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