diff options
author | Nicholas Clark <nick@ccl4.org> | 2009-09-10 10:56:30 +0100 |
---|---|---|
committer | Nicholas Clark <nick@ccl4.org> | 2009-09-10 11:09:18 +0100 |
commit | 2db10ba327c7c0a1b993bf71c5feb22a2044498a (patch) | |
tree | 5a27d4eec8a02a002445ae20dab5762e1a177a18 /lib | |
parent | 66c85ba8d72ac70beb51ca6fcf48ade6d6b89439 (diff) | |
download | perl-2db10ba327c7c0a1b993bf71c5feb22a2044498a.tar.gz |
Move ExtUtils::Constant to from lib to ext.
Diffstat (limited to 'lib')
-rw-r--r-- | lib/.gitignore | 2 | ||||
-rw-r--r-- | lib/ExtUtils/Constant.pm | 565 | ||||
-rw-r--r-- | lib/ExtUtils/Constant/Base.pm | 1006 | ||||
-rw-r--r-- | lib/ExtUtils/Constant/ProxySubs.pm | 549 | ||||
-rw-r--r-- | lib/ExtUtils/Constant/Utils.pm | 131 | ||||
-rw-r--r-- | lib/ExtUtils/Constant/XS.pm | 259 | ||||
-rw-r--r-- | lib/ExtUtils/t/Constant.t | 1056 |
7 files changed, 2 insertions, 3566 deletions
diff --git a/lib/.gitignore b/lib/.gitignore index 7f50914568..3817b3d669 100644 --- a/lib/.gitignore +++ b/lib/.gitignore @@ -125,6 +125,8 @@ /Encode.pm /Encode /Errno.pm +/ExtUtils/Constant.pm +/ExtUtils/Constant /ExtUtils/Miniperl.pm /Fatal.pm /Fcntl.pm diff --git a/lib/ExtUtils/Constant.pm b/lib/ExtUtils/Constant.pm deleted file mode 100644 index 0a20b89b79..0000000000 --- a/lib/ExtUtils/Constant.pm +++ /dev/null @@ -1,565 +0,0 @@ -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/lib/ExtUtils/Constant/Base.pm b/lib/ExtUtils/Constant/Base.pm deleted file mode 100644 index b5b79af1ea..0000000000 --- a/lib/ExtUtils/Constant/Base.pm +++ /dev/null @@ -1,1006 +0,0 @@ -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/lib/ExtUtils/Constant/ProxySubs.pm b/lib/ExtUtils/Constant/ProxySubs.pm deleted file mode 100644 index c3fe8ed3c5..0000000000 --- a/lib/ExtUtils/Constant/ProxySubs.pm +++ /dev/null @@ -1,549 +0,0 @@ -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/lib/ExtUtils/Constant/Utils.pm b/lib/ExtUtils/Constant/Utils.pm deleted file mode 100644 index 016507c72a..0000000000 --- a/lib/ExtUtils/Constant/Utils.pm +++ /dev/null @@ -1,131 +0,0 @@ -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/lib/ExtUtils/Constant/XS.pm b/lib/ExtUtils/Constant/XS.pm deleted file mode 100644 index 14eb809714..0000000000 --- a/lib/ExtUtils/Constant/XS.pm +++ /dev/null @@ -1,259 +0,0 @@ -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/lib/ExtUtils/t/Constant.t b/lib/ExtUtils/t/Constant.t deleted file mode 100644 index 02b7528bcb..0000000000 --- a/lib/ExtUtils/t/Constant.t +++ /dev/null @@ -1,1056 +0,0 @@ -#!/usr/bin/perl -w - -BEGIN { - if( $ENV{PERL_CORE} ) { - chdir 't' if -d 't'; - @INC = '../lib'; - } - 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; |