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