In perl.git, the branch smoke-me/vtbl has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/cf395be7e975b8f37c27c237eba305b1596dad2e?hp=452cca5ccbee507639e1f443a4b39eb052a1015b>
- Log -----------------------------------------------------------------
commit cf395be7e975b8f37c27c237eba305b1596dad2e
Author: Nicholas Clark <n...@ccl4.org>
Date: Sun May 15 14:45:53 2011 +0100
In PL_magic_data flag whether magic can be added to a readonly value.
Use this to simplify the logic in Perl_sv_magic().
This introduces a small change of behaviour for error cases involving
unknown
magic types. Previously, if Perl_sv_magic() was passed a magic type unknown
to
it, it would
1: Croak "Modification of a read-only value attempted" if read only
2: Return without error if the SV happened to already have this magic
3: otherwise croak "Don't know how to handle magic of type \\%o"
Now it will always croak "Don't know how to handle magic of type \\%o", even
on read only values, or SVs which already have the unknown magic type.
M mg_raw.h
M perl.h
M regen/mg_vtable.pl
M sv.c
commit 63efdc9965894e92d60b0b1c0aeffa3687e09412
Author: Nicholas Clark <n...@ccl4.org>
Date: Sun May 15 13:54:19 2011 +0100
Store a flag for container/value magic in PL_magic_data.
Use this to replace S_is_container_magic() in mg.c with a direct lookup.
M mg.c
M mg_raw.h
M perl.h
M regen/mg_vtable.pl
M sv.c
commit da86261127c75edda993a3e1a32c377b8e5ac34a
Author: Nicholas Clark <n...@ccl4.org>
Date: Sun May 15 13:21:09 2011 +0100
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
M MANIFEST
M Makefile.SH
M Makefile.micro
M generate_uudmap.c
M globvar.sym
A mg_raw.h
M perl.h
M regen/mg_vtable.pl
M sv.c
M t/porting/regen.t
M vms/descrip_mms.template
M win32/Makefile
M win32/makefile.mk
commit da7ac0b3bde1534777493a7852e7bffe8d8c39a3
Author: Nicholas Clark <n...@ccl4.org>
Date: Sun May 15 12:02:28 2011 +0100
Refactor generate_uudmap.c to use a helper function to output init blocks.
In future, this will allow it to generate other output formats without
duplicating code.
M generate_uudmap.c
-----------------------------------------------------------------------
Summary of changes:
MANIFEST | 1 +
Makefile.SH | 10 ++-
Makefile.micro | 8 +-
generate_uudmap.c | 90 ++++++++++++++++++++++++-----
globvar.sym | 1 +
mg.c | 41 +-------------
mg_raw.h | 90 ++++++++++++++++++++++++++++++
perl.h | 17 ++++++
regen/mg_vtable.pl | 139 ++++++++++++++++++++++++++++++++++++++++++----
sv.c | 137 ++++++---------------------------------------
t/porting/regen.t | 2 +-
vms/descrip_mms.template | 10 ++-
win32/Makefile | 11 ++-
win32/makefile.mk | 11 ++-
14 files changed, 361 insertions(+), 207 deletions(-)
create mode 100644 mg_raw.h
diff --git a/MANIFEST b/MANIFEST
index b7add30..e056cef 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4118,6 +4118,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 33f8505..a374300 100755
--- a/Makefile.SH
+++ b/Makefile.SH
@@ -619,12 +619,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)
@@ -1213,7 +1215,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
--- 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 2c3e24a..7fdc7c3 100644
--- a/generate_uudmap.c
+++ b/generate_uudmap.c
@@ -12,17 +12,47 @@
"hello world" won't port easily to it. */
#include <errno.h>
-void output_block_to_file(const char *progname, const char *filename,
- const char *block, size_t count) {
- FILE *const out = fopen(filename, "w");
-
- if (!out) {
- fprintf(stderr, "%s: Could not open '%s': %s\n", progname, filename,
- strerror(errno));
- exit(1);
+struct mg_data_raw_t {
+ unsigned char type;
+ const char *value;
+ const char *comment;
+};
+
+static struct mg_data_raw_t mg_data_raw[] = {
+#include "mg_raw.h"
+ {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;
- fputs("{\n ", out);
+ fputs(" ", out);
while (count--) {
fprintf(out, "%d", *block);
block++;
@@ -33,7 +63,24 @@ void output_block_to_file(const char *progname, const char
*filename,
}
}
}
- fputs("\n}\n", out);
+ fputc('\n', out);
+}
+
+static void
+output_to_file(const char *progname, const char *filename,
+ void (format_function)(FILE *out, const void *thing, size_t
count),
+ const void *thing, size_t count) {
+ FILE *const out = fopen(filename, "w");
+
+ if (!out) {
+ fprintf(stderr, "%s: Could not open '%s': %s\n", progname, filename,
+ strerror(errno));
+ exit(1);
+ }
+
+ fputs("{\n", out);
+ format_function(out, thing, count);
+ fputs("}\n", out);
if (fclose(out)) {
fprintf(stderr, "%s: Could not close '%s': %s\n", progname, filename,
@@ -55,9 +102,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;
}
@@ -69,7 +118,8 @@ int main(int argc, char **argv) {
*/
PL_uudmap[(U8)' '] = 0;
- output_block_to_file(argv[0], argv[1], PL_uudmap, sizeof(PL_uudmap));
+ output_to_file(argv[0], argv[1], &format_char_block,
+ (const void *)PL_uudmap, sizeof(PL_uudmap));
for (bits = 1; bits < 256; bits++) {
if (bits & 1) PL_bitcount[bits]++;
@@ -82,9 +132,17 @@ int main(int argc, char **argv) {
if (bits & 128) PL_bitcount[bits]++;
}
- output_block_to_file(argv[0], argv[2], PL_bitcount, sizeof(PL_bitcount));
+ 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 c6355c9..a12c322 100644
--- a/globvar.sym
+++ b/globvar.sym
@@ -12,6 +12,7 @@ fold_latin1
fold_locale
freq
keyword_plugin
+magic_data
magic_vtables
magic_vtable_names
memory_wrap
diff --git a/mg.c b/mg.c
index 04daa32..3af646f 100644
--- a/mg.c
+++ b/mg.c
@@ -164,42 +164,6 @@ Perl_mg_magical(pTHX_ SV *sv)
}
}
-
-/* is this container magic (%ENV, $1 etc), or value magic (pos, taint etc)? */
-
-STATIC bool
-S_is_container_magic(const MAGIC *mg)
-{
- assert(mg);
- switch (mg->mg_type) {
- case PERL_MAGIC_bm:
- case PERL_MAGIC_fm:
- case PERL_MAGIC_regex_global:
- case PERL_MAGIC_nkeys:
-#ifdef USE_LOCALE_COLLATE
- case PERL_MAGIC_collxfrm:
-#endif
- case PERL_MAGIC_qr:
- case PERL_MAGIC_taint:
- case PERL_MAGIC_vec:
- case PERL_MAGIC_vstring:
- case PERL_MAGIC_utf8:
- case PERL_MAGIC_substr:
- case PERL_MAGIC_defelem:
- case PERL_MAGIC_arylen:
- case PERL_MAGIC_pos:
- case PERL_MAGIC_backref:
- case PERL_MAGIC_arylen_p:
- case PERL_MAGIC_rhash:
- case PERL_MAGIC_symtab:
- case PERL_MAGIC_tied: /* treat as value, so 'local @tied' isn't tied */
- case PERL_MAGIC_checkcall:
- return 0;
- default:
- return 1;
- }
-}
-
/*
=for apidoc mg_get
@@ -296,7 +260,8 @@ Perl_mg_set(pTHX_ SV *sv)
mg->mg_flags &= ~MGf_GSKIP; /* setting requires another read */
(SSPTR(mgs_ix, MGS*))->mgs_magical = 0;
}
- if (PL_localizing == 2 && (!S_is_container_magic(mg) || sv == DEFSV))
+ if (PL_localizing == 2
+ && (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type) || sv == DEFSV))
continue;
if (vtbl && vtbl->svt_set)
vtbl->svt_set(aTHX_ sv, mg);
@@ -526,7 +491,7 @@ Perl_mg_localize(pTHX_ SV *sv, SV *nsv, bool setmagic)
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
const MGVTBL* const vtbl = mg->mg_virtual;
- if (!S_is_container_magic(mg))
+ if (PERL_MAGIC_TYPE_IS_VALUE_MAGIC(mg->mg_type))
continue;
if ((mg->mg_flags & MGf_LOCAL) && vtbl->svt_local)
diff --git a/mg_raw.h b/mg_raw.h
new file mode 100644
index 0000000..7ed04ee
--- /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 | PERL_MAGIC_READONLY_ACCEPTABLE",
+ "/* 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 | PERL_MAGIC_READONLY_ACCEPTABLE |
PERL_MAGIC_VALUE_MAGIC",
+ "/* 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 | PERL_MAGIC_READONLY_ACCEPTABLE |
PERL_MAGIC_VALUE_MAGIC",
+ "/* fm 'f' Formline ('compiled' format) */" },
+ { 'g', "want_vtbl_mglob | PERL_MAGIC_READONLY_ACCEPTABLE |
PERL_MAGIC_VALUE_MAGIC",
+ "/* 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 | PERL_MAGIC_VALUE_MAGIC",
+ "/* 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 | PERL_MAGIC_VALUE_MAGIC",
+ "/* collxfrm 'o' Locale transformation */" },
+ { 'P', "want_vtbl_pack | PERL_MAGIC_VALUE_MAGIC",
+ "/* 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 | PERL_MAGIC_VALUE_MAGIC",
+ "/* 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 | PERL_MAGIC_VALUE_MAGIC",
+ "/* taint 't' Taintedness */" },
+ { 'U', "want_vtbl_uvar",
+ "/* uvar 'U' Available for use by extensions */" },
+ { 'v', "want_vtbl_vec | PERL_MAGIC_VALUE_MAGIC",
+ "/* vec 'v' vec() lvalue */" },
+ { 'V', "magic_vtable_max | PERL_MAGIC_VALUE_MAGIC",
+ "/* vstring 'V' SV was vstring literal */" },
+ { 'w', "want_vtbl_utf8 | PERL_MAGIC_VALUE_MAGIC",
+ "/* utf8 'w' Cached UTF-8 information */" },
+ { 'x', "want_vtbl_substr | PERL_MAGIC_VALUE_MAGIC",
+ "/* substr 'x' substr() lvalue */" },
+ { 'y', "want_vtbl_defelem | PERL_MAGIC_VALUE_MAGIC",
+ "/* defelem 'y' Shadow \"foreach\" iterator variable / smart parameter
vivification */" },
+ { '#', "want_vtbl_arylen | PERL_MAGIC_VALUE_MAGIC",
+ "/* arylen '#' Array length ($#ary) */" },
+ { '.', "want_vtbl_pos | PERL_MAGIC_VALUE_MAGIC",
+ "/* pos '.' pos() lvalue */" },
+ { '<', "want_vtbl_backref | PERL_MAGIC_READONLY_ACCEPTABLE |
PERL_MAGIC_VALUE_MAGIC",
+ "/* backref '<' for weak ref data */" },
+ { ':', "magic_vtable_max | PERL_MAGIC_VALUE_MAGIC",
+ "/* symtab ':' extra data for symbol tables */" },
+ { '%', "magic_vtable_max | PERL_MAGIC_VALUE_MAGIC",
+ "/* rhash '%' extra data for restricted hashes */" },
+ { '@', "magic_vtable_max | PERL_MAGIC_VALUE_MAGIC",
+ "/* arylen_p '@' to move arylen out of XPVAV */" },
+ { '~', "magic_vtable_max",
+ "/* ext '~' Available for use by extensions */" },
+ { ']', "magic_vtable_max | PERL_MAGIC_VALUE_MAGIC",
+ "/* checkcall ']' inlining/mutation of call to this CV */" },
+
+/* ex: set ro: */
diff --git a/perl.h b/perl.h
index 9c00120..9405788 100644
--- a/perl.h
+++ b/perl.h
@@ -5071,7 +5071,24 @@ START_EXTERN_C
# define EXT_MGVTBL EXT MGVTBL
#endif
+#define PERL_MAGIC_READONLY_ACCEPTABLE 0x40
+#define PERL_MAGIC_VALUE_MAGIC 0x80
+#define PERL_MAGIC_VTABLE_MASK 0x3F
+#define PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(t) \
+ (PL_magic_data[(U8)(t)] & PERL_MAGIC_READONLY_ACCEPTABLE)
+#define PERL_MAGIC_TYPE_IS_VALUE_MAGIC(t) \
+ (PL_magic_data[(U8)(t)] & PERL_MAGIC_VALUE_MAGIC)
+
#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..8b587ff 100644
--- a/regen/mg_vtable.pl
+++ b/regen/mg_vtable.pl
@@ -18,6 +18,92 @@ BEGIN {
require 'regen/regen_lib.pl';
}
+my @mg =
+ (
+ sv => { char => '\0', vtable => 'sv', readonly_acceptable => 1,
+ 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', value_magic => 1,
+ readonly_acceptable => 1,
+ 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', 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 / 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', value_magic => 1,
+ 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', 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,
+ 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 / smart 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' },
+ checkcall => { char => ']', value_magic => 1,
+ desc => 'inlining/mutation of call to this CV'},
+);
+
# These have a subtly different "namespace" from the magic types.
my @sig =
(
@@ -55,16 +141,42 @@ 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 $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->{char}' $data->{desc} */";
+ $comment =~ s/([\\"])/\\$1/g;
+ print $raw qq{ { '$data->{char}', "$value",\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 +192,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 +229,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 +242,7 @@ EOH
}
}
-print $h <<'EOH';
+print $vt <<'EOH';
};
#else
EXT_MGVTBL PL_magic_vtables[magic_vtable_max];
@@ -138,9 +250,12 @@ 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);
+# 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;
diff --git a/sv.c b/sv.c
index 957dc80..fd5c262 100644
--- a/sv.c
+++ b/sv.c
@@ -5243,9 +5243,25 @@ Perl_sv_magic(pTHX_ register SV *const sv, SV *const
obj, const int how,
dVAR;
const MGVTBL *vtable;
MAGIC* mg;
+ unsigned int flags;
+ unsigned int vtable_index;
PERL_ARGS_ASSERT_SV_MAGIC;
+ if (how < 0 || how > C_ARRAY_LENGTH(PL_magic_data)
+ || ((flags = PL_magic_data[how]),
+ (vtable_index = flags & PERL_MAGIC_VTABLE_MASK)
+ > 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;
+
#ifdef PERL_OLD_COPY_ON_WRITE
if (SvIsCOW(sv))
sv_force_normal_flags(sv, 0);
@@ -5257,11 +5273,7 @@ Perl_sv_magic(pTHX_ register SV *const sv, SV *const
obj, const int how,
!(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG)
&& IN_PERL_RUNTIME
- && how != PERL_MAGIC_regex_global
- && how != PERL_MAGIC_bm
- && how != PERL_MAGIC_fm
- && how != PERL_MAGIC_sv
- && how != PERL_MAGIC_backref
+ && !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how)
)
{
Perl_croak_no_modify(aTHX);
@@ -5283,121 +5295,6 @@ 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:
- Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
- }
-
/* 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
--- 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 a3a48b1..5145cde 100644
--- 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:
@@ -1752,7 +1752,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)
@@ -1887,6 +1887,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
@@ -1920,6 +1921,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 2a35c31..6ca3f94 100644
--- 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 a6e1593..26869aa 100644
--- a/win32/makefile.mk
+++ b/win32/makefile.mk
@@ -937,6 +937,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))
@@ -1308,12 +1309,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"
@@ -1676,7 +1679,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)
--
Perl5 Master Repository
