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