home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
BURKS 2
/
BURKS_AUG97.ISO
/
SLAKWARE
/
D12
/
PERL1.TGZ
/
perl1.tar
/
usr
/
lib
/
perl5
/
ExtUtils
/
xsubpp
< prev
Wrap
Text File
|
1996-06-28
|
31KB
|
1,219 lines
#!./miniperl
=head1 NAME
xsubpp - compiler to convert Perl XS code into C code
=head1 SYNOPSIS
B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-typemap typemap>]... file.xs
=head1 DESCRIPTION
I<xsubpp> will compile XS code into C code by embedding the constructs
necessary to let C functions manipulate Perl values and creates the glue
necessary to let Perl access those functions. The compiler uses typemaps to
determine how to map C function parameters and variables to Perl values.
The compiler will search for typemap files called I<typemap>. It will use
the following search path to find default typemaps, with the rightmost
typemap taking precedence.
../../../typemap:../../typemap:../typemap:typemap
=head1 OPTIONS
=over 5
=item B<-C++>
Adds ``extern "C"'' to the C code.
=item B<-except>
Adds exception handling stubs to the C code.
=item B<-typemap typemap>
Indicates that a user-supplied typemap should take precedence over the
default typemaps. This option may be used multiple times, with the last
typemap having the highest precedence.
=item B<-v>
Prints the I<xsubpp> version number to standard output, then exits.
=item B<-prototypes>
By default I<xsubpp> will not automatically generate prototype code for
all xsubs. This flag will enable prototypes.
=item B<-noversioncheck>
Disables the run time test that determines if the object file (derived
from the C<.xs> file) and the C<.pm> files have the same version
number.
=back
=head1 ENVIRONMENT
No environment variables are used.
=head1 AUTHOR
Larry Wall
=head1 MODIFICATION HISTORY
See the file F<changes.pod>.
=head1 SEE ALSO
perl(1), perlxs(1), perlxstut(1), perlapi(1)
=cut
# Global Constants
$XSUBPP_version = "1.935";
require 5.002;
use vars '$cplusplus';
sub Q ;
$FH = 'File0000' ;
$usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-s pattern] [-typemap typemap]... file.xs\n";
$proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
$except = "";
$WantPrototypes = -1 ;
$WantVersionChk = 1 ;
$ProtoUsed = 0 ;
SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) {
$flag = shift @ARGV;
$flag =~ s/^-// ;
$spat = shift, next SWITCH if $flag eq 's';
$cplusplus = 1, next SWITCH if $flag eq 'C++';
$WantPrototypes = 0, next SWITCH if $flag eq 'noprototypes';
$WantPrototypes = 1, next SWITCH if $flag eq 'prototypes';
$WantVersionChk = 0, next SWITCH if $flag eq 'noversioncheck';
$WantVersionChk = 1, next SWITCH if $flag eq 'versioncheck';
$except = " TRY", next SWITCH if $flag eq 'except';
push(@tm,shift), next SWITCH if $flag eq 'typemap';
(print "xsubpp version $XSUBPP_version\n"), exit
if $flag eq 'v';
die $usage;
}
if ($WantPrototypes == -1)
{ $WantPrototypes = 0}
else
{ $ProtoUsed = 1 }
@ARGV == 1 or die $usage;
($dir, $filename) = $ARGV[0] =~ m#(.*)/(.*)#
or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)#
or ($dir, $filename) = ('.', $ARGV[0]);
chdir($dir);
# Check for VMS; Config.pm may not be installed yet, but this routine
# is built into VMS perl
if (defined(&VMS::Filespec::vmsify)) { $Is_VMS = 1; $pwd = $ENV{DEFAULT}; }
else { $Is_VMS = 0; chomp($pwd = `pwd`); }
++ $IncludedFiles{$ARGV[0]} ;
my(@XSStack) = ({type => 'none'}); # Stack of conditionals and INCLUDEs
my($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA");
sub TrimWhitespace
{
$_[0] =~ s/^\s+|\s+$//go ;
}
sub TidyType
{
local ($_) = @_ ;
# rationalise any '*' by joining them into bunches and removing whitespace
s#\s*(\*+)\s*#$1#g;
s#(\*+)# $1 #g ;
# change multiple whitespace into a single space
s/\s+/ /g ;
# trim leading & trailing whitespace
TrimWhitespace($_) ;
$_ ;
}
$typemap = shift @ARGV;
foreach $typemap (@tm) {
die "Can't find $typemap in $pwd\n" unless -r $typemap;
}
unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap
../../lib/ExtUtils/typemap ../../../typemap ../../typemap
../typemap typemap);
foreach $typemap (@tm) {
next unless -e $typemap ;
# skip directories, binary files etc.
warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
unless -T $typemap ;
open(TYPEMAP, $typemap)
or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
$mode = 'Typemap';
$junk = "" ;
$current = \$junk;
while (<TYPEMAP>) {
next if /^\s*#/;
if (/^INPUT\s*$/) { $mode = 'Input'; $current = \$junk; next; }
if (/^OUTPUT\s*$/) { $mode = 'Output'; $current = \$junk; next; }
if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk; next; }
if ($mode eq 'Typemap') {
chomp;
my $line = $_ ;
TrimWhitespace($_) ;
# skip blank lines and comment lines
next if /^$/ or /^#/ ;
my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or
warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next;
$type = TidyType($type) ;
$type_kind{$type} = $kind ;
# prototype defaults to '$'
$proto = '$' unless $proto ;
warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
unless ValidProtoString($proto) ;
$proto_letter{$type} = C_string($proto) ;
}
elsif (/^\s/) {
$$current .= $_;
}
elsif ($mode eq 'Input') {
s/\s+$//;
$input_expr{$_} = '';
$current = \$input_expr{$_};
}
else {
s/\s+$//;
$output_expr{$_} = '';
$current = \$output_expr{$_};
}
}
close(TYPEMAP);
}
foreach $key (keys %input_expr) {
$input_expr{$key} =~ s/\n+$//;
}
$END = "!End!\n\n"; # "impossible" keyword (multiple newline)
# Match an XS keyword
$BLOCK_re= '\s*(' . join('|', qw(
REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT
CLEANUP ALIAS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
)) . "|$END)\\s*:";
# Input: ($_, @line) == unparsed input.
# Output: ($_, @line) == (rest of line, following lines).
# Return: the matched keyword if found, otherwise 0
sub check_keyword {
$_ = shift(@line) while !/\S/ && @line;
s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
}
sub print_section {
$_ = shift(@line) while !/\S/ && @line;
for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
print "$_\n";
}
}
sub process_keyword($)
{
my($pattern) = @_ ;
my $kwd ;
&{"${kwd}_handler"}()
while $kwd = check_keyword($pattern) ;
}
sub CASE_handler {
blurt ("Error: `CASE:' after unconditional `CASE:'")
if $condnum && $cond eq '';
$cond = $_;
TrimWhitespace($cond);
print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
$_ = '' ;
}
sub INPUT_handler {
for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
last if /^\s*NOT_IMPLEMENTED_YET/;
next unless /\S/; # skip blank lines
TrimWhitespace($_) ;
my $line = $_ ;
# remove trailing semicolon if no initialisation
s/\s*;$//g unless /=/ ;
# check for optional initialisation code
my $var_init = '' ;
$var_init = $1 if s/\s*(=.*)$//s ;
$var_init =~ s/"/\\"/g;
s/\s+/ /g;
my ($var_type, $var_addr, $var_name) = /^(.*?[^& ]) *(\&?) *\b(\w+)$/s
or blurt("Error: invalid argument declaration '$line'"), next;
# Check for duplicate definitions
blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
if $arg_list{$var_name} ++ ;
$thisdone |= $var_name eq "THIS";
$retvaldone |= $var_name eq "RETVAL";
$var_types{$var_name} = $var_type;
print "\t" . &map_type($var_type);
$var_num = $args_match{$var_name};
$proto_arg[$var_num] = ProtoString($var_type)
if $var_num ;
if ($var_addr) {
$var_addr{$var_name} = 1;
$func_args =~ s/\b($var_name)\b/&$1/;
}
if ($var_init =~ /^=\s*NO_INIT\s*;?\s*$/) {
print "\t$var_name;\n";
} elsif ($var_init =~ /\S/) {
&output_init($var_type, $var_num, "$var_name $var_init");
} elsif ($var_num) {
# generate initialization code
&generate_init($var_type, $var_num, $var_name);
} else {
print ";\n";
}
}
}
sub OUTPUT_handler {
for (; !/^$BLOCK_re/o; $_ =