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