1#!./miniperl 2 3=head1 NAME 4 5xsubpp - compiler to convert Perl XS code into C code 6 7=head1 SYNOPSIS 8 9B<xsubpp> [B<-v>] [B<-C++>] [B<-csuffix csuffix>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-nooptimize>] [B<-typemap typemap>] ... file.xs 10 11=head1 DESCRIPTION 12 13This compiler is typically run by the makefiles created by L<ExtUtils::MakeMaker>. 14 15I<xsubpp> will compile XS code into C code by embedding the constructs 16necessary to let C functions manipulate Perl values and creates the glue 17necessary to let Perl access those functions. The compiler uses typemaps to 18determine how to map C function parameters and variables to Perl values. 19 20The compiler will search for typemap files called I<typemap>. It will use 21the following search path to find default typemaps, with the rightmost 22typemap taking precedence. 23 24 ../../../typemap:../../typemap:../typemap:typemap 25 26=head1 OPTIONS 27 28Note that the C<XSOPT> MakeMaker option may be used to add these options to 29any makefiles generated by MakeMaker. 30 31=over 5 32 33=item B<-C++> 34 35Adds ``extern "C"'' to the C code. 36 37=item B<-csuffix csuffix> 38 39Set the suffix used for the generated C or C++ code. Defaults to '.c' 40(even with B<-C++>), but some platforms might want to have e.g. '.cpp'. 41Don't forget the '.' from the front. 42 43=item B<-hiertype> 44 45Retains '::' in type names so that C++ hierachical types can be mapped. 46 47=item B<-except> 48 49Adds exception handling stubs to the C code. 50 51=item B<-typemap typemap> 52 53Indicates that a user-supplied typemap should take precedence over the 54default typemaps. This option may be used multiple times, with the last 55typemap having the highest precedence. 56 57=item B<-v> 58 59Prints the I<xsubpp> version number to standard output, then exits. 60 61=item B<-prototypes> 62 63By default I<xsubpp> will not automatically generate prototype code for 64all xsubs. This flag will enable prototypes. 65 66=item B<-noversioncheck> 67 68Disables the run time test that determines if the object file (derived 69from the C<.xs> file) and the C<.pm> files have the same version 70number. 71 72=item B<-nolinenumbers> 73 74Prevents the inclusion of `#line' directives in the output. 75 76=item B<-nooptimize> 77 78Disables certain optimizations. The only optimization that is currently 79affected is the use of I<target>s by the output C code (see L<perlguts>). 80This may significantly slow down the generated code, but this is the way 81B<xsubpp> of 5.005 and earlier operated. 82 83=item B<-noinout> 84 85Disable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST> declarations. 86 87=item B<-noargtypes> 88 89Disable recognition of ANSI-like descriptions of function signature. 90 91=back 92 93=head1 ENVIRONMENT 94 95No environment variables are used. 96 97=head1 AUTHOR 98 99Larry Wall 100 101=head1 MODIFICATION HISTORY 102 103See the file F<changes.pod>. 104 105=head1 SEE ALSO 106 107perl(1), perlxs(1), perlxstut(1) 108 109=cut 110 111require 5.002; 112use Cwd; 113use vars qw($cplusplus $hiertype); 114use vars '%v'; 115 116use Config; 117 118sub Q ; 119 120# Global Constants 121 122$XSUBPP_version = "1.9508"; 123 124my ($Is_VMS, $SymSet); 125if ($^O eq 'VMS') { 126 $Is_VMS = 1; 127 # Establish set of global symbols with max length 28, since xsubpp 128 # will later add the 'XS_' prefix. 129 require ExtUtils::XSSymSet; 130 $SymSet = new ExtUtils::XSSymSet 28; 131} 132 133$FH = 'File0000' ; 134 135$usage = "Usage: xsubpp [-v] [-C++] [-csuffix csuffix] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-nooptimize] [-noinout] [-noargtypes] [-s pattern] [-typemap typemap]... file.xs\n"; 136 137$proto_re = "[" . quotemeta('\$%&*@;[]') . "]" ; 138 139$except = ""; 140$WantPrototypes = -1 ; 141$WantVersionChk = 1 ; 142$ProtoUsed = 0 ; 143$WantLineNumbers = 1 ; 144$WantOptimize = 1 ; 145$Overload = 0; 146$Fallback = 'PL_sv_undef'; 147 148my $process_inout = 1; 149my $process_argtypes = 1; 150my $csuffix = '.c'; 151 152SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) { 153 $flag = shift @ARGV; 154 $flag =~ s/^-// ; 155 $spat = quotemeta shift, next SWITCH if $flag eq 's'; 156 $cplusplus = 1, next SWITCH if $flag eq 'C++'; 157 $csuffix = shift, next SWITCH if $flag eq 'csuffix'; 158 $hiertype = 1, next SWITCH if $flag eq 'hiertype'; 159 $WantPrototypes = 0, next SWITCH if $flag eq 'noprototypes'; 160 $WantPrototypes = 1, next SWITCH if $flag eq 'prototypes'; 161 $WantVersionChk = 0, next SWITCH if $flag eq 'noversioncheck'; 162 $WantVersionChk = 1, next SWITCH if $flag eq 'versioncheck'; 163 # XXX left this in for compat 164 next SWITCH if $flag eq 'object_capi'; 165 $except = " TRY", next SWITCH if $flag eq 'except'; 166 push(@tm,shift), next SWITCH if $flag eq 'typemap'; 167 $WantLineNumbers = 0, next SWITCH if $flag eq 'nolinenumbers'; 168 $WantLineNumbers = 1, next SWITCH if $flag eq 'linenumbers'; 169 $WantOptimize = 0, next SWITCH if $flag eq 'nooptimize'; 170 $WantOptimize = 1, next SWITCH if $flag eq 'optimize'; 171 $process_inout = 0, next SWITCH if $flag eq 'noinout'; 172 $process_inout = 1, next SWITCH if $flag eq 'inout'; 173 $process_argtypes = 0, next SWITCH if $flag eq 'noargtypes'; 174 $process_argtypes = 1, next SWITCH if $flag eq 'argtypes'; 175 (print "xsubpp version $XSUBPP_version\n"), exit 176 if $flag eq 'v'; 177 die $usage; 178} 179if ($WantPrototypes == -1) 180 { $WantPrototypes = 0} 181else 182 { $ProtoUsed = 1 } 183 184 185@ARGV == 1 or die $usage; 186($dir, $filename) = $ARGV[0] =~ m#(.*)/(.*)# 187 or ($dir, $filename) = $ARGV[0] =~ m#(.*)\\(.*)# 188 or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)# 189 or ($dir, $filename) = ('.', $ARGV[0]); 190chdir($dir); 191$pwd = cwd(); 192 193++ $IncludedFiles{$ARGV[0]} ; 194 195my(@XSStack) = ({type => 'none'}); # Stack of conditionals and INCLUDEs 196my($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA"); 197 198 199sub TrimWhitespace 200{ 201 $_[0] =~ s/^\s+|\s+$//go ; 202} 203 204sub TidyType 205{ 206 local ($_) = @_ ; 207 208 # rationalise any '*' by joining them into bunches and removing whitespace 209 s#\s*(\*+)\s*#$1#g; 210 s#(\*+)# $1 #g ; 211 212 # change multiple whitespace into a single space 213 s/\s+/ /g ; 214 215 # trim leading & trailing whitespace 216 TrimWhitespace($_) ; 217 218 $_ ; 219} 220 221$typemap = shift @ARGV; 222foreach $typemap (@tm) { 223 die "Can't find $typemap in $pwd\n" unless -r $typemap; 224} 225unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap 226 ../../lib/ExtUtils/typemap ../../../typemap ../../typemap 227 ../typemap typemap); 228foreach $typemap (@tm) { 229 next unless -f $typemap ; 230 # skip directories, binary files etc. 231 warn("Warning: ignoring non-text typemap file '$typemap'\n"), next 232 unless -T $typemap ; 233 open(TYPEMAP, $typemap) 234 or warn ("Warning: could not open typemap file '$typemap': $!\n"), next; 235 $mode = 'Typemap'; 236 $junk = "" ; 237 $current = \$junk; 238 while (<TYPEMAP>) { 239 next if /^\s*#/; 240 my $line_no = $. + 1; 241 if (/^INPUT\s*$/) { $mode = 'Input'; $current = \$junk; next; } 242 if (/^OUTPUT\s*$/) { $mode = 'Output'; $current = \$junk; next; } 243 if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk; next; } 244 if ($mode eq 'Typemap') { 245 chomp; 246 my $line = $_ ; 247 TrimWhitespace($_) ; 248 # skip blank lines and comment lines 249 next if /^$/ or /^#/ ; 250 my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or 251 warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next; 252 $type = TidyType($type) ; 253 $type_kind{$type} = $kind ; 254 # prototype defaults to '$' 255 $proto = "\$" unless $proto ; 256 warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n") 257 unless ValidProtoString($proto) ; 258 $proto_letter{$type} = C_string($proto) ; 259 } 260 elsif (/^\s/) { 261 $$current .= $_; 262 } 263 elsif ($mode eq 'Input') { 264 s/\s+$//; 265 $input_expr{$_} = ''; 266 $current = \$input_expr{$_}; 267 } 268 else { 269 s/\s+$//; 270 $output_expr{$_} = ''; 271 $current = \$output_expr{$_}; 272 } 273 } 274 close(TYPEMAP); 275} 276 277foreach $key (keys %input_expr) { 278 $input_expr{$key} =~ s/;*\s+\z//; 279} 280 281$bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*]; # ()-balanced 282$cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?]; # Optional (SV*) cast 283$size = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn) 284 285foreach $key (keys %output_expr) { 286 use re 'eval'; 287 288 my ($t, $with_size, $arg, $sarg) = 289 ($output_expr{$key} =~ 290 m[^ \s+ sv_set ( [iunp] ) v (n)? # Type, is_setpvn 291 \s* \( \s* $cast \$arg \s* , 292 \s* ( (??{ $bal }) ) # Set from 293 ( (??{ $size }) )? # Possible sizeof set-from 294 \) \s* ; \s* $ 295 ]x); 296 $targetable{$key} = [$t, $with_size, $arg, $sarg] if $t; 297} 298 299$END = "!End!\n\n"; # "impossible" keyword (multiple newline) 300 301# Match an XS keyword 302$BLOCK_re= '\s*(' . join('|', qw( 303 REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT 304 CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE 305 SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD FALLBACK 306 )) . "|$END)\\s*:"; 307 308# Input: ($_, @line) == unparsed input. 309# Output: ($_, @line) == (rest of line, following lines). 310# Return: the matched keyword if found, otherwise 0 311sub check_keyword { 312 $_ = shift(@line) while !/\S/ && @line; 313 s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2; 314} 315 316my ($C_group_rex, $C_arg); 317# Group in C (no support for comments or literals) 318$C_group_rex = qr/ [({\[] 319 (?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )* 320 [)}\]] /x ; 321# Chunk in C without comma at toplevel (no comments): 322$C_arg = qr/ (?: (?> [^()\[\]{},"']+ ) 323 | (??{ $C_group_rex }) 324 | " (?: (?> [^\\"]+ ) 325 | \\. 326 )* " # String literal 327 | ' (?: (?> [^\\']+ ) | \\. )* ' # Char literal 328 )* /xs; 329 330if ($WantLineNumbers) { 331 { 332 package xsubpp::counter; 333 sub TIEHANDLE { 334 my ($class, $cfile) = @_; 335 my $buf = ""; 336 $SECTION_END_MARKER = "#line --- \"$cfile\""; 337 $line_no = 1; 338 bless \$buf; 339 } 340 341 sub PRINT { 342 my $self = shift; 343 for (@_) { 344 $$self .= $_; 345 while ($$self =~ s/^([^\n]*\n)//) { 346 my $line = $1; 347 ++ $line_no; 348 $line =~ s|^\#line\s+---(?=\s)|#line $line_no|; 349 print STDOUT $line; 350 } 351 } 352 } 353 354 sub PRINTF { 355 my $self = shift; 356 my $fmt = shift; 357 $self->PRINT(sprintf($fmt, @_)); 358 } 359 360 sub DESTROY { 361 # Not necessary if we're careful to end with a "\n" 362 my $self = shift; 363 print STDOUT $$self; 364 } 365 } 366 367 my $cfile = $filename; 368 $cfile =~ s/\.xs$/$csuffix/i or $cfile .= $csuffix; 369 tie(*PSEUDO_STDOUT, 'xsubpp::counter', $cfile); 370 select PSEUDO_STDOUT; 371} 372 373sub print_section { 374 # the "do" is required for right semantics 375 do { $_ = shift(@line) } while !/\S/ && @line; 376 377 print("#line ", $line_no[@line_no - @line -1], " \"$filename\"\n") 378 if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/; 379 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) { 380 print "$_\n"; 381 } 382 print "$xsubpp::counter::SECTION_END_MARKER\n" if $WantLineNumbers; 383} 384 385sub merge_section { 386 my $in = ''; 387 388 while (!/\S/ && @line) { 389 $_ = shift(@line); 390 } 391 392 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) { 393 $in .= "$_\n"; 394 } 395 chomp $in; 396 return $in; 397} 398 399sub process_keyword($) 400{ 401 my($pattern) = @_ ; 402 my $kwd ; 403 404 &{"${kwd}_handler"}() 405 while $kwd = check_keyword($pattern) ; 406} 407 408sub CASE_handler { 409 blurt ("Error: `CASE:' after unconditional `CASE:'") 410 if $condnum && $cond eq ''; 411 $cond = $_; 412 TrimWhitespace($cond); 413 print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n"); 414 $_ = '' ; 415} 416 417sub INPUT_handler { 418 for (; !/^$BLOCK_re/o; $_ = shift(@line)) { 419 last if /^\s*NOT_IMPLEMENTED_YET/; 420 next unless /\S/; # skip blank lines 421 422 TrimWhitespace($_) ; 423 my $line = $_ ; 424 425 # remove trailing semicolon if no initialisation 426 s/\s*;$//g unless /[=;+].*\S/ ; 427 428 # Process the length(foo) declarations 429 if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) { 430 print "\tSTRLEN\tSTRLEN_length_of_$2;\n"; 431 $lengthof{$2} = $name; 432 # $islengthof{$name} = $1; 433 $deferred .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;"; 434 } 435 436 # check for optional initialisation code 437 my $var_init = '' ; 438 $var_init = $1 if s/\s*([=;+].*)$//s ; 439 $var_init =~ s/"/\\"/g; 440 441 s/\s+/ /g; 442 my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s 443 or blurt("Error: invalid argument declaration '$line'"), next; 444 445 # Check for duplicate definitions 446 blurt ("Error: duplicate definition of argument '$var_name' ignored"), next 447 if $arg_list{$var_name}++ 448 or defined $argtype_seen{$var_name} and not $processing_arg_with_types; 449 450 $thisdone |= $var_name eq "THIS"; 451 $retvaldone |= $var_name eq "RETVAL"; 452 $var_types{$var_name} = $var_type; 453 # XXXX This check is a safeguard against the unfinished conversion of 454 # generate_init(). When generate_init() is fixed, 455 # one can use 2-args map_type() unconditionally. 456 if ($var_type =~ / \( \s* \* \s* \) /x) { 457 # Function pointers are not yet supported with &output_init! 458 print "\t" . &map_type($var_type, $var_name); 459 $name_printed = 1; 460 } else { 461 print "\t" . &map_type($var_type); 462 $name_printed = 0; 463 } 464 $var_num = $args_match{$var_name}; 465 466 $proto_arg[$var_num] = ProtoString($var_type) 467 if $var_num ; 468 $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr; 469 if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/ 470 or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/ 471 and $var_init !~ /\S/) { 472 if ($name_printed) { 473 print ";\n"; 474 } else { 475 print "\t$var_name;\n"; 476 } 477 } elsif ($var_init =~ /\S/) { 478 &output_init($var_type, $var_num, $var_name, $var_init, $name_printed); 479 } elsif ($var_num) { 480 # generate initialization code 481 &generate_init($var_type, $var_num, $var_name, $name_printed); 482 } else { 483 print ";\n"; 484 } 485 } 486} 487 488sub OUTPUT_handler { 489 for (; !/^$BLOCK_re/o; $_ = shift(@line)) { 490 next unless /\S/; 491 if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) { 492 $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0); 493 next; 494 } 495 my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ; 496 blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next 497 if $outargs{$outarg} ++ ; 498 if (!$gotRETVAL and $outarg eq 'RETVAL') { 499 # deal with RETVAL last 500 $RETVAL_code = $outcode ; 501 $gotRETVAL = 1 ; 502 next ; 503 } 504 blurt ("Error: OUTPUT $outarg not an argument"), next 505 unless defined($args_match{$outarg}); 506 blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next 507 unless defined $var_types{$outarg} ; 508 $var_num = $args_match{$outarg}; 509 if ($outcode) { 510 print "\t$outcode\n"; 511 print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic; 512 } else { 513 &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic); 514 } 515 delete $in_out{$outarg} # No need to auto-OUTPUT 516 if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/; 517 } 518} 519 520sub C_ARGS_handler() { 521 my $in = merge_section(); 522 523 TrimWhitespace($in); 524 $func_args = $in; 525} 526 527sub INTERFACE_MACRO_handler() { 528 my $in = merge_section(); 529 530 TrimWhitespace($in); 531 if ($in =~ /\s/) { # two 532 ($interface_macro, $interface_macro_set) = split ' ', $in; 533 } else { 534 $interface_macro = $in; 535 $interface_macro_set = 'UNKNOWN_CVT'; # catch later 536 } 537 $interface = 1; # local 538 $Interfaces = 1; # global 539} 540 541sub INTERFACE_handler() { 542 my $in = merge_section(); 543 544 TrimWhitespace($in); 545 546 foreach (split /[\s,]+/, $in) { 547 $Interfaces{$_} = $_; 548 } 549 print Q<<"EOF"; 550# XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr); 551EOF 552 $interface = 1; # local 553 $Interfaces = 1; # global 554} 555 556sub CLEANUP_handler() { print_section() } 557sub PREINIT_handler() { print_section() } 558sub POSTCALL_handler() { print_section() } 559sub INIT_handler() { print_section() } 560 561sub GetAliases 562{ 563 my ($line) = @_ ; 564 my ($orig) = $line ; 565 my ($alias) ; 566 my ($value) ; 567 568 # Parse alias definitions 569 # format is 570 # alias = value alias = value ... 571 572 while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) { 573 $alias = $1 ; 574 $orig_alias = $alias ; 575 $value = $2 ; 576 577 # check for optional package definition in the alias 578 $alias = $Packprefix . $alias if $alias !~ /::/ ; 579 580 # check for duplicate alias name & duplicate value 581 Warn("Warning: Ignoring duplicate alias '$orig_alias'") 582 if defined $XsubAliases{$alias} ; 583 584 Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values") 585 if $XsubAliasValues{$value} ; 586 587 $XsubAliases = 1; 588 $XsubAliases{$alias} = $value ; 589 $XsubAliasValues{$value} = $orig_alias ; 590 } 591 592 blurt("Error: Cannot parse ALIAS definitions from '$orig'") 593 if $line ; 594} 595 596sub ATTRS_handler () 597{ 598 for (; !/^$BLOCK_re/o; $_ = shift(@line)) { 599 next unless /\S/; 600 TrimWhitespace($_) ; 601 push @Attributes, $_; 602 } 603} 604 605sub ALIAS_handler () 606{ 607 for (; !/^$BLOCK_re/o; $_ = shift(@line)) { 608 next unless /\S/; 609 TrimWhitespace($_) ; 610 GetAliases($_) if $_ ; 611 } 612} 613 614sub OVERLOAD_handler() 615{ 616 for (; !/^$BLOCK_re/o; $_ = shift(@line)) { 617 next unless /\S/; 618 TrimWhitespace($_) ; 619 while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) { 620 $Overload = 1 unless $Overload; 621 my $overload = "$Package\::(".$1 ; 622 push(@InitFileCode, 623 " newXS(\"$overload\", XS_$Full_func_name, file$proto);\n"); 624 } 625 } 626 627} 628 629sub FALLBACK_handler() 630{ 631 # the rest of the current line should contain either TRUE, 632 # FALSE or UNDEF 633 634 TrimWhitespace($_) ; 635 my %map = ( 636 TRUE => "PL_sv_yes", 1 => "PL_sv_yes", 637 FALSE => "PL_sv_no", 0 => "PL_sv_no", 638 UNDEF => "PL_sv_undef", 639 ) ; 640 641 # check for valid FALLBACK value 642 death ("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_} ; 643 644 $Fallback = $map{uc $_} ; 645} 646 647sub REQUIRE_handler () 648{ 649 # the rest of the current line should contain a version number 650 my ($Ver) = $_ ; 651 652 TrimWhitespace($Ver) ; 653 654 death ("Error: REQUIRE expects a version number") 655 unless $Ver ; 656 657 # check that the version number is of the form n.n 658 death ("Error: REQUIRE: expected a number, got '$Ver'") 659 unless $Ver =~ /^\d+(\.\d*)?/ ; 660 661 death ("Error: xsubpp $Ver (or better) required--this is only $XSUBPP_version.") 662 unless $XSUBPP_version >= $Ver ; 663} 664 665sub VERSIONCHECK_handler () 666{ 667 # the rest of the current line should contain either ENABLE or 668 # DISABLE 669 670 TrimWhitespace($_) ; 671 672 # check for ENABLE/DISABLE 673 death ("Error: VERSIONCHECK: ENABLE/DISABLE") 674 unless /^(ENABLE|DISABLE)/i ; 675 676 $WantVersionChk = 1 if $1 eq 'ENABLE' ; 677 $WantVersionChk = 0 if $1 eq 'DISABLE' ; 678 679} 680 681sub PROTOTYPE_handler () 682{ 683 my $specified ; 684 685 death("Error: Only 1 PROTOTYPE definition allowed per xsub") 686 if $proto_in_this_xsub ++ ; 687 688 for (; !/^$BLOCK_re/o; $_ = shift(@line)) { 689 next unless /\S/; 690 $specified = 1 ; 691 TrimWhitespace($_) ; 692 if ($_ eq 'DISABLE') { 693 $ProtoThisXSUB = 0 694 } 695 elsif ($_ eq 'ENABLE') { 696 $ProtoThisXSUB = 1 697 } 698 else { 699 # remove any whitespace 700 s/\s+//g ; 701 death("Error: Invalid prototype '$_'") 702 unless ValidProtoString($_) ; 703 $ProtoThisXSUB = C_string($_) ; 704 } 705 } 706 707 # If no prototype specified, then assume empty prototype "" 708 $ProtoThisXSUB = 2 unless $specified ; 709 710 $ProtoUsed = 1 ; 711 712} 713 714sub SCOPE_handler () 715{ 716 death("Error: Only 1 SCOPE declaration allowed per xsub") 717 if $scope_in_this_xsub ++ ; 718 719 for (; !/^$BLOCK_re/o; $_ = shift(@line)) { 720 next unless /\S/; 721 TrimWhitespace($_) ; 722 if ($_ =~ /^DISABLE/i) { 723 $ScopeThisXSUB = 0 724 } 725 elsif ($_ =~ /^ENABLE/i) { 726 $ScopeThisXSUB = 1 727 } 728 } 729 730} 731 732sub PROTOTYPES_handler () 733{ 734 # the rest of the current line should contain either ENABLE or 735 # DISABLE 736 737 TrimWhitespace($_) ; 738 739 # check for ENABLE/DISABLE 740 death ("Error: PROTOTYPES: ENABLE/DISABLE") 741 unless /^(ENABLE|DISABLE)/i ; 742 743 $WantPrototypes = 1 if $1 eq 'ENABLE' ; 744 $WantPrototypes = 0 if $1 eq 'DISABLE' ; 745 $ProtoUsed = 1 ; 746 747} 748 749sub INCLUDE_handler () 750{ 751 # the rest of the current line should contain a valid filename 752 753 TrimWhitespace($_) ; 754 755 death("INCLUDE: filename missing") 756 unless $_ ; 757 758 death("INCLUDE: output pipe is illegal") 759 if /^\s*\|/ ; 760 761 # simple minded recursion detector 762 death("INCLUDE loop detected") 763 if $IncludedFiles{$_} ; 764 765 ++ $IncludedFiles{$_} unless /\|\s*$/ ; 766 767 # Save the current file context. 768 push(@XSStack, { 769 type => 'file', 770 LastLine => $lastline, 771 LastLineNo => $lastline_no, 772 Line => \@line, 773 LineNo => \@line_no, 774 Filename => $filename, 775 Handle => $FH, 776 }) ; 777 778 ++ $FH ; 779 780 # open the new file 781 open ($FH, "$_") or death("Cannot open '$_': $!") ; 782 783 print Q<<"EOF" ; 784# 785#/* INCLUDE: Including '$_' from '$filename' */ 786# 787EOF 788 789 $filename = $_ ; 790 791 # Prime the pump by reading the first 792 # non-blank line 793 794 # skip leading blank lines 795 while (<$FH>) { 796 last unless /^\s*$/ ; 797 } 798 799 $lastline = $_ ; 800 $lastline_no = $. ; 801 802} 803 804sub PopFile() 805{ 806 return 0 unless $XSStack[-1]{type} eq 'file' ; 807 808 my $data = pop @XSStack ; 809 my $ThisFile = $filename ; 810 my $isPipe = ($filename =~ /\|\s*$/) ; 811 812 -- $IncludedFiles{$filename} 813 unless $isPipe ; 814 815 close $FH ; 816 817 $FH = $data->{Handle} ; 818 $filename = $data->{Filename} ; 819 $lastline = $data->{LastLine} ; 820 $lastline_no = $data->{LastLineNo} ; 821 @line = @{ $data->{Line} } ; 822 @line_no = @{ $data->{LineNo} } ; 823 824 if ($isPipe and $? ) { 825 -- $lastline_no ; 826 print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n" ; 827 exit 1 ; 828 } 829 830 print Q<<"EOF" ; 831# 832#/* INCLUDE: Returning to '$filename' from '$ThisFile' */ 833# 834EOF 835 836 return 1 ; 837} 838 839sub ValidProtoString ($) 840{ 841 my($string) = @_ ; 842 843 if ( $string =~ /^$proto_re+$/ ) { 844 return $string ; 845 } 846 847 return 0 ; 848} 849 850sub C_string ($) 851{ 852 my($string) = @_ ; 853 854 $string =~ s[\\][\\\\]g ; 855 $string ; 856} 857 858sub ProtoString ($) 859{ 860 my ($type) = @_ ; 861 862 $proto_letter{$type} or "\$" ; 863} 864 865sub check_cpp { 866 my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line); 867 if (@cpp) { 868 my ($cpp, $cpplevel); 869 for $cpp (@cpp) { 870 if ($cpp =~ /^\#\s*if/) { 871 $cpplevel++; 872 } elsif (!$cpplevel) { 873 Warn("Warning: #else/elif/endif without #if in this function"); 874 print STDERR " (precede it with a blank line if the matching #if is outside the function)\n" 875 if $XSStack[-1]{type} eq 'if'; 876 return; 877 } elsif ($cpp =~ /^\#\s*endif/) { 878 $cpplevel--; 879 } 880 } 881 Warn("Warning: #if without #endif in this function") if $cpplevel; 882 } 883} 884 885 886sub Q { 887 my($text) = @_; 888 $text =~ s/^#//gm; 889 $text =~ s/\[\[/{/g; 890 $text =~ s/\]\]/}/g; 891 $text; 892} 893 894open($FH, $filename) or die "cannot open $filename: $!\n"; 895 896# Identify the version of xsubpp used 897print <<EOM ; 898/* 899 * This file was generated automatically by xsubpp version $XSUBPP_version from the 900 * contents of $filename. Do not edit this file, edit $filename instead. 901 * 902 * ANY CHANGES MADE HERE WILL BE LOST! 903 * 904 */ 905 906EOM 907 908 909print("#line 1 \"$filename\"\n") 910 if $WantLineNumbers; 911 912firstmodule: 913while (<$FH>) { 914 if (/^=/) { 915 my $podstartline = $.; 916 do { 917 if (/^=cut\s*$/) { 918 # We can't just write out a /* */ comment, as our embedded 919 # POD might itself be in a comment. We can't put a /**/ 920 # comment inside #if 0, as the C standard says that the source 921 # file is decomposed into preprocessing characters in the stage 922 # before preprocessing commands are executed. 923 # I don't want to leave the text as barewords, because the spec 924 # isn't clear whether macros are expanded before or after 925 # preprocessing commands are executed, and someone pathological 926 # may just have defined one of the 3 words as a macro that does 927 # something strange. Multiline strings are illegal in C, so 928 # the "" we write must be a string literal. And they aren't 929 # concatenated until 2 steps later, so we are safe. 930 print("#if 0\n \"Skipped embedded POD.\"\n#endif\n"); 931 printf("#line %d \"$filename\"\n", $. + 1) 932 if $WantLineNumbers; 933 next firstmodule 934 } 935 936 } while (<$FH>); 937 # At this point $. is at end of file so die won't state the start 938 # of the problem, and as we haven't yet read any lines &death won't 939 # show the correct line in the message either. 940 die ("Error: Unterminated pod in $filename, line $podstartline\n") 941 unless $lastline; 942 } 943 last if ($Module, $Package, $Prefix) = 944 /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/; 945 946 print $_; 947} 948&Exit unless defined $_; 949 950print "$xsubpp::counter::SECTION_END_MARKER\n" if $WantLineNumbers; 951 952$lastline = $_; 953$lastline_no = $.; 954 955# Read next xsub into @line from ($lastline, <$FH>). 956sub fetch_para { 957 # parse paragraph 958 death ("Error: Unterminated `#if/#ifdef/#ifndef'") 959 if !defined $lastline && $XSStack[-1]{type} eq 'if'; 960 @line = (); 961 @line_no = () ; 962 return PopFile() if !defined $lastline; 963 964 if ($lastline =~ 965 /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) { 966 $Module = $1; 967 $Package = defined($2) ? $2 : ''; # keep -w happy 968 $Prefix = defined($3) ? $3 : ''; # keep -w happy 969 $Prefix = quotemeta $Prefix ; 970 ($Module_cname = $Module) =~ s/\W/_/g; 971 ($Packid = $Package) =~ tr/:/_/; 972 $Packprefix = $Package; 973 $Packprefix .= "::" if $Packprefix ne ""; 974 $lastline = ""; 975 } 976 977 for(;;) { 978 # Skip embedded PODs 979 while ($lastline =~ /^=/) { 980 while ($lastline = <$FH>) { 981 last if ($lastline =~ /^=cut\s*$/); 982 } 983 death ("Error: Unterminated pod") unless $lastline; 984 $lastline = <$FH>; 985 chomp $lastline; 986 $lastline =~ s/^\s+$//; 987 } 988 if ($lastline !~ /^\s*#/ || 989 # CPP directives: 990 # ANSI: if ifdef ifndef elif else endif define undef 991 # line error pragma 992 # gcc: warning include_next 993 # obj-c: import 994 # others: ident (gcc notes that some cpps have this one) 995 $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) { 996 last if $lastline =~ /^\S/ && @line && $line[-1] eq ""; 997 push(@line, $lastline); 998 push(@line_no, $lastline_no) ; 999 } 1000 1001 # Read next line and continuation lines 1002 last unless defined($lastline = <$FH>); 1003 $lastline_no = $.; 1004 my $tmp_line; 1005 $lastline .= $tmp_line 1006 while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>)); 1007 1008 chomp $lastline; 1009 $lastline =~ s/^\s+$//; 1010 } 1011 pop(@line), pop(@line_no) while @line && $line[-1] eq ""; 1012 1; 1013} 1014 1015PARAGRAPH: 1016while (fetch_para()) { 1017 # Print initial preprocessor statements and blank lines 1018 while (@line && $line[0] !~ /^[^\#]/) { 1019 my $line = shift(@line); 1020 print $line, "\n"; 1021 next unless $line =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/; 1022 my $statement = $+; 1023 if ($statement eq 'if') { 1024 $XSS_work_idx = @XSStack; 1025 push(@XSStack, {type => 'if'}); 1026 } else { 1027 death ("Error: `$statement' with no matching `if'") 1028 if $XSStack[-1]{type} ne 'if'; 1029 if ($XSStack[-1]{varname}) { 1030 push(@InitFileCode, "#endif\n"); 1031 push(@BootCode, "#endif"); 1032 } 1033 1034 my(@fns) = keys %{$XSStack[-1]{functions}}; 1035 if ($statement ne 'endif') { 1036 # Hide the functions defined in other #if branches, and reset. 1037 @{$XSStack[-1]{other_functions}}{@fns} = (1) x @fns; 1038 @{$XSStack[-1]}{qw(varname functions)} = ('', {}); 1039 } else { 1040 my($tmp) = pop(@XSStack); 1041 0 while (--$XSS_work_idx 1042 && $XSStack[$XSS_work_idx]{type} ne 'if'); 1043 # Keep all new defined functions 1044 push(@fns, keys %{$tmp->{other_functions}}); 1045 @{$XSStack[$XSS_work_idx]{functions}}{@fns} = (1) x @fns; 1046 } 1047 } 1048 } 1049 1050 next PARAGRAPH unless @line; 1051 1052 if ($XSS_work_idx && !$XSStack[$XSS_work_idx]{varname}) { 1053 # We are inside an #if, but have not yet #defined its xsubpp variable. 1054 print "#define $cpp_next_tmp 1\n\n"; 1055 push(@InitFileCode, "#if $cpp_next_tmp\n"); 1056 push(@BootCode, "#if $cpp_next_tmp"); 1057 $XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++; 1058 } 1059 1060 death ("Code is not inside a function" 1061 ." (maybe last function was ended by a blank line " 1062 ." followed by a statement on column one?)") 1063 if $line[0] =~ /^\s/; 1064 1065 # initialize info arrays 1066 undef(%args_match); 1067 undef(%var_types); 1068 undef(%defaults); 1069 undef($class); 1070 undef($externC); 1071 undef($static); 1072 undef($elipsis); 1073 undef($wantRETVAL) ; 1074 undef($RETVAL_no_return) ; 1075 undef(%arg_list) ; 1076 undef(@proto_arg) ; 1077 undef(@fake_INPUT_pre) ; # For length(s) generated variables 1078 undef(@fake_INPUT) ; 1079 undef($processing_arg_with_types) ; 1080 undef(%argtype_seen) ; 1081 undef(@outlist) ; 1082 undef(%in_out) ; 1083 undef(%lengthof) ; 1084 # undef(%islengthof) ; 1085 undef($proto_in_this_xsub) ; 1086 undef($scope_in_this_xsub) ; 1087 undef($interface); 1088 undef($prepush_done); 1089 $interface_macro = 'XSINTERFACE_FUNC' ; 1090 $interface_macro_set = 'XSINTERFACE_FUNC_SET' ; 1091 $ProtoThisXSUB = $WantPrototypes ; 1092 $ScopeThisXSUB = 0; 1093 $xsreturn = 0; 1094 1095 $_ = shift(@line); 1096 while ($kwd = check_keyword("REQUIRE|PROTOTYPES|FALLBACK|VERSIONCHECK|INCLUDE")) { 1097 &{"${kwd}_handler"}() ; 1098 next PARAGRAPH unless @line ; 1099 $_ = shift(@line); 1100 } 1101 1102 if (check_keyword("BOOT")) { 1103 &check_cpp; 1104 push (@BootCode, "#line $line_no[@line_no - @line] \"$filename\"") 1105 if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/; 1106 push (@BootCode, @line, "") ; 1107 next PARAGRAPH ; 1108 } 1109 1110 1111 # extract return type, function name and arguments 1112 ($ret_type) = TidyType($_); 1113 $RETVAL_no_return = 1 if $ret_type =~ s/^NO_OUTPUT\s+//; 1114 1115 # Allow one-line ANSI-like declaration 1116 unshift @line, $2 1117 if $process_argtypes 1118 and $ret_type =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s; 1119 1120 # a function definition needs at least 2 lines 1121 blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH 1122 unless @line ; 1123 1124 $externC = 1 if $ret_type =~ s/^extern "C"\s+//; 1125 $static = 1 if $ret_type =~ s/^static\s+//; 1126 1127 $func_header = shift(@line); 1128 blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH 1129 unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*(;\s*)?$/s; 1130 1131 ($class, $func_name, $orig_args) = ($1, $2, $3) ; 1132 $class = "$4 $class" if $4; 1133 ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/; 1134 ($clean_func_name = $func_name) =~ s/^$Prefix//; 1135 $Full_func_name = "${Packid}_$clean_func_name"; 1136 if ($Is_VMS) { $Full_func_name = $SymSet->addsym($Full_func_name); } 1137 1138 # Check for duplicate function definition 1139 for $tmp (@XSStack) { 1140 next unless defined $tmp->{functions}{$Full_func_name}; 1141 Warn("Warning: duplicate function definition '$clean_func_name' detected"); 1142 last; 1143 } 1144 $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ; 1145 %XsubAliases = %XsubAliasValues = %Interfaces = @Attributes = (); 1146 $DoSetMagic = 1; 1147 1148 $orig_args =~ s/\\\s*/ /g; # process line continuations 1149 1150 my %only_C_inlist; # Not in the signature of Perl function 1151 if ($process_argtypes and $orig_args =~ /\S/) { 1152 my $args = "$orig_args ,"; 1153 if ($args =~ /^( (??{ $C_arg }) , )* $ /x) { 1154 @args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg); 1155 for ( @args ) { 1156 s/^\s+//; 1157 s/\s+$//; 1158 my ($arg, $default) = / ( [^=]* ) ( (?: = .* )? ) /x; 1159 my ($pre, $name) = ($arg =~ /(.*?) \s* 1160 \b ( \w+ | length\( \s*\w+\s* \) ) 1161 \s* $ /x); 1162 next unless length $pre; 1163 my $out_type; 1164 my $inout_var; 1165 if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//) { 1166 my $type = $1; 1167 $out_type = $type if $type ne 'IN'; 1168 $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//; 1169 $pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//; 1170 } 1171 my $islength; 1172 if ($name =~ /^length\( \s* (\w+) \s* \)\z/x) { 1173 $name = "XSauto_length_of_$1"; 1174 $islength = 1; 1175 die "Default value on length() argument: `$_'" 1176 if length $default; 1177 } 1178 if (length $pre or $islength) { # Has a type 1179 if ($islength) { 1180 push @fake_INPUT_pre, $arg; 1181 } else { 1182 push @fake_INPUT, $arg; 1183 } 1184 # warn "pushing '$arg'\n"; 1185 $argtype_seen{$name}++; 1186 $_ = "$name$default"; # Assigns to @args 1187 } 1188 $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST" or $islength; 1189 push @outlist, $name if $out_type =~ /OUTLIST$/; 1190 $in_out{$name} = $out_type if $out_type; 1191 } 1192 } else { 1193 @args = split(/\s*,\s*/, $orig_args); 1194 Warn("Warning: cannot parse argument list '$orig_args', fallback to split"); 1195 } 1196 } else { 1197 @args = split(/\s*,\s*/, $orig_args); 1198 for (@args) { 1199 if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\s+//) { 1200 my $out_type = $1; 1201 next if $out_type eq 'IN'; 1202 $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST"; 1203 push @outlist, $name if $out_type =~ /OUTLIST$/; 1204 $in_out{$_} = $out_type; 1205 } 1206 } 1207 } 1208 if (defined($class)) { 1209 my $arg0 = ((defined($static) or $func_name eq 'new') 1210 ? "CLASS" : "THIS"); 1211 unshift(@args, $arg0); 1212 ($report_args = "$arg0, $report_args") =~ s/^\w+, $/$arg0/; 1213 } 1214 my $extra_args = 0; 1215 @args_num = (); 1216 $num_args = 0; 1217 my $report_args = ''; 1218 foreach $i (0 .. $#args) { 1219 if ($args[$i] =~ s/\.\.\.//) { 1220 $elipsis = 1; 1221 if ($args[$i] eq '' && $i == $#args) { 1222 $report_args .= ", ..."; 1223 pop(@args); 1224 last; 1225 } 1226 } 1227 if ($only_C_inlist{$args[$i]}) { 1228 push @args_num, undef; 1229 } else { 1230 push @args_num, ++$num_args; 1231 $report_args .= ", $args[$i]"; 1232 } 1233 if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) { 1234 $extra_args++; 1235 $args[$i] = $1; 1236 $defaults{$args[$i]} = $2; 1237 $defaults{$args[$i]} =~ s/"/\\"/g; 1238 } 1239 $proto_arg[$i+1] = "\$" ; 1240 } 1241 $min_args = $num_args - $extra_args; 1242 $report_args =~ s/"/\\"/g; 1243 $report_args =~ s/^,\s+//; 1244 my @func_args = @args; 1245 shift @func_args if defined($class); 1246 1247 for (@func_args) { 1248 s/^/&/ if $in_out{$_}; 1249 } 1250 $func_args = join(", ", @func_args); 1251 @args_match{@args} = @args_num; 1252 1253 $PPCODE = grep(/^\s*PPCODE\s*:/, @line); 1254 $CODE = grep(/^\s*CODE\s*:/, @line); 1255 # Detect CODE: blocks which use ST(n)= or XST_m*(n,v) 1256 # to set explicit return values. 1257 $EXPLICIT_RETURN = ($CODE && 1258 ("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x )); 1259 $ALIAS = grep(/^\s*ALIAS\s*:/, @line); 1260 $INTERFACE = grep(/^\s*INTERFACE\s*:/, @line); 1261 1262 $xsreturn = 1 if $EXPLICIT_RETURN; 1263 1264 $externC = $externC ? qq[extern "C"] : ""; 1265 1266 # print function header 1267 print Q<<"EOF"; 1268#$externC 1269#XS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */ 1270#XS(XS_${Full_func_name}) 1271#[[ 1272# dXSARGS; 1273EOF 1274 print Q<<"EOF" if $ALIAS ; 1275# dXSI32; 1276EOF 1277 print Q<<"EOF" if $INTERFACE ; 1278# dXSFUNCTION($ret_type); 1279EOF 1280 if ($elipsis) { 1281 $cond = ($min_args ? qq(items < $min_args) : 0); 1282 } 1283 elsif ($min_args == $num_args) { 1284 $cond = qq(items != $min_args); 1285 } 1286 else { 1287 $cond = qq(items < $min_args || items > $num_args); 1288 } 1289 1290 print Q<<"EOF" if $except; 1291# char errbuf[1024]; 1292# *errbuf = '\0'; 1293EOF 1294 1295 if ($ALIAS) 1296 { print Q<<"EOF" if $cond } 1297# if ($cond) 1298# Perl_croak(aTHX_ "Usage: %s($report_args)", GvNAME(CvGV(cv))); 1299EOF 1300 else 1301 { print Q<<"EOF" if $cond } 1302# if ($cond) 1303# Perl_croak(aTHX_ "Usage: $pname($report_args)"); 1304EOF 1305 1306 #gcc -Wall: if an xsub has no arguments and PPCODE is used 1307 #it is likely none of ST, XSRETURN or XSprePUSH macros are used 1308 #hence `ax' (setup by dXSARGS) is unused 1309 #XXX: could breakup the dXSARGS; into dSP;dMARK;dITEMS 1310 #but such a move could break third-party extensions 1311 print Q<<"EOF" if $PPCODE and $num_args == 0; 1312# PERL_UNUSED_VAR(ax); /* -Wall */ 1313EOF 1314 1315 print Q<<"EOF" if $PPCODE; 1316# SP -= items; 1317EOF 1318 1319 # Now do a block of some sort. 1320 1321 $condnum = 0; 1322 $cond = ''; # last CASE: condidional 1323 push(@line, "$END:"); 1324 push(@line_no, $line_no[-1]); 1325 $_ = ''; 1326 &check_cpp; 1327 while (@line) { 1328 &CASE_handler if check_keyword("CASE"); 1329 print Q<<"EOF"; 1330# $except [[ 1331EOF 1332 1333 # do initialization of input variables 1334 $thisdone = 0; 1335 $retvaldone = 0; 1336 $deferred = ""; 1337 %arg_list = () ; 1338 $gotRETVAL = 0; 1339 1340 INPUT_handler() ; 1341 process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD") ; 1342 1343 print Q<<"EOF" if $ScopeThisXSUB; 1344# ENTER; 1345# [[ 1346EOF 1347 1348 if (!$thisdone && defined($class)) { 1349 if (defined($static) or $func_name eq 'new') { 1350 print "\tchar *"; 1351 $var_types{"CLASS"} = "char *"; 1352 &generate_init("char *", 1, "CLASS"); 1353 } 1354 else { 1355 print "\t$class *"; 1356 $var_types{"THIS"} = "$class *"; 1357 &generate_init("$class *", 1, "THIS"); 1358 } 1359 } 1360 1361 # do code 1362 if (/^\s*NOT_IMPLEMENTED_YET/) { 1363 print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n"; 1364 $_ = '' ; 1365 } else { 1366 if ($ret_type ne "void") { 1367 print "\t" . &map_type($ret_type, 'RETVAL') . ";\n" 1368 if !$retvaldone; 1369 $args_match{"RETVAL"} = 0; 1370 $var_types{"RETVAL"} = $ret_type; 1371 print "\tdXSTARG;\n" 1372 if $WantOptimize and $targetable{$type_kind{$ret_type}}; 1373 } 1374 1375 if (@fake_INPUT or @fake_INPUT_pre) { 1376 unshift @line, @fake_INPUT_pre, @fake_INPUT, $_; 1377 $_ = ""; 1378 $processing_arg_with_types = 1; 1379 INPUT_handler() ; 1380 } 1381 print $deferred; 1382 1383 process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD") ; 1384 1385 if (check_keyword("PPCODE")) { 1386 print_section(); 1387 death ("PPCODE must be last thing") if @line; 1388 print "\tLEAVE;\n" if $ScopeThisXSUB; 1389 print "\tPUTBACK;\n\treturn;\n"; 1390 } elsif (check_keyword("CODE")) { 1391 print_section() ; 1392 } elsif (defined($class) and $func_name eq "DESTROY") { 1393 print "\n\t"; 1394 print "delete THIS;\n"; 1395 } else { 1396 print "\n\t"; 1397 if ($ret_type ne "void") { 1398 print "RETVAL = "; 1399 $wantRETVAL = 1; 1400 } 1401 if (defined($static)) { 1402 if ($func_name eq 'new') { 1403 $func_name = "$class"; 1404 } else { 1405 print "${class}::"; 1406 } 1407 } elsif (defined($class)) { 1408 if ($func_name eq 'new') { 1409 $func_name .= " $class"; 1410 } else { 1411 print "THIS->"; 1412 } 1413 } 1414 $func_name =~ s/^($spat)// 1415 if defined($spat); 1416 $func_name = 'XSFUNCTION' if $interface; 1417 print "$func_name($func_args);\n"; 1418 } 1419 } 1420 1421 # do output variables 1422 $gotRETVAL = 0; # 1 if RETVAL seen in OUTPUT section; 1423 undef $RETVAL_code ; # code to set RETVAL (from OUTPUT section); 1424 # $wantRETVAL set if 'RETVAL =' autogenerated 1425 ($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return; 1426 undef %outargs ; 1427 process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD"); 1428 1429 &generate_output($var_types{$_}, $args_match{$_}, $_, $DoSetMagic) 1430 for grep $in_out{$_} =~ /OUT$/, keys %in_out; 1431 1432 # all OUTPUT done, so now push the return value on the stack 1433 if ($gotRETVAL && $RETVAL_code) { 1434 print "\t$RETVAL_code\n"; 1435 } elsif ($gotRETVAL || $wantRETVAL) { 1436 my $t = $WantOptimize && $targetable{$type_kind{$ret_type}}; 1437 my $var = 'RETVAL'; 1438 my $type = $ret_type; 1439 1440 # 0: type, 1: with_size, 2: how, 3: how_size 1441 if ($t and not $t->[1] and $t->[0] eq 'p') { 1442 # PUSHp corresponds to setpvn. Treate setpv directly 1443 my $what = eval qq("$t->[2]"); 1444 warn $@ if $@; 1445 1446 print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n"; 1447 $prepush_done = 1; 1448 } 1449 elsif ($t) { 1450 my $what = eval qq("$t->[2]"); 1451 warn $@ if $@; 1452 1453 my $size = $t->[3]; 1454 $size = '' unless defined $size; 1455 $size = eval qq("$size"); 1456 warn $@ if $@; 1457 print "\tXSprePUSH; PUSH$t->[0]($what$size);\n"; 1458 $prepush_done = 1; 1459 } 1460 else { 1461 # RETVAL almost never needs SvSETMAGIC() 1462 &generate_output($ret_type, 0, 'RETVAL', 0); 1463 } 1464 } 1465 1466 $xsreturn = 1 if $ret_type ne "void"; 1467 my $num = $xsreturn; 1468 my $c = @outlist; 1469 # (PP)CODE set different values of SP; reset to PPCODE's with 0 output 1470 print "\tXSprePUSH;" if $c and not $prepush_done; 1471 # Take into account stuff already put on stack 1472 print "\t++SP;" if $c and not $prepush_done and $xsreturn; 1473 # Now SP corresponds to ST($xsreturn), so one can combine PUSH and ST() 1474 print "\tEXTEND(SP,$c);\n" if $c; 1475 $xsreturn += $c; 1476 generate_output($var_types{$_}, $num++, $_, 0, 1) for @outlist; 1477 1478 # do cleanup 1479 process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD") ; 1480 1481 print Q<<"EOF" if $ScopeThisXSUB; 1482# ]] 1483EOF 1484 print Q<<"EOF" if $ScopeThisXSUB and not $PPCODE; 1485# LEAVE; 1486EOF 1487 1488 # print function trailer 1489 print Q<<EOF; 1490# ]] 1491EOF 1492 print Q<<EOF if $except; 1493# BEGHANDLERS 1494# CATCHALL 1495# sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason); 1496# ENDHANDLERS 1497EOF 1498 if (check_keyword("CASE")) { 1499 blurt ("Error: No `CASE:' at top of function") 1500 unless $condnum; 1501 $_ = "CASE: $_"; # Restore CASE: label 1502 next; 1503 } 1504 last if $_ eq "$END:"; 1505 death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function"); 1506 } 1507 1508 print Q<<EOF if $except; 1509# if (errbuf[0]) 1510# Perl_croak(aTHX_ errbuf); 1511EOF 1512 1513 if ($xsreturn) { 1514 print Q<<EOF unless $PPCODE; 1515# XSRETURN($xsreturn); 1516EOF 1517 } else { 1518 print Q<<EOF unless $PPCODE; 1519# XSRETURN_EMPTY; 1520EOF 1521 } 1522 1523 print Q<<EOF; 1524#]] 1525# 1526EOF 1527 1528 my $newXS = "newXS" ; 1529 my $proto = "" ; 1530 1531 # Build the prototype string for the xsub 1532 if ($ProtoThisXSUB) { 1533 $newXS = "newXSproto"; 1534 1535 if ($ProtoThisXSUB eq 2) { 1536 # User has specified empty prototype 1537 $proto = ', ""' ; 1538 } 1539 elsif ($ProtoThisXSUB ne 1) { 1540 # User has specified a prototype 1541 $proto = ', "' . $ProtoThisXSUB . '"'; 1542 } 1543 else { 1544 my $s = ';'; 1545 if ($min_args < $num_args) { 1546 $s = ''; 1547 $proto_arg[$min_args] .= ";" ; 1548 } 1549 push @proto_arg, "$s\@" 1550 if $elipsis ; 1551 1552 $proto = ', "' . join ("", @proto_arg) . '"'; 1553 } 1554 } 1555 1556 if (%XsubAliases) { 1557 $XsubAliases{$pname} = 0 1558 unless defined $XsubAliases{$pname} ; 1559 while ( ($name, $value) = each %XsubAliases) { 1560 push(@InitFileCode, Q<<"EOF"); 1561# cv = newXS(\"$name\", XS_$Full_func_name, file); 1562# XSANY.any_i32 = $value ; 1563EOF 1564 push(@InitFileCode, Q<<"EOF") if $proto; 1565# sv_setpv((SV*)cv$proto) ; 1566EOF 1567 } 1568 } 1569 elsif (@Attributes) { 1570 push(@InitFileCode, Q<<"EOF"); 1571# cv = newXS(\"$pname\", XS_$Full_func_name, file); 1572# apply_attrs_string("$Package", cv, "@Attributes", 0); 1573EOF 1574 } 1575 elsif ($interface) { 1576 while ( ($name, $value) = each %Interfaces) { 1577 $name = "$Package\::$name" unless $name =~ /::/; 1578 push(@InitFileCode, Q<<"EOF"); 1579# cv = newXS(\"$name\", XS_$Full_func_name, file); 1580# $interface_macro_set(cv,$value) ; 1581EOF 1582 push(@InitFileCode, Q<<"EOF") if $proto; 1583# sv_setpv((SV*)cv$proto) ; 1584EOF 1585 } 1586 } 1587 else { 1588 push(@InitFileCode, 1589 " ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n"); 1590 } 1591} 1592 1593if ($Overload) # make it findable with fetchmethod 1594{ 1595 1596 print Q<<"EOF"; 1597#XS(XS_${Packid}_nil); /* prototype to pass -Wmissing-prototypes */ 1598#XS(XS_${Packid}_nil) 1599#{ 1600# XSRETURN_EMPTY; 1601#} 1602# 1603EOF 1604 unshift(@InitFileCode, <<"MAKE_FETCHMETHOD_WORK"); 1605 /* Making a sub named "${Package}::()" allows the package */ 1606 /* to be findable via fetchmethod(), and causes */ 1607 /* overload::Overloaded("${Package}") to return true. */ 1608 newXS("${Package}::()", XS_${Packid}_nil, file$proto); 1609MAKE_FETCHMETHOD_WORK 1610} 1611 1612# print initialization routine 1613 1614print Q<<"EOF"; 1615##ifdef __cplusplus 1616#extern "C" 1617##endif 1618EOF 1619 1620print Q<<"EOF"; 1621#XS(boot_$Module_cname); /* prototype to pass -Wmissing-prototypes */ 1622#XS(boot_$Module_cname) 1623EOF 1624 1625print Q<<"EOF"; 1626#[[ 1627# dXSARGS; 1628EOF 1629 1630#-Wall: if there is no $Full_func_name there are no xsubs in this .xs 1631#so `file' is unused 1632print Q<<"EOF" if $Full_func_name; 1633# char* file = __FILE__; 1634EOF 1635 1636print Q "#\n"; 1637 1638print Q<<"EOF" if $WantVersionChk ; 1639# XS_VERSION_BOOTCHECK ; 1640# 1641EOF 1642 1643print Q<<"EOF" if defined $XsubAliases or defined $Interfaces ; 1644# { 1645# CV * cv ; 1646# 1647EOF 1648 1649print Q<<"EOF" if ($Overload); 1650# /* register the overloading (type 'A') magic */ 1651# PL_amagic_generation++; 1652# /* The magic for overload gets a GV* via gv_fetchmeth as */ 1653# /* mentioned above, and looks in the SV* slot of it for */ 1654# /* the "fallback" status. */ 1655# sv_setsv( 1656# get_sv( "${Package}::()", TRUE ), 1657# $Fallback 1658# ); 1659EOF 1660 1661print @InitFileCode; 1662 1663print Q<<"EOF" if defined $XsubAliases or defined $Interfaces ; 1664# } 1665EOF 1666 1667if (@BootCode) 1668{ 1669 print "\n /* Initialisation Section */\n\n" ; 1670 @line = @BootCode; 1671 print_section(); 1672 print "\n /* End of Initialisation Section */\n\n" ; 1673} 1674 1675print Q<<"EOF";; 1676# XSRETURN_YES; 1677#]] 1678# 1679EOF 1680 1681warn("Please specify prototyping behavior for $filename (see perlxs manual)\n") 1682 unless $ProtoUsed ; 1683&Exit; 1684 1685sub output_init { 1686 local($type, $num, $var, $init, $name_printed) = @_; 1687 local($arg) = "ST(" . ($num - 1) . ")"; 1688 1689 if( $init =~ /^=/ ) { 1690 if ($name_printed) { 1691 eval qq/print " $init\\n"/; 1692 } else { 1693 eval qq/print "\\t$var $init\\n"/; 1694 } 1695 warn $@ if $@; 1696 } else { 1697 if( $init =~ s/^\+// && $num ) { 1698 &generate_init($type, $num, $var, $name_printed); 1699 } elsif ($name_printed) { 1700 print ";\n"; 1701 $init =~ s/^;//; 1702 } else { 1703 eval qq/print "\\t$var;\\n"/; 1704 warn $@ if $@; 1705 $init =~ s/^;//; 1706 } 1707 $deferred .= eval qq/"\\n\\t$init\\n"/; 1708 warn $@ if $@; 1709 } 1710} 1711 1712sub Warn 1713{ 1714 # work out the line number 1715 my $line_no = $line_no[@line_no - @line -1] ; 1716 1717 print STDERR "@_ in $filename, line $line_no\n" ; 1718} 1719 1720sub blurt 1721{ 1722 Warn @_ ; 1723 $errors ++ 1724} 1725 1726sub death 1727{ 1728 Warn @_ ; 1729 exit 1 ; 1730} 1731 1732sub generate_init { 1733 local($type, $num, $var) = @_; 1734 local($arg) = "ST(" . ($num - 1) . ")"; 1735 local($argoff) = $num - 1; 1736 local($ntype); 1737 local($tk); 1738 1739 $type = TidyType($type) ; 1740 blurt("Error: '$type' not in typemap"), return 1741 unless defined($type_kind{$type}); 1742 1743 ($ntype = $type) =~ s/\s*\*/Ptr/g; 1744 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; 1745 $tk = $type_kind{$type}; 1746 $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/; 1747 if ($tk eq 'T_PV' and exists $lengthof{$var}) { 1748 print "\t$var" unless $name_printed; 1749 print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n"; 1750 die "default value not supported with length(NAME) supplied" 1751 if defined $defaults{$var}; 1752 return; 1753 } 1754 $type =~ tr/:/_/ unless $hiertype; 1755 blurt("Error: No INPUT definition for type '$type', typekind '$type_kind{$type}' found"), return 1756 unless defined $input_expr{$tk} ; 1757 $expr = $input_expr{$tk}; 1758 if ($expr =~ /DO_ARRAY_ELEM/) { 1759 blurt("Error: '$subtype' not in typemap"), return 1760 unless defined($type_kind{$subtype}); 1761 blurt("Error: No INPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return 1762 unless defined $input_expr{$type_kind{$subtype}} ; 1763 $subexpr = $input_expr{$type_kind{$subtype}}; 1764 $subexpr =~ s/\$type/\$subtype/g; 1765 $subexpr =~ s/ntype/subtype/g; 1766 $subexpr =~ s/\$arg/ST(ix_$var)/g; 1767 $subexpr =~ s/\n\t/\n\t\t/g; 1768 $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g; 1769 $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/; 1770 $expr =~ s/DO_ARRAY_ELEM/$subexpr/; 1771 } 1772 if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments 1773 $ScopeThisXSUB = 1; 1774 } 1775 if (defined($defaults{$var})) { 1776 $expr =~ s/(\t+)/$1 /g; 1777 $expr =~ s/ /\t/g; 1778 if ($name_printed) { 1779 print ";\n"; 1780 } else { 1781 eval qq/print "\\t$var;\\n"/; 1782 warn $@ if $@; 1783 } 1784 if ($defaults{$var} eq 'NO_INIT') { 1785 $deferred .= eval qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/; 1786 } else { 1787 $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/; 1788 } 1789 warn $@ if $@; 1790 } elsif ($ScopeThisXSUB or $expr !~ /^\s*\$var =/) { 1791 if ($name_printed) { 1792 print ";\n"; 1793 } else { 1794 eval qq/print "\\t$var;\\n"/; 1795 warn $@ if $@; 1796 } 1797 $deferred .= eval qq/"\\n$expr;\\n"/; 1798 warn $@ if $@; 1799 } else { 1800 die "panic: do not know how to handle this branch for function pointers" 1801 if $name_printed; 1802 eval qq/print "$expr;\\n"/; 1803 warn $@ if $@; 1804 } 1805} 1806 1807sub generate_output { 1808 local($type, $num, $var, $do_setmagic, $do_push) = @_; 1809 local($arg) = "ST(" . ($num - ($num != 0)) . ")"; 1810 local($argoff) = $num - 1; 1811 local($ntype); 1812 1813 $type = TidyType($type) ; 1814 if ($type =~ /^array\(([^,]*),(.*)\)/) { 1815 print "\t$arg = sv_newmortal();\n"; 1816 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n"; 1817 print "\tSvSETMAGIC($arg);\n" if $do_setmagic; 1818 } else { 1819 blurt("Error: '$type' not in typemap"), return 1820 unless defined($type_kind{$type}); 1821 blurt("Error: No OUTPUT definition for type '$type', typekind '$type_kind{$type}' found"), return 1822 unless defined $output_expr{$type_kind{$type}} ; 1823 ($ntype = $type) =~ s/\s*\*/Ptr/g; 1824 $ntype =~ s/\(\)//g; 1825 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; 1826 $expr = $output_expr{$type_kind{$type}}; 1827 if ($expr =~ /DO_ARRAY_ELEM/) { 1828 blurt("Error: '$subtype' not in typemap"), return 1829 unless defined($type_kind{$subtype}); 1830 blurt("Error: No OUTPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return 1831 unless defined $output_expr{$type_kind{$subtype}} ; 1832 $subexpr = $output_expr{$type_kind{$subtype}}; 1833 $subexpr =~ s/ntype/subtype/g; 1834 $subexpr =~ s/\$arg/ST(ix_$var)/g; 1835 $subexpr =~ s/\$var/${var}[ix_$var]/g; 1836 $subexpr =~ s/\n\t/\n\t\t/g; 1837 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/; 1838 eval "print qq\a$expr\a"; 1839 warn $@ if $@; 1840 print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic; 1841 } 1842 elsif ($var eq 'RETVAL') { 1843 if ($expr =~ /^\t\$arg = new/) { 1844 # We expect that $arg has refcnt 1, so we need to 1845 # mortalize it. 1846 eval "print qq\a$expr\a"; 1847 warn $@ if $@; 1848 print "\tsv_2mortal(ST($num));\n"; 1849 print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic; 1850 } 1851 elsif ($expr =~ /^\s*\$arg\s*=/) { 1852 # We expect that $arg has refcnt >=1, so we need 1853 # to mortalize it! 1854 eval "print qq\a$expr\a"; 1855 warn $@ if $@; 1856 print "\tsv_2mortal(ST(0));\n"; 1857 print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic; 1858 } 1859 else { 1860 # Just hope that the entry would safely write it 1861 # over an already mortalized value. By 1862 # coincidence, something like $arg = &sv_undef 1863 # works too. 1864 print "\tST(0) = sv_newmortal();\n"; 1865 eval "print qq\a$expr\a"; 1866 warn $@ if $@; 1867 # new mortals don't have set magic 1868 } 1869 } 1870 elsif ($do_push) { 1871 print "\tPUSHs(sv_newmortal());\n"; 1872 $arg = "ST($num)"; 1873 eval "print qq\a$expr\a"; 1874 warn $@ if $@; 1875 print "\tSvSETMAGIC($arg);\n" if $do_setmagic; 1876 } 1877 elsif ($arg =~ /^ST\(\d+\)$/) { 1878 eval "print qq\a$expr\a"; 1879 warn $@ if $@; 1880 print "\tSvSETMAGIC($arg);\n" if $do_setmagic; 1881 } 1882 } 1883} 1884 1885sub map_type { 1886 my($type, $varname) = @_; 1887 1888 # C++ has :: in types too so skip this 1889 $type =~ tr/:/_/ unless $hiertype; 1890 $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s; 1891 if ($varname) { 1892 if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) { 1893 (substr $type, pos $type, 0) = " $varname "; 1894 } else { 1895 $type .= "\t$varname"; 1896 } 1897 } 1898 $type; 1899} 1900 1901 1902sub Exit { 1903# If this is VMS, the exit status has meaning to the shell, so we 1904# use a predictable value (SS$_Normal or SS$_Abort) rather than an 1905# arbitrary number. 1906# exit ($Is_VMS ? ($errors ? 44 : 1) : $errors) ; 1907 exit ($errors ? 1 : 0); 1908} 1909