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