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.

6 files changed, 23 insertions, 9 deletions

diff --git a/embed.fnc b/embed.fnc
index df387d19fb..af6119bd5b 100644
--- 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)
-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 \
diff --git a/embed.h b/embed.h
index 2fc8466bfa..528f0b0373 100644
--- 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 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)
diff --git a/mg.c b/mg.c
index 518d1085b4..e56f53db2d 100644
--- 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
-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;
 
-    PERL_ARGS_ASSERT_SAVE_MAGIC;
+    PERL_ARGS_ASSERT_SAVE_MAGIC_FLAGS;
 
     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;
 
-    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);
 }
 
+#define save_magic(a,b) save_magic_flags(a,b,SVs_GMG|SVs_SMG|SVs_RMG)
+
 /*
 =for apidoc mg_magical
 
@@ -263,7 +265,7 @@ Perl_mg_set(pTHX_ SV *sv)
 
     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;
diff --git a/proto.h b/proto.h
index 242e35b9e5..63d1c9c2b9 100644
--- 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);
-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);
-#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);
diff --git a/t/op/tie.t b/t/op/tie.t
index ad58af74c0..6ff5870ef6 100644
--- 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.
+########
+
+# 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 5fca6267a5..3969d11709 100644
--- a/t/op/ver.t
+++ b/t/op/ver.t
@@ -11,7 +11,7 @@ $DOWARN = 1; # enable run-time warnings now
 
 use Config;
 
-plan( tests => 57 );
+plan( tests => 58 );
 
 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';
 
+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