From: Nicholas Clark Date: Thu, 22 Dec 2005 21:02:19 +0000 (+0000) Subject: Make ExtUtils::Constant generate the inlineable proxy constant subs. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=6d7fb585cd8ad83f4523191641999603aa48eb76;p=p5sagit%2Fp5-mst-13.2.git Make ExtUtils::Constant generate the inlineable proxy constant subs. So far just enough to make Fcntl work. p4raw-id: //depot/perl@26453 --- diff --git a/MANIFEST b/MANIFEST index a8b5a98..eb3be34 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1447,6 +1447,7 @@ lib/ExtUtils/Command/MM.pm Calling MM functions from the cmd line lib/ExtUtils/Command.pm Utilities for Make on non-UNIX platforms lib/ExtUtils/Constant/Base.pm generate XS code to import C header constants lib/ExtUtils/Constant.pm generate XS code to import C header constants +lib/ExtUtils/Constant/ProxySubs.pm generate XS code for proxy constants lib/ExtUtils/Constant/Utils.pm generate XS code to import C header constants lib/ExtUtils/Constant/XS.pm generate XS code to import C header constants lib/ExtUtils/Embed.pm Utilities for embedding Perl in C programs diff --git a/ext/Fcntl/Makefile.PL b/ext/Fcntl/Makefile.PL index 6ba40a5..2f31a73 100644 --- a/ext/Fcntl/Makefile.PL +++ b/ext/Fcntl/Makefile.PL @@ -40,6 +40,7 @@ my @names = (qw( {name=>"SEEK_END", default=>["IV", "2"]}, {name=>"_S_IFMT", macro=>"S_IFMT", value=>"S_IFMT"}); WriteConstants( + PROXYSUBS => 1, NAME => 'Fcntl', NAMES => \@names, ); diff --git a/lib/ExtUtils/Constant.pm b/lib/ExtUtils/Constant.pm index 9e2b6b8..cd04063 100644 --- a/lib/ExtUtils/Constant.pm +++ b/lib/ExtUtils/Constant.pm @@ -1,6 +1,6 @@ package ExtUtils::Constant; use vars qw (@ISA $VERSION @EXPORT_OK %EXPORT_TAGS); -$VERSION = 0.17; +$VERSION = 0.20; =head1 NAME @@ -490,23 +490,40 @@ sub WriteConstants { # 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 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 + + if ($ARGS{PROXYSUBS}) { + require ExtUtils::Constant::ProxySubs; + ExtUtils::Constant::ProxySubs->WriteConstants({c_fh => $c_fh, + xs_fh => $xs_fh, + package => $ARGS{NAME}, + c_subname + => $ARGS{C_SUBNAME}, + xs_subname + => $ARGS{XS_SUBNAME}, + default_type + => $ARGS{DEFAULT_TYPE}, + }, @{$ARGS{NAMES}}); + } 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}); } - 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}: $!"; diff --git a/lib/ExtUtils/Constant/ProxySubs.pm b/lib/ExtUtils/Constant/ProxySubs.pm new file mode 100644 index 0000000..9578db3 --- /dev/null +++ b/lib/ExtUtils/Constant/ProxySubs.pm @@ -0,0 +1,250 @@ +package ExtUtils::Constant::ProxySubs; + +use strict; +use vars qw($VERSION @ISA %type_to_struct %type_to_sv %type_to_C_value + %type_is_a_problem %type_num_args); +use Carp; +require ExtUtils::Constant::XS; +use ExtUtils::Constant::Utils qw(C_stringify); +use ExtUtils::Constant::XS qw(%XS_TypeSet); + +$VERSION = '0.01'; +@ISA = 'ExtUtils::Constant::XS'; + +%type_to_struct = + ( + IV => '{const char *name; I32 namelen; IV value;}', + '' => '{const char *name; I32 namelen;} ', + ); + +%type_to_sv = + ( + IV => sub { 'newSViv(' . $_[0] . '->value)' }, + '' => sub { '&PL_sv_yes' }, + ); + +%type_to_C_value = + ( + '' => sub {}, + ); + +%type_is_a_problem = + ( + SV => 1, + ); + +while (my ($type, $value) = each %XS_TypeSet) { + $type_num_args{$type} = ref $value ? scalar @$value : 1; +} +$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_name($item)); + } + + if ($item->{pre} or $item->{post} 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 $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($iterator); + while ($iterator->name) { + $subname($athx $hash, $iterator->name, + $iterator->namelen, %s); + ++$iterator; + } +EOBOOT +} + +sub WriteConstants { + my $self = shift; + my $ARGS = shift; + + my ($c_fh, $xs_fh, $c_subname, $xs_subname, $default_type, $package) + = @{$ARGS}{qw(c_fh xs_fh c_subname xs_subname default_type package)}; + + $xs_subname ||= 'constant'; + + croak("Package name '$package' contains % characters") if $package =~ /%/; + + # 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, @_); + + # 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); + + die "Can't cope with trouble yet" if @$trouble; + + my $pthx = $self->C_constant_prefix_param_defintion(); + my $athx = $self->C_constant_prefix_param(); + my $symbol_table = C_stringify($package) . '::'; + + print $c_fh <<"EOADD"; +void ${c_subname}_add_symbol($pthx HV *hash, const char *name, I32 namelen, SV *value) { + SV *rv = newRV_noinc(value); + if (!hv_store(hash, name, namelen, rv, TRUE)) { + SvREFCNT_dec(rv); + Perl_croak("Couldn't add key '%s' to %%%s", name, "$package"); + } +} + +static HV *${c_subname}_missing = NULL; + +EOADD + + print $xs_fh <<"EOBOOT"; +BOOT: + { +#ifdef dTHX + dTHX; +#endif + HV *symbol_table = get_hv("$symbol_table", TRUE); +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 = $type_to_C_value{$type} + || sub {return map {ref $_ ? @$_ : $_} @_}; + 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 = $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_name($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->{''}; + foreach my $type (sort keys %$found) { + print $xs_fh $self->boottime_iterator($type, $iterator{$type}, + 'symbol_table', + "${c_subname}_add_symbol"); + } + print $xs_fh <<"EOBOOT"; + + ${c_subname}_missing = newHV(); + while (value_for_notfound->name) { + if (!hv_store(${c_subname}_missing, value_for_notfound->name, + value_for_notfound->namelen, &PL_sv_yes, TRUE)) + Perl_croak("Couldn't add key '%s' to missing_hash", + value_for_notfound->name); + ++value_for_notfound; + } + } +EOBOOT + + print $xs_fh <