From: Nicholas Clark Date: Sun, 15 May 2011 13:45:53 +0000 (+0100) Subject: In PL_magic_data flag whether magic can be added to a readonly value. X-Git-Tag: accepted/trunk/20130322.191538~3805 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=82ff486e3dffdd873d119ab2245448a996948e2d;p=platform%2Fupstream%2Fperl.git 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. --- diff --git a/mg_raw.h b/mg_raw.h index aebd777..7ed04ee 100644 --- a/mg_raw.h +++ b/mg_raw.h @@ -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 */" }, diff --git a/perl.h b/perl.h index def6d1d..9405788 100644 --- a/perl.h +++ b/perl.h @@ -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 371ac98..8b587ff 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; diff --git a/sv.c b/sv.c index 67c07f8..86b1020 100644 --- a/sv.c +++ b/sv.c @@ -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);