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