From af6c647ee5aae2406b2bfb66c4fe11a81de75b05 Mon Sep 17 00:00:00 2001 From: Nicholas Clark Date: Sun, 20 May 2001 20:24:13 +0100 Subject: [PATCH] Re: [PATCH] Re: h2xs [was Re: HEAR YE, HEAR YE!] Message-ID: <20010520192413.G83222@plum.flirble.org> p4raw-id: //depot/perl@10213 --- MANIFEST | 2 + lib/ExtUtils/Constant.pm | 630 +++++++++++++++++++++++++++++++++++++++++++++++ t/lib/extutils.t | 185 ++++++++++++++ utils/h2xs.PL | 293 ++++------------------ 4 files changed, 862 insertions(+), 248 deletions(-) create mode 100644 lib/ExtUtils/Constant.pm create mode 100644 t/lib/extutils.t diff --git a/MANIFEST b/MANIFEST index e2a1fdc..f338082 100644 --- a/MANIFEST +++ b/MANIFEST @@ -720,6 +720,7 @@ lib/Env.pm Map environment into ordinary variables lib/Exporter.pm Exporter base class lib/Exporter/Heavy.pm Complicated routines for Exporter lib/ExtUtils/Command.pm Utilities for Make on non-UNIX platforms +lib/ExtUtils/Constant.pm generate XS code to import C header constants lib/ExtUtils/Embed.pm Utilities for embedding Perl in C programs lib/ExtUtils/Install.pm Handles 'make install' on extensions lib/ExtUtils/Installed.pm Information on installed extensions @@ -1504,6 +1505,7 @@ t/lib/env-array.t See if Env works for arrays t/lib/env.t See if Env works t/lib/errno.t See if Errno works t/lib/exporter.t See if Exporter works +t/lib/extutils.t See if extutils work t/lib/fatal.t See if Fatal works t/lib/fcntl.t See if Fcntl works t/lib/fields.t See if base/fields works diff --git a/lib/ExtUtils/Constant.pm b/lib/ExtUtils/Constant.pm new file mode 100644 index 0000000..59a3126 --- /dev/null +++ b/lib/ExtUtils/Constant.pm @@ -0,0 +1,630 @@ +package ExtUtils::Constant; + +=head1 NAME + +ExtUtils::Constant - generate XS code to import C header constants + +=head1 SYNOPSIS + + use ExtUtils::Constant qw (constant_types C_constant XS_constant); + print constant_types(); # macro defs + foreach (C_constant (undef, "IV", undef, undef, undef, @names) ) { + print $_, "\n"; # C constant subs + } + print "MODULE = Foo PACKAGE = Foo\n"; + print XS_constant ("Foo", {NV => 1, IV => 1}); # XS for Foo::constant + +=head1 DESCRIPTION + +ExtUtils::Constant facilitates generating C and XS wrapper code to allow +perl modules to AUTOLOAD constants defined in C library header files. +It is principally used by the C utility, on which this code is based. +It doesn't contain the routines to scan header files to extract these +constants. + +=head1 USAGE + +Generally one only needs to call the 3 functions shown in the synopsis, +C, C and C. + +Currently this module understands the following types. h2xs may only know +a subset. The sizes of the numeric types are chosen by the C +script at compile time. + +=over 4 + +=item IV + +signed integer, at least 32 bits. + +=item UV + +unsigned integer, the same size as I + +=item NV + +floating point type, probably C, possibly C + +=item PV + +NUL terminated string, length will be determined with C + +=item PVN + +A fixed length thing, given as a [pointer, length] pair. If you know the +length of a string at compile time you may use this instead of I + +=back + +=head1 FUNCTIONS + +=over 4 + +=cut + +require 5.006; # I think, for [:cntrl:] in REGEXP +use warnings; +use strict; +use Carp; + +use Exporter; +use vars qw (@ISA $VERSION %XS_Constant %XS_TypeSet @EXPORT_OK %EXPORT_TAGS); +use Text::Wrap; +$Text::Wrap::huge = 'overflow'; +$Text::Wrap::columns = 80; + +@ISA = 'Exporter'; +$VERSION = '0.01'; + +%EXPORT_TAGS = ( 'all' => [ qw( + XS_constant constant_types return_clause memEQ_clause C_stringify + C_constant autoload +) ] ); + +@EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); + +%XS_Constant = ( + IV => 'PUSHi(iv)', + UV => 'PUSHu((UV)iv)', + NV => 'PUSHn(nv)', + PV => 'PUSHp(pv, strlen(pv))', + PVN => 'PUSHp(pv, iv)' +); + +%XS_TypeSet = ( + IV => '*iv_return =', + UV => '*iv_return = (IV)', + NV => '*nv_return =', + PV => '*pv_return =', + PVN => ['*pv_return =', '*iv_return = (IV)'] +); + + +=item C_stringify NAME + +A function which returns a correctly \ escaped version of the string passed +suitable for C's "" or '' + +=cut + +# Hopefully make a happy C identifier. +sub C_stringify { + local $_ = shift; + s/\\/\\\\/g; + s/([\"\'])/\\$1/g; # Grr. fix perl mode. + s/([[:cntrl:]])/sprintf "\\%03o", ord $1/ge; + s/\177/\\177/g; # DEL doesn't seem to be a [:cntrl:] + $_; +} + +=item constant_types + +A function returning a single scalar with C<#define> definitions for the +constants used internally between the generated C and XS functions. + +=cut + +sub constant_types () { + my $start = 1; + my @lines; + push @lines, "#define PERL_constant_NOTFOUND\t$start\n"; $start++; + push @lines, "#define PERL_constant_NOTDEF\t$start\n"; $start++; + foreach (sort keys %XS_Constant) { + push @lines, "#define PERL_constant_IS$_\t$start\n"; $start++; + } + push @lines, << 'EOT'; + +#ifndef NVTYPE +typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */ +#endif +EOT + + return join '', @lines; +} + +=item memEQ_clause NAME, CHECKED_AT, INDENT + +A function to return a suitable C C statement to check whether I +is equal to the C variable C. If I is defined, then it +is used to avoid C for short names, or to generate a comment to +highlight the position of the character in the C statement. + +=cut + +sub memEQ_clause { +# if (memEQ(name, "thingy", 6)) { + # Which could actually be a character comparison or even "" + my ($name, $checked_at, $indent) = @_; + $indent = ' ' x ($indent || 4); + my $len = length $name; + + if ($len < 2) { + return $indent . "{\n" if (defined $checked_at and $checked_at == 0); + # We didn't switch, drop through to the code for the 2 character string + $checked_at = 1; + } + if ($len < 3 and defined $checked_at) { + my $check; + if ($checked_at == 1) { + $check = 0; + } elsif ($checked_at == 0) { + $check = 1; + } + if (defined $check) { + my $char = C_stringify (substr $name, $check, 1); + return $indent . "if (name[$check] == '$char') {\n"; + } + } + # Could optimise a memEQ on 3 to 2 single character checks here + $name = C_stringify ($name); + my $body = $indent . "if (memEQ(name, \"$name\", $len)) {\n"; + $body .= $indent . "/* ". (' ' x $checked_at) . '^' + . (' ' x ($len - $checked_at + length $len)) . " */\n" + if defined $checked_at; + return $body; +} + +=item return_clause VALUE, TYPE, INDENT, MACRO + +A function to return a suitable C<#ifdef> clause. I defaults to +I when not defined. If I is aggregate (eg I expects both +pointer and length) then I should be a reference to an array of +values in the order expected by the type. + +=cut + +sub return_clause { +##ifdef thingy +# *iv_return = thingy; +# return PERL_constant_ISIV; +##else +# return PERL_constant_NOTDEF; +##endif + my ($value, $type, $indent, $macro) = @_; + $macro = $value unless defined $macro; + $indent = ' ' x ($indent || 6); + + die "Macro must not be a reference" if ref $macro; + my $clause = "#ifdef $macro\n"; + + my $typeset = $XS_TypeSet{$type}; + die "Can't generate code for type $type" unless defined $typeset; + if (ref $typeset) { + die "Type $type is aggregate, but only single value given" + unless ref $value; + foreach (0 .. $#$typeset) { + $clause .= $indent . "$typeset->[$_] $value->[$_];\n"; + } + } else { + die "Aggregate value given for type $type" + if ref $value; + $clause .= $indent . "$typeset $value;\n"; + } + return $clause . <<"EOT"; +${indent}return PERL_constant_IS$type; +#else +${indent}return PERL_constant_NOTDEF; +#endif +EOT +} + +=item params WHAT + +An internal function. I should be a hashref of types the constant +function will return. I returns the list of flags C<$use_iv, $use_nv, +$use_pv> to show which combination of pointers will be needed in the C +argument list. + +=cut + +sub params { + my $what = shift; + foreach (sort keys %$what) { + warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_}; + } + my $use_iv = $what->{IV} || $what->{UV} || $what->{PVN}; + my $use_nv = $what->{NV}; + my $use_pv = $what->{PV} || $what->{PVN}; + return ($use_iv, $use_nv, $use_pv); +} + +=item C_constant SUBNAME, DEFAULT_TYPE, TYPES, INDENT, NAMELEN, ITEM... + +A function that returns a B of C subroutine definitions that return +the value and type of constants when passed the name by the XS wrapper. +I gives a list of constant names. Each can either be a string, +which is taken as a C macro name, or a reference to a hash with the following +keys + +=over 8 + +=item name + +The name of the constant, as seen by the perl code. + +=item type + +The type of the constant (I, I etc) + +=item value + +A C expression for the value of the constant, or a list of C expressions if +the type is aggregate. This defaults to the I if not given. + +=item macro + +The C pre-processor macro to use in the C<#ifdef>. This defaults to the +I, and is mainly used if I is an C. + +=back + +The first 5 argument can safely be given as C, and are mainly used +for recursion. I defaults to C if undefined. + +I is the type returned by Cs that don't specify their +type. In turn it defaults to I. I should be given either as a comma +separated list of types that the C subroutine C will generate or as +a reference to a hash. I will be added to the list if not +present, as will any types given in the list of Is. The resultant list +should be the same list of types that C is given. [Otherwise +C and C may differ in the number of parameters to the +constant function. I is currently unused and ignored. In future it may +be used to pass in information used to change the C indentation style used.] +The best way to maintain consistency is to pass in a hash reference and let +this function update it. + +I if defined signals that all the Is of the Is are of +this length, and that the constant name passed in by perl is checked and +also of this length. It is used during recursion, and should be C +unless the caller has checked all the lengths during code generation, and +the generated subroutine is only to be called with a name of this length. + +=cut + +sub C_constant { + my ($subname, $default_type, $what, $indent, $namelen, @items) = @_; + $subname ||= 'constant'; + # I'm not using this. But a hashref could be used for full formatting without + # breaking this API + $indent ||= 0; + $default_type ||= 'IV'; + if (!ref $what) { + # Convert line of the form IV,UV,NV to hash + $what = {map {$_ => 1} split /,\s*/, ($what || '')}; + # Figure out what types we're dealing with, and assign all unknowns to the + # default type + } + my %items; + foreach (@items) { + my $name; + if (ref $_) { + $name = $_->{name}; + $what->{$_->{type} ||= $default_type} = 1; + } else { + $name = $_; + $_ = {name=>$_, type=>$default_type}; + $what->{$default_type} = 1; + } + warn "ExtUtils::Constant doesn't know how to handle values of type $_ used in macro $name" unless defined $XS_Constant{$_->{type}}; + if (exists $items{$name}) { + die "Multiple definitions for macro $name"; + } + $items{$name} = $_; + } + my ($use_iv, $use_nv, $use_pv) = params ($what); + + my ($body, @subs) = "static int\n$subname (const char *name"; + $body .= ", STRLEN len" unless defined $namelen; + $body .= ", IV *iv_return" if $use_iv; + $body .= ", NV *nv_return" if $use_nv; + $body .= ", const char **pv_return" if $use_pv; + $body .= ") {\n"; + + my @names = sort map {$_->{name}} @items; + my $names = << 'EOT' + /* When generated this function returned values for the list of names given + here. However, subsequent manual editing may have added or removed some. +EOT + . wrap (" ", " ", join (" ", @names) . " */") . "\n"; + + if (defined $namelen) { + # We are a child subroutine. + # Figure out what to switch on. + # (RMS, Spread of jump table, Position, Hashref) + my @best = (1e38, ~0); + foreach my $i (0 .. ($namelen - 1)) { + my ($min, $max) = (~0, 0); + my %spread; + foreach (@names) { + my $char = substr $_, $i, 1; + my $ord = ord $char; + $max = $ord if $ord > $max; + $min = $ord if $ord < $min; + push @{$spread{$char}}, $_; + # warn "$_ $char"; + } + # I'm going to pick the character to split on that minimises the root + # mean square of the number of names in each case. Normally this should + # be the one with the most keys, but it may pick a 7 where the 8 has + # one long linear search. I'm not sure if RMS or just sum of squares is + # actually better. + # $max and $min are for the tie-breaker if the root mean squares match. + # Assuming that the compiler may be building a jump table for the + # switch() then try to minimise the size of that jump table. + # Finally use < not <= so that if it still ties the earliest part of + # the string wins. Because if that passes but the memEQ fails, it may + # only need the start of the string to bin the choice. + # I think. But I'm micro-optimising. :-) + my $ss; + $ss += @$_ * @$_ foreach values %spread; + my $rms = sqrt ($ss / keys %spread); + if ($rms < $best[0] || ($rms == $best[0] && ($max - $min) < $best[1])) { + @best = ($rms, $max - $min, $i, \%spread); + } + } + die "Internal error. Failed to pick a switch point for @names" + unless defined $best[2]; + # use Data::Dumper; print Dumper (@best); + my ($offset, $best) = @best[2,3]; + $body .= " /* Names all of length $namelen. */\n"; + $body .= $names; + $body .= " /* Offset $offset gives the best switch position. */\n"; + $body .= " switch (name[$offset]) {\n"; + foreach my $char (sort keys %$best) { + $body .= " case '" . C_stringify ($char) . "':\n"; + foreach my $name (sort @{$best->{$char}}) { + my $thisone = $items{$name}; + my ($value, $macro) = (@$thisone{qw (value macro)}); + $value = $name unless defined $value; + $macro = $name unless defined $macro; + + $body .= memEQ_clause ($name, $offset); # We have checked this offset. + $body .= return_clause ($value, $thisone->{type}, undef, $macro); + $body .= " }\n"; + } + $body .= " break;\n"; + } + $body .= " }\n"; + } else { + # We are the top level. + $body .= " /* Initially switch on the length of the name. */\n"; + $body .= $names; + $body .= " switch (len) {\n"; + # Need to group names of the same length + my @by_length; + foreach (@items) { + push @{$by_length[length $_->{name}]}, $_; + } + foreach my $i (0 .. $#by_length) { + next unless $by_length[$i]; # None of this length + $body .= " case $i:\n"; + if (@{$by_length[$i]} == 1) { + my $thisone = $by_length[$i]->[0]; + my ($name, $value, $macro) = (@$thisone{qw (name value macro)}); + $value = $name unless defined $value; + $macro = $name unless defined $macro; + + $body .= memEQ_clause ($name); + $body .= return_clause ($value, $thisone->{type}, undef, $macro); + $body .= " }\n"; + } else { + push @subs, C_constant ("${subname}_$i", $default_type, $what, $indent, + $i, @{$by_length[$i]}); + $body .= " return ${subname}_$i (name"; + $body .= ", iv_return" if $use_iv; + $body .= ", nv_return" if $use_nv; + $body .= ", pv_return" if $use_pv; + $body .= ");\n"; + } + $body .= " break;\n"; + } + $body .= " }\n"; + } + $body .= " return PERL_constant_NOTFOUND;\n}\n"; + return (@subs, $body); +} + +=item XS_constant PACKAGE, TYPES, SUBNAME, C_SUBNAME + +A function to generate the XS code to implement the perl subroutine +I::constant used by I::AUTOLOAD to load constants. +This XS code is a wrapper around a C subroutine usually generated by +C, and usually named C. + +I should be given either as a comma separated list of types that the +C subroutine C will generate or as a reference to a hash. It should +be the same list of types as C was given. +[Otherwise C and C may have different ideas about +the number of parameters passed to the C function C] + +You can call the perl visible subroutine something other than C if +you give the parameter I. The C subroutine it calls defaults to the +the name of the perl visible subroutine, unless you give the parameter +I. + +=cut + +sub XS_constant { + my $package = shift; + my $what = shift; + my $subname = shift; + my $C_subname = shift; + $subname ||= 'constant'; + $C_subname ||= $subname; + + if (!ref $what) { + # Convert line of the form IV,UV,NV to hash + $what = {map {$_ => 1} split /,\s*/, ($what)}; + } + my ($use_iv, $use_nv, $use_pv) = params ($what); + my $type; + + my $xs = <<"EOT"; +void +$subname(sv) + PREINIT: +#ifdef dXSTARG + dXSTARG; /* Faster if we have it. */ +#else + dTARGET; +#endif + STRLEN len; + int type; +EOT + + if ($use_iv) { + $xs .= " IV iv;\n"; + } else { + $xs .= " /* IV\t\tiv;\tUncomment this if you need to return IVs */\n"; + } + if ($use_nv) { + $xs .= " NV nv;\n"; + } else { + $xs .= " /* NV\t\tnv;\tUncomment this if you need to return NVs */\n"; + } + if ($use_pv) { + $xs .= " const char *pv;\n"; + } else { + $xs .= + " /* const char\t*pv;\tUncomment this if you need to return PVs */\n"; + } + + $xs .= << 'EOT'; + INPUT: + SV * sv; + const char * s = SvPV(sv, len); + PPCODE: +EOT + + if ($use_iv xor $use_nv) { + $xs .= << "EOT"; + /* Change this to $C_subname(s, len, &iv, &nv); + if you need to return both NVs and IVs */ +EOT + } + $xs .= " type = $C_subname(s, len"; + $xs .= ', &iv' if $use_iv; + $xs .= ', &nv' if $use_nv; + $xs .= ', &pv' if $use_pv; + $xs .= ");\n"; + + $xs .= << "EOT"; + /* Return 1 or 2 items. First is error message, or undef if no error. + Second, if present, is found value */ + switch (type) { + case PERL_constant_NOTFOUND: + sv = sv_2mortal(newSVpvf("%s is not a valid $package macro", s)); + break; + case PERL_constant_NOTDEF: + sv = sv_2mortal(newSVpvf( + "Your vendor has not defined $package macro %s used", s)); + break; +EOT + + foreach $type (sort keys %XS_Constant) { + $xs .= "\t/* Uncomment this if you need to return ${type}s\n" + unless $what->{$type}; + $xs .= << "EOT"; + case PERL_constant_IS$type: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + $XS_Constant{$type}; + break; +EOT + unless ($what->{$type}) { + chop $xs; # Yes, another need for chop not chomp. + $xs .= " */\n"; + } + } + $xs .= << "EOT"; + default: + sv = sv_2mortal(newSVpvf( + "Unexpected return type %d while processing $package macro %s used", + type, s)); + } +EOT + + return $xs; +} + + +=item autoload PACKAGE, VERSION + +A function to generate the AUTOLOAD subroutine for the module I +I is the perl version the code should be backwards compatible with. +It defaults to the version of perl running the subroutine. + +=cut + +sub autoload { + my ($module, $compat_version) = @_; + $compat_version ||= $]; + croak "Can't maintain compatibility back as far as version $compat_version" + if $compat_version < 5; + my $tmp = ( $compat_version < 5.006 ? "" : "our \$AUTOLOAD;" ); + return <<"END"; +sub AUTOLOAD { + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. If a constant is not found then control is passed + # to the AUTOLOAD in AutoLoader. + + my \$constname; + $tmp + (\$constname = \$AUTOLOAD) =~ s/.*:://; + croak "&${module}::constant not defined" if \$constname eq 'constant'; + my (\$error, \$val) = constant(\$constname); + if (\$error) { + if (\$error =~ /is not a valid/) { + \$AutoLoader::AUTOLOAD = \$AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } else { + croak \$error; + } + } + { + no strict 'refs'; + # Fixed between 5.005_53 and 5.005_61 +#XXX if (\$] >= 5.00561) { +#XXX *\$AUTOLOAD = sub () { \$val }; +#XXX } +#XXX else { + *\$AUTOLOAD = sub { \$val }; +#XXX } + } + goto &\$AUTOLOAD; +} + +END + +} +1; +__END__ + +=back + +=head1 AUTHOR + +Nicholas Clark based on the code in C by Larry Wall and +others + +=cut diff --git a/t/lib/extutils.t b/t/lib/extutils.t new file mode 100644 index 0000000..0f285a3 --- /dev/null +++ b/t/lib/extutils.t @@ -0,0 +1,185 @@ +#!./perl -w + +print "1..8\n"; + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use warnings; +use strict; +use ExtUtils::MakeMaker; +use ExtUtils::Constant qw (constant_types C_constant XS_constant autoload); +use Config; + +my $runperl = $^X; +my $tobitbucket = ">/dev/null"; +# my @cleanup; +$| = 1; + +my $dir = "ext-$$"; +mkdir $dir, 0777 or die $!; + +END { + system "$Config{rm} -rf $dir"; +} + +# push @cleanup, $dir; + +my @names = ("THREE", {name=>"OK4", type=>"PV",}, + {name=>"OK5", type=>"PVN", + value=>['"not ok 5\\n\\0ok 5\\n"', 15]}, + {name => "FARTHING", type=>"NV"}, + {name => "NOT_ZERO", type=>"UV", value=>~0 . "u"}); + +my @names_only = map {(ref $_) ? $_->{name} : $_} @names; + +my $package = "ExtTest"; +################ Header +my $header = "$dir/test.h"; +open FH, ">$header" or die $!; +print FH <<'EOT'; +#define THREE 3 +#define OK4 "ok 4\n" +#define OK5 1 +#define FARTHING 0.25 +#define NOT_ZERO 1 +EOT +close FH or die $!; +# push @cleanup, $header; + +################ XS +my $xs = "$dir/$package.xs"; +open FH, ">$xs" or die $!; + +print FH <<'EOT'; +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +EOT + +print FH "#include \"test.h\"\n\n"; +print FH constant_types(); # macro defs +my $types = {}; +foreach (C_constant (undef, "IV", $types, undef, undef, @names) ) { + print FH $_, "\n"; # C constant subs +} +print FH "MODULE = $package PACKAGE = $package\n"; +print FH "PROTOTYPES: ENABLE\n"; +print FH XS_constant ($package, $types); # XS for ExtTest::constant +close FH or die $!; +# push @cleanup, $xs; + +################ PM +my $pm = "$dir/$package.pm"; +open FH, ">$pm" or die $!; +print FH "package $package;\n"; +print FH "use $];\n"; + +print FH <<'EOT'; + +use strict; +use warnings; +use Carp; + +require Exporter; +require DynaLoader; +use AutoLoader; +use vars qw ($VERSION @ISA @EXPORT_OK); + +$VERSION = '0.01'; +@ISA = qw(Exporter DynaLoader); +@EXPORT_OK = qw( +EOT + +print FH "\t$_\n" foreach (@names_only); +print FH ");\n"; +print FH autoload ($package, $]); +print FH "bootstrap $package \$VERSION;\n1;\n__END__\n"; +close FH or die $!; +# push @cleanup, $pm; + +################ test.pl +my $testpl = "$dir/test.pl"; +open FH, ">$testpl" or die $!; + +print FH "use $package qw(@names_only);\n"; +print FH <<'EOT'; + +my $three = THREE; +if ($three == 3) { + print "ok 3\n"; +} else { + print "not ok 3 # $three\n"; +} + +print OK4; + +$_ = OK5; +s/.*\0//s; +print; + +my $farthing = FARTHING; +if ($farthing == 0.25) { + print "ok 6\n"; +} else { + print "not ok 6 # $farthing\n"; +} + +my $not_zero = NOT_ZERO; +if ($not_zero > 0 && $not_zero == ~0) { + print "ok 7\n"; +} else { + print "not ok 7 # \$not_zero=$not_zero ~0=" . (~0) . "\n"; +} + + +EOT + +close FH or die $!; +# push @cleanup, $testpl; + +################ dummy Makefile.PL +# Keep the dependancy in the Makefile happy +my $makefilePL = "$dir/Makefile.PL"; +open FH, ">$makefilePL" or die $!; +close FH or die $!; +# push @cleanup, $makefilePL; + +chdir $dir or die $!; push @INC, '../../lib'; +END {chdir ".." or warn $!}; + +print "# "; # Grr. MakeMaker hardwired to write its message to STDOUT +WriteMakefile( + 'NAME' => $package, + 'VERSION_FROM' => "$package.pm", # finds $VERSION + ($] >= 5.005 ? + (#ABSTRACT_FROM => "$package.pm", # XXX add this + AUTHOR => $0) : ()) + ); +if (-f "Makefile") { + print "ok 1\n"; +} else { + print "not ok 1\n"; +} + +my $make = $Config{make}; +$make = $ENV{MAKE} if exists $ENV{MAKE}; +print "# make = '$make'\n"; +if (system "$make $tobitbucket") { + print "not ok 2 # $make failed\n"; + # Bail out? +} else { + print "ok 2\n"; +} + +$make .= ' test'; +# This hack to get a # in front of "PERL_DL_NONLAZY=1 ..." isn't going to work +# on VMS mailboxes. +print "# make = '$make'\n# "; +if (system $make) { + print "not ok 8 # $make failed\n"; +} else { + print "ok 8\n"; +} diff --git a/utils/h2xs.PL b/utils/h2xs.PL index 4333c0f..ef31a2e 100644 --- a/utils/h2xs.PL +++ b/utils/h2xs.PL @@ -116,6 +116,18 @@ 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<-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. + =item B<-c> Omit C from the .xs file and corresponding specialised @@ -178,6 +190,13 @@ 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<-t> I + +Specify the internal type that the constant() mechanism uses for macros. +The default is IV (signed integer). Currently all macros found during the +header scanning process will be assumed to have this type. Future versions +of C may gain the ability to make educated guesses. + =item B<-v> I Specify a version number for this extension. This version number is added @@ -198,18 +217,6 @@ 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 =head1 EXAMPLES @@ -417,6 +424,10 @@ my $compat_version = $]; use Getopt::Std; use Config; +use Text::Wrap; +$Text::Wrap::huge = 'overflow'; +$Text::Wrap::columns = 80; +use ExtUtils::Constant qw (constant_types C_constant XS_constant autoload); sub usage { warn "@_\n" if @_; @@ -444,6 +455,7 @@ version: $H2XS_VERSION -v Specify a version number for this extension. -x Autogenerate XSUBs using C::Scan. -b Specify a perl version to be backwards compatibile with + -t Default type for autoloaded constants extra_libraries are any libraries that might be needed for loading the extension, e.g. -lm would try to link in the math library. @@ -451,10 +463,10 @@ EOFUSAGE } -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); +getopts("ACF:M:OPXacdfhkmn:o:p:s:v:xb:t:") || 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 $opt_t); usage if $opt_h; @@ -896,41 +908,7 @@ if (@vdecls) { } -$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() - # XS function. If a constant is not found then control is passed - # 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/ || \$!{EINVAL}) { - \$AutoLoader::AUTOLOAD = \$AUTOLOAD; - goto &AutoLoader::AUTOLOAD; - } - else { - 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 }; - } - } - goto &\$AUTOLOAD; -} - -END +print PM autoload ($module, $compat_version) unless $opt_c or $opt_X; if( ! $opt_X ){ # print bootstrap, unless XS is disabled print PM <<"END"; @@ -1152,186 +1130,15 @@ sub td_is_struct { 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 NV -constant(char *name, int len, int arg) -{ - 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 NV -constant(char *name, int len, int arg) -{ - errno = 0; - 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; - } - - for my $n (@$list) { - my $c = substr $n, $off, 1; - $leading{$c} = [] unless exists $leading{$c}; - push @{$leading{$c}}, $off < length $n ? substr $n, $off + 1 : $n - } - - 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; - } - - my $npref = "_$pref"; - $npref = '' if $pref eq ''; - - print $fh <<"END"; -static NV -constant$npref(char *name, int len, int arg) -{ -END - - print $fh <<"END" if $npref eq ''; - errno = 0; -END - - if ($off) { - my $null = 0; - - foreach my $letter (keys %leading) { - if ($letter eq '') { - $null = 1; - last; - } - } - - my $cmp = $null ? '>' : '>='; - - print $fh <<"END" - if ($offarg + $off $cmp 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 <