X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=utils%2Fh2xs.PL;h=2885c6f5ee284f2de1ad88c13c37b57212bf8886;hb=be3174d2532d82826fc0aa416a83ef8ce0f07732;hp=52f590b776de2592bc7049f495f1f3f25f441a68;hpb=8a5546a1774bc5278c3b557b5a3cac8da26aa636;p=p5sagit%2Fp5-mst-13.2.git diff --git a/utils/h2xs.PL b/utils/h2xs.PL index 52f590b..2885c6f 100644 --- a/utils/h2xs.PL +++ b/utils/h2xs.PL @@ -13,9 +13,9 @@ use Cwd; # 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. -$origdir = cwd; +my $origdir = cwd; chdir dirname($0); -$file = basename($0, '.PL'); +my $file = basename($0, '.PL'); $file .= '.com' if $^O eq 'VMS'; open OUT,">$file" or die "Can't create $file: $!"; @@ -41,7 +41,7 @@ h2xs - convert .h C header files to Perl extensions =head1 SYNOPSIS -B [B<-AOPXcdf>] [B<-v> version] [B<-n> module_name] [B<-p> prefix] [B<-s> sub] [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> @@ -71,12 +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<-F> +=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>. +function declarations. Should not be used without B<-x>. + +=item B<-M> I + +selects functions/macros to process. =item B<-O> @@ -89,7 +98,21 @@ 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. +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> @@ -103,21 +126,46 @@ 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 mechansim. +autoloaded via the C mechanism. =item B<-s> I @@ -140,7 +188,20 @@ 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. +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 @@ -193,6 +254,12 @@ pointer (like C), pointers to functions, or arrays. # 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 No environment variables are used. @@ -209,31 +276,103 @@ L, L, L, and L. 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.18 $ ' =~ /\$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 [-AOPXcdfh] [-v version] [-n module_name] [-p prefix] [-s subs] [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 -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. + -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. @@ -241,15 +380,35 @@ extra_libraries } -getopts("AF:OPXcdfhn:p:s:v:x") || 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; -%const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s; + +# -X implies -c and -f +$opt_c = $opt_f = 1 if $opt_X; + +my %const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s; +my $extralibs; +my @path_h; while (my $arg = shift) { if ($arg =~ /^-l/i) { @@ -262,34 +421,78 @@ while (my $arg = shift) { 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$/; - $fullpath = $path_h; + my $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"; + $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) { @@ -298,10 +501,24 @@ if( @path_h ){ # 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]*define\s+([\$\w]+)\b\s*[^("]/) { - print "Matched $_ ($1)\n" if $opt_d; - $_ = $1; + 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? if (defined $opt_p) { if (!/^$opt_p(\d)/) { @@ -311,17 +528,20 @@ if( @path_h ){ warn "can't remove $opt_p prefix from '$_'!\n"; } } - $const_names{$_}++; + $prefixless{$def} = $_; + if (!$fmask or /$fmask/) { + print "... Passes mask of -M.\n" if $opt_d and $fmask; + $const_names{$_}++; + } } } close(CH); } } - @const_names = sort keys %const_names; } -$module = $opt_n || do { +my $module = $opt_n || do { $name =~ s/\.h$//; if( $name !~ /::/ ){ $name =~ s#^.*/##; @@ -330,6 +550,7 @@ $module = $opt_n || do { $name; }; +my ($ext, $nested, @modparts, $modfname, $modpname); (chdir 'ext', $ext = 'ext/') if -d 'ext'; if( $module =~ /::/ ){ @@ -347,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 .= "$_/"; @@ -362,60 +584,154 @@ chdir($modpname) || die "Can't chdir $ext$modpname: $!\n"; my %types_seen; my %std_types; -my $fdecls; -my $fdecls_parsed; +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 C::Scan; # Run-time directive require Config; # Run-time directive warn "Scanning typemaps...\n"; get_typemap(); - my $c; - my $filter; - my @fdecls; - foreach my $filename (@path_h) { + my @td; + my @good_td; my $addflags = $opt_F || ''; - if ($fullpath =~ /,/) { - $filename = $`; - $filter = $'; + + 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; } - 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'); - push(@fdecls, @{$c->get('fdecls')}); - } - $fdecls = [ @fdecls ]; } } +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 @EXPORT_OK); +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 @EXPORT_OK $AUTOLOAD); END } @@ -428,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)) || (!$opt_X) ) { - 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() @@ -487,19 +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 }; } } - *\$AUTOLOAD = sub () { \$val }; goto &\$AUTOLOAD; } @@ -511,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 @@ -591,19 +969,13 @@ 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 ){ - foreach my $path_h (@path_h) { + foreach my $path_h (@path_h_ini) { my($h) = $path_h; $h =~ s#^/usr/include/##; if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; } @@ -612,57 +984,185 @@ if( @path_h ){ print XS "\n"; } -if( ! $opt_c ){ -print XS <<"END"; -static int -not_here(s) -char *s; +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); +} + +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; + } + + 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; + } -foreach $letter (@AZ, @az, @under) { + my $npref = "_$pref"; + $npref = '' if $pref eq ''; - last if $letter eq 'a' && !@const_names; + print $fh <<"END"; +static double +constant$npref(char *name, int len, int arg) +{ +END + + print $fh <<"END" if $npref eq ''; + errno = 0; +END - print XS " case '$letter':\n"; - 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 $macro - return $macro; + print $fh <<"END" if $off; + if ($offarg + $off >= len ) { + errno = EINVAL; + return 0; + } +END + + print $fh <<"END"; + switch (name[$offarg + $off]) { +END + + 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] ) } @$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 '...') { @@ -730,21 +1260,152 @@ sub print_decl { $argnames[-1] = '...'; } local $" = ', '; - $type = normalize_type($type); - + $type = normalize_type($type, 1); + print $fh <<"EOP"; $type $name(@argnames) EOP - for $arg (0 .. $numargs - 1) { + 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. @@ -752,9 +1413,11 @@ sub get_typemap { my $stdtypemap = "$Config::Config{privlib}/ExtUtils/typemap"; unshift @tm, $stdtypemap; my $proto_re = "[" . quotemeta('\$%&*@;') . "]" ; - my $image; - - foreach $typemap (@tm) { + + # 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"; @@ -770,11 +1433,12 @@ sub get_typemap { elsif (/^TYPEMAP\s*$/) { $mode = 'Typemap'; next; } elsif ($mode eq 'Typemap') { next if /^\s*($|\#)/ ; - if ( ($type, $image) = + 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)) { - normalize_type($type); + $typemap{normalize_type($type)} = $image; } } } @@ -785,24 +1449,64 @@ sub get_typemap { } -sub normalize_type { - my $ignore_mods = '(?:\b(?:__const__|static|inline|__inline__)\b\s*)*'; +sub normalize_type { # Second arg: do not strip const's before \* my $type = shift; - $type =~ s/$ignore_mods//go; - $type =~ s/([\]\[()])/ \1 /g; - $type =~ s/\s+/ /g; + 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/\b\*/ */g; - $type =~ s/\*\b/* /g; - $type =~ s/\*\s+(?=\*)/*/g; + $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 $decl (@$fdecls_parsed) { print_decl(\*XS, $decl) } + 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; @@ -812,10 +1516,32 @@ if (%types_seen) { 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" + 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: $!"; } @@ -824,18 +1550,22 @@ if (%types_seen) { 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"; @@ -870,16 +1600,25 @@ 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); }