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