home *** CD-ROM | disk | FTP | other *** search
/ BURKS 2 / BURKS_AUG97.ISO / SLAKWARE / D12 / PERL1.TGZ / perl1.tar / usr / lib / perl5 / ExtUtils / xsubpp < prev   
Text File  |  1996-06-28  |  31KB  |  1,219 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), perlapi(1)
  75.  
  76. =cut
  77.  
  78. # Global Constants
  79. $XSUBPP_version = "1.935";
  80. require 5.002;
  81. use vars '$cplusplus';
  82.  
  83. sub Q ;
  84.  
  85. $FH = 'File0000' ;
  86.  
  87. $usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-s pattern] [-typemap typemap]... file.xs\n";
  88.  
  89. $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
  90.  
  91. $except = "";
  92. $WantPrototypes = -1 ;
  93. $WantVersionChk = 1 ;
  94. $ProtoUsed = 0 ;
  95. SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) {
  96.     $flag = shift @ARGV;
  97.     $flag =~ s/^-// ;
  98.     $spat = shift,    next SWITCH    if $flag eq 's';
  99.     $cplusplus = 1,    next SWITCH    if $flag eq 'C++';
  100.     $WantPrototypes = 0, next SWITCH    if $flag eq 'noprototypes';
  101.     $WantPrototypes = 1, next SWITCH    if $flag eq 'prototypes';
  102.     $WantVersionChk = 0, next SWITCH    if $flag eq 'noversioncheck';
  103.     $WantVersionChk = 1, next SWITCH    if $flag eq 'versioncheck';
  104.     $except = " TRY",    next SWITCH    if $flag eq 'except';
  105.     push(@tm,shift),    next SWITCH    if $flag eq 'typemap';
  106.     (print "xsubpp version $XSUBPP_version\n"), exit      
  107.     if $flag eq 'v';
  108.     die $usage;
  109. }
  110. if ($WantPrototypes == -1)
  111.   { $WantPrototypes = 0}
  112. else
  113.   { $ProtoUsed = 1 }
  114.  
  115.  
  116. @ARGV == 1 or die $usage;
  117. ($dir, $filename) = $ARGV[0] =~ m#(.*)/(.*)#
  118.     or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)#
  119.     or ($dir, $filename) = ('.', $ARGV[0]);
  120. chdir($dir);
  121. # Check for VMS; Config.pm may not be installed yet, but this routine
  122. # is built into VMS perl
  123. if (defined(&VMS::Filespec::vmsify)) { $Is_VMS = 1; $pwd = $ENV{DEFAULT}; }
  124. else                                 { $Is_VMS = 0; chomp($pwd = `pwd`);   }
  125.  
  126. ++ $IncludedFiles{$ARGV[0]} ;
  127.  
  128. my(@XSStack) = ({type => 'none'});    # Stack of conditionals and INCLUDEs
  129. my($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA");
  130.  
  131. sub TrimWhitespace
  132. {
  133.     $_[0] =~ s/^\s+|\s+$//go ;
  134. }
  135.  
  136. sub TidyType
  137. {
  138.     local ($_) = @_ ;
  139.  
  140.     # rationalise any '*' by joining them into bunches and removing whitespace
  141.     s#\s*(\*+)\s*#$1#g;
  142.     s#(\*+)# $1 #g ;
  143.  
  144.     # change multiple whitespace into a single space
  145.     s/\s+/ /g ;
  146.     
  147.     # trim leading & trailing whitespace
  148.     TrimWhitespace($_) ;
  149.  
  150.     $_ ;
  151. }
  152.  
  153. $typemap = shift @ARGV;
  154. foreach $typemap (@tm) {
  155.     die "Can't find $typemap in $pwd\n" unless -r $typemap;
  156. }
  157. unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap
  158.                 ../../lib/ExtUtils/typemap ../../../typemap ../../typemap
  159.                 ../typemap typemap);
  160. foreach $typemap (@tm) {
  161.     next unless -e $typemap ;
  162.     # skip directories, binary files etc.
  163.     warn("Warning: ignoring non-text typemap file '$typemap'\n"), next 
  164.     unless -T $typemap ;
  165.     open(TYPEMAP, $typemap) 
  166.     or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
  167.     $mode = 'Typemap';
  168.     $junk = "" ;
  169.     $current = \$junk;
  170.     while (<TYPEMAP>) {
  171.     next if /^\s*#/;
  172.     if (/^INPUT\s*$/)   { $mode = 'Input';   $current = \$junk;  next; }
  173.     if (/^OUTPUT\s*$/)  { $mode = 'Output';  $current = \$junk;  next; }
  174.     if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk;  next; }
  175.     if ($mode eq 'Typemap') {
  176.         chomp;
  177.         my $line = $_ ;
  178.             TrimWhitespace($_) ;
  179.         # skip blank lines and comment lines
  180.         next if /^$/ or /^#/ ;
  181.         my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or
  182.         warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next;
  183.             $type = TidyType($type) ;
  184.         $type_kind{$type} = $kind ;
  185.             # prototype defaults to '$'
  186.             $proto = '$' unless $proto ;
  187.             warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n") 
  188.                 unless ValidProtoString($proto) ;
  189.             $proto_letter{$type} = C_string($proto) ;
  190.     }
  191.     elsif (/^\s/) {
  192.         $$current .= $_;
  193.     }
  194.     elsif ($mode eq 'Input') {
  195.         s/\s+$//;
  196.         $input_expr{$_} = '';
  197.         $current = \$input_expr{$_};
  198.     }
  199.     else {
  200.         s/\s+$//;
  201.         $output_expr{$_} = '';
  202.         $current = \$output_expr{$_};
  203.     }
  204.     }
  205.     close(TYPEMAP);
  206. }
  207.  
  208. foreach $key (keys %input_expr) {
  209.     $input_expr{$key} =~ s/\n+$//;
  210. }
  211.  
  212. $END = "!End!\n\n";        # "impossible" keyword (multiple newline)
  213.  
  214. # Match an XS keyword
  215. $BLOCK_re= '\s*(' . join('|', qw(
  216.     REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT 
  217.     CLEANUP ALIAS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
  218.     )) . "|$END)\\s*:";
  219.  
  220. # Input:  ($_, @line) == unparsed input.
  221. # Output: ($_, @line) == (rest of line, following lines).
  222. # Return: the matched keyword if found, otherwise 0
  223. sub check_keyword {
  224.     $_ = shift(@line) while !/\S/ && @line;
  225.     s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
  226. }
  227.  
  228.  
  229. sub print_section {
  230.     $_ = shift(@line) while !/\S/ && @line;
  231.     for (;  defined($_) && !/^$BLOCK_re/o;  $_ = shift(@line)) {
  232.     print "$_\n";
  233.     }
  234. }
  235.  
  236. sub process_keyword($)
  237. {
  238.     my($pattern) = @_ ;
  239.     my $kwd ;
  240.  
  241.     &{"${kwd}_handler"}() 
  242.         while $kwd = check_keyword($pattern) ;
  243. }
  244.  
  245. sub CASE_handler {
  246.     blurt ("Error: `CASE:' after unconditional `CASE:'")
  247.     if $condnum && $cond eq '';
  248.     $cond = $_;
  249.     TrimWhitespace($cond);
  250.     print "   ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
  251.     $_ = '' ;
  252. }
  253.  
  254. sub INPUT_handler {
  255.     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
  256.     last if /^\s*NOT_IMPLEMENTED_YET/;
  257.     next unless /\S/;    # skip blank lines 
  258.  
  259.     TrimWhitespace($_) ;
  260.     my $line = $_ ;
  261.  
  262.     # remove trailing semicolon if no initialisation
  263.     s/\s*;$//g unless /=/ ;
  264.  
  265.     # check for optional initialisation code
  266.     my $var_init = '' ;
  267.     $var_init = $1 if s/\s*(=.*)$//s ;
  268.     $var_init =~ s/"/\\"/g;
  269.  
  270.     s/\s+/ /g;
  271.     my ($var_type, $var_addr, $var_name) = /^(.*?[^& ]) *(\&?) *\b(\w+)$/s
  272.         or blurt("Error: invalid argument declaration '$line'"), next;
  273.  
  274.     # Check for duplicate definitions
  275.     blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
  276.         if $arg_list{$var_name} ++  ;
  277.  
  278.     $thisdone |= $var_name eq "THIS";
  279.     $retvaldone |= $var_name eq "RETVAL";
  280.     $var_types{$var_name} = $var_type;
  281.     print "\t" . &map_type($var_type);
  282.     $var_num = $args_match{$var_name};
  283.  
  284.         $proto_arg[$var_num] = ProtoString($var_type) 
  285.         if $var_num ;
  286.     if ($var_addr) {
  287.         $var_addr{$var_name} = 1;
  288.         $func_args =~ s/\b($var_name)\b/&$1/;
  289.     }
  290.     if ($var_init =~ /^=\s*NO_INIT\s*;?\s*$/) {
  291.         print "\t$var_name;\n";
  292.     } elsif ($var_init =~ /\S/) {
  293.         &output_init($var_type, $var_num, "$var_name $var_init");
  294.     } elsif ($var_num) {
  295.         # generate initialization code
  296.         &generate_init($var_type, $var_num, $var_name);
  297.     } else {
  298.         print ";\n";
  299.     }
  300.     }
  301. }
  302.  
  303. sub OUTPUT_handler {
  304.     for (;  !/^$BLOCK_re/o;  $_ =