diff options
author | Nicholas Clark <nick@ccl4.org> | 2009-10-02 17:42:02 +0100 |
---|---|---|
committer | Nicholas Clark <nick@ccl4.org> | 2009-10-02 17:42:02 +0100 |
commit | 610892605b3814cdf4f5f2215ee00d25d7ffba45 (patch) | |
tree | 2cbfaa5f9c8b8888ebbcfc99da006223fe77f89c /cpan | |
parent | 0e455d2b24396ba08377dc3cf2d01e6db5f47048 (diff) | |
download | perl-610892605b3814cdf4f5f2215ee00d25d7ffba45.tar.gz |
Move ExtUtils::Constant from ext/ to cpan/
Diffstat (limited to 'cpan')
-rw-r--r-- | cpan/ExtUtils-Constant/lib/ExtUtils/Constant.pm | 565 | ||||
-rw-r--r-- | cpan/ExtUtils-Constant/lib/ExtUtils/Constant/Base.pm | 1006 | ||||
-rw-r--r-- | cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm | 549 | ||||
-rw-r--r-- | cpan/ExtUtils-Constant/lib/ExtUtils/Constant/Utils.pm | 131 | ||||
-rw-r--r-- | cpan/ExtUtils-Constant/lib/ExtUtils/Constant/XS.pm | 259 | ||||
-rw-r--r-- | cpan/ExtUtils-Constant/t/Constant.t | 1050 |
6 files changed, 3560 insertions, 0 deletions
diff --git a/cpan/ExtUtils-Constant/lib/ExtUtils/Constant.pm b/cpan/ExtUtils-Constant/lib/ExtUtils/Constant.pm new file mode 100644 index 0000000000..0a20b89b79 --- /dev/null +++ b/cpan/ExtUtils-Constant/lib/ExtUtils/Constant.pm @@ -0,0 +1,565 @@ +package ExtUtils::Constant; +use vars qw (@ISA $VERSION @EXPORT_OK %EXPORT_TAGS); +$VERSION = 0.22; + +=head1 NAME + +ExtUtils::Constant - generate XS code to import C header constants + +=head1 SYNOPSIS + + use ExtUtils::Constant qw (WriteConstants); + WriteConstants( + NAME => 'Foo', + NAMES => [qw(FOO BAR BAZ)], + ); + # Generates wrapper code to make the values of the constants FOO BAR BAZ + # available to perl + +=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<h2xs> 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 C<WriteConstants> function, and then + + #include "const-c.inc" + +in the C section of C<Foo.xs> + + INCLUDE: const-xs.inc + +in the XS section of C<Foo.xs>. + +For greater flexibility use C<constant_types()>, C<C_constant> and +C<XS_constant>, with which C<WriteConstants> is implemented. + +Currently this module understands the following types. h2xs may only know +a subset. The sizes of the numeric types are chosen by the C<Configure> +script at compile time. + +=over 4 + +=item IV + +signed integer, at least 32 bits. + +=item UV + +unsigned integer, the same size as I<IV> + +=item NV + +floating point type, probably C<double>, possibly C<long double> + +=item PV + +NUL terminated string, length will be determined with C<strlen> + +=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<PV> + +=item SV + +A B<mortal> SV. + +=item YES + +Truth. (C<PL_sv_yes>) The value is not needed (and ignored). + +=item NO + +Defined Falsehood. (C<PL_sv_no>) The value is not needed (and ignored). + +=item UNDEF + +C<undef>. The value of the macro is not needed. + +=back + +=head1 FUNCTIONS + +=over 4 + +=cut + +if ($] >= 5.006) { + eval "use warnings; 1" or die $@; +} +use strict; +use Carp qw(croak cluck); + +use Exporter; +use ExtUtils::Constant::Utils qw(C_stringify); +use ExtUtils::Constant::XS qw(%XS_Constant %XS_TypeSet); + +@ISA = 'Exporter'; + +%EXPORT_TAGS = ( 'all' => [ qw( + XS_constant constant_types return_clause memEQ_clause C_stringify + C_constant autoload WriteConstants WriteMakefileSnippet +) ] ); + +@EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); + +=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 { + ExtUtils::Constant::XS->header(); +} + +sub memEQ_clause { + cluck "ExtUtils::Constant::memEQ_clause is deprecated"; + ExtUtils::Constant::XS->memEQ_clause({name=>$_[0], checked_at=>$_[1], + indent=>$_[2]}); +} + +sub return_clause ($$) { + cluck "ExtUtils::Constant::return_clause is deprecated"; + my $indent = shift; + ExtUtils::Constant::XS->return_clause({indent=>$indent}, @_); +} + +sub switch_clause { + cluck "ExtUtils::Constant::switch_clause is deprecated"; + my $indent = shift; + my $comment = shift; + ExtUtils::Constant::XS->switch_clause({indent=>$indent, comment=>$comment}, + @_); +} + +sub C_constant { + my ($package, $subname, $default_type, $what, $indent, $breakout, @items) + = @_; + ExtUtils::Constant::XS->C_constant({package => $package, subname => $subname, + default_type => $default_type, + types => $what, indent => $indent, + breakout => $breakout}, @items); +} + +=item XS_constant PACKAGE, TYPES, XS_SUBNAME, C_SUBNAME + +A function to generate the XS code to implement the perl subroutine +I<PACKAGE>::constant used by I<PACKAGE>::AUTOLOAD to load constants. +This XS code is a wrapper around a C subroutine usually generated by +C<C_constant>, and usually named C<constant>. + +I<TYPES> should be given either as a comma separated list of types that the +C subroutine C<constant> will generate or as a reference to a hash. It should +be the same list of types as C<C_constant> was given. +[Otherwise C<XS_constant> and C<C_constant> may have different ideas about +the number of parameters passed to the C function C<constant>] + +You can call the perl visible subroutine something other than C<constant> if +you give the parameter I<XS_SUBNAME>. The C subroutine it calls defaults to +the name of the perl visible subroutine, unless you give the parameter +I<C_SUBNAME>. + +=cut + +sub XS_constant { + my $package = shift; + my $what = shift; + my $XS_subname = shift; + my $C_subname = shift; + $XS_subname ||= 'constant'; + $C_subname ||= $XS_subname; + + if (!ref $what) { + # Convert line of the form IV,UV,NV to hash + $what = {map {$_ => 1} split /,\s*/, ($what)}; + } + my $params = ExtUtils::Constant::XS->params ($what); + my $type; + + my $xs = <<"EOT"; +void +$XS_subname(sv) + PREINIT: +#ifdef dXSTARG + dXSTARG; /* Faster if we have it. */ +#else + dTARGET; +#endif + STRLEN len; + int type; +EOT + + if ($params->{IV}) { + $xs .= " IV iv;\n"; + } else { + $xs .= " /* IV\t\tiv;\tUncomment this if you need to return IVs */\n"; + } + if ($params->{NV}) { + $xs .= " NV nv;\n"; + } else { + $xs .= " /* NV\t\tnv;\tUncomment this if you need to return NVs */\n"; + } + if ($params->{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); +EOT + if ($params->{''}) { + $xs .= << 'EOT'; + INPUT: + int utf8 = SvUTF8(sv); +EOT + } + $xs .= << 'EOT'; + PPCODE: +EOT + + if ($params->{IV} xor $params->{NV}) { + $xs .= << "EOT"; + /* Change this to $C_subname(aTHX_ s, len, &iv, &nv); + if you need to return both NVs and IVs */ +EOT + } + $xs .= " type = $C_subname(aTHX_ s, len"; + $xs .= ', utf8' if $params->{''}; + $xs .= ', &iv' if $params->{IV}; + $xs .= ', &nv' if $params->{NV}; + $xs .= ', &pv' if $params->{PV}; + $xs .= ', &sv' if $params->{SV}; + $xs .= ");\n"; + + # If anyone is insane enough to suggest a package name containing % + my $package_sprintf_safe = $package; + $package_sprintf_safe =~ s/%/%%/g; + + $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_sprintf_safe macro", s)); + PUSHs(sv); + break; + case PERL_constant_NOTDEF: + sv = sv_2mortal(newSVpvf( + "Your vendor has not defined $package_sprintf_safe macro %s, used", + s)); + PUSHs(sv); + break; +EOT + + foreach $type (sort keys %XS_Constant) { + # '' marks utf8 flag needed. + next if $type eq ''; + $xs .= "\t/* Uncomment this if you need to return ${type}s\n" + unless $what->{$type}; + $xs .= " case PERL_constant_IS$type:\n"; + if (length $XS_Constant{$type}) { + $xs .= << "EOT"; + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + $XS_Constant{$type}; +EOT + } else { + # Do nothing. return (), which will be correctly interpreted as + # (undef, undef) + } + $xs .= " break;\n"; + 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_sprintf_safe macro %s, used", + type, s)); + PUSHs(sv); + } +EOT + + return $xs; +} + + +=item autoload PACKAGE, VERSION, AUTOLOADER + +A function to generate the AUTOLOAD subroutine for the module I<PACKAGE> +I<VERSION> is the perl version the code should be backwards compatible with. +It defaults to the version of perl running the subroutine. If I<AUTOLOADER> +is true, the AUTOLOAD subroutine falls back on AutoLoader::AUTOLOAD for all +names that the constant() routine doesn't recognise. + +=cut + +# ' # Grr. syntax highlighters that don't grok pod. + +sub autoload { + my ($module, $compat_version, $autoloader) = @_; + $compat_version ||= $]; + croak "Can't maintain compatibility back as far as version $compat_version" + if $compat_version < 5; + my $func = "sub AUTOLOAD {\n" + . " # This AUTOLOAD is used to 'autoload' constants from the constant()\n" + . " # XS function."; + $func .= " If a constant is not found then control is passed\n" + . " # to the AUTOLOAD in AutoLoader." if $autoloader; + + + $func .= "\n\n" + . " my \$constname;\n"; + $func .= + " our \$AUTOLOAD;\n" if ($compat_version >= 5.006); + + $func .= <<"EOT"; + (\$constname = \$AUTOLOAD) =~ s/.*:://; + croak "&${module}::constant not defined" if \$constname eq 'constant'; + my (\$error, \$val) = constant(\$constname); +EOT + + if ($autoloader) { + $func .= <<'EOT'; + if ($error) { + if ($error =~ /is not a valid/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD; + } else { + croak $error; + } + } +EOT + } else { + $func .= + " if (\$error) { croak \$error; }\n"; + } + + $func .= <<'END'; + { + 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 + + return $func; +} + + +=item WriteMakefileSnippet + +WriteMakefileSnippet ATTRIBUTE =E<gt> VALUE [, ...] + +A function to generate perl code for Makefile.PL that will regenerate +the constant subroutines. Parameters are named as passed to C<WriteConstants>, +with the addition of C<INDENT> to specify the number of leading spaces +(default 2). + +Currently only C<INDENT>, C<NAME>, C<DEFAULT_TYPE>, C<NAMES>, C<C_FILE> and +C<XS_FILE> are recognised. + +=cut + +sub WriteMakefileSnippet { + my %args = @_; + my $indent = $args{INDENT} || 2; + + my $result = <<"EOT"; +ExtUtils::Constant::WriteConstants( + NAME => '$args{NAME}', + NAMES => \\\@names, + DEFAULT_TYPE => '$args{DEFAULT_TYPE}', +EOT + foreach (qw (C_FILE XS_FILE)) { + next unless exists $args{$_}; + $result .= sprintf " %-12s => '%s',\n", + $_, $args{$_}; + } + $result .= <<'EOT'; + ); +EOT + + $result =~ s/^/' 'x$indent/gem; + return ExtUtils::Constant::XS->dump_names({default_type=>$args{DEFAULT_TYPE}, + indent=>$indent,}, + @{$args{NAMES}}) + . $result; +} + +=item WriteConstants ATTRIBUTE =E<gt> VALUE [, ...] + +Writes a file of C code and a file of XS code which you should C<#include> +and C<INCLUDE> in the C and XS sections respectively of your module's XS +code. You probably want to do this in your C<Makefile.PL>, so that you can +easily edit the list of constants without touching the rest of your module. +The attributes supported are + +=over 4 + +=item NAME + +Name of the module. This must be specified + +=item DEFAULT_TYPE + +The default type for the constants. If not specified C<IV> is assumed. + +=item BREAKOUT_AT + +The names of the constants are grouped by length. Generate child subroutines +for each group with this number or more names in. + +=item NAMES + +An array of constants' names, either scalars containing names, or hashrefs +as detailed in L<"C_constant">. + +=item PROXYSUBS + +If true, uses proxy subs. See L<ExtUtils::Constant::ProxySubs>. + +=item C_FH + +A filehandle to write the C code to. If not given, then I<C_FILE> is opened +for writing. + +=item C_FILE + +The name of the file to write containing the C code. The default is +C<const-c.inc>. The C<-> in the name ensures that the file can't be +mistaken for anything related to a legitimate perl package name, and +not naming the file C<.c> avoids having to override Makefile.PL's +C<.xs> to C<.c> rules. + +=item XS_FH + +A filehandle to write the XS code to. If not given, then I<XS_FILE> is opened +for writing. + +=item XS_FILE + +The name of the file to write containing the XS code. The default is +C<const-xs.inc>. + +=item XS_SUBNAME + +The perl visible name of the XS subroutine generated which will return the +constants. The default is C<constant>. + +=item C_SUBNAME + +The name of the C subroutine generated which will return the constants. +The default is I<XS_SUBNAME>. Child subroutines have C<_> and the name +length appended, so constants with 10 character names would be in +C<constant_10> with the default I<XS_SUBNAME>. + +=back + +=cut + +sub WriteConstants { + my %ARGS = + ( # defaults + C_FILE => 'const-c.inc', + XS_FILE => 'const-xs.inc', + XS_SUBNAME => 'constant', + DEFAULT_TYPE => 'IV', + @_); + + $ARGS{C_SUBNAME} ||= $ARGS{XS_SUBNAME}; # No-one sane will have C_SUBNAME eq '0' + + croak "Module name not specified" unless length $ARGS{NAME}; + + my $c_fh = $ARGS{C_FH}; + if (!$c_fh) { + if ($] <= 5.008) { + # We need these little games, rather than doing things + # unconditionally, because we're used in core Makefile.PLs before + # IO is available (needed by filehandle), but also we want to work on + # older perls where undefined scalars do not automatically turn into + # anonymous file handles. + require FileHandle; + $c_fh = FileHandle->new(); + } + open $c_fh, ">$ARGS{C_FILE}" or die "Can't open $ARGS{C_FILE}: $!"; + } + + my $xs_fh = $ARGS{XS_FH}; + if (!$xs_fh) { + if ($] <= 5.008) { + require FileHandle; + $xs_fh = FileHandle->new(); + } + open $xs_fh, ">$ARGS{XS_FILE}" or die "Can't open $ARGS{XS_FILE}: $!"; + } + + # As this subroutine is intended to make code that isn't edited, there's no + # need for the user to specify any types that aren't found in the list of + # names. + + if ($ARGS{PROXYSUBS}) { + require ExtUtils::Constant::ProxySubs; + $ARGS{C_FH} = $c_fh; + $ARGS{XS_FH} = $xs_fh; + ExtUtils::Constant::ProxySubs->WriteConstants(%ARGS); + } else { + my $types = {}; + + print $c_fh constant_types(); # macro defs + print $c_fh "\n"; + + # indent is still undef. Until anyone implements indent style rules with + # it. + foreach (ExtUtils::Constant::XS->C_constant({package => $ARGS{NAME}, + subname => $ARGS{C_SUBNAME}, + default_type => + $ARGS{DEFAULT_TYPE}, + types => $types, + breakout => + $ARGS{BREAKOUT_AT}}, + @{$ARGS{NAMES}})) { + print $c_fh $_, "\n"; # C constant subs + } + print $xs_fh XS_constant ($ARGS{NAME}, $types, $ARGS{XS_SUBNAME}, + $ARGS{C_SUBNAME}); + } + + close $c_fh or warn "Error closing $ARGS{C_FILE}: $!" unless $ARGS{C_FH}; + close $xs_fh or warn "Error closing $ARGS{XS_FILE}: $!" unless $ARGS{XS_FH}; +} + +1; +__END__ + +=back + +=head1 AUTHOR + +Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and +others + +=cut diff --git a/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/Base.pm b/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/Base.pm new file mode 100644 index 0000000000..b5b79af1ea --- /dev/null +++ b/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/Base.pm @@ -0,0 +1,1006 @@ +package ExtUtils::Constant::Base; + +use strict; +use vars qw($VERSION); +use Carp; +use Text::Wrap; +use ExtUtils::Constant::Utils qw(C_stringify perl_stringify); +$VERSION = '0.04'; + +use constant is_perl56 => ($] < 5.007 && $] > 5.005_50); + + +=head1 NAME + +ExtUtils::Constant::Base - base class for ExtUtils::Constant objects + +=head1 SYNOPSIS + + require ExtUtils::Constant::Base; + @ISA = 'ExtUtils::Constant::Base'; + +=head1 DESCRIPTION + +ExtUtils::Constant::Base provides a base implementation of methods to +generate C code to give fast constant value lookup by named string. Currently +it's mostly used ExtUtils::Constant::XS, which generates the lookup code +for the constant() subroutine found in many XS modules. + +=head1 USAGE + +ExtUtils::Constant::Base exports no subroutines. The following methods are +available + +=over 4 + +=cut + +sub valid_type { + # Default to assuming that you don't need different types of return data. + 1; +} +sub default_type { + ''; +} + +=item header + +A method returning a scalar containing definitions needed, typically for a +C header file. + +=cut + +sub header { + '' +} + +# This might actually be a return statement. Note that you are responsible +# for any space you might need before your value, as it lets to perform +# "tricks" such as "return KEY_" and have strings appended. +sub assignment_clause_for_type; +# In which case this might be an empty string +sub return_statement_for_type {undef}; +sub return_statement_for_notdef; +sub return_statement_for_notfound; + +# "#if 1" is true to a C pre-processor +sub macro_from_name { + 1; +} + +sub macro_from_item { + 1; +} + +sub macro_to_ifdef { + my ($self, $macro) = @_; + if (ref $macro) { + return $macro->[0]; + } + if (defined $macro && $macro ne "" && $macro ne "1") { + return $macro ? "#ifdef $macro\n" : "#if 0\n"; + } + return ""; +} + +sub macro_to_endif { + my ($self, $macro) = @_; + + if (ref $macro) { + return $macro->[1]; + } + if (defined $macro && $macro ne "" && $macro ne "1") { + return "#endif\n"; + } + return ""; +} + +sub name_param { + 'name'; +} + +# This is possibly buggy, in that it's not mandatory (below, in the main +# C_constant parameters, but is expected to exist here, if it's needed) +# Buggy because if you're definitely pure 8 bit only, and will never be +# presented with your constants in utf8, the default form of C_constant can't +# be told not to do the utf8 version. + +sub is_utf8_param { + 'utf8'; +} + +sub memEQ { + "!memcmp"; +} + +=item memEQ_clause args_hashref + +A method to return a suitable C C<if> statement to check whether I<name> +is equal to the C variable C<name>. If I<checked_at> is defined, then it +is used to avoid C<memEQ> for short names, or to generate a comment to +highlight the position of the character in the C<switch> statement. + +If i<checked_at> is a reference to a scalar, then instead it gives +the characters pre-checked at the beginning, (and the number of chars by +which the C variable name has been advanced. These need to be chopped from +the front of I<name>). + +=cut + +sub memEQ_clause { +# if (memEQ(name, "thingy", 6)) { + # Which could actually be a character comparison or even "" + my ($self, $args) = @_; + my ($name, $checked_at, $indent) = @{$args}{qw(name checked_at indent)}; + $indent = ' ' x ($indent || 4); + my $front_chop; + if (ref $checked_at) { + # regexp won't work on 5.6.1 without use utf8; in turn that won't work + # on 5.005_03. + substr ($name, 0, length $$checked_at,) = ''; + $front_chop = C_stringify ($$checked_at); + undef $checked_at; + } + my $len = length $name; + + if ($len < 2) { + return $indent . "{\n" + if (defined $checked_at and $checked_at == 0) or $len == 0; + # We didn't switch, drop through to the code for the 2 character string + $checked_at = 1; + } + + my $name_param = $self->name_param; + + 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); + # Placate 5.005 with a break in the string. I can't see a good way of + # getting it to not take [ as introducing an array lookup, even with + # ${name_param}[$check] + return $indent . "if ($name_param" . "[$check] == '$char') {\n"; + } + } + if (($len == 2 and !defined $checked_at) + or ($len == 3 and defined ($checked_at) and $checked_at == 2)) { + my $char1 = C_stringify (substr $name, 0, 1); + my $char2 = C_stringify (substr $name, 1, 1); + return $indent . + "if ($name_param" . "[0] == '$char1' && $name_param" . "[1] == '$char2') {\n"; + } + if (($len == 3 and defined ($checked_at) and $checked_at == 1)) { + my $char1 = C_stringify (substr $name, 0, 1); + my $char2 = C_stringify (substr $name, 2, 1); + return $indent . + "if ($name_param" . "[0] == '$char1' && $name_param" . "[2] == '$char2') {\n"; + } + + my $pointer = '^'; + my $have_checked_last = defined ($checked_at) && $len == $checked_at + 1; + if ($have_checked_last) { + # Checked at the last character, so no need to memEQ it. + $pointer = C_stringify (chop $name); + $len--; + } + + $name = C_stringify ($name); + my $memEQ = $self->memEQ(); + my $body = $indent . "if ($memEQ($name_param, \"$name\", $len)) {\n"; + # Put a little ^ under the letter we checked at + # Screws up for non printable and non-7 bit stuff, but that's too hard to + # get right. + if (defined $checked_at) { + $body .= $indent . "/* " . (' ' x length $memEQ) + . (' ' x length $name_param) + . (' ' x $checked_at) . $pointer + . (' ' x ($len - $checked_at + length $len)) . " */\n"; + } elsif (defined $front_chop) { + $body .= $indent . "/* $front_chop" + . (' ' x ($len + 1 + length $len)) . " */\n"; + } + return $body; +} + +=item dump_names arg_hashref, ITEM... + +An internal function to generate the embedded perl code that will regenerate +the constant subroutines. I<default_type>, I<types> and I<ITEM>s are the +same as for C_constant. I<indent> is treated as number of spaces to indent +by. If C<declare_types> is true a C<$types> is always declared in the perl +code generated, if defined and false never declared, and if undefined C<$types> +is only declared if the values in I<types> as passed in cannot be inferred from +I<default_types> and the I<ITEM>s. + +=cut + +sub dump_names { + my ($self, $args, @items) = @_; + my ($default_type, $what, $indent, $declare_types) + = @{$args}{qw(default_type what indent declare_types)}; + $indent = ' ' x ($indent || 0); + + my $result; + my (@simple, @complex, %used_types); + foreach (@items) { + my $type; + if (ref $_) { + $type = $_->{type} || $default_type; + if ($_->{utf8}) { + # For simplicity always skip the bytes case, and reconstitute this entry + # from its utf8 twin. + next if $_->{utf8} eq 'no'; + # Copy the hashref, as we don't want to mess with the caller's hashref. + $_ = {%$_}; + unless (is_perl56) { + utf8::decode ($_->{name}); + } else { + $_->{name} = pack 'U*', unpack 'U0U*', $_->{name}; + } + delete $_->{utf8}; + } + } else { + $_ = {name=>$_}; + $type = $default_type; + } + $used_types{$type}++; + if ($type eq $default_type + # grr 5.6.1 + and length $_->{name} + and length $_->{name} == ($_->{name} =~ tr/A-Za-z0-9_//) + and !defined ($_->{macro}) and !defined ($_->{value}) + and !defined ($_->{default}) and !defined ($_->{pre}) + and !defined ($_->{post}) and !defined ($_->{def_pre}) + and !defined ($_->{def_post}) and !defined ($_->{weight})) { + # It's the default type, and the name consists only of A-Za-z0-9_ + push @simple, $_->{name}; + } else { + push @complex, $_; + } + } + + if (!defined $declare_types) { + # Do they pass in any types we weren't already using? + foreach (keys %$what) { + next if $used_types{$_}; + $declare_types++; # Found one in $what that wasn't used. + last; # And one is enough to terminate this loop + } + } + if ($declare_types) { + $result = $indent . 'my $types = {map {($_, 1)} qw(' + . join (" ", sort keys %$what) . ")};\n"; + } + local $Text::Wrap::huge = 'overflow'; + local $Text::Wrap::columns = 80; + $result .= wrap ($indent . "my \@names = (qw(", + $indent . " ", join (" ", sort @simple) . ")"); + if (@complex) { + foreach my $item (sort {$a->{name} cmp $b->{name}} @complex) { + my $name = perl_stringify $item->{name}; + my $line = ",\n$indent {name=>\"$name\""; + $line .= ", type=>\"$item->{type}\"" if defined $item->{type}; + foreach my $thing (qw (macro value default pre post def_pre def_post)) { + my $value = $item->{$thing}; + if (defined $value) { + if (ref $value) { + $line .= ", $thing=>[\"" + . join ('", "', map {perl_stringify $_} @$value) . '"]'; + } else { + $line .= ", $thing=>\"" . perl_stringify($value) . "\""; + } + } + } + $line .= "}"; + # Ensure that the enclosing C comment doesn't end + # by turning */ into *" . "/ + $line =~ s!\*\/!\*" . "/!gs; + # gcc -Wall doesn't like finding /* inside a comment + $line =~ s!\/\*!/" . "\*!gs; + $result .= $line; + } + } + $result .= ");\n"; + + $result; +} + +=item assign arg_hashref, VALUE... + +A method to return a suitable assignment clause. If I<type> is aggregate +(eg I<PVN> expects both pointer and length) then there should be multiple +I<VALUE>s for the components. I<pre> and I<post> if defined give snippets +of C code to proceed and follow the assignment. I<pre> will be at the start +of a block, so variables may be defined in it. + +=cut +# Hmm. value undef to to NOTDEF? value () to do NOTFOUND? + +sub assign { + my $self = shift; + my $args = shift; + my ($indent, $type, $pre, $post, $item) + = @{$args}{qw(indent type pre post item)}; + $post ||= ''; + my $clause; + my $close; + if ($pre) { + chomp $pre; + $close = "$indent}\n"; + $clause = $indent . "{\n"; + $indent .= " "; + $clause .= "$indent$pre"; + $clause .= ";" unless $pre =~ /;$/; + $clause .= "\n"; + } + confess "undef \$type" unless defined $type; + confess "Can't generate code for type $type" + unless $self->valid_type($type); + + $clause .= join '', map {"$indent$_\n"} + $self->assignment_clause_for_type({type=>$type,item=>$item}, @_); + chomp $post; + if (length $post) { + $clause .= "$post"; + $clause .= ";" unless $post =~ /;$/; + $clause .= "\n"; + } + my $return = $self->return_statement_for_type($type); + $clause .= "$indent$return\n" if defined $return; + $clause .= $close if $close; + return $clause; +} + +=item return_clause arg_hashref, ITEM + +A method to return a suitable C<#ifdef> clause. I<ITEM> is a hashref +(as passed to C<C_constant> and C<match_clause>. I<indent> is the number +of spaces to indent, defaulting to 6. + +=cut + +sub return_clause { + +##ifdef thingy +# *iv_return = thingy; +# return PERL_constant_ISIV; +##else +# return PERL_constant_NOTDEF; +##endif + my ($self, $args, $item) = @_; + my $indent = $args->{indent}; + + my ($name, $value, $default, $pre, $post, $def_pre, $def_post, $type) + = @$item{qw (name value default pre post def_pre def_post type)}; + $value = $name unless defined $value; + my $macro = $self->macro_from_item($item); + $indent = ' ' x ($indent || 6); + unless (defined $type) { + # use Data::Dumper; print STDERR Dumper ($item); + confess "undef \$type"; + } + + ##ifdef thingy + my $clause = $self->macro_to_ifdef($macro); + + # *iv_return = thingy; + # return PERL_constant_ISIV; + $clause + .= $self->assign ({indent=>$indent, type=>$type, pre=>$pre, post=>$post, + item=>$item}, ref $value ? @$value : $value); + + if (defined $macro && $macro ne "" && $macro ne "1") { + ##else + $clause .= "#else\n"; + + # return PERL_constant_NOTDEF; + if (!defined $default) { + my $notdef = $self->return_statement_for_notdef(); + $clause .= "$indent$notdef\n" if defined $notdef; + } else { + my @default = ref $default ? @$default : $default; + $type = shift @default; + $clause .= $self->assign ({indent=>$indent, type=>$type, pre=>$pre, + post=>$post, item=>$item}, @default); + } + } + ##endif + $clause .= $self->macro_to_endif($macro); + + return $clause; +} + +sub match_clause { + # $offset defined if we have checked an offset. + my ($self, $args, $item) = @_; + my ($offset, $indent) = @{$args}{qw(checked_at indent)}; + $indent = ' ' x ($indent || 4); + my $body = ''; + my ($no, $yes, $either, $name, $inner_indent); + if (ref $item eq 'ARRAY') { + ($yes, $no) = @$item; + $either = $yes || $no; + confess "$item is $either expecting hashref in [0] || [1]" + unless ref $either eq 'HASH'; + $name = $either->{name}; + } else { + confess "$item->{name} has utf8 flag '$item->{utf8}', should be false" + if $item->{utf8}; + $name = $item->{name}; + $inner_indent = $indent; + } + + $body .= $self->memEQ_clause ({name => $name, checked_at => $offset, + indent => length $indent}); + # If we've been presented with an arrayref for $item, then the user string + # contains in the range 128-255, and we need to check whether it was utf8 + # (or not). + # In the worst case we have two named constants, where one's name happens + # encoded in UTF8 happens to be the same byte sequence as the second's + # encoded in (say) ISO-8859-1. + # In this case, $yes and $no both have item hashrefs. + if ($yes) { + $body .= $indent . " if (" . $self->is_utf8_param . ") {\n"; + } elsif ($no) { + $body .= $indent . " if (!" . $self->is_utf8_param . ") {\n"; + } + if ($either) { + $body .= $self->return_clause ({indent=>4 + length $indent}, $either); + if ($yes and $no) { + $body .= $indent . " } else {\n"; + $body .= $self->return_clause ({indent=>4 + length $indent}, $no); + } + $body .= $indent . " }\n"; + } else { + $body .= $self->return_clause ({indent=>2 + length $indent}, $item); + } + $body .= $indent . "}\n"; +} + + +=item switch_clause arg_hashref, NAMELEN, ITEMHASH, ITEM... + +An internal method to generate a suitable C<switch> clause, called by +C<C_constant> I<ITEM>s are in the hash ref format as given in the description +of C<C_constant>, and must all have the names of the same length, given by +I<NAMELEN>. I<ITEMHASH> is a reference to a hash, keyed by name, values being +the hashrefs in the I<ITEM> list. (No parameters are modified, and there can +be keys in the I<ITEMHASH> that are not in the list of I<ITEM>s without +causing problems - the hash is passed in to save generating it afresh for +each call). + +=cut + +sub switch_clause { + my ($self, $args, $namelen, $items, @items) = @_; + my ($indent, $comment) = @{$args}{qw(indent comment)}; + $indent = ' ' x ($indent || 2); + + local $Text::Wrap::huge = 'overflow'; + local $Text::Wrap::columns = 80; + + my @names = sort map {$_->{name}} @items; + my $leader = $indent . '/* '; + my $follower = ' ' x length $leader; + my $body = $indent . "/* Names all of length $namelen. */\n"; + if (defined $comment) { + $body = wrap ($leader, $follower, $comment) . "\n"; + $leader = $follower; + } + my @safe_names = @names; + foreach (@safe_names) { + confess sprintf "Name '$_' is length %d, not $namelen", length + unless length == $namelen; + # Argh. 5.6.1 + # next unless tr/A-Za-z0-9_//c; + next if tr/A-Za-z0-9_// == length; + $_ = '"' . perl_stringify ($_) . '"'; + # Ensure that the enclosing C comment doesn't end + # by turning */ into *" . "/ + s!\*\/!\*"."/!gs; + # gcc -Wall doesn't like finding /* inside a comment + s!\/\*!/"."\*!gs; + } + $body .= wrap ($leader, $follower, join (" ", @safe_names) . " */") . "\n"; + # Figure out what to switch on. + # (RMS, Spread of jump table, Position, Hashref) + my @best = (1e38, ~0); + # Prefer the last character over the others. (As it lets us shorten the + # memEQ clause at no cost). + foreach my $i ($namelen - 1, 0 .. ($namelen - 2)) { + my ($min, $max) = (~0, 0); + my %spread; + if (is_perl56) { + # Need proper Unicode preserving hash keys for bytes in range 128-255 + # here too, for some reason. grr 5.6.1 yet again. + tie %spread, 'ExtUtils::Constant::Aaargh56Hash'; + } + foreach (@names) { + my $char = substr $_, $i, 1; + my $ord = ord $char; + confess "char $ord is out of range" if $ord > 255; + $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. :-) + # OK. Trump that. Now favour the last character of the string, before the + # rest. + 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); + } + } + confess "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 .= $indent . "/* Offset $offset gives the best switch position. */\n"; + + my $do_front_chop = $offset == 0 && $namelen > 2; + if ($do_front_chop) { + $body .= $indent . "switch (*" . $self->name_param() . "++) {\n"; + } else { + $body .= $indent . "switch (" . $self->name_param() . "[$offset]) {\n"; + } + foreach my $char (sort keys %$best) { + confess sprintf "'$char' is %d bytes long, not 1", length $char + if length ($char) != 1; + confess sprintf "char %#X is out of range", ord $char if ord ($char) > 255; + $body .= $indent . "case '" . C_stringify ($char) . "':\n"; + foreach my $thisone (sort { + # Deal with the case of an item actually being an array ref to 1 or 2 + # hashrefs. Don't assign to $a or $b, as they're aliases to the orignal + my $l = ref $a eq 'ARRAY' ? ($a->[0] || $->[1]) : $a; + my $r = ref $b eq 'ARRAY' ? ($b->[0] || $->[1]) : $b; + # Sort by weight first + ($r->{weight} || 0) <=> ($l->{weight} || 0) + # Sort equal weights by name + or $l->{name} cmp $r->{name}} + # If this looks evil, maybe it is. $items is a + # hashref, and we're doing a hash slice on it + @{$items}{@{$best->{$char}}}) { + # warn "You are here"; + if ($do_front_chop) { + $body .= $self->match_clause ({indent => 2 + length $indent, + checked_at => \$char}, $thisone); + } else { + $body .= $self->match_clause ({indent => 2 + length $indent, + checked_at => $offset}, $thisone); + } + } + $body .= $indent . " break;\n"; + } + $body .= $indent . "}\n"; + return $body; +} + +sub C_constant_return_type { + "static int"; +} + +sub C_constant_prefix_param { + ''; +} + +sub C_constant_prefix_param_defintion { + ''; +} + +sub name_param_definition { + "const char *" . $_[0]->name_param; +} + +sub namelen_param { + 'len'; +} + +sub namelen_param_definition { + 'size_t ' . $_[0]->namelen_param; +} + +sub C_constant_other_params { + ''; +} + +sub C_constant_other_params_defintion { + ''; +} + +=item params WHAT + +An "internal" method, subject to change, currently called to allow an +overriding class to cache information that will then be passed into all +the C<*param*> calls. (Yes, having to read the source to make sense of this is +considered a known bug). I<WHAT> is be a hashref of types the constant +function will return. In ExtUtils::Constant::XS this method is used to +returns a hashref keyed IV NV PV SV to show which combination of pointers will +be needed in the C argument list generated by +C_constant_other_params_definition and C_constant_other_params + +=cut + +sub params { + ''; +} + + +=item dogfood arg_hashref, ITEM... + +An internal function to generate the embedded perl code that will regenerate +the constant subroutines. Parameters are the same as for C_constant. + +Currently the base class does nothing and returns an empty string. + +=cut + +sub dogfood { + '' +} + +=item normalise_items args, default_type, seen_types, seen_items, ITEM... + +Convert the items to a normalised form. For 8 bit and Unicode values converts +the item to an array of 1 or 2 items, both 8 bit and UTF-8 encoded. + +=cut + +sub normalise_items +{ + my $self = shift; + my $args = shift; + my $default_type = shift; + my $what = shift; + my $items = shift; + my @new_items; + foreach my $orig (@_) { + my ($name, $item); + if (ref $orig) { + # Make a copy which is a normalised version of the ref passed in. + $name = $orig->{name}; + my ($type, $macro, $value) = @$orig{qw (type macro value)}; + $type ||= $default_type; + $what->{$type} = 1; + $item = {name=>$name, type=>$type}; + + undef $macro if defined $macro and $macro eq $name; + $item->{macro} = $macro if defined $macro; + undef $value if defined $value and $value eq $name; + $item->{value} = $value if defined $value; + foreach my $key (qw(default pre post def_pre def_post weight + not_constant)) { + my $value = $orig->{$key}; + $item->{$key} = $value if defined $value; + # warn "$key $value"; + } + } else { + $name = $orig; + $item = {name=>$name, type=>$default_type}; + $what->{$default_type} = 1; + } + warn +(ref ($self) || $self) + . "doesn't know how to handle values of type $_ used in macro $name" + unless $self->valid_type ($item->{type}); + # tr///c is broken on 5.6.1 for utf8, so my original tr/\0-\177//c + # doesn't work. Upgrade to 5.8 + # if ($name !~ tr/\0-\177//c || $] < 5.005_50) { + if ($name =~ tr/\0-\177// == length $name || $] < 5.005_50 + || $args->{disable_utf8_duplication}) { + # No characters outside 7 bit ASCII. + if (exists $items->{$name}) { + die "Multiple definitions for macro $name"; + } + $items->{$name} = $item; + } else { + # No characters outside 8 bit. This is hardest. + if (exists $items->{$name} and ref $items->{$name} ne 'ARRAY') { + confess "Unexpected ASCII definition for macro $name"; + } + # Again, 5.6.1 tr broken, so s/5\.6.*/5\.8\.0/; + # if ($name !~ tr/\0-\377//c) { + if ($name =~ tr/\0-\377// == length $name) { +# if ($] < 5.007) { +# $name = pack "C*", unpack "U*", $name; +# } + $item->{utf8} = 'no'; + $items->{$name}[1] = $item; + push @new_items, $item; + # Copy item, to create the utf8 variant. + $item = {%$item}; + } + # Encode the name as utf8 bytes. + unless (is_perl56) { + utf8::encode($name); + } else { +# warn "Was >$name< " . length ${name}; + $name = pack 'C*', unpack 'C*', $name . pack 'U*'; +# warn "Now '${name}' " . length ${name}; + } + if ($items->{$name}[0]) { + die "Multiple definitions for macro $name"; + } + $item->{utf8} = 'yes'; + $item->{name} = $name; + $items->{$name}[0] = $item; + # We have need for the utf8 flag. + $what->{''} = 1; + } + push @new_items, $item; + } + @new_items; +} + +=item C_constant arg_hashref, ITEM... + +A function that returns a B<list> of C subroutine definitions that return +the value and type of constants when passed the name by the XS wrapper. +I<ITEM...> 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<IV>, I<NV> 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<name> if not given. + +=item macro + +The C pre-processor macro to use in the C<#ifdef>. This defaults to the +I<name>, and is mainly used if I<value> is an C<enum>. If a reference an +array is passed then the first element is used in place of the C<#ifdef> +line, and the second element in place of the C<#endif>. This allows +pre-processor constructions such as + + #if defined (foo) + #if !defined (bar) + ... + #endif + #endif + +to be used to determine if a constant is to be defined. + +A "macro" 1 signals that the constant is always defined, so the C<#if>/C<#endif> +test is omitted. + +=item default + +Default value to use (instead of C<croak>ing with "your vendor has not +defined...") to return if the macro isn't defined. Specify a reference to +an array with type followed by value(s). + +=item pre + +C code to use before the assignment of the value of the constant. This allows +you to use temporary variables to extract a value from part of a C<struct> +and return this as I<value>. This C code is places at the start of a block, +so you can declare variables in it. + +=item post + +C code to place between the assignment of value (to a temporary) and the +return from the function. This allows you to clear up anything in I<pre>. +Rarely needed. + +=item def_pre + +=item def_post + +Equivalents of I<pre> and I<post> for the default value. + +=item utf8 + +Generated internally. Is zero or undefined if name is 7 bit ASCII, +"no" if the name is 8 bit (and so should only match if SvUTF8() is false), +"yes" if the name is utf8 encoded. + +The internals automatically clone any name with characters 128-255 but none +256+ (ie one that could be either in bytes or utf8) into a second entry +which is utf8 encoded. + +=item weight + +Optional sorting weight for names, to determine the order of +linear testing when multiple names fall in the same case of a switch clause. +Higher comes earlier, undefined defaults to zero. + +=back + +In the argument hashref, I<package> is the name of the package, and is only +used in comments inside the generated C code. I<subname> defaults to +C<constant> if undefined. + +I<default_type> is the type returned by C<ITEM>s that don't specify their +type. It defaults to the value of C<default_type()>. I<types> should be given +either as a comma separated list of types that the C subroutine I<subname> +will generate or as a reference to a hash. I<default_type> will be added to +the list if not present, as will any types given in the list of I<ITEM>s. The +resultant list should be the same list of types that C<XS_constant> is +given. [Otherwise C<XS_constant> and C<C_constant> may differ in the number of +parameters to the constant function. I<indent> 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<breakout> governs when child functions of I<subname> are generated. If there +are I<breakout> or more I<ITEM>s with the same length of name, then the code +to switch between them is placed into a function named I<subname>_I<len>, for +example C<constant_5> for names 5 characters long. The default I<breakout> is +3. A single C<ITEM> is always inlined. + +=cut + +# The parameter now BREAKOUT was previously documented as: +# +# I<NAMELEN> if defined signals that all the I<name>s of the I<ITEM>s 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<undef> +# 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. +# +# As you can see it now performs this function during recursion by being a +# scalar reference. + +sub C_constant { + my ($self, $args, @items) = @_; + my ($package, $subname, $default_type, $what, $indent, $breakout) = + @{$args}{qw(package subname default_type types indent breakout)}; + $package ||= 'Foo'; + $subname ||= 'constant'; + # I'm not using this. But a hashref could be used for full formatting without + # breaking this API + # $indent ||= 0; + + my ($namelen, $items); + if (ref $breakout) { + # We are called recursively. We trust @items to be normalised, $what to + # be a hashref, and pinch %$items from our parent to save recalculation. + ($namelen, $items) = @$breakout; + } else { + $items = {}; + if (is_perl56) { + # Need proper Unicode preserving hash keys. + require ExtUtils::Constant::Aaargh56Hash; + tie %$items, 'ExtUtils::Constant::Aaargh56Hash'; + } + $breakout ||= 3; + $default_type ||= $self->default_type(); + 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 + } + @items = $self->normalise_items ({}, $default_type, $what, $items, @items); + # use Data::Dumper; print Dumper @items; + } + my $params = $self->params ($what); + + # Probably "static int" + my ($body, @subs); + $body = $self->C_constant_return_type($params) . "\n$subname (" + # Eg "pTHX_ " + . $self->C_constant_prefix_param_defintion($params) + # Probably "const char *name" + . $self->name_param_definition($params); + # Something like ", STRLEN len" + $body .= ", " . $self->namelen_param_definition($params) + unless defined $namelen; + $body .= $self->C_constant_other_params_defintion($params); + $body .= ") {\n"; + + if (defined $namelen) { + # We are a child subroutine. Print the simple description + my $comment = 'When generated this function returned values for the list' + . ' of names given here. However, subsequent manual editing may have' + . ' added or removed some.'; + $body .= $self->switch_clause ({indent=>2, comment=>$comment}, + $namelen, $items, @items); + } else { + # We are the top level. + $body .= " /* Initially switch on the length of the name. */\n"; + $body .= $self->dogfood ({package => $package, subname => $subname, + default_type => $default_type, what => $what, + indent => $indent, breakout => $breakout}, + @items); + $body .= ' switch ('.$self->namelen_param().") {\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 $only_thing = $by_length[$i]->[0]; + if ($only_thing->{utf8}) { + if ($only_thing->{utf8} eq 'yes') { + # With utf8 on flag item is passed in element 0 + $body .= $self->match_clause (undef, [$only_thing]); + } else { + # With utf8 off flag item is passed in element 1 + $body .= $self->match_clause (undef, [undef, $only_thing]); + } + } else { + $body .= $self->match_clause (undef, $only_thing); + } + } elsif (@{$by_length[$i]} < $breakout) { + $body .= $self->switch_clause ({indent=>4}, + $i, $items, @{$by_length[$i]}); + } else { + # Only use the minimal set of parameters actually needed by the types + # of the names of this length. + my $what = {}; + foreach (@{$by_length[$i]}) { + $what->{$_->{type}} = 1; + $what->{''} = 1 if $_->{utf8}; + } + $params = $self->params ($what); + push @subs, $self->C_constant ({package=>$package, + subname=>"${subname}_$i", + default_type => $default_type, + types => $what, indent => $indent, + breakout => [$i, $items]}, + @{$by_length[$i]}); + $body .= " return ${subname}_$i (" + # Eg "aTHX_ " + . $self->C_constant_prefix_param($params) + # Probably "name" + . $self->name_param($params); + $body .= $self->C_constant_other_params($params); + $body .= ");\n"; + } + $body .= " break;\n"; + } + $body .= " }\n"; + } + my $notfound = $self->return_statement_for_notfound(); + $body .= " $notfound\n" if $notfound; + $body .= "}\n"; + return (@subs, $body); +} + +1; +__END__ + +=back + +=head1 BUGS + +Not everything is documented yet. + +Probably others. + +=head1 AUTHOR + +Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and +others diff --git a/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm b/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm new file mode 100644 index 0000000000..c3fe8ed3c5 --- /dev/null +++ b/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm @@ -0,0 +1,549 @@ +package ExtUtils::Constant::ProxySubs; + +use strict; +use vars qw($VERSION @ISA %type_to_struct %type_from_struct %type_to_sv + %type_to_C_value %type_is_a_problem %type_num_args + %type_temporary); +use Carp; +require ExtUtils::Constant::XS; +use ExtUtils::Constant::Utils qw(C_stringify); +use ExtUtils::Constant::XS qw(%XS_TypeSet); + +$VERSION = '0.06'; +@ISA = 'ExtUtils::Constant::XS'; + +%type_to_struct = + ( + IV => '{const char *name; I32 namelen; IV value;}', + NV => '{const char *name; I32 namelen; NV value;}', + UV => '{const char *name; I32 namelen; UV value;}', + PV => '{const char *name; I32 namelen; const char *value;}', + PVN => '{const char *name; I32 namelen; const char *value; STRLEN len;}', + YES => '{const char *name; I32 namelen;}', + NO => '{const char *name; I32 namelen;}', + UNDEF => '{const char *name; I32 namelen;}', + '' => '{const char *name; I32 namelen;} ', + ); + +%type_from_struct = + ( + IV => sub { $_[0] . '->value' }, + NV => sub { $_[0] . '->value' }, + UV => sub { $_[0] . '->value' }, + PV => sub { $_[0] . '->value' }, + PVN => sub { $_[0] . '->value', $_[0] . '->len' }, + YES => sub {}, + NO => sub {}, + UNDEF => sub {}, + '' => sub {}, + ); + +%type_to_sv = + ( + IV => sub { "newSViv($_[0])" }, + NV => sub { "newSVnv($_[0])" }, + UV => sub { "newSVuv($_[0])" }, + PV => sub { "newSVpv($_[0], 0)" }, + PVN => sub { "newSVpvn($_[0], $_[1])" }, + YES => sub { '&PL_sv_yes' }, + NO => sub { '&PL_sv_no' }, + UNDEF => sub { '&PL_sv_undef' }, + '' => sub { '&PL_sv_yes' }, + SV => sub {"SvREFCNT_inc($_[0])"}, + ); + +%type_to_C_value = + ( + YES => sub {}, + NO => sub {}, + UNDEF => sub {}, + '' => sub {}, + ); + +sub type_to_C_value { + my ($self, $type) = @_; + return $type_to_C_value{$type} || sub {return map {ref $_ ? @$_ : $_} @_}; +} + +# TODO - figure out if there is a clean way for the type_to_sv code to +# attempt s/sv_2mortal// and if it succeeds tell type_to_sv not to add +# SvREFCNT_inc +%type_is_a_problem = + ( + # The documentation says *mortal SV*, but we now need a non-mortal copy. + SV => 1, + ); + +%type_temporary = + ( + SV => ['SV *'], + PV => ['const char *'], + PVN => ['const char *', 'STRLEN'], + ); +$type_temporary{$_} = [$_] foreach qw(IV UV NV); + +while (my ($type, $value) = each %XS_TypeSet) { + $type_num_args{$type} + = defined $value ? ref $value ? scalar @$value : 1 : 0; +} +$type_num_args{''} = 0; + +sub partition_names { + my ($self, $default_type, @items) = @_; + my (%found, @notfound, @trouble); + + while (my $item = shift @items) { + my $default = delete $item->{default}; + if ($default) { + # If we find a default value, convert it into a regular item and + # append it to the queue of items to process + my $default_item = {%$item}; + $default_item->{invert_macro} = 1; + $default_item->{pre} = delete $item->{def_pre}; + $default_item->{post} = delete $item->{def_post}; + $default_item->{type} = shift @$default; + $default_item->{value} = $default; + push @items, $default_item; + } else { + # It can be "not found" unless it's the default (invert the macro) + # or the "macro" is an empty string (ie no macro) + push @notfound, $item unless $item->{invert_macro} + or !$self->macro_to_ifdef($self->macro_from_item($item)); + } + + if ($item->{pre} or $item->{post} or $item->{not_constant} + or $type_is_a_problem{$item->{type}}) { + push @trouble, $item; + } else { + push @{$found{$item->{type}}}, $item; + } + } + # use Data::Dumper; print Dumper \%found; + (\%found, \@notfound, \@trouble); +} + +sub boottime_iterator { + my ($self, $type, $iterator, $hash, $subname) = @_; + my $extractor = $type_from_struct{$type}; + die "Can't find extractor code for type $type" + unless defined $extractor; + my $generator = $type_to_sv{$type}; + die "Can't find generator code for type $type" + unless defined $generator; + + my $athx = $self->C_constant_prefix_param(); + + return sprintf <<"EOBOOT", &$generator(&$extractor($iterator)); + while ($iterator->name) { + $subname($athx $hash, $iterator->name, + $iterator->namelen, %s); + ++$iterator; + } +EOBOOT +} + +sub name_len_value_macro { + my ($self, $item) = @_; + my $name = $item->{name}; + my $value = $item->{value}; + $value = $item->{name} unless defined $value; + + my $namelen = length $name; + if ($name =~ tr/\0-\377// != $namelen) { + # the hash API signals UTF-8 by passing the length negated. + utf8::encode($name); + $namelen = -length $name; + } + $name = C_stringify($name); + + my $macro = $self->macro_from_item($item); + ($name, $namelen, $value, $macro); +} + +sub WriteConstants { + my $self = shift; + my $ARGS = {@_}; + + my ($c_fh, $xs_fh, $c_subname, $xs_subname, $default_type, $package) + = @{$ARGS}{qw(C_FH XS_FH C_SUBNAME XS_SUBNAME DEFAULT_TYPE NAME)}; + + my $options = $ARGS->{PROXYSUBS}; + $options = {} unless ref $options; + my $explosives = $options->{croak_on_read}; + + $xs_subname ||= 'constant'; + + # If anyone is insane enough to suggest a package name containing % + my $package_sprintf_safe = $package; + $package_sprintf_safe =~ s/%/%%/g; + + # All the types we see + my $what = {}; + # A hash to lookup items with. + my $items = {}; + + my @items = $self->normalise_items ({disable_utf8_duplication => 1}, + $default_type, $what, $items, + @{$ARGS->{NAMES}}); + + # Partition the values by type. Also include any defaults in here + # Everything that doesn't have a default needs alternative code for + # "I'm missing" + # And everything that has pre or post code ends up in a private block + my ($found, $notfound, $trouble) + = $self->partition_names($default_type, @items); + + my $pthx = $self->C_constant_prefix_param_defintion(); + my $athx = $self->C_constant_prefix_param(); + my $symbol_table = C_stringify($package) . '::'; + + my $can_do_pcs = $] >= 5.009; + my $cast_CONSTSUB = $] < 5.010 ? '(char *)' : ''; + + print $c_fh $self->header(), <<"EOADD"; +static void +${c_subname}_add_symbol($pthx HV *hash, const char *name, I32 namelen, SV *value) { +EOADD + if (!$can_do_pcs) { + print $c_fh <<'EO_NOPCS'; + if (namelen == namelen) { +EO_NOPCS + } else { + print $c_fh <<"EO_PCS"; + SV **sv = hv_fetch(hash, name, namelen, TRUE); + if (!sv) { + Perl_croak($athx "Couldn't add key '%s' to %%$package_sprintf_safe\::", + name); + } + if (SvOK(*sv) || SvTYPE(*sv) == SVt_PVGV) { + /* Someone has been here before us - have to make a real sub. */ +EO_PCS + } + # This piece of code is common to both + print $c_fh <<"EOADD"; + newCONSTSUB(hash, ${cast_CONSTSUB}name, value); +EOADD + if ($can_do_pcs) { + print $c_fh <<'EO_PCS'; + } else { + SvUPGRADE(*sv, SVt_RV); + SvRV_set(*sv, value); + SvROK_on(*sv); + SvREADONLY_on(value); + } +EO_PCS + } else { + print $c_fh <<'EO_NOPCS'; + } +EO_NOPCS + } + print $c_fh <<'EOADD'; +} + +EOADD + + print $c_fh $explosives ? <<"EXPLODE" : "\n"; + +static int +Im_sorry_Dave(pTHX_ SV *sv, MAGIC *mg) +{ + PERL_UNUSED_ARG(mg); + Perl_croak(aTHX_ + "Your vendor has not defined $package_sprintf_safe macro %"SVf + " used", sv); + NORETURN_FUNCTION_END; +} + +static MGVTBL not_defined_vtbl = { + Im_sorry_Dave, /* get - I'm afraid I can't do that */ + Im_sorry_Dave, /* set */ + 0, /* len */ + 0, /* clear */ + 0, /* free */ + 0, /* copy */ + 0, /* dup */ +}; + +EXPLODE + +{ + my $key = $symbol_table; + # Just seems tidier (and slightly more space efficient) not to have keys + # such as Fcntl:: + $key =~ s/::$//; + my $key_len = length $key; + + print $c_fh <<"MISSING"; + +#ifndef SYMBIAN + +/* Store a hash of all symbols missing from the package. To avoid trampling on + the package namespace (uninvited) put each package's hash in our namespace. + To avoid creating lots of typeblogs and symbol tables for sub-packages, put + each package's hash into one hash in our namespace. */ + +static HV * +get_missing_hash(pTHX) { + HV *const parent + = get_hv("ExtUtils::Constant::ProxySubs::Missing", GVf_MULTI); + /* We could make a hash of hashes directly, but this would confuse anything + at Perl space that looks at us, and as we're visible in Perl space, + best to play nice. */ + SV *const *const ref + = hv_fetch(parent, "$key", $key_len, TRUE); + HV *new_hv; + + if (!ref) + return NULL; + + if (SvROK(*ref)) + return (HV*) SvRV(*ref); + + new_hv = newHV(); + SvUPGRADE(*ref, SVt_RV); + SvRV_set(*ref, (SV *)new_hv); + SvROK_on(*ref); + return new_hv; +} + +#endif + +MISSING + +} + + print $xs_fh <<"EOBOOT"; +BOOT: + { +#ifdef dTHX + dTHX; +#endif + HV *symbol_table = get_hv("$symbol_table", GV_ADD); +#ifndef SYMBIAN + HV *${c_subname}_missing; +#endif +EOBOOT + + my %iterator; + + $found->{''} + = [map {{%$_, type=>'', invert_macro => 1}} @$notfound]; + + foreach my $type (sort keys %$found) { + my $struct = $type_to_struct{$type}; + my $type_to_value = $self->type_to_C_value($type); + my $number_of_args = $type_num_args{$type}; + die "Can't find structure definition for type $type" + unless defined $struct; + + my $struct_type = $type ? lc($type) . '_s' : 'notfound_s'; + print $c_fh "struct $struct_type $struct;\n"; + + my $array_name = 'values_for_' . ($type ? lc $type : 'notfound'); + print $xs_fh <<"EOBOOT"; + + static const struct $struct_type $array_name\[] = + { +EOBOOT + + + foreach my $item (@{$found->{$type}}) { + my ($name, $namelen, $value, $macro) + = $self->name_len_value_macro($item); + + my $ifdef = $self->macro_to_ifdef($macro); + if (!$ifdef && $item->{invert_macro}) { + carp("Attempting to supply a default for '$name' which has no conditional macro"); + next; + } + print $xs_fh $ifdef; + if ($item->{invert_macro}) { + print $xs_fh + " /* This is the default value: */\n" if $type; + print $xs_fh "#else\n"; + } + print $xs_fh " { ", join (', ', "\"$name\"", $namelen, + &$type_to_value($value)), " },\n", + $self->macro_to_endif($macro); + } + + + # Terminate the list with a NULL + print $xs_fh " { NULL, 0", (", 0" x $number_of_args), " } };\n"; + + $iterator{$type} = "value_for_" . ($type ? lc $type : 'notfound'); + + print $xs_fh <<"EOBOOT"; + const struct $struct_type *$iterator{$type} = $array_name; +EOBOOT + } + + delete $found->{''}; + + print $xs_fh <<"EOBOOT"; +#ifndef SYMBIAN + ${c_subname}_missing = get_missing_hash(aTHX); +#endif +EOBOOT + + my $add_symbol_subname = $c_subname . '_add_symbol'; + foreach my $type (sort keys %$found) { + print $xs_fh $self->boottime_iterator($type, $iterator{$type}, + 'symbol_table', + $add_symbol_subname); + } + + print $xs_fh <<"EOBOOT"; + while (value_for_notfound->name) { +EOBOOT + + print $xs_fh $explosives ? <<"EXPLODE" : << "DONT"; + SV *tripwire = newSV(0); + + sv_magicext(tripwire, 0, PERL_MAGIC_ext, ¬_defined_vtbl, 0, 0); + SvPV_set(tripwire, (char *)value_for_notfound->name); + if(value_for_notfound->namelen >= 0) { + SvCUR_set(tripwire, value_for_notfound->namelen); + } else { + SvCUR_set(tripwire, -value_for_notfound->namelen); + SvUTF8_on(tripwire); + } + SvPOKp_on(tripwire); + SvREADONLY_on(tripwire); + assert(SvLEN(tripwire) == 0); + + $add_symbol_subname($athx symbol_table, value_for_notfound->name, + value_for_notfound->namelen, tripwire); +EXPLODE + + /* Need to add prototypes, else parsing will vary by platform. */ + SV **sv = hv_fetch(symbol_table, value_for_notfound->name, + value_for_notfound->namelen, TRUE); + if (!sv) { + Perl_croak($athx + "Couldn't add key '%s' to %%$package_sprintf_safe\::", + value_for_notfound->name); + } + if (!SvOK(*sv) && SvTYPE(*sv) != SVt_PVGV) { + /* Nothing was here before, so mark a prototype of "" */ + sv_setpvn(*sv, "", 0); + } else if (SvPOK(*sv) && SvCUR(*sv) == 0) { + /* There is already a prototype of "" - do nothing */ + } else { + /* Someone has been here before us - have to make a real + typeglob. */ + /* It turns out to be incredibly hard to deal with all the + corner cases of sub foo (); and reporting errors correctly, + so lets cheat a bit. Start with a constant subroutine */ + CV *cv = newCONSTSUB(symbol_table, + ${cast_CONSTSUB}value_for_notfound->name, + &PL_sv_yes); + /* and then turn it into a non constant declaration only. */ + SvREFCNT_dec(CvXSUBANY(cv).any_ptr); + CvCONST_off(cv); + CvXSUB(cv) = NULL; + CvXSUBANY(cv).any_ptr = NULL; + } +#ifndef SYMBIAN + if (!hv_store(${c_subname}_missing, value_for_notfound->name, + value_for_notfound->namelen, &PL_sv_yes, 0)) + Perl_croak($athx "Couldn't add key '%s' to missing_hash", + value_for_notfound->name); +#endif +DONT + + print $xs_fh <<"EOBOOT"; + + ++value_for_notfound; + } +EOBOOT + + foreach my $item (@$trouble) { + my ($name, $namelen, $value, $macro) + = $self->name_len_value_macro($item); + my $ifdef = $self->macro_to_ifdef($macro); + my $type = $item->{type}; + my $type_to_value = $self->type_to_C_value($type); + + print $xs_fh $ifdef; + if ($item->{invert_macro}) { + print $xs_fh + " /* This is the default value: */\n" if $type; + print $xs_fh "#else\n"; + } + my $generator = $type_to_sv{$type}; + die "Can't find generator code for type $type" + unless defined $generator; + + print $xs_fh " {\n"; + # We need to use a temporary value because some really troublesome + # items use C pre processor directives in their values, and in turn + # these don't fit nicely in the macro-ised generator functions + my $counter = 0; + printf $xs_fh " %s temp%d;\n", $_, $counter++ + foreach @{$type_temporary{$type}}; + + print $xs_fh " $item->{pre}\n" if $item->{pre}; + + # And because the code in pre might be both declarations and + # statements, we can't declare and assign to the temporaries in one. + $counter = 0; + printf $xs_fh " temp%d = %s;\n", $counter++, $_ + foreach &$type_to_value($value); + + my @tempvarnames = map {sprintf 'temp%d', $_} 0 .. $counter - 1; + printf $xs_fh <<"EOBOOT", $name, &$generator(@tempvarnames); + ${c_subname}_add_symbol($athx symbol_table, "%s", + $namelen, %s); +EOBOOT + print $xs_fh " $item->{post}\n" if $item->{post}; + print $xs_fh " }\n"; + + print $xs_fh $self->macro_to_endif($macro); + } + + print $xs_fh <<EOBOOT; + /* As we've been creating subroutines, we better invalidate any cached + methods */ + ++PL_sub_generation; + } +EOBOOT + + print $xs_fh $explosives ? <<"EXPLODE" : <<"DONT"; + +void +$xs_subname(sv) + INPUT: + SV * sv; + PPCODE: + sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf + ", used", sv); + PUSHs(sv_2mortal(sv)); +EXPLODE + +void +$xs_subname(sv) + PREINIT: + STRLEN len; + INPUT: + SV * sv; + const char * s = SvPV(sv, len); + PPCODE: +#ifdef SYMBIAN + sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro", sv); +#else + HV *${c_subname}_missing = get_missing_hash(aTHX); + if (hv_exists(${c_subname}_missing, s, SvUTF8(sv) ? -(I32)len : (I32)len)) { + sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf + ", used", sv); + } else { + sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro", + sv); + } +#endif + PUSHs(sv_2mortal(sv)); +DONT + +} + +1; diff --git a/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/Utils.pm b/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/Utils.pm new file mode 100644 index 0000000000..016507c72a --- /dev/null +++ b/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/Utils.pm @@ -0,0 +1,131 @@ +package ExtUtils::Constant::Utils; + +use strict; +use vars qw($VERSION @EXPORT_OK @ISA $is_perl56); +use Carp; + +@ISA = 'Exporter'; +@EXPORT_OK = qw(C_stringify perl_stringify); +$VERSION = '0.02'; + +$is_perl56 = ($] < 5.007 && $] > 5.005_50); + +=head1 NAME + +ExtUtils::Constant::Utils - helper functions for ExtUtils::Constant + +=head1 SYNOPSIS + + use ExtUtils::Constant::Utils qw (C_stringify); + $C_code = C_stringify $stuff; + +=head1 DESCRIPTION + +ExtUtils::Constant::Utils packages up utility subroutines used by +ExtUtils::Constant, ExtUtils::Constant::Base and derived classes. All its +functions are explicitly exportable. + +=head1 USAGE + +=over 4 + +=item C_stringify NAME + +A function which returns a 7 bit ASCII correctly \ escaped version of the +string passed suitable for C's "" or ''. It will die if passed Unicode +characters. + +=cut + +# Hopefully make a happy C identifier. +sub C_stringify { + local $_ = shift; + return unless defined $_; + # grr 5.6.1 + confess "Wide character in '$_' intended as a C identifier" + if tr/\0-\377// != length; + # grr 5.6.1 moreso because its regexps will break on data that happens to + # be utf8, which includes my 8 bit test cases. + $_ = pack 'C*', unpack 'U*', $_ . pack 'U*' if $is_perl56; + s/\\/\\\\/g; + s/([\"\'])/\\$1/g; # Grr. fix perl mode. + s/\n/\\n/g; # Ensure newlines don't end up in octal + s/\r/\\r/g; + s/\t/\\t/g; + s/\f/\\f/g; + s/\a/\\a/g; + if (ord('A') == 193) { # EBCDIC has no ^\0-\177 workalike. + s/([[:^print:]])/sprintf "\\%03o", ord $1/ge; + } else { + s/([^\0-\177])/sprintf "\\%03o", ord $1/ge; + } + unless ($] < 5.006) { + # This will elicit a warning on 5.005_03 about [: :] being reserved unless + # I cheat + my $cheat = '([[:^print:]])'; + s/$cheat/sprintf "\\%03o", ord $1/ge; + } else { + require POSIX; + s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge; + } + $_; +} + +=item perl_stringify NAME + +A function which returns a 7 bit ASCII correctly \ escaped version of the +string passed suitable for a perl "" string. + +=cut + +# Hopefully make a happy perl identifier. +sub perl_stringify { + local $_ = shift; + return unless defined $_; + s/\\/\\\\/g; + s/([\"\'])/\\$1/g; # Grr. fix perl mode. + s/\n/\\n/g; # Ensure newlines don't end up in octal + s/\r/\\r/g; + s/\t/\\t/g; + s/\f/\\f/g; + s/\a/\\a/g; + unless ($] < 5.006) { + if ($] > 5.007) { + if (ord('A') == 193) { # EBCDIC has no ^\0-\177 workalike. + s/([[:^print:]])/sprintf "\\x{%X}", ord $1/ge; + } else { + s/([^\0-\177])/sprintf "\\x{%X}", ord $1/ge; + } + } else { + # Grr 5.6.1. And I don't think I can use utf8; to force the regexp + # because 5.005_03 will fail. + # This is grim, but I also can't split on // + my $copy; + foreach my $index (0 .. length ($_) - 1) { + my $char = substr ($_, $index, 1); + $copy .= ($char le "\177") ? $char : sprintf "\\x{%X}", ord $char; + } + $_ = $copy; + } + # This will elicit a warning on 5.005_03 about [: :] being reserved unless + # I cheat + my $cheat = '([[:^print:]])'; + s/$cheat/sprintf "\\%03o", ord $1/ge; + } else { + # Turns out "\x{}" notation only arrived with 5.6 + s/([^\0-\177])/sprintf "\\x%02X", ord $1/ge; + require POSIX; + s/([^A-Za-z0-9_])/POSIX::isprint($1) ? $1 : sprintf "\\%03o", ord $1/ge; + } + $_; +} + +1; +__END__ + +=back + +=head1 AUTHOR + +Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and +others diff --git a/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/XS.pm b/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/XS.pm new file mode 100644 index 0000000000..14eb809714 --- /dev/null +++ b/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/XS.pm @@ -0,0 +1,259 @@ +package ExtUtils::Constant::XS; + +use strict; +use vars qw($VERSION %XS_Constant %XS_TypeSet @ISA @EXPORT_OK $is_perl56); +use Carp; +use ExtUtils::Constant::Utils 'perl_stringify'; +require ExtUtils::Constant::Base; + + +@ISA = qw(ExtUtils::Constant::Base Exporter); +@EXPORT_OK = qw(%XS_Constant %XS_TypeSet); + +$VERSION = '0.03'; + +$is_perl56 = ($] < 5.007 && $] > 5.005_50); + +=head1 NAME + +ExtUtils::Constant::XS - generate C code for XS modules' constants. + +=head1 SYNOPSIS + + require ExtUtils::Constant::XS; + +=head1 DESCRIPTION + +ExtUtils::Constant::XS overrides ExtUtils::Constant::Base to generate C +code for XS modules' constants. + +=head1 BUGS + +Nothing is documented. + +Probably others. + +=head1 AUTHOR + +Nicholas Clark <nick@ccl4.org> based on the code in C<h2xs> by Larry Wall and +others + +=cut + +# '' is used as a flag to indicate non-ascii macro names, and hence the need +# to pass in the utf8 on/off flag. +%XS_Constant = ( + '' => '', + IV => 'PUSHi(iv)', + UV => 'PUSHu((UV)iv)', + NV => 'PUSHn(nv)', + PV => 'PUSHp(pv, strlen(pv))', + PVN => 'PUSHp(pv, iv)', + SV => 'PUSHs(sv)', + YES => 'PUSHs(&PL_sv_yes)', + NO => 'PUSHs(&PL_sv_no)', + UNDEF => '', # implicit undef +); + +%XS_TypeSet = ( + IV => '*iv_return = ', + UV => '*iv_return = (IV)', + NV => '*nv_return = ', + PV => '*pv_return = ', + PVN => ['*pv_return = ', '*iv_return = (IV)'], + SV => '*sv_return = ', + YES => undef, + NO => undef, + UNDEF => undef, +); + +sub header { + 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) { + next if $_ eq ''; + 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 +#ifndef aTHX_ +#define aTHX_ /* 5.6 or later define this for threading support. */ +#endif +#ifndef pTHX_ +#define pTHX_ /* 5.6 or later define this for threading support. */ +#endif +EOT + + return join '', @lines; +} + +sub valid_type { + my ($self, $type) = @_; + return exists $XS_TypeSet{$type}; +} + +# This might actually be a return statement +sub assignment_clause_for_type { + my $self = shift; + my $args = shift; + my $type = $args->{type}; + my $typeset = $XS_TypeSet{$type}; + if (ref $typeset) { + die "Type $type is aggregate, but only single value given" + if @_ == 1; + return map {"$typeset->[$_]$_[$_];"} 0 .. $#$typeset; + } elsif (defined $typeset) { + confess "Aggregate value given for type $type" + if @_ > 1; + return "$typeset$_[0];"; + } + return (); +} + +sub return_statement_for_type { + my ($self, $type) = @_; + # In the future may pass in an options hash + $type = $type->{type} if ref $type; + "return PERL_constant_IS$type;"; +} + +sub return_statement_for_notdef { + # my ($self) = @_; + "return PERL_constant_NOTDEF;"; +} + +sub return_statement_for_notfound { + # my ($self) = @_; + "return PERL_constant_NOTFOUND;"; +} + +sub default_type { + 'IV'; +} + +sub macro_from_name { + my ($self, $item) = @_; + my $macro = $item->{name}; + $macro = $item->{value} unless defined $macro; + $macro; +} + +sub macro_from_item { + my ($self, $item) = @_; + my $macro = $item->{macro}; + $macro = $self->macro_from_name($item) unless defined $macro; + $macro; +} + +# Keep to the traditional perl source macro +sub memEQ { + "memEQ"; +} + +sub params { + my ($self, $what) = @_; + foreach (sort keys %$what) { + warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_}; + } + my $params = {}; + $params->{''} = 1 if $what->{''}; + $params->{IV} = 1 if $what->{IV} || $what->{UV} || $what->{PVN}; + $params->{NV} = 1 if $what->{NV}; + $params->{PV} = 1 if $what->{PV} || $what->{PVN}; + $params->{SV} = 1 if $what->{SV}; + return $params; +} + + +sub C_constant_prefix_param { + "aTHX_ "; +} + +sub C_constant_prefix_param_defintion { + "pTHX_ "; +} + +sub namelen_param_definition { + 'STRLEN ' . $_[0] -> namelen_param; +} + +sub C_constant_other_params_defintion { + my ($self, $params) = @_; + my $body = ''; + $body .= ", int utf8" if $params->{''}; + $body .= ", IV *iv_return" if $params->{IV}; + $body .= ", NV *nv_return" if $params->{NV}; + $body .= ", const char **pv_return" if $params->{PV}; + $body .= ", SV **sv_return" if $params->{SV}; + $body; +} + +sub C_constant_other_params { + my ($self, $params) = @_; + my $body = ''; + $body .= ", utf8" if $params->{''}; + $body .= ", iv_return" if $params->{IV}; + $body .= ", nv_return" if $params->{NV}; + $body .= ", pv_return" if $params->{PV}; + $body .= ", sv_return" if $params->{SV}; + $body; +} + +sub dogfood { + my ($self, $args, @items) = @_; + my ($package, $subname, $default_type, $what, $indent, $breakout) = + @{$args}{qw(package subname default_type what indent breakout)}; + my $result = <<"EOT"; + /* When generated this function returned values for the list of names given + in this section of perl code. Rather than manually editing these functions + to add or remove constants, which would result in this comment and section + of code becoming inaccurate, we recommend that you edit this section of + code, and use it to regenerate a new set of constant functions which you + then use to replace the originals. + + Regenerate these constant functions by feeding this entire source file to + perl -x + +#!$^X -w +use ExtUtils::Constant qw (constant_types C_constant XS_constant); + +EOT + $result .= $self->dump_names ({default_type=>$default_type, what=>$what, + indent=>0, declare_types=>1}, + @items); + $result .= <<'EOT'; + +print constant_types(), "\n"; # macro defs +EOT + $package = perl_stringify($package); + $result .= + "foreach (C_constant (\"$package\", '$subname', '$default_type', \$types, "; + # The form of the indent parameter isn't defined. (Yet) + if (defined $indent) { + require Data::Dumper; + $Data::Dumper::Terse=1; + $Data::Dumper::Terse=1; # Not used once. :-) + chomp ($indent = Data::Dumper::Dumper ($indent)); + $result .= $indent; + } else { + $result .= 'undef'; + } + $result .= ", $breakout" . ', @names) ) { + print $_, "\n"; # C constant subs +} +print "\n#### XS Section:\n"; +print XS_constant ("' . $package . '", $types); +__END__ + */ + +'; + + $result; +} + +1; diff --git a/cpan/ExtUtils-Constant/t/Constant.t b/cpan/ExtUtils-Constant/t/Constant.t new file mode 100644 index 0000000000..17330f72fa --- /dev/null +++ b/cpan/ExtUtils-Constant/t/Constant.t @@ -0,0 +1,1050 @@ +#!/usr/bin/perl -w + +use Config; +unless ($Config{usedl}) { + print "1..0 # no usedl, skipping\n"; + exit 0; +} + +# use warnings; +use strict; +use ExtUtils::MakeMaker; +use ExtUtils::Constant qw (C_constant autoload); +use File::Spec; +use Cwd; + +my $do_utf_tests = $] > 5.006; +my $better_than_56 = $] > 5.007; +# For debugging set this to 1. +my $keep_files = 0; +$| = 1; + +# Because were are going to be changing directory before running Makefile.PL +my $perl = $^X; +# 5.005 doesn't have new enough File::Spec to have rel2abs. But actually we +# only need it when $^X isn't absolute, which is going to be 5.8.0 or later +# (where ExtUtils::Constant is in the core, and tests against the uninstalled +# perl) +$perl = File::Spec->rel2abs ($perl) unless $] < 5.006; +# ExtUtils::Constant::C_constant uses $^X inside a comment, and we want to +# compare output to ensure that it is the same. We were probably run as ./perl +# whereas we will run the child with the full path in $perl. So make $^X for +# us the same as our child will see. +$^X = $perl; +my $lib = $ENV{PERL_CORE} ? '../../../lib' : '../../blib/lib'; +my $runperl = "$perl \"-I$lib\""; +print "# perl=$perl\n"; + +my $make = $Config{make}; +$make = $ENV{MAKE} if exists $ENV{MAKE}; +if ($^O eq 'MSWin32' && $make eq 'nmake') { $make .= " -nologo"; } + +# VMS may be using something other than MMS/MMK +my $mms_or_mmk = 0; +my $vms_lc = 0; +my $vms_nodot = 0; +if ($^O eq 'VMS') { + $mms_or_mmk = 1 if (($make eq 'MMK') || ($make eq 'MMS')); + $vms_lc = 1; + $vms_nodot = 1; + my $vms_unix_rpt = 0; + my $vms_efs = 0; + my $vms_efs_case = 0; + if (eval 'require VMS::Feature') { + $vms_unix_rpt = VMS::Feature::current("filename_unix_report"); + $vms_efs = VMS::Feature::current("efs_case_preserve"); + $vms_efs_case = VMS::Feature::current("efs_charset"); + } else { + my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; + my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || ''; + my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || ''; + $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i; + $vms_efs = $efs_charset =~ /^[ET1]/i; + $vms_efs_case = $efs_case =~ /^[ET1]/i; + } + $vms_lc = 0 if $vms_efs_case; + $vms_nodot = 0 if $vms_unix_rpt; +} + +# Renamed by make clean +my $makefile = ($mms_or_mmk ? 'descrip' : 'Makefile'); +my $makefile_ext = ($mms_or_mmk ? '.mms' : ''); +my $makefile_rename = $makefile . ($mms_or_mmk ? '.mms_old' : '.old'); + +my $output = "output"; +my $package = "ExtTest"; +my $dir = "ext-$$"; +my $subdir = 0; +# The real test counter. +my $realtest = 1; + +my $orig_cwd = cwd; +my $updir = File::Spec->updir; +die "Can't get current directory: $!" unless defined $orig_cwd; + +print "# $dir being created...\n"; +mkdir $dir, 0777 or die "mkdir: $!\n"; + +END { + if (defined $orig_cwd and length $orig_cwd) { + chdir $orig_cwd or die "Can't chdir back to '$orig_cwd': $!"; + use File::Path; + print "# $dir being removed...\n"; + rmtree($dir) unless $keep_files; + } else { + # Can't get here. + die "cwd at start was empty, but directory '$dir' was created" if $dir; + } +} + +chdir $dir or die $!; +push @INC, '../../lib', '../../../lib'; + +package TieOut; + +sub TIEHANDLE { + my $class = shift; + bless(\( my $ref = ''), $class); +} + +sub PRINT { + my $self = shift; + $$self .= join('', @_); +} + +sub PRINTF { + my $self = shift; + $$self .= sprintf shift, @_; +} + +sub read { + my $self = shift; + return substr($$self, 0, length($$self), ''); +} + +package main; + +sub check_for_bonus_files { + my $dir = shift; + my %expect = map {($vms_lc ? lc($_) : $_), 1} @_; + + my $fail; + opendir DIR, $dir or die "opendir '$dir': $!"; + while (defined (my $entry = readdir DIR)) { + $entry =~ s/\.$// if $vms_nodot; # delete trailing dot that indicates no extension + next if $expect{$entry}; + print "# Extra file '$entry'\n"; + $fail = 1; + } + + closedir DIR or warn "closedir '.': $!"; + if ($fail) { + print "not ok $realtest\n"; + } else { + print "ok $realtest\n"; + } + $realtest++; +} + +sub build_and_run { + my ($tests, $expect, $files) = @_; + my $core = $ENV{PERL_CORE} ? ' PERL_CORE=1' : ''; + my @perlout = `$runperl Makefile.PL $core`; + if ($?) { + print "not ok $realtest # $runperl Makefile.PL failed: $?\n"; + print "# $_" foreach @perlout; + exit($?); + } else { + print "ok $realtest\n"; + } + $realtest++; + + if (-f "$makefile$makefile_ext") { + print "ok $realtest\n"; + } else { + print "not ok $realtest\n"; + } + $realtest++; + + my @makeout; + + if ($^O eq 'VMS') { $make .= ' all'; } + + # Sometimes it seems that timestamps can get confused + + # make failed: 256 + # Makefile out-of-date with respect to Makefile.PL + # Cleaning current config before rebuilding Makefile... + # make -f Makefile.old clean > /dev/null 2>&1 || /bin/sh -c true + # ../../perl "-I../../../lib" "-I../../../lib" Makefile.PL "PERL_CORE=1" + # Checking if your kit is complete... + # Looks good + # Writing Makefile for ExtTest + # ==> Your Makefile has been rebuilt. <== + # ==> Please rerun the make command. <== + # false + + my $timewarp = (-M "Makefile.PL") - (-M "$makefile$makefile_ext"); + # Convert from days to seconds + $timewarp *= 86400; + print "# Makefile.PL is $timewarp second(s) older than $makefile$makefile_ext\n"; + if ($timewarp < 0) { + # Sleep for a while to catch up. + $timewarp = -$timewarp; + $timewarp+=2; + $timewarp = 10 if $timewarp > 10; + print "# Sleeping for $timewarp second(s) to try to resolve this\n"; + sleep $timewarp; + } + + print "# make = '$make'\n"; + @makeout = `$make`; + if ($?) { + print "not ok $realtest # $make failed: $?\n"; + print "# $_" foreach @makeout; + exit($?); + } else { + print "ok $realtest\n"; + } + $realtest++; + + if ($^O eq 'VMS') { $make =~ s{ all}{}; } + + if ($Config{usedl}) { + print "ok $realtest # This is dynamic linking, so no need to make perl\n"; + } else { + my $makeperl = "$make perl"; + print "# make = '$makeperl'\n"; + @makeout = `$makeperl`; + if ($?) { + print "not ok $realtest # $makeperl failed: $?\n"; + print "# $_" foreach @makeout; + exit($?); + } else { + print "ok $realtest\n"; + } + } + $realtest++; + + my $maketest = "$make test"; + print "# make = '$maketest'\n"; + + @makeout = `$maketest`; + + if (open OUTPUT, "<$output") { + local $/; # Slurp it - faster. + print <OUTPUT>; + close OUTPUT or print "# Close $output failed: $!\n"; + } else { + # Harness will report missing test results at this point. + print "# Open <$output failed: $!\n"; + } + + $realtest += $tests; + if ($?) { + print "not ok $realtest # $maketest failed: $?\n"; + print "# $_" foreach @makeout; + } else { + print "ok $realtest - maketest\n"; + } + $realtest++; + + if (defined $expect) { + # -x is busted on Win32 < 5.6.1, so we emulate it. + my $regen; + if( $^O eq 'MSWin32' && $] <= 5.006001 ) { + open(REGENTMP, ">regentmp") or die $!; + open(XS, "$package.xs") or die $!; + my $saw_shebang; + while(<XS>) { + $saw_shebang++ if /^#!.*/i ; + print REGENTMP $_ if $saw_shebang; + } + close XS; close REGENTMP; + $regen = `$runperl regentmp`; + unlink 'regentmp'; + } + else { + $regen = `$runperl -x $package.xs`; + } + if ($?) { + print "not ok $realtest # $runperl -x $package.xs failed: $?\n"; + } else { + print "ok $realtest - regen\n"; + } + $realtest++; + + if ($expect eq $regen) { + print "ok $realtest - regen worked\n"; + } else { + print "not ok $realtest - regen worked\n"; + # open FOO, ">expect"; print FOO $expect; + # open FOO, ">regen"; print FOO $regen; close FOO; + } + $realtest++; + } else { + for (0..1) { + print "ok $realtest # skip no regen or expect for this set of tests\n"; + $realtest++; + } + } + + my $makeclean = "$make clean"; + print "# make = '$makeclean'\n"; + @makeout = `$makeclean`; + if ($?) { + print "not ok $realtest # $make failed: $?\n"; + print "# $_" foreach @makeout; + } else { + print "ok $realtest\n"; + } + $realtest++; + + check_for_bonus_files ('.', @$files, $output, $makefile_rename, '.', '..'); + + rename $makefile_rename, $makefile . $makefile_ext + or die "Can't rename '$makefile_rename' to '$makefile$makefile_ext': $!"; + + unlink $output or warn "Can't unlink '$output': $!"; + + # Need to make distclean to remove ../../lib/ExtTest.pm + my $makedistclean = "$make distclean"; + print "# make = '$makedistclean'\n"; + @makeout = `$makedistclean`; + if ($?) { + print "not ok $realtest # $make failed: $?\n"; + print "# $_" foreach @makeout; + } else { + print "ok $realtest\n"; + } + $realtest++; + + check_for_bonus_files ('.', @$files, '.', '..'); + + unless ($keep_files) { + foreach (@$files) { + unlink $_ or warn "unlink $_: $!"; + } + } + + check_for_bonus_files ('.', '.', '..'); +} + +sub Makefile_PL { + my $package = shift; + ################ Makefile.PL + # We really need a Makefile.PL because make test for a no dynamic linking perl + # will run Makefile.PL again as part of the "make perl" target. + my $makefilePL = "Makefile.PL"; + open FH, ">$makefilePL" or die "open >$makefilePL: $!\n"; + print FH <<"EOT"; +#!$perl -w +use ExtUtils::MakeMaker; +WriteMakefile( + 'NAME' => "$package", + 'VERSION_FROM' => "$package.pm", # finds \$VERSION + (\$] >= 5.005 ? + (#ABSTRACT_FROM => "$package.pm", # XXX add this + AUTHOR => "$0") : ()) + ); +EOT + + close FH or die "close $makefilePL: $!\n"; + return $makefilePL; +} + +sub MANIFEST { + my (@files) = @_; + ################ MANIFEST + # We really need a MANIFEST because make distclean checks it. + my $manifest = "MANIFEST"; + push @files, $manifest; + open FH, ">$manifest" or die "open >$manifest: $!\n"; + print FH "$_\n" foreach @files; + close FH or die "close $manifest: $!\n"; + return @files; +} + +sub write_and_run_extension { + my ($name, $items, $export_names, $package, $header, $testfile, $num_tests, + $wc_args) = @_; + + my $c = tie *C, 'TieOut'; + my $xs = tie *XS, 'TieOut'; + + ExtUtils::Constant::WriteConstants(C_FH => \*C, + XS_FH => \*XS, + NAME => $package, + NAMES => $items, + @$wc_args, + ); + + my $C_code = $c->read(); + my $XS_code = $xs->read(); + + undef $c; + undef $xs; + + untie *C; + untie *XS; + + # Don't check the regeneration code if we specify extra arguments to + # WriteConstants. (Fix this to give finer grained control if needed) + my $expect; + $expect = $C_code . "\n#### XS Section:\n" . $XS_code unless $wc_args; + + print "# $name\n# $dir/$subdir being created...\n"; + mkdir $subdir, 0777 or die "mkdir: $!\n"; + chdir $subdir or die $!; + + my @files; + + ################ Header + my $header_name = "test.h"; + push @files, $header_name; + open FH, ">$header_name" or die "open >$header_name: $!\n"; + print FH $header or die $!; + close FH or die "close $header_name: $!\n"; + + ################ XS + my $xs_name = "$package.xs"; + push @files, $xs_name; + open FH, ">$xs_name" or die "open >$xs_name: $!\n"; + + print FH <<"EOT"; +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include "$header_name" + + +$C_code +MODULE = $package PACKAGE = $package +PROTOTYPES: ENABLE +$XS_code; +EOT + + close FH or die "close $xs: $!\n"; + + ################ PM + my $pm = "$package.pm"; + push @files, $pm; + open FH, ">$pm" or die "open >$pm: $!\n"; + print FH "package $package;\n"; + print FH "use $];\n"; + + print FH <<'EOT'; + +use strict; +EOT + printf FH "use warnings;\n" unless $] < 5.006; + print FH <<'EOT'; +use Carp; + +require Exporter; +require DynaLoader; +use vars qw ($VERSION @ISA @EXPORT_OK $AUTOLOAD); + +$VERSION = '0.01'; +@ISA = qw(Exporter DynaLoader); +EOT + # Having this qw( in the here doc confuses cperl mode far too much to be + # helpful. And I'm using cperl mode to edit this, even if you're not :-) + print FH "\@EXPORT_OK = qw(\n"; + + # Print the names of all our autoloaded constants + print FH "\t$_\n" foreach (@$export_names); + print FH ");\n"; + # Print the AUTOLOAD subroutine ExtUtils::Constant generated for us + print FH autoload ($package, $]); + print FH "bootstrap $package \$VERSION;\n1;\n__END__\n"; + close FH or die "close $pm: $!\n"; + + ################ test.pl + my $testpl = "test.pl"; + push @files, $testpl; + open FH, ">$testpl" or die "open >$testpl: $!\n"; + # Standard test header (need an option to suppress this?) + print FH <<"EOT" or die $!; +use strict; +use $package qw(@$export_names); + +print "1..2\n"; +if (open OUTPUT, ">$output") { + print "ok 1\n"; + select OUTPUT; +} else { + print "not ok 1 # Failed to open '$output': \$!\n"; + exit 1; +} +EOT + print FH $testfile or die $!; + print FH <<"EOT" or die $!; +select STDOUT; +if (close OUTPUT) { + print "ok 2\n"; +} else { + print "not ok 2 # Failed to close '$output': \$!\n"; +} +EOT + close FH or die "close $testpl: $!\n"; + + push @files, Makefile_PL($package); + @files = MANIFEST (@files); + + build_and_run ($num_tests, $expect, \@files); + + chdir $updir or die "chdir '$updir': $!"; + ++$subdir; +} + +# Tests are arrayrefs of the form +# $name, [items], [export_names], $package, $header, $testfile, $num_tests +my @tests; +my $before_tests = 4; # Number of "ok"s emitted to build extension +my $after_tests = 8; # Number of "ok"s emitted after make test run +my $dummytest = 1; + +my $here; +sub start_tests { + $dummytest += $before_tests; + $here = $dummytest; +} +sub end_tests { + my ($name, $items, $export_names, $header, $testfile, $args) = @_; + push @tests, [$name, $items, $export_names, $package, $header, $testfile, + $dummytest - $here, $args]; + $dummytest += $after_tests; +} + +my $pound; +if (ord('A') == 193) { # EBCDIC platform + $pound = chr 177; # A pound sign. (Currency) +} else { # ASCII platform + $pound = chr 163; # A pound sign. (Currency) +} +my @common_items = ( + {name=>"perl", type=>"PV",}, + {name=>"*/", type=>"PV", value=>'"CLOSE"', macro=>1}, + {name=>"/*", type=>"PV", value=>'"OPEN"', macro=>1}, + {name=>$pound, type=>"PV", value=>'"Sterling"', macro=>1}, + ); + +my @args = undef; +push @args, [PROXYSUBS => 1] if $] > 5.009002; +foreach my $args (@args) +{ + # Simple tests + start_tests(); + my $parent_rfc1149 = + 'A Standard for the Transmission of IP Datagrams on Avian Carriers'; + # Test the code that generates 1 and 2 letter name comparisons. + my %compass = ( + N => 0, 'NE' => 45, E => 90, SE => 135, + S => 180, SW => 225, W => 270, NW => 315 + ); + + my $header = << "EOT"; +#define FIVE 5 +#define OK6 "ok 6\\n" +#define OK7 1 +#define FARTHING 0.25 +#define NOT_ZERO 1 +#define Yes 0 +#define No 1 +#define Undef 1 +#define RFC1149 "$parent_rfc1149" +#undef NOTDEF +#define perl "rules" +EOT + + while (my ($point, $bearing) = each %compass) { + $header .= "#define $point $bearing\n" + } + + my @items = ("FIVE", {name=>"OK6", type=>"PV",}, + {name=>"OK7", type=>"PVN", + value=>['"not ok 7\\n\\0ok 7\\n"', 15]}, + {name => "FARTHING", type=>"NV"}, + {name => "NOT_ZERO", type=>"UV", value=>"~(UV)0"}, + {name => "OPEN", type=>"PV", value=>'"/*"', macro=>1}, + {name => "CLOSE", type=>"PV", value=>'"*/"', + macro=>["#if 1\n", "#endif\n"]}, + {name => "ANSWER", default=>["UV", 42]}, "NOTDEF", + {name => "Yes", type=>"YES"}, + {name => "No", type=>"NO"}, + {name => "Undef", type=>"UNDEF"}, + # OK. It wasn't really designed to allow the creation of dual valued + # constants. + # It was more for INADDR_ANY INADDR_BROADCAST INADDR_LOOPBACK INADDR_NONE + {name=>"RFC1149", type=>"SV", value=>"sv_2mortal(temp_sv)", + pre=>"SV *temp_sv = newSVpv(RFC1149, 0); " + . "(void) SvUPGRADE(temp_sv,SVt_PVIV); SvIOK_on(temp_sv); " + . "SvIV_set(temp_sv, 1149);"}, + ); + + push @items, $_ foreach keys %compass; + + # Automatically compile the list of all the macro names, and make them + # exported constants. + my @export_names = map {(ref $_) ? $_->{name} : $_} @items; + + # Exporter::Heavy (currently) isn't able to export the last 3 of these: + push @items, @common_items; + + my $test_body = <<"EOT"; + +my \$test = $dummytest; + +EOT + + $test_body .= <<'EOT'; +# What follows goes to the temporary file. +# IV +my $five = FIVE; +if ($five == 5) { + print "ok $test\n"; +} else { + print "not ok $test # \$five\n"; +} +$test++; + +# PV +if (OK6 eq "ok 6\n") { + print "ok $test\n"; +} else { + print "not ok $test # \$five\n"; +} +$test++; + +# PVN containing embedded \0s +$_ = OK7; +s/.*\0//s; +s/7/$test/; +$test++; +print; + +# NV +my $farthing = FARTHING; +if ($farthing == 0.25) { + print "ok $test\n"; +} else { + print "not ok $test # $farthing\n"; +} +$test++; + +# UV +my $not_zero = NOT_ZERO; +if ($not_zero > 0 && $not_zero == ~0) { + print "ok $test\n"; +} else { + print "not ok $test # \$not_zero=$not_zero ~0=" . (~0) . "\n"; +} +$test++; + +# Value includes a "*/" in an attempt to bust out of a C comment. +# Also tests custom cpp #if clauses +my $close = CLOSE; +if ($close eq '*/') { + print "ok $test\n"; +} else { + print "not ok $test # \$close='$close'\n"; +} +$test++; + +# Default values if macro not defined. +my $answer = ANSWER; +if ($answer == 42) { + print "ok $test\n"; +} else { + print "not ok $test # What do you get if you multiply six by nine? '$answer'\n"; +} +$test++; + +# not defined macro +my $notdef = eval { NOTDEF; }; +if (defined $notdef) { + print "not ok $test # \$notdef='$notdef'\n"; +} elsif ($@ !~ /Your vendor has not defined ExtTest macro NOTDEF/) { + print "not ok $test # \$@='$@'\n"; +} else { + print "ok $test\n"; +} +$test++; + +# not a macro +my $notthere = eval { &ExtTest::NOTTHERE; }; +if (defined $notthere) { + print "not ok $test # \$notthere='$notthere'\n"; +} elsif ($@ !~ /NOTTHERE is not a valid ExtTest macro/) { + chomp $@; + print "not ok $test # \$@='$@'\n"; +} else { + print "ok $test\n"; +} +$test++; + +# Truth +my $yes = Yes; +if ($yes) { + print "ok $test\n"; +} else { + print "not ok $test # $yes='\$yes'\n"; +} +$test++; + +# Falsehood +my $no = No; +if (defined $no and !$no) { + print "ok $test\n"; +} else { + print "not ok $test # \$no=" . defined ($no) ? "'$no'\n" : "undef\n"; +} +$test++; + +# Undef +my $undef = Undef; +unless (defined $undef) { + print "ok $test\n"; +} else { + print "not ok $test # \$undef='$undef'\n"; +} +$test++; + +# invalid macro (chosen to look like a mix up between No and SW) +$notdef = eval { &ExtTest::So }; +if (defined $notdef) { + print "not ok $test # \$notdef='$notdef'\n"; +} elsif ($@ !~ /^So is not a valid ExtTest macro/) { + print "not ok $test # \$@='$@'\n"; +} else { + print "ok $test\n"; +} +$test++; + +# invalid defined macro +$notdef = eval { &ExtTest::EW }; +if (defined $notdef) { + print "not ok $test # \$notdef='$notdef'\n"; +} elsif ($@ !~ /^EW is not a valid ExtTest macro/) { + print "not ok $test # \$@='$@'\n"; +} else { + print "ok $test\n"; +} +$test++; + +my %compass = ( +EOT + +while (my ($point, $bearing) = each %compass) { + $test_body .= "'$point' => $bearing, " +} + +$test_body .= <<'EOT'; + +); + +my $fail; +while (my ($point, $bearing) = each %compass) { + my $val = eval $point; + if ($@) { + print "# $point: \$@='$@'\n"; + $fail = 1; + } elsif (!defined $bearing) { + print "# $point: \$val=undef\n"; + $fail = 1; + } elsif ($val != $bearing) { + print "# $point: \$val=$val, not $bearing\n"; + $fail = 1; + } +} +if ($fail) { + print "not ok $test\n"; +} else { + print "ok $test\n"; +} +$test++; + +EOT + +$test_body .= <<"EOT"; +my \$rfc1149 = RFC1149; +if (\$rfc1149 ne "$parent_rfc1149") { + print "not ok \$test # '\$rfc1149' ne '$parent_rfc1149'\n"; +} else { + print "ok \$test\n"; +} +\$test++; + +if (\$rfc1149 != 1149) { + printf "not ok \$test # %d != 1149\n", \$rfc1149; +} else { + print "ok \$test\n"; +} +\$test++; + +EOT + +$test_body .= <<'EOT'; +# test macro=>1 +my $open = OPEN; +if ($open eq '/*') { + print "ok $test\n"; +} else { + print "not ok $test # \$open='$open'\n"; +} +$test++; +EOT +$dummytest+=18; + + end_tests("Simple tests", \@items, \@export_names, $header, $test_body, + $args); +} + +if ($do_utf_tests) { + # utf8 tests + start_tests(); + my ($inf, $pound_bytes, $pound_utf8); + + $inf = chr 0x221E; + # Check that we can distiguish the pathological case of a string, and the + # utf8 representation of that string. + $pound_utf8 = $pound . '1'; + if ($better_than_56) { + $pound_bytes = $pound_utf8; + utf8::encode ($pound_bytes); + } else { + # Must have that "U*" to generate a zero length UTF string that forces + # top bit set chars (such as the pound sign) into UTF8, so that the + # unpack 'C*' then gets the byte form of the UTF8. + $pound_bytes = pack 'C*', unpack 'C*', $pound_utf8 . pack "U*"; + } + + my @items = (@common_items, + {name=>$inf, type=>"PV", value=>'"Infinity"', macro=>1}, + {name=>$pound_utf8, type=>"PV", value=>'"1 Pound"', macro=>1}, + {name=>$pound_bytes, type=>"PV", value=>'"1 Pound (as bytes)"', + macro=>1}, + ); + +=pod + +The above set of names seems to produce a suitably bad set of compile +problems on a Unicode naive version of ExtUtils::Constant (ie 0.11): + +nick@thinking-cap 15439-32-utf$ PERL_CORE=1 ./perl lib/ExtUtils/t/Constant.t +1..33 +# perl=/stuff/perl5/15439-32-utf/perl +# ext-30370 being created... +Wide character in print at lib/ExtUtils/t/Constant.t line 140. +ok 1 +ok 2 +# make = 'make' +ExtTest.xs: In function `constant_1': +ExtTest.xs:80: warning: multi-character character constant +ExtTest.xs:80: warning: case value out of range +ok 3 + +=cut + +# Grr ` + + # Do this in 7 bit in case someone is testing with some settings that cause + # 8 bit files incapable of storing this character. + my @values + = map {"'" . join (",", unpack "U*", $_ . pack "U*") . "'"} + ($pound, $inf, $pound_bytes, $pound_utf8); + # Values is a list of strings, such as ('194,163,49', '163,49') + + my $test_body .= "my \$test = $dummytest;\n"; + $dummytest += 7 * 3; # 3 tests for each of the 7 things: + + $test_body .= << 'EOT'; + +use utf8; +my $better_than_56 = $] > 5.007; + +my ($pound, $inf, $pound_bytes, $pound_utf8) = map {eval "pack 'U*', $_"} +EOT + + $test_body .= join ",", @values; + + $test_body .= << 'EOT'; +; + +foreach (["perl", "rules", "rules"], + ["/*", "OPEN", "OPEN"], + ["*/", "CLOSE", "CLOSE"], + [$pound, 'Sterling', []], + [$inf, 'Infinity', []], + [$pound_utf8, '1 Pound', '1 Pound (as bytes)'], + [$pound_bytes, '1 Pound (as bytes)', []], + ) { + # Flag an expected error with a reference for the expect string. + my ($string, $expect, $expect_bytes) = @$_; + (my $name = $string) =~ s/([^ !"#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~])/sprintf '\x{%X}', ord $1/ges; + print "# \"$name\" => \'$expect\'\n"; + # Try to force this to be bytes if possible. + if ($better_than_56) { + utf8::downgrade ($string, 1); + } else { + if ($string =~ tr/0-\377// == length $string) { + # No chars outside range 0-255 + $string = pack 'C*', unpack 'U*', ($string . pack 'U*'); + } + } +EOT + + $test_body .= "my (\$error, \$got) = ${package}::constant (\$string);\n"; + + $test_body .= <<'EOT'; + if ($error or $got ne $expect) { + print "not ok $test # error '$error', got '$got'\n"; + } else { + print "ok $test\n"; + } + $test++; + print "# Now upgrade '$name' to utf8\n"; + if ($better_than_56) { + utf8::upgrade ($string); + } else { + $string = pack ('U*') . $string; + } +EOT + + $test_body .= "my (\$error, \$got) = ${package}::constant (\$string);\n"; + + $test_body .= <<'EOT'; + if ($error or $got ne $expect) { + print "not ok $test # error '$error', got '$got'\n"; + } else { + print "ok $test\n"; + } + $test++; + if (defined $expect_bytes) { + print "# And now with the utf8 byte sequence for name\n"; + # Try the encoded bytes. + if ($better_than_56) { + utf8::encode ($string); + } else { + $string = pack 'C*', unpack 'C*', $string . pack "U*"; + } +EOT + + $test_body .= "my (\$error, \$got) = ${package}::constant (\$string);\n"; + + $test_body .= <<'EOT'; + if (ref $expect_bytes) { + # Error expected. + if ($error) { + print "ok $test # error='$error' (as expected)\n"; + } else { + print "not ok $test # expected error, got no error and '$got'\n"; + } + } elsif ($got ne $expect_bytes) { + print "not ok $test # error '$error', expect '$expect_bytes', got '$got'\n"; + } else { + print "ok $test\n"; + } + $test++; + } +} +EOT + + end_tests("utf8 tests", \@items, [], "#define perl \"rules\"\n", $test_body); +} + +# XXX I think that I should merge this into the utf8 test above. +sub explict_call_constant { + my ($string, $expect) = @_; + # This does assume simple strings suitable for '' + my $test_body = <<"EOT"; +{ + my (\$error, \$got) = ${package}::constant ('$string');\n; +EOT + + if (defined $expect) { + # No error expected + $test_body .= <<"EOT"; + if (\$error or \$got ne "$expect") { + print "not ok $dummytest # error '\$error', expect '$expect', got '\$got'\n"; + } else { + print "ok $dummytest\n"; + } + } +EOT + } else { + # Error expected. + $test_body .= <<"EOT"; + if (\$error) { + print "ok $dummytest # error='\$error' (as expected)\n"; + } else { + print "not ok $dummytest # expected error, got no error and '\$got'\n"; + } +EOT + } + $dummytest++; + return $test_body . <<'EOT'; +} +EOT +} + +# Simple tests to verify bits of the switch generation system work. +sub simple { + start_tests(); + # Deliberately leave $name in @_, so that it is indexed from 1. + my ($name, @items) = @_; + my $test_header; + my $test_body = "my \$value;\n"; + foreach my $counter (1 .. $#_) { + my $thisname = $_[$counter]; + $test_header .= "#define $thisname $counter\n"; + $test_body .= <<"EOT"; +\$value = $thisname; +if (\$value == $counter) { + print "ok $dummytest\n"; +} else { + print "not ok $dummytest # $thisname gave \$value\n"; +} +EOT + ++$dummytest; + # Yes, the last time round the loop appends a z to the string. + for my $i (0 .. length $thisname) { + my $copyname = $thisname; + substr ($copyname, $i, 1) = 'z'; + $test_body .= explict_call_constant ($copyname, + $copyname eq $thisname + ? $thisname : undef); + } + } + # Ho. This seems to be buggy in 5.005_03: + # # Now remove $name from @_: + # shift @_; + end_tests($name, \@items, \@items, $test_header, $test_body); +} + +# Check that the memeq clauses work correctly when there isn't a switch +# statement to bump off a character +simple ("Singletons", "A", "AB", "ABC", "ABCD", "ABCDE"); +# Check the three code. +simple ("Three start", qw(Bea kea Lea lea nea pea rea sea tea Wea yea Zea)); +# There were 162 2 letter words in /usr/share/dict/words on FreeBSD 4.6, which +# I felt was rather too many. So I used words with 2 vowels. +simple ("Twos and three middle", qw(aa ae ai ea eu ie io oe era eta)); +# Given the choice go for the end, else the earliest point +simple ("Three end and four symetry", qw(ean ear eat barb marm tart)); + + +# Need this if the single test below is rolled into @tests : +# --$dummytest; +print "1..$dummytest\n"; + +write_and_run_extension @$_ foreach @tests; + +# This was causing an assertion failure (a C<confess>ion) +# Any single byte > 128 should do it. +C_constant ($package, undef, undef, undef, undef, undef, chr 255); +print "ok $realtest\n"; $realtest++; + +print STDERR "# You were running with \$keep_files set to $keep_files\n" + if $keep_files; |