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