Create a lookup table for magic vtables from magic type, PL_magic_data.

Use it to eliminate the large switch statement in Perl_sv_magic().

As the table needs to be keyed on magic type, which is expressed as C character
constants, the order depends on the compiler's character set. Frustratingly,
EBCDIC variants don't agree on the code points for '~' and ']', which we use
here. Instead of having (at least) 4 tables, get the local runtime to sort the
table for us. Hence the regen script writes out the (unsorted) mg_raw.h, which
generate_uudmap sorts to generate mg_data.h

diff --git a/MANIFEST b/MANIFEST
index 1c657d4..d482674 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -4125,6 +4125,7 @@ metaconfig.SH                     Control file for the metaconfig process
 META.yml                       Distribution meta-data in YAML
 mg.c                           Magic code
 mg.h                           Magic header
+mg_raw.h                       Generated magic data used by generate_uudmap.c
 mg_vtable.h                    Generated magic vtable data
 minimod.pl                     Writes lib/ExtUtils/Miniperl.pm
 miniperlmain.c                 Basic perl w/o dynamic loading or extensions

diff --git a/Makefile.SH b/Makefile.SH
index 8c17ac2..b4955ad 100755 (executable)
--- a/Makefile.SH
+++ b/Makefile.SH
@@ -630,12 +630,14 @@ done
 
 $spitshell >>$Makefile <<'!NO!SUBS!'
 
-globals$(OBJ_EXT): uudmap.h bitcount.h
+globals$(OBJ_EXT): uudmap.h bitcount.h mg_data.h
 
-uudmap.h: bitcount.h
+uudmap.h mg_data.h: bitcount.h
 
 bitcount.h: generate_uudmap$(HOST_EXE_EXT)
-       $(RUN) ./generate_uudmap$(HOST_EXE_EXT) uudmap.h bitcount.h
+       $(RUN) ./generate_uudmap$(HOST_EXE_EXT) uudmap.h bitcount.h mg_data.h
+
+generate_uudmap$(OBJ_EXT): mg_raw.h
 
 generate_uudmap$(HOST_EXE_EXT): generate_uudmap$(OBJ_EXT)
        $(CC) -o generate_uudmap$(EXE_EXT) $(LDFLAGS) generate_uudmap$(OBJ_EXT) $(libs)
@@ -1224,7 +1226,7 @@ veryclean:        _verycleaner _mopup _clobber
 
 # Do not 'make _mopup' directly.
 _mopup:
-       rm -f *$(OBJ_EXT) *$(LIB_EXT) all perlmain.c opmini.c perlmini.c uudmap.h generate_uudmap$(EXE_EXT) bitcount.h
+       rm -f *$(OBJ_EXT) *$(LIB_EXT) all perlmain.c opmini.c perlmini.c uudmap.h generate_uudmap$(EXE_EXT) bitcount.h mg_data.h
        -rmdir .depending
        -@test -f extra.pods && rm -f `cat extra.pods`
        -@test -f vms/README_vms.pod && rm -f vms/README_vms.pod

diff --git a/Makefile.micro b/Makefile.micro
index b5a7123..45cf26e 100644 (file)
--- a/Makefile.micro
+++ b/Makefile.micro
@@ -36,7 +36,7 @@ H = av.h uconfig.h cop.h cv.h embed.h embedvar.h form.h gv.h handy.h \
 HE = $(H) EXTERN.h
 
 clean:
-       -rm -f $(O) microperl generate_uudmap$(_X) uudmap.h bitcount.h
+       -rm -f $(O) microperl generate_uudmap$(_X) uudmap.h bitcount.h mg_data.h
 
 distclean:     clean
 
@@ -78,7 +78,7 @@ udoop$(_O):   $(HE) doop.c
 udump$(_O):    $(HE) dump.c regcomp.h regnodes.h
        $(CC) $(CCFLAGS) -o $@ $(CFLAGS) dump.c
 
-uglobals$(_O): $(H) globals.c INTERN.h perlapi.h uudmap.h bitcount.h
+uglobals$(_O): $(H) globals.c INTERN.h perlapi.h uudmap.h bitcount.h mg_data.h
        $(CC) $(CCFLAGS) -o $@ $(CFLAGS) globals.c
 
 ugv$(_O):      $(HE) gv.c
@@ -177,8 +177,8 @@ uutil$(_O): $(HE) util.c
 uperlapi$(_O): $(HE) perlapi.c perlapi.h
        $(CC) $(CCFLAGS) -o $@ $(CFLAGS) perlapi.c
 
-uudmap.h bitcount.h: generate_uudmap$(_X)
-       $(RUN) ./generate_uudmap$(_X) uudmap.h bitcount.h
+uudmap.h bitcount.h mg_data.h: generate_uudmap$(_X)
+       $(RUN) ./generate_uudmap$(_X) uudmap.h bitcount.h mg_data.h
 
 generate_uudmap$(_O): generate_uudmap.c
        $(CC) $(CCFLAGS) -o $@ $(CFLAGS) generate_uudmap.c

diff --git a/generate_uudmap.c b/generate_uudmap.c
index 6159259..b6307c0 100644 (file)
--- a/generate_uudmap.c
+++ b/generate_uudmap.c
@@ -12,6 +12,46 @@
    "hello world" won't port easily to it.  */
 #include <errno.h>
 
+struct mg_data_raw_t {
+    unsigned char type;
+    const char *value;
+    const char *comment;
+};
+
+static struct mg_data_raw_t mg_data_raw[] = {
+#ifdef WIN32
+#  include "..\mg_raw.h"
+#else
+#  include "mg_raw.h"
+#endif
+    {0, 0, 0}
+};
+
+struct mg_data_t {
+    const char *value;
+    const char *comment;
+};
+
+static struct mg_data_t mg_data[256];
+
+static void
+format_mg_data(FILE *out, const void *thing, size_t count) {
+  const struct mg_data_t *p = (const struct mg_data_t *)thing;
+
+  while (1) {
+      if (p->value) {
+         fprintf(out, "    %s\n    %s", p->comment, p->value);
+      } else {
+         fputs("    0", out);
+      }
+      ++p;
+      if (!--count)
+         break;
+      fputs(",\n", out);
+  }
+  fputc('\n', out);
+}
+
 static void
 format_char_block(FILE *out, const void *thing, size_t count) {
   const char *block = (const char *)thing;
@@ -66,9 +106,11 @@ static char PL_bitcount[256];
 int main(int argc, char **argv) {
   size_t i;
   int bits;
+  struct mg_data_raw_t *p = mg_data_raw;
 
-  if (argc < 3 || argv[1][0] == '\0' || argv[2][0] == '\0') {
-    fprintf(stderr, "Usage: %s uudemap.h bitcount.h\n", argv[0]);
+  if (argc < 4 || argv[1][0] == '\0' || argv[2][0] == '\0'
+      || argv[3][0] == '\0') {
+    fprintf(stderr, "Usage: %s uudemap.h bitcount.h mg_data.h\n", argv[0]);
     return 1;
   }
 
@@ -97,5 +139,14 @@ int main(int argc, char **argv) {
   output_to_file(argv[0], argv[2], &format_char_block,
                 (const void *)PL_bitcount, sizeof(PL_bitcount));
 
+  while (p->value) {
+      mg_data[p->type].value = p->value;
+      mg_data[p->type].comment = p->comment;
+      ++p;
+  }
+      
+  output_to_file(argv[0], argv[3], &format_mg_data,
+                (const void *)mg_data, sizeof(mg_data)/sizeof(mg_data[0]));
+
   return 0;
 }

diff --git a/globvar.sym b/globvar.sym
index 49c2abf..9bec861 100644 (file)
--- a/globvar.sym
+++ b/globvar.sym
@@ -13,6 +13,7 @@ fold_latin1
 fold_locale
 freq
 keyword_plugin
+magic_data
 magic_vtables
 magic_vtable_names
 memory_wrap

diff --git a/mg_raw.h b/mg_raw.h
new file mode 100644 (file)
index 0000000..363e189
--- /dev/null
+++ b/mg_raw.h
@@ -0,0 +1,90 @@
+/* -*- buffer-read-only: t -*-
+ *
+ *    mg_raw.h
+ * !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
+ * This file is built by regen/mg_vtable.pl.
+ * Any changes made here will be lost!
+ */
+
+    { '\0', "want_vtbl_sv",
+      "/* sv '\\0' Special scalar variable */" },
+    { 'A', "want_vtbl_amagic",
+      "/* overload 'A' %OVERLOAD hash */" },
+    { 'a', "want_vtbl_amagicelem",
+      "/* overload_elem 'a' %OVERLOAD hash element */" },
+    { 'c', "want_vtbl_ovrld",
+      "/* overload_table 'c' Holds overload table (AMT) on stash */" },
+    { 'B', "want_vtbl_regexp",
+      "/* bm 'B' Boyer-Moore (fast string search) */" },
+    { 'D', "want_vtbl_regdata",
+      "/* regdata 'D' Regex match position data (@+ and @- vars) */" },
+    { 'd', "want_vtbl_regdatum",
+      "/* regdatum 'd' Regex match position data element */" },
+    { 'E', "want_vtbl_env",
+      "/* env 'E' %ENV hash */" },
+    { 'e', "want_vtbl_envelem",
+      "/* envelem 'e' %ENV hash element */" },
+    { 'f', "want_vtbl_regdata",
+      "/* fm 'f' Formline ('compiled' format) */" },
+    { 'g', "want_vtbl_mglob",
+      "/* regex_global 'g' m//g target / study()ed string */" },
+    { 'H', "want_vtbl_hints",
+      "/* hints 'H' %^H hash */" },
+    { 'h', "want_vtbl_hintselem",
+      "/* hintselem 'h' %^H hash element */" },
+    { 'I', "want_vtbl_isa",
+      "/* isa 'I' @ISA array */" },
+    { 'i', "want_vtbl_isaelem",
+      "/* isaelem 'i' @ISA array element */" },
+    { 'k', "want_vtbl_nkeys",
+      "/* nkeys 'k' scalar(keys()) lvalue */" },
+    { 'L', "want_vtbl_dbline",
+      "/* dbfile 'L' Debugger %_<filename */" },
+    { 'l', "magic_vtable_max",
+      "/* dbline 'l' Debugger %_<filename element */" },
+    { 'o', "want_vtbl_collxfrm",
+      "/* collxfrm 'o' Locale transformation */" },
+    { 'P', "want_vtbl_pack",
+      "/* tied 'P' Tied array or hash */" },
+    { 'p', "want_vtbl_packelem",
+      "/* tiedelem 'p' Tied array or hash element */" },
+    { 'q', "want_vtbl_packelem",
+      "/* tiedscalar 'q' Tied scalar or handle */" },
+    { 'r', "want_vtbl_regexp",
+      "/* qr 'r' precompiled qr// regex */" },
+    { 'S', "magic_vtable_max",
+      "/* sig 'S' %SIG hash */" },
+    { 's', "want_vtbl_sigelem",
+      "/* sigelem 's' %SIG hash element */" },
+    { 't', "want_vtbl_taint",
+      "/* taint 't' Taintedness */" },
+    { 'U', "want_vtbl_uvar",
+      "/* uvar 'U' Available for use by extensions */" },
+    { 'v', "want_vtbl_vec",
+      "/* vec 'v' vec() lvalue */" },
+    { 'V', "magic_vtable_max",
+      "/* vstring 'V' SV was vstring literal */" },
+    { 'w', "want_vtbl_utf8",
+      "/* utf8 'w' Cached UTF-8 information */" },
+    { 'x', "want_vtbl_substr",
+      "/* substr 'x' substr() lvalue */" },
+    { 'y', "want_vtbl_defelem",
+      "/* defelem 'y' Shadow \"foreach\" iterator variable / smart parameter vivification */" },
+    { '#', "want_vtbl_arylen",
+      "/* arylen '#' Array length ($#ary) */" },
+    { '.', "want_vtbl_pos",
+      "/* pos '.' pos() lvalue */" },
+    { '<', "want_vtbl_backref",
+      "/* backref '<' for weak ref data */" },
+    { ':', "magic_vtable_max",
+      "/* symtab ':' extra data for symbol tables */" },
+    { '%', "magic_vtable_max",
+      "/* rhash '%' extra data for restricted hashes */" },
+    { '@', "magic_vtable_max",
+      "/* arylen_p '@' to move arylen out of XPVAV */" },
+    { '~', "magic_vtable_max",
+      "/* ext '~' Available for use by extensions */" },
+    { ']', "magic_vtable_max",
+      "/* checkcall ']' inlining/mutation of call to this CV */" },
+
+/* ex: set ro: */

diff --git a/perl.h b/perl.h
index 9c00120..6b688b6 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -5072,6 +5072,15 @@ START_EXTERN_C
 #endif
 
 #include "mg_vtable.h"
+
+#ifdef DOINIT
+EXTCONST U8 PL_magic_data[256] =
+#include "mg_data.h"
+;
+#else
+EXTCONST U8 PL_magic_data[256];
+#endif
+
 #include "overload.h"
 
 END_EXTERN_C

diff --git a/regen/mg_vtable.pl b/regen/mg_vtable.pl
index f527a3e..121a9b4 100644 (file)
--- a/regen/mg_vtable.pl
+++ b/regen/mg_vtable.pl
@@ -18,6 +18,77 @@ BEGIN {
     require 'regen/regen_lib.pl';
 }
 
+my @mg =
+    (
+     sv => { char => '\0', vtable => 'sv', desc => 'Special scalar variable' },
+     overload => { char => 'A', vtable => 'amagic', desc => '%OVERLOAD hash' },
+     overload_elem => { char => 'a', vtable => 'amagicelem',
+                       desc => '%OVERLOAD hash element' },
+     overload_table => { char => 'c', vtable => 'ovrld',
+                        desc => 'Holds overload table (AMT) on stash' },
+     bm => { char => 'B', vtable => 'regexp',
+            desc => 'Boyer-Moore (fast string search)' },
+     regdata => { char => 'D', vtable => 'regdata',
+                 desc => 'Regex match position data (@+ 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 => 'regdata',
+            desc => "Formline ('compiled' format)" },
+     regex_global => { char => 'g', vtable => 'mglob',
+                      desc => 'm//g target / study()ed string' },
+     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',
+               desc => 'scalar(keys()) lvalue' },
+     dbfile => { char => 'L', vtable => 'dbline',
+                desc => 'Debugger %_<filename' },
+     dbline => { char => 'l', 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',
+                  desc => 'Locale transformation' },
+     tied => { char => 'P', vtable => 'pack', 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', desc => 'precompiled qr// regex' },
+     sig => { char => 'S', desc => '%SIG hash' },
+     sigelem => { char => 's', vtable => 'sigelem',
+                 desc => '%SIG hash element' },
+     taint => { char => 't', vtable => 'taint', 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', desc => 'vec() lvalue' },
+     vstring => { char => 'V', desc => 'SV was vstring literal' },
+     utf8 => { char => 'w', vtable => 'utf8',
+              desc => 'Cached UTF-8 information' },
+     substr => { char => 'x', vtable => 'substr', desc => 'substr() lvalue' },
+     defelem => { char => 'y', vtable => 'defelem',
+                 desc => 'Shadow "foreach" iterator variable / smart parameter vivification' },
+     arylen => { char => '#', vtable => 'arylen',
+                desc => 'Array length ($#ary)' },
+     pos => { char => '.', vtable => 'pos', desc => 'pos() lvalue' },
+     backref => { char => '<', vtable => 'backref',
+                 desc => 'for weak ref data' },
+     symtab => { char => ':', desc => 'extra data for symbol tables' },
+     rhash => { char => '%', desc => 'extra data for restricted hashes' },
+     arylen_p => { char => '@', desc => 'to move arylen out of XPVAV' },
+     ext => { char => '~', desc => 'Available for use by extensions' },
+     checkcall => { char => ']', desc => 'inlining/mutation of call to this CV'},
+);
+
 # These have a subtly different "namespace" from the magic types.
 my @sig =
     (
@@ -55,16 +126,39 @@ my @sig =
      'hints' => {clear => 'clearhints'},
 );
 
-my $h = open_new('mg_vtable.h', '>',
-                { by => 'regen/mg_vtable.pl', file => 'mg_vtable.h',
-                  style => '*' });
+my ($vt, $raw) = map {
+    open_new($_, '>',
+            { by => 'regen/mg_vtable.pl', file => $_, style => '*' });
+} 'mg_vtable.h', 'mg_raw.h';
+
+# 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)
+
+{
+    while (my ($name, $data) = splice @mg, 0, 2) {
+       my $i = ord eval qq{"$data->{char}"};
+       unless ($data->{unknown_to_sv_magic}) {
+           my $vtable = $data->{vtable}
+               ? "want_vtbl_$data->{vtable}" : 'magic_vtable_max';
+           my $comment = "/* $name '$data->{char}' $data->{desc} */";
+           $comment =~ s/([\\"])/\\$1/g;
+           print $raw qq{    { '$data->{char}', "$vtable",\n      "$comment" },\n};
+       }
+    }
+}
 
 {
     my @names = grep {!ref $_} @sig;
     my $want = join ",\n    ", (map {"want_vtbl_$_"} @names), 'magic_vtable_max';
     my $names = join qq{",\n    "}, @names;
 
-    print $h <<"EOH";
+    print $vt <<"EOH";
 enum {         /* pass one of these to get_vtbl */
     $want
 };
@@ -80,7 +174,7 @@ EXTCONST char *PL_magic_vtable_names[magic_vtable_max];
 EOH
 }
 
-print $h <<'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.
@@ -117,9 +211,9 @@ while (my ($name, $data) = splice @sig, 0, 2) {
     # Because we can't have a , after the last {...}
     my $comma = @sig ? ',' : '';
 
-    print $h "$data->{cond}\n" if $data->{cond};
-    print $h "  { $funcs }$comma\n";
-    print $h <<"EOH" if $data->{cond};
+    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
@@ -130,7 +224,7 @@ EOH
     }
 }
 
-print $h <<'EOH';
+print $vt <<'EOH';
 };
 #else
 EXT_MGVTBL PL_magic_vtables[magic_vtable_max];
@@ -138,9 +232,9 @@ EXT_MGVTBL PL_magic_vtables[magic_vtable_max];
 
 EOH
 
-print $h (sort @aliases), "\n";
+print $vt (sort @aliases), "\n";
 
-print $h "#define PL_vtbl_$_ PL_magic_vtables[want_vtbl_$_]\n"
+print $vt "#define PL_vtbl_$_ PL_magic_vtables[want_vtbl_$_]\n"
     foreach sort @vtable_names;
 
-read_only_bottom_close_and_rename($h);
+read_only_bottom_close_and_rename($_) foreach $vt, $raw;

diff --git a/sv.c b/sv.c
index b76e076..779da64 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -5239,6 +5239,7 @@ Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
     dVAR;
     const MGVTBL *vtable;
     MAGIC* mg;
+    unsigned int vtable_index;
 
     PERL_ARGS_ASSERT_SV_MAGIC;
 
@@ -5279,120 +5280,17 @@ Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
        }
     }
 
-    switch (how) {
-    case PERL_MAGIC_sv:
-       vtable = &PL_vtbl_sv;
-       break;
-    case PERL_MAGIC_overload:
-        vtable = &PL_vtbl_amagic;
-        break;
-    case PERL_MAGIC_overload_elem:
-        vtable = &PL_vtbl_amagicelem;
-        break;
-    case PERL_MAGIC_overload_table:
-        vtable = &PL_vtbl_ovrld;
-        break;
-    case PERL_MAGIC_regdata:
-       vtable = &PL_vtbl_regdata;
-       break;
-    case PERL_MAGIC_regdatum:
-       vtable = &PL_vtbl_regdatum;
-       break;
-    case PERL_MAGIC_env:
-       vtable = &PL_vtbl_env;
-       break;
-    case PERL_MAGIC_envelem:
-       vtable = &PL_vtbl_envelem;
-       break;
-    case PERL_MAGIC_regex_global:
-       vtable = &PL_vtbl_mglob;
-       break;
-    case PERL_MAGIC_isa:
-       vtable = &PL_vtbl_isa;
-       break;
-    case PERL_MAGIC_isaelem:
-       vtable = &PL_vtbl_isaelem;
-       break;
-    case PERL_MAGIC_nkeys:
-       vtable = &PL_vtbl_nkeys;
-       break;
-    case PERL_MAGIC_dbline:
-       vtable = &PL_vtbl_dbline;
-       break;
-#ifdef USE_LOCALE_COLLATE
-    case PERL_MAGIC_collxfrm:
-        vtable = &PL_vtbl_collxfrm;
-        break;
-#endif /* USE_LOCALE_COLLATE */
-    case PERL_MAGIC_tied:
-       vtable = &PL_vtbl_pack;
-       break;
-    case PERL_MAGIC_tiedelem:
-    case PERL_MAGIC_tiedscalar:
-       vtable = &PL_vtbl_packelem;
-       break;
-    case PERL_MAGIC_fm:
-    case PERL_MAGIC_bm:
-    case PERL_MAGIC_qr:
-       vtable = &PL_vtbl_regexp;
-       break;
-#ifndef PERL_MICRO
-    case PERL_MAGIC_sigelem:
-       vtable = &PL_vtbl_sigelem;
-       break;
-#endif
-    case PERL_MAGIC_taint:
-       vtable = &PL_vtbl_taint;
-       break;
-    case PERL_MAGIC_uvar:
-       vtable = &PL_vtbl_uvar;
-       break;
-    case PERL_MAGIC_vec:
-       vtable = &PL_vtbl_vec;
-       break;
-    case PERL_MAGIC_dbfile:
-    case PERL_MAGIC_sig:
-    case PERL_MAGIC_arylen_p:
-    case PERL_MAGIC_rhash:
-    case PERL_MAGIC_symtab:
-    case PERL_MAGIC_vstring:
-    case PERL_MAGIC_checkcall:
-       vtable = NULL;
-       break;
-    case PERL_MAGIC_utf8:
-       vtable = &PL_vtbl_utf8;
-       break;
-    case PERL_MAGIC_substr:
-       vtable = &PL_vtbl_substr;
-       break;
-    case PERL_MAGIC_defelem:
-       vtable = &PL_vtbl_defelem;
-       break;
-    case PERL_MAGIC_arylen:
-       vtable = &PL_vtbl_arylen;
-       break;
-    case PERL_MAGIC_pos:
-       vtable = &PL_vtbl_pos;
-       break;
-    case PERL_MAGIC_backref:
-       vtable = &PL_vtbl_backref;
-       break;
-    case PERL_MAGIC_hintselem:
-       vtable = &PL_vtbl_hintselem;
-       break;
-    case PERL_MAGIC_hints:
-       vtable = &PL_vtbl_hints;
-       break;
-    case PERL_MAGIC_ext:
-       /* Reserved for use by extensions not perl internals.           */
-       /* Useful for attaching extension internal data to perl vars.   */
-       /* Note that multiple extensions may clash if magical scalars   */
-       /* etc holding private data from one are passed to another.     */
-       vtable = NULL;
-       break;
-    default:
+    if (how < 0 || how > C_ARRAY_LENGTH(PL_magic_data)
+       || (vtable_index = PL_magic_data[how]) > magic_vtable_max)
        Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
-    }
+
+    /* PERL_MAGIC_ext is reserved for use by extensions not perl internals.
+       Useful for attaching extension internal data to perl vars.
+       Note that multiple extensions may clash if magical scalars
+       etc holding private data from one are passed to another. */
+
+    vtable = (vtable_index == magic_vtable_max)
+       ? NULL : PL_magic_vtables + vtable_index;
 
     /* Rest of work is done else where */
     mg = sv_magicext(sv,obj,how,vtable,name,namlen);

diff --git a/t/porting/regen.t b/t/porting/regen.t
index 0e052dd..b644d70 100644 (file)
--- a/t/porting/regen.t
+++ b/t/porting/regen.t
@@ -27,7 +27,7 @@ if ( $^O eq "VMS" ) {
   skip_all( "- regen.pl needs porting." );
 }
 
-my $in_regen_pl = 18; # I can't see a clean way to calculate this automatically.
+my $in_regen_pl = 19; # I can't see a clean way to calculate this automatically.
 my @files = qw(perly.act perly.h perly.tab keywords.c keywords.h uconfig.h);
 my @progs = qw(Porting/makemeta regen/regcharclass.pl regen/mk_PL_charclass.pl);
 

diff --git a/vms/descrip_mms.template b/vms/descrip_mms.template
index 31faefb..200ab25 100644 (file)
--- a/vms/descrip_mms.template
+++ b/vms/descrip_mms.template
@@ -508,16 +508,16 @@ perlmini.c : perl.c
 perlmini$(O) : perlmini.c
        $(CC) $(CORECFLAGS) $(MMS$SOURCE)
 
-bitcount.h : uudmap.h 
+bitcount.h mg_data.h : uudmap.h 
        @ $(NOOP)
 
 uudmap.h : generate_uudmap$(E)
-       MCR SYS$DISK:[]generate_uudmap$(E) uudmap.h bitcount.h
+       MCR SYS$DISK:[]generate_uudmap$(E) uudmap.h bitcount.h mg_data.h
 
 generate_uudmap$(E) : generate_uudmap$(O) $(CRTL)
        Link $(LINKFLAGS)/NoDebug/Trace/NoMap/NoFull/NoCross/Exe=$(MMS$TARGET) generate_uudmap$(O) $(CRTLOPTS)
 
-generate_uudmap$(O) : generate_uudmap.c
+generate_uudmap$(O) : generate_uudmap.c mg_raw.h
         $(CC) $(CORECFLAGS) $(MMS$SOURCE)
 
 # The following files are built in one go by gen_shrfls.pl:
@@ -1756,7 +1756,7 @@ doop$(O) : doop.c $(h)
        $(CC) $(CORECFLAGS) $(MMS$SOURCE)
 dump$(O) : dump.c $(h)
        $(CC) $(CORECFLAGS) $(MMS$SOURCE)
-globals$(O) : globals.c uudmap.h bitcount.h $(h)
+globals$(O) : globals.c uudmap.h bitcount.h mg_data.h $(h)
         $(CC) $(CORECFLAGS) $(MMS$SOURCE)
 gv$(O) : gv.c $(h)
        $(CC) $(CORECFLAGS) $(MMS$SOURCE)
@@ -1891,6 +1891,7 @@ tidy : cleanlis
        - If F$Search("perlmain.c;-1")   .nes."" Then Purge/NoConfirm/Log perlmain.c
        - If F$Search("uudmap.h;-1")   .nes."" Then Purge/NoConfirm/Log uudmap.h
        - If F$Search("bitcount.h;-1")   .nes."" Then Purge/NoConfirm/Log bitcount.h
+       - If F$Search("mg_data.h;-1")   .nes."" Then Purge/NoConfirm/Log mg_data.h
        - If F$Search("Perlshr_Gbl*.Mar;-1")   .nes."" Then Purge/NoConfirm/Log Perlshr_Gbl*.Mar
        - If F$Search("[.ext.Opcode...];-1").nes."" Then Purge/NoConfirm/Log [.ext.Opcode]
        - If F$Search("[.vms.ext...]*.C;-1").nes."" Then Purge/NoConfirm/Log [.vms.ext...]*.C
@@ -1924,6 +1925,7 @@ clean : tidy cleantest
        - If F$Search("perlmini.c")   .nes."" Then Delete/NoConfirm/Log perlmini.c;*
        - If F$Search("uudmap.h")   .nes."" Then Delete/NoConfirm/Log uudmap.h;*
        - If F$Search("bitcount.h")   .nes."" Then Delete/NoConfirm/Log bitcount.h;*
+       - If F$Search("mg_data.h")   .nes."" Then Delete/NoConfirm/Log md_data.h;*
        - If F$Search("Perlshr_Gbl*.Mar")   .nes."" Then Delete/NoConfirm/Log Perlshr_Gbl*.Mar;*
        - If F$Search("*.TS").nes."" Then Delete/NoConfirm/Log *.TS;*
        - If F$Search("[.vms.ext...]*.C").nes."" Then Delete/NoConfirm/Log [.vms.ext...]*.C;*

diff --git a/win32/Makefile b/win32/Makefile
index eea0545..2619992 100644 (file)
--- a/win32/Makefile
+++ b/win32/Makefile
@@ -726,6 +726,7 @@ CORE_H              = $(CORE_NOCFG_H) .\config.h ..\git_version.h
 
 UUDMAP_H       = ..\uudmap.h
 BITCOUNT_H     = ..\bitcount.h
+MG_DATA_H      = ..\mg_data.h
 
 MICROCORE_OBJ  = $(MICROCORE_SRC:.c=.obj)
 CORE_OBJ       = $(MICROCORE_OBJ) $(EXTRACORE_SRC:.c=.obj)
@@ -947,12 +948,14 @@ $(X2P) : $(MINIPERL) $(X2P_OBJ) Extensions
 <<
        $(EMBED_EXE_MANI)
 
-$(MINIDIR)\globals$(o) : $(UUDMAP_H) $(BITCOUNT_H)
+$(MINIDIR)\globals$(o) : $(UUDMAP_H) $(BITCOUNT_H) $(MG_DATA_H)
 
-$(UUDMAP_H) : $(BITCOUNT_H)
+$(UUDMAP_H) $(MG_DATA_H) : $(BITCOUNT_H)
 
 $(BITCOUNT_H) : $(GENUUDMAP)
-       $(GENUUDMAP) $(UUDMAP_H) $(BITCOUNT_H)
+       $(GENUUDMAP) $(UUDMAP_H) $(BITCOUNT_H) $(MG_DATA_H)
+
+$(GENUUDMAP_OBJ) : ..\mg_raw.h
 
 $(GENUUDMAP) : $(GENUUDMAP_OBJ)
        $(LINK32) -subsystem:console -out:$@ @<<
@@ -1279,7 +1282,7 @@ _clean :
        -@$(DEL) $(PERLSTATICLIB)
        -@$(DEL) $(PERLDLL)
        -@$(DEL) $(CORE_OBJ)
-       -@$(DEL) $(GENUUDMAP) $(GENUUDMAP_OBJ) $(UUDMAP_H) $(BITCOUNT_H)
+       -@$(DEL) $(GENUUDMAP) $(GENUUDMAP_OBJ) $(UUDMAP_H) $(BITCOUNT_H) $(MG_DATA_H)
        -if exist $(MINIDIR) rmdir /s /q $(MINIDIR)
        -if exist $(UNIDATADIR1) rmdir /s /q $(UNIDATADIR1)
        -if exist $(UNIDATADIR2) rmdir /s /q $(UNIDATADIR2)

diff --git a/win32/makefile.mk b/win32/makefile.mk
index 2cbcdea..4acac4c 100644 (file)
--- a/win32/makefile.mk
+++ b/win32/makefile.mk
@@ -921,6 +921,7 @@ CORE_H              = $(CORE_NOCFG_H) .\config.h ..\git_version.h
 
 UUDMAP_H       = ..\uudmap.h
 BITCOUNT_H     = ..\bitcount.h
+MG_DATA_H      = ..\mg_data.h
 
 MICROCORE_OBJ  = $(MICROCORE_SRC:db:+$(o))
 CORE_OBJ       = $(MICROCORE_OBJ) $(EXTRACORE_SRC:db:+$(o))
@@ -1292,12 +1293,14 @@ $(X2P) : $(MINIPERL) $(X2P_OBJ) Extensions
        $(EMBED_EXE_MANI)
 .ENDIF
 
-$(MINIDIR)\globals$(o) : $(UUDMAP_H) $(BITCOUNT_H)
+$(MINIDIR)\globals$(o) : $(UUDMAP_H) $(BITCOUNT_H) $(MG_DATA_H)
 
-$(UUDMAP_H) : $(BITCOUNT_H)
+$(UUDMAP_H) $(MG_DATA_H) : $(BITCOUNT_H)
 
 $(BITCOUNT_H) : $(GENUUDMAP)
-       $(GENUUDMAP) $(UUDMAP_H) $(BITCOUNT_H)
+       $(GENUUDMAP) $(UUDMAP_H) $(BITCOUNT_H) $(MG_DATA_H)
+
+$(GENUUDMAP_OBJ) : ..\mg_raw.h
 
 $(GENUUDMAP) : $(GENUUDMAP_OBJ)
 .IF "$(CCTYPE)" == "BORLAND"
@@ -1669,7 +1672,7 @@ _clean :
        -@erase $(PERLSTATICLIB)
        -@erase $(PERLDLL)
        -@erase $(CORE_OBJ)
-       -@erase $(GENUUDMAP) $(GENUUDMAP_OBJ) $(UUDMAP_H) $(BITCOUNT_H)
+       -@erase $(GENUUDMAP) $(GENUUDMAP_OBJ) $(UUDMAP_H) $(BITCOUNT_H) $(MG_DATA_H)
        -if exist $(MINIDIR) rmdir /s /q $(MINIDIR)
        -if exist $(UNIDATADIR1) rmdir /s /q $(UNIDATADIR1)
        -if exist $(UNIDATADIR2) rmdir /s /q $(UNIDATADIR2)