Commit | Line | Data |
---|---|---|
6d7fb585 NC |
1 | package ExtUtils::Constant::ProxySubs; |
2 | ||
3 | use strict; | |
64bb7586 | 4 | use vars qw($VERSION @ISA %type_to_struct %type_from_struct %type_to_sv |
6800c0cf NC |
5 | %type_to_C_value %type_is_a_problem %type_num_args |
6 | %type_temporary); | |
6d7fb585 NC |
7 | use Carp; |
8 | require ExtUtils::Constant::XS; | |
9 | use ExtUtils::Constant::Utils qw(C_stringify); | |
10 | use ExtUtils::Constant::XS qw(%XS_TypeSet); | |
11 | ||
12 | $VERSION = '0.01'; | |
13 | @ISA = 'ExtUtils::Constant::XS'; | |
14 | ||
15 | %type_to_struct = | |
16 | ( | |
17 | IV => '{const char *name; I32 namelen; IV value;}', | |
64bb7586 NC |
18 | NV => '{const char *name; I32 namelen; NV value;}', |
19 | UV => '{const char *name; I32 namelen; UV value;}', | |
49657794 | 20 | PV => '{const char *name; I32 namelen; const char *value;}', |
6f226cd7 | 21 | PVN => '{const char *name; I32 namelen; const char *value; STRLEN len;}', |
64bb7586 NC |
22 | YES => '{const char *name; I32 namelen;}', |
23 | NO => '{const char *name; I32 namelen;}', | |
6f226cd7 | 24 | UNDEF => '{const char *name; I32 namelen;}', |
6d7fb585 NC |
25 | '' => '{const char *name; I32 namelen;} ', |
26 | ); | |
27 | ||
64bb7586 NC |
28 | %type_from_struct = |
29 | ( | |
30 | IV => sub { $_[0] . '->value' }, | |
31 | NV => sub { $_[0] . '->value' }, | |
32 | UV => sub { $_[0] . '->value' }, | |
49657794 | 33 | PV => sub { $_[0] . '->value' }, |
6f226cd7 | 34 | PVN => sub { $_[0] . '->value', $_[0] . '->len' }, |
64bb7586 NC |
35 | YES => sub {}, |
36 | NO => sub {}, | |
6f226cd7 | 37 | UNDEF => sub {}, |
64bb7586 NC |
38 | '' => sub {}, |
39 | ); | |
40 | ||
6d7fb585 NC |
41 | %type_to_sv = |
42 | ( | |
64bb7586 NC |
43 | IV => sub { "newSViv($_[0])" }, |
44 | NV => sub { "newSVnv($_[0])" }, | |
45 | UV => sub { "newSVuv($_[0])" }, | |
49657794 | 46 | PV => sub { "newSVpv($_[0], 0)" }, |
6f226cd7 | 47 | PVN => sub { "newSVpvn($_[0], $_[1])" }, |
64bb7586 NC |
48 | YES => sub { '&PL_sv_yes' }, |
49 | NO => sub { '&PL_sv_no' }, | |
0fcb9a02 | 50 | UNDEF => sub { '&PL_sv_undef' }, |
6d7fb585 | 51 | '' => sub { '&PL_sv_yes' }, |
2ebbb0c3 | 52 | SV => sub {"SvREFCNT_inc($_[0])"}, |
6d7fb585 NC |
53 | ); |
54 | ||
55 | %type_to_C_value = | |
56 | ( | |
64bb7586 NC |
57 | YES => sub {}, |
58 | NO => sub {}, | |
0fcb9a02 | 59 | UNDEF => sub {}, |
6d7fb585 NC |
60 | '' => sub {}, |
61 | ); | |
62 | ||
64bb7586 NC |
63 | sub type_to_C_value { |
64 | my ($self, $type) = @_; | |
65 | return $type_to_C_value{$type} || sub {return map {ref $_ ? @$_ : $_} @_}; | |
66 | } | |
67 | ||
49657794 NC |
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 | |
70 | # SvREFCNT_inc | |
6d7fb585 NC |
71 | %type_is_a_problem = |
72 | ( | |
2ebbb0c3 | 73 | # The documentation says *mortal SV*, but we now need a non-mortal copy. |
6d7fb585 NC |
74 | SV => 1, |
75 | ); | |
76 | ||
49657794 NC |
77 | %type_temporary = |
78 | ( | |
6f226cd7 NC |
79 | SV => ['SV *'], |
80 | PV => ['const char *'], | |
81 | PVN => ['const char *', 'STRLEN'], | |
49657794 | 82 | ); |
6f226cd7 | 83 | $type_temporary{$_} = [$_] foreach qw(IV UV NV); |
6800c0cf | 84 | |
6d7fb585 | 85 | while (my ($type, $value) = each %XS_TypeSet) { |
64bb7586 NC |
86 | $type_num_args{$type} |
87 | = defined $value ? ref $value ? scalar @$value : 1 : 0; | |
6d7fb585 NC |
88 | } |
89 | $type_num_args{''} = 0; | |
90 | ||
91 | sub partition_names { | |
92 | my ($self, $default_type, @items) = @_; | |
93 | my (%found, @notfound, @trouble); | |
94 | ||
95 | while (my $item = shift @items) { | |
96 | my $default = delete $item->{default}; | |
97 | if ($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; | |
107 | } else { | |
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} | |
0fcb9a02 | 111 | or !$self->macro_to_ifdef($self->macro_from_item($item)); |
6d7fb585 NC |
112 | } |
113 | ||
64bb7586 NC |
114 | if ($item->{pre} or $item->{post} or $item->{not_constant} |
115 | or $type_is_a_problem{$item->{type}}) { | |
6d7fb585 NC |
116 | push @trouble, $item; |
117 | } else { | |
118 | push @{$found{$item->{type}}}, $item; | |
119 | } | |
120 | } | |
121 | # use Data::Dumper; print Dumper \%found; | |
122 | (\%found, \@notfound, \@trouble); | |
123 | } | |
124 | ||
125 | sub boottime_iterator { | |
126 | my ($self, $type, $iterator, $hash, $subname) = @_; | |
64bb7586 NC |
127 | my $extractor = $type_from_struct{$type}; |
128 | die "Can't find extractor code for type $type" | |
129 | unless defined $extractor; | |
6d7fb585 NC |
130 | my $generator = $type_to_sv{$type}; |
131 | die "Can't find generator code for type $type" | |
132 | unless defined $generator; | |
133 | ||
134 | my $athx = $self->C_constant_prefix_param(); | |
135 | ||
64bb7586 | 136 | return sprintf <<"EOBOOT", &$generator(&$extractor($iterator)); |
6d7fb585 NC |
137 | while ($iterator->name) { |
138 | $subname($athx $hash, $iterator->name, | |
139 | $iterator->namelen, %s); | |
140 | ++$iterator; | |
141 | } | |
142 | EOBOOT | |
143 | } | |
144 | ||
64bb7586 NC |
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; | |
150 | ||
151 | my $namelen = length $name; | |
152 | if ($name =~ tr/\0-\377// != $namelen) { | |
153 | # the hash API signals UTF-8 by passing the length negated. | |
154 | utf8::encode($name); | |
155 | $namelen = -length $name; | |
156 | } | |
157 | $name = C_stringify($name); | |
158 | ||
0fcb9a02 | 159 | my $macro = $self->macro_from_item($item); |
64bb7586 NC |
160 | ($name, $namelen, $value, $macro); |
161 | } | |
162 | ||
6d7fb585 NC |
163 | sub WriteConstants { |
164 | my $self = shift; | |
6b43b341 | 165 | my $ARGS = {@_}; |
6d7fb585 NC |
166 | |
167 | my ($c_fh, $xs_fh, $c_subname, $xs_subname, $default_type, $package) | |
6b43b341 NC |
168 | = @{$ARGS}{qw(C_FH XS_FH C_SUBNAME XS_SUBNAME DEFAULT_TYPE NAME)}; |
169 | ||
170 | my $options = $ARGS->{PROXYSUBS}; | |
171 | $options = {} unless ref $options; | |
172 | my $explosives = $options->{croak_on_read}; | |
6d7fb585 NC |
173 | |
174 | $xs_subname ||= 'constant'; | |
175 | ||
fa6eee5a NC |
176 | # If anyone is insane enough to suggest a package name containing % |
177 | my $package_sprintf_safe = $package; | |
178 | $package_sprintf_safe =~ s/%/%%/g; | |
6d7fb585 NC |
179 | |
180 | # All the types we see | |
181 | my $what = {}; | |
182 | # A hash to lookup items with. | |
183 | my $items = {}; | |
184 | ||
185 | my @items = $self->normalise_items ({disable_utf8_duplication => 1}, | |
6b43b341 NC |
186 | $default_type, $what, $items, |
187 | @{$ARGS->{NAMES}}); | |
6d7fb585 NC |
188 | |
189 | # Partition the values by type. Also include any defaults in here | |
190 | # Everything that doesn't have a default needs alternative code for | |
191 | # "I'm missing" | |
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); | |
195 | ||
6d7fb585 NC |
196 | my $pthx = $self->C_constant_prefix_param_defintion(); |
197 | my $athx = $self->C_constant_prefix_param(); | |
198 | my $symbol_table = C_stringify($package) . '::'; | |
199 | ||
64bb7586 | 200 | print $c_fh $self->header(), <<"EOADD"; |
6d7fb585 | 201 | void ${c_subname}_add_symbol($pthx HV *hash, const char *name, I32 namelen, SV *value) { |
0998eade NC |
202 | SV **sv = hv_fetch(hash, name, namelen, TRUE); |
203 | if (!sv) { | |
fa6eee5a NC |
204 | Perl_croak($athx "Couldn't add key '%s' to %%$package_sprintf_safe\::", |
205 | name); | |
0998eade NC |
206 | } |
207 | if (SvOK(*sv) || SvTYPE(*sv) == SVt_PVGV) { | |
208 | /* Someone has been here before us - have to make a real sub. */ | |
209 | newCONSTSUB(hash, name, value); | |
210 | } else { | |
211 | SvUPGRADE(*sv, SVt_RV); | |
212 | SvRV_set(*sv, value); | |
213 | SvROK_on(*sv); | |
abe8a887 | 214 | SvREADONLY_on(value); |
6d7fb585 NC |
215 | } |
216 | } | |
217 | ||
6b43b341 NC |
218 | EOADD |
219 | ||
220 | print $c_fh $explosives ? <<"EXPLODE" : <<"DONT"; | |
221 | ||
222 | static int | |
223 | Im_sorry_Dave(pTHX_ SV *sv, MAGIC *mg) | |
224 | { | |
225 | PERL_UNUSED_ARG(mg); | |
fa6eee5a NC |
226 | Perl_croak(aTHX_ |
227 | "Your vendor has not defined $package_sprintf_safe macro %"SVf | |
228 | " used", sv); | |
6b43b341 NC |
229 | NORETURN_FUNCTION_END; |
230 | } | |
231 | ||
232 | static MGVTBL not_defined_vtbl = { | |
233 | Im_sorry_Dave, /* get - I'm afraid I can't do that */ | |
234 | Im_sorry_Dave, /* set */ | |
235 | 0, /* len */ | |
236 | 0, /* clear */ | |
237 | 0, /* free */ | |
238 | 0, /* copy */ | |
239 | 0, /* dup */ | |
240 | }; | |
241 | ||
242 | EXPLODE | |
243 | ||
6d7fb585 NC |
244 | static HV *${c_subname}_missing = NULL; |
245 | ||
6b43b341 | 246 | DONT |
6d7fb585 NC |
247 | |
248 | print $xs_fh <<"EOBOOT"; | |
249 | BOOT: | |
250 | { | |
251 | #ifdef dTHX | |
252 | dTHX; | |
253 | #endif | |
254 | HV *symbol_table = get_hv("$symbol_table", TRUE); | |
255 | EOBOOT | |
256 | ||
257 | my %iterator; | |
258 | ||
259 | $found->{''} | |
260 | = [map {{%$_, type=>'', invert_macro => 1}} @$notfound]; | |
261 | ||
262 | foreach my $type (sort keys %$found) { | |
263 | my $struct = $type_to_struct{$type}; | |
64bb7586 | 264 | my $type_to_value = $self->type_to_C_value($type); |
6d7fb585 NC |
265 | my $number_of_args = $type_num_args{$type}; |
266 | die "Can't find structure definition for type $type" | |
267 | unless defined $struct; | |
268 | ||
269 | my $struct_type = $type ? lc($type) . '_s' : 'notfound_s'; | |
270 | print $c_fh "struct $struct_type $struct;\n"; | |
271 | ||
272 | my $array_name = 'values_for_' . ($type ? lc $type : 'notfound'); | |
273 | print $xs_fh <<"EOBOOT"; | |
274 | ||
275 | static const struct $struct_type $array_name\[] = | |
276 | { | |
277 | EOBOOT | |
278 | ||
279 | ||
280 | foreach my $item (@{$found->{$type}}) { | |
64bb7586 NC |
281 | my ($name, $namelen, $value, $macro) |
282 | = $self->name_len_value_macro($item); | |
6d7fb585 | 283 | |
6d7fb585 NC |
284 | my $ifdef = $self->macro_to_ifdef($macro); |
285 | if (!$ifdef && $item->{invert_macro}) { | |
286 | carp("Attempting to supply a default for '$name' which has no conditional macro"); | |
287 | next; | |
288 | } | |
289 | print $xs_fh $ifdef; | |
290 | if ($item->{invert_macro}) { | |
291 | print $xs_fh | |
292 | " /* This is the default value: */\n" if $type; | |
293 | print $xs_fh "#else\n"; | |
294 | } | |
295 | print $xs_fh " { ", join (', ', "\"$name\"", $namelen, | |
296 | &$type_to_value($value)), " },\n", | |
297 | $self->macro_to_endif($macro); | |
298 | } | |
299 | ||
300 | ||
301 | # Terminate the list with a NULL | |
302 | print $xs_fh " { NULL, 0", (", 0" x $number_of_args), " } };\n"; | |
303 | ||
304 | $iterator{$type} = "value_for_" . ($type ? lc $type : 'notfound'); | |
305 | ||
306 | print $xs_fh <<"EOBOOT"; | |
307 | const struct $struct_type *$iterator{$type} = $array_name; | |
308 | ||
309 | EOBOOT | |
310 | } | |
311 | ||
312 | delete $found->{''}; | |
6b43b341 NC |
313 | |
314 | my $add_symbol_subname = $c_subname . '_add_symbol'; | |
6d7fb585 NC |
315 | foreach my $type (sort keys %$found) { |
316 | print $xs_fh $self->boottime_iterator($type, $iterator{$type}, | |
317 | 'symbol_table', | |
6b43b341 | 318 | $add_symbol_subname); |
6d7fb585 | 319 | } |
6b43b341 | 320 | print $xs_fh "\n", $explosives ? "" : <<"EOBOOT"; |
6d7fb585 | 321 | ${c_subname}_missing = newHV(); |
6b43b341 NC |
322 | EOBOOT |
323 | ||
324 | print $xs_fh <<"EOBOOT"; | |
6d7fb585 | 325 | while (value_for_notfound->name) { |
6b43b341 NC |
326 | EOBOOT |
327 | ||
328 | print $xs_fh $explosives ? <<"EXPLODE" : << "DONT"; | |
329 | SV *tripwire = newSV(0); | |
330 | ||
331 | sv_magicext(tripwire, 0, PERL_MAGIC_ext, ¬_defined_vtbl, 0, 0); | |
332 | SvPV_set(tripwire, (char *)value_for_notfound->name); | |
333 | if(value_for_notfound->namelen >= 0) { | |
334 | SvCUR_set(tripwire, value_for_notfound->namelen); | |
335 | } else { | |
336 | SvCUR_set(tripwire, -value_for_notfound->namelen); | |
337 | SvUTF8_on(tripwire); | |
338 | } | |
339 | SvPOKp_on(tripwire); | |
340 | SvREADONLY_on(tripwire); | |
341 | assert(SvLEN(tripwire) == 0); | |
342 | ||
343 | $add_symbol_subname($athx symbol_table, value_for_notfound->name, | |
344 | value_for_notfound->namelen, tripwire); | |
345 | EXPLODE | |
346 | ||
347 | /* Need to add prototypes, else parsing will vary by platform. */ | |
348 | SV **sv = hv_fetch(symbol_table, value_for_notfound->name, | |
349 | value_for_notfound->namelen, TRUE); | |
350 | if (!sv) { | |
fa6eee5a NC |
351 | Perl_croak($athx |
352 | "Couldn't add key '%s' to %%$package_sprintf_safe\::", | |
353 | value_for_notfound->name); | |
6b43b341 NC |
354 | } |
355 | if (!SvOK(*sv) && SvTYPE(*sv) != SVt_PVGV) { | |
356 | /* Nothing was here before, so mark a prototype of "" */ | |
357 | sv_setpvn(*sv, "", 0); | |
358 | } else if (SvPOK(*sv) && SvCUR(*sv) == 0) { | |
359 | /* There is already a prototype of "" - do nothing */ | |
360 | } else { | |
361 | /* Someone has been here before us - have to make a real | |
362 | typeglob. */ | |
363 | /* It turns out to be incredibly hard to deal with all the | |
364 | corner cases of sub foo (); and reporting errors correctly, | |
365 | so lets cheat a bit. Start with a constant subroutine */ | |
366 | CV *cv = newCONSTSUB(symbol_table, value_for_notfound->name, | |
367 | &PL_sv_yes); | |
368 | /* and then turn it into a non constant declaration only. */ | |
369 | CvCONST_off(cv); | |
370 | CvXSUB(cv) = NULL; | |
371 | } | |
372 | ||
6d7fb585 | 373 | if (!hv_store(${c_subname}_missing, value_for_notfound->name, |
0998eade | 374 | value_for_notfound->namelen, &PL_sv_yes, 0)) |
64bb7586 | 375 | Perl_croak($athx "Couldn't add key '%s' to missing_hash", |
6d7fb585 | 376 | value_for_notfound->name); |
6b43b341 NC |
377 | DONT |
378 | ||
379 | print $xs_fh <<"EOBOOT"; | |
380 | ||
6d7fb585 NC |
381 | ++value_for_notfound; |
382 | } | |
6d7fb585 NC |
383 | EOBOOT |
384 | ||
64bb7586 NC |
385 | foreach my $item (@$trouble) { |
386 | my ($name, $namelen, $value, $macro) | |
387 | = $self->name_len_value_macro($item); | |
388 | my $ifdef = $self->macro_to_ifdef($macro); | |
389 | my $type = $item->{type}; | |
390 | my $type_to_value = $self->type_to_C_value($type); | |
391 | ||
392 | print $xs_fh $ifdef; | |
393 | if ($item->{invert_macro}) { | |
394 | print $xs_fh | |
395 | " /* This is the default value: */\n" if $type; | |
396 | print $xs_fh "#else\n"; | |
397 | } | |
398 | my $generator = $type_to_sv{$type}; | |
399 | die "Can't find generator code for type $type" | |
400 | unless defined $generator; | |
401 | ||
6f226cd7 | 402 | print $xs_fh " {\n"; |
6800c0cf NC |
403 | # We need to use a temporary value because some really troublesome |
404 | # items use C pre processor directives in their values, and in turn | |
405 | # these don't fit nicely in the macro-ised generator functions | |
6f226cd7 NC |
406 | my $counter = 0; |
407 | printf $xs_fh " %s temp%d;\n", $_, $counter++ | |
408 | foreach @{$type_temporary{$type}}; | |
409 | ||
410 | print $xs_fh " $item->{pre}\n" if $item->{pre}; | |
411 | ||
412 | # And because the code in pre might be both declarations and | |
413 | # statements, we can't declare and assign to the temporaries in one. | |
414 | $counter = 0; | |
415 | printf $xs_fh " temp%d = %s;\n", $counter++, $_ | |
416 | foreach &$type_to_value($value); | |
417 | ||
418 | my @tempvarnames = map {sprintf 'temp%d', $_} 0 .. $counter - 1; | |
419 | printf $xs_fh <<"EOBOOT", $name, &$generator(@tempvarnames); | |
2ebbb0c3 NC |
420 | ${c_subname}_add_symbol($athx symbol_table, "%s", |
421 | $namelen, %s); | |
64bb7586 | 422 | EOBOOT |
2ebbb0c3 NC |
423 | print $xs_fh " $item->{post}\n" if $item->{post}; |
424 | print $xs_fh " }\n"; | |
64bb7586 NC |
425 | |
426 | print $xs_fh $self->macro_to_endif($macro); | |
427 | } | |
428 | ||
6b43b341 | 429 | print $xs_fh <<EOBOOT; |
e1234d8e NC |
430 | /* As we've been creating subroutines, we better invalidate any cached |
431 | methods */ | |
432 | ++PL_sub_generation; | |
64bb7586 | 433 | } |
6b43b341 NC |
434 | EOBOOT |
435 | ||
436 | print $xs_fh $explosives ? <<"EXPLODE" : <<"DONT"; | |
437 | ||
438 | void | |
439 | $xs_subname(sv) | |
440 | INPUT: | |
441 | SV * sv; | |
442 | PPCODE: | |
fa6eee5a | 443 | sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf |
6b43b341 NC |
444 | ", used", sv); |
445 | PUSHs(sv_2mortal(sv)); | |
446 | EXPLODE | |
6d7fb585 NC |
447 | |
448 | void | |
449 | $xs_subname(sv) | |
450 | PREINIT: | |
451 | STRLEN len; | |
452 | INPUT: | |
453 | SV * sv; | |
454 | const char * s = SvPV(sv, len); | |
455 | PPCODE: | |
456 | if (hv_exists(${c_subname}_missing, s, SvUTF8(sv) ? -len : len)) { | |
fa6eee5a | 457 | sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf |
6d7fb585 NC |
458 | ", used", sv); |
459 | } else { | |
fa6eee5a NC |
460 | sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro", |
461 | sv); | |
6d7fb585 NC |
462 | } |
463 | PUSHs(sv_2mortal(sv)); | |
6b43b341 NC |
464 | DONT |
465 | ||
6d7fb585 NC |
466 | } |
467 | ||
468 | 1; |