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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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);