package ExtUtils::Constant;
+use vars qw (@ISA $VERSION %XS_Constant %XS_TypeSet @EXPORT_OK %EXPORT_TAGS);
+$VERSION = '0.10';
=head1 NAME
=head1 SYNOPSIS
- use ExtUtils::Constant qw (constant_types C_constant XS_constant);
- print constant_types(); # macro defs
- foreach (C_constant ("Foo", undef, "IV", undef, undef, undef,
- @names) ) {
- print $_, "\n"; # C constant subs
- }
- print "MODULE = Foo PACKAGE = Foo\n";
- print XS_constant ("Foo", {NV => 1, IV => 1}); # XS for Foo::constant
+ use ExtUtils::Constant qw (WriteConstants);
+ WriteConstants(
+ NAME => 'Foo',
+ NAMES => [qw(FOO BAR BAZ)],
+ C_FILE => 'constants.c',
+ XS_FILE => 'constants.xs',
+ );
+ # Generates wrapper code to make the values of the constants FOO BAR BAZ
+ # available to perl
=head1 DESCRIPTION
=head1 USAGE
-Generally one only needs to call the 3 functions shown in the synopsis,
-C<constant_types()>, C<C_constant> and C<XS_constant>.
+Generally one only needs to call the C<WriteConstants> function, and then
+
+ #include "constants.c"
+
+in the C section of C<Foo.xs>
+
+ INCLUDE constants.xs
+
+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>
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
=cut
-require 5.006; # I think, for [:cntrl:] in REGEXP
-use warnings;
+if ($] >= 5.006) {
+ eval "use warnings; 1" or die $@;
+}
use strict;
use Carp;
use Exporter;
-use vars qw (@ISA $VERSION %XS_Constant %XS_TypeSet @EXPORT_OK %EXPORT_TAGS);
use Text::Wrap;
$Text::Wrap::huge = 'overflow';
$Text::Wrap::columns = 80;
@ISA = 'Exporter';
-$VERSION = '0.03';
%EXPORT_TAGS = ( 'all' => [ qw(
XS_constant constant_types return_clause memEQ_clause C_stringify
- C_constant autoload
+ C_constant autoload WriteConstants WriteMakefileSnippet
) ] );
@EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
%XS_Constant = (
- IV => 'PUSHi(iv)',
- UV => 'PUSHu((UV)iv)',
- NV => 'PUSHn(nv)',
- PV => 'PUSHp(pv, strlen(pv))',
- PVN => 'PUSHp(pv, iv)'
+ 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)']
+ 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,
);
s/([\"\'])/\\$1/g; # Grr. fix perl mode.
s/\n/\\n/g; # Ensure newlines don't end up in octal
s/\r/\\r/g;
- s/([[:cntrl:]])/sprintf "\\%03o", ord $1/ge;
- s/\177/\\177/g; # DEL doesn't seem to be a [:cntrl:]
+ s/\t/\\t/g;
+ s/\f/\\f/g;
+ s/\a/\\a/g;
+ unless ($] < 5.006) {
+ # This will elict 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;
+ }
$_;
}
#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;
return $body;
}
-=item assign INDENT, TYPE, VALUE...
+=item assign INDENT, TYPE, PRE, POST, VALUE...
A function 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<VALUE>s for the components. I<PRE> and I<POST> if defined give snippets
+of C code to preceed and follow the assignment. I<PRE> will be at the start
+of a block, so variables may be defined in it.
=cut
sub assign {
my $indent = shift;
my $type = shift;
- my $typeset = $XS_TypeSet{$type};
+ my $pre = shift;
+ my $post = shift || '';
my $clause;
- die "Can't generate code for type $type" unless defined $typeset;
+ my $close;
+ if ($pre) {
+ chomp $pre;
+ $clause = $indent . "{\n$pre";
+ $clause .= ";" unless $pre =~ /;$/;
+ $clause .= "\n";
+ $close = "$indent}\n";
+ $indent .= " ";
+ }
+ die "Can't generate code for type $type" unless exists $XS_TypeSet{$type};
+ my $typeset = $XS_TypeSet{$type};
if (ref $typeset) {
die "Type $type is aggregate, but only single value given"
if @_ == 1;
foreach (0 .. $#$typeset) {
$clause .= $indent . "$typeset->[$_] $_[$_];\n";
}
- } else {
+ } elsif (defined $typeset) {
die "Aggregate value given for type $type"
if @_ > 1;
$clause .= $indent . "$typeset $_[0];\n";
}
+ chomp $post;
+ if (length $post) {
+ $clause .= "$post";
+ $clause .= ";" unless $post =~ /;$/;
+ $clause .= "\n";
+ }
$clause .= "${indent}return PERL_constant_IS$type;\n";
+ $clause .= $close if $close;
return $clause;
}
-=item return_clause VALUE, TYPE, INDENT, MACRO, DEFAULT
+=item return_clause
+
+return_clause VALUE, TYPE, INDENT, MACRO, DEFAULT, PRE, POST, PRE, POST
A function to return a suitable C<#ifdef> clause. I<MACRO> defaults to
I<VALUE> when not defined. If I<TYPE> is aggregate (eg I<PVN> expects both
this function with I<MACRO> defined, defaulting to the constant's name.
I<DEFAULT> if defined is an array reference giving default type and and
value(s) if the clause generated by I<MACRO> doesn't evaluate to true.
+The two pairs I<PRE> and I<POST> if defined give C code snippets to proceed
+and follow the value, and the default value.
=cut
-sub return_clause ($$$$$) {
+sub return_clause ($$$$$$$$$) {
##ifdef thingy
# *iv_return = thingy;
# return PERL_constant_ISIV;
##else
# return PERL_constant_NOTDEF;
##endif
- my ($value, $type, $indent, $macro, $default) = @_;
+ my ($value, $type, $indent, $macro, $default, $pre, $post,
+ $def_pre, $def_post) = @_;
$macro = $value unless defined $macro;
$indent = ' ' x ($indent || 6);
##ifdef thingy
if (ref $macro) {
$clause = $macro->[0];
- } else {
+ } elsif ($macro ne "1") {
$clause = "#ifdef $macro\n";
}
# *iv_return = thingy;
# return PERL_constant_ISIV;
- $clause .= assign ($indent, $type, ref $value ? @$value : $value);
-
- ##else
- $clause .= "#else\n";
-
- # return PERL_constant_NOTDEF;
- if (!defined $default) {
- $clause .= "${indent}return PERL_constant_NOTDEF;\n";
- } else {
- $clause .= assign ($indent, ref $default ? @$default : $default);
- }
+ $clause .= assign ($indent, $type, $pre, $post,
+ ref $value ? @$value : $value);
- ##endif
- if (ref $macro) {
- $clause .= $macro->[1];
- } else {
- $clause .= "#endif\n";
+ if (ref $macro or $macro ne "1") {
+ ##else
+ $clause .= "#else\n";
+
+ # return PERL_constant_NOTDEF;
+ if (!defined $default) {
+ $clause .= "${indent}return PERL_constant_NOTDEF;\n";
+ } else {
+ my @default = ref $default ? @$default : $default;
+ $type = shift @default;
+ $clause .= assign ($indent, $type, $def_pre, $def_post, @default);
+ }
+
+ ##endif
+ if (ref $macro) {
+ $clause .= $macro->[1];
+ } else {
+ $clause .= "#endif\n";
+ }
}
return $clause
}
+=item switch_clause INDENT, NAMELEN, ITEMHASH, ITEM...
+
+An internal function 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> (This is not checked). 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).
+
+=cut
+
+sub switch_clause {
+ my ($indent, $comment, $namelen, $items, @items) = @_;
+ $indent = ' ' x ($indent || 2);
+
+ my @names = sort map {$_->{name}} @items;
+ my $leader = $indent . '/* ';
+ my $follower = ' ' x length $leader;
+ my $body = $indent . "/* Names all of length $namelen. */\n";
+ if ($comment) {
+ $body = wrap ($leader, $follower, $comment) . "\n";
+ $leader = $follower;
+ }
+ $body .= wrap ($leader, $follower, join (" ", @names) . " */") . "\n";
+ # Figure out what to switch on.
+ # (RMS, Spread of jump table, Position, Hashref)
+ my @best = (1e38, ~0);
+ foreach my $i (0 .. ($namelen - 1)) {
+ my ($min, $max) = (~0, 0);
+ my %spread;
+ foreach (@names) {
+ my $char = substr $_, $i, 1;
+ my $ord = ord $char;
+ $max = $ord if $ord > $max;
+ $min = $ord if $ord < $min;
+ push @{$spread{$char}}, $_;
+ # warn "$_ $char";
+ }
+ # I'm going to pick the character to split on that minimises the root
+ # mean square of the number of names in each case. Normally this should
+ # be the one with the most keys, but it may pick a 7 where the 8 has
+ # one long linear search. I'm not sure if RMS or just sum of squares is
+ # actually better.
+ # $max and $min are for the tie-breaker if the root mean squares match.
+ # Assuming that the compiler may be building a jump table for the
+ # switch() then try to minimise the size of that jump table.
+ # Finally use < not <= so that if it still ties the earliest part of
+ # the string wins. Because if that passes but the memEQ fails, it may
+ # only need the start of the string to bin the choice.
+ # I think. But I'm micro-optimising. :-)
+ my $ss;
+ $ss += @$_ * @$_ foreach values %spread;
+ my $rms = sqrt ($ss / keys %spread);
+ if ($rms < $best[0] || ($rms == $best[0] && ($max - $min) < $best[1])) {
+ @best = ($rms, $max - $min, $i, \%spread);
+ }
+ }
+ die "Internal error. Failed to pick a switch point for @names"
+ unless defined $best[2];
+ # use Data::Dumper; print Dumper (@best);
+ my ($offset, $best) = @best[2,3];
+ $body .= $indent . "/* Offset $offset gives the best switch position. */\n";
+ $body .= $indent . "switch (name[$offset]) {\n";
+ foreach my $char (sort keys %$best) {
+ $body .= $indent . "case '" . C_stringify ($char) . "':\n";
+ foreach my $name (sort @{$best->{$char}}) {
+ my $thisone = $items->{$name};
+ my ($value, $macro, $default, $pre, $post, $def_pre, $def_post)
+ = @$thisone{qw (value macro default pre post def_pre def_post)};
+ $value = $name unless defined $value;
+ $macro = $name unless defined $macro;
+
+ # We have checked this offset.
+ $body .= memEQ_clause ($name, $offset, 2 + length $indent);
+ $body .= return_clause ($value, $thisone->{type}, 4 + length $indent,
+ $macro, $default, $pre, $post,
+ $def_pre, $def_post);
+ $body .= $indent . " }\n";
+ }
+ $body .= $indent . " break;\n";
+ }
+ $body .= $indent . "}\n";
+ return $body;
+}
+
=item params WHAT
An internal function. I<WHAT> should be a hashref of types the constant
-function will return. I<params> returns the list of flags C<$use_iv, $use_nv,
-$use_pv> to show which combination of pointers will be needed in the C
-argument list.
+function will return. I<params> returns a hashref keyed IV NV PV SV to show
+which combination of pointers will be needed in the C argument list.
=cut
foreach (sort keys %$what) {
warn "ExtUtils::Constant doesn't know how to handle values of type $_" unless defined $XS_Constant{$_};
}
- my $use_iv = $what->{IV} || $what->{UV} || $what->{PVN};
- my $use_nv = $what->{NV};
- my $use_pv = $what->{PV} || $what->{PVN};
- return ($use_iv, $use_nv, $use_pv);
+ my $params = {};
+ $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;
}
-=item dump_names
+=item dump_names
-dump_names PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, ITEM...
+dump_names DEFAULT_TYPE, TYPES, INDENT, OPTIONS, ITEM...
An internal function to generate the embedded perl code that will regenerate
-the constant subroutines. Parameters are the same as for C_constant, except
-that there is no NAMELEN.
+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. I<OPTIONS> is a hashref of options. Currently only C<declare_types> is
+recognised. If the value 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 ($package, $subname, $default_type, $what, $indent, @items) = @_;
- my (@simple, @complex);
+ my ($default_type, $what, $indent, $options, @items) = @_;
+ my $declare_types = $options->{declare_types};
+ $indent = ' ' x ($indent || 0);
+
+ my $result;
+ my (@simple, @complex, %used_types);
foreach (@items) {
- my $type = $_->{type} || $default_type;
+ my $type;
+ if (ref $_) {
+ $type = $_->{type} || $default_type;
+ } else {
+ $_ = {name=>$_};
+ $type = $default_type;
+ }
+ $used_types{$type}++;
if ($type eq $default_type and 0 == ($_->{name} =~ tr/A-Za-z0-9_//c)
and !defined ($_->{macro}) and !defined ($_->{value})
- and !defined ($_->{default})) {
+ and !defined ($_->{default}) and !defined ($_->{pre})
+ and !defined ($_->{post}) and !defined ($_->{def_pre})
+ and !defined ($_->{def_post})) {
# It's the default type, and the name consists only of A-Za-z0-9_
push @simple, $_->{name};
} else {
push @complex, $_;
}
}
- 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 .= 'my $types = {' . join (", ", map "$_ => 1", sort keys %$what)
- . "};\n";
- $result .= wrap ("my \@names = (qw(",
- " ", join (" ", sort @simple) . ")");
+ 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";
+ }
+ $result .= wrap ($indent . "my \@names = (qw(",
+ $indent . " ", join (" ", sort @simple) . ")");
if (@complex) {
foreach my $item (sort {$a->{name} cmp $b->{name}} @complex) {
my $name = C_stringify $item->{name};
- my ($macro, $value, $default) = @$item{qw (macro value default)};
- my $line = ",\n {name=>\"$name\"";
+ my $line = ",\n$indent {name=>\"$name\"";
$line .= ", type=>\"$item->{type}\"" if defined $item->{type};
- if (defined $macro) {
- if (ref $macro) {
- $line .= ', macro=>["'. join ('", "', map {C_stringify $_} @$macro)
- . '"]';
- } else {
- $line .= ", macro=>\"" . C_stringify($macro) . "\"";
- }
- }
- if (defined $value) {
- if (ref $value) {
- $line .= ', value=>["'. join ('", "', map {C_stringify $_} @$value)
- . '"]';
- } else {
- $line .= ", value=>\"" . C_stringify($value) . "\"";
- }
- }
- if (defined $default) {
- if (ref $default) {
- $line .= ', default=>["'. join ('", "', map {C_stringify $_}
- @$default)
- . '"]';
- } else {
- $line .= ", default=>\"" . C_stringify($default) . "\"";
+ 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 {C_stringify $_} @$value) . '"]';
+ } else {
+ $line .= ", $thing=>\"" . C_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 dogfood
+
+dogfood PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, BREAKOUT, ITEM...
+
+An internal function to generate the embedded perl code that will regenerate
+the constant subroutines. Parameters are the same as for C_constant.
+
+=cut
+
+sub dogfood {
+ my ($package, $subname, $default_type, $what, $indent, $breakout, @items)
+ = @_;
+ 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 .= dump_names ($default_type, $what, 0, {declare_types=>1}, @items);
$result .= <<'EOT';
print constant_types(); # macro defs
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 .= ', undef, @names) ) {
+ $result .= ", $breakout" . ', @names) ) {
print $_, "\n"; # C constant subs
}
print "#### XS Section:\n";
*/
';
-
+
$result;
}
-=item C_constant
+=item C_constant
-C_constant PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, NAMELEN, ITEM...
+C_constant PACKAGE, SUBNAME, DEFAULT_TYPE, TYPES, INDENT, BREAKOUT, 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.
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.
+
=back
I<PACKAGE> is the name of the package, and is only used in comments inside the
The best way to maintain consistency is to pass in a hash reference and let
this function update it.
-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.
+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 ($package, $subname, $default_type, $what, $indent, $namelen, @items) = @_;
+ my ($package, $subname, $default_type, $what, $indent, $breakout, @items)
+ = @_;
$package ||= 'Foo';
$subname ||= 'constant';
# I'm not using this. But a hashref could be used for full formatting without
# breaking this API
# $indent ||= 0;
- $default_type ||= 'IV';
- if (!ref $what) {
- # Convert line of the form IV,UV,NV to hash
- $what = {map {$_ => 1} split /,\s*/, ($what || '')};
- # Figure out what types we're dealing with, and assign all unknowns to the
- # default type
- }
- my %items;
- foreach (@items) {
- my $name;
- if (ref $_) {
- # Make a copy which is a normalised version of the ref passed in.
- $name = $_->{name};
- my ($type, $macro, $value, $default) = @$_{qw (type macro value default)};
- $type ||= $default_type;
- $what->{$type} = 1;
- $_ = {name=>$name, type=>$type};
-
- undef $macro if defined $macro and $macro eq $name;
- $_->{macro} = $macro if defined $macro;
- undef $value if defined $value and $value eq $name;
- $_->{value} = $value if defined $value;
- $_->{default} = $default if defined $default;
- } else {
- $name = $_;
- $_ = {name=>$_, type=>$default_type};
- $what->{$default_type} = 1;
+
+ 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 {
+ $breakout ||= 3;
+ $default_type ||= 'IV';
+ if (!ref $what) {
+ # Convert line of the form IV,UV,NV to hash
+ $what = {map {$_ => 1} split /,\s*/, ($what || '')};
+ # Figure out what types we're dealing with, and assign all unknowns to the
+ # default type
}
- warn "ExtUtils::Constant doesn't know how to handle values of type $_ used in macro $name" unless defined $XS_Constant{$_->{type}};
- if (exists $items{$name}) {
- die "Multiple definitions for macro $name";
+ foreach (@items) {
+ my $name;
+ if (ref $_) {
+ my $orig = $_;
+ # Make a copy which is a normalised version of the ref passed in.
+ $name = $_->{name};
+ my ($type, $macro, $value) = @$_{qw (type macro value)};
+ $type ||= $default_type;
+ $what->{$type} = 1;
+ $_ = {name=>$name, type=>$type};
+
+ undef $macro if defined $macro and $macro eq $name;
+ $_->{macro} = $macro if defined $macro;
+ undef $value if defined $value and $value eq $name;
+ $_->{value} = $value if defined $value;
+ foreach my $key (qw(default pre post def_pre def_post)) {
+ my $value = $orig->{$key};
+ $_->{$key} = $value if defined $value;
+ # warn "$key $value";
+ }
+ } else {
+ $name = $_;
+ $_ = {name=>$_, type=>$default_type};
+ $what->{$default_type} = 1;
+ }
+ warn "ExtUtils::Constant doesn't know how to handle values of type $_ used in macro $name" unless defined $XS_Constant{$_->{type}};
+ if (exists $items->{$name}) {
+ die "Multiple definitions for macro $name";
+ }
+ $items->{$name} = $_;
}
- $items{$name} = $_;
}
- my ($use_iv, $use_nv, $use_pv) = params ($what);
+ my $params = params ($what);
- my ($body, @subs) = "static int\n$subname (const char *name";
+ my ($body, @subs) = "static int\n$subname (pTHX_ const char *name";
$body .= ", STRLEN len" unless defined $namelen;
- $body .= ", IV *iv_return" if $use_iv;
- $body .= ", NV *nv_return" if $use_nv;
- $body .= ", const char **pv_return" if $use_pv;
+ $body .= ", 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 .= ") {\n";
if (defined $namelen) {
# We are a child subroutine. Print the simple description
- my @names = sort map {$_->{name}} @items;
- my $names = << 'EOT'
- /* When generated this function returned values for the list of names given
- here. However, subsequent manual editing may have added or removed some.
-EOT
- . wrap (" ", " ", join (" ", @names) . " */") . "\n";
- # Figure out what to switch on.
- # (RMS, Spread of jump table, Position, Hashref)
- my @best = (1e38, ~0);
- foreach my $i (0 .. ($namelen - 1)) {
- my ($min, $max) = (~0, 0);
- my %spread;
- foreach (@names) {
- my $char = substr $_, $i, 1;
- my $ord = ord $char;
- $max = $ord if $ord > $max;
- $min = $ord if $ord < $min;
- push @{$spread{$char}}, $_;
- # warn "$_ $char";
- }
- # I'm going to pick the character to split on that minimises the root
- # mean square of the number of names in each case. Normally this should
- # be the one with the most keys, but it may pick a 7 where the 8 has
- # one long linear search. I'm not sure if RMS or just sum of squares is
- # actually better.
- # $max and $min are for the tie-breaker if the root mean squares match.
- # Assuming that the compiler may be building a jump table for the
- # switch() then try to minimise the size of that jump table.
- # Finally use < not <= so that if it still ties the earliest part of
- # the string wins. Because if that passes but the memEQ fails, it may
- # only need the start of the string to bin the choice.
- # I think. But I'm micro-optimising. :-)
- my $ss;
- $ss += @$_ * @$_ foreach values %spread;
- my $rms = sqrt ($ss / keys %spread);
- if ($rms < $best[0] || ($rms == $best[0] && ($max - $min) < $best[1])) {
- @best = ($rms, $max - $min, $i, \%spread);
- }
- }
- die "Internal error. Failed to pick a switch point for @names"
- unless defined $best[2];
- # use Data::Dumper; print Dumper (@best);
- my ($offset, $best) = @best[2,3];
- $body .= " /* Names all of length $namelen. */\n";
- $body .= $names;
- $body .= " /* Offset $offset gives the best switch position. */\n";
- $body .= " switch (name[$offset]) {\n";
- foreach my $char (sort keys %$best) {
- $body .= " case '" . C_stringify ($char) . "':\n";
- foreach my $name (sort @{$best->{$char}}) {
- my $thisone = $items{$name};
- my ($value, $macro, $default) = @$thisone{qw (value macro default)};
- $value = $name unless defined $value;
- $macro = $name unless defined $macro;
-
- $body .= memEQ_clause ($name, $offset); # We have checked this offset.
- $body .= return_clause ($value, $thisone->{type}, undef, $macro,
- $default);
- $body .= " }\n";
- }
- $body .= " break;\n";
- }
- $body .= " }\n";
+ 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 .= switch_clause (2, $comment, $namelen, $items, @items);
} else {
# We are the top level.
$body .= " /* Initially switch on the length of the name. */\n";
- $body .= dump_names ($package, $subname, $default_type, $what, $indent,
- @items);
+ $body .= dogfood ($package, $subname, $default_type, $what, $indent,
+ $breakout, @items);
$body .= " switch (len) {\n";
# Need to group names of the same length
my @by_length;
$body .= " case $i:\n";
if (@{$by_length[$i]} == 1) {
my $thisone = $by_length[$i]->[0];
- my ($name, $value, $macro, $default)
- = @$thisone{qw (name value macro default)};
+ my ($name, $value, $macro, $default, $pre, $post, $def_pre, $def_post)
+ = @$thisone{qw (name value macro default pre post def_pre def_post)};
$value = $name unless defined $value;
$macro = $name unless defined $macro;
$body .= memEQ_clause ($name);
$body .= return_clause ($value, $thisone->{type}, undef, $macro,
- $default);
+ $default, $pre, $post, $def_pre, $def_post);
$body .= " }\n";
+ } elsif (@{$by_length[$i]} < $breakout) {
+ $body .= switch_clause (4, '', $i, $items, @{$by_length[$i]});
} else {
- push @subs, C_constant ($package, "${subname}_$i", $default_type,
- $what, $indent, $i, @{$by_length[$i]});
- $body .= " return ${subname}_$i (name";
- $body .= ", iv_return" if $use_iv;
- $body .= ", nv_return" if $use_nv;
- $body .= ", pv_return" if $use_pv;
+ # 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;
+ }
+ $params = params ($what);
+ push @subs, C_constant ($package, "${subname}_$i", $default_type, $what,
+ $indent, [$i, $items], @{$by_length[$i]});
+ $body .= " return ${subname}_$i (aTHX_ name";
+ $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 .= ");\n";
}
$body .= " break;\n";
# Convert line of the form IV,UV,NV to hash
$what = {map {$_ => 1} split /,\s*/, ($what)};
}
- my ($use_iv, $use_nv, $use_pv) = params ($what);
+ my $params = params ($what);
my $type;
my $xs = <<"EOT";
int type;
EOT
- if ($use_iv) {
+ if ($params->{IV}) {
$xs .= " IV iv;\n";
} else {
$xs .= " /* IV\t\tiv;\tUncomment this if you need to return IVs */\n";
}
- if ($use_nv) {
+ if ($params->{NV}) {
$xs .= " NV nv;\n";
} else {
$xs .= " /* NV\t\tnv;\tUncomment this if you need to return NVs */\n";
}
- if ($use_pv) {
+ if ($params->{PV}) {
$xs .= " const char *pv;\n";
} else {
$xs .=
PPCODE:
EOT
- if ($use_iv xor $use_nv) {
+ if ($params->{IV} xor $params->{NV}) {
$xs .= << "EOT";
- /* Change this to $C_subname(s, len, &iv, &nv);
+ /* Change this to $C_subname(aTHX_ s, len, &iv, &nv);
if you need to return both NVs and IVs */
EOT
}
- $xs .= " type = $C_subname(s, len";
- $xs .= ', &iv' if $use_iv;
- $xs .= ', &nv' if $use_nv;
- $xs .= ', &pv' if $use_pv;
+ $xs .= " type = $C_subname(aTHX_ s, len";
+ $xs .= ', &iv' if $params->{IV};
+ $xs .= ', &nv' if $params->{NV};
+ $xs .= ', &pv' if $params->{PV};
+ $xs .= ', &sv' if $params->{SV};
$xs .= ");\n";
$xs .= << "EOT";
break;
case PERL_constant_NOTDEF:
sv = sv_2mortal(newSVpvf(
- "Your vendor has not defined $package macro %s used", s));
+ "Your vendor has not defined $package macro %s, used", s));
PUSHs(sv);
break;
EOT
foreach $type (sort keys %XS_Constant) {
$xs .= "\t/* Uncomment this if you need to return ${type}s\n"
unless $what->{$type};
- $xs .= << "EOT";
- case PERL_constant_IS$type:
+ $xs .= " case PERL_constant_IS$type:\n";
+ if (length $XS_Constant{$type}) {
+ $xs .= << "EOT";
EXTEND(SP, 1);
PUSHs(&PL_sv_undef);
$XS_Constant{$type};
- break;
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 macro %s used",
+ "Unexpected return type %d while processing $package macro %s, used",
type, s));
PUSHs(sv);
}
$func .= "\n\n"
. " my \$constname;\n";
- $func .=
+ $func .=
" our \$AUTOLOAD;\n" if ($compat_version >= 5.006);
$func .= <<"EOT";
return $func;
}
+
+
+=item WriteMakefileSnippet
+
+WriteMakefileSnippet ATTRIBUTE =E<gt> VALUE [, ...]
+
+An 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 dump_names ($args{DEFAULT_TYPE}, undef, $indent, undef,
+ @{$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 probaby 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 C_FILE
+
+The name of the file to write containing the C code. The default is
+C<constants.c>.
+
+=item XS_FILE
+
+The name of the file to write containing the XS code. The default is
+C<constants.xs>.
+
+=item 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<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 => 'constants.c',
+ XS_FILE => 'constants.xs',
+ SUBNAME => 'constant',
+ DEFAULT_TYPE => 'IV',
+ @_);
+
+ $ARGS{C_SUBNAME} ||= $ARGS{SUBNAME}; # No-one sane will have C_SUBNAME eq '0'
+
+ croak "Module name not specified" unless length $ARGS{NAME};
+
+ open my $c_fh, ">$ARGS{C_FILE}" or die "Can't open $ARGS{C_FILE}: $!";
+ open my $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.
+ my $types = {};
+
+ print $c_fh constant_types(); # macro defs
+ print $c_fh "\n";
+
+ # indent is still undef. Until anyone implents indent style rules with it.
+ foreach (C_constant ($ARGS{NAME}, $ARGS{C_SUBNAME}, $ARGS{DEFAULT_TYPE},
+ $types, undef, $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}: $!";
+ close $xs_fh or warn "Error closing $ARGS{XS_FILE}: $!";
+}
+
1;
__END__
projects / p5sagit/p5-mst-13.2.git / blobdiff