Flatten vstrings modified in place
authorFather Chrysostomos <sprout@cpan.org>
Sat, 28 Jul 2012 06:46:07 +0000 (23:46 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Sat, 28 Jul 2012 06:46:33 +0000 (23:46 -0700)
A substitution forces its target to a string upon successful substitu-
tion, even if the substitution did nothing:

$ ./perl -Ilib -le '$a = *f; $a =~ s/f/f/; print ref \$a'
SCALAR

Notice that $a is no longer a glob after s///.

But vstrings are different:

$ ./perl -Ilib -le '$a = v102; $a =~ s/f/f/; print ref \$a'
VSTRING

I fixed this in 5.16 (1e6bda93) for those cases where the vstring ends
up with a value that doesn’t correspond to the actual string:

$ ./perl -Ilib -le '$a = v102; $a =~ s/f/o/; print ref \$a'
SCALAR

It works through vstring set-magic, that does the check and removes
the magic if it doesn’t match.

I did it that way because I couldn’t think of any other way to fix
bug #29070, and I didn’t realise at the time that I hadn’t fixed
all the bugs.

By making SvTHINKFIRST true on a vstring, we force it through
sv_force_normal before any in-place string operations.  We can also
make sv_force_normal handle vstrings as well.  This fixes all the lin-
gering-vstring-magic bugs in just two lines, making the vstring set-
magic (which is also slow) redundant.  It also allows the special case
in sv_setsv_flags to be removed.

Or at least that was what I had hoped.

It turns out that pp_subst, twists and turns in tortuous ways, and
needs special treatment for things like this.

And do_trans functions wasn’t checking SvTHINKFIRST when arguably it
should have.

I tweaked sv_2pv{utf8,byte} to avoid copying magic variables that do
not need copying.

13 files changed:
doop.c
embed.fnc
embed.h
mg.c
mg_raw.h
mg_vtable.h
pod/perlguts.pod
pp_hot.c
proto.h
regen/mg_vtable.pl
sv.c
sv.h
t/op/ver.t

diff --git a/doop.c b/doop.c
index 1593d19..bfcdef5 100644 (file)
--- a/doop.c
+++ b/doop.c
@@ -641,7 +641,7 @@ Perl_do_trans(pTHX_ SV *sv)
     if (!len)
        return 0;
     if (!(PL_op->op_private & OPpTRANS_IDENTICAL)) {
-       if (!SvPOKp(sv))
+       if (!SvPOKp(sv) || SvTHINKFIRST(sv))
            (void)SvPV_force_nomg(sv, len);
        (void)SvPOK_only_UTF8(sv);
     }
index dd4daef..b3f757c 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -775,7 +775,6 @@ p   |int    |magic_settaint |NN SV* sv|NN MAGIC* mg
 p      |int    |magic_setuvar  |NN SV* sv|NN MAGIC* mg
 p      |int    |magic_setvec   |NN SV* sv|NN MAGIC* mg
 p      |int    |magic_setutf8  |NN SV* sv|NN MAGIC* mg
-p      |int    |magic_setvstring|NN SV* sv|NN MAGIC* mg
 p      |int    |magic_set_all_env|NN SV* sv|NN MAGIC* mg
 p      |U32    |magic_sizepack |NN SV* sv|NN MAGIC* mg
 p      |int    |magic_wipepack |NN SV* sv|NN MAGIC* mg
diff --git a/embed.h b/embed.h
index 5e9f6eb..50d2344 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define magic_setutf8(a,b)     Perl_magic_setutf8(aTHX_ a,b)
 #define magic_setuvar(a,b)     Perl_magic_setuvar(aTHX_ a,b)
 #define magic_setvec(a,b)      Perl_magic_setvec(aTHX_ a,b)
-#define magic_setvstring(a,b)  Perl_magic_setvstring(aTHX_ a,b)
 #define magic_sizepack(a,b)    Perl_magic_sizepack(aTHX_ a,b)
 #define magic_wipepack(a,b)    Perl_magic_wipepack(aTHX_ a,b)
 #define mg_localize(a,b,c)     Perl_mg_localize(aTHX_ a,b,c)
diff --git a/mg.c b/mg.c
index f4979f1..3b4ed1c 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -2325,19 +2325,6 @@ Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
     return 0;
 }
 
-int
-Perl_magic_setvstring(pTHX_ SV *sv, MAGIC *mg)
-{
-    PERL_ARGS_ASSERT_MAGIC_SETVSTRING;
-
-    if (SvPOKp(sv)) {
-       SV * const vecsv = sv_newmortal();
-       scan_vstring(mg->mg_ptr, mg->mg_ptr + mg->mg_len, vecsv);
-       if (sv_eq_flags(vecsv, sv, 0 /*nomg*/)) return 0;
-    }
-    return sv_unmagic(sv, mg->mg_type);
-}
-
 int
 Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
 {
index 76cf42f..f577087 100644 (file)
--- a/mg_raw.h
+++ b/mg_raw.h
@@ -68,7 +68,7 @@
       "/* taint 't' Taintedness */" },
     { 'U', "want_vtbl_uvar",
       "/* uvar 'U' Available for use by extensions */" },
-    { 'V', "want_vtbl_vstring | PERL_MAGIC_VALUE_MAGIC",
+    { 'V', "magic_vtable_max | PERL_MAGIC_VALUE_MAGIC",
       "/* vstring 'V' SV was vstring literal */" },
     { 'v', "want_vtbl_vec | PERL_MAGIC_VALUE_MAGIC",
       "/* vec 'v' vec() lvalue */" },
index 3c73c2b..2490394 100644 (file)
@@ -86,7 +86,6 @@ enum {                /* pass one of these to get_vtbl */
     want_vtbl_utf8,
     want_vtbl_uvar,
     want_vtbl_vec,
-    want_vtbl_vstring,
     magic_vtable_max
 };
 
@@ -120,8 +119,7 @@ EXTCONST char *PL_magic_vtable_names[magic_vtable_max] = {
     "taint",
     "utf8",
     "uvar",
-    "vec",
-    "vstring"
+    "vec"
 };
 #else
 EXTCONST char *PL_magic_vtable_names[magic_vtable_max];
@@ -182,8 +180,7 @@ EXT_MGVTBL PL_magic_vtables[magic_vtable_max] = {
   { Perl_magic_gettaint, Perl_magic_settaint, 0, 0, 0, 0, 0, 0 },
   { 0, Perl_magic_setutf8, 0, 0, 0, 0, 0, 0 },
   { Perl_magic_getuvar, Perl_magic_setuvar, 0, 0, 0, 0, 0, 0 },
-  { Perl_magic_getvec, Perl_magic_setvec, 0, 0, 0, 0, 0, 0 },
-  { 0, Perl_magic_setvstring, 0, 0, 0, 0, 0, 0 }
+  { Perl_magic_getvec, Perl_magic_setvec, 0, 0, 0, 0, 0, 0 }
 };
 #else
 EXT_MGVTBL PL_magic_vtables[magic_vtable_max];
@@ -223,6 +220,5 @@ EXT_MGVTBL PL_magic_vtables[magic_vtable_max];
 #define PL_vtbl_utf8 PL_magic_vtables[want_vtbl_utf8]
 #define PL_vtbl_uvar PL_magic_vtables[want_vtbl_uvar]
 #define PL_vtbl_vec PL_magic_vtables[want_vtbl_vec]
-#define PL_vtbl_vstring PL_magic_vtables[want_vtbl_vstring]
 
 /* ex: set ro: */
index 8f3ed0c..33bf007 100644 (file)
@@ -1103,7 +1103,7 @@ will be lost.
                                              extensions
  u  PERL_MAGIC_uvar_elem      (none)         Reserved for use by
                                              extensions
- V  PERL_MAGIC_vstring        vtbl_vstring   SV was vstring literal
+ V  PERL_MAGIC_vstring        (none)         SV was vstring literal
  v  PERL_MAGIC_vec            vtbl_vec       vec() lvalue
  w  PERL_MAGIC_utf8           vtbl_utf8      Cached UTF-8 information
  x  PERL_MAGIC_substr         vtbl_substr    substr() lvalue
index e04d5ca..72a812e 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2116,7 +2116,7 @@ PP(pp_subst)
 
   setup_match:
     s = SvPV_mutable(TARG, len);
-    if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
+    if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
        force_on_match = 1;
 
     /* only replace once? */
diff --git a/proto.h b/proto.h
index 1930ff3..3447f6c 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -2345,12 +2345,6 @@ PERL_CALLCONV int        Perl_magic_setvec(pTHX_ SV* sv, MAGIC* mg)
 #define PERL_ARGS_ASSERT_MAGIC_SETVEC  \
        assert(sv); assert(mg)
 
-PERL_CALLCONV int      Perl_magic_setvstring(pTHX_ SV* sv, MAGIC* mg)
-                       __attribute__nonnull__(pTHX_1)
-                       __attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_MAGIC_SETVSTRING      \
-       assert(sv); assert(mg)
-
 PERL_CALLCONV U32      Perl_magic_sizepack(pTHX_ SV* sv, MAGIC* mg)
                        __attribute__nonnull__(pTHX_1)
                        __attribute__nonnull__(pTHX_2);
index f96c7a0..5fcdc4c 100644 (file)
@@ -84,7 +84,7 @@ my %mg =
                    unknown_to_sv_magic => 1 },
      vec => { char => 'v', vtable => 'vec', value_magic => 1,
              desc => 'vec() lvalue' },
-     vstring => { char => 'V', value_magic => 1, vtable => 'vstring',
+     vstring => { char => 'V', value_magic => 1,
                  desc => 'SV was vstring literal' },
      utf8 => { char => 'w', vtable => 'utf8', value_magic => 1,
               desc => 'Cached UTF-8 information' },
@@ -142,7 +142,6 @@ my %sig =
                    cond => '#ifdef USE_LOCALE_COLLATE'},
      'hintselem' => {set => 'sethint', clear => 'clearhint'},
      'hints' => {clear => 'clearhints'},
-     'vstring' => {set => 'setvstring'},
      'checkcall' => {copy => 'copycallchecker'},
 );
 
diff --git a/sv.c b/sv.c
index 7022ce1..b5950d6 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -3035,7 +3035,8 @@ Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *const lp)
 {
     PERL_ARGS_ASSERT_SV_2PVBYTE;
 
-    if ((SvTHINKFIRST(sv) && !SvIsCOW(sv)) || isGV_with_GP(sv)) {
+    if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
+     || isGV_with_GP(sv) || SvROK(sv)) {
        SV *sv2 = sv_newmortal();
        sv_copypv(sv2,sv);
        sv = sv2;
@@ -3061,7 +3062,8 @@ Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *const lp)
 {
     PERL_ARGS_ASSERT_SV_2PVUTF8;
 
-    if ((SvTHINKFIRST(sv) && !SvIsCOW(sv)) || isGV_with_GP(sv))
+    if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
+     || isGV_with_GP(sv) || SvROK(sv))
        sv = sv_mortalcopy(sv);
     else
         SvGETMAGIC(sv);
@@ -3937,12 +3939,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
     stype = SvTYPE(sstr);
     dtype = SvTYPE(dstr);
 
-    if ( SvVOK(dstr) )
-    {
-       /* need to nuke the magic */
-       sv_unmagic(dstr, PERL_MAGIC_vstring);
-    }
-
     /* There's a lot of redundancy below but we're going for speed here */
 
     switch (stype) {
@@ -4719,10 +4715,12 @@ S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after)
 /*
 =for apidoc sv_force_normal_flags
 
-Undo various types of fakery on an SV: if the PV is a shared string, make
+Undo various types of fakery on an SV, where fakery means
+"more than" a string: if the PV is a shared string, make
 a private copy; if we're a ref, stop refing; if we're a glob, downgrade to
 an xpvmg; if we're a copy-on-write scalar, this is the on-write time when
-we do the copy, and is also used locally.  If C<SV_COW_DROP_PV> is set
+we do the copy, and is also used locally; if this is a
+vstring, drop the vstring magic.  If C<SV_COW_DROP_PV> is set
 then a copy-on-write scalar drops its PV buffer (if any) and becomes
 SvPOK_off rather than making a copy.  (Used where this
 scalar is about to be set to some other value.)  In addition,
@@ -4849,6 +4847,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
 
        SvREFCNT_dec(temp);
     }
+    else if (SvVOK(sv)) sv_unmagic(sv, PERL_MAGIC_vstring);
 }
 
 /*
diff --git a/sv.h b/sv.h
index 291ef3d..4c58ee4 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -348,7 +348,7 @@ perform the upgrade if necessary.  See C<svtype>.
 
 
 
-#define SVf_THINKFIRST (SVf_READONLY|SVf_ROK|SVf_FAKE)
+#define SVf_THINKFIRST (SVf_READONLY|SVf_ROK|SVf_FAKE|SVs_RMG)
 
 #define SVf_OK         (SVf_IOK|SVf_NOK|SVf_POK|SVf_ROK| \
                         SVp_IOK|SVp_NOK|SVp_POK|SVpgv_GP)
index fa94d5e..5fca626 100644 (file)
@@ -11,7 +11,7 @@ $DOWARN = 1; # enable run-time warnings now
 
 use Config;
 
-plan( tests => 55 );
+plan( tests => 57 );
 
 eval 'use v5.5.640';
 is( $@, '', "use v5.5.640; $@");
@@ -270,6 +270,11 @@ ok( exists $h{chr(65).chr(66).chr(67)}, "v-stringness is engaged for X.Y.Z" );
     is $|, 1, 'clobbering vstrings does not clobber all magic';
 }
 
+$a = v102; $a =~ s/f/f/;
+is ref \$a, 'SCALAR',
+  's/// flattens vstrings even when the subst results in the same value';
+$a = v102; $a =~ y/f/g/;
+is ref \$a, 'SCALAR', 'y/// flattens vstrings';
 
 # The following tests whether v-strings are correctly
 # interpreted by the tokeniser when it's in a XTERMORDORDOR