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