File: mg_vtable.pl

package info (click to toggle)
perl 5.24.1-3+deb9u5
  • links: PTS, VCS
  • area: main
  • in suites: stretch
  • size: 103,716 kB
  • sloc: perl: 559,611; ansic: 293,886; sh: 67,316; pascal: 7,632; cpp: 3,895; makefile: 2,436; xml: 2,410; yacc: 989; sed: 6; lisp: 1
file content (371 lines) | stat: -rw-r--r-- 13,060 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
#!/usr/bin/perl -w
#
# Regenerate (overwriting only if changed):
#
#    mg_names.inc
#    mg_raw.h
#    mg_vtable.h
#    pod/perlguts.pod
#
# from information stored in this file.  pod/perlguts.pod is not completely
# regenerated.  Only the magic table is replaced; the other parts remain
# untouched.
#
# Accepts the standard regen_lib -q and -v args.
#
# This script is normally invoked from regen.pl.

use strict;
require 5.004;

BEGIN {
    # Get function prototypes
    require './regen/regen_lib.pl';
}

my %mg =
    (
     sv => { char => "\0", vtable => 'sv', readonly_acceptable => 1,
	     desc => 'Special scalar variable' },
     # overload, or type "A" magic, used to be here.  Hence overloaded is
     # often called AMAGIC internally, even though it does not use "A"
     # magic any more.
     overload_table => { char => 'c', vtable => 'ovrld',
			 desc => 'Holds overload table (AMT) on stash' },
     bm => { char => 'B', vtable => 'regexp', value_magic => 1,
	     readonly_acceptable => 1,
	     desc => 'Boyer-Moore (fast string search)' },
     regdata => { char => 'D', vtable => 'regdata',
		  desc => "Regex match position data\n(\@+ and \@- vars)" },
     regdatum => { char => 'd', vtable => 'regdatum',
		   desc => 'Regex match position data element' },
     env => { char => 'E', vtable => 'env', desc => '%ENV hash' },
     envelem => { char => 'e', vtable => 'envelem',
		  desc => '%ENV hash element' },
     fm => { char => 'f', vtable => 'regexp', value_magic => 1,
	     readonly_acceptable => 1, desc => "Formline ('compiled' format)" },
     regex_global => { char => 'g', vtable => 'mglob', value_magic => 1,
		       readonly_acceptable => 1, desc => 'm//g target' },
     hints => { char => 'H', vtable => 'hints', desc => '%^H hash' },
     hintselem => { char => 'h', vtable => 'hintselem',
		    desc => '%^H hash element' },
     isa => { char => 'I', vtable => 'isa', desc => '@ISA array' },
     isaelem => { char => 'i', vtable => 'isaelem',
		  desc => '@ISA array element' },
     nkeys => { char => 'k', vtable => 'nkeys', value_magic => 1,
		desc => 'scalar(keys()) lvalue' },
     dbfile => { char => 'L',
		 desc => 'Debugger %_<filename' },
     dbline => { char => 'l', vtable => 'dbline',
		 desc => 'Debugger %_<filename element' },
     shared => { char => 'N', desc => 'Shared between threads',
		 unknown_to_sv_magic => 1 },
     shared_scalar => { char => 'n', desc => 'Shared between threads',
			unknown_to_sv_magic => 1 },
     collxfrm => { char => 'o', vtable => 'collxfrm', value_magic => 1,
		   desc => 'Locale transformation' },
     tied => { char => 'P', vtable => 'pack',
	       value_magic => 1, # treat as value, so 'local @tied' isn't tied
	       desc => 'Tied array or hash' },
     tiedelem => { char => 'p', vtable => 'packelem',
		   desc => 'Tied array or hash element' },
     tiedscalar => { char => 'q', vtable => 'packelem',
		     desc => 'Tied scalar or handle' },
     qr => { char => 'r', vtable => 'regexp', value_magic => 1, 
	     readonly_acceptable => 1, desc => 'Precompiled qr// regex' },
     sig => { char => 'S', desc => '%SIG hash' },
     sigelem => { char => 's', vtable => 'sigelem',
		  desc => '%SIG hash element' },
     taint => { char => 't', vtable => 'taint', value_magic => 1,
		desc => 'Taintedness' },
     uvar => { char => 'U', vtable => 'uvar',
	       desc => 'Available for use by extensions' },
     uvar_elem => { char => 'u', desc => 'Reserved for use by extensions',
		    unknown_to_sv_magic => 1 },
     vec => { char => 'v', vtable => 'vec', value_magic => 1,
	      desc => 'vec() lvalue' },
     vstring => { char => 'V', value_magic => 1,
		  desc => 'SV was vstring literal' },
     utf8 => { char => 'w', vtable => 'utf8', value_magic => 1,
	       desc => 'Cached UTF-8 information' },
     substr => { char => 'x', vtable => 'substr',  value_magic => 1,
		 desc => 'substr() lvalue' },
     defelem => { char => 'y', vtable => 'defelem', value_magic => 1,
		  desc => "Shadow \"foreach\" iterator variable /\nsmart parameter vivification" },
     arylen => { char => '#', vtable => 'arylen', value_magic => 1,
		 desc => 'Array length ($#ary)' },
     pos => { char => '.', vtable => 'pos', value_magic => 1,
	      desc => 'pos() lvalue' },
     backref => { char => '<', vtable => 'backref', value_magic => 1,
		  readonly_acceptable => 1, desc => 'For weak ref data' },
     symtab => { char => ':', value_magic => 1,
		 desc => 'Extra data for symbol tables' },
     rhash => { char => '%', value_magic => 1,
		desc => 'Extra data for restricted hashes' },
     arylen_p => { char => '@', value_magic => 1,
		   desc => 'To move arylen out of XPVAV' },
     ext => { char => '~', desc => 'Available for use by extensions',
	      readonly_acceptable => 1 },
     checkcall => { char => ']', value_magic => 1, vtable => 'checkcall',
		    desc => 'Inlining/mutation of call to this CV'},
     debugvar => { char => '*', desc => '$DB::single, signal, trace vars',
		   vtable => 'debugvar' },
     lvref => { char => '\\', vtable => 'lvref',
		  desc => "Lvalue reference constructor" },
);

# These have a subtly different "namespace" from the magic types.
my %sig =
    (
     'sv' => {get => 'get', set => 'set'},
     'env' => {set => 'set_all_env', clear => 'clear_all_env'},
     'envelem' => {set => 'setenv', clear => 'clearenv'},
     'sigelem' => {get => 'getsig', set => 'setsig', clear => 'clearsig',
		   cond => '#ifndef PERL_MICRO'},
     'pack' => {len => 'sizepack', clear => 'wipepack'},
     'packelem' => {get => 'getpack', set => 'setpack', clear => 'clearpack'},
     'dbline' => {set => 'setdbline'},
     'isa' => {set => 'setisa', clear => 'clearisa'},
     'isaelem' => {set => 'setisa'},
     'arylen' => {get => 'getarylen', set => 'setarylen', const => 1},
     'arylen_p' => {clear => 'cleararylen_p', free => 'freearylen_p'},
     'mglob' => {set => 'setmglob'},
     'nkeys' => {get => 'getnkeys', set => 'setnkeys'},
     'taint' => {get => 'gettaint', set => 'settaint'},
     'substr' => {get => 'getsubstr', set => 'setsubstr'},
     'vec' => {get => 'getvec', set => 'setvec'},
     'pos' => {get => 'getpos', set => 'setpos'},
     'uvar' => {get => 'getuvar', set => 'setuvar'},
     'defelem' => {get => 'getdefelem', set => 'setdefelem'},
     'regexp' => {set => 'setregexp', alias => [qw(bm fm)]},
     'regdata' => {len => 'regdata_cnt'},
     'regdatum' => {get => 'regdatum_get', set => 'regdatum_set'},
     'backref' => {free => 'killbackrefs'},
     'ovrld' => {free => 'freeovrld'},
     'utf8' => {set => 'setutf8'},
     'collxfrm' => {set => 'setcollxfrm',
		    cond => '#ifdef USE_LOCALE_COLLATE'},
     'hintselem' => {set => 'sethint', clear => 'clearhint'},
     'hints' => {clear => 'clearhints'},
     'checkcall' => {copy => 'copycallchecker'},
     'debugvar' => { set => 'setdebugvar', get => 'getdebugvar' },
     'lvref' => {set => 'setlvref'},
);

my ($vt, $raw, $names) = map {
    open_new($_, '>',
	     { by => 'regen/mg_vtable.pl', file => $_, style => '*' });
} 'mg_vtable.h', 'mg_raw.h', 'mg_names.inc';
my $guts = open_new("pod/perlguts.pod", ">");

print $vt <<'EOH';
/* These constants should be used in preference to raw characters
 * when using magic. Note that some perl guts still assume
 * certain character properties of these constants, namely that
 * isUPPER() and toLOWER() may do useful mappings.
 */

EOH

# Of course, it would be *much* easier if we could output this table directly
# here and now. However, for our sins, we try to support EBCDIC, which wouldn't
# be *so* bad, except that there are (at least) 3 EBCDIC charset variants, and
# they don't agree on the code point for '~'. Which we use. Great.
# So we have to get the local build runtime to sort our table in character order
# (And of course, just to be helpful, in POSIX BC '~' is \xFF, so we can't even
# simplify the C code by assuming that the last element of the array is
# predictable)

{
    my $longest = 0;
    foreach (keys %mg) {
	$longest = length $_ if length $_ > $longest;
    }

    my $longest_p1 = $longest + 1;

    my %mg_order;
    while (my ($name, $data) = each %mg) {
	my $byte = $data->{char};
	if ($byte =~ /[[:print:]]/) {
	    $data->{r_char} = $byte; # readable char
	    ($data->{c_char} = $byte) =~ s/([\\"])/\\$1/g; # for C strings
	}
	else {
	    $data->{c_char} = $data->{r_char} = '\\'.ord $byte;
	}
	$mg_order{(uc $byte) . $byte} = $name;
    }
    my @rows;
    foreach (sort keys %mg_order) {
	my $name = $mg_order{$_};
	my $data = $mg{$name};
	my $i = ord $data->{char};
	unless ($data->{unknown_to_sv_magic}) {
	    my $value = $data->{vtable}
		? "want_vtbl_$data->{vtable}" : 'magic_vtable_max';
	    $value .= ' | PERL_MAGIC_READONLY_ACCEPTABLE'
		if $data->{readonly_acceptable};
	    $value .= ' | PERL_MAGIC_VALUE_MAGIC' if $data->{value_magic};
	    my $comment = "/* $name '$data->{r_char}' $data->{desc} */";
	    $comment =~ s/([\\"])/\\$1/g;
	    $comment =~ tr/\n/ /;
	    print $raw qq{    { '$data->{c_char}', "$value",\n      "$comment" },\n};
	}

	my $comment = $data->{desc};
	my $leader = ' ' x ($longest + 27);
	$comment =~ s/\n/\n$leader/s;
	printf $vt "#define PERL_MAGIC_%-${longest}s '%s' /* %s */\n",
	    $name, $data->{c_char}, $comment;

	my $char = $data->{r_char};
	$char =~ s/([\\"])/\\$1/g;
	printf $names qq[\t{ PERL_MAGIC_%-${longest_p1}s "%s(%s)" },\n],
	    "$name,", $name, $char;

	push @rows, [(sprintf "%-2s PERL_MAGIC_%s", $data->{r_char},$name),
		     $data->{vtable} ? "vtbl_$data->{vtable}" : '(none)',
		     $data->{desc}];
    }
    select +(select($guts), do {
	my @header = ('(old-style char and macro)', 'MGVTBL', 'Type of magic');
	my @widths = (0, 0);
	foreach my $row (@rows) {
	    for (0, 1) {
		$widths[$_] = length $row->[$_]
		    if length $row->[$_] > $widths[$_];
	    }
	}
	my $indent = ' ';
	my $format
	    = sprintf "$indent%%-%ds%%-%ds%%s\n", $widths[0] + 1, $widths[1] + 1;
	my $desc_wrap =
	    79 - 7 - (length $indent) - $widths[0] - $widths[1] - 2;

	open my $oldguts, "<", "pod/perlguts.pod"
	   or die "$0 cannot open pod/perlguts.pod for reading: $!";
	while (<$oldguts>) {
	    print;
	    last if /^=for mg_vtable.pl begin/
	}

	print "\n", $indent . "mg_type\n";
	printf $format, @header;
	printf $format, map {'-' x length $_} @header;
	foreach (@rows) {
	    my ($type, $vtbl, $desc) = @$_;
	    $desc =~ tr/\n/ /;
	    my @cont;
	    if (length $desc > $desc_wrap) {
		# If it's too long, first split on '(', if there.
		# [Which, if there, is always short enough, currently.
		# Make this more robust if that changes]
		($desc, @cont) = split /(?=\()/, $desc;
		if (!@cont) {
		    ($desc, @cont) = $desc =~ /(.{1,$desc_wrap})(?: |\z)/g
		}
	    }
	    printf $format, $type, $vtbl, $desc;
	    printf $format, '', '', $_ foreach @cont;
	}
	print "\n";

	while (<$oldguts>) {
	    last if /^=for mg_vtable.pl end/;
	}
	do { print } while <$oldguts>;
    })[0];
}

my @names = sort keys %sig;
{
    my $want = join ",\n    ", (map {"want_vtbl_$_"} @names), 'magic_vtable_max';
    my $names = join qq{",\n    "}, @names;

    print $vt <<"EOH";

enum {		/* pass one of these to get_vtbl */
    $want
};

#ifdef DOINIT
EXTCONST char * const PL_magic_vtable_names[magic_vtable_max] = {
    "$names"
};
#else
EXTCONST char * const PL_magic_vtable_names[magic_vtable_max];
#endif

EOH
}

print $vt <<'EOH';
/* These all need to be 0, not NULL, as NULL can be (void*)0, which is a
 * pointer to data, whereas we're assigning pointers to functions, which are
 * not the same beast. ANSI doesn't allow the assignment from one to the other.
 * (although most, but not all, compilers are prepared to do it)
 */

/* order is:
    get
    set
    len
    clear
    free
    copy
    dup
    local
*/

#ifdef DOINIT
EXT_MGVTBL PL_magic_vtables[magic_vtable_max] = {
EOH

my @vtable_names;
my @aliases;

while (my $name = shift @names) {
    my $data = $sig{$name};
    push @vtable_names, $name;
    my @funcs = map {
	$data->{$_} ? "Perl_magic_$data->{$_}" : 0;
    } qw(get set len clear free copy dup local);

    $funcs[0] = "(int (*)(pTHX_ SV *, MAGIC *))" . $funcs[0] if $data->{const};
    my $funcs = join ", ", @funcs;

    # Because we can't have a , after the last {...}
    my $comma = @names ? ',' : '';

    print $vt "$data->{cond}\n" if $data->{cond};
    print $vt "  { $funcs }$comma\n";
    print $vt <<"EOH" if $data->{cond};
#else
  { 0, 0, 0, 0, 0, 0, 0, 0 }$comma
#endif
EOH
    foreach(@{$data->{alias}}) {
	push @aliases, "#define want_vtbl_$_ want_vtbl_$name\n";
	push @vtable_names, $_;
    }
}

print $vt <<'EOH';
};
#else
EXT_MGVTBL PL_magic_vtables[magic_vtable_max];
#endif

EOH

print $vt (sort @aliases), "\n";

print $vt "#define PL_vtbl_$_ PL_magic_vtables[want_vtbl_$_]\n"
    foreach sort @vtable_names;

# 63, not 64, As we rely on the last possible value to mean "NULL vtable"
die "Too many vtable names" if @vtable_names > 63;

read_only_bottom_close_and_rename($_) foreach $vt, $raw, $names;
		 close_and_rename($guts);