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