diff options
| -rw-r--r-- | mg_raw.h | 10 | ||||
| -rw-r--r-- | perl.h | 3 | ||||
| -rw-r--r-- | regen/mg_vtable.pl | 11 | ||||
| -rw-r--r-- | sv.c | 34 |
4 files changed, 32 insertions, 26 deletions
@@ -6,7 +6,7 @@ * Any changes made here will be lost! */ - { '\0', "want_vtbl_sv", + { '\0', "want_vtbl_sv | PERL_MAGIC_READONLY_ACCEPTABLE", "/* sv '\\0' Special scalar variable */" }, { 'A', "want_vtbl_amagic", "/* overload 'A' %OVERLOAD hash */" }, @@ -14,7 +14,7 @@ "/* 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_VALUE_MAGIC", + { '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) */" }, @@ -24,9 +24,9 @@ "/* env 'E' %ENV hash */" }, { 'e', "want_vtbl_envelem", "/* envelem 'e' %ENV hash element */" }, - { 'f', "want_vtbl_regdata | PERL_MAGIC_VALUE_MAGIC", + { 'f', "want_vtbl_regdata | PERL_MAGIC_READONLY_ACCEPTABLE | PERL_MAGIC_VALUE_MAGIC", "/* fm 'f' Formline ('compiled' format) */" }, - { 'g', "want_vtbl_mglob | PERL_MAGIC_VALUE_MAGIC", + { '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 */" }, @@ -74,7 +74,7 @@ "/* arylen '#' Array length ($#ary) */" }, { '.', "want_vtbl_pos | PERL_MAGIC_VALUE_MAGIC", "/* pos '.' pos() lvalue */" }, - { '<', "want_vtbl_backref | PERL_MAGIC_VALUE_MAGIC", + { '<', "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 */" }, @@ -5071,8 +5071,11 @@ 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) diff --git a/regen/mg_vtable.pl b/regen/mg_vtable.pl index 371ac98bc0..8b587ff1ac 100644 --- a/regen/mg_vtable.pl +++ b/regen/mg_vtable.pl @@ -20,13 +20,15 @@ BEGIN { my @mg = ( - sv => { char => '\0', vtable => 'sv', desc => 'Special scalar variable' }, + 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)' }, @@ -36,8 +38,9 @@ my @mg = envelem => { char => 'e', vtable => 'envelem', desc => '%ENV hash element' }, fm => { char => 'f', vtable => 'regdata', value_magic => 1, - desc => "Formline ('compiled' format)" }, + 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', @@ -89,7 +92,7 @@ my @mg = pos => { char => '.', vtable => 'pos', value_magic => 1, desc => 'pos() lvalue' }, backref => { char => '<', vtable => 'backref', value_magic => 1, - desc => 'for weak ref data' }, + readonly_acceptable => 1, desc => 'for weak ref data' }, symtab => { char => ':', value_magic => 1, desc => 'extra data for symbol tables' }, rhash => { char => '%', value_magic => 1, @@ -158,6 +161,8 @@ my ($vt, $raw) = map { 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; @@ -5239,10 +5239,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); @@ -5254,11 +5269,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); @@ -5280,19 +5291,6 @@ Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how, } } - if (how < 0 || how > C_ARRAY_LENGTH(PL_magic_data) - || ((vtable_index = PL_magic_data[how] & 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; - /* Rest of work is done else where */ mg = sv_magicext(sv,obj,how,vtable,name,namlen); |