1 package ExtUtils::Constant::ProxySubs;
4 use vars qw($VERSION @ISA %type_to_struct %type_from_struct %type_to_sv
5 %type_to_C_value %type_is_a_problem %type_num_args
8 require ExtUtils::Constant::XS;
9 use ExtUtils::Constant::Utils qw(C_stringify);
10 use ExtUtils::Constant::XS qw(%XS_TypeSet);
13 @ISA = 'ExtUtils::Constant::XS';
17 IV => '{const char *name; I32 namelen; IV value;}',
18 NV => '{const char *name; I32 namelen; NV value;}',
19 UV => '{const char *name; I32 namelen; UV value;}',
20 PV => '{const char *name; I32 namelen; const char *value;}',
21 PVN => '{const char *name; I32 namelen; const char *value; STRLEN len;}',
22 YES => '{const char *name; I32 namelen;}',
23 NO => '{const char *name; I32 namelen;}',
24 UNDEF => '{const char *name; I32 namelen;}',
25 '' => '{const char *name; I32 namelen;} ',
30 IV => sub { $_[0] . '->value' },
31 NV => sub { $_[0] . '->value' },
32 UV => sub { $_[0] . '->value' },
33 PV => sub { $_[0] . '->value' },
34 PVN => sub { $_[0] . '->value', $_[0] . '->len' },
43 IV => sub { "newSViv($_[0])" },
44 NV => sub { "newSVnv($_[0])" },
45 UV => sub { "newSVuv($_[0])" },
46 PV => sub { "newSVpv($_[0], 0)" },
47 PVN => sub { "newSVpvn($_[0], $_[1])" },
48 YES => sub { '&PL_sv_yes' },
49 NO => sub { '&PL_sv_no' },
50 UNDEF => sub { '&PL_sv_undef' },
51 '' => sub { '&PL_sv_yes' },
52 SV => sub {"SvREFCNT_inc($_[0])"},
64 my ($self, $type) = @_;
65 return $type_to_C_value{$type} || sub {return map {ref $_ ? @$_ : $_} @_};
68 # TODO - figure out if there is a clean way for the type_to_sv code to
69 # attempt s/sv_2mortal// and if it succeeds tell type_to_sv not to add
73 # The documentation says *mortal SV*, but we now need a non-mortal copy.
80 PV => ['const char *'],
81 PVN => ['const char *', 'STRLEN'],
83 $type_temporary{$_} = [$_] foreach qw(IV UV NV);
85 while (my ($type, $value) = each %XS_TypeSet) {
87 = defined $value ? ref $value ? scalar @$value : 1 : 0;
89 $type_num_args{''} = 0;
92 my ($self, $default_type, @items) = @_;
93 my (%found, @notfound, @trouble);
95 while (my $item = shift @items) {
96 my $default = delete $item->{default};
98 # If we find a default value, convert it into a regular item and
99 # append it to the queue of items to process
100 my $default_item = {%$item};
101 $default_item->{invert_macro} = 1;
102 $default_item->{pre} = delete $item->{def_pre};
103 $default_item->{post} = delete $item->{def_post};
104 $default_item->{type} = shift @$default;
105 $default_item->{value} = $default;
106 push @items, $default_item;
108 # It can be "not found" unless it's the default (invert the macro)
109 # or the "macro" is an empty string (ie no macro)
110 push @notfound, $item unless $item->{invert_macro}
111 or !$self->macro_to_ifdef($self->macro_from_item($item));
114 if ($item->{pre} or $item->{post} or $item->{not_constant}
115 or $type_is_a_problem{$item->{type}}) {
116 push @trouble, $item;
118 push @{$found{$item->{type}}}, $item;
121 # use Data::Dumper; print Dumper \%found;
122 (\%found, \@notfound, \@trouble);
125 sub boottime_iterator {
126 my ($self, $type, $iterator, $hash, $subname) = @_;
127 my $extractor = $type_from_struct{$type};
128 die "Can't find extractor code for type $type"
129 unless defined $extractor;
130 my $generator = $type_to_sv{$type};
131 die "Can't find generator code for type $type"
132 unless defined $generator;
134 my $athx = $self->C_constant_prefix_param();
136 return sprintf <<"EOBOOT", &$generator(&$extractor($iterator));
137 while ($iterator->name) {
138 $subname($athx $hash, $iterator->name,
139 $iterator->namelen, %s);
145 sub name_len_value_macro {
146 my ($self, $item) = @_;
147 my $name = $item->{name};
148 my $value = $item->{value};
149 $value = $item->{name} unless defined $value;
151 my $namelen = length $name;
152 if ($name =~ tr/\0-\377// != $namelen) {
153 # the hash API signals UTF-8 by passing the length negated.
155 $namelen = -length $name;
157 $name = C_stringify($name);
159 my $macro = $self->macro_from_item($item);
160 ($name, $namelen, $value, $macro);
167 my ($c_fh, $xs_fh, $c_subname, $xs_subname, $default_type, $package)
168 = @{$ARGS}{qw(C_FH XS_FH C_SUBNAME XS_SUBNAME DEFAULT_TYPE NAME)};
170 my $options = $ARGS->{PROXYSUBS};
171 $options = {} unless ref $options;
172 my $explosives = $options->{croak_on_read};
174 $xs_subname ||= 'constant';
176 # If anyone is insane enough to suggest a package name containing %
177 my $package_sprintf_safe = $package;
178 $package_sprintf_safe =~ s/%/%%/g;
180 # All the types we see
182 # A hash to lookup items with.
185 my @items = $self->normalise_items ({disable_utf8_duplication => 1},
186 $default_type, $what, $items,
189 # Partition the values by type. Also include any defaults in here
190 # Everything that doesn't have a default needs alternative code for
192 # And everything that has pre or post code ends up in a private block
193 my ($found, $notfound, $trouble)
194 = $self->partition_names($default_type, @items);
196 my $pthx = $self->C_constant_prefix_param_defintion();
197 my $athx = $self->C_constant_prefix_param();
198 my $symbol_table = C_stringify($package) . '::';
200 print $c_fh $self->header(), <<"EOADD";
202 ${c_subname}_add_symbol($pthx HV *hash, const char *name, I32 namelen, SV *value) {
203 SV **sv = hv_fetch(hash, name, namelen, TRUE);
205 Perl_croak($athx "Couldn't add key '%s' to %%$package_sprintf_safe\::",
208 if (SvOK(*sv) || SvTYPE(*sv) == SVt_PVGV) {
209 /* Someone has been here before us - have to make a real sub. */
210 newCONSTSUB(hash, name, value);
212 SvUPGRADE(*sv, SVt_RV);
213 SvRV_set(*sv, value);
215 SvREADONLY_on(value);
221 print $c_fh $explosives ? <<"EXPLODE" : <<"DONT";
224 Im_sorry_Dave(pTHX_ SV *sv, MAGIC *mg)
228 "Your vendor has not defined $package_sprintf_safe macro %"SVf
230 NORETURN_FUNCTION_END;
233 static MGVTBL not_defined_vtbl = {
234 Im_sorry_Dave, /* get - I'm afraid I can't do that */
235 Im_sorry_Dave, /* set */
245 static HV *${c_subname}_missing = NULL;
249 print $xs_fh <<"EOBOOT";
255 HV *symbol_table = get_hv("$symbol_table", TRUE);
261 = [map {{%$_, type=>'', invert_macro => 1}} @$notfound];
263 foreach my $type (sort keys %$found) {
264 my $struct = $type_to_struct{$type};
265 my $type_to_value = $self->type_to_C_value($type);
266 my $number_of_args = $type_num_args{$type};
267 die "Can't find structure definition for type $type"
268 unless defined $struct;
270 my $struct_type = $type ? lc($type) . '_s' : 'notfound_s';
271 print $c_fh "struct $struct_type $struct;\n";
273 my $array_name = 'values_for_' . ($type ? lc $type : 'notfound');
274 print $xs_fh <<"EOBOOT";
276 static const struct $struct_type $array_name\[] =
281 foreach my $item (@{$found->{$type}}) {
282 my ($name, $namelen, $value, $macro)
283 = $self->name_len_value_macro($item);
285 my $ifdef = $self->macro_to_ifdef($macro);
286 if (!$ifdef && $item->{invert_macro}) {
287 carp("Attempting to supply a default for '$name' which has no conditional macro");
291 if ($item->{invert_macro}) {
293 " /* This is the default value: */\n" if $type;
294 print $xs_fh "#else\n";
296 print $xs_fh " { ", join (', ', "\"$name\"", $namelen,
297 &$type_to_value($value)), " },\n",
298 $self->macro_to_endif($macro);
302 # Terminate the list with a NULL
303 print $xs_fh " { NULL, 0", (", 0" x $number_of_args), " } };\n";
305 $iterator{$type} = "value_for_" . ($type ? lc $type : 'notfound');
307 print $xs_fh <<"EOBOOT";
308 const struct $struct_type *$iterator{$type} = $array_name;
315 my $add_symbol_subname = $c_subname . '_add_symbol';
316 foreach my $type (sort keys %$found) {
317 print $xs_fh $self->boottime_iterator($type, $iterator{$type},
319 $add_symbol_subname);
321 print $xs_fh "\n", $explosives ? "" : <<"EOBOOT";
322 ${c_subname}_missing = newHV();
325 print $xs_fh <<"EOBOOT";
326 while (value_for_notfound->name) {
329 print $xs_fh $explosives ? <<"EXPLODE" : << "DONT";
330 SV *tripwire = newSV(0);
332 sv_magicext(tripwire, 0, PERL_MAGIC_ext, ¬_defined_vtbl, 0, 0);
333 SvPV_set(tripwire, (char *)value_for_notfound->name);
334 if(value_for_notfound->namelen >= 0) {
335 SvCUR_set(tripwire, value_for_notfound->namelen);
337 SvCUR_set(tripwire, -value_for_notfound->namelen);
341 SvREADONLY_on(tripwire);
342 assert(SvLEN(tripwire) == 0);
344 $add_symbol_subname($athx symbol_table, value_for_notfound->name,
345 value_for_notfound->namelen, tripwire);
348 /* Need to add prototypes, else parsing will vary by platform. */
349 SV **sv = hv_fetch(symbol_table, value_for_notfound->name,
350 value_for_notfound->namelen, TRUE);
353 "Couldn't add key '%s' to %%$package_sprintf_safe\::",
354 value_for_notfound->name);
356 if (!SvOK(*sv) && SvTYPE(*sv) != SVt_PVGV) {
357 /* Nothing was here before, so mark a prototype of "" */
358 sv_setpvn(*sv, "", 0);
359 } else if (SvPOK(*sv) && SvCUR(*sv) == 0) {
360 /* There is already a prototype of "" - do nothing */
362 /* Someone has been here before us - have to make a real
364 /* It turns out to be incredibly hard to deal with all the
365 corner cases of sub foo (); and reporting errors correctly,
366 so lets cheat a bit. Start with a constant subroutine */
367 CV *cv = newCONSTSUB(symbol_table, value_for_notfound->name,
369 /* and then turn it into a non constant declaration only. */
374 if (!hv_store(${c_subname}_missing, value_for_notfound->name,
375 value_for_notfound->namelen, &PL_sv_yes, 0))
376 Perl_croak($athx "Couldn't add key '%s' to missing_hash",
377 value_for_notfound->name);
380 print $xs_fh <<"EOBOOT";
382 ++value_for_notfound;
386 foreach my $item (@$trouble) {
387 my ($name, $namelen, $value, $macro)
388 = $self->name_len_value_macro($item);
389 my $ifdef = $self->macro_to_ifdef($macro);
390 my $type = $item->{type};
391 my $type_to_value = $self->type_to_C_value($type);
394 if ($item->{invert_macro}) {
396 " /* This is the default value: */\n" if $type;
397 print $xs_fh "#else\n";
399 my $generator = $type_to_sv{$type};
400 die "Can't find generator code for type $type"
401 unless defined $generator;
404 # We need to use a temporary value because some really troublesome
405 # items use C pre processor directives in their values, and in turn
406 # these don't fit nicely in the macro-ised generator functions
408 printf $xs_fh " %s temp%d;\n", $_, $counter++
409 foreach @{$type_temporary{$type}};
411 print $xs_fh " $item->{pre}\n" if $item->{pre};
413 # And because the code in pre might be both declarations and
414 # statements, we can't declare and assign to the temporaries in one.
416 printf $xs_fh " temp%d = %s;\n", $counter++, $_
417 foreach &$type_to_value($value);
419 my @tempvarnames = map {sprintf 'temp%d', $_} 0 .. $counter - 1;
420 printf $xs_fh <<"EOBOOT", $name, &$generator(@tempvarnames);
421 ${c_subname}_add_symbol($athx symbol_table, "%s",
424 print $xs_fh " $item->{post}\n" if $item->{post};
427 print $xs_fh $self->macro_to_endif($macro);
430 print $xs_fh <<EOBOOT;
431 /* As we've been creating subroutines, we better invalidate any cached
437 print $xs_fh $explosives ? <<"EXPLODE" : <<"DONT";
444 sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf
446 PUSHs(sv_2mortal(sv));
455 const char * s = SvPV(sv, len);
457 if (hv_exists(${c_subname}_missing, s, SvUTF8(sv) ? -(I32)len : len)) {
458 sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf
461 sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro",
464 PUSHs(sv_2mortal(sv));