dist/ExtUtils-ParseXS/lib/ExtUtils/ParseXS.pm

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