xref: /openbsd/gnu/usr.bin/perl/regen/mg_vtable.pl (revision 3bef86f7) 
1#!/usr/bin/perl -w
2#
3# Regenerate (overwriting only if changed):
4#
5#    mg_names.inc
6#    mg_raw.h
7#    mg_vtable.h
8#    pod/perlguts.pod
9#
10# from information stored in this file.  pod/perlguts.pod is not completely
11# regenerated.  Only the magic table is replaced; the other parts remain
12# untouched.
13#
14# Accepts the standard regen_lib -q and -v args.
15#
16# This script is normally invoked from regen.pl.
17#
18# Its output files contain:
19#
20# mg_names.inc
21#    included by dump.c - the textual representation for each magic type.
22#    Contains a list of
23#
24#         { PERL_MAGIC_foo, "foo(f)" }
25#
26#    pairs.
27#
28#
29# mg_raw.h
30#    processed by generate_uudmap.c into mg_data.h which eventually
31#    populates PL_magic_vtables[].
32#
33#    Contains a list of:
34#
35#         { 'f', "want_vtbl_foo | FLAGS", "description for comments" }
36#
37#    triplets. FLAGS can be:
38#         PERL_MAGIC_READONLY_ACCEPTABLE
39#               ok set this type of magic on an SvREADONLY() SV
40#         PERL_MAGIC_VALUE_MAGIC
41#               this is value magic (pos, taint etc)
42#               rather than container magic (%ENV, $1 etc)
43#
44#
45# mg_vtable.h
46#     This contains five kinds of entries:
47#
48#     #define PERL_MAGIC_arylen         '#'
49#     ....
50#
51#     enum { /* pass one of these to get_vtbl */
52#          want_vtbl_arylen,
53#          ...
54#     }
55#
56#     PL_magic_vtable_names[] = {
57#         "arylen",
58#         ...
59#     }
60#
61#     PL_magic_vtables[] = {
62#         /* per-magic sets of vtable function pointers */
63#         { get, set, len, clear, free, copy, dup, local },
64#     }
65#
66#     define PL_vtbl_arylen PL_magic_vtables[want_vtbl_arylen]
67#     ....
68#
69#
70#
71# pod/perlguts.pod
72#     updates the list of magic types between
73#     =for mg_vtable.pl begin
74#     ...
75#     =for mg_vtable.pl end
76
77
78use strict;
79require 5.004;
80
81BEGIN {
82    # Get function prototypes
83    require './regen/regen_lib.pl';
84}
85
86# =====================================================================
87#
88# START OF CONFIGURATION DATA
89
90
91# %mg
92#
93# This hash is mainly concerned with populating all the other stuff
94# ancillary to the vtable.
95#
96# The key is the name, e.g. 'regdata' for PERL_MAGIC_regdata
97#
98# The keys of the value hash are:
99#    char
100#       the magic's char identifier
101#
102#    desc
103#       a description which appears in code comments in generated files
104#
105#    readonly_acceptable
106#       If true, set PERL_MAGIC_READONLY_ACCEPTABLE flag;
107#       SvREADONLY() svs are allowed to have this magic added to them
108#
109#    unknown_to_sv_magic
110#       if true, this isn't one of the standard magic types which
111#       Perl_sv_magic() knows how to deal with
112#
113#    value_magic
114#       If true, set PERL_MAGIC_VALUE_MAGIC flag;
115#       this kind of magic is value (pos, taint etc) rather than
116#       container magic (%ENV, $1 etc)
117#
118#    vtable
119#        name of the vtable lookup enum, e.g. 'foo' creates want_vtbl_foo
120
121my %mg =
122    (
123     sv => { char => "\0", vtable => 'sv', readonly_acceptable => 1,
124             desc => 'Special scalar variable' },
125     # overload, or type "A" magic, used to be here.  Hence overloaded is
126     # often called AMAGIC internally, even though it does not use "A"
127     # magic any more.
128     overload_table => { char => 'c', vtable => 'ovrld',
129                         desc => 'Holds overload table (AMT) on stash' },
130     bm => { char => 'B', vtable => 'regexp', value_magic => 1,
131             readonly_acceptable => 1,
132             desc => 'Boyer-Moore (fast string search)' },
133     regdata => { char => 'D', vtable => 'regdata',
134                  desc => "Regex match position data\n(\@+ and \@- vars)" },
135     regdatum => { char => 'd', vtable => 'regdatum',
136                   desc => 'Regex match position data element' },
137     env => { char => 'E', vtable => 'env', desc => '%ENV hash' },
138     envelem => { char => 'e', vtable => 'envelem',
139                  desc => '%ENV hash element' },
140     fm => { char => 'f', vtable => 'regexp', value_magic => 1,
141             readonly_acceptable => 1, desc => "Formline ('compiled' format)" },
142     regex_global => { char => 'g', vtable => 'mglob', value_magic => 1,
143                       readonly_acceptable => 1, desc => 'm//g target' },
144     hints => { char => 'H', vtable => 'hints', desc => '%^H hash' },
145     hintselem => { char => 'h', vtable => 'hintselem',
146                    desc => '%^H hash element' },
147     isa => { char => 'I', vtable => 'isa', desc => '@ISA array' },
148     isaelem => { char => 'i', vtable => 'isaelem',
149                  desc => '@ISA array element' },
150     nkeys => { char => 'k', vtable => 'nkeys', value_magic => 1,
151                desc => 'scalar(keys()) lvalue' },
152     dbfile => { char => 'L',
153                 desc => 'Debugger %_<filename' },
154     dbline => { char => 'l', vtable => 'dbline',
155                 desc => 'Debugger %_<filename element' },
156     shared => { char => 'N', desc => 'Shared between threads',
157                 unknown_to_sv_magic => 1 },
158     shared_scalar => { char => 'n', desc => 'Shared between threads',
159                        unknown_to_sv_magic => 1 },
160     collxfrm => { char => 'o', vtable => 'collxfrm', value_magic => 1,
161                   desc => 'Locale transformation' },
162     tied => { char => 'P', vtable => 'pack',
163               value_magic => 1, # treat as value, so 'local @tied' isn't tied
164               desc => 'Tied array or hash' },
165     tiedelem => { char => 'p', vtable => 'packelem',
166                   desc => 'Tied array or hash element' },
167     tiedscalar => { char => 'q', vtable => 'packelem',
168                     desc => 'Tied scalar or handle' },
169     qr => { char => 'r', vtable => 'regexp', value_magic => 1,
170             readonly_acceptable => 1, desc => 'Precompiled qr// regex' },
171     sig => { char => 'S', vtable => 'sig',
172		      desc => '%SIG hash' },
173     sigelem => { char => 's', vtable => 'sigelem',
174                  desc => '%SIG hash element' },
175     taint => { char => 't', vtable => 'taint', value_magic => 1,
176                desc => 'Taintedness' },
177     uvar => { char => 'U', vtable => 'uvar',
178               desc => 'Available for use by extensions' },
179     uvar_elem => { char => 'u', desc => 'Reserved for use by extensions',
180                    unknown_to_sv_magic => 1 },
181     vec => { char => 'v', vtable => 'vec', value_magic => 1,
182              desc => 'vec() lvalue' },
183     vstring => { char => 'V', value_magic => 1,
184                  desc => 'SV was vstring literal' },
185     utf8 => { char => 'w', vtable => 'utf8', value_magic => 1,
186               desc => 'Cached UTF-8 information' },
187     substr => { char => 'x', vtable => 'substr',  value_magic => 1,
188                 desc => 'substr() lvalue' },
189     defelem => { char => 'y', vtable => 'defelem', value_magic => 1,
190                  desc => "Shadow \"foreach\" iterator variable /\nsmart parameter vivification" },
191     nonelem => { char => 'Y', vtable => 'nonelem', value_magic => 1,
192                  desc => "Array element that does not exist" },
193     arylen => { char => '#', vtable => 'arylen', value_magic => 1,
194                 desc => 'Array length ($#ary)' },
195     pos => { char => '.', vtable => 'pos', value_magic => 1,
196              desc => 'pos() lvalue' },
197     backref => { char => '<', vtable => 'backref', value_magic => 1,
198                  readonly_acceptable => 1, desc => 'For weak ref data' },
199     symtab => { char => ':', value_magic => 1,
200                 desc => 'Extra data for symbol tables' },
201     rhash => { char => '%', value_magic => 1,
202                desc => 'Extra data for restricted hashes' },
203     arylen_p => { char => '@', value_magic => 1,
204                   desc => 'To move arylen out of XPVAV' },
205     ext => { char => '~', desc => 'Available for use by extensions',
206              readonly_acceptable => 1 },
207     checkcall => { char => ']', value_magic => 1, vtable => 'checkcall',
208                    desc => 'Inlining/mutation of call to this CV'},
209     debugvar => { char => '*', desc => '$DB::single, signal, trace vars',
210                   vtable => 'debugvar' },
211     lvref => { char => '\\', vtable => 'lvref',
212                  desc => "Lvalue reference constructor" },
213);
214
215
216# %sig
217#
218# This hash is mainly concerned with populating the vtable.
219# (despite the name it has nothing to do with signals!)
220#
221# These have a subtly different "namespace" from the magic types.
222#
223# The key is the name, e.g. 'regdata' for PERL_MAGIC_regdata
224# The keys of the value hash are:
225#
226#    alias
227#       for each entry in the anon array, add
228#       add "#define want_vtbl_$_ want_vtbl_$name"
229#
230#    cond
231#       prefix the vtable with the specified entry (e.g. '#ifdef FOO')
232#       and suffix it with '#else { 0, 0, 0, 0, 0, 0, 0, 0 } #endif'
233#
234#    const
235#       special-case cast a 'get' function whose signature expects
236#       a pointer to constant magic, so that it can be added to a vtable
237#       which expects pointers to functions without the 'const'.
238#
239#    get
240#    set
241#    len
242#    clear
243#    free
244#    copy
245#    dup
246#    local
247#       For each specified method, add a vtable function pointer
248#       of the form "Perl_magic_$sig{foo}{get}" etc
249
250my %sig =
251    (
252     'sv' => {get => 'get', set => 'set'},
253     'env' => {set => 'set_all_env', clear => 'clear_all_env'},
254     'envelem' => {set => 'setenv', clear => 'clearenv'},
255     'sig' => { set => 'setsigall' },
256     'sigelem' => {get => 'getsig', set => 'setsig', clear => 'clearsig',
257                   cond => '#ifndef PERL_MICRO'},
258     'pack' => {len => 'sizepack', clear => 'wipepack'},
259     'packelem' => {get => 'getpack', set => 'setpack', clear => 'clearpack'},
260     'dbline' => {set => 'setdbline'},
261     'isa' => {set => 'setisa', clear => 'clearisa'},
262     'isaelem' => {set => 'setisa'},
263     'arylen' => {get => 'getarylen', set => 'setarylen', const => 1},
264     'arylen_p' => {clear => 'cleararylen_p', free => 'freearylen_p'},
265     'mglob'    => {set   => 'setmglob',
266                    free  => 'freemglob' },
267     'nkeys' => {get => 'getnkeys', set => 'setnkeys'},
268     'taint' => {get => 'gettaint', set => 'settaint'},
269     'substr' => {get => 'getsubstr', set => 'setsubstr'},
270     'vec' => {get => 'getvec', set => 'setvec'},
271     'pos' => {get => 'getpos', set => 'setpos'},
272     'uvar' => {get => 'getuvar', set => 'setuvar'},
273     'defelem' => {get => 'getdefelem', set => 'setdefelem'},
274     'nonelem' => {set => 'setnonelem'},
275     'regexp' => {set => 'setregexp', alias => [qw(bm fm)]},
276     'regdata' => {len => 'regdata_cnt'},
277     'regdatum' => {get => 'regdatum_get', set => 'regdatum_set'},
278     'backref' => {free => 'killbackrefs'},
279     'ovrld' => {free => 'freeovrld'},
280     'utf8'     => {set   => 'setutf8',
281                    free  => 'freeutf8' },
282     'collxfrm' => {set => 'setcollxfrm',
283                    free => 'freecollxfrm',
284                    cond => '#ifdef USE_LOCALE_COLLATE'},
285     'hintselem' => {set => 'sethint', clear => 'clearhint'},
286     'hints' => {clear => 'clearhints'},
287     'checkcall' => {copy => 'copycallchecker'},
288     'debugvar' => { set => 'setdebugvar', get => 'getdebugvar' },
289     'lvref' => {set => 'setlvref'},
290);
291
292
293# END OF CONFIGURATION DATA
294#
295# =====================================================================
296
297
298
299my ($vt, $raw, $names) = map {
300    open_new($_, '>',
301             { by => 'regen/mg_vtable.pl', file => $_, style => '*' });
302} 'mg_vtable.h', 'mg_raw.h', 'mg_names.inc';
303my $guts = open_new("pod/perlguts.pod", ">");
304
305print $vt <<'EOH';
306/* These constants should be used in preference to raw characters
307 * when using magic. Note that some perl guts still assume
308 * certain character properties of these constants, namely that
309 * isUPPER() and toLOWER() may do useful mappings.
310 */
311
312EOH
313
314# Of course, it would be *much* easier if we could output this table directly
315# here and now. However, for our sins, we try to support EBCDIC, which wouldn't
316# be *so* bad, except that there are (at least) 3 EBCDIC charset variants, and
317# they don't agree on the code point for '~'. Which we use. Great.
318# So we have to get the local build runtime to sort our table in character order
319# (And of course, just to be helpful, in POSIX BC '~' is \xFF, so we can't even
320# simplify the C code by assuming that the last element of the array is
321# predictable)
322
323# Process %mg
324
325{
326    my $longest = 0;
327    foreach (keys %mg) {
328        $longest = length $_ if length $_ > $longest;
329    }
330
331    my $longest_p1 = $longest + 1;
332
333    my %mg_order;
334    while (my ($name, $data) = each %mg) {
335        my $byte = $data->{char};
336        if ($byte =~ /[[:print:]]/) {
337            $data->{r_char} = $byte; # readable char
338            ($data->{c_char} = $byte) =~ s/([\\"])/\\$1/g; # for C strings
339        }
340        else {
341            $data->{c_char} = $data->{r_char} = '\\'.ord $byte;
342        }
343        $mg_order{(uc $byte) . $byte} = $name;
344    }
345
346    my @rows;
347    my @names;
348    foreach (sort keys %mg_order) {
349        my $name = $mg_order{$_};
350        push @names, $name;
351        my $data = $mg{$name};
352        my $i = ord $data->{char};
353
354        # add entry to mg_raw.h
355
356        unless ($data->{unknown_to_sv_magic}) {
357            my $value = $data->{vtable}
358                ? "want_vtbl_$data->{vtable}" : 'magic_vtable_max';
359            $value .= ' | PERL_MAGIC_READONLY_ACCEPTABLE'
360                if $data->{readonly_acceptable};
361            $value .= ' | PERL_MAGIC_VALUE_MAGIC' if $data->{value_magic};
362            my $comment = "/* $name '$data->{r_char}' $data->{desc} */";
363            $comment =~ s/([\\"])/\\$1/g;
364            $comment =~ tr/\n/ /;
365            print $raw qq{    { '$data->{c_char}', "$value",\n      "$comment" },\n};
366        }
367
368        # add #define PERL_MAGIC_foo entry to vt_table.h
369
370        my $comment = $data->{desc};
371        my $leader = ' ' x ($longest + 27);
372        $comment =~ s/\n/\n$leader/s;
373        printf $vt "#define PERL_MAGIC_%-${longest}s '%s' /* %s */\n",
374            $name, $data->{c_char}, $comment;
375
376        # add entry to mg_names.inc
377
378        my $char = $data->{r_char};
379        $char =~ s/([\\"])/\\$1/g;
380        printf $names qq[\t{ PERL_MAGIC_%-${longest_p1}s "%s(%s)" },\n],
381            "$name,", $name, $char;
382
383        # construct perlguts.pod entry
384
385        push @rows, [(sprintf "%-2s PERL_MAGIC_%s", $data->{r_char},$name),
386                     $data->{vtable} ? "vtbl_$data->{vtable}" : '(none)',
387                     $data->{desc}];
388    }
389
390    # output @rows to perlguts.pod
391
392    select +(select($guts), do {
393        my @header = ('(old-style char and macro)', 'MGVTBL', 'Type of magic');
394        my @widths = (0, 0);
395        foreach my $row (@rows) {
396            for (0, 1) {
397                $widths[$_] = length $row->[$_]
398                    if length $row->[$_] > $widths[$_];
399            }
400        }
401        my $indent = ' ';
402        my $format
403            = sprintf "$indent%%-%ds%%-%ds%%s\n", $widths[0] + 1, $widths[1] + 1;
404        my $desc_wrap =
405            79 - 7 - (length $indent) - $widths[0] - $widths[1] - 2;
406
407        open my $oldguts, "<", "pod/perlguts.pod"
408           or die "$0 cannot open pod/perlguts.pod for reading: $!";
409        while (<$oldguts>) {
410            print;
411            last if /^=for mg_vtable.pl begin/
412        }
413
414        print "\n", $indent . "mg_type\n";
415        printf $format, @header;
416        printf $format, map {'-' x length $_} @header;
417        foreach (@rows) {
418            my ($type, $vtbl, $desc) = @$_;
419            $desc =~ tr/\n/ /;
420            my @cont;
421            if (length $desc > $desc_wrap) {
422                # If it's too long, first split on '(', if there.
423                # [Which, if there, is always short enough, currently.
424                # Make this more robust if that changes]
425                ($desc, @cont) = split /(?=\()/, $desc;
426                if (!@cont) {
427                    ($desc, @cont) = $desc =~ /(.{1,$desc_wrap})(?: |\z)/g
428                }
429            }
430            printf $format, $type, $vtbl, $desc;
431            printf $format, '', '', $_ foreach @cont;
432        }
433        print "\n\n";
434
435        my $first = 1;
436        for my $magic (sort @names) {
437            if ($first) {
438                $first = 0;
439                print "=for apidoc_section \$magic\n";
440                print "=for apidoc AmnhU||PERL_MAGIC_$magic\n";
441            }
442            else {
443                print "=for apidoc_item ||PERL_MAGIC_$magic\n";
444            }
445        }
446        print "\n";
447
448        while (<$oldguts>) {
449            last if /^=for mg_vtable.pl end/;
450        }
451        do { print } while <$oldguts>;
452    })[0];
453}
454
455
456# Process %sig - everything goes to mg_vtable.h
457
458my @names = sort keys %sig;
459{
460    my $want = join ",\n    ", (map {"want_vtbl_$_"} @names), 'magic_vtable_max';
461    my $names = join qq{",\n    "}, @names;
462
463    print $vt <<"EOH";
464
465enum {		/* pass one of these to get_vtbl */
466    $want
467};
468
469#ifdef DOINIT
470EXTCONST char * const PL_magic_vtable_names[magic_vtable_max] = {
471    "$names"
472};
473#else
474EXTCONST char * const PL_magic_vtable_names[magic_vtable_max];
475#endif
476
477EOH
478}
479
480print $vt <<'EOH';
481/* These all need to be 0, not NULL, as NULL can be (void*)0, which is a
482 * pointer to data, whereas we're assigning pointers to functions, which are
483 * not the same beast. ANSI doesn't allow the assignment from one to the other.
484 * (although most, but not all, compilers are prepared to do it)
485 */
486
487/* order is:
488    get
489    set
490    len
491    clear
492    free
493    copy
494    dup
495    local
496*/
497
498#ifdef DOINIT
499EXT_MGVTBL PL_magic_vtables[magic_vtable_max] = {
500EOH
501
502my @vtable_names;
503my @aliases;
504
505while (my $name = shift @names) {
506    my $data = $sig{$name};
507    push @vtable_names, $name;
508    my @funcs = map {
509        $data->{$_} ? "Perl_magic_$data->{$_}" : 0;
510    } qw(get set len clear free copy dup local);
511
512    $funcs[0] = "(int (*)(pTHX_ SV *, MAGIC *))" . $funcs[0] if $data->{const};
513    my $funcs = join ", ", @funcs;
514
515    # Because we can't have a , after the last {...}
516    my $comma = @names ? ',' : '';
517
518    print $vt "$data->{cond}\n" if $data->{cond};
519    print $vt "  { $funcs }$comma\n";
520    print $vt <<"EOH" if $data->{cond};
521#else
522  { 0, 0, 0, 0, 0, 0, 0, 0 }$comma
523#endif
524EOH
525    foreach(@{$data->{alias}}) {
526        push @aliases, "#define want_vtbl_$_ want_vtbl_$name\n";
527        push @vtable_names, $_;
528    }
529}
530
531print $vt <<'EOH';
532};
533#else
534EXT_MGVTBL PL_magic_vtables[magic_vtable_max];
535#endif
536
537EOH
538
539print $vt (sort @aliases), "\n";
540
541print $vt "#define PL_vtbl_$_ PL_magic_vtables[want_vtbl_$_]\n"
542    foreach sort @vtable_names;
543
544# 63, not 64, As we rely on the last possible value to mean "NULL vtable"
545die "Too many vtable names" if @vtable_names > 63;
546
547read_only_bottom_close_and_rename($_) foreach $vt, $raw, $names;
548                 close_and_rename($guts);
549