diff options
Diffstat (limited to 'utils/h2xs.PL')
| -rw-r--r-- | utils/h2xs.PL | 347 |
1 files changed, 310 insertions, 37 deletions
diff --git a/utils/h2xs.PL b/utils/h2xs.PL index 6dfd4f5ea1..5e22b7096e 100644 --- a/utils/h2xs.PL +++ b/utils/h2xs.PL @@ -12,10 +12,9 @@ use File::Basename qw(&basename &dirname); # This forces PL files to create target in same directory as PL file. # This is so that make depend always knows where to find PL derivatives. -chdir(dirname($0)); -($file = basename($0)) =~ s/\.PL$//; -$file =~ s/\.pl$// - if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving" +chdir dirname($0); +$file = basename($0, '.PL'); +$file .= '.com' if $^O eq 'VMS'; open OUT,">$file" or die "Can't create $file: $!"; @@ -25,9 +24,9 @@ print "Extracting $file (with variable substitutions)\n"; # You can use $Config{...} to use Configure variables. print OUT <<"!GROK!THIS!"; -$Config{'startperl'} - eval 'exec perl -S \$0 "\$@"' - if 0; +$Config{startperl} + eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}' + if \$running_under_some_shell; !GROK!THIS! # In the following, perl variables are not expanded during extraction. @@ -40,7 +39,7 @@ h2xs - convert .h C header files to Perl extensions =head1 SYNOPSIS -B<h2xs> [B<-AOPXcf>] [B<-v> version] [B<-n> module_name] [headerfile [extra_libraries]] +B<h2xs> [B<-AOPXcdf>] [B<-v> version] [B<-n> module_name] [B<-p> prefix] [B<-s> sub] [headerfile [extra_libraries]] B<h2xs> B<-h> @@ -72,6 +71,11 @@ in the extra-libraries argument. Omit all autoload facilities. This is the same as B<-c> but also removes the S<C<require AutoLoader>> statement from the .pm file. +=item B<-F> + +Additional flags to specify to C preprocessor when scanning header for +function declarations. Should not be used without B<-x>. + =item B<-O> Allows a pre-existing extension directory to be overwritten. @@ -80,11 +84,20 @@ Allows a pre-existing extension directory to be overwritten. Omit the autogenerated stub POD section. +=item B<-X> + +Omit the XS portion. Used to generate templates for a module which is not +XS-based. + =item B<-c> Omit C<constant()> from the .xs file and corresponding specialised C<AUTOLOAD> from the .pm file. +=item B<-d> + +Turn on debugging messages. + =item B<-f> Allows an extension to be created for a header even if that header is @@ -98,15 +111,34 @@ Print the usage, help and version for this h2xs and exit. Specifies a name to be used for the extension, e.g., S<-n RPC::DCE> +=item B<-p> I<prefix> + +Specify a prefix which should be removed from the Perl function names, e.g., S<-p sec_rgy_> +This sets up the XS B<PREFIX> keyword and removes the prefix from functions that are +autoloaded via the C<constant()> mechansim. + +=item B<-s> I<sub1,sub2> + +Create a perl subroutine for the specified macros rather than autoload with the constant() subroutine. +These macros are assumed to have a return type of B<char *>, e.g., S<-s sec_rgy_wildcard_name,sec_rgy_wildcard_sid>. + =item B<-v> I<version> Specify a version number for this extension. This version number is added to the templates. The default is 0.01. -=item B<-X> +=item B<-x> -Omit the XS portion. Used to generate templates for a module which is not -XS-based. +Automatically generate XSUBs basing on function declarations in the +header file. The package C<C::Scan> should be installed. If this +option is specified, the name of the header file may look like +C<NAME1,NAME2>. In this case NAME1 is used instead of the specified string, +but XSUBs are emitted only for the declarations included from file NAME2. + +Note that some types of arguments/return-values for functions may +result in XSUB-declarations/typemap-entries which need +hand-editing. Such may be objects which cannot be converted from/to a +pointer (like C<long long>), pointers to functions, or arrays. =back @@ -138,6 +170,26 @@ XS-based. # additional directory /opt/net/lib h2xs rpcsvc/rusers -L/opt/net/lib -lrpc + # Extension is DCE::rgynbase + # prefix "sec_rgy_" is dropped from perl function names + h2xs -n DCE::rgynbase -p sec_rgy_ dce/rgynbase + + # Extension is DCE::rgynbase + # prefix "sec_rgy_" is dropped from perl function names + # subroutines are created for sec_rgy_wildcard_name and sec_rgy_wildcard_sid + h2xs -n DCE::rgynbase -p sec_rgy_ \ + -s sec_rgy_wildcard_name,sec_rgy_wildcard_sid dce/rgynbase + + # Make XS without defines in perl.h, but with function declarations + # visible from perl.h. Name of the extension is perl1. + # When scanning perl.h, define -DEXT=extern -DdEXT= -DINIT(x)= + # Extra backslashes below because the string is passed to shell. + # Note that a directory with perl header files would + # be added automatically to include path. + h2xs -xAn perl1 -F "-DEXT=extern -DdEXT= -DINIT\(x\)=" perl.h + + # Same with function declaration in proto.h as visible from perl.h. + h2xs -xAn perl2 perl.h,proto.h =head1 ENVIRONMENT @@ -153,28 +205,33 @@ L<perl>, L<perlxstut>, L<ExtUtils::MakeMaker>, and L<AutoLoader>. =head1 DIAGNOSTICS -The usual warnings if it can't read or write the files involved. +The usual warnings if it cannot read or write the files involved. =cut -my( $H2XS_VERSION ) = '$Revision: 1.1.1.1 $' =~ /\$Revision:\s+([^\s]+)/; +my( $H2XS_VERSION ) = ' $Revision: 1.18 $ ' =~ /\$Revision:\s+([^\s]+)/; my $TEMPLATE_VERSION = '0.01'; use Getopt::Std; sub usage{ warn "@_\n" if @_; - die "h2xs [-AOPXcfh] [-v version] [-n module_name] [headerfile [extra_libraries]] + die "h2xs [-AOPXcdfh] [-v version] [-n module_name] [-p prefix] [-s subs] [headerfile [extra_libraries]] version: $H2XS_VERSION - -f Force creation of the extension even if the C header does not exist. - -n Specify a name to use for the extension (recommended). - -c Omit the constant() function and specialised AUTOLOAD from the XS file. -A Omit all autoloading facilities (implies -c). + -F Additional flags for C preprocessor (used with -x). -O Allow overwriting of a pre-existing extension directory. -P Omit the stub POD section. -X Omit the XS portion. - -v Specify a version number for this extension. + -c Omit the constant() function and specialised AUTOLOAD from the XS file. + -d Turn on debugging messages. + -f Force creation of the extension even if the C header does not exist. -h Display this help message + -n Specify a name to use for the extension (recommended). + -p Specify a prefix which should be removed from the Perl function names. + -s Create subroutines for specified macros. + -v Specify a version number for this extension. + -x Autogenerate XSUBs using C::Scan. extra_libraries are any libraries that might be needed for loading the extension, e.g. -lm would try to link in the math library. @@ -182,7 +239,7 @@ extra_libraries } -getopts("AOPXcfhv:n:") || usage; +getopts("AF:OPXcdfhn:p:s:v:x") || usage; usage if $opt_h; @@ -190,6 +247,7 @@ if( $opt_v ){ $TEMPLATE_VERSION = $opt_v; } $opt_c = 1 if $opt_A; +%const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s; $path_h = shift; $extralibs = "@ARGV"; @@ -204,22 +262,53 @@ if( $path_h ){ warn "Nesting of headerfile ignored with -n\n"; } $path_h .= ".h" unless $path_h =~ /\.h$/; - $path_h = "/usr/include/$path_h" unless $path_h =~ m#^[./]#; - die "Can't find $path_h\n" if ( ! $opt_f && ! -f $path_h ); - - # Scan the header file (we should deal with nested header files) - # Record the names of simple #define constants into const_names - # Function prototypes are not (currently) processed. - open(CH, "<$path_h") || die "Can't open $path_h: $!\n"; - while (<CH>) { - if (/^#[ \t]*define\s+(\w+)\b\s*[^("]/) { + $fullpath = $path_h; + $path_h =~ s/,.*$// if $opt_x; + if ($^O eq 'VMS') { # Consider overrides of default location + if ($path_h !~ m![:>\[]!) { + my($hadsys) = ($path_h =~ s!^sys/!!i); + if ($ENV{'DECC$System_Include'}) { $path_h = "DECC\$System_Include:$path_h"; } + elsif ($ENV{'DECC$Library_Include'}) { $path_h = "DECC\$Library_Include:$path_h"; } + elsif ($ENV{'GNU_CC_Include'}) { $path_h = 'GNU_CC_Include:' . + ($hadsys ? '[vms]' : '[000000]') . $path_h; } + elsif ($ENV{'VAXC$Include'}) { $path_h = "VAXC\$_Include:$path_h"; } + else { $path_h = "Sys\$Library:$path_h"; } + } + } + elsif ($^O eq 'os2') { + $path_h = "/usr/include/$path_h" + if $path_h !~ m#^([a-z]:)?[./]#i and -r "/usr/include/$path_h"; + } + else { + $path_h = "/usr/include/$path_h" + if $path_h !~ m#^[./]# and -r "/usr/include/$path_h"; + } + + if (!$opt_c) { + die "Can't find $path_h\n" if ( ! $opt_f && ! -f $path_h ); + # Scan the header file (we should deal with nested header files) + # Record the names of simple #define constants into const_names + # Function prototypes are not (currently) processed. + open(CH, "<$path_h") || die "Can't open $path_h: $!\n"; + while (<CH>) { + if (/^#[ \t]*define\s+([\$\w]+)\b\s*[^("]/) { + print "Matched $_ ($1)\n" if $opt_d; $_ = $1; next if /^_.*_h_*$/i; # special case, but for what? + if (defined $opt_p) { + if (!/^$opt_p(\d)/) { + ++$prefix{$_} if s/^$opt_p//; + } + else { + warn "can't remove $opt_p prefix from '$_'!\n"; + } + } $const_names{$_}++; - } + } + } + close(CH); + @const_names = sort keys %const_names; } - close(CH); - @const_names = sort keys %const_names; } @@ -262,9 +351,36 @@ if( $nested ){ mkdir($modpname, 0777); chdir($modpname) || die "Can't chdir $ext$modpname: $!\n"; +my %types_seen; +my %std_types; +my $fdecls; +my $fdecls_parsed; + if( ! $opt_X ){ # use XS, unless it was disabled open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n"; + if ($opt_x) { + require C::Scan; # Run-time directive + require Config; # Run-time directive + warn "Scanning typemaps...\n"; + get_typemap(); + my $c; + my $filter; + my $filename = $path_h; + my $addflags = $opt_F || ''; + if ($fullpath =~ /,/) { + $filename = $`; + $filter = $'; + } + warn "Scanning $filename for functions...\n"; + $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter, + 'add_cppflags' => $addflags; + $c->set('includeDirs' => ["$Config::Config{archlib}/CORE"]); + + $fdecls_parsed = $c->get('parsed_fdecls'); + $fdecls = $c->get('fdecls'); + } } + open(PM, ">$modfname.pm") || die "Can't create $ext$modpname/$modfname.pm: $!\n"; $" = "\n\t"; @@ -279,7 +395,7 @@ END if( $opt_X || $opt_c || $opt_A ){ # we won't have our own AUTOLOAD(), so won't have $AUTOLOAD print PM <<'END'; -use vars qw($VERSION @ISA @EXPORT); +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); END } else{ @@ -287,7 +403,7 @@ else{ # will want Carp. print PM <<'END'; use Carp; -use vars qw($VERSION @ISA @EXPORT $AUTOLOAD); +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD); END } @@ -402,6 +518,25 @@ END $author = "A. U. Thor"; $email = 'a.u.thor@a.galaxy.far.far.away'; +my $const_doc = ''; +my $fdecl_doc = ''; +if (@const_names and not $opt_P) { + $const_doc = <<EOD; +\n=head1 Exported constants + + @{[join "\n ", @const_names]} + +EOD +} +if (defined $fdecls and @$fdecls and not $opt_P) { + $fdecl_doc = <<EOD; +\n=head1 Exported functions + + @{[join "\n ", @$fdecls]} + +EOD +} + $pod = <<"END" unless $opt_P; ## Below is the stub of documentation for your module. You better edit it! # @@ -421,7 +556,7 @@ $pod = <<"END" unless $opt_P; #unedited. # #Blah blah blah. -# +#$const_doc$fdecl_doc #=head1 AUTHOR # #$author, $email @@ -457,6 +592,7 @@ END if( $path_h ){ my($h) = $path_h; $h =~ s#^/usr/include/##; + if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; } print XS <<"END"; #include <$h> @@ -498,10 +634,12 @@ foreach $letter (@AZ, @az, @under) { my($name); while (substr($const_names[0],0,1) eq $letter) { $name = shift(@const_names); + $macro = $prefix{$name} ? "$opt_p$name" : $name; + next if $const_xsub{$macro}; print XS <<"END"; if (strEQ(name, "$name")) -#ifdef $name - return $name; +#ifdef $macro + return $macro; #else goto not_there; #endif @@ -524,13 +662,32 @@ not_there: END } +$prefix = "PREFIX = $opt_p" if defined $opt_p; # Now switch from C to XS by issuing the first MODULE declaration: print XS <<"END"; -MODULE = $module PACKAGE = $module +MODULE = $module PACKAGE = $module $prefix END +foreach (sort keys %const_xsub) { + print XS <<"END"; +char * +$_() + + CODE: +#ifdef $_ + RETVAL = $_; +#else + croak("Your vendor has not defined the $module macro $_"); +#endif + + OUTPUT: + RETVAL + +END +} + # If a constant() function was written then output a corresponding # XS declaration: print XS <<"END" unless $opt_c; @@ -542,7 +699,113 @@ constant(name,arg) END +my %seen_decl; + + +sub print_decl { + my $fh = shift; + my $decl = shift; + my ($type, $name, $args) = @$decl; + return if $seen_decl{$name}++; # Need to do the same for docs as well? + + my @argnames = map {$_->[1]} @$args; + my @argtypes = map { normalize_type( $_->[0] ) } @$args; + my @argarrays = map { $_->[4] || '' } @$args; + my $numargs = @$args; + if ($numargs and $argtypes[-1] eq '...') { + $numargs--; + $argnames[-1] = '...'; + } + local $" = ', '; + $type = normalize_type($type); + + print $fh <<"EOP"; + +$type +$name(@argnames) +EOP + + for $arg (0 .. $numargs - 1) { + print $fh <<"EOP"; + $argtypes[$arg] $argnames[$arg]$argarrays[$arg] +EOP + } +} + +# Should be called before any actual call to normalize_type(). +sub get_typemap { + # We do not want to read ./typemap by obvios reasons. + my @tm = qw(../../../typemap ../../typemap ../typemap); + my $stdtypemap = "$Config::Config{privlib}/ExtUtils/typemap"; + unshift @tm, $stdtypemap; + my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ; + my $image; + + foreach $typemap (@tm) { + next unless -e $typemap ; + # skip directories, binary files etc. + warn " Scanning $typemap\n"; + 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; + my $mode = 'Typemap'; + while (<TYPEMAP>) { + next if /^\s*\#/; + if (/^INPUT\s*$/) { $mode = 'Input'; next; } + elsif (/^OUTPUT\s*$/) { $mode = 'Output'; next; } + elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; } + elsif ($mode eq 'Typemap') { + next if /^\s*($|\#)/ ; + if ( ($type, $image) = + /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/o + # This may reference undefined functions: + and not ($image eq 'T_PACKED' and $typemap eq $stdtypemap)) { + normalize_type($type); + } + } + } + close(TYPEMAP) or die "Cannot close $typemap: $!"; + } + %std_types = %types_seen; + %types_seen = (); +} + + +sub normalize_type { + my $ignore_mods = '(?:\b(?:__const__|static|inline|__inline__)\b\s*)*'; + my $type = shift; + $type =~ s/$ignore_mods//go; + $type =~ s/([\]\[()])/ \1 /g; + $type =~ s/\s+/ /g; + $type =~ s/\s+$//; + $type =~ s/^\s+//; + $type =~ s/\b\*/ */g; + $type =~ s/\*\b/* /g; + $type =~ s/\*\s+(?=\*)/*/g; + $types_seen{$type}++ + unless $type eq '...' or $type eq 'void' or $std_types{$type}; + $type; +} + +if ($opt_x) { + for $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) } +} + close XS; + +if (%types_seen) { + my $type; + warn "Writing $ext$modpname/typemap\n"; + open TM, ">typemap" or die "Cannot open typemap file for write: $!"; + + for $type (keys %types_seen) { + print TM $type, "\t" x (6 - int((length $type)/8)), "T_PTROBJ\n" + } + + close TM or die "Cannot close typemap file for write: $!"; +} + } # if( ! $opt_X ) warn "Writing $ext$modpname/Makefile.PL\n"; @@ -609,6 +872,16 @@ if (!@files) { unless ($@) { @files = readdir(D); closedir(D); } } if (!@files) { @files = map {chomp && $_} `ls`; } +if ($^O eq 'VMS') { + foreach (@files) { + # Clip trailing '.' for portability -- non-VMS OSs don't expect it + s%\.$%%; + # Fix up for case-sensitive file systems + s/$modfname/$modfname/i && next; + $_ = "\U$_" if $_ eq 'manifest' or $_ eq 'changes'; + $_ = 'Makefile.PL' if $_ eq 'makefile.pl'; + } +} print MANI join("\n",@files); close MANI; !NO!SUBS! |