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