1#!/usr/bin/perl -w 2# 3# Regenerate (overwriting only if changed): 4# 5# mg_names.c 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 18use strict; 19require 5.004; 20 21BEGIN { 22 # Get function prototypes 23 require 'regen/regen_lib.pl'; 24} 25 26my %mg = 27 ( 28 sv => { char => '\0', vtable => 'sv', readonly_acceptable => 1, 29 desc => 'Special scalar variable' }, 30 # overload, or type "A" magic, used to be here. Hence overloaded is 31 # often called AMAGIC internally, even though it does not use "A" 32 # magic any more. 33 overload_table => { char => 'c', vtable => 'ovrld', 34 desc => 'Holds overload table (AMT) on stash' }, 35 bm => { char => 'B', vtable => 'regexp', value_magic => 1, 36 readonly_acceptable => 1, 37 desc => 'Boyer-Moore (fast string search)' }, 38 regdata => { char => 'D', vtable => 'regdata', 39 desc => "Regex match position data\n(\@+ and \@- vars)" }, 40 regdatum => { char => 'd', vtable => 'regdatum', 41 desc => 'Regex match position data element' }, 42 env => { char => 'E', vtable => 'env', desc => '%ENV hash' }, 43 envelem => { char => 'e', vtable => 'envelem', 44 desc => '%ENV hash element' }, 45 fm => { char => 'f', vtable => 'regexp', value_magic => 1, 46 readonly_acceptable => 1, desc => "Formline ('compiled' format)" }, 47 regex_global => { char => 'g', vtable => 'mglob', value_magic => 1, 48 readonly_acceptable => 1, desc => 'm//g target' }, 49 hints => { char => 'H', vtable => 'hints', desc => '%^H hash' }, 50 hintselem => { char => 'h', vtable => 'hintselem', 51 desc => '%^H hash element' }, 52 isa => { char => 'I', vtable => 'isa', desc => '@ISA array' }, 53 isaelem => { char => 'i', vtable => 'isaelem', 54 desc => '@ISA array element' }, 55 nkeys => { char => 'k', vtable => 'nkeys', value_magic => 1, 56 desc => 'scalar(keys()) lvalue' }, 57 dbfile => { char => 'L', 58 desc => 'Debugger %_<filename' }, 59 dbline => { char => 'l', vtable => 'dbline', 60 desc => 'Debugger %_<filename element' }, 61 shared => { char => 'N', desc => 'Shared between threads', 62 unknown_to_sv_magic => 1 }, 63 shared_scalar => { char => 'n', desc => 'Shared between threads', 64 unknown_to_sv_magic => 1 }, 65 collxfrm => { char => 'o', vtable => 'collxfrm', value_magic => 1, 66 desc => 'Locale transformation' }, 67 tied => { char => 'P', vtable => 'pack', 68 value_magic => 1, # treat as value, so 'local @tied' isn't tied 69 desc => 'Tied array or hash' }, 70 tiedelem => { char => 'p', vtable => 'packelem', 71 desc => 'Tied array or hash element' }, 72 tiedscalar => { char => 'q', vtable => 'packelem', 73 desc => 'Tied scalar or handle' }, 74 qr => { char => 'r', vtable => 'regexp', value_magic => 1, 75 readonly_acceptable => 1, desc => 'precompiled qr// regex' }, 76 sig => { char => 'S', desc => '%SIG hash' }, 77 sigelem => { char => 's', vtable => 'sigelem', 78 desc => '%SIG hash element' }, 79 taint => { char => 't', vtable => 'taint', value_magic => 1, 80 desc => 'Taintedness' }, 81 uvar => { char => 'U', vtable => 'uvar', 82 desc => 'Available for use by extensions' }, 83 uvar_elem => { char => 'u', desc => 'Reserved for use by extensions', 84 unknown_to_sv_magic => 1 }, 85 vec => { char => 'v', vtable => 'vec', value_magic => 1, 86 desc => 'vec() lvalue' }, 87 vstring => { char => 'V', value_magic => 1, 88 desc => 'SV was vstring literal' }, 89 utf8 => { char => 'w', vtable => 'utf8', value_magic => 1, 90 desc => 'Cached UTF-8 information' }, 91 substr => { char => 'x', vtable => 'substr', value_magic => 1, 92 desc => 'substr() lvalue' }, 93 defelem => { char => 'y', vtable => 'defelem', value_magic => 1, 94 desc => "Shadow \"foreach\" iterator variable /\nsmart parameter vivification" }, 95 arylen => { char => '#', vtable => 'arylen', value_magic => 1, 96 desc => 'Array length ($#ary)' }, 97 proto => { char => '&', desc => 'my sub prototype CV' }, 98 pos => { char => '.', vtable => 'pos', value_magic => 1, 99 desc => 'pos() lvalue' }, 100 backref => { char => '<', vtable => 'backref', value_magic => 1, 101 readonly_acceptable => 1, desc => 'for weak ref data' }, 102 symtab => { char => ':', value_magic => 1, 103 desc => 'extra data for symbol tables' }, 104 rhash => { char => '%', value_magic => 1, 105 desc => 'extra data for restricted hashes' }, 106 arylen_p => { char => '@', value_magic => 1, 107 desc => 'to move arylen out of XPVAV' }, 108 ext => { char => '~', desc => 'Available for use by extensions' }, 109 checkcall => { char => ']', value_magic => 1, vtable => 'checkcall', 110 desc => 'inlining/mutation of call to this CV'}, 111); 112 113# These have a subtly different "namespace" from the magic types. 114my %sig = 115 ( 116 'sv' => {get => 'get', set => 'set'}, 117 'env' => {set => 'set_all_env', clear => 'clear_all_env'}, 118 'envelem' => {set => 'setenv', clear => 'clearenv'}, 119 'sigelem' => {get => 'getsig', set => 'setsig', clear => 'clearsig', 120 cond => '#ifndef PERL_MICRO'}, 121 'pack' => {len => 'sizepack', clear => 'wipepack'}, 122 'packelem' => {get => 'getpack', set => 'setpack', clear => 'clearpack'}, 123 'dbline' => {set => 'setdbline'}, 124 'isa' => {set => 'setisa', clear => 'clearisa'}, 125 'isaelem' => {set => 'setisa'}, 126 'arylen' => {get => 'getarylen', set => 'setarylen', const => 1}, 127 'arylen_p' => {clear => 'cleararylen_p', free => 'freearylen_p'}, 128 'mglob' => {set => 'setmglob'}, 129 'nkeys' => {get => 'getnkeys', set => 'setnkeys'}, 130 'taint' => {get => 'gettaint', set => 'settaint'}, 131 'substr' => {get => 'getsubstr', set => 'setsubstr'}, 132 'vec' => {get => 'getvec', set => 'setvec'}, 133 'pos' => {get => 'getpos', set => 'setpos'}, 134 'uvar' => {get => 'getuvar', set => 'setuvar'}, 135 'defelem' => {get => 'getdefelem', set => 'setdefelem'}, 136 'regexp' => {set => 'setregexp', alias => [qw(bm fm)]}, 137 'regdata' => {len => 'regdata_cnt'}, 138 'regdatum' => {get => 'regdatum_get', set => 'regdatum_set'}, 139 'backref' => {free => 'killbackrefs'}, 140 'ovrld' => {free => 'freeovrld'}, 141 'utf8' => {set => 'setutf8'}, 142 'collxfrm' => {set => 'setcollxfrm', 143 cond => '#ifdef USE_LOCALE_COLLATE'}, 144 'hintselem' => {set => 'sethint', clear => 'clearhint'}, 145 'hints' => {clear => 'clearhints'}, 146 'checkcall' => {copy => 'copycallchecker'}, 147); 148 149my ($vt, $raw, $names) = map { 150 open_new($_, '>', 151 { by => 'regen/mg_vtable.pl', file => $_, style => '*' }); 152} 'mg_vtable.h', 'mg_raw.h', 'mg_names.c'; 153my $guts = open_new("pod/perlguts.pod", ">"); 154 155print $vt <<'EOH'; 156/* These constants should be used in preference to raw characters 157 * when using magic. Note that some perl guts still assume 158 * certain character properties of these constants, namely that 159 * isUPPER() and toLOWER() may do useful mappings. 160 */ 161 162EOH 163 164# Of course, it would be *much* easier if we could output this table directly 165# here and now. However, for our sins, we try to support EBCDIC, which wouldn't 166# be *so* bad, except that there are (at least) 3 EBCDIC charset variants, and 167# they don't agree on the code point for '~'. Which we use. Great. 168# So we have to get the local build runtime to sort our table in character order 169# (And of course, just to be helpful, in POSIX BC '~' is \xFF, so we can't even 170# simplify the C code by assuming that the last element of the array is 171# predictable) 172 173{ 174 my $longest = 0; 175 foreach (keys %mg) { 176 $longest = length $_ if length $_ > $longest; 177 } 178 179 my $longest_p1 = $longest + 1; 180 181 my %mg_order; 182 while (my ($name, $data) = each %mg) { 183 my $byte = eval qq{"$data->{char}"}; 184 $data->{byte} = $byte; 185 $mg_order{(uc $byte) . $byte} = $name; 186 } 187 my @rows; 188 foreach (sort keys %mg_order) { 189 my $name = $mg_order{$_}; 190 my $data = $mg{$name}; 191 my $i = ord $data->{byte}; 192 unless ($data->{unknown_to_sv_magic}) { 193 my $value = $data->{vtable} 194 ? "want_vtbl_$data->{vtable}" : 'magic_vtable_max'; 195 $value .= ' | PERL_MAGIC_READONLY_ACCEPTABLE' 196 if $data->{readonly_acceptable}; 197 $value .= ' | PERL_MAGIC_VALUE_MAGIC' if $data->{value_magic}; 198 my $comment = "/* $name '$data->{char}' $data->{desc} */"; 199 $comment =~ s/([\\"])/\\$1/g; 200 $comment =~ tr/\n/ /; 201 print $raw qq{ { '$data->{char}', "$value",\n "$comment" },\n}; 202 } 203 204 my $comment = $data->{desc}; 205 my $leader = ' ' x ($longest + 27); 206 $comment =~ s/\n/\n$leader/s; 207 printf $vt "#define PERL_MAGIC_%-${longest}s '%s' /* %s */\n", 208 $name, $data->{char}, $comment; 209 210 my $char = $data->{char}; 211 $char =~ s/([\\"])/\\$1/g; 212 printf $names qq[\t{ PERL_MAGIC_%-${longest_p1}s "%s(%s)" },\n], 213 "$name,", $name, $char; 214 215 push @rows, [(sprintf "%-2s PERL_MAGIC_%s", $data->{char}, $name), 216 $data->{vtable} ? "vtbl_$data->{vtable}" : '(none)', 217 $data->{desc}]; 218 } 219 select +(select($guts), do { 220 my @header = ('(old-style char and macro)', 'MGVTBL', 'Type of magic'); 221 my @widths = (0, 0); 222 foreach my $row (@rows) { 223 for (0, 1) { 224 $widths[$_] = length $row->[$_] 225 if length $row->[$_] > $widths[$_]; 226 } 227 } 228 my $indent = ' '; 229 my $format 230 = sprintf "$indent%%-%ds%%-%ds%%s\n", $widths[0] + 1, $widths[1] + 1; 231 my $desc_wrap = 232 79 - 7 - (length $indent) - $widths[0] - $widths[1] - 2; 233 234 open my $oldguts, "<", "pod/perlguts.pod" 235 or die "$0 cannot open pod/perlguts.pod for reading: $!"; 236 while (<$oldguts>) { 237 print; 238 last if /^=for mg_vtable.pl begin/ 239 } 240 241 print "\n", $indent . "mg_type\n"; 242 printf $format, @header; 243 printf $format, map {'-' x length $_} @header; 244 foreach (@rows) { 245 my ($type, $vtbl, $desc) = @$_; 246 $desc =~ tr/\n/ /; 247 my @cont; 248 if (length $desc > $desc_wrap) { 249 # If it's too long, first split on '(', if there. 250 # [Which, if there, is always short enough, currently. 251 # Make this more robust if that changes] 252 ($desc, @cont) = split /(?=\()/, $desc; 253 if (!@cont) { 254 ($desc, @cont) = $desc =~ /(.{1,$desc_wrap})(?: |\z)/g 255 } 256 } 257 printf $format, $type, $vtbl, $desc; 258 printf $format, '', '', $_ foreach @cont; 259 } 260 print "\n"; 261 262 while (<$oldguts>) { 263 last if /^=for mg_vtable.pl end/; 264 } 265 do { print } while <$oldguts>; 266 })[0]; 267} 268 269my @names = sort keys %sig; 270{ 271 my $want = join ",\n ", (map {"want_vtbl_$_"} @names), 'magic_vtable_max'; 272 my $names = join qq{",\n "}, @names; 273 274 print $vt <<"EOH"; 275 276enum { /* pass one of these to get_vtbl */ 277 $want 278}; 279 280#ifdef DOINIT 281EXTCONST char * const PL_magic_vtable_names[magic_vtable_max] = { 282 "$names" 283}; 284#else 285EXTCONST char * const PL_magic_vtable_names[magic_vtable_max]; 286#endif 287 288EOH 289} 290 291print $vt <<'EOH'; 292/* These all need to be 0, not NULL, as NULL can be (void*)0, which is a 293 * pointer to data, whereas we're assigning pointers to functions, which are 294 * not the same beast. ANSI doesn't allow the assignment from one to the other. 295 * (although most, but not all, compilers are prepared to do it) 296 */ 297 298/* order is: 299 get 300 set 301 len 302 clear 303 free 304 copy 305 dup 306 local 307*/ 308 309#ifdef DOINIT 310EXT_MGVTBL PL_magic_vtables[magic_vtable_max] = { 311EOH 312 313my @vtable_names; 314my @aliases; 315 316while (my $name = shift @names) { 317 my $data = $sig{$name}; 318 push @vtable_names, $name; 319 my @funcs = map { 320 $data->{$_} ? "Perl_magic_$data->{$_}" : 0; 321 } qw(get set len clear free copy dup local); 322 323 $funcs[0] = "(int (*)(pTHX_ SV *, MAGIC *))" . $funcs[0] if $data->{const}; 324 my $funcs = join ", ", @funcs; 325 326 # Because we can't have a , after the last {...} 327 my $comma = @names ? ',' : ''; 328 329 print $vt "$data->{cond}\n" if $data->{cond}; 330 print $vt " { $funcs }$comma\n"; 331 print $vt <<"EOH" if $data->{cond}; 332#else 333 { 0, 0, 0, 0, 0, 0, 0, 0 }$comma 334#endif 335EOH 336 foreach(@{$data->{alias}}) { 337 push @aliases, "#define want_vtbl_$_ want_vtbl_$name\n"; 338 push @vtable_names, $_; 339 } 340} 341 342print $vt <<'EOH'; 343}; 344#else 345EXT_MGVTBL PL_magic_vtables[magic_vtable_max]; 346#endif 347 348EOH 349 350print $vt (sort @aliases), "\n"; 351 352print $vt "#define PL_vtbl_$_ PL_magic_vtables[want_vtbl_$_]\n" 353 foreach sort @vtable_names; 354 355# 63, not 64, As we rely on the last possible value to mean "NULL vtable" 356die "Too many vtable names" if @vtable_names > 63; 357 358read_only_bottom_close_and_rename($_) foreach $vt, $raw, $names; 359 close_and_rename($guts); 360