X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=utils%2Fh2xs.PL;h=2885c6f5ee284f2de1ad88c13c37b57212bf8886;hb=aacdac464b116367cebe4e1e19fd4b760789bbdf;hp=6dfd4f5ea1db1769d0b1d17f39a98caeb4e6abbc;hpb=cfe4554026dfe078c2d7c706ace0e327f16b2c05;p=p5sagit%2Fp5-mst-13.2.git diff --git a/utils/h2xs.PL b/utils/h2xs.PL index 6dfd4f5..2885c6f 100644 --- a/utils/h2xs.PL +++ b/utils/h2xs.PL @@ -2,6 +2,7 @@ use Config; use File::Basename qw(&basename &dirname); +use Cwd; # List explicitly here the variables you want Configure to # generate. Metaconfig only looks for shell variables, so you @@ -12,10 +13,10 @@ 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" +my $origdir = cwd; +chdir dirname($0); +my $file = basename($0, '.PL'); +$file .= '.com' if $^O eq 'VMS'; open OUT,">$file" or die "Can't create $file: $!"; @@ -25,9 +26,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,19 +41,19 @@ h2xs - convert .h C header files to Perl extensions =head1 SYNOPSIS -B [B<-AOPXcf>] [B<-v> version] [B<-n> module_name] [headerfile [extra_libraries]] +B [B<-ACOPXacdfkmx>] [B<-F> addflags] [B<-M> fmask] [B<-n> module_name] [B<-o> tmask] [B<-p> prefix] [B<-s> subs] [B<-v> version] [headerfile ... [extra_libraries]] B B<-h> =head1 DESCRIPTION -I builds a Perl extension from any C header file. The extension will -include functions which can be used to retrieve the value of any #define -statement which was in the C header. +I builds a Perl extension from C header files. The extension +will include functions which can be used to retrieve the value of any +#define statement which was in the C header files. The I will be used for the name of the extension. If -module_name is not supplied then the name of the header file will be used, -with the first character capitalized. +module_name is not supplied then the name of the first header file +will be used, with the first character capitalized. If the extension might need extra libraries, they should be included here. The extension Makefile.PL will take care of checking whether @@ -70,7 +71,21 @@ in the extra-libraries argument. =item B<-A> Omit all autoload facilities. This is the same as B<-c> but also removes the -S> statement from the .pm file. +S> statement from the .pm file. + +=item B<-C> + +Omits creation of the F file, and adds a HISTORY section to +the POD template. + +=item B<-F> I + +Additional flags to specify to C preprocessor when scanning header for +function declarations. Should not be used without B<-x>. + +=item B<-M> I + +selects functions/macros to process. =item B<-O> @@ -80,33 +95,113 @@ 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. C<-c> and C<-f> are implicitly enabled. + +=item B<-a> + +Generate an accessor method for each element of structs and unions. The +generated methods are named after the element name; will return the current +value of the element if called without additional arguments; and will set +the element to the supplied value (and return the new value) if called with +an additional argument. Embedded structures and unions are returned as a +pointer rather than the complete structure, to facilitate chained calls. + +These methods all apply to the Ptr type for the structure; additionally +two methods are constructed for the structure type itself, C<_to_ptr> +which returns a Ptr type pointing to the same structure, and a C +method to construct and return a new structure, initialised to zeroes. + =item B<-c> Omit C from the .xs file and corresponding specialised C 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 -not found in /usr/include. +not found in standard include directories. =item B<-h> Print the usage, help and version for this h2xs and exit. +=item B<-k> + +For function arguments declared as C, omit the const attribute in the +generated XS code. + +=item B<-m> + +B: for each variable declared in the header file(s), declare +a perl variable of the same name magically tied to the C variable. + =item B<-n> I Specifies a name to be used for the extension, e.g., S<-n RPC::DCE> +=item B<-o> I + +Use "opaque" data type for the C types matched by the regular +expression, even if these types are C-equivalent to types +from typemaps. Should not be used without B<-x>. + +This may be useful since, say, types which are C-equivalent +to integers may represent OS-related handles, and one may want to work +with these handles in OO-way, as in C<$handle-Edo_something()>. +Use C<-o .> if you want to handle all the Ced types as opaque types. + +The type-to-match is whitewashed (except for commas, which have no +whitespace before them, and multiple C<*> which have no whitespace +between them). + +=item B<-p> I + +Specify a prefix which should be removed from the Perl function names, e.g., S<-p sec_rgy_> +This sets up the XS B keyword and removes the prefix from functions that are +autoloaded via the C mechanism. + +=item B<-s> I + +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, e.g., S<-s sec_rgy_wildcard_name,sec_rgy_wildcard_sid>. + =item B<-v> I 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 should be installed. If this +option is specified, the name of the header file may look like +C. 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), pointers to functions, or arrays. See +also the section on L>. + +=item B<-b> I + +Generates a .pm file which is backwards compatible with the specified +perl version. + +For versions < 5.6.0, the changes are. + - no use of 'our' (uses 'use vars' instead) + - no 'use warnings' + +Specifying a compatibility version higher than the version of perl you +are using to run h2xs will have no effect. =back @@ -138,6 +233,32 @@ 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 + + # Same but select only functions which match /^av_/ + h2xs -M '^av_' -xAn perl2 perl.h,proto.h + + # Same but treat SV* etc as "opaque" types + h2xs -o '^[S]V \*$' -M '^av_' -xAn perl2 perl.h,proto.h =head1 ENVIRONMENT @@ -153,28 +274,105 @@ L, L, L, and L. =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. + +=head1 LIMITATIONS of B<-x> + +F would not distinguish whether an argument to a C function +which is of the form, say, C, is an input, output, or +input/output parameter. In particular, argument declarations of the +form + + int + foo(n) + int *n + +should be better rewritten as + + int + foo(n) + int &n + +if C is an input parameter. + +Additionally, F has no facilities to intuit that a function + + int + foo(addr,l) + char *addr + int l + +takes a pair of address and length of data at this address, so it is better +to rewrite this function as + + int + foo(sv) + SV *addr + PREINIT: + STRLEN len; + char *s; + CODE: + s = SvPV(sv,len); + RETVAL = foo(s, len); + OUTPUT: + RETVAL + +or alternately + + static int + my_foo(SV *sv) + { + STRLEN len; + char *s = SvPV(sv,len); + + return foo(s, len); + } + + MODULE = foo PACKAGE = foo PREFIX = my_ + + int + foo(sv) + SV *sv + +See L and L for additional details. =cut -my( $H2XS_VERSION ) = '$Revision: 1.1.1.1 $' =~ /\$Revision:\s+([^\s]+)/; +use strict; + + +my( $H2XS_VERSION ) = ' $Revision: 1.20 $ ' =~ /\$Revision:\s+([^\s]+)/; my $TEMPLATE_VERSION = '0.01'; +my @ARGS = @ARGV; +my $compat_version = $]; use Getopt::Std; sub usage{ warn "@_\n" if @_; - die "h2xs [-AOPXcfh] [-v version] [-n module_name] [headerfile [extra_libraries]] + die "h2xs [-ACOPXacdfhkmx] [-F addflags] [-M fmask] [-n module_name] [-o tmask] [-p prefix] [-s subs] [-v version] [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). + -C Omit creating the Changes file, add HISTORY heading to stub POD. + -F Additional flags for C preprocessor (used with -x). + -M Mask to select C functions/macros (default is select all). -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. + -X Omit the XS portion (implies both -c and -f). + -a Generate get/set accessors for struct and union members (used with -x). + -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 + -k Omit 'const' attribute on function arguments (used with -x). + -m Generate tied variables for access to declared variables. + -n Specify a name to use for the extension (recommended). + -o Regular expression for \"opaque\" types. + -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. + -b Specify a perl version to be backwards compatibile with 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,48 +380,168 @@ extra_libraries } -getopts("AOPXcfhv:n:") || usage; +getopts("ACF:M:OPXacdfhkmn:o:p:s:v:xb:") || usage; +use vars qw($opt_A $opt_C $opt_F $opt_M $opt_O $opt_P $opt_X $opt_a $opt_c $opt_d + $opt_f $opt_h $opt_k $opt_m $opt_n $opt_o $opt_p $opt_s $opt_v $opt_x + $opt_b); usage if $opt_h; +if( $opt_b ){ + usage "You cannot use -b and -m at the same time.\n" if ($opt_b && $opt_m); + $opt_b =~ /^\d+\.\d+\.\d+/ || + usage "You must provide the backwards compatibility version in X.Y.Z form. " . + "(i.e. 5.5.0)\n"; + my ($maj,$min,$sub) = split(/\./,$opt_b,3); + $compat_version = sprintf("%d.%03d%02d",$maj,$min,$sub); +} + if( $opt_v ){ $TEMPLATE_VERSION = $opt_v; } + +# -A implies -c. $opt_c = 1 if $opt_A; -$path_h = shift; -$extralibs = "@ARGV"; +# -X implies -c and -f +$opt_c = $opt_f = 1 if $opt_X; -usage "Must supply header file or module name\n" - unless ($path_h or $opt_n); +my %const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s; +my $extralibs; +my @path_h; +while (my $arg = shift) { + if ($arg =~ /^-l/i) { + $extralibs = "$arg @ARGV"; + last; + } + push(@path_h, $arg); +} -if( $path_h ){ - $name = $path_h; +usage "Must supply header file or module name\n" + unless (@path_h or $opt_n); + +my $fmask; +my $tmask; + +$fmask = qr{$opt_M} if defined $opt_M; +$tmask = qr{$opt_o} if defined $opt_o; +my $tmask_all = $tmask && $opt_o eq '.'; + +if ($opt_x) { + eval {require C::Scan; 1} + or die <= 0.70 + or die <curdir(), $Config{usrinc}, + (split ' ', $Config{locincpth}), '/usr/include'); + } + foreach my $path_h (@path_h) { + $name ||= $path_h; if( $path_h =~ s#::#/#g && $opt_n ){ 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 () { - if (/^#[ \t]*define\s+(\w+)\b\s*[^("]/) { - $_ = $1; + my $fullpath = $path_h; + $path_h =~ s/,.*$// if $opt_x; + $fullpath{$path_h} = $fullpath; + + if (not -f $path_h) { + my $tmp_path_h = $path_h; + for my $dir (@paths) { + last if -f ($path_h = File::Spec->catfile($dir, $tmp_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 processed below. + open(CH, "<$path_h") || die "Can't open $path_h: $!\n"; + defines: + while () { + if (/^[ \t]*#[ \t]*define\s+([\$\w]+)\b(?!\()\s*(?=[^" \t])(.*)/) { + my $def = $1; + my $rest = $2; + $rest =~ s!/\*.*?(\*/|\n)|//.*!!g; # Remove comments + $rest =~ s/^\s+//; + $rest =~ s/\s+$//; + # Cannot do: (-1) and ((LHANDLE)3) are OK: + #print("Skip non-wordy $def => $rest\n"), + # next defines if $rest =~ /[^\w\$]/; + if ($rest =~ /"/) { + print("Skip stringy $def => $rest\n") if $opt_d; + next defines; + } + print "Matched $_ ($def)\n" if $opt_d; + $seen_define{$def} = $rest; + $_ = $def; next if /^_.*_h_*$/i; # special case, but for what? - $const_names{$_}++; - } + if (defined $opt_p) { + if (!/^$opt_p(\d)/) { + ++$prefix{$_} if s/^$opt_p//; + } + else { + warn "can't remove $opt_p prefix from '$_'!\n"; + } + } + $prefixless{$def} = $_; + if (!$fmask or /$fmask/) { + print "... Passes mask of -M.\n" if $opt_d and $fmask; + $const_names{$_}++; + } + } + } + close(CH); + } } - close(CH); - @const_names = sort keys %const_names; } -$module = $opt_n || do { +my $module = $opt_n || do { $name =~ s/\.h$//; if( $name !~ /::/ ){ $name =~ s#^.*/##; @@ -232,6 +550,7 @@ $module = $opt_n || do { $name; }; +my ($ext, $nested, @modparts, $modfname, $modpname); (chdir 'ext', $ext = 'ext/') if -d 'ext'; if( $module =~ /::/ ){ @@ -249,11 +568,12 @@ else { if ($opt_O) { warn "Overwriting existing $ext$modpname!!!\n" if -e $modpname; -} else { +} +else { die "Won't overwrite existing $ext$modpname\n" if -e $modpname; } if( $nested ){ - $modpath = ""; + my $modpath = ""; foreach (@modparts){ mkdir("$modpath$_", 0777); $modpath .= "$_/"; @@ -262,32 +582,156 @@ 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 = []; +my $typedef_rex; +my %typedefs_pre; +my %known_fnames; +my %structs; + +my @fnames; +my @fnames_no_prefix; +my %vdecl_hash; +my @vdecls; + 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 Config; # Run-time directive + warn "Scanning typemaps...\n"; + get_typemap(); + my @td; + my @good_td; + my $addflags = $opt_F || ''; + + foreach my $filename (@path_h) { + my $c; + my $filter; + + if ($fullpath{$filename} =~ /,/) { + $filename = $`; + $filter = $'; + } + warn "Scanning $filename for functions...\n"; + $c = new C::Scan 'filename' => $filename, 'filename_filter' => $filter, + 'add_cppflags' => $addflags, 'c_styles' => [qw(C++ C9X)]; + $c->set('includeDirs' => ["$Config::Config{archlib}/CORE"]); + + push @$fdecls_parsed, @{ $c->get('parsed_fdecls') }; + push(@$fdecls, @{$c->get('fdecls')}); + + push @td, @{$c->get('typedefs_maybe')}; + if ($opt_a) { + my $structs = $c->get('typedef_structs'); + @structs{keys %$structs} = values %$structs; + } + + if ($opt_m) { + %vdecl_hash = %{ $c->get('vdecl_hash') }; + @vdecls = sort keys %vdecl_hash; + for (local $_ = 0; $_ < @vdecls; ++$_) { + my $var = $vdecls[$_]; + my($type, $post) = @{ $vdecl_hash{$var} }; + if (defined $post) { + warn "Can't handle variable '$type $var $post', skipping.\n"; + splice @vdecls, $_, 1; + redo; + } + $type = normalize_type($type); + $vdecl_hash{$var} = $type; + } + } + + unless ($tmask_all) { + warn "Scanning $filename for typedefs...\n"; + my $td = $c->get('typedef_hash'); + # eval {require 'dumpvar.pl'; ::dumpValue($td)} or warn $@ if $opt_d; + my @f_good_td = grep $td->{$_}[1] eq '', keys %$td; + push @good_td, @f_good_td; + @typedefs_pre{@f_good_td} = map $_->[0], @$td{@f_good_td}; + } + } + { local $" = '|'; + $typedef_rex = qr(\b(?[$i][1] =~ /$fmask/; # [1] is NAME + push @good, $i; + print "... Function $fdecls_parsed->[$i][1] passes -M mask.\n" + if $opt_d; + } + $fdecls = [@$fdecls[@good]]; + $fdecls_parsed = [@$fdecls_parsed[@good]]; + } + @fnames = sort map $_->[1], @$fdecls_parsed; # 1 is NAME + # Sort declarations: + { + my %h = map( ($_->[1], $_), @$fdecls_parsed); + $fdecls_parsed = [ @h{@fnames} ]; + } + @fnames_no_prefix = @fnames; + @fnames_no_prefix + = sort map { ++$prefix{$_} if s/^$opt_p(?!\d)//; $_ } @fnames_no_prefix; + # Remove macros which expand to typedefs + print "Typedefs are @td.\n" if $opt_d; + my %td = map {($_, $_)} @td; + # Add some other possible but meaningless values for macros + for my $k (qw(char double float int long short unsigned signed void)) { + $td{"$_$k"} = "$_$k" for ('', 'signed ', 'unsigned '); + } + # eval {require 'dumpvar.pl'; ::dumpValue( [\@td, \%td] ); 1} or warn $@; + my $n = 0; + my %bad_macs; + while (keys %td > $n) { + $n = keys %td; + my ($k, $v); + while (($k, $v) = each %seen_define) { + # print("found '$k'=>'$v'\n"), + $bad_macs{$k} = $td{$k} = $td{$v} if exists $td{$v}; + } + } + # Now %bad_macs contains names of bad macros + for my $k (keys %bad_macs) { + delete $const_names{$prefixless{$k}}; + print "Ignoring macro $k which expands to a typedef name '$bad_macs{$k}'\n" if $opt_d; + } + } } +my @const_names = sort keys %const_names; + open(PM, ">$modfname.pm") || die "Can't create $ext$modpname/$modfname.pm: $!\n"; $" = "\n\t"; warn "Writing $ext$modpname/$modfname.pm\n"; +if ( $compat_version < 5.006 ) { print PM <<"END"; package $module; +use $compat_version; use strict; END +} +else { +print PM <<"END"; +package $module; -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 5.006; +use strict; +use warnings; END } -else{ + +unless( $opt_X || $opt_c || $opt_A ){ # we'll have an AUTOLOAD(), and it will have $AUTOLOAD and # will want Carp. print PM <<'END'; use Carp; -use vars qw($VERSION @ISA @EXPORT $AUTOLOAD); END } @@ -300,58 +744,65 @@ print PM <<"END" if ! $opt_X; # use DynaLoader, unless XS was disabled require DynaLoader; END -# require autoloader if XS is disabled. -# if XS is enabled, require autoloader unless autoloading is disabled. -if( $opt_X || (! $opt_A) ){ - print PM <<"END"; -require AutoLoader; -END -} - -if( $opt_X || ($opt_c && ! $opt_A) ){ - # we won't have our own AUTOLOAD(), so we'll inherit it. - if( ! $opt_X ) { # use DynaLoader, unless XS was disabled - print PM <<"END"; -\@ISA = qw(Exporter AutoLoader DynaLoader); -END +# Are we using AutoLoader or not? +unless ($opt_A) { # no autoloader whatsoever. + unless ($opt_c) { # we're doing the AUTOLOAD + print PM "use AutoLoader;\n"; } - else{ - print PM <<"END"; - -\@ISA = qw(Exporter AutoLoader); -END + else { + print PM "use AutoLoader qw(AUTOLOAD);\n" } } -else{ - # 1) we have our own AUTOLOAD(), so don't need to inherit it. - # or - # 2) we don't want autoloading mentioned. - if( ! $opt_X ){ # use DynaLoader, unless XS was disabled - print PM <<"END"; - -\@ISA = qw(Exporter DynaLoader); -END - } - else{ - print PM <<"END"; -\@ISA = qw(Exporter); -END - } +if ( $compat_version < 5.006 ) { + if ( $opt_X || $opt_c || $opt_A ) { + print PM 'use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);'; + } else { + print PM 'use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $AUTOLOAD);'; + } } -print PM<<"END"; +# Determine @ISA. +my $myISA = 'our @ISA = qw(Exporter'; # We seem to always want this. +$myISA .= ' DynaLoader' unless $opt_X; # no XS +$myISA .= ');'; +$myISA =~ s/^our // if $compat_version < 5.006; + +print PM "\n$myISA\n\n"; + +my @exported_names = (@const_names, @fnames_no_prefix, map '$'.$_, @vdecls); + +my $tmp=<<"END"; # Items to export into callers namespace by default. Note: do not export # names by default without a very good reason. Use EXPORT_OK instead. # Do not simply export all your public functions/methods/constants. -\@EXPORT = qw( + +# This allows declaration use $module ':all'; +# If you do not need this, moving things directly into \@EXPORT or \@EXPORT_OK +# will save memory. +our %EXPORT_TAGS = ( 'all' => [ qw( + @exported_names +) ] ); + +our \@EXPORT_OK = ( \@{ \$EXPORT_TAGS{'all'} } ); + +our \@EXPORT = qw( @const_names ); -\$VERSION = '$TEMPLATE_VERSION'; +our \$VERSION = '$TEMPLATE_VERSION'; END +$tmp =~ s/^our //mg if $compat_version < 5.006; +print PM $tmp; + +if (@vdecls) { + printf PM "our(@{[ join ', ', map '$'.$_, @vdecls ]});\n\n"; +} + + +$tmp = ( $compat_version < 5.006 ? "" : "our \$AUTOLOAD;" ); print PM <<"END" unless $opt_c or $opt_X; sub AUTOLOAD { # This AUTOLOAD is used to 'autoload' constants from the constant() @@ -359,18 +810,29 @@ sub AUTOLOAD { # to the AUTOLOAD in AutoLoader. my \$constname; + $tmp (\$constname = \$AUTOLOAD) =~ s/.*:://; + croak "&$module::constant not defined" if \$constname eq 'constant'; my \$val = constant(\$constname, \@_ ? \$_[0] : 0); if (\$! != 0) { - if (\$! =~ /Invalid/) { + if (\$! =~ /Invalid/ || \$!{EINVAL}) { \$AutoLoader::AUTOLOAD = \$AUTOLOAD; goto &AutoLoader::AUTOLOAD; } else { - croak "Your vendor has not defined $module macro \$constname"; + croak "Your vendor has not defined $module macro \$constname"; + } + } + { + no strict 'refs'; + # Fixed between 5.005_53 and 5.005_61 + if (\$] >= 5.00561) { + *\$AUTOLOAD = sub () { \$val }; + } + else { + *\$AUTOLOAD = sub { \$val }; } } - eval "sub \$AUTOLOAD { \$val }"; goto &\$AUTOLOAD; } @@ -382,6 +844,17 @@ bootstrap $module \$VERSION; END } +# tying the variables can happen only after bootstrap +if (@vdecls) { + printf PM < should be removed. +# +EOD + $exp_doc .= <. # #=cut END @@ -443,75 +969,200 @@ if( ! $opt_X ){ # print XS, unless it is disabled warn "Writing $ext$modpname/$modfname.xs\n"; print XS <<"END"; -#ifdef __cplusplus -extern "C" { -#endif #include "EXTERN.h" #include "perl.h" #include "XSUB.h" -#ifdef __cplusplus -} -#endif END -if( $path_h ){ +if( @path_h ){ + foreach my $path_h (@path_h_ini) { my($h) = $path_h; $h =~ s#^/usr/include/##; -print XS <<"END"; -#include <$h> + if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; } + print XS qq{#include <$h>\n}; + } + print XS "\n"; +} -END +my %pointer_typedefs; +my %struct_typedefs; + +sub td_is_pointer { + my $type = shift; + my $out = $pointer_typedefs{$type}; + return $out if defined $out; + my $otype = $type; + $out = ($type =~ /\*$/); + # This converts only the guys which do not have trailing part in the typedef + if (not $out + and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) { + $type = normalize_type($type); + print "Is-Pointer: Type mutation via typedefs: $otype ==> $type\n" + if $opt_d; + $out = td_is_pointer($type); + } + return ($pointer_typedefs{$otype} = $out); } -if( ! $opt_c ){ -print XS <<"END"; -static int -not_here(s) -char *s; +sub td_is_struct { + my $type = shift; + my $out = $struct_typedefs{$type}; + return $out if defined $out; + my $otype = $type; + $out = ($type =~ /^(struct|union)\b/) && !td_is_pointer($type); + # This converts only the guys which do not have trailing part in the typedef + if (not $out + and $typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) { + $type = normalize_type($type); + print "Is-Struct: Type mutation via typedefs: $otype ==> $type\n" + if $opt_d; + $out = td_is_struct($type); + } + return ($struct_typedefs{$otype} = $out); +} + +# Some macros will bomb if you try to return them from a double-returning func. +# Say, ((char *)0), or strlen (if somebody #define STRLEN strlen). +# Fortunately, we can detect both these cases... +sub protect_convert_to_double { + my $in = shift; + my $val; + return '' unless defined ($val = $seen_define{$in}); + return '(IV)' if $known_fnames{$val}; + # OUT_t of ((OUT_t)-1): + return '' unless $val =~ /^\s*(\(\s*)?\(\s*([^()]*?)\s*\)/; + td_is_pointer($2) ? '(IV)' : ''; +} + +# For each of the generated functions, length($pref) leading +# letters are already checked. Moreover, it is recommended that +# the generated functions uses switch on letter at offset at least +# $off + length($pref). +# +# The given list has length($pref) chars removed at front, it is +# guarantied that $off leading chars in the rest are the same for all +# elts of the list. +# +# Returns: how at which offset it was decided to make a switch, or -1 if none. + +sub write_const; + +sub write_const { + my ($fh, $pref, $off, $list) = (shift,shift,shift,shift); + my %leading; + my $offarg = length $pref; + + if (@$list == 0) { # Can happen on the initial iteration only + print $fh <<"END"; +static double +constant(char *name, int len, int arg) { - croak("$module::%s not implemented on this architecture", s); - return -1; + errno = EINVAL; + return 0; } +END + return -1; + } + if (@$list == 1) { # Can happen on the initial iteration only + my $protect = protect_convert_to_double("$pref$list->[0]"); + + print $fh <<"END"; static double -constant(name, arg) -char *name; -int arg; +constant(char *name, int len, int arg) { errno = 0; - switch (*name) { + if (strEQ(name + $offarg, "$list->[0]")) { /* $pref removed */ +#ifdef $pref$list->[0] + return $protect$pref$list->[0]; +#else + errno = ENOENT; + return 0; +#endif + } + errno = EINVAL; + return 0; +} END + return -1; + } -my(@AZ, @az, @under); + for my $n (@$list) { + my $c = substr $n, $off, 1; + $leading{$c} = [] unless exists $leading{$c}; + push @{$leading{$c}}, substr $n, $off + 1; + } -foreach(@const_names){ - @AZ = 'A' .. 'Z' if !@AZ && /^[A-Z]/; - @az = 'a' .. 'z' if !@az && /^[a-z]/; - @under = '_' if !@under && /^_/; -} + if (keys(%leading) == 1) { + return 1 + write_const $fh, $pref, $off + 1, $list; + } -foreach $letter (@AZ, @az, @under) { + my $leader = substr $list->[0], 0, $off; + foreach my $letter (keys %leading) { + write_const $fh, "$pref$leader$letter", 0, $leading{$letter} + if @{$leading{$letter}} > 1; + } - last if $letter eq 'a' && !@const_names; + my $npref = "_$pref"; + $npref = '' if $pref eq ''; + + print $fh <<"END"; +static double +constant$npref(char *name, int len, int arg) +{ +END + + print $fh <<"END" if $npref eq ''; + errno = 0; +END + + print $fh <<"END" if $off; + if ($offarg + $off >= len ) { + errno = EINVAL; + return 0; + } +END + + print $fh <<"END"; + switch (name[$offarg + $off]) { +END - print XS " case '$letter':\n"; - my($name); - while (substr($const_names[0],0,1) eq $letter) { - $name = shift(@const_names); - print XS <<"END"; - if (strEQ(name, "$name")) -#ifdef $name - return $name; + foreach my $letter (sort keys %leading) { + my $let = $letter; + $let = '\0' if $letter eq ''; + + print $fh < 1) { + # It makes sense to call a function + if ($off) { + print $fh <[1]} @$args; + my @argtypes = map { normalize_type( $_->[0], 1 ) } @$args; + if ($opt_k) { + s/^\s*const\b\s*// for @argtypes; + } + my @argarrays = map { $_->[4] || '' } @$args; + my $numargs = @$args; + if ($numargs and $argtypes[-1] eq '...') { + $numargs--; + $argnames[-1] = '...'; + } + local $" = ', '; + $type = normalize_type($type, 1); + + print $fh <<"EOP"; + +$type +$name(@argnames) +EOP + + for my $arg (0 .. $numargs - 1) { + print $fh <<"EOP"; + $argtypes[$arg] $argnames[$arg]$argarrays[$arg] +EOP + } +} + +sub print_tievar_subs { + my($fh, $name, $type) = @_; + print $fh <[0] =~ /_ANON/) { + if (defined $item->[2]) { + push @items, map [ + @$_[0, 1], "$item->[2]_$_->[2]", "$item->[2].$_->[2]", + ], @{ $structs{$item->[0]} }; + } else { + push @items, @{ $structs{$item->[0]} }; + } + } else { + my $type = normalize_type($item->[0]); + my $ttype = $structs{$type} ? normalize_type("$type *") : $type; + print $fh <<"EOF"; +$ttype +$item->[2](THIS, __value = NO_INIT) + $ptrname THIS + $type __value + PROTOTYPE: \$;\$ + CODE: + if (items > 1) + THIS->$item->[-1] = __value; + RETVAL = @{[ + $type eq $ttype ? "THIS->$item->[-1]" : "&(THIS->$item->[-1])" + ]}; + OUTPUT: + RETVAL + +EOF + } + } +} + +# 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('\$%&*@;') . "]" ; + + # Start with useful default values + $typemap{float} = 'T_DOUBLE'; + + foreach my $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 () { + 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*($|\#)/ ; + my ($type, $image); + 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)) { + $typemap{normalize_type($type)} = $image; + } + } + } + close(TYPEMAP) or die "Cannot close $typemap: $!"; + } + %std_types = %types_seen; + %types_seen = (); +} + + +sub normalize_type { # Second arg: do not strip const's before \* + my $type = shift; + my $do_keep_deep_const = shift; + # If $do_keep_deep_const this is heuristical only + my $keep_deep_const = ($do_keep_deep_const ? '\b(?![^(,)]*\*)' : ''); + my $ignore_mods + = "(?:\\b(?:(?:__const__|const)$keep_deep_const|static|inline|__inline__)\\b\\s*)*"; + if ($do_keep_deep_const) { # Keep different compiled /RExen/o separately! + $type =~ s/$ignore_mods//go; + } + else { + $type =~ s/$ignore_mods//go; + } + $type =~ s/([^\s\w])/ \1 /g; + $type =~ s/\s+$//; + $type =~ s/^\s+//; + $type =~ s/\s+/ /g; + $type =~ s/\* (?=\*)/*/g; + $type =~ s/\. \. \./.../g; + $type =~ s/ ,/,/g; + $types_seen{$type}++ + unless $type eq '...' or $type eq 'void' or $std_types{$type}; + $type; +} + +my $need_opaque; + +sub assign_typemap_entry { + my $type = shift; + my $otype = $type; + my $entry; + if ($tmask and $type =~ /$tmask/) { + print "Type $type matches -o mask\n" if $opt_d; + $entry = (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ"); + } + elsif ($typedef_rex and $type =~ s/($typedef_rex)/$typedefs_pre{$1}/go) { + $type = normalize_type $type; + print "Type mutation via typedefs: $otype ==> $type\n" if $opt_d; + $entry = assign_typemap_entry($type); + } + $entry ||= $typemap{$otype} + || (td_is_struct($type) ? "T_OPAQUE_STRUCT" : "T_PTROBJ"); + $typemap{$otype} = $entry; + $need_opaque = 1 if $entry eq "T_OPAQUE_STRUCT"; + return $entry; +} + +for (@vdecls) { + print_tievar_xsubs(\*XS, $_, $vdecl_hash{$_}); +} + +if ($opt_x) { + for my $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) } + if ($opt_a) { + while (my($name, $struct) = each %structs) { + print_accessors(\*XS, $name, $struct); + } + } +} 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 (sort keys %types_seen) { + my $entry = assign_typemap_entry $type; + print TM $type, "\t" x (5 - int((length $type)/8)), "\t$entry\n" + } + + print TM <<'EOP' if $need_opaque; # Older Perls do not have correct entry +############################################################################# +INPUT +T_OPAQUE_STRUCT + if (sv_derived_from($arg, \"${ntype}\")) { + STRLEN len; + char *s = SvPV((SV*)SvRV($arg), len); + + if (len != sizeof($var)) + croak(\"Size %d of packed data != expected %d\", + len, sizeof($var)); + $var = *($type *)s; + } + else + croak(\"$var is not of type ${ntype}\") +############################################################################# +OUTPUT +T_OPAQUE_STRUCT + sv_setref_pvn($arg, \"${ntype}\", (char *)&$var, sizeof($var)); +EOP + + close TM or die "Cannot close typemap file for write: $!"; +} + } # if( ! $opt_X ) warn "Writing $ext$modpname/Makefile.PL\n"; open(PL, ">Makefile.PL") || die "Can't create $ext$modpname/Makefile.PL: $!\n"; -print PL <<'END'; +print PL < '$module', + 'VERSION_FROM' => '$modfname.pm', # finds \$VERSION + 'PREREQ_PM' => {}, # e.g., Module::Name => 1.1 +END +if (!$opt_X) { # print C stuff, unless XS is disabled + $opt_F = '' unless defined $opt_F; + print PL < ['$extralibs'], # e.g., '-lm' + 'DEFINE' => '$opt_F', # e.g., '-DHAVE_SOMETHING' + 'INC' => '', # e.g., '-I/usr/include/other' END -print PL "WriteMakefile(\n"; -print PL " 'NAME' => '$module',\n"; -print PL " 'VERSION_FROM' => '$modfname.pm', # finds \$VERSION\n"; -if( ! $opt_X ){ # print C stuff, unless XS is disabled - print PL " 'LIBS' => ['$extralibs'], # e.g., '-lm' \n"; - print PL " 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' \n"; - print PL " 'INC' => '', # e.g., '-I/usr/include/other' \n"; } print PL ");\n"; close(PL) || die "Can't close $ext$modpname/Makefile.PL: $!\n"; @@ -594,25 +1600,45 @@ print "ok 1\n"; _END_ close(EX) || die "Can't close $ext$modpname/test.pl: $!\n"; -warn "Writing $ext$modpname/Changes\n"; -open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n"; -print EX "Revision history for Perl extension $module.\n\n"; -print EX "$TEMPLATE_VERSION ",scalar localtime,"\n"; -print EX "\t- original version; created by h2xs $H2XS_VERSION\n\n"; -close(EX) || die "Can't close $ext$modpname/Changes: $!\n"; +unless ($opt_C) { + warn "Writing $ext$modpname/Changes\n"; + $" = ' '; + open(EX, ">Changes") || die "Can't create $ext$modpname/Changes: $!\n"; + @ARGS = map {/[\s\"\'\`\$*?^|&<>\[\]\{\}\(\)]/ ? "'$_'" : $_} @ARGS; + print EX <MANIFEST') or die "Can't create MANIFEST: $!"; -@files = <*>; +my @files = <*>; if (!@files) { eval {opendir(D,'.');}; unless ($@) { @files = readdir(D); closedir(D); } } if (!@files) { @files = map {chomp && $_} `ls`; } -print MANI join("\n",@files); +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), "\n"; close MANI; !NO!SUBS! close OUT or die "Can't close $file: $!"; chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; +chdir $origdir;