home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl_mlb.zip / ExtUtils / xsubpp < prev   
Text File  |  1997-11-25  |  35KB  |  1,364 lines
  1. #!./miniperl
  2.  
  3. =head1 NAME
  4.  
  5. xsubpp - compiler to convert Perl XS code into C code
  6.  
  7. =head1 SYNOPSIS
  8.  
  9. B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-typemap typemap>]... file.xs
  10.  
  11. =head1 DESCRIPTION
  12.  
  13. I<xsubpp> will compile XS code into C code by embedding the constructs
  14. necessary to let C functions manipulate Perl values and creates the glue
  15. necessary to let Perl access those functions.  The compiler uses typemaps to
  16. determine how to map C function parameters and variables to Perl values.
  17.  
  18. The compiler will search for typemap files called I<typemap>.  It will use
  19. the following search path to find default typemaps, with the rightmost
  20. typemap taking precedence.
  21.  
  22.     ../../../typemap:../../typemap:../typemap:typemap
  23.  
  24. =head1 OPTIONS
  25.  
  26. =over 5
  27.  
  28. =item B<-C++>
  29.  
  30. Adds ``extern "C"'' to the C code.
  31.  
  32.  
  33. =item B<-except>
  34.  
  35. Adds exception handling stubs to the C code.
  36.  
  37. =item B<-typemap typemap>
  38.  
  39. Indicates that a user-supplied typemap should take precedence over the
  40. default typemaps.  This option may be used multiple times, with the last
  41. typemap having the highest precedence.
  42.  
  43. =item B<-v>
  44.  
  45. Prints the I<xsubpp> version number to standard output, then exits.
  46.  
  47. =item B<-prototypes>
  48.  
  49. By default I<xsubpp> will not automatically generate prototype code for
  50. all xsubs. This flag will enable prototypes.
  51.  
  52. =item B<-noversioncheck>
  53.  
  54. Disables the run time test that determines if the object file (derived
  55. from the C<.xs> file) and the C<.pm> files have the same version
  56. number.
  57.  
  58. =item B<-nolinenumbers>
  59.  
  60. Prevents the inclusion of `#line' directives in the output.
  61.  
  62. =back
  63.  
  64. =head1 ENVIRONMENT
  65.  
  66. No environment variables are used.
  67.  
  68. =head1 AUTHOR
  69.  
  70. Larry Wall
  71.  
  72. =head1 MODIFICATION HISTORY
  73.  
  74. See the file F<changes.pod>.
  75.  
  76. =head1 SEE ALSO
  77.  
  78. perl(1), perlxs(1), perlxstut(1)
  79.  
  80. =cut
  81.  
  82. require 5.002;
  83. use Cwd;
  84. use vars '$cplusplus';
  85.  
  86. sub Q ;
  87.  
  88. # Global Constants
  89.  
  90. $XSUBPP_version = "1.9505";
  91.  
  92. my ($Is_VMS, $SymSet);
  93. if ($^O eq 'VMS') {
  94.     $Is_VMS = 1;
  95.     # Establish set of global symbols with max length 28, since xsubpp
  96.     # will later add the 'XS_' prefix.
  97.     require ExtUtils::XSSymSet;
  98.     $SymSet = new ExtUtils::XSSymSet 28;
  99. }
  100.  
  101. $FH = 'File0000' ;
  102.  
  103. $usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-s pattern] [-typemap typemap]... file.xs\n";
  104.  
  105. $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
  106.  
  107. $except = "";
  108. $WantPrototypes = -1 ;
  109. $WantVersionChk = 1 ;
  110. $ProtoUsed = 0 ;
  111. $WantLineNumbers = 1 ;
  112. SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) {
  113.     $flag = shift @ARGV;
  114.     $flag =~ s/^-// ;
  115.     $spat = quotemeta shift,    next SWITCH    if $flag eq 's';
  116.     $cplusplus = 1,    next SWITCH    if $flag eq 'C++';
  117.     $WantPrototypes = 0, next SWITCH    if $flag eq 'noprototypes';
  118.     $WantPrototypes = 1, next SWITCH    if $flag eq 'prototypes';
  119.     $WantVersionChk = 0, next SWITCH    if $flag eq 'noversioncheck';
  120.     $WantVersionChk = 1, next SWITCH    if $flag eq 'versioncheck';
  121.     $except = " TRY",    next SWITCH    if $flag eq 'except';
  122.     push(@tm,shift),    next SWITCH    if $flag eq 'typemap';
  123.     $WantLineNumbers = 0, next SWITCH    if $flag eq 'nolinenumbers';
  124.     $WantLineNumbers = 1, next SWITCH    if $flag eq 'linenumbers';
  125.     (print "xsubpp version $XSUBPP_version\n"), exit      
  126.     if $flag eq 'v';
  127.     die $usage;
  128. }
  129. if ($WantPrototypes == -1)
  130.   { $WantPrototypes = 0}
  131. else
  132.   { $ProtoUsed = 1 }
  133.  
  134.  
  135. @ARGV == 1 or die $usage;
  136. ($dir, $filename) = $ARGV[0] =~ m#(.*)/(.*)#
  137.     or ($dir, $filename) = $ARGV[0] =~ m#(.*)\\(.*)#
  138.     or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)#
  139.     or ($dir, $filename) = ('.', $ARGV[0]);
  140. chdir($dir);
  141. $pwd = cwd();
  142.  
  143. ++ $IncludedFiles{$ARGV[0]} ;
  144.  
  145. my(@XSStack) = ({type => 'none'});    # Stack of conditionals and INCLUDEs
  146. my($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA");
  147.  
  148.  
  149. sub TrimWhitespace
  150. {
  151.     $_[0] =~ s/^\s+|\s+$//go ;
  152. }
  153.  
  154. sub TidyType
  155. {
  156.     local ($_) = @_ ;
  157.  
  158.     # rationalise any '*' by joining them into bunches and removing whitespace
  159.     s#\s*(\*+)\s*#$1#g;
  160.     s#(\*+)# $1 #g ;
  161.  
  162.     # change multiple whitespace into a single space
  163.     s/\s+/ /g ;
  164.     
  165.     # trim leading & trailing whitespace
  166.     TrimWhitespace($_) ;
  167.  
  168.     $_ ;
  169. }
  170.  
  171. $typemap = shift @ARGV;
  172. foreach $typemap (@tm) {
  173.     die "Can't find $typemap in $pwd\n" unless -r $typemap;
  174. }
  175. unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap
  176.                 ../../lib/ExtUtils/typemap ../../../typemap ../../typemap
  177.                 ../typemap typemap);
  178. foreach $typemap (@tm) {
  179.     next unless -e $typemap ;
  180.     # skip directories, binary files etc.
  181.     warn("Warning: ignoring non-text typemap file '$typemap'\n"), next 
  182.     unless -T $typemap ;
  183.     open(TYPEMAP, $typemap) 
  184.     or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
  185.     $mode = 'Typemap';
  186.     $junk = "" ;
  187.     $current = \$junk;
  188.     while (<TYPEMAP>) {
  189.     next if /^\s*#/;
  190.         my $line_no = $. + 1; 
  191.     if (/^INPUT\s*$/)   { $mode = 'Input';   $current = \$junk;  next; }
  192.     if (/^OUTPUT\s*$/)  { $mode = 'Output';  $current = \$junk;  next; }
  193.     if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk;  next; }
  194.     if ($mode eq 'Typemap') {
  195.         chomp;
  196.         my $line = $_ ;
  197.             TrimWhitespace($_) ;
  198.         # skip blank lines and comment lines
  199.         next if /^$/ or /^#/ ;
  200.         my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or
  201.         warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next;
  202.             $type = TidyType($type) ;
  203.         $type_kind{$type} = $kind ;
  204.             # prototype defaults to '$'
  205.             $proto = "\$" unless $proto ;
  206.             warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n") 
  207.                 unless ValidProtoString($proto) ;
  208.             $proto_letter{$type} = C_string($proto) ;
  209.     }
  210.     elsif (/^\s/) {
  211.         $$current .= $_;
  212.     }
  213.     elsif ($mode eq 'Input') {
  214.         s/\s+$//;
  215.         $input_expr{$_} = '';
  216.         $current = \$input_expr{$_};
  217.     }
  218.     else {
  219.         s/\s+$//;
  220.         $output_expr{$_} = '';
  221.         $current = \$output_expr{$_};
  222.     }
  223.     }
  224.     close(TYPEMAP);
  225. }
  226.  
  227. foreach $key (keys %input_expr) {
  228.     $input_expr{$key} =~ s/\n+$//;
  229. }
  230.  
  231. $END = "!End!\n\n";        # "impossible" keyword (multiple newline)
  232.  
  233. # Match an XS keyword
  234. $BLOCK_re= '\s*(' . join('|', qw(
  235.     REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT 
  236.     CLEANUP ALIAS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
  237.     SCOPE
  238.     )) . "|$END)\\s*:";
  239.  
  240. # Input:  ($_, @line) == unparsed input.
  241. # Output: ($_, @line) == (rest of line, following lines).
  242. # Return: the matched keyword if found, otherwise 0
  243. sub check_keyword {
  244.     $_ = shift(@line) while !/\S/ && @line;
  245.     s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
  246. }
  247.  
  248.  
  249. if ($WantLineNumbers) {
  250.     {
  251.     package xsubpp::counter;
  252.     sub TIEHANDLE {
  253.         my ($class, $cfile) = @_;
  254.         my $buf = "";
  255.         $SECTION_END_MARKER = "#line --- \"$cfile\"";
  256.         $line_no = 1;
  257.         bless \$buf;
  258.     }
  259.  
  260.     sub PRINT {
  261.         my $self = shift;
  262.         for (@_) {
  263.         $$self .= $_;
  264.         while ($$self =~ s/^([^\n]*\n)//) {
  265.             my $line = $1;
  266.             ++ $line_no;
  267.             $line =~ s|^\#line\s+---(?=\s)|#line $line_no|;
  268.             print STDOUT $line;
  269.         }
  270.         }
  271.     }
  272.  
  273.     sub PRINTF {
  274.         my $self = shift;
  275.         my $fmt = shift;
  276.         $self->PRINT(sprintf($fmt, @_));
  277.     }
  278.  
  279.     sub DESTROY {
  280.         # Not necessary if we're careful to end with a "\n"
  281.         my $self = shift;
  282.         print STDOUT $$self;
  283.     }
  284.     }
  285.  
  286.     my $cfile = $filename;
  287.     $cfile =~ s/\.xs$/.c/i or $cfile .= ".c";
  288.     tie(*PSEUDO_STDOUT, 'xsubpp::counter', $cfile);
  289.     select PSEUDO_STDOUT;
  290. }
  291.  
  292. sub print_section {
  293.     # the "do" is required for right semantics
  294.     do { $_ = shift(@line) } while !/\S/ && @line;
  295.     
  296.     print("#line ", $line_no[@line_no - @line -1], " \"$filename\"\n")
  297.     if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
  298.     for (;  defined($_) && !/^$BLOCK_re/o;  $_ = shift(@line)) {
  299.     print "$_\n";
  300.     }
  301.     print "$xsubpp::counter::SECTION_END_MARKER\n" if $WantLineNumbers;
  302. }
  303.  
  304. sub process_keyword($)
  305. {
  306.     my($pattern) = @_ ;
  307.     my $kwd ;
  308.  
  309.     &{"${kwd}_handler"}() 
  310.         while $kwd = check_keyword($pattern) ;
  311. }
  312.  
  313. sub CASE_handler {
  314.     blurt ("Error: `CASE:' after unconditional `CASE:'")
  315.     if $condnum && $cond eq '';
  316.     $cond = $_;
  317.     TrimWhitespace($cond);
  318.     print "   ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
  319.     $_ = '' ;
  320. }
  321.  
  322. sub INPUT_handler {
  323.     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
  324.     last if /^\s*NOT_IMPLEMENTED_YET/;
  325.     next unless /\S/;    # skip blank lines 
  326.  
  327.     TrimWhitespace($_) ;
  328.     my $line = $_ ;
  329.  
  330.     # remove trailing semicolon if no initialisation
  331.     s/\s*;$//g unless /=/ ;
  332.  
  333.     # check for optional initialisation code
  334.     my $var_init = '' ;
  335.     $var_init = $1 if s/\s*(=.*)$//s ;
  336.     $var_init =~ s/"/\\"/g;
  337.  
  338.     s/\s+/ /g;
  339.     my ($var_type, $var_addr, $var_name) = /^(.*?[^& ]) *(\&?) *\b(\w+)$/s
  340.         or blurt("Error: invalid argument declaration '$line'"), next;
  341.  
  342.     # Check for duplicate definitions
  343.     blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
  344.         if $arg_list{$var_name} ++  ;
  345.  
  346.     $thisdone |= $var_name eq "THIS";
  347.     $retvaldone |= $var_name eq "RETVAL";
  348.     $var_types{$var_name} = $var_type;
  349.     print "\t" . &map_type($var_type);
  350.     $var_num = $args_match{$var_name};
  351.  
  352.         $proto_arg[$var_num] = ProtoString($var_type) 
  353.         if $var_num ;
  354.     if ($var_addr) {
  355.         $var_addr{$var_name} = 1;
  356.         $func_args =~ s/\b($var_name)\b/&$1/;
  357.     }
  358.     if ($var_init =~ /^=\s*NO_INIT\s*;?\s*$/) {
  359.         print "\t$var_name;\n";
  360.     } elsif ($var_init =~ /\S/) {
  361.         &output_init($var_type, $var_num, "$var_name $var_init");
  362.     } elsif ($var_num) {
  363.         # generate initialization code
  364.         &generate_init($var_type, $var_num, $var_name);
  365.     } else {
  366.         print ";\n";
  367.     }
  368.     }
  369. }
  370.  
  371. sub OUTPUT_handler {
  372.     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
  373.     next unless /\S/;
  374.     my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ;
  375.     blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
  376.         if $outargs{$outarg} ++ ;
  377.     if (!$gotRETVAL and $outarg eq 'RETVAL') {
  378.         # deal with RETVAL last
  379.         $RETVAL_code = $outcode ;
  380.         $gotRETVAL = 1 ;
  381.         next ;
  382.     }
  383.     blurt ("Error: OUTPUT $outarg not an argument"), next
  384.         unless defined($args_match{$outarg});
  385.     blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
  386.         unless defined $var_types{$outarg} ;
  387.     if ($outcode) {
  388.         print "\t$outcode\n";
  389.     } else {
  390.         $var_num = $args_match{$outarg};
  391.         &generate_output($var_types{$outarg}, $var_num, $outarg); 
  392.     }
  393.     }
  394. }
  395.  
  396. sub CLEANUP_handler() { print_section() } 
  397. sub PREINIT_handler() { print_section() } 
  398. sub INIT_handler()    { print_section() } 
  399.  
  400. sub GetAliases
  401. {
  402.     my ($line) = @_ ;
  403.     my ($orig) = $line ;
  404.     my ($alias) ;
  405.     my ($value) ;
  406.  
  407.     # Parse alias definitions
  408.     # format is
  409.     #    alias = value alias = value ...
  410.  
  411.     while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
  412.         $alias = $1 ;
  413.         $orig_alias = $alias ;
  414.         $value = $2 ;
  415.  
  416.         # check for optional package definition in the alias
  417.     $alias = $Packprefix . $alias if $alias !~ /::/ ;
  418.         
  419.         # check for duplicate alias name & duplicate value
  420.     Warn("Warning: Ignoring duplicate alias '$orig_alias'")
  421.         if defined $XsubAliases{$alias} ;
  422.  
  423.     Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values")
  424.         if $XsubAliasValues{$value} ;
  425.  
  426.     $XsubAliases = 1;
  427.     $XsubAliases{$alias} = $value ;
  428.     $XsubAliasValues{$value} = $orig_alias ;
  429.     }
  430.  
  431.     blurt("Error: Cannot parse ALIAS definitions from '$orig'")
  432.         if $line ;
  433. }
  434.  
  435. sub ALIAS_handler ()
  436. {
  437.     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
  438.     next unless /\S/;
  439.     TrimWhitespace($_) ;
  440.         GetAliases($_) if $_ ;
  441.     }
  442. }
  443.  
  444. sub REQUIRE_handler ()
  445. {
  446.     # the rest of the current line should contain a version number
  447.     my ($Ver) = $_ ;
  448.  
  449.     TrimWhitespace($Ver) ;
  450.  
  451.     death ("Error: REQUIRE expects a version number")
  452.     unless $Ver ;
  453.  
  454.     # check that the version number is of the form n.n
  455.     death ("Error: REQUIRE: expected a number, got '$Ver'")
  456.     unless $Ver =~ /^\d+(\.\d*)?/ ;
  457.  
  458.     death ("Error: xsubpp $Ver (or better) required--this is only $XSUBPP_version.")
  459.         unless $XSUBPP_version >= $Ver ; 
  460. }
  461.  
  462. sub VERSIONCHECK_handler ()
  463. {
  464.     # the rest of the current line should contain either ENABLE or
  465.     # DISABLE
  466.  
  467.     TrimWhitespace($_) ;
  468.  
  469.     # check for ENABLE/DISABLE
  470.     death ("Error: VERSIONCHECK: ENABLE/DISABLE")
  471.         unless /^(ENABLE|DISABLE)/i ;
  472.  
  473.     $WantVersionChk = 1 if $1 eq 'ENABLE' ;
  474.     $WantVersionChk = 0 if $1 eq 'DISABLE' ;
  475.  
  476. }
  477.  
  478. sub PROTOTYPE_handler ()
  479. {
  480.     my $specified ;
  481.  
  482.     death("Error: Only 1 PROTOTYPE definition allowed per xsub") 
  483.         if $proto_in_this_xsub ++ ;
  484.  
  485.     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
  486.     next unless /\S/;
  487.     $specified = 1 ;
  488.     TrimWhitespace($_) ;
  489.         if ($_ eq 'DISABLE') {
  490.        $ProtoThisXSUB = 0 
  491.         }
  492.         elsif ($_ eq 'ENABLE') {
  493.        $ProtoThisXSUB = 1 
  494.         }
  495.         else {
  496.             # remove any whitespace
  497.             s/\s+//g ;
  498.             death("Error: Invalid prototype '$_'")
  499.                 unless ValidProtoString($_) ;
  500.             $ProtoThisXSUB = C_string($_) ;
  501.         }
  502.     }
  503.  
  504.     # If no prototype specified, then assume empty prototype ""
  505.     $ProtoThisXSUB = 2 unless $specified ;
  506.  
  507.     $ProtoUsed = 1 ;
  508.  
  509. }
  510.  
  511. sub SCOPE_handler ()
  512. {
  513.     death("Error: Only 1 SCOPE declaration allowed per xsub") 
  514.         if $scope_in_this_xsub ++ ;
  515.  
  516.     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
  517.         next unless /\S/;
  518.         TrimWhitespace($_) ;
  519.         if ($_ =~ /^DISABLE/i) {
  520.            $ScopeThisXSUB = 0 
  521.         }
  522.         elsif ($_ =~ /^ENABLE/i) {
  523.            $ScopeThisXSUB = 1 
  524.         }
  525.     }
  526.  
  527. }
  528.  
  529. sub PROTOTYPES_handler ()
  530. {
  531.     # the rest of the current line should contain either ENABLE or
  532.     # DISABLE 
  533.  
  534.     TrimWhitespace($_) ;
  535.  
  536.     # check for ENABLE/DISABLE
  537.     death ("Error: PROTOTYPES: ENABLE/DISABLE")
  538.         unless /^(ENABLE|DISABLE)/i ;
  539.  
  540.     $WantPrototypes = 1 if $1 eq 'ENABLE' ;
  541.     $WantPrototypes = 0 if $1 eq 'DISABLE' ;
  542.     $ProtoUsed = 1 ;
  543.  
  544. }
  545.  
  546. sub INCLUDE_handler ()
  547. {
  548.     # the rest of the current line should contain a valid filename
  549.  
  550.     TrimWhitespace($_) ;
  551.  
  552.     death("INCLUDE: filename missing")
  553.         unless $_ ;
  554.  
  555.     death("INCLUDE: output pipe is illegal")
  556.         if /^\s*\|/ ;
  557.  
  558.     # simple minded recursion detector
  559.     death("INCLUDE loop detected")
  560.         if $IncludedFiles{$_} ;
  561.  
  562.     ++ $IncludedFiles{$_} unless /\|\s*$/ ;
  563.  
  564.     # Save the current file context.
  565.     push(@XSStack, {
  566.     type        => 'file',
  567.         LastLine        => $lastline,
  568.         LastLineNo      => $lastline_no,
  569.         Line            => \@line,
  570.         LineNo          => \@line_no,
  571.         Filename        => $filename,
  572.         Handle          => $FH,
  573.         }) ;
  574.  
  575.     ++ $FH ;
  576.  
  577.     # open the new file
  578.     open ($FH, "$_") or death("Cannot open '$_': $!") ;
  579.  
  580.     print Q<<"EOF" ;
  581. #
  582. #/* INCLUDE:  Including '$_' from '$filename' */
  583. #
  584. EOF
  585.  
  586.     $filename = $_ ;
  587.  
  588.     # Prime the pump by reading the first 
  589.     # non-blank line
  590.  
  591.     # skip leading blank lines
  592.     while (<$FH>) {
  593.         last unless /^\s*$/ ;
  594.     }
  595.  
  596.     $lastline = $_ ;
  597.     $lastline_no = $. ;
  598.  
  599. }
  600.  
  601. sub PopFile()
  602. {
  603.     return 0 unless $XSStack[-1]{type} eq 'file' ;
  604.  
  605.     my $data     = pop @XSStack ;
  606.     my $ThisFile = $filename ;
  607.     my $isPipe   = ($filename =~ /\|\s*$/) ;
  608.  
  609.     -- $IncludedFiles{$filename}
  610.         unless $isPipe ;
  611.  
  612.     close $FH ;
  613.  
  614.     $FH         = $data->{Handle} ;
  615.     $filename   = $data->{Filename} ;
  616.     $lastline   = $data->{LastLine} ;
  617.     $lastline_no = $data->{LastLineNo} ;
  618.     @line       = @{ $data->{Line} } ;
  619.     @line_no    = @{ $data->{LineNo} } ;
  620.  
  621.     if ($isPipe and $? ) {
  622.         -- $lastline_no ;
  623.         print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n"  ;
  624.         exit 1 ;
  625.     }
  626.  
  627.     print Q<<"EOF" ;
  628. #
  629. #/* INCLUDE: Returning to '$filename' from '$ThisFile' */
  630. #
  631. EOF
  632.  
  633.     return 1 ;
  634. }
  635.  
  636. sub ValidProtoString ($)
  637. {
  638.     my($string) = @_ ;
  639.  
  640.     if ( $string =~ /^$proto_re+$/ ) {
  641.         return $string ;
  642.     }
  643.  
  644.     return 0 ;
  645. }
  646.  
  647. sub C_string ($)
  648. {
  649.     my($string) = @_ ;
  650.  
  651.     $string =~ s[\\][\\\\]g ;
  652.     $string ;
  653. }
  654.  
  655. sub ProtoString ($)
  656. {
  657.     my ($type) = @_ ;
  658.  
  659.     $proto_letter{$type} or "\$" ;
  660. }
  661.  
  662. sub check_cpp {
  663.     my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
  664.     if (@cpp) {
  665.     my ($cpp, $cpplevel);
  666.     for $cpp (@cpp) {
  667.         if ($cpp =~ /^\#\s*if/) {
  668.         $cpplevel++;
  669.         } elsif (!$cpplevel) {
  670.         Warn("Warning: #else/elif/endif without #if in this function");
  671.         print STDERR "    (precede it with a blank line if the matching #if is outside the function)\n"
  672.             if $XSStack[-1]{type} eq 'if';
  673.         return;
  674.         } elsif ($cpp =~ /^\#\s*endif/) {
  675.         $cpplevel--;
  676.         }
  677.     }
  678.     Warn("Warning: #if without #endif in this function") if $cpplevel;
  679.     }
  680. }
  681.  
  682.  
  683. sub Q {
  684.     my($text) = @_;
  685.     $text =~ s/^#//gm;
  686.     $text =~ s/\[\[/{/g;
  687.     $text =~ s/\]\]/}/g;
  688.     $text;
  689. }
  690.  
  691. open($FH, $filename) or die "cannot open $filename: $!\n";
  692.  
  693. # Identify the version of xsubpp used
  694. print <<EOM ;
  695. /*
  696.  * This file was generated automatically by xsubpp version $XSUBPP_version from the 
  697.  * contents of $filename. Do not edit this file, edit $filename instead.
  698.  *
  699.  *    ANY CHANGES MADE HERE WILL BE LOST! 
  700.  *
  701.  */
  702.  
  703. EOM
  704.  
  705.  
  706. print("#line 1 \"$filename\"\n")
  707.     if $WantLineNumbers;
  708.  
  709. while (<$FH>) {
  710.     last if ($Module, $Package, $Prefix) =
  711.     /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
  712.     print $_;
  713. }
  714. &Exit unless defined $_;
  715.  
  716. $lastline    = $_;
  717. $lastline_no = $.;
  718.  
  719. # Read next xsub into @line from ($lastline, <$FH>).
  720. sub fetch_para {
  721.     # parse paragraph
  722.     death ("Error: Unterminated `#if/#ifdef/#ifndef'")
  723.     if !defined $lastline && $XSStack[-1]{type} eq 'if';
  724.     @line = ();
  725.     @line_no = () ;
  726.     return PopFile() if !defined $lastline;
  727.  
  728.     if ($lastline =~
  729.     /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
  730.     $Module = $1;
  731.     $Package = defined($2) ? $2 : '';    # keep -w happy
  732.     $Prefix  = defined($3) ? $3 : '';    # keep -w happy
  733.     $Prefix = quotemeta $Prefix ;
  734.     ($Module_cname = $Module) =~ s/\W/_/g;
  735.     ($Packid = $Package) =~ tr/:/_/;
  736.     $Packprefix = $Package;
  737.     $Packprefix .= "::" if $Packprefix ne "";
  738.     $lastline = "";
  739.     }
  740.  
  741.     for(;;) {
  742.     if ($lastline !~ /^\s*#/ ||
  743.         # CPP directives:
  744.         #    ANSI:    if ifdef ifndef elif else endif define undef
  745.         #        line error pragma
  746.         #    gcc:    warning include_next
  747.         #   obj-c:    import
  748.         #   others:    ident (gcc notes that some cpps have this one)
  749.         $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) {
  750.         last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
  751.         push(@line, $lastline);
  752.         push(@line_no, $lastline_no) ;
  753.     }
  754.  
  755.     # Read next line and continuation lines
  756.     last unless defined($lastline = <$FH>);
  757.     $lastline_no = $.;
  758.     my $tmp_line;
  759.     $lastline .= $tmp_line
  760.         while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>));
  761.         
  762.     chomp $lastline;
  763.     $lastline =~ s/^\s+$//;
  764.     }
  765.     pop(@line), pop(@line_no) while @line && $line[-1] eq "";
  766.     1;
  767. }
  768.  
  769. PARAGRAPH:
  770. while (fetch_para()) {
  771.     # Print initial preprocessor statements and blank lines
  772.     while (@line && $line[0] !~ /^[^\#]/) {
  773.     my $line = shift(@line);
  774.     print $line, "\n";
  775.     next unless $line =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/;
  776.     my $statement = $+;
  777.     if ($statement eq 'if') {
  778.         $XSS_work_idx = @XSStack;
  779.         push(@XSStack, {type => 'if'});
  780.     } else {
  781.         death ("Error: `$statement' with no matching `if'")
  782.         if $XSStack[-1]{type} ne 'if';
  783.         if ($XSStack[-1]{varname}) {
  784.         push(@InitFileCode, "#endif\n");
  785.         push(@BootCode,     "#endif");
  786.         }
  787.  
  788.         my(@fns) = keys %{$XSStack[-1]{functions}};
  789.         if ($statement ne 'endif') {
  790.         # Hide the functions defined in other #if branches, and reset.
  791.         @{$XSStack[-1]{other_functions}}{@fns} = (1) x @fns;
  792.         @{$XSStack[-1]}{qw(varname functions)} = ('', {});
  793.         } else {
  794.         my($tmp) = pop(@XSStack);
  795.         0 while (--$XSS_work_idx
  796.              && $XSStack[$XSS_work_idx]{type} ne 'if');
  797.         # Keep all new defined functions
  798.         push(@fns, keys %{$tmp->{other_functions}});
  799.         @{$XSStack[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
  800.         }
  801.     }
  802.     }
  803.  
  804.     next PARAGRAPH unless @line;
  805.  
  806.     if ($XSS_work_idx && !$XSStack[$XSS_work_idx]{varname}) {
  807.     # We are inside an #if, but have not yet #defined its xsubpp variable.
  808.     print "#define $cpp_next_tmp 1\n\n";
  809.     push(@InitFileCode, "#if $cpp_next_tmp\n");
  810.     push(@BootCode,     "#if $cpp_next_tmp");
  811.     $XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++;
  812.     }
  813.  
  814.     death ("Code is not inside a function"
  815.        ." (maybe last function was ended by a blank line "
  816.        ." followed by a a statement on column one?)")
  817.     if $line[0] =~ /^\s/;
  818.  
  819.     # initialize info arrays
  820.     undef(%args_match);
  821.     undef(%var_types);
  822.     undef(%var_addr);
  823.     undef(%defaults);
  824.     undef($class);
  825.     undef($static);
  826.     undef($elipsis);
  827.     undef($wantRETVAL) ;
  828.     undef(%arg_list) ;
  829.     undef(@proto_arg) ;
  830.     undef($proto_in_this_xsub) ;
  831.     undef($scope_in_this_xsub) ;
  832.     $ProtoThisXSUB = $WantPrototypes ;
  833.     $ScopeThisXSUB = 0;
  834.  
  835.     $_ = shift(@line);
  836.     while ($kwd = check_keyword("REQUIRE|PROTOTYPES|VERSIONCHECK|INCLUDE")) {
  837.         &{"${kwd}_handler"}() ;
  838.         next PARAGRAPH unless @line ;
  839.         $_ = shift(@line);
  840.     }
  841.  
  842.     if (check_keyword("BOOT")) {
  843.     &check_cpp;
  844.     push (@BootCode, "#line $line_no[@line_no - @line] \"$filename\"")
  845.       if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/;
  846.         push (@BootCode, @line, "") ;
  847.         next PARAGRAPH ;
  848.     }
  849.  
  850.  
  851.     # extract return type, function name and arguments
  852.     my($ret_type) = TidyType($_);
  853.  
  854.     # a function definition needs at least 2 lines
  855.     blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
  856.     unless @line ;
  857.  
  858.     $static = 1 if $ret_type =~ s/^static\s+//;
  859.  
  860.     $func_header = shift(@line);
  861.     blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
  862.     unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*$/s;
  863.  
  864.     ($class, $func_name, $orig_args) =  ($1, $2, $3) ;
  865.     ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
  866.     ($clean_func_name = $func_name) =~ s/^$Prefix//;
  867.     $Full_func_name = "${Packid}_$clean_func_name";
  868.     if ($Is_VMS) { $Full_func_name = $SymSet->addsym($Full_func_name); }
  869.  
  870.     # Check for duplicate function definition
  871.     for $tmp (@XSStack) {
  872.     next unless defined $tmp->{functions}{$Full_func_name};
  873.     Warn("Warning: duplicate function definition '$clean_func_name' detected");
  874.     last;
  875.     }
  876.     $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ;
  877.     %XsubAliases = %XsubAliasValues = ();
  878.  
  879.     @args = split(/\s*,\s*/, $orig_args);
  880.     if (defined($class)) {
  881.     my $arg0 = ((defined($static) or $func_name eq 'new')
  882.             ? "CLASS" : "THIS");
  883.     unshift(@args, $arg0);
  884.     ($orig_args = "$arg0, $orig_args") =~ s/^$arg0, $/$arg0/;
  885.     }
  886.     $orig_args =~ s/"/\\"/g;
  887.     $min_args = $num_args = @args;
  888.     foreach $i (0..$num_args-1) {
  889.         if ($args[$i] =~ s/\.\.\.//) {
  890.             $elipsis = 1;
  891.             $min_args--;
  892.             if ($args[$i] eq '' && $i == $num_args - 1) {
  893.             pop(@args);
  894.             last;
  895.             }
  896.         }
  897.         if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) {
  898.             $min_args--;
  899.             $args[$i] = $1;
  900.             $defaults{$args[$i]} = $2;
  901.             $defaults{$args[$i]} =~ s/"/\\"/g;
  902.         }
  903.         $proto_arg[$i+1] = "\$" ;
  904.     }
  905.     if (defined($class)) {
  906.         $func_args = join(", ", @args[1..$#args]);
  907.     } else {
  908.         $func_args = join(", ", @args);
  909.     }
  910.     @args_match{@args} = 1..@args;
  911.  
  912.     $PPCODE = grep(/^\s*PPCODE\s*:/, @line);
  913.     $CODE = grep(/^\s*CODE\s*:/, @line);
  914.     # Detect CODE: blocks which use ST(n)= or XST_m*(n,v)
  915.     #   to set explicit return values.
  916.     $EXPLICIT_RETURN = ($CODE &&
  917.         ("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x ));
  918.     $ALIAS  = grep(/^\s*ALIAS\s*:/,  @line);
  919.  
  920.     # print function header
  921.     print Q<<"EOF";
  922. #XS(XS_${Full_func_name})
  923. #[[
  924. #    dXSARGS;
  925. EOF
  926.     print Q<<"EOF" if $ALIAS ;
  927. #    dXSI32;
  928. EOF
  929.     if ($elipsis) {
  930.     $cond = ($min_args ? qq(items < $min_args) : 0);
  931.     }
  932.     elsif ($min_args == $num_args) {
  933.     $cond = qq(items != $min_args);
  934.     }
  935.     else {
  936.     $cond = qq(items < $min_args || items > $num_args);
  937.     }
  938.  
  939.     print Q<<"EOF" if $except;
  940. #    char errbuf[1024];
  941. #    *errbuf = '\0';
  942. EOF
  943.  
  944.     if ($ALIAS) 
  945.       { print Q<<"EOF" if $cond }
  946. #    if ($cond)
  947. #       croak("Usage: %s($orig_args)", GvNAME(CvGV(cv)));
  948. EOF
  949.     else 
  950.       { print Q<<"EOF" if $cond }
  951. #    if ($cond)
  952. #    croak("Usage: $pname($orig_args)");
  953. EOF
  954.  
  955.     print Q<<"EOF" if $PPCODE;
  956. #    SP -= items;
  957. EOF
  958.  
  959.     # Now do a block of some sort.
  960.  
  961.     $condnum = 0;
  962.     $cond = '';            # last CASE: condidional
  963.     push(@line, "$END:");
  964.     push(@line_no, $line_no[-1]);
  965.     $_ = '';
  966.     &check_cpp;
  967.     while (@line) {
  968.     &CASE_handler if check_keyword("CASE");
  969.     print Q<<"EOF";
  970. #   $except [[
  971. EOF
  972.  
  973.     # do initialization of input variables
  974.     $thisdone = 0;
  975.     $retvaldone = 0;
  976.     $deferred = "";
  977.     %arg_list = () ;
  978.         $gotRETVAL = 0;
  979.  
  980.     INPUT_handler() ;
  981.     process_keyword("INPUT|PREINIT|ALIAS|PROTOTYPE|SCOPE") ;
  982.  
  983.     print Q<<"EOF" if $ScopeThisXSUB;
  984. #   ENTER;
  985. #   [[
  986. EOF
  987.     
  988.     if (!$thisdone && defined($class)) {
  989.         if (defined($static) or $func_name eq 'new') {
  990.         print "\tchar *";
  991.         $var_types{"CLASS"} = "char *";
  992.         &generate_init("char *", 1, "CLASS");
  993.         }
  994.         else {
  995.         print "\t$class *";
  996.         $var_types{"THIS"} = "$class *";
  997.         &generate_init("$class *", 1, "THIS");
  998.         }
  999.     }
  1000.  
  1001.     # do code
  1002.     if (/^\s*NOT_IMPLEMENTED_YET/) {
  1003.         print "\n\tcroak(\"$pname: not implemented yet\");\n";
  1004.         $_ = '' ;
  1005.     } else {
  1006.         if ($ret_type ne "void") {
  1007.             print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
  1008.                 if !$retvaldone;
  1009.             $args_match{"RETVAL"} = 0;
  1010.             $var_types{"RETVAL"} = $ret_type;
  1011.         }
  1012.  
  1013.         print $deferred;
  1014.  
  1015.         process_keyword("INIT|ALIAS|PROTOTYPE") ;
  1016.  
  1017.         if (check_keyword("PPCODE")) {
  1018.             print_section();
  1019.             death ("PPCODE must be last thing") if @line;
  1020.             print "\tLEAVE;\n" if $ScopeThisXSUB;
  1021.             print "\tPUTBACK;\n\treturn;\n";
  1022.         } elsif (check_keyword("CODE")) {
  1023.             print_section() ;
  1024.         } elsif (defined($class) and $func_name eq "DESTROY") {
  1025.             print "\n\t";
  1026.             print "delete THIS;\n";
  1027.         } else {
  1028.             print "\n\t";
  1029.             if ($ret_type ne "void") {
  1030.                 print "RETVAL = ";
  1031.                 $wantRETVAL = 1;
  1032.             }
  1033.             if (defined($static)) {
  1034.                 if ($func_name eq 'new') {
  1035.                 $func_name = "$class";
  1036.                 } else {
  1037.                 print "${class}::";
  1038.                 }
  1039.             } elsif (defined($class)) {
  1040.                 if ($func_name eq 'new') {
  1041.                 $func_name .= " $class";
  1042.                 } else {
  1043.                 print "THIS->";
  1044.                 }
  1045.             }
  1046.             $func_name =~ s/^($spat)//
  1047.                 if defined($spat);
  1048.             print "$func_name($func_args);\n";
  1049.         }
  1050.     }
  1051.  
  1052.     # do output variables
  1053.     $gotRETVAL = 0;
  1054.     undef $RETVAL_code ;
  1055.     undef %outargs ;
  1056.         process_keyword("OUTPUT|ALIAS|PROTOTYPE"); 
  1057.  
  1058.     # all OUTPUT done, so now push the return value on the stack
  1059.     if ($gotRETVAL && $RETVAL_code) {
  1060.         print "\t$RETVAL_code\n";
  1061.     } elsif ($gotRETVAL || $wantRETVAL) {
  1062.         &generate_output($ret_type, 0, 'RETVAL');
  1063.     }
  1064.  
  1065.     # do cleanup
  1066.     process_keyword("CLEANUP|ALIAS|PROTOTYPE") ;
  1067.  
  1068.     print Q<<"EOF" if $ScopeThisXSUB;
  1069. #   ]]
  1070. EOF
  1071.     print Q<<"EOF" if $ScopeThisXSUB and not $PPCODE;
  1072. #   LEAVE;
  1073. EOF
  1074.  
  1075.     # print function trailer
  1076.     print Q<<EOF;
  1077. #    ]]
  1078. EOF
  1079.     print Q<<EOF if $except;
  1080. #    BEGHANDLERS
  1081. #    CATCHALL
  1082. #    sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
  1083. #    ENDHANDLERS
  1084. EOF
  1085.     if (check_keyword("CASE")) {
  1086.         blurt ("Error: No `CASE:' at top of function")
  1087.         unless $condnum;
  1088.         $_ = "CASE: $_";    # Restore CASE: label
  1089.         next;
  1090.     }
  1091.     last if $_ eq "$END:";
  1092.     death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function");
  1093.     }
  1094.  
  1095.     print Q<<EOF if $except;
  1096. #    if (errbuf[0])
  1097. #    croak(errbuf);
  1098. EOF
  1099.  
  1100.     if ($ret_type ne "void" or $EXPLICIT_RETURN) {
  1101.         print Q<<EOF unless $PPCODE;
  1102. #    XSRETURN(1);
  1103. EOF
  1104.     } else {
  1105.         print Q<<EOF unless $PPCODE;
  1106. #    XSRETURN_EMPTY;
  1107. EOF
  1108.     }
  1109.  
  1110.     print Q<<EOF;
  1111. #]]
  1112. #
  1113. EOF
  1114.  
  1115.     my $newXS = "newXS" ;
  1116.     my $proto = "" ;
  1117.  
  1118.     # Build the prototype string for the xsub
  1119.     if ($ProtoThisXSUB) {
  1120.     $newXS = "newXSproto";
  1121.  
  1122.     if ($ProtoThisXSUB eq 2) {
  1123.         # User has specified empty prototype
  1124.         $proto = ', ""' ;
  1125.     }
  1126.         elsif ($ProtoThisXSUB ne 1) {
  1127.             # User has specified a prototype
  1128.             $proto = ', "' . $ProtoThisXSUB . '"';
  1129.         }
  1130.         else {
  1131.         my $s = ';';
  1132.             if ($min_args < $num_args)  {
  1133.                 $s = ''; 
  1134.         $proto_arg[$min_args] .= ";" ;
  1135.         }
  1136.             push @proto_arg, "$s\@" 
  1137.                 if $elipsis ;
  1138.     
  1139.             $proto = ', "' . join ("", @proto_arg) . '"';
  1140.         }
  1141.     }
  1142.  
  1143.     if (%XsubAliases) {
  1144.     $XsubAliases{$pname} = 0 
  1145.         unless defined $XsubAliases{$pname} ;
  1146.     while ( ($name, $value) = each %XsubAliases) {
  1147.         push(@InitFileCode, Q<<"EOF");
  1148. #        cv = newXS(\"$name\", XS_$Full_func_name, file);
  1149. #        XSANY.any_i32 = $value ;
  1150. EOF
  1151.     push(@InitFileCode, Q<<"EOF") if $proto;
  1152. #        sv_setpv((SV*)cv$proto) ;
  1153. EOF
  1154.         }
  1155.     }
  1156.     else {
  1157.     push(@InitFileCode,
  1158.          "        ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n");
  1159.     }
  1160. }
  1161.  
  1162. # print initialization routine
  1163. print Q<<"EOF";
  1164. ##ifdef __cplusplus
  1165. #extern "C"
  1166. ##endif
  1167. #XS(boot_$Module_cname)
  1168. #[[
  1169. #    dXSARGS;
  1170. #    char* file = __FILE__;
  1171. #
  1172. EOF
  1173.  
  1174. print Q<<"EOF" if $WantVersionChk ;
  1175. #    XS_VERSION_BOOTCHECK ;
  1176. #
  1177. EOF
  1178.  
  1179. print Q<<"EOF" if defined $XsubAliases ;
  1180. #    {
  1181. #        CV * cv ;
  1182. #
  1183. EOF
  1184.  
  1185. print @InitFileCode;
  1186.  
  1187. print Q<<"EOF" if defined $XsubAliases ;
  1188. #    }
  1189. EOF
  1190.  
  1191. if (@BootCode)
  1192. {
  1193.     print "\n    /* Initialisation Section */\n\n" ;
  1194.     @line = @BootCode;
  1195.     print_section();
  1196.     print "\n    /* End of Initialisation Section */\n\n" ;
  1197. }
  1198.  
  1199. print Q<<"EOF";;
  1200. #    ST(0) = &sv_yes;
  1201. #    XSRETURN(1);
  1202. #]]
  1203. EOF
  1204.  
  1205. warn("Please specify prototyping behavior for $filename (see perlxs manual)\n") 
  1206.     unless $ProtoUsed ;
  1207. &Exit;
  1208.  
  1209.  
  1210. sub output_init {
  1211.     local($type, $num, $init) = @_;
  1212.     local($arg) = "ST(" . ($num - 1) . ")";
  1213.  
  1214.     eval qq/print " $init\\\n"/;
  1215. }
  1216.  
  1217. sub Warn
  1218. {
  1219.     # work out the line number
  1220.     my $line_no = $line_no[@line_no - @line -1] ;
  1221.  
  1222.     print STDERR "@_ in $filename, line $line_no\n" ;
  1223. }
  1224.  
  1225. sub blurt 
  1226. { 
  1227.     Warn @_ ;
  1228.     $errors ++ 
  1229. }
  1230.  
  1231. sub death
  1232. {
  1233.     Warn @_ ;
  1234.     exit 1 ;
  1235. }
  1236.  
  1237. sub generate_init {
  1238.     local($type, $num, $var) = @_;
  1239.     local($arg) = "ST(" . ($num - 1) . ")";
  1240.     local($argoff) = $num - 1;
  1241.     local($ntype);
  1242.     local($tk);
  1243.  
  1244.     $type = TidyType($type) ;
  1245.     blurt("Error: '$type' not in typemap"), return 
  1246.     unless defined($type_kind{$type});
  1247.  
  1248.     ($ntype = $type) =~ s/\s*\*/Ptr/g;
  1249.     ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
  1250.     $tk = $type_kind{$type};
  1251.     $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
  1252.     $type =~ tr/:/_/;
  1253.     blurt("Error: No INPUT definition for type '$type' found"), return
  1254.         unless defined $input_expr{$tk} ;
  1255.     $expr = $input_expr{$tk};
  1256.     if ($expr =~ /DO_ARRAY_ELEM/) {
  1257.         blurt("Error: '$subtype' not in typemap"), return 
  1258.         unless defined($type_kind{$subtype});
  1259.         blurt("Error: No INPUT definition for type '$subtype' found"), return
  1260.             unless defined $input_expr{$type_kind{$subtype}} ;
  1261.     $subexpr = $input_expr{$type_kind{$subtype}};
  1262.     $subexpr =~ s/ntype/subtype/g;
  1263.     $subexpr =~ s/\$arg/ST(ix_$var)/g;
  1264.     $subexpr =~ s/\n\t/\n\t\t/g;
  1265.     $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g;
  1266.     $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
  1267.     $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
  1268.     }
  1269.     if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments
  1270.         $ScopeThisXSUB = 1;
  1271.     }
  1272.     if (defined($defaults{$var})) {
  1273.         $expr =~ s/(\t+)/$1    /g;
  1274.         $expr =~ s/        /\t/g;
  1275.         eval qq/print "\\t$var;\\n"/;
  1276.         $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t    $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
  1277.     } elsif ($ScopeThisXSUB or $expr !~ /^\t\$var =/) {
  1278.         eval qq/print "\\t$var;\\n"/;
  1279.         $deferred .= eval qq/"\\n$expr;\\n"/;
  1280.     } else {
  1281.         eval qq/print "$expr;\\n"/;
  1282.     }
  1283. }
  1284.  
  1285. sub generate_output {
  1286.     local($type, $num, $var) = @_;
  1287.     local($arg) = "ST(" . ($num - ($num != 0)) . ")";
  1288.     local($argoff) = $num - 1;
  1289.     local($ntype);
  1290.  
  1291.     $type = TidyType($type) ;
  1292.     if ($type =~ /^array\(([^,]*),(.*)\)/) {
  1293.         print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
  1294.     } else {
  1295.         blurt("Error: '$type' not in typemap"), return
  1296.         unless defined($type_kind{$type});
  1297.             blurt("Error: No OUTPUT definition for type '$type' found"), return
  1298.                 unless defined $output_expr{$type_kind{$type}} ;
  1299.         ($ntype = $type) =~ s/\s*\*/Ptr/g;
  1300.         $ntype =~ s/\(\)//g;
  1301.         ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
  1302.         $expr = $output_expr{$type_kind{$type}};
  1303.         if ($expr =~ /DO_ARRAY_ELEM/) {
  1304.             blurt("Error: '$subtype' not in typemap"), return
  1305.             unless defined($type_kind{$subtype});
  1306.                 blurt("Error: No OUTPUT definition for type '$subtype' found"), return
  1307.                     unless defined $output_expr{$type_kind{$subtype}} ;
  1308.         $subexpr = $output_expr{$type_kind{$subtype}};
  1309.         $subexpr =~ s/ntype/subtype/g;
  1310.         $subexpr =~ s/\$arg/ST(ix_$var)/g;
  1311.         $subexpr =~ s/\$var/${var}[ix_$var]/g;
  1312.         $subexpr =~ s/\n\t/\n\t\t/g;
  1313.         $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
  1314.         eval "print qq\a$expr\a";
  1315.         }
  1316.         elsif ($var eq 'RETVAL') {
  1317.         if ($expr =~ /^\t\$arg = new/) {
  1318.             # We expect that $arg has refcnt 1, so we need to
  1319.             # mortalize it.
  1320.             eval "print qq\a$expr\a";
  1321.             print "\tsv_2mortal(ST(0));\n";
  1322.         }
  1323.         elsif ($expr =~ /^\s*\$arg\s*=/) {
  1324.             # We expect that $arg has refcnt >=1, so we need
  1325.             # to mortalize it. However, the extension may have
  1326.             # returned the built-in perl value, which is
  1327.             # read-only, thus not mortalizable. However, it is
  1328.             # safe to leave it as it is, since it would be
  1329.             # ignored by REFCNT_dec. Builtin values have REFCNT==0.
  1330.             eval "print qq\a$expr\a";
  1331.             print "\tif (SvREFCNT(ST(0))) sv_2mortal(ST(0));\n";
  1332.         }
  1333.         else {
  1334.             # Just hope that the entry would safely write it
  1335.             # over an already mortalized value. By
  1336.             # coincidence, something like $arg = &sv_undef
  1337.             # works too.
  1338.             print "\tST(0) = sv_newmortal();\n";
  1339.             eval "print qq\a$expr\a";
  1340.         }
  1341.         }
  1342.         elsif ($arg =~ /^ST\(\d+\)$/) {
  1343.         eval "print qq\a$expr\a";
  1344.         }
  1345.     }
  1346. }
  1347.  
  1348. sub map_type {
  1349.     my($type) = @_;
  1350.  
  1351.     $type =~ tr/:/_/;
  1352.     $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
  1353.     $type;
  1354. }
  1355.  
  1356.  
  1357. sub Exit {
  1358. # If this is VMS, the exit status has meaning to the shell, so we
  1359. # use a predictable value (SS$_Normal or SS$_Abort) rather than an
  1360. # arbitrary number.
  1361. #    exit ($Is_VMS ? ($errors ? 44 : 1) : $errors) ;
  1362.     exit ($errors ? 1 : 0);
  1363. }
  1364.