Commit | Line | Data |
6d7fb585 |
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 |
5 | %type_to_C_value %type_is_a_problem %type_num_args |
6 | %type_temporary); |
6d7fb585 |
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 |
18 | NV => '{const char *name; I32 namelen; NV value;}', |
19 | UV => '{const char *name; I32 namelen; UV value;}', |
20 | YES => '{const char *name; I32 namelen;}', |
21 | NO => '{const char *name; I32 namelen;}', |
6d7fb585 |
22 | '' => '{const char *name; I32 namelen;} ', |
23 | ); |
24 | |
64bb7586 |
25 | %type_from_struct = |
26 | ( |
27 | IV => sub { $_[0] . '->value' }, |
28 | NV => sub { $_[0] . '->value' }, |
29 | UV => sub { $_[0] . '->value' }, |
30 | YES => sub {}, |
31 | NO => sub {}, |
32 | '' => sub {}, |
33 | ); |
34 | |
6d7fb585 |
35 | %type_to_sv = |
36 | ( |
64bb7586 |
37 | IV => sub { "newSViv($_[0])" }, |
38 | NV => sub { "newSVnv($_[0])" }, |
39 | UV => sub { "newSVuv($_[0])" }, |
40 | YES => sub { '&PL_sv_yes' }, |
41 | NO => sub { '&PL_sv_no' }, |
6d7fb585 |
42 | '' => sub { '&PL_sv_yes' }, |
2ebbb0c3 |
43 | SV => sub {"SvREFCNT_inc($_[0])"}, |
6d7fb585 |
44 | ); |
45 | |
46 | %type_to_C_value = |
47 | ( |
64bb7586 |
48 | YES => sub {}, |
49 | NO => sub {}, |
6d7fb585 |
50 | '' => sub {}, |
51 | ); |
52 | |
64bb7586 |
53 | sub type_to_C_value { |
54 | my ($self, $type) = @_; |
55 | return $type_to_C_value{$type} || sub {return map {ref $_ ? @$_ : $_} @_}; |
56 | } |
57 | |
6d7fb585 |
58 | %type_is_a_problem = |
59 | ( |
2ebbb0c3 |
60 | # The documentation says *mortal SV*, but we now need a non-mortal copy. |
6d7fb585 |
61 | SV => 1, |
62 | ); |
63 | |
0998eade |
64 | $type_temporary{SV} = 'SV *'; |
65 | $type_temporary{$_} = $_ foreach qw(IV UV NV); |
6800c0cf |
66 | |
6d7fb585 |
67 | while (my ($type, $value) = each %XS_TypeSet) { |
64bb7586 |
68 | $type_num_args{$type} |
69 | = defined $value ? ref $value ? scalar @$value : 1 : 0; |
6d7fb585 |
70 | } |
71 | $type_num_args{''} = 0; |
72 | |
73 | sub partition_names { |
74 | my ($self, $default_type, @items) = @_; |
75 | my (%found, @notfound, @trouble); |
76 | |
77 | while (my $item = shift @items) { |
78 | my $default = delete $item->{default}; |
79 | if ($default) { |
80 | # If we find a default value, convert it into a regular item and |
81 | # append it to the queue of items to process |
82 | my $default_item = {%$item}; |
83 | $default_item->{invert_macro} = 1; |
84 | $default_item->{pre} = delete $item->{def_pre}; |
85 | $default_item->{post} = delete $item->{def_post}; |
86 | $default_item->{type} = shift @$default; |
87 | $default_item->{value} = $default; |
88 | push @items, $default_item; |
89 | } else { |
90 | # It can be "not found" unless it's the default (invert the macro) |
91 | # or the "macro" is an empty string (ie no macro) |
92 | push @notfound, $item unless $item->{invert_macro} |
93 | or !$self->macro_to_ifdef($self->macro_from_name($item)); |
94 | } |
95 | |
64bb7586 |
96 | if ($item->{pre} or $item->{post} or $item->{not_constant} |
97 | or $type_is_a_problem{$item->{type}}) { |
6d7fb585 |
98 | push @trouble, $item; |
99 | } else { |
100 | push @{$found{$item->{type}}}, $item; |
101 | } |
102 | } |
103 | # use Data::Dumper; print Dumper \%found; |
104 | (\%found, \@notfound, \@trouble); |
105 | } |
106 | |
107 | sub boottime_iterator { |
108 | my ($self, $type, $iterator, $hash, $subname) = @_; |
64bb7586 |
109 | my $extractor = $type_from_struct{$type}; |
110 | die "Can't find extractor code for type $type" |
111 | unless defined $extractor; |
6d7fb585 |
112 | my $generator = $type_to_sv{$type}; |
113 | die "Can't find generator code for type $type" |
114 | unless defined $generator; |
115 | |
116 | my $athx = $self->C_constant_prefix_param(); |
117 | |
64bb7586 |
118 | return sprintf <<"EOBOOT", &$generator(&$extractor($iterator)); |
6d7fb585 |
119 | while ($iterator->name) { |
120 | $subname($athx $hash, $iterator->name, |
121 | $iterator->namelen, %s); |
122 | ++$iterator; |
123 | } |
124 | EOBOOT |
125 | } |
126 | |
64bb7586 |
127 | sub name_len_value_macro { |
128 | my ($self, $item) = @_; |
129 | my $name = $item->{name}; |
130 | my $value = $item->{value}; |
131 | $value = $item->{name} unless defined $value; |
132 | |
133 | my $namelen = length $name; |
134 | if ($name =~ tr/\0-\377// != $namelen) { |
135 | # the hash API signals UTF-8 by passing the length negated. |
136 | utf8::encode($name); |
137 | $namelen = -length $name; |
138 | } |
139 | $name = C_stringify($name); |
140 | |
141 | my $macro = $self->macro_from_name($item); |
142 | ($name, $namelen, $value, $macro); |
143 | } |
144 | |
6d7fb585 |
145 | sub WriteConstants { |
146 | my $self = shift; |
147 | my $ARGS = shift; |
148 | |
149 | my ($c_fh, $xs_fh, $c_subname, $xs_subname, $default_type, $package) |
150 | = @{$ARGS}{qw(c_fh xs_fh c_subname xs_subname default_type package)}; |
151 | |
152 | $xs_subname ||= 'constant'; |
153 | |
154 | croak("Package name '$package' contains % characters") if $package =~ /%/; |
155 | |
156 | # All the types we see |
157 | my $what = {}; |
158 | # A hash to lookup items with. |
159 | my $items = {}; |
160 | |
161 | my @items = $self->normalise_items ({disable_utf8_duplication => 1}, |
162 | $default_type, $what, $items, @_); |
163 | |
164 | # Partition the values by type. Also include any defaults in here |
165 | # Everything that doesn't have a default needs alternative code for |
166 | # "I'm missing" |
167 | # And everything that has pre or post code ends up in a private block |
168 | my ($found, $notfound, $trouble) |
169 | = $self->partition_names($default_type, @items); |
170 | |
6d7fb585 |
171 | my $pthx = $self->C_constant_prefix_param_defintion(); |
172 | my $athx = $self->C_constant_prefix_param(); |
173 | my $symbol_table = C_stringify($package) . '::'; |
174 | |
64bb7586 |
175 | print $c_fh $self->header(), <<"EOADD"; |
6d7fb585 |
176 | void ${c_subname}_add_symbol($pthx HV *hash, const char *name, I32 namelen, SV *value) { |
0998eade |
177 | SV **sv = hv_fetch(hash, name, namelen, TRUE); |
178 | if (!sv) { |
179 | Perl_croak($athx "Couldn't add key '%s' to %%%s::", name, "$package"); |
180 | } |
181 | if (SvOK(*sv) || SvTYPE(*sv) == SVt_PVGV) { |
182 | /* Someone has been here before us - have to make a real sub. */ |
183 | newCONSTSUB(hash, name, value); |
184 | } else { |
185 | SvUPGRADE(*sv, SVt_RV); |
186 | SvRV_set(*sv, value); |
187 | SvROK_on(*sv); |
6d7fb585 |
188 | } |
189 | } |
190 | |
191 | static HV *${c_subname}_missing = NULL; |
192 | |
193 | EOADD |
194 | |
195 | print $xs_fh <<"EOBOOT"; |
196 | BOOT: |
197 | { |
198 | #ifdef dTHX |
199 | dTHX; |
200 | #endif |
201 | HV *symbol_table = get_hv("$symbol_table", TRUE); |
202 | EOBOOT |
203 | |
204 | my %iterator; |
205 | |
206 | $found->{''} |
207 | = [map {{%$_, type=>'', invert_macro => 1}} @$notfound]; |
208 | |
209 | foreach my $type (sort keys %$found) { |
210 | my $struct = $type_to_struct{$type}; |
64bb7586 |
211 | my $type_to_value = $self->type_to_C_value($type); |
6d7fb585 |
212 | my $number_of_args = $type_num_args{$type}; |
213 | die "Can't find structure definition for type $type" |
214 | unless defined $struct; |
215 | |
216 | my $struct_type = $type ? lc($type) . '_s' : 'notfound_s'; |
217 | print $c_fh "struct $struct_type $struct;\n"; |
218 | |
219 | my $array_name = 'values_for_' . ($type ? lc $type : 'notfound'); |
220 | print $xs_fh <<"EOBOOT"; |
221 | |
222 | static const struct $struct_type $array_name\[] = |
223 | { |
224 | EOBOOT |
225 | |
226 | |
227 | foreach my $item (@{$found->{$type}}) { |
64bb7586 |
228 | my ($name, $namelen, $value, $macro) |
229 | = $self->name_len_value_macro($item); |
6d7fb585 |
230 | |
6d7fb585 |
231 | my $ifdef = $self->macro_to_ifdef($macro); |
232 | if (!$ifdef && $item->{invert_macro}) { |
233 | carp("Attempting to supply a default for '$name' which has no conditional macro"); |
234 | next; |
235 | } |
236 | print $xs_fh $ifdef; |
237 | if ($item->{invert_macro}) { |
238 | print $xs_fh |
239 | " /* This is the default value: */\n" if $type; |
240 | print $xs_fh "#else\n"; |
241 | } |
242 | print $xs_fh " { ", join (', ', "\"$name\"", $namelen, |
243 | &$type_to_value($value)), " },\n", |
244 | $self->macro_to_endif($macro); |
245 | } |
246 | |
247 | |
248 | # Terminate the list with a NULL |
249 | print $xs_fh " { NULL, 0", (", 0" x $number_of_args), " } };\n"; |
250 | |
251 | $iterator{$type} = "value_for_" . ($type ? lc $type : 'notfound'); |
252 | |
253 | print $xs_fh <<"EOBOOT"; |
254 | const struct $struct_type *$iterator{$type} = $array_name; |
255 | |
256 | EOBOOT |
257 | } |
258 | |
259 | delete $found->{''}; |
260 | foreach my $type (sort keys %$found) { |
261 | print $xs_fh $self->boottime_iterator($type, $iterator{$type}, |
262 | 'symbol_table', |
263 | "${c_subname}_add_symbol"); |
264 | } |
265 | print $xs_fh <<"EOBOOT"; |
266 | |
267 | ${c_subname}_missing = newHV(); |
268 | while (value_for_notfound->name) { |
269 | if (!hv_store(${c_subname}_missing, value_for_notfound->name, |
0998eade |
270 | value_for_notfound->namelen, &PL_sv_yes, 0)) |
64bb7586 |
271 | Perl_croak($athx "Couldn't add key '%s' to missing_hash", |
6d7fb585 |
272 | value_for_notfound->name); |
273 | ++value_for_notfound; |
274 | } |
6d7fb585 |
275 | EOBOOT |
276 | |
64bb7586 |
277 | foreach my $item (@$trouble) { |
278 | my ($name, $namelen, $value, $macro) |
279 | = $self->name_len_value_macro($item); |
280 | my $ifdef = $self->macro_to_ifdef($macro); |
281 | my $type = $item->{type}; |
282 | my $type_to_value = $self->type_to_C_value($type); |
283 | |
284 | print $xs_fh $ifdef; |
285 | if ($item->{invert_macro}) { |
286 | print $xs_fh |
287 | " /* This is the default value: */\n" if $type; |
288 | print $xs_fh "#else\n"; |
289 | } |
290 | my $generator = $type_to_sv{$type}; |
291 | die "Can't find generator code for type $type" |
292 | unless defined $generator; |
293 | |
6800c0cf |
294 | print $xs_fh <<"EOBOOT"; |
295 | { |
296 | $type_temporary{$type} temp; |
297 | EOBOOT |
2ebbb0c3 |
298 | print $xs_fh " $item->{pre}\n" if $item->{pre}; |
6800c0cf |
299 | # We need to use a temporary value because some really troublesome |
300 | # items use C pre processor directives in their values, and in turn |
301 | # these don't fit nicely in the macro-ised generator functions |
302 | printf $xs_fh <<"EOBOOT", &$type_to_value($value), $name, &$generator('temp'); |
303 | temp = %s; |
2ebbb0c3 |
304 | ${c_subname}_add_symbol($athx symbol_table, "%s", |
305 | $namelen, %s); |
64bb7586 |
306 | EOBOOT |
2ebbb0c3 |
307 | print $xs_fh " $item->{post}\n" if $item->{post}; |
308 | print $xs_fh " }\n"; |
64bb7586 |
309 | |
310 | print $xs_fh $self->macro_to_endif($macro); |
311 | } |
312 | |
313 | print $xs_fh <<EOCONSTANT |
314 | } |
6d7fb585 |
315 | |
316 | void |
317 | $xs_subname(sv) |
318 | PREINIT: |
319 | STRLEN len; |
320 | INPUT: |
321 | SV * sv; |
322 | const char * s = SvPV(sv, len); |
323 | PPCODE: |
324 | if (hv_exists(${c_subname}_missing, s, SvUTF8(sv) ? -len : len)) { |
325 | sv = newSVpvf("Your vendor has not defined $package macro %" SVf |
326 | ", used", sv); |
327 | } else { |
328 | sv = newSVpvf("%" SVf " is not a valid $package macro", sv); |
329 | } |
330 | PUSHs(sv_2mortal(sv)); |
331 | EOCONSTANT |
332 | } |
333 | |
334 | 1; |