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