diff options
Diffstat (limited to 'contrib/perl5/utils/h2xs.PL')
| -rw-r--r-- | contrib/perl5/utils/h2xs.PL | 1084 |
1 files changed, 891 insertions, 193 deletions
diff --git a/contrib/perl5/utils/h2xs.PL b/contrib/perl5/utils/h2xs.PL index 129b01b..ca0e7cb 100644 --- a/contrib/perl5/utils/h2xs.PL +++ b/contrib/perl5/utils/h2xs.PL @@ -41,7 +41,7 @@ h2xs - convert .h C header files to Perl extensions =head1 SYNOPSIS -B<h2xs> [B<-AOPXcdf>] [B<-v> version] [B<-n> module_name] [B<-p> prefix] [B<-s> sub] [headerfile ... [extra_libraries]] +B<h2xs> [B<-ACOPXcdf>] [B<-v> version] [B<-n> module_name] [B<-p> prefix] [B<-s> sub] [headerfile ... [extra_libraries]] B<h2xs> 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<C<require AutoLoader>> statement from the .pm file. +S<C<use AutoLoader>> statement from the .pm file. + +=item B<-C> + +Omits creation of the F<Changes> file, and adds a HISTORY section to +the POD template. =item B<-F> 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<regular expression> + +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<new> +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<const>, omit the const attribute in the +generated XS code. + +=item B<-m> + +B<Experimental>: 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<module_name> Specifies a name to be used for the extension, e.g., S<-n RPC::DCE> +=item B<-o> I<regular expression> + +Use "opaque" data type for the C types matched by the regular +expression, even if these types are C<typedef>-equivalent to types +from typemaps. Should not be used without B<-x>. + +This may be useful since, say, types which are C<typedef>-equivalent +to integers may represent OS-related handles, and one may want to work +with these handles in OO-way, as in C<$handle-E<gt>do_something()>. +Use C<-o .> if you want to handle all the C<typedef>ed 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<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. +autoloaded via the C<constant()> mechanism. =item B<-s> I<sub1,sub2> @@ -140,7 +188,8 @@ 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. +pointer (like C<long long>), pointers to functions, or arrays. See +also the section on L<LIMITATIONS of B<-x>>. =back @@ -193,6 +242,12 @@ pointer (like C<long long>), 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,27 +264,97 @@ L<perl>, L<perlxstut>, L<ExtUtils::MakeMaker>, and L<AutoLoader>. The usual warnings if it cannot read or write the files involved. +=head1 LIMITATIONS of B<-x> + +F<h2xs> would not distinguish whether an argument to a C function +which is of the form, say, C<int *>, 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<n> is an input parameter. + +Additionally, F<h2xs> 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<perlxs> and L<perlxstut> for additional details. + =cut -my( $H2XS_VERSION ) = ' $Revision: 1.19 $ ' =~ /\$Revision:\s+([^\s]+)/; +use strict; + + +my( $H2XS_VERSION ) = ' $Revision: 1.20 $ ' =~ /\$Revision:\s+([^\s]+)/; my $TEMPLATE_VERSION = '0.01'; +my @ARGS = @ARGV; 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 [-ACOPXcdfh] [-v version] [-n module_name] [-p prefix] [-s subs] [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. @@ -241,15 +366,25 @@ extra_libraries } -getopts("AF:OPXcdfhn:p:s:v:x") || usage; +getopts("ACF:M:OPXacdfhkmn:o:p:s:v:x") || 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); usage if $opt_h; 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 +397,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 <<EOD; +C::Scan required if you use -x option. +To install C::Scan, execute + perl -MCPAN -e "install C::Scan" +EOD + unless ($tmask_all) { + $C::Scan::VERSION >= 0.70 + or die <<EOD; +C::Scan v. 0.70 or later required unless you use -o . option. +You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}. +To install C::Scan, execute + perl -MCPAN -e "install C::Scan" +EOD + } + if (($opt_m || $opt_a) && $C::Scan::VERSION < 0.73) { + die <<EOD; +C::Scan v. 0.73 or later required to use -m or -a options. +You have version $C::Scan::VERSION installed as $INC{'C/Scan.pm'}. +To install C::Scan, execute + perl -MCPAN -e "install C::Scan" +EOD + } +} +elsif ($opt_o or $opt_F) { + warn <<EOD; +Options -o and -F do not make sense without -x. +EOD +} + +my @path_h_ini = @path_h; +my ($name, %fullpath, %prefix, %seen_define, %prefixless, %const_names); if( @path_h ){ + use Config; + use File::Spec; + my @paths; + if ($^O eq 'VMS') { # Consider overrides of default location + # XXXX This is not equivalent to what the older version did: + # it was looking at $hadsys header-file per header-file... + my($hadsys) = grep s!^sys/!!i , @path_h; + @paths = qw( Sys$Library VAXC$Include ); + push @paths, ($hadsys ? 'GNU_CC_Include[vms]' : 'GNU_CC_Include[000000]'); + push @paths, qw( DECC$Library_Include DECC$System_Include ); + } + else { + @paths = (File::Spec->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 +477,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 (<CH>) { - 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 +504,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 +526,7 @@ $module = $opt_n || do { $name; }; +my ($ext, $nested, @modparts, $modfname, $modpname); (chdir 'ext', $ext = 'ext/') if -d 'ext'; if( $module =~ /::/ ){ @@ -347,11 +544,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,36 +560,125 @@ 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(?<!struct )(?:@good_td)\b) if @good_td; + } + %known_fnames = map @$_[1,3], @$fdecls_parsed; # [1,3] is NAME, FULLTEXT + if ($fmask) { + my @good; + for my $i (0..$#$fdecls_parsed) { + next unless $fdecls_parsed->[$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"; @@ -401,21 +688,16 @@ warn "Writing $ext$modpname/$modfname.pm\n"; print PM <<"END"; package $module; +require 5.005_62; use strict; +use warnings; 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 @EXPORT_OK); -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 +710,50 @@ 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"; +# Determine @ISA. +my $myISA = 'our @ISA = qw(Exporter'; # We seem to always want this. +$myISA .= ' DynaLoader' unless $opt_X; # no XS +$myISA .= ');'; +print PM "\n$myISA\n\n"; -\@ISA = qw(Exporter); -END - } -} +my @exported_names = (@const_names, @fnames_no_prefix, map '$'.$_, @vdecls); print PM<<"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 +if (@vdecls) { + printf PM "our(@{[ join ', ', map '$'.$_, @vdecls ]});\n\n"; +} + print PM <<"END" unless $opt_c or $opt_X; sub AUTOLOAD { # This AUTOLOAD is used to 'autoload' constants from the constant() @@ -487,20 +761,29 @@ sub AUTOLOAD { # to the AUTOLOAD in AutoLoader. my \$constname; + our \$AUTOLOAD; (\$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 }; } } - no strict 'refs'; - *\$AUTOLOAD = sub () { \$val }; goto &\$AUTOLOAD; } @@ -512,6 +795,17 @@ bootstrap $module \$VERSION; END } +# tying the variables can happen only after bootstrap +if (@vdecls) { + printf PM <<END; +{ +@{[ join "\n", map " _tievar_$_(\$$_);", @vdecls ]} +} + +END +} + +my $after; if( $opt_P ){ # if POD is disabled $after = '__END__'; } @@ -522,37 +816,71 @@ else { print PM <<"END"; # Preloaded methods go here. +END + +print PM <<"END" unless $opt_A; # Autoload methods go after $after, and are processed by the autosplit program. +END + +print PM <<"END"; 1; __END__ END -$author = "A. U. Thor"; -$email = 'a.u.thor@a.galaxy.far.far.away'; +my $author = "A. U. Thor"; +my $email = 'a.u.thor@a.galaxy.far.far.away'; + +my $revhist = ''; +$revhist = <<EOT if $opt_C; + +=head1 HISTORY -my $const_doc = ''; -my $fdecl_doc = ''; +=over 8 + +=item $TEMPLATE_VERSION + +Original version; created by h2xs $H2XS_VERSION with options + + @ARGS + +=back + +EOT + +my $exp_doc = <<EOD; + +=head2 EXPORT + +None by default. + +EOD if (@const_names and not $opt_P) { - $const_doc = <<EOD; -\n=head1 Exported constants + $exp_doc .= <<EOD; +=head2 Exportable constants @{[join "\n ", @const_names]} EOD } if (defined $fdecls and @$fdecls and not $opt_P) { - $fdecl_doc = <<EOD; -\n=head1 Exported functions + $exp_doc .= <<EOD; +=head2 Exportable functions + +EOD + $exp_doc .= <<EOD if $opt_p; +When accessing these functions from Perl, prefix C<$opt_p> should be removed. - @{[join "\n ", @$fdecls]} +EOD + $exp_doc .= <<EOD; + @{[join "\n ", @known_fnames{@fnames}]} EOD } -$pod = <<"END" unless $opt_P; -## Below is the stub of documentation for your module. You better edit it! +my $pod = <<"END" unless $opt_P; +## Below is stub documentation for your module. You better edit it! # #=head1 NAME # @@ -565,12 +893,12 @@ $pod = <<"END" unless $opt_P; # #=head1 DESCRIPTION # -#Stub documentation for $module was created by h2xs. It looks like the +#Stub documentation for $module, created by h2xs. It looks like the #author of the extension was negligent enough to leave the stub #unedited. # #Blah blah blah. -#$const_doc$fdecl_doc +#$exp_doc$revhist #=head1 AUTHOR # #$author, $email @@ -598,7 +926,7 @@ print XS <<"END"; 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#.*[:>\]]##; } @@ -607,54 +935,185 @@ if( @path_h ){ print XS "\n"; } -if( ! $opt_c ){ -print XS <<"END"; -static int -not_here(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(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 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"; +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 + + foreach my $letter (sort keys %leading) { + my $let = $letter; + $let = '\0' if $letter eq ''; + + print $fh <<EOP; + case '$let': +EOP + if (@{$leading{$letter}} > 1) { + # It makes sense to call a function + if ($off) { + print $fh <<EOP; + if (!strnEQ(name + $offarg,"$leader", $off)) + break; +EOP + } + print $fh <<EOP; + return constant_$pref$leader$letter(name, len, arg); +EOP + } + else { + # Do it ourselves + my $protect + = protect_convert_to_double("$pref$leader$letter$leading{$letter}[0]"); + + print $fh <<EOP; + if (strEQ(name + $offarg, "$leader$letter$leading{$letter}[0]")) { /* $pref removed */ +#ifdef $pref$leader$letter$leading{$letter}[0] + return $protect$pref$leader$letter$leading{$letter}[0]; #else goto not_there; #endif -END + } +EOP } - print XS <<"END"; - break; -END -} -print XS <<"END"; + } + print $fh <<"END"; } errno = EINVAL; return 0; @@ -665,9 +1124,28 @@ not_there: } END + +} + +if( ! $opt_c ) { + print XS <<"END"; +static int +not_here(char *s) +{ + croak("$module::%s not implemented on this architecture", s); + return -1; +} + +END + + write_const(\*XS, '', 0, \@const_names); } +print_tievar_subs(\*XS, $_, $vdecl_hash{$_}) for @vdecls; + +my $prefix; $prefix = "PREFIX = $opt_p" if defined $opt_p; + # Now switch from C to XS by issuing the first MODULE declaration: print XS <<"END"; @@ -682,13 +1160,13 @@ $_() CODE: #ifdef $_ - RETVAL = $_; + RETVAL = $_; #else - croak("Your vendor has not defined the $module macro $_"); + croak("Your vendor has not defined the $module macro $_"); #endif OUTPUT: - RETVAL + RETVAL END } @@ -698,14 +1176,22 @@ END print XS <<"END" unless $opt_c; double -constant(name,arg) - char * name +constant(sv,arg) + PREINIT: + STRLEN len; + INPUT: + SV * sv + char * s = SvPV(sv, len); int arg + CODE: + RETVAL = constant(s,len,arg); + OUTPUT: + RETVAL END my %seen_decl; - +my %typemap; sub print_decl { my $fh = shift; @@ -714,7 +1200,10 @@ sub print_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 @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 '...') { @@ -722,21 +1211,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 <<END; +I32 +_get_$name(IV index, SV *sv) { + dSP; + PUSHMARK(SP); + XPUSHs(sv); + PUTBACK; + (void)call_pv("$module\::_get_$name", G_DISCARD); + return (I32)0; +} + +I32 +_set_$name(IV index, SV *sv) { + dSP; + PUSHMARK(SP); + XPUSHs(sv); + PUTBACK; + (void)call_pv("$module\::_set_$name", G_DISCARD); + return (I32)0; +} + +END +} + +sub print_tievar_xsubs { + my($fh, $name, $type) = @_; + print $fh <<END; +void +_tievar_$name(sv) + SV* sv + PREINIT: + struct ufuncs uf; + CODE: + uf.uf_val = &_get_$name; + uf.uf_set = &_set_$name; + uf.uf_index = (IV)&_get_$name; + sv_magic(sv, 0, 'U', (char*)&uf, sizeof(uf)); + +void +_get_$name(THIS) + $type THIS = NO_INIT + CODE: + THIS = $name; + OUTPUT: + SETMAGIC: DISABLE + THIS + +void +_set_$name(THIS) + $type THIS + CODE: + $name = THIS; + +END +} + +sub print_accessors { + my($fh, $name, $struct) = @_; + return unless defined $struct && $name !~ /\s|_ANON/; + $name = normalize_type($name); + my $ptrname = normalize_type("$name *"); + print $fh <<"EOF"; + +MODULE = $module PACKAGE = ${name} $prefix + +$name * +_to_ptr(THIS) + $name THIS = NO_INIT + PROTOTYPE: \$ + CODE: + if (sv_derived_from(ST(0), "$name")) { + STRLEN len; + char *s = SvPV((SV*)SvRV(ST(0)), len); + if (len != sizeof(THIS)) + croak("Size \%d of packed data != expected \%d", + len, sizeof(THIS)); + RETVAL = ($name *)s; + } + else + croak("THIS is not of type $name"); + OUTPUT: + RETVAL + +$name +new(CLASS) + char *CLASS = NO_INIT + PROTOTYPE: \$ + CODE: + Zero((void*)&RETVAL, sizeof(RETVAL), char); + OUTPUT: + RETVAL + +MODULE = $module PACKAGE = ${name}Ptr $prefix + +EOF + my @items = @$struct; + while (@items) { + my $item = shift @items; + if ($item->[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. @@ -744,9 +1364,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"; @@ -762,11 +1384,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; } } } @@ -777,24 +1400,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; @@ -804,10 +1467,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: $!"; } @@ -816,18 +1501,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 <<END; use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. +WriteMakefile( + 'NAME' => '$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 <<END; + 'LIBS' => ['$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"; @@ -862,16 +1551,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 <<EOP; +Revision history for Perl extension $module. + +$TEMPLATE_VERSION @{[scalar localtime]} +\t- original version; created by h2xs $H2XS_VERSION with options +\t\t@ARGS + +EOP + close(EX) || die "Can't close $ext$modpname/Changes: $!\n"; +} warn "Writing $ext$modpname/MANIFEST\n"; open(MANI,'>MANIFEST') or die "Can't create MANIFEST: $!"; -@files = <*>; +my @files = <*>; if (!@files) { eval {opendir(D,'.');}; unless ($@) { @files = readdir(D); closedir(D); } |
