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.40'; 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); 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] = '$' unless $only_C_inlist_ref->{$args[$i]}; 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 and items likely to be unused 523 print Q(<<"EOF"); 524# PERL_UNUSED_VAR(cv); /* -W */ 525# PERL_UNUSED_VAR(items); /* -W */ 526EOF 527 } 528 529 #gcc -Wall: if an xsub has PPCODE is used 530 #it is possible none of ST, XSRETURN or XSprePUSH macros are used 531 #hence 'ax' (setup by dXSARGS) is unused 532 #XXX: could breakup the dXSARGS; into dSP;dMARK;dITEMS 533 #but such a move could break third-party extensions 534 print Q(<<"EOF") if $PPCODE; 535# PERL_UNUSED_VAR(ax); /* -Wall */ 536EOF 537 538 print Q(<<"EOF") if $PPCODE; 539# SP -= items; 540EOF 541 542 # Now do a block of some sort. 543 544 $self->{condnum} = 0; 545 $self->{cond} = ''; # last CASE: conditional 546 push(@{ $self->{line} }, "$END:"); 547 push(@{ $self->{line_no} }, $self->{line_no}->[-1]); 548 $_ = ''; 549 check_conditional_preprocessor_statements(); 550 while (@{ $self->{line} }) { 551 552 $self->CASE_handler($_) if $self->check_keyword("CASE"); 553 print Q(<<"EOF"); 554# $self->{except} [[ 555EOF 556 557 # do initialization of input variables 558 $self->{thisdone} = 0; 559 $self->{retvaldone} = 0; 560 $self->{deferred} = ""; 561 %{ $self->{arg_list} } = (); 562 $self->{gotRETVAL} = 0; 563 $self->INPUT_handler($_); 564 $self->process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD"); 565 566 print Q(<<"EOF") if $self->{ScopeThisXSUB}; 567# ENTER; 568# [[ 569EOF 570 571 if (!$self->{thisdone} && defined($class)) { 572 if (defined($static) or $self->{func_name} eq 'new') { 573 print "\tchar *"; 574 $self->{var_types}->{"CLASS"} = "char *"; 575 $self->generate_init( { 576 type => "char *", 577 num => 1, 578 var => "CLASS", 579 printed_name => undef, 580 } ); 581 } 582 else { 583 print "\t" . map_type($self, "$class *"); 584 $self->{var_types}->{"THIS"} = "$class *"; 585 $self->generate_init( { 586 type => "$class *", 587 num => 1, 588 var => "THIS", 589 printed_name => undef, 590 } ); 591 } 592 } 593 594 # These are set if OUTPUT is found and/or CODE using RETVAL 595 $self->{have_OUTPUT} = $self->{have_CODE_with_RETVAL} = 0; 596 597 my ($wantRETVAL); 598 # do code 599 if (/^\s*NOT_IMPLEMENTED_YET/) { 600 print "\n\tPerl_croak(aTHX_ \"$self->{pname}: not implemented yet\");\n"; 601 $_ = ''; 602 } 603 else { 604 if ($self->{ret_type} ne "void") { 605 print "\t" . map_type($self, $self->{ret_type}, 'RETVAL') . ";\n" 606 if !$self->{retvaldone}; 607 $self->{args_match}->{"RETVAL"} = 0; 608 $self->{var_types}->{"RETVAL"} = $self->{ret_type}; 609 my $outputmap = $self->{typemap}->get_outputmap( ctype => $self->{ret_type} ); 610 print "\tdXSTARG;\n" 611 if $self->{optimize} and $outputmap and $outputmap->targetable; 612 } 613 614 if (@fake_INPUT or @fake_INPUT_pre) { 615 unshift @{ $self->{line} }, @fake_INPUT_pre, @fake_INPUT, $_; 616 $_ = ""; 617 $self->{processing_arg_with_types} = 1; 618 $self->INPUT_handler($_); 619 } 620 print $self->{deferred}; 621 622 $self->process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD"); 623 624 if ($self->check_keyword("PPCODE")) { 625 $self->print_section(); 626 $self->death("PPCODE must be last thing") if @{ $self->{line} }; 627 print "\tLEAVE;\n" if $self->{ScopeThisXSUB}; 628 print "\tPUTBACK;\n\treturn;\n"; 629 } 630 elsif ($self->check_keyword("CODE")) { 631 my $consumed_code = $self->print_section(); 632 if ($consumed_code =~ /\bRETVAL\b/) { 633 $self->{have_CODE_with_RETVAL} = 1; 634 } 635 } 636 elsif (defined($class) and $self->{func_name} eq "DESTROY") { 637 print "\n\t"; 638 print "delete THIS;\n"; 639 } 640 else { 641 print "\n\t"; 642 if ($self->{ret_type} ne "void") { 643 print "RETVAL = "; 644 $wantRETVAL = 1; 645 } 646 if (defined($static)) { 647 if ($self->{func_name} eq 'new') { 648 $self->{func_name} = "$class"; 649 } 650 else { 651 print "${class}::"; 652 } 653 } 654 elsif (defined($class)) { 655 if ($self->{func_name} eq 'new') { 656 $self->{func_name} .= " $class"; 657 } 658 else { 659 print "THIS->"; 660 } 661 } 662 my $strip = $self->{strip_c_func_prefix}; 663 $self->{func_name} =~ s/^\Q$strip// 664 if defined $strip; 665 $self->{func_name} = 'XSFUNCTION' if $self->{interface}; 666 print "$self->{func_name}($self->{func_args});\n"; 667 } 668 } 669 670 # do output variables 671 $self->{gotRETVAL} = 0; # 1 if RETVAL seen in OUTPUT section; 672 undef $self->{RETVAL_code} ; # code to set RETVAL (from OUTPUT section); 673 # $wantRETVAL set if 'RETVAL =' autogenerated 674 ($wantRETVAL, $self->{ret_type}) = (0, 'void') if $RETVAL_no_return; 675 undef %{ $self->{outargs} }; 676 677 $self->process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD"); 678 679 # A CODE section with RETVAL, but no OUTPUT? FAIL! 680 if ($self->{have_CODE_with_RETVAL} and not $self->{have_OUTPUT} and $self->{ret_type} ne 'void') { 681 $self->Warn("Warning: Found a 'CODE' section which seems to be using 'RETVAL' but no 'OUTPUT' section."); 682 } 683 684 $self->generate_output( { 685 type => $self->{var_types}->{$_}, 686 num => $self->{args_match}->{$_}, 687 var => $_, 688 do_setmagic => $self->{DoSetMagic}, 689 do_push => undef, 690 } ) for grep $self->{in_out}->{$_} =~ /OUT$/, sort keys %{ $self->{in_out} }; 691 692 my $prepush_done; 693 # all OUTPUT done, so now push the return value on the stack 694 if ($self->{gotRETVAL} && $self->{RETVAL_code}) { 695 print "\t$self->{RETVAL_code}\n"; 696 } 697 elsif ($self->{gotRETVAL} || $wantRETVAL) { 698 my $outputmap = $self->{typemap}->get_outputmap( ctype => $self->{ret_type} ); 699 my $trgt = $self->{optimize} && $outputmap && $outputmap->targetable; 700 my $var = 'RETVAL'; 701 my $type = $self->{ret_type}; 702 703 if ($trgt) { 704 my $what = $self->eval_output_typemap_code( 705 qq("$trgt->{what}"), 706 {var => $var, type => $self->{ret_type}} 707 ); 708 if (not $trgt->{with_size} and $trgt->{type} eq 'p') { # sv_setpv 709 # PUSHp corresponds to sv_setpvn. Treat sv_setpv directly 710 print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n"; 711 $prepush_done = 1; 712 } 713 else { 714 my $tsize = $trgt->{what_size}; 715 $tsize = '' unless defined $tsize; 716 $tsize = $self->eval_output_typemap_code( 717 qq("$tsize"), 718 {var => $var, type => $self->{ret_type}} 719 ); 720 print "\tXSprePUSH; PUSH$trgt->{type}($what$tsize);\n"; 721 $prepush_done = 1; 722 } 723 } 724 else { 725 # RETVAL almost never needs SvSETMAGIC() 726 $self->generate_output( { 727 type => $self->{ret_type}, 728 num => 0, 729 var => 'RETVAL', 730 do_setmagic => 0, 731 do_push => undef, 732 } ); 733 } 734 } 735 736 $xsreturn = 1 if $self->{ret_type} ne "void"; 737 my $num = $xsreturn; 738 my $c = @{ $outlist_ref }; 739 print "\tXSprePUSH;" if $c and not $prepush_done; 740 print "\tEXTEND(SP,$c);\n" if $c; 741 $xsreturn += $c; 742 $self->generate_output( { 743 type => $self->{var_types}->{$_}, 744 num => $num++, 745 var => $_, 746 do_setmagic => 0, 747 do_push => 1, 748 } ) for @{ $outlist_ref }; 749 750 # do cleanup 751 $self->process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD"); 752 753 print Q(<<"EOF") if $self->{ScopeThisXSUB}; 754# ]] 755EOF 756 print Q(<<"EOF") if $self->{ScopeThisXSUB} and not $PPCODE; 757# LEAVE; 758EOF 759 760 # print function trailer 761 print Q(<<"EOF"); 762# ]] 763EOF 764 print Q(<<"EOF") if $self->{except}; 765# BEGHANDLERS 766# CATCHALL 767# sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason); 768# ENDHANDLERS 769EOF 770 if ($self->check_keyword("CASE")) { 771 $self->blurt("Error: No 'CASE:' at top of function") 772 unless $self->{condnum}; 773 $_ = "CASE: $_"; # Restore CASE: label 774 next; 775 } 776 last if $_ eq "$END:"; 777 $self->death(/^$BLOCK_regexp/o ? "Misplaced '$1:'" : "Junk at end of function ($_)"); 778 } 779 780 print Q(<<"EOF") if $self->{except}; 781# if (errbuf[0]) 782# Perl_croak(aTHX_ errbuf); 783EOF 784 785 if ($xsreturn) { 786 print Q(<<"EOF") unless $PPCODE; 787# XSRETURN($xsreturn); 788EOF 789 } 790 else { 791 print Q(<<"EOF") unless $PPCODE; 792# XSRETURN_EMPTY; 793EOF 794 } 795 796 print Q(<<"EOF"); 797#]] 798# 799EOF 800 801 $self->{proto} = ""; 802 unless($self->{ProtoThisXSUB}) { 803 $self->{newXS} = "newXS_deffile"; 804 $self->{file} = ""; 805 } 806 else { 807 # Build the prototype string for the xsub 808 $self->{newXS} = "newXSproto_portable"; 809 $self->{file} = ", file"; 810 811 if ($self->{ProtoThisXSUB} eq 2) { 812 # User has specified empty prototype 813 } 814 elsif ($self->{ProtoThisXSUB} eq 1) { 815 my $s = ';'; 816 if ($min_args < $num_args) { 817 $s = ''; 818 $self->{proto_arg}->[$min_args] .= ";"; 819 } 820 push @{ $self->{proto_arg} }, "$s\@" 821 if $ellipsis; 822 823 $self->{proto} = join ("", grep defined, @{ $self->{proto_arg} } ); 824 } 825 else { 826 # User has specified a prototype 827 $self->{proto} = $self->{ProtoThisXSUB}; 828 } 829 $self->{proto} = qq{, "$self->{proto}"}; 830 } 831 832 if ($self->{XsubAliases} and keys %{ $self->{XsubAliases} }) { 833 $self->{XsubAliases}->{ $self->{pname} } = 0 834 unless defined $self->{XsubAliases}->{ $self->{pname} }; 835 foreach my $xname (sort keys %{ $self->{XsubAliases} }) { 836 my $value = $self->{XsubAliases}{$xname}; 837 push(@{ $self->{InitFileCode} }, Q(<<"EOF")); 838# cv = $self->{newXS}(\"$xname\", XS_$self->{Full_func_name}$self->{file}$self->{proto}); 839# XSANY.any_i32 = $value; 840EOF 841 } 842 } 843 elsif (@{ $self->{Attributes} }) { 844 push(@{ $self->{InitFileCode} }, Q(<<"EOF")); 845# cv = $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto}); 846# apply_attrs_string("$self->{Package}", cv, "@{ $self->{Attributes} }", 0); 847EOF 848 } 849 elsif ($self->{interface}) { 850 foreach my $yname (sort keys %{ $self->{Interfaces} }) { 851 my $value = $self->{Interfaces}{$yname}; 852 $yname = "$self->{Package}\::$yname" unless $yname =~ /::/; 853 push(@{ $self->{InitFileCode} }, Q(<<"EOF")); 854# cv = $self->{newXS}(\"$yname\", XS_$self->{Full_func_name}$self->{file}$self->{proto}); 855# $self->{interface_macro_set}(cv,$value); 856EOF 857 } 858 } 859 elsif($self->{newXS} eq 'newXS_deffile'){ # work around P5NCI's empty newXS macro 860 push(@{ $self->{InitFileCode} }, 861 " $self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n"); 862 } 863 else { 864 push(@{ $self->{InitFileCode} }, 865 " (void)$self->{newXS}(\"$self->{pname}\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n"); 866 } 867 } # END 'PARAGRAPH' 'while' loop 868 869 if ($self->{Overload}) { # make it findable with fetchmethod 870 print Q(<<"EOF"); 871#XS_EUPXS(XS_$self->{Packid}_nil); /* prototype to pass -Wmissing-prototypes */ 872#XS_EUPXS(XS_$self->{Packid}_nil) 873#{ 874# dXSARGS; 875# PERL_UNUSED_VAR(items); 876# XSRETURN_EMPTY; 877#} 878# 879EOF 880 unshift(@{ $self->{InitFileCode} }, <<"MAKE_FETCHMETHOD_WORK"); 881 /* Making a sub named "$self->{Package}::()" allows the package */ 882 /* to be findable via fetchmethod(), and causes */ 883 /* overload::Overloaded("$self->{Package}") to return true. */ 884 (void)$self->{newXS}("$self->{Package}::()", XS_$self->{Packid}_nil$self->{file}$self->{proto}); 885MAKE_FETCHMETHOD_WORK 886 } 887 888 # print initialization routine 889 890 print Q(<<"EOF"); 891##ifdef __cplusplus 892#extern "C" 893##endif 894EOF 895 896 print Q(<<"EOF"); 897#XS_EXTERNAL(boot_$self->{Module_cname}); /* prototype to pass -Wmissing-prototypes */ 898#XS_EXTERNAL(boot_$self->{Module_cname}) 899#[[ 900##if PERL_VERSION_LE(5, 21, 5) 901# dVAR; dXSARGS; 902##else 903# dVAR; ${\($self->{WantVersionChk} ? 904 'dXSBOOTARGSXSAPIVERCHK;' : 'dXSBOOTARGSAPIVERCHK;')} 905##endif 906EOF 907 908 #Under 5.8.x and lower, newXS is declared in proto.h as expecting a non-const 909 #file name argument. If the wrong qualifier is used, it causes breakage with 910 #C++ compilers and warnings with recent gcc. 911 #-Wall: if there is no $self->{Full_func_name} there are no xsubs in this .xs 912 #so 'file' is unused 913 print Q(<<"EOF") if $self->{Full_func_name}; 914##if (PERL_REVISION == 5 && PERL_VERSION < 9) 915# char* file = __FILE__; 916##else 917# const char* file = __FILE__; 918##endif 919# 920# PERL_UNUSED_VAR(file); 921EOF 922 923 print Q("#\n"); 924 925 print Q(<<"EOF"); 926# PERL_UNUSED_VAR(cv); /* -W */ 927# PERL_UNUSED_VAR(items); /* -W */ 928EOF 929 930 if( $self->{WantVersionChk}){ 931 print Q(<<"EOF") ; 932##if PERL_VERSION_LE(5, 21, 5) 933# XS_VERSION_BOOTCHECK; 934## ifdef XS_APIVERSION_BOOTCHECK 935# XS_APIVERSION_BOOTCHECK; 936## endif 937##endif 938 939EOF 940 } else { 941 print Q(<<"EOF") ; 942##if PERL_VERSION_LE(5, 21, 5) && defined(XS_APIVERSION_BOOTCHECK) 943# XS_APIVERSION_BOOTCHECK; 944##endif 945 946EOF 947 } 948 949 print Q(<<"EOF") if defined $self->{XsubAliases} or defined $self->{interfaces}; 950# { 951# CV * cv; 952# 953EOF 954 955 print Q(<<"EOF") if ($self->{Overload}); 956# /* register the overloading (type 'A') magic */ 957##if (PERL_REVISION == 5 && PERL_VERSION < 9) 958# PL_amagic_generation++; 959##endif 960# /* The magic for overload gets a GV* via gv_fetchmeth as */ 961# /* mentioned above, and looks in the SV* slot of it for */ 962# /* the "fallback" status. */ 963# sv_setsv( 964# get_sv( "$self->{Package}::()", TRUE ), 965# $self->{Fallback} 966# ); 967EOF 968 969 print @{ $self->{InitFileCode} }; 970 971 print Q(<<"EOF") if defined $self->{XsubAliases} or defined $self->{interfaces}; 972# } 973EOF 974 975 if (@{ $BootCode_ref }) { 976 print "\n /* Initialisation Section */\n\n"; 977 @{ $self->{line} } = @{ $BootCode_ref }; 978 $self->print_section(); 979 print "\n /* End of Initialisation Section */\n\n"; 980 } 981 982 print Q(<<'EOF'); 983##if PERL_VERSION_LE(5, 21, 5) 984## if PERL_VERSION_GE(5, 9, 0) 985# if (PL_unitcheckav) 986# call_list(PL_scopestack_ix, PL_unitcheckav); 987## endif 988# XSRETURN_YES; 989##else 990# Perl_xs_boot_epilog(aTHX_ ax); 991##endif 992#]] 993# 994EOF 995 996 warn("Please specify prototyping behavior for $self->{filename} (see perlxs manual)\n") 997 unless $self->{ProtoUsed}; 998 999 chdir($orig_cwd); 1000 select($orig_fh); 1001 untie *PSEUDO_STDOUT if tied *PSEUDO_STDOUT; 1002 close $self->{FH}; 1003 1004 return 1; 1005} 1006 1007sub report_error_count { 1008 if (@_) { 1009 return $_[0]->{errors}||0; 1010 } 1011 else { 1012 return $Singleton->{errors}||0; 1013 } 1014} 1015 1016# Input: ($self, $_, @{ $self->{line} }) == unparsed input. 1017# Output: ($_, @{ $self->{line} }) == (rest of line, following lines). 1018# Return: the matched keyword if found, otherwise 0 1019sub check_keyword { 1020 my $self = shift; 1021 $_ = shift(@{ $self->{line} }) while !/\S/ && @{ $self->{line} }; 1022 s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2; 1023} 1024 1025sub print_section { 1026 my $self = shift; 1027 1028 # the "do" is required for right semantics 1029 do { $_ = shift(@{ $self->{line} }) } while !/\S/ && @{ $self->{line} }; 1030 1031 my $consumed_code = ''; 1032 1033 print("#line ", $self->{line_no}->[@{ $self->{line_no} } - @{ $self->{line} } -1], " \"", 1034 escape_file_for_line_directive($self->{filepathname}), "\"\n") 1035 if $self->{WantLineNumbers} && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/; 1036 for (; defined($_) && !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { 1037 print "$_\n"; 1038 $consumed_code .= "$_\n"; 1039 } 1040 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $self->{WantLineNumbers}; 1041 1042 return $consumed_code; 1043} 1044 1045sub merge_section { 1046 my $self = shift; 1047 my $in = ''; 1048 1049 while (!/\S/ && @{ $self->{line} }) { 1050 $_ = shift(@{ $self->{line} }); 1051 } 1052 1053 for (; defined($_) && !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { 1054 $in .= "$_\n"; 1055 } 1056 chomp $in; 1057 return $in; 1058} 1059 1060sub process_keyword { 1061 my($self, $pattern) = @_; 1062 1063 while (my $kwd = $self->check_keyword($pattern)) { 1064 my $method = $kwd . "_handler"; 1065 $self->$method($_); 1066 } 1067} 1068 1069sub CASE_handler { 1070 my $self = shift; 1071 $_ = shift; 1072 $self->blurt("Error: 'CASE:' after unconditional 'CASE:'") 1073 if $self->{condnum} && $self->{cond} eq ''; 1074 $self->{cond} = $_; 1075 trim_whitespace($self->{cond}); 1076 print " ", ($self->{condnum}++ ? " else" : ""), ($self->{cond} ? " if ($self->{cond})\n" : "\n"); 1077 $_ = ''; 1078} 1079 1080sub INPUT_handler { 1081 my $self = shift; 1082 $_ = shift; 1083 for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { 1084 last if /^\s*NOT_IMPLEMENTED_YET/; 1085 next unless /\S/; # skip blank lines 1086 1087 trim_whitespace($_); 1088 my $ln = $_; 1089 1090 # remove trailing semicolon if no initialisation 1091 s/\s*;$//g unless /[=;+].*\S/; 1092 1093 # Process the length(foo) declarations 1094 if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) { 1095 print "\tSTRLEN\tSTRLEN_length_of_$2;\n"; 1096 $self->{lengthof}->{$2} = undef; 1097 $self->{deferred} .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;\n"; 1098 } 1099 1100 # check for optional initialisation code 1101 my $var_init = ''; 1102 $var_init = $1 if s/\s*([=;+].*)$//s; 1103 $var_init =~ s/"/\\"/g; 1104 # *sigh* It's valid to supply explicit input typemaps in the argument list... 1105 my $is_overridden_typemap = $var_init =~ /ST\s*\(|\$arg\b/; 1106 1107 s/\s+/ /g; 1108 my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s 1109 or $self->blurt("Error: invalid argument declaration '$ln'"), next; 1110 1111 # Check for duplicate definitions 1112 $self->blurt("Error: duplicate definition of argument '$var_name' ignored"), next 1113 if $self->{arg_list}->{$var_name}++ 1114 or defined $self->{argtype_seen}->{$var_name} and not $self->{processing_arg_with_types}; 1115 1116 $self->{thisdone} |= $var_name eq "THIS"; 1117 $self->{retvaldone} |= $var_name eq "RETVAL"; 1118 $self->{var_types}->{$var_name} = $var_type; 1119 # XXXX This check is a safeguard against the unfinished conversion of 1120 # generate_init(). When generate_init() is fixed, 1121 # one can use 2-args map_type() unconditionally. 1122 my $printed_name; 1123 if ($var_type =~ / \( \s* \* \s* \) /x) { 1124 # Function pointers are not yet supported with output_init()! 1125 print "\t" . map_type($self, $var_type, $var_name); 1126 $printed_name = 1; 1127 } 1128 else { 1129 print "\t" . map_type($self, $var_type, undef); 1130 $printed_name = 0; 1131 } 1132 $self->{var_num} = $self->{args_match}->{$var_name}; 1133 1134 if ($self->{var_num}) { 1135 my $typemap = $self->{typemap}->get_typemap(ctype => $var_type); 1136 $self->report_typemap_failure($self->{typemap}, $var_type, "death") 1137 if not $typemap and not $is_overridden_typemap; 1138 $self->{proto_arg}->[$self->{var_num}] = ($typemap && $typemap->proto) || "\$"; 1139 } 1140 $self->{func_args} =~ s/\b($var_name)\b/&$1/ if $var_addr; 1141 if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/ 1142 or $self->{in_out}->{$var_name} and $self->{in_out}->{$var_name} =~ /^OUT/ 1143 and $var_init !~ /\S/) { 1144 if ($printed_name) { 1145 print ";\n"; 1146 } 1147 else { 1148 print "\t$var_name;\n"; 1149 } 1150 } 1151 elsif ($var_init =~ /\S/) { 1152 $self->output_init( { 1153 type => $var_type, 1154 num => $self->{var_num}, 1155 var => $var_name, 1156 init => $var_init, 1157 printed_name => $printed_name, 1158 } ); 1159 } 1160 elsif ($self->{var_num}) { 1161 $self->generate_init( { 1162 type => $var_type, 1163 num => $self->{var_num}, 1164 var => $var_name, 1165 printed_name => $printed_name, 1166 } ); 1167 } 1168 else { 1169 print ";\n"; 1170 } 1171 } 1172} 1173 1174sub OUTPUT_handler { 1175 my $self = shift; 1176 $self->{have_OUTPUT} = 1; 1177 1178 $_ = shift; 1179 for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { 1180 next unless /\S/; 1181 if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) { 1182 $self->{DoSetMagic} = ($1 eq "ENABLE" ? 1 : 0); 1183 next; 1184 } 1185 my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s; 1186 $self->blurt("Error: duplicate OUTPUT argument '$outarg' ignored"), next 1187 if $self->{outargs}->{$outarg}++; 1188 if (!$self->{gotRETVAL} and $outarg eq 'RETVAL') { 1189 # deal with RETVAL last 1190 $self->{RETVAL_code} = $outcode; 1191 $self->{gotRETVAL} = 1; 1192 next; 1193 } 1194 $self->blurt("Error: OUTPUT $outarg not an argument"), next 1195 unless defined($self->{args_match}->{$outarg}); 1196 $self->blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next 1197 unless defined $self->{var_types}->{$outarg}; 1198 $self->{var_num} = $self->{args_match}->{$outarg}; 1199 if ($outcode) { 1200 print "\t$outcode\n"; 1201 print "\tSvSETMAGIC(ST(" , $self->{var_num} - 1 , "));\n" if $self->{DoSetMagic}; 1202 } 1203 else { 1204 $self->generate_output( { 1205 type => $self->{var_types}->{$outarg}, 1206 num => $self->{var_num}, 1207 var => $outarg, 1208 do_setmagic => $self->{DoSetMagic}, 1209 do_push => undef, 1210 } ); 1211 } 1212 delete $self->{in_out}->{$outarg} # No need to auto-OUTPUT 1213 if exists $self->{in_out}->{$outarg} and $self->{in_out}->{$outarg} =~ /OUT$/; 1214 } 1215} 1216 1217sub C_ARGS_handler { 1218 my $self = shift; 1219 $_ = shift; 1220 my $in = $self->merge_section(); 1221 1222 trim_whitespace($in); 1223 $self->{func_args} = $in; 1224} 1225 1226sub INTERFACE_MACRO_handler { 1227 my $self = shift; 1228 $_ = shift; 1229 my $in = $self->merge_section(); 1230 1231 trim_whitespace($in); 1232 if ($in =~ /\s/) { # two 1233 ($self->{interface_macro}, $self->{interface_macro_set}) = split ' ', $in; 1234 } 1235 else { 1236 $self->{interface_macro} = $in; 1237 $self->{interface_macro_set} = 'UNKNOWN_CVT'; # catch later 1238 } 1239 $self->{interface} = 1; # local 1240 $self->{interfaces} = 1; # global 1241} 1242 1243sub INTERFACE_handler { 1244 my $self = shift; 1245 $_ = shift; 1246 my $in = $self->merge_section(); 1247 1248 trim_whitespace($in); 1249 1250 foreach (split /[\s,]+/, $in) { 1251 my $iface_name = $_; 1252 $iface_name =~ s/^$self->{Prefix}//; 1253 $self->{Interfaces}->{$iface_name} = $_; 1254 } 1255 print Q(<<"EOF"); 1256# XSFUNCTION = $self->{interface_macro}($self->{ret_type},cv,XSANY.any_dptr); 1257EOF 1258 $self->{interface} = 1; # local 1259 $self->{interfaces} = 1; # global 1260} 1261 1262sub CLEANUP_handler { 1263 my $self = shift; 1264 $self->print_section(); 1265} 1266 1267sub PREINIT_handler { 1268 my $self = shift; 1269 $self->print_section(); 1270} 1271 1272sub POSTCALL_handler { 1273 my $self = shift; 1274 $self->print_section(); 1275} 1276 1277sub INIT_handler { 1278 my $self = shift; 1279 $self->print_section(); 1280} 1281 1282sub get_aliases { 1283 my $self = shift; 1284 my ($line) = @_; 1285 my ($orig) = $line; 1286 1287 # Parse alias definitions 1288 # format is 1289 # alias = value alias = value ... 1290 1291 while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) { 1292 my ($alias, $value) = ($1, $2); 1293 my $orig_alias = $alias; 1294 1295 # check for optional package definition in the alias 1296 $alias = $self->{Packprefix} . $alias if $alias !~ /::/; 1297 1298 # check for duplicate alias name & duplicate value 1299 Warn( $self, "Warning: Ignoring duplicate alias '$orig_alias'") 1300 if defined $self->{XsubAliases}->{$alias}; 1301 1302 Warn( $self, "Warning: Aliases '$orig_alias' and '$self->{XsubAliasValues}->{$value}' have identical values") 1303 if $self->{XsubAliasValues}->{$value}; 1304 1305 $self->{XsubAliases}->{$alias} = $value; 1306 $self->{XsubAliasValues}->{$value} = $orig_alias; 1307 } 1308 1309 blurt( $self, "Error: Cannot parse ALIAS definitions from '$orig'") 1310 if $line; 1311} 1312 1313sub ATTRS_handler { 1314 my $self = shift; 1315 $_ = shift; 1316 1317 for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { 1318 next unless /\S/; 1319 trim_whitespace($_); 1320 push @{ $self->{Attributes} }, $_; 1321 } 1322} 1323 1324sub ALIAS_handler { 1325 my $self = shift; 1326 $_ = shift; 1327 1328 for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { 1329 next unless /\S/; 1330 trim_whitespace($_); 1331 $self->get_aliases($_) if $_; 1332 } 1333} 1334 1335sub OVERLOAD_handler { 1336 my $self = shift; 1337 $_ = shift; 1338 1339 for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { 1340 next unless /\S/; 1341 trim_whitespace($_); 1342 while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) { 1343 $self->{Overload} = 1 unless $self->{Overload}; 1344 my $overload = "$self->{Package}\::(".$1; 1345 push(@{ $self->{InitFileCode} }, 1346 " (void)$self->{newXS}(\"$overload\", XS_$self->{Full_func_name}$self->{file}$self->{proto});\n"); 1347 } 1348 } 1349} 1350 1351sub FALLBACK_handler { 1352 my ($self, $setting) = @_; 1353 1354 # the rest of the current line should contain either TRUE, 1355 # FALSE or UNDEF 1356 1357 trim_whitespace($setting); 1358 $setting = uc($setting); 1359 1360 my %map = ( 1361 TRUE => "&PL_sv_yes", 1 => "&PL_sv_yes", 1362 FALSE => "&PL_sv_no", 0 => "&PL_sv_no", 1363 UNDEF => "&PL_sv_undef", 1364 ); 1365 1366 # check for valid FALLBACK value 1367 $self->death("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{$setting}; 1368 1369 $self->{Fallback} = $map{$setting}; 1370} 1371 1372 1373sub REQUIRE_handler { 1374 # the rest of the current line should contain a version number 1375 my ($self, $ver) = @_; 1376 1377 trim_whitespace($ver); 1378 1379 $self->death("Error: REQUIRE expects a version number") 1380 unless $ver; 1381 1382 # check that the version number is of the form n.n 1383 $self->death("Error: REQUIRE: expected a number, got '$ver'") 1384 unless $ver =~ /^\d+(\.\d*)?/; 1385 1386 $self->death("Error: xsubpp $ver (or better) required--this is only $VERSION.") 1387 unless $VERSION >= $ver; 1388} 1389 1390sub VERSIONCHECK_handler { 1391 # the rest of the current line should contain either ENABLE or 1392 # DISABLE 1393 my ($self, $setting) = @_; 1394 1395 trim_whitespace($setting); 1396 1397 # check for ENABLE/DISABLE 1398 $self->death("Error: VERSIONCHECK: ENABLE/DISABLE") 1399 unless $setting =~ /^(ENABLE|DISABLE)/i; 1400 1401 $self->{WantVersionChk} = 1 if $1 eq 'ENABLE'; 1402 $self->{WantVersionChk} = 0 if $1 eq 'DISABLE'; 1403 1404} 1405 1406sub PROTOTYPE_handler { 1407 my $self = shift; 1408 $_ = shift; 1409 1410 my $specified; 1411 1412 $self->death("Error: Only 1 PROTOTYPE definition allowed per xsub") 1413 if $self->{proto_in_this_xsub}++; 1414 1415 for (; !/^$BLOCK_regexp/o; $_ = shift(@{ $self->{line} })) { 1416 next unless /\S/; 1417 $specified = 1; 1418 trim_whitespace($_); 1419 if ($_ eq 'DISABLE') { 1420 $self->{ProtoThisXSUB} = 0; 1421 } 1422 elsif ($_ eq 'ENABLE') { 1423 $self->{ProtoThisXSUB} = 1; 1424 } 1425 else { 1426 # remove any whitespace 1427 s/\s+//g; 1428 $self->death("Error: Invalid prototype '$_'") 1429 unless valid_proto_string($_); 1430 $self->{ProtoThisXSUB} = C_string($_); 1431 } 1432 } 1433 1434 # If no prototype specified, then assume empty prototype "" 1435 $self->{ProtoThisXSUB} = 2 unless $specified; 1436 1437 $self->{ProtoUsed} = 1; 1438} 1439 1440sub SCOPE_handler { 1441 # Rest of line should be either ENABLE or DISABLE 1442 my ($self, $setting) = @_; 1443 1444 $self->death("Error: Only 1 SCOPE declaration allowed per xsub") 1445 if $self->{scope_in_this_xsub}++; 1446 1447 trim_whitespace($setting); 1448 $self->death("Error: SCOPE: ENABLE/DISABLE") 1449 unless $setting =~ /^(ENABLE|DISABLE)\b/i; 1450 $self->{ScopeThisXSUB} = ( uc($1) eq 'ENABLE' ); 1451} 1452 1453sub PROTOTYPES_handler { 1454 # the rest of the current line should contain either ENABLE or 1455 # DISABLE 1456 my ($self, $setting) = @_; 1457 1458 trim_whitespace($setting); 1459 1460 # check for ENABLE/DISABLE 1461 $self->death("Error: PROTOTYPES: ENABLE/DISABLE") 1462 unless $setting =~ /^(ENABLE|DISABLE)/i; 1463 1464 $self->{WantPrototypes} = 1 if $1 eq 'ENABLE'; 1465 $self->{WantPrototypes} = 0 if $1 eq 'DISABLE'; 1466 $self->{ProtoUsed} = 1; 1467} 1468 1469sub EXPORT_XSUB_SYMBOLS_handler { 1470 # the rest of the current line should contain either ENABLE or 1471 # DISABLE 1472 my ($self, $setting) = @_; 1473 1474 trim_whitespace($setting); 1475 1476 # check for ENABLE/DISABLE 1477 $self->death("Error: EXPORT_XSUB_SYMBOLS: ENABLE/DISABLE") 1478 unless $setting =~ /^(ENABLE|DISABLE)/i; 1479 1480 my $xs_impl = $1 eq 'ENABLE' ? 'XS_EXTERNAL' : 'XS_INTERNAL'; 1481 1482 print Q(<<"EOF"); 1483##undef XS_EUPXS 1484##if defined(PERL_EUPXS_ALWAYS_EXPORT) 1485## define XS_EUPXS(name) XS_EXTERNAL(name) 1486##elif defined(PERL_EUPXS_NEVER_EXPORT) 1487## define XS_EUPXS(name) XS_INTERNAL(name) 1488##else 1489## define XS_EUPXS(name) $xs_impl(name) 1490##endif 1491EOF 1492} 1493 1494 1495sub PushXSStack { 1496 my $self = shift; 1497 my %args = @_; 1498 # Save the current file context. 1499 push(@{ $self->{XSStack} }, { 1500 type => 'file', 1501 LastLine => $self->{lastline}, 1502 LastLineNo => $self->{lastline_no}, 1503 Line => $self->{line}, 1504 LineNo => $self->{line_no}, 1505 Filename => $self->{filename}, 1506 Filepathname => $self->{filepathname}, 1507 Handle => $self->{FH}, 1508 IsPipe => scalar($self->{filename} =~ /\|\s*$/), 1509 %args, 1510 }); 1511 1512} 1513 1514sub INCLUDE_handler { 1515 my $self = shift; 1516 $_ = shift; 1517 # the rest of the current line should contain a valid filename 1518 1519 trim_whitespace($_); 1520 1521 $self->death("INCLUDE: filename missing") 1522 unless $_; 1523 1524 $self->death("INCLUDE: output pipe is illegal") 1525 if /^\s*\|/; 1526 1527 # simple minded recursion detector 1528 $self->death("INCLUDE loop detected") 1529 if $self->{IncludedFiles}->{$_}; 1530 1531 ++$self->{IncludedFiles}->{$_} unless /\|\s*$/; 1532 1533 if (/\|\s*$/ && /^\s*perl\s/) { 1534 Warn( $self, "The INCLUDE directive with a command is discouraged." . 1535 " Use INCLUDE_COMMAND instead! In particular using 'perl'" . 1536 " in an 'INCLUDE: ... |' directive is not guaranteed to pick" . 1537 " up the correct perl. The INCLUDE_COMMAND directive allows" . 1538 " the use of \$^X as the currently running perl, see" . 1539 " 'perldoc perlxs' for details."); 1540 } 1541 1542 $self->PushXSStack(); 1543 1544 $self->{FH} = Symbol::gensym(); 1545 1546 # open the new file 1547 open($self->{FH}, $_) or $self->death("Cannot open '$_': $!"); 1548 1549 print Q(<<"EOF"); 1550# 1551#/* INCLUDE: Including '$_' from '$self->{filename}' */ 1552# 1553EOF 1554 1555 $self->{filename} = $_; 1556 $self->{filepathname} = ( $^O =~ /^mswin/i ) 1557 ? qq($self->{dir}/$self->{filename}) # See CPAN RT #61908: gcc doesn't like backslashes on win32? 1558 : File::Spec->catfile($self->{dir}, $self->{filename}); 1559 1560 # Prime the pump by reading the first 1561 # non-blank line 1562 1563 # skip leading blank lines 1564 while (readline($self->{FH})) { 1565 last unless /^\s*$/; 1566 } 1567 1568 $self->{lastline} = $_; 1569 $self->{lastline_no} = $.; 1570} 1571 1572sub QuoteArgs { 1573 my $cmd = shift; 1574 my @args = split /\s+/, $cmd; 1575 $cmd = shift @args; 1576 for (@args) { 1577 $_ = q(").$_.q(") if !/^\"/ && length($_) > 0; 1578 } 1579 return join (' ', ($cmd, @args)); 1580} 1581 1582# code copied from CPAN::HandleConfig::safe_quote 1583# - that has doc saying leave if start/finish with same quote, but no code 1584# given text, will conditionally quote it to protect from shell 1585{ 1586 my ($quote, $use_quote) = $^O eq 'MSWin32' 1587 ? (q{"}, q{"}) 1588 : (q{"'}, q{'}); 1589 sub _safe_quote { 1590 my ($self, $command) = @_; 1591 # Set up quote/default quote 1592 if (defined($command) 1593 and $command =~ /\s/ 1594 and $command !~ /[$quote]/) { 1595 return qq{$use_quote$command$use_quote} 1596 } 1597 return $command; 1598 } 1599} 1600 1601sub INCLUDE_COMMAND_handler { 1602 my $self = shift; 1603 $_ = shift; 1604 # the rest of the current line should contain a valid command 1605 1606 trim_whitespace($_); 1607 1608 $_ = QuoteArgs($_) if $^O eq 'VMS'; 1609 1610 $self->death("INCLUDE_COMMAND: command missing") 1611 unless $_; 1612 1613 $self->death("INCLUDE_COMMAND: pipes are illegal") 1614 if /^\s*\|/ or /\|\s*$/; 1615 1616 $self->PushXSStack( IsPipe => 1 ); 1617 1618 $self->{FH} = Symbol::gensym(); 1619 1620 # If $^X is used in INCLUDE_COMMAND, we know it's supposed to be 1621 # the same perl interpreter as we're currently running 1622 my $X = $self->_safe_quote($^X); # quotes if has spaces 1623 s/^\s*\$\^X/$X/; 1624 1625 # open the new file 1626 open ($self->{FH}, "-|", $_) 1627 or $self->death( $self, "Cannot run command '$_' to include its output: $!"); 1628 1629 print Q(<<"EOF"); 1630# 1631#/* INCLUDE_COMMAND: Including output of '$_' from '$self->{filename}' */ 1632# 1633EOF 1634 1635 $self->{filename} = $_; 1636 $self->{filepathname} = $self->{filename}; 1637 #$self->{filepathname} =~ s/\"/\\"/g; # Fails? See CPAN RT #53938: MinGW Broken after 2.21 1638 $self->{filepathname} =~ s/\\/\\\\/g; # Works according to reporter of #53938 1639 1640 # Prime the pump by reading the first 1641 # non-blank line 1642 1643 # skip leading blank lines 1644 while (readline($self->{FH})) { 1645 last unless /^\s*$/; 1646 } 1647 1648 $self->{lastline} = $_; 1649 $self->{lastline_no} = $.; 1650} 1651 1652sub PopFile { 1653 my $self = shift; 1654 1655 return 0 unless $self->{XSStack}->[-1]{type} eq 'file'; 1656 1657 my $data = pop @{ $self->{XSStack} }; 1658 my $ThisFile = $self->{filename}; 1659 my $isPipe = $data->{IsPipe}; 1660 1661 --$self->{IncludedFiles}->{$self->{filename}} 1662 unless $isPipe; 1663 1664 close $self->{FH}; 1665 1666 $self->{FH} = $data->{Handle}; 1667 # $filename is the leafname, which for some reason is used for diagnostic 1668 # messages, whereas $filepathname is the full pathname, and is used for 1669 # #line directives. 1670 $self->{filename} = $data->{Filename}; 1671 $self->{filepathname} = $data->{Filepathname}; 1672 $self->{lastline} = $data->{LastLine}; 1673 $self->{lastline_no} = $data->{LastLineNo}; 1674 @{ $self->{line} } = @{ $data->{Line} }; 1675 @{ $self->{line_no} } = @{ $data->{LineNo} }; 1676 1677 if ($isPipe and $? ) { 1678 --$self->{lastline_no}; 1679 print STDERR "Error reading from pipe '$ThisFile': $! in $self->{filename}, line $self->{lastline_no}\n" ; 1680 exit 1; 1681 } 1682 1683 print Q(<<"EOF"); 1684# 1685#/* INCLUDE: Returning to '$self->{filename}' from '$ThisFile' */ 1686# 1687EOF 1688 1689 return 1; 1690} 1691 1692sub Q { 1693 my($text) = @_; 1694 $text =~ s/^#//gm; 1695 $text =~ s/\[\[/{/g; 1696 $text =~ s/\]\]/}/g; 1697 $text; 1698} 1699 1700# Process "MODULE = Foo ..." lines and update global state accordingly 1701sub _process_module_xs_line { 1702 my ($self, $module, $pkg, $prefix) = @_; 1703 1704 ($self->{Module_cname} = $module) =~ s/\W/_/g; 1705 1706 $self->{Package} = defined($pkg) ? $pkg : ''; 1707 $self->{Prefix} = quotemeta( defined($prefix) ? $prefix : '' ); 1708 1709 ($self->{Packid} = $self->{Package}) =~ tr/:/_/; 1710 1711 $self->{Packprefix} = $self->{Package}; 1712 $self->{Packprefix} .= "::" if $self->{Packprefix} ne ""; 1713 1714 $self->{lastline} = ""; 1715} 1716 1717# Skip any embedded POD sections 1718sub _maybe_skip_pod { 1719 my ($self) = @_; 1720 1721 while ($self->{lastline} =~ /^=/) { 1722 while ($self->{lastline} = readline($self->{FH})) { 1723 last if ($self->{lastline} =~ /^=cut\s*$/); 1724 } 1725 $self->death("Error: Unterminated pod") unless defined $self->{lastline}; 1726 $self->{lastline} = readline($self->{FH}); 1727 chomp $self->{lastline}; 1728 $self->{lastline} =~ s/^\s+$//; 1729 } 1730} 1731 1732# This chunk of code strips out (and parses) embedded TYPEMAP blocks 1733# which support a HEREdoc-alike block syntax. 1734sub _maybe_parse_typemap_block { 1735 my ($self) = @_; 1736 1737 # This is special cased from the usual paragraph-handler logic 1738 # due to the HEREdoc-ish syntax. 1739 if ($self->{lastline} =~ /^TYPEMAP\s*:\s*<<\s*(?:(["'])(.+?)\1|([^\s'"]+?))\s*;?\s*$/) 1740 { 1741 my $end_marker = quotemeta(defined($1) ? $2 : $3); 1742 1743 # Scan until we find $end_marker alone on a line. 1744 my @tmaplines; 1745 while (1) { 1746 $self->{lastline} = readline($self->{FH}); 1747 $self->death("Error: Unterminated TYPEMAP section") if not defined $self->{lastline}; 1748 last if $self->{lastline} =~ /^$end_marker\s*$/; 1749 push @tmaplines, $self->{lastline}; 1750 } 1751 1752 my $tmap = ExtUtils::Typemaps->new( 1753 string => join("", @tmaplines), 1754 lineno_offset => 1 + ($self->current_line_number() || 0), 1755 fake_filename => $self->{filename}, 1756 ); 1757 $self->{typemap}->merge(typemap => $tmap, replace => 1); 1758 1759 $self->{lastline} = ""; 1760 } 1761} 1762 1763# Read next xsub into @{ $self->{line} } from ($lastline, readline($self->{FH})). 1764sub fetch_para { 1765 my $self = shift; 1766 1767 # parse paragraph 1768 $self->death("Error: Unterminated '#if/#ifdef/#ifndef'") 1769 if !defined $self->{lastline} && $self->{XSStack}->[-1]{type} eq 'if'; 1770 @{ $self->{line} } = (); 1771 @{ $self->{line_no} } = (); 1772 return $self->PopFile() if not defined $self->{lastline}; # EOF 1773 1774 if ($self->{lastline} =~ 1775 /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) 1776 { 1777 $self->_process_module_xs_line($1, $2, $3); 1778 } 1779 1780 for (;;) { 1781 $self->_maybe_skip_pod; 1782 1783 $self->_maybe_parse_typemap_block; 1784 1785 if ($self->{lastline} !~ /^\s*#/ # not a CPP directive 1786 # CPP directives: 1787 # ANSI: if ifdef ifndef elif else endif define undef 1788 # line error pragma 1789 # gcc: warning include_next 1790 # obj-c: import 1791 # others: ident (gcc notes that some cpps have this one) 1792 || $self->{lastline} =~ /^\#[ \t]* 1793 (?: 1794 (?:if|ifn?def|elif|else|endif| 1795 define|undef|pragma|error| 1796 warning|line\s+\d+|ident) 1797 \b 1798 | (?:include(?:_next)?|import) 1799 \s* ["<] .* [>"] 1800 ) 1801 /x 1802 ) 1803 { 1804 last if $self->{lastline} =~ /^\S/ && @{ $self->{line} } && $self->{line}->[-1] eq ""; 1805 push(@{ $self->{line} }, $self->{lastline}); 1806 push(@{ $self->{line_no} }, $self->{lastline_no}); 1807 } 1808 1809 # Read next line and continuation lines 1810 last unless defined($self->{lastline} = readline($self->{FH})); 1811 $self->{lastline_no} = $.; 1812 my $tmp_line; 1813 $self->{lastline} .= $tmp_line 1814 while ($self->{lastline} =~ /\\$/ && defined($tmp_line = readline($self->{FH}))); 1815 1816 chomp $self->{lastline}; 1817 $self->{lastline} =~ s/^\s+$//; 1818 } 1819 1820 # Nuke trailing "line" entries until there's one that's not empty 1821 pop(@{ $self->{line} }), pop(@{ $self->{line_no} }) 1822 while @{ $self->{line} } && $self->{line}->[-1] eq ""; 1823 1824 return 1; 1825} 1826 1827sub output_init { 1828 my $self = shift; 1829 my $argsref = shift; 1830 1831 my ($type, $num, $var, $init, $printed_name) 1832 = @{$argsref}{qw(type num var init printed_name)}; 1833 1834 # local assign for efficiently passing in to eval_input_typemap_code 1835 local $argsref->{arg} = $num 1836 ? "ST(" . ($num-1) . ")" 1837 : "/* not a parameter */"; 1838 1839 if ( $init =~ /^=/ ) { 1840 if ($printed_name) { 1841 $self->eval_input_typemap_code(qq/print " $init\\n"/, $argsref); 1842 } 1843 else { 1844 $self->eval_input_typemap_code(qq/print "\\t$var $init\\n"/, $argsref); 1845 } 1846 } 1847 else { 1848 if ( $init =~ s/^\+// && $num ) { 1849 $self->generate_init( { 1850 type => $type, 1851 num => $num, 1852 var => $var, 1853 printed_name => $printed_name, 1854 } ); 1855 } 1856 elsif ($printed_name) { 1857 print ";\n"; 1858 $init =~ s/^;//; 1859 } 1860 else { 1861 $self->eval_input_typemap_code(qq/print "\\t$var;\\n"/, $argsref); 1862 $init =~ s/^;//; 1863 } 1864 $self->{deferred} 1865 .= $self->eval_input_typemap_code(qq/"\\n\\t$init\\n"/, $argsref); 1866 } 1867} 1868 1869sub generate_init { 1870 my $self = shift; 1871 my $argsref = shift; 1872 1873 my ($type, $num, $var, $printed_name) 1874 = @{$argsref}{qw(type num var printed_name)}; 1875 1876 my $argoff = $num - 1; 1877 my $arg = "ST($argoff)"; 1878 1879 my $typemaps = $self->{typemap}; 1880 1881 $type = ExtUtils::Typemaps::tidy_type($type); 1882 if (not $typemaps->get_typemap(ctype => $type)) { 1883 $self->report_typemap_failure($typemaps, $type); 1884 return; 1885 } 1886 1887 (my $ntype = $type) =~ s/\s*\*/Ptr/g; 1888 (my $subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; 1889 1890 my $typem = $typemaps->get_typemap(ctype => $type); 1891 my $xstype = $typem->xstype; 1892 #this is an optimization from perl 5.0 alpha 6, class check is skipped 1893 #T_REF_IV_REF is missing since it has no untyped analog at the moment 1894 $xstype =~ s/OBJ$/REF/ || $xstype =~ s/^T_REF_IV_PTR$/T_PTRREF/ 1895 if $self->{func_name} =~ /DESTROY$/; 1896 if ($xstype eq 'T_PV' and exists $self->{lengthof}->{$var}) { 1897 print "\t$var" unless $printed_name; 1898 print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n"; 1899 die "default value not supported with length(NAME) supplied" 1900 if defined $self->{defaults}->{$var}; 1901 return; 1902 } 1903 $type =~ tr/:/_/ unless $self->{RetainCplusplusHierarchicalTypes}; 1904 1905 my $inputmap = $typemaps->get_inputmap(xstype => $xstype); 1906 if (not defined $inputmap) { 1907 $self->blurt("Error: No INPUT definition for type '$type', typekind '" . $type->xstype . "' found"); 1908 return; 1909 } 1910 1911 my $expr = $inputmap->cleaned_code; 1912 # Note: This gruesome bit either needs heavy rethinking or documentation. I vote for the former. --Steffen 1913 if ($expr =~ /DO_ARRAY_ELEM/) { 1914 my $subtypemap = $typemaps->get_typemap(ctype => $subtype); 1915 if (not $subtypemap) { 1916 $self->report_typemap_failure($typemaps, $subtype); 1917 return; 1918 } 1919 1920 my $subinputmap = $typemaps->get_inputmap(xstype => $subtypemap->xstype); 1921 if (not $subinputmap) { 1922 $self->blurt("Error: No INPUT definition for type '$subtype', typekind '" . $subtypemap->xstype . "' found"); 1923 return; 1924 } 1925 1926 my $subexpr = $subinputmap->cleaned_code; 1927 $subexpr =~ s/\$type/\$subtype/g; 1928 $subexpr =~ s/ntype/subtype/g; 1929 $subexpr =~ s/\$arg/ST(ix_$var)/g; 1930 $subexpr =~ s/\n\t/\n\t\t/g; 1931 $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g; 1932 $subexpr =~ s/\$var/${var}\[ix_$var - $argoff]/; 1933 $expr =~ s/DO_ARRAY_ELEM/$subexpr/; 1934 } 1935 if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments 1936 $self->{ScopeThisXSUB} = 1; 1937 } 1938 1939 my $eval_vars = { 1940 var => $var, 1941 printed_name => $printed_name, 1942 type => $type, 1943 ntype => $ntype, 1944 subtype => $subtype, 1945 num => $num, 1946 arg => $arg, 1947 argoff => $argoff, 1948 }; 1949 1950 if (defined($self->{defaults}->{$var})) { 1951 $expr =~ s/(\t+)/$1 /g; 1952 $expr =~ s/ /\t/g; 1953 if ($printed_name) { 1954 print ";\n"; 1955 } 1956 else { 1957 $self->eval_input_typemap_code(qq/print "\\t$var;\\n"/, $eval_vars); 1958 } 1959 if ($self->{defaults}->{$var} eq 'NO_INIT') { 1960 $self->{deferred} .= $self->eval_input_typemap_code( 1961 qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/, 1962 $eval_vars 1963 ); 1964 } 1965 else { 1966 $self->{deferred} .= $self->eval_input_typemap_code( 1967 qq/"\\n\\tif (items < $num)\\n\\t $var = $self->{defaults}->{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/, 1968 $eval_vars 1969 ); 1970 } 1971 } 1972 elsif ($self->{ScopeThisXSUB} or $expr !~ /^\s*\$var =/) { 1973 if ($printed_name) { 1974 print ";\n"; 1975 } 1976 else { 1977 $self->eval_input_typemap_code(qq/print "\\t$var;\\n"/, $eval_vars); 1978 } 1979 $self->{deferred} 1980 .= $self->eval_input_typemap_code(qq/"\\n$expr;\\n"/, $eval_vars); 1981 } 1982 else { 1983 die "panic: do not know how to handle this branch for function pointers" 1984 if $printed_name; 1985 $self->eval_input_typemap_code(qq/print "$expr;\\n"/, $eval_vars); 1986 } 1987} 1988 1989sub generate_output { 1990 my $self = shift; 1991 my $argsref = shift; 1992 my ($type, $num, $var, $do_setmagic, $do_push) 1993 = @{$argsref}{qw(type num var do_setmagic do_push)}; 1994 1995 my $arg = "ST(" . ($num - ($num != 0)) . ")"; 1996 1997 my $typemaps = $self->{typemap}; 1998 1999 $type = ExtUtils::Typemaps::tidy_type($type); 2000 local $argsref->{type} = $type; 2001 2002 if ($type =~ /^array\(([^,]*),(.*)\)/) { 2003 print "\t$arg = sv_newmortal();\n"; 2004 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n"; 2005 print "\tSvSETMAGIC($arg);\n" if $do_setmagic; 2006 } 2007 else { 2008 my $typemap = $typemaps->get_typemap(ctype => $type); 2009 if (not $typemap) { 2010 $self->report_typemap_failure($typemaps, $type); 2011 return; 2012 } 2013 2014 my $outputmap = $typemaps->get_outputmap(xstype => $typemap->xstype); 2015 if (not $outputmap) { 2016 $self->blurt("Error: No OUTPUT definition for type '$type', typekind '" . $typemap->xstype . "' found"); 2017 return; 2018 } 2019 2020 (my $ntype = $type) =~ s/\s*\*/Ptr/g; 2021 $ntype =~ s/\(\)//g; 2022 (my $subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//; 2023 2024 my $eval_vars = {%$argsref, subtype => $subtype, ntype => $ntype, arg => $arg}; 2025 my $expr = $outputmap->cleaned_code; 2026 if ($expr =~ /DO_ARRAY_ELEM/) { 2027 my $subtypemap = $typemaps->get_typemap(ctype => $subtype); 2028 if (not $subtypemap) { 2029 $self->report_typemap_failure($typemaps, $subtype); 2030 return; 2031 } 2032 2033 my $suboutputmap = $typemaps->get_outputmap(xstype => $subtypemap->xstype); 2034 if (not $suboutputmap) { 2035 $self->blurt("Error: No OUTPUT definition for type '$subtype', typekind '" . $subtypemap->xstype . "' found"); 2036 return; 2037 } 2038 2039 my $subexpr = $suboutputmap->cleaned_code; 2040 $subexpr =~ s/ntype/subtype/g; 2041 $subexpr =~ s/\$arg/ST(ix_$var)/g; 2042 $subexpr =~ s/\$var/${var}\[ix_$var]/g; 2043 $subexpr =~ s/\n\t/\n\t\t/g; 2044 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/; 2045 $self->eval_output_typemap_code("print qq\a$expr\a", $eval_vars); 2046 print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic; 2047 } 2048 elsif ($var eq 'RETVAL') { 2049 my $orig_arg = $arg; 2050 my $indent; 2051 my $use_RETVALSV = 1; 2052 my $do_mortal = 0; 2053 my $do_copy_tmp = 1; 2054 my $pre_expr; 2055 local $eval_vars->{arg} = $arg = 'RETVALSV'; 2056 my $evalexpr = $self->eval_output_typemap_code("qq\a$expr\a", $eval_vars); 2057 2058 if ($expr =~ /^\t\Q$arg\E = new/) { 2059 # We expect that $arg has refcnt 1, so we need to 2060 # mortalize it. 2061 $do_mortal = 1; 2062 } 2063 # If RETVAL is immortal, don't mortalize it. This code is not perfect: 2064 # It won't detect a func or expression that only returns immortals, for 2065 # example, this RE must be tried before next elsif. 2066 elsif ($evalexpr =~ /^\t\Q$arg\E\s*=\s*(boolSV\(|(&PL_sv_yes|&PL_sv_no|&PL_sv_undef)\s*;)/) { 2067 $do_copy_tmp = 0; #$arg will be a ST(X), no SV* RETVAL, no RETVALSV 2068 $use_RETVALSV = 0; 2069 } 2070 elsif ($evalexpr =~ /^\s*\Q$arg\E\s*=/) { 2071 # We expect that $arg has refcnt >=1, so we need 2072 # to mortalize it! 2073 $use_RETVALSV = 0 if $ntype eq "SVPtr";#reuse SV* RETVAL vs open new block 2074 $do_mortal = 1; 2075 } 2076 else { 2077 # Just hope that the entry would safely write it 2078 # over an already mortalized value. By 2079 # coincidence, something like $arg = &PL_sv_undef 2080 # works too, but should be caught above. 2081 $pre_expr = "RETVALSV = sv_newmortal();\n"; 2082 # new mortals don't have set magic 2083 $do_setmagic = 0; 2084 } 2085 if($use_RETVALSV) { 2086 print "\t{\n\t SV * RETVALSV;\n"; 2087 $indent = "\t "; 2088 } else { 2089 $indent = "\t"; 2090 } 2091 print $indent.$pre_expr if $pre_expr; 2092 2093 if($use_RETVALSV) { 2094 #take control of 1 layer of indent, may or may not indent more 2095 $evalexpr =~ s/^(\t| )/$indent/gm; 2096 #"\t \t" doesn't draw right in some IDEs 2097 #break down all \t into spaces 2098 $evalexpr =~ s/\t/ /g; 2099 #rebuild back into \t'es, \t==8 spaces, indent==4 spaces 2100 $evalexpr =~ s/ /\t/g; 2101 } 2102 else { 2103 if($do_mortal || $do_setmagic) { 2104 #typemap entry evaled with RETVALSV, if we aren't using RETVALSV replace 2105 $evalexpr =~ s/RETVALSV/RETVAL/g; #all uses with RETVAL for prettier code 2106 } 2107 else { #if no extra boilerplate (no mortal, no set magic) is needed 2108 #after $evalexport, get rid of RETVALSV's visual cluter and change 2109 $evalexpr =~ s/RETVALSV/$orig_arg/g;#the lvalue to ST(X) 2110 } 2111 } 2112 #stop " RETVAL = RETVAL;" for SVPtr type 2113 print $evalexpr if $evalexpr !~ /^\s*RETVAL = RETVAL;$/; 2114 print $indent.'RETVAL'.($use_RETVALSV ? 'SV':'') 2115 .' = sv_2mortal(RETVAL'.($use_RETVALSV ? 'SV':'').");\n" if $do_mortal; 2116 print $indent.'SvSETMAGIC(RETVAL'.($use_RETVALSV ? 'SV':'').");\n" if $do_setmagic; 2117 #dont do "RETVALSV = boolSV(RETVAL); ST(0) = RETVALSV;", it is visual clutter 2118 print $indent."$orig_arg = RETVAL".($use_RETVALSV ? 'SV':'').";\n" 2119 if $do_mortal || $do_setmagic || $do_copy_tmp; 2120 print "\t}\n" if $use_RETVALSV; 2121 } 2122 elsif ($do_push) { 2123 print "\tPUSHs(sv_newmortal());\n"; 2124 local $eval_vars->{arg} = "ST($num)"; 2125 $self->eval_output_typemap_code("print qq\a$expr\a", $eval_vars); 2126 print "\tSvSETMAGIC($arg);\n" if $do_setmagic; 2127 } 2128 elsif ($arg =~ /^ST\(\d+\)$/) { 2129 $self->eval_output_typemap_code("print qq\a$expr\a", $eval_vars); 2130 print "\tSvSETMAGIC($arg);\n" if $do_setmagic; 2131 } 2132 } 2133} 2134 2135 2136# Just delegates to a clean package. 2137# Shim to evaluate Perl code in the right variable context 2138# for typemap code (having things such as $ALIAS set up). 2139sub eval_output_typemap_code { 2140 my ($self, $code, $other) = @_; 2141 return ExtUtils::ParseXS::Eval::eval_output_typemap_code($self, $code, $other); 2142} 2143 2144sub eval_input_typemap_code { 2145 my ($self, $code, $other) = @_; 2146 return ExtUtils::ParseXS::Eval::eval_input_typemap_code($self, $code, $other); 2147} 2148 21491; 2150 2151# vim: ts=2 sw=2 et: 2152