This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
af8c458b6348468b8af6645d98294215460a63e7
[perl5.git] / lib / ExtUtils / Constant / ProxySubs.pm
1 package ExtUtils::Constant::ProxySubs;
2
3 use strict;
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
6             %type_temporary);
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.05';
13 @ISA = 'ExtUtils::Constant::XS';
14
15 %type_to_struct =
16     (
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;} ',
26      );
27
28 %type_from_struct =
29     (
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' },
35      YES => sub {},
36      NO => sub {},
37      UNDEF => sub {},
38      '' => sub {},
39     );
40
41 %type_to_sv = 
42     (
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])"},
53      );
54
55 %type_to_C_value = 
56     (
57      YES => sub {},
58      NO => sub {},
59      UNDEF => sub {},
60      '' => sub {},
61      );
62
63 sub type_to_C_value {
64     my ($self, $type) = @_;
65     return $type_to_C_value{$type} || sub {return map {ref $_ ? @$_ : $_} @_};
66 }
67
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
71 %type_is_a_problem =
72     (
73      # The documentation says *mortal SV*, but we now need a non-mortal copy.
74      SV => 1,
75      );
76
77 %type_temporary =
78     (
79      SV => ['SV *'],
80      PV => ['const char *'],
81      PVN => ['const char *', 'STRLEN'],
82      );
83 $type_temporary{$_} = [$_] foreach qw(IV UV NV);
84      
85 while (my ($type, $value) = each %XS_TypeSet) {
86     $type_num_args{$type}
87         = defined $value ? ref $value ? scalar @$value : 1 : 0;
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}
111                 or !$self->macro_to_ifdef($self->macro_from_item($item));
112         }
113
114         if ($item->{pre} or $item->{post} or $item->{not_constant}
115             or $type_is_a_problem{$item->{type}}) {
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) = @_;
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;
133
134     my $athx = $self->C_constant_prefix_param();
135
136     return sprintf <<"EOBOOT", &$generator(&$extractor($iterator));
137         while ($iterator->name) {
138             $subname($athx $hash, $iterator->name,
139                                 $iterator->namelen, %s);
140             ++$iterator;
141         }
142 EOBOOT
143 }
144
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
159     my $macro = $self->macro_from_item($item);
160     ($name, $namelen, $value, $macro);
161 }
162
163 sub WriteConstants {
164     my $self = shift;
165     my $ARGS = {@_};
166
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)};
169
170     my $options = $ARGS->{PROXYSUBS};
171     $options = {} unless ref $options;
172     my $explosives = $options->{croak_on_read};
173
174     $xs_subname ||= 'constant';
175
176     # If anyone is insane enough to suggest a package name containing %
177     my $package_sprintf_safe = $package;
178     $package_sprintf_safe =~ s/%/%%/g;
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},
186                                         $default_type, $what, $items,
187                                         @{$ARGS->{NAMES}});
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
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
200     print $c_fh $self->header(), <<"EOADD";
201 static void
202 ${c_subname}_add_symbol($pthx HV *hash, const char *name, I32 namelen, SV *value) {
203     SV **sv = hv_fetch(hash, name, namelen, TRUE);
204     if (!sv) {
205         Perl_croak($athx "Couldn't add key '%s' to %%$package_sprintf_safe\::",
206                    name);
207     }
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);
211     } else {
212         SvUPGRADE(*sv, SVt_RV);
213         SvRV_set(*sv, value);
214         SvROK_on(*sv);
215         SvREADONLY_on(value);
216     }
217 }
218
219 EOADD
220
221     print $c_fh $explosives ? <<"EXPLODE" : "\n";
222
223 static int
224 Im_sorry_Dave(pTHX_ SV *sv, MAGIC *mg)
225 {
226     PERL_UNUSED_ARG(mg);
227     Perl_croak(aTHX_
228                "Your vendor has not defined $package_sprintf_safe macro %"SVf
229                " used", sv);
230     NORETURN_FUNCTION_END;
231 }
232
233 static MGVTBL not_defined_vtbl = {
234  Im_sorry_Dave, /* get - I'm afraid I can't do that */
235  Im_sorry_Dave, /* set */
236  0, /* len */
237  0, /* clear */
238  0, /* free */
239  0, /* copy */
240  0, /* dup */
241 };
242
243 EXPLODE
244
245 {
246     my $key = $symbol_table;
247     # Just seems tidier (and slightly more space efficient) not to have keys
248     # such as Fcntl::
249     $key =~ s/::$//;
250     my $key_len = length $key;
251
252     print $c_fh <<"MISSING";
253
254 #ifndef SYMBIAN
255
256 /* Store a hash of all symbols missing from the package. To avoid trampling on
257    the package namespace (uninvited) put each package's hash in our namespace.
258    To avoid creating lots of typeblogs and symbol tables for sub-packages, put
259    each package's hash into one hash in our namespace.  */
260
261 static HV *
262 get_missing_hash(pTHX) {
263     HV *const parent
264         = get_hv("ExtUtils::Constant::ProxySubs::Missing", GVf_MULTI);
265     /* We could make a hash of hashes directly, but this would confuse anything
266         at Perl space that looks at us, and as we're visible in Perl space,
267         best to play nice. */
268     SV *const *const ref
269         = hv_fetch(parent, "$key", $key_len, TRUE);
270     HV *new_hv;
271
272     if (!ref)
273         return NULL;
274
275     if (SvROK(*ref))
276         return (HV*) SvRV(*ref);
277
278     new_hv = newHV();
279     SvUPGRADE(*ref, SVt_RV);
280     SvRV_set(*ref, (SV *)new_hv);
281     SvROK_on(*ref);
282     return new_hv;
283 }
284
285 #endif
286
287 MISSING
288
289 }
290
291     print $xs_fh <<"EOBOOT";
292 BOOT:
293   {
294 #ifdef dTHX
295     dTHX;
296 #endif
297     HV *symbol_table = get_hv("$symbol_table", TRUE);
298 #ifndef SYMBIAN
299     HV *${c_subname}_missing;
300 #endif
301 EOBOOT
302
303     my %iterator;
304
305     $found->{''}
306         = [map {{%$_, type=>'', invert_macro => 1}} @$notfound];
307
308     foreach my $type (sort keys %$found) {
309         my $struct = $type_to_struct{$type};
310         my $type_to_value = $self->type_to_C_value($type);
311         my $number_of_args = $type_num_args{$type};
312         die "Can't find structure definition for type $type"
313             unless defined $struct;
314
315         my $struct_type = $type ? lc($type) . '_s' : 'notfound_s';
316         print $c_fh "struct $struct_type $struct;\n";
317
318         my $array_name = 'values_for_' . ($type ? lc $type : 'notfound');
319         print $xs_fh <<"EOBOOT";
320
321     static const struct $struct_type $array_name\[] =
322       {
323 EOBOOT
324
325
326         foreach my $item (@{$found->{$type}}) {
327             my ($name, $namelen, $value, $macro)
328                  = $self->name_len_value_macro($item);
329
330             my $ifdef = $self->macro_to_ifdef($macro);
331             if (!$ifdef && $item->{invert_macro}) {
332                 carp("Attempting to supply a default for '$name' which has no conditional macro");
333                 next;
334             }
335             print $xs_fh $ifdef;
336             if ($item->{invert_macro}) {
337                 print $xs_fh
338                     "        /* This is the default value: */\n" if $type;
339                 print $xs_fh "#else\n";
340             }
341             print $xs_fh "        { ", join (', ', "\"$name\"", $namelen,
342                                              &$type_to_value($value)), " },\n",
343                                                  $self->macro_to_endif($macro);
344         }
345
346
347     # Terminate the list with a NULL
348         print $xs_fh "        { NULL, 0", (", 0" x $number_of_args), " } };\n";
349
350         $iterator{$type} = "value_for_" . ($type ? lc $type : 'notfound');
351
352         print $xs_fh <<"EOBOOT";
353         const struct $struct_type *$iterator{$type} = $array_name;
354 EOBOOT
355     }
356
357     delete $found->{''};
358
359     print $xs_fh <<"EOBOOT";
360 #ifndef SYMBIAN
361         ${c_subname}_missing = get_missing_hash(aTHX);
362 #endif
363 EOBOOT
364
365     my $add_symbol_subname = $c_subname . '_add_symbol';
366     foreach my $type (sort keys %$found) {
367         print $xs_fh $self->boottime_iterator($type, $iterator{$type}, 
368                                               'symbol_table',
369                                               $add_symbol_subname);
370     }
371
372     print $xs_fh <<"EOBOOT";
373         while (value_for_notfound->name) {
374 EOBOOT
375
376     print $xs_fh $explosives ? <<"EXPLODE" : << "DONT";
377             SV *tripwire = newSV(0);
378             
379             sv_magicext(tripwire, 0, PERL_MAGIC_ext, &not_defined_vtbl, 0, 0);
380             SvPV_set(tripwire, (char *)value_for_notfound->name);
381             if(value_for_notfound->namelen >= 0) {
382                 SvCUR_set(tripwire, value_for_notfound->namelen);
383             } else {
384                 SvCUR_set(tripwire, -value_for_notfound->namelen);
385                 SvUTF8_on(tripwire);
386             }
387             SvPOKp_on(tripwire);
388             SvREADONLY_on(tripwire);
389             assert(SvLEN(tripwire) == 0);
390
391             $add_symbol_subname($athx symbol_table, value_for_notfound->name,
392                                 value_for_notfound->namelen, tripwire);
393 EXPLODE
394
395             /* Need to add prototypes, else parsing will vary by platform.  */
396             SV **sv = hv_fetch(symbol_table, value_for_notfound->name,
397                                value_for_notfound->namelen, TRUE);
398             if (!sv) {
399                 Perl_croak($athx
400                            "Couldn't add key '%s' to %%$package_sprintf_safe\::",
401                            value_for_notfound->name);
402             }
403             if (!SvOK(*sv) && SvTYPE(*sv) != SVt_PVGV) {
404                 /* Nothing was here before, so mark a prototype of ""  */
405                 sv_setpvn(*sv, "", 0);
406             } else if (SvPOK(*sv) && SvCUR(*sv) == 0) {
407                 /* There is already a prototype of "" - do nothing  */
408             } else {
409                 /* Someone has been here before us - have to make a real
410                    typeglob.  */
411                 /* It turns out to be incredibly hard to deal with all the
412                    corner cases of sub foo (); and reporting errors correctly,
413                    so lets cheat a bit.  Start with a constant subroutine  */
414                 CV *cv = newCONSTSUB(symbol_table, value_for_notfound->name,
415                                      &PL_sv_yes);
416                 /* and then turn it into a non constant declaration only.  */
417                 SvREFCNT_dec(CvXSUBANY(cv).any_ptr);
418                 CvCONST_off(cv);
419                 CvXSUB(cv) = NULL;
420                 CvXSUBANY(cv).any_ptr = NULL;
421             }
422 #ifndef SYMBIAN
423             if (!hv_store(${c_subname}_missing, value_for_notfound->name,
424                           value_for_notfound->namelen, &PL_sv_yes, 0))
425                 Perl_croak($athx "Couldn't add key '%s' to missing_hash",
426                            value_for_notfound->name);
427 #endif
428 DONT
429
430     print $xs_fh <<"EOBOOT";
431
432             ++value_for_notfound;
433         }
434 EOBOOT
435
436     foreach my $item (@$trouble) {
437         my ($name, $namelen, $value, $macro)
438             = $self->name_len_value_macro($item);
439         my $ifdef = $self->macro_to_ifdef($macro);
440         my $type = $item->{type};
441         my $type_to_value = $self->type_to_C_value($type);
442
443         print $xs_fh $ifdef;
444         if ($item->{invert_macro}) {
445             print $xs_fh
446                  "        /* This is the default value: */\n" if $type;
447             print $xs_fh "#else\n";
448         }
449         my $generator = $type_to_sv{$type};
450         die "Can't find generator code for type $type"
451             unless defined $generator;
452
453         print $xs_fh "        {\n";
454         # We need to use a temporary value because some really troublesome
455         # items use C pre processor directives in their values, and in turn
456         # these don't fit nicely in the macro-ised generator functions
457         my $counter = 0;
458         printf $xs_fh "            %s temp%d;\n", $_, $counter++
459             foreach @{$type_temporary{$type}};
460
461         print $xs_fh "            $item->{pre}\n" if $item->{pre};
462
463         # And because the code in pre might be both declarations and
464         # statements, we can't declare and assign to the temporaries in one.
465         $counter = 0;
466         printf $xs_fh "            temp%d = %s;\n", $counter++, $_
467             foreach &$type_to_value($value);
468
469         my @tempvarnames = map {sprintf 'temp%d', $_} 0 .. $counter - 1;
470         printf $xs_fh <<"EOBOOT", $name, &$generator(@tempvarnames);
471             ${c_subname}_add_symbol($athx symbol_table, "%s",
472                                     $namelen, %s);
473 EOBOOT
474         print $xs_fh "        $item->{post}\n" if $item->{post};
475         print $xs_fh "        }\n";
476
477         print $xs_fh $self->macro_to_endif($macro);
478     }
479
480     print $xs_fh <<EOBOOT;
481     /* As we've been creating subroutines, we better invalidate any cached
482        methods  */
483     ++PL_sub_generation;
484   }
485 EOBOOT
486
487     print $xs_fh $explosives ? <<"EXPLODE" : <<"DONT";
488
489 void
490 $xs_subname(sv)
491     INPUT:
492         SV *            sv;
493     PPCODE:
494         sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf
495                           ", used", sv);
496         PUSHs(sv_2mortal(sv));
497 EXPLODE
498
499 void
500 $xs_subname(sv)
501     PREINIT:
502         STRLEN          len;
503     INPUT:
504         SV *            sv;
505         const char *    s = SvPV(sv, len);
506     PPCODE:
507 #ifdef SYMBIAN
508         sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro", sv);
509 #else
510         HV *${c_subname}_missing = get_missing_hash(aTHX);
511         if (hv_exists(${c_subname}_missing, s, SvUTF8(sv) ? -(I32)len : (I32)len)) {
512             sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf
513                           ", used", sv);
514         } else {
515             sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro",
516                           sv);
517         }
518 #endif
519         PUSHs(sv_2mortal(sv));
520 DONT
521
522 }
523
524 1;