Make set-magic handle vstrings properly

Assigning a vstring to a tied variable would result in a plain string
in $_[1] in STORE.

Assigning a vstring to a magic deferred element would result in a
plain string in the aggregate’s actual element.

When magic is invoked, the magic flags are temporarily turned off on
the sv so that recursive calls to magic don’t happen.  This makes it
easier to implement functions like Perl_magic_set to read the value of
the sv without triggering get-magic.

Since vstrings are only considered vstrings when they are SvRMAGICAL,
this meant that set-magic would turn vstrings temporarily into plain
strings.  Subsequent copying (e.g., in STORE) would then fail to copy
the vstring magic.

This commit changes mg_set to leave the rmagical flag on, since it
does not affect the functionaiity of set-magic.

diff --git a/embed.fnc b/embed.fnc
index df387d1..af6119b 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1785,7 +1785,7 @@ sM        |void   |clear_placeholders     |NN HV *hv|U32 items
 #endif
 
 #if defined(PERL_IN_MG_C)
 #endif
 
 #if defined(PERL_IN_MG_C)

-s      |void   |save_magic     |I32 mgs_ix|NN SV *sv
+s      |void   |save_magic_flags|I32 mgs_ix|NN SV *sv|U32 flags

 -s     |int    |magic_methpack |NN SV *sv|NN const MAGIC *mg|NN SV *meth
 s      |SV*    |magic_methcall1|NN SV *sv|NN const MAGIC *mg \
                                |NN SV *meth|U32 flags \
 -s     |int    |magic_methpack |NN SV *sv|NN const MAGIC *mg|NN SV *meth
 s      |SV*    |magic_methcall1|NN SV *sv|NN const MAGIC *mg \
                                |NN SV *meth|U32 flags \

diff --git a/embed.h b/embed.h
index 2fc8466..528f0b0 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1395,7 +1395,7 @@
 #define magic_methcall1(a,b,c,d,e,f)   S_magic_methcall1(aTHX_ a,b,c,d,e,f)
 #define magic_methpack(a,b,c)  S_magic_methpack(aTHX_ a,b,c)
 #define restore_magic(a)       S_restore_magic(aTHX_ a)
 #define magic_methcall1(a,b,c,d,e,f)   S_magic_methcall1(aTHX_ a,b,c,d,e,f)
 #define magic_methpack(a,b,c)  S_magic_methpack(aTHX_ a,b,c)
 #define restore_magic(a)       S_restore_magic(aTHX_ a)

-#define save_magic(a,b)                S_save_magic(aTHX_ a,b)
+#define save_magic_flags(a,b,c)        S_save_magic_flags(aTHX_ a,b,c)

 #define unwind_handler_stack(a)        S_unwind_handler_stack(aTHX_ a)
 #  endif
 #  if defined(PERL_IN_MG_C) || defined(PERL_IN_PP_C)
 #define unwind_handler_stack(a)        S_unwind_handler_stack(aTHX_ a)
 #  endif
 #  if defined(PERL_IN_MG_C) || defined(PERL_IN_PP_C)

diff --git a/mg.c b/mg.c
index 518d108..e56f53d 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -90,13 +90,13 @@ struct magic_state {
 /* MGS is typedef'ed to struct magic_state in perl.h */
 
 STATIC void
 /* MGS is typedef'ed to struct magic_state in perl.h */
 
 STATIC void

-S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
+S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags)

 {
     dVAR;
     MGS* mgs;
     bool bumped = FALSE;
 
 {
     dVAR;
     MGS* mgs;
     bool bumped = FALSE;
 

-    PERL_ARGS_ASSERT_SAVE_MAGIC;
+    PERL_ARGS_ASSERT_SAVE_MAGIC_FLAGS;

 
     assert(SvMAGICAL(sv));
 
 
     assert(SvMAGICAL(sv));
 


@@ -120,12 +120,14 @@ S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
     mgs->mgs_ss_ix = PL_savestack_ix;   /* points after the saved destructor */
     mgs->mgs_bumped = bumped;
 
     mgs->mgs_ss_ix = PL_savestack_ix;   /* points after the saved destructor */
     mgs->mgs_bumped = bumped;
 

-    SvMAGICAL_off(sv);
+    SvFLAGS(sv) &= ~flags;

     /* Turning READONLY off for a copy-on-write scalar (including shared
        hash keys) is a bad idea.  */
     if (!SvIsCOW(sv)) SvREADONLY_off(sv);
 }
 
     /* Turning READONLY off for a copy-on-write scalar (including shared
        hash keys) is a bad idea.  */
     if (!SvIsCOW(sv)) SvREADONLY_off(sv);
 }
 

+#define save_magic(a,b) save_magic_flags(a,b,SVs_GMG|SVs_SMG|SVs_RMG)
+

 /*
 =for apidoc mg_magical
 
 /*
 =for apidoc mg_magical
 


@@ -263,7 +265,7 @@ Perl_mg_set(pTHX_ SV *sv)
 
     if (PL_localizing == 2 && sv == DEFSV) return 0;
 
 
     if (PL_localizing == 2 && sv == DEFSV) return 0;
 

-    save_magic(mgs_ix, sv);
+    save_magic_flags(mgs_ix, sv, SVs_GMG|SVs_SMG); /* leave SVs_RMG on */

 
     for (mg = SvMAGIC(sv); mg; mg = nextmg) {
         const MGVTBL* vtbl = mg->mg_virtual;
 
     for (mg = SvMAGIC(sv); mg; mg = nextmg) {
         const MGVTBL* vtbl = mg->mg_virtual;

diff --git a/proto.h b/proto.h
index 242e35b..63d1c9c 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -5792,9 +5792,9 @@ STATIC int        S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, SV *meth)
        assert(sv); assert(mg); assert(meth)
 
 STATIC void    S_restore_magic(pTHX_ const void *p);
        assert(sv); assert(mg); assert(meth)
 
 STATIC void    S_restore_magic(pTHX_ const void *p);

-STATIC void    S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
+STATIC void    S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags)

                        __attribute__nonnull__(pTHX_2);
                        __attribute__nonnull__(pTHX_2);

-#define PERL_ARGS_ASSERT_SAVE_MAGIC    \
+#define PERL_ARGS_ASSERT_SAVE_MAGIC_FLAGS      \

        assert(sv)
 
 STATIC void    S_unwind_handler_stack(pTHX_ const void *p);
        assert(sv)
 
 STATIC void    S_unwind_handler_stack(pTHX_ const void *p);

diff --git a/t/op/tie.t b/t/op/tie.t
index ad58af7..6ff5870 100644 (file)
--- a/t/op/tie.t
+++ b/t/op/tie.t
@@ -1332,3 +1332,11 @@ Can't call method "FETCHSIZE" on an undefined value at - line 5.
 Can't call method "FETCHSIZE" on an undefined value at - line 6.
 Can't call method "FETCHSIZE" on an undefined value at - line 7.
 Can't call method "FETCHSIZE" on an undefined value at - line 8.
 Can't call method "FETCHSIZE" on an undefined value at - line 6.
 Can't call method "FETCHSIZE" on an undefined value at - line 7.
 Can't call method "FETCHSIZE" on an undefined value at - line 8.

+########
+
+# Assigning vstrings to tied scalars
+sub TIESCALAR{bless[]};
+sub STORE { print ref \$_[1], "\n" }
+tie $x, ""; $x = v3;
+EXPECT
+VSTRING

diff --git a/t/op/ver.t b/t/op/ver.t
index 5fca626..3969d11 100644 (file)
--- a/t/op/ver.t
+++ b/t/op/ver.t
@@ -11,7 +11,7 @@ $DOWARN = 1; # enable run-time warnings now
 
 use Config;
 
 
 use Config;
 

-plan( tests => 57 );
+plan( tests => 58 );

 
 eval 'use v5.5.640';
 is( $@, '', "use v5.5.640; $@");
 
 eval 'use v5.5.640';
 is( $@, '', "use v5.5.640; $@");


@@ -276,6 +276,10 @@ is ref \$a, 'SCALAR',
 $a = v102; $a =~ y/f/g/;
 is ref \$a, 'SCALAR', 'y/// flattens vstrings';
 
 $a = v102; $a =~ y/f/g/;
 is ref \$a, 'SCALAR', 'y/// flattens vstrings';
 

+sub { $_[0] = v3;
+      is ref \$h{nonexistent}, 'VSTRING', 'defelems can pass vstrings' }
+->($h{nonexistent});
+

 # The following tests whether v-strings are correctly
 # interpreted by the tokeniser when it's in a XTERMORDORDOR
 # state (fittingly, the only tokeniser state to contain the
 # The following tests whether v-strings are correctly
 # interpreted by the tokeniser when it's in a XTERMORDORDOR
 # state (fittingly, the only tokeniser state to contain the