The magic v-string patch from John Peacock for 5.8;

permits the programmer to know when a given scalar was
originally encoded as a v-string; Scalar::Util has already
been enhanced to expose this at the Perl level.

p4raw-id: //depot/maint-5.8/perl@18387

diff --git a/dump.c b/dump.c
index 8127ba0..a26da0c 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -770,6 +770,7 @@ static struct { char type; char *name; } magic_names[] = {
        { PERL_MAGIC_taint,          "taint(t)" },
        { PERL_MAGIC_uvar_elem,      "uvar_elem(v)" },
        { PERL_MAGIC_vec,            "vec(v)" },
+       { PERL_MAGIC_vstring,        "v-string(V)" },
        { PERL_MAGIC_utf8,           "utf8(w)" },
        { PERL_MAGIC_substr,         "substr(x)" },
        { PERL_MAGIC_defelem,        "defelem(y)" },

diff --git a/perl.h b/perl.h
index 10bd07d..0c9dca4 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -2655,6 +2655,7 @@ Gid_t getegid (void);
 #define PERL_MAGIC_taint         't' /* Taintedness */
 #define PERL_MAGIC_uvar                  'U' /* Available for use by extensions */
 #define PERL_MAGIC_uvar_elem     'u' /* Reserved for use by extensions */
+#define PERL_MAGIC_vstring       'V' /* SV was vstring literal */
 #define PERL_MAGIC_vec           'v' /* vec() lvalue */
 #define PERL_MAGIC_utf8                  'w' /* Cached UTF-8 information */
 #define PERL_MAGIC_substr        'x' /* substr() lvalue */

diff --git a/pod/perlguts.pod b/pod/perlguts.pod
index 29b5181..39f2392 100644 (file)
--- a/pod/perlguts.pod
+++ b/pod/perlguts.pod
@@ -963,6 +963,7 @@ The current kinds of Magic Virtual Tables are:
     t  PERL_MAGIC_taint          vtbl_taint     Taintedness
     U  PERL_MAGIC_uvar           vtbl_uvar      Available for use by extensions
     v  PERL_MAGIC_vec            vtbl_vec       vec() lvalue
+    V  PERL_MAGIC_vstring        (none)         v-string scalars
     x  PERL_MAGIC_substr         vtbl_substr    substr() lvalue
     y  PERL_MAGIC_defelem        vtbl_defelem   Shadow "foreach" iterator
                                                variable / smart parameter
@@ -974,10 +975,10 @@ The current kinds of Magic Virtual Tables are:
     ~  PERL_MAGIC_ext            (none)         Available for use by extensions
 
 When an uppercase and lowercase letter both exist in the table, then the
-uppercase letter is used to represent some kind of composite type (a list
-or a hash), and the lowercase letter is used to represent an element of
-that composite type. Some internals code makes use of this case
-relationship.
+uppercase letter is typically used to represent some kind of composite type
+(a list or a hash), and the lowercase letter is used to represent an element
+of that composite type. Some internals code makes use of this case
+relationship.  However, 'v' and 'V' (vec and v-string) are in no way related.
 
 The C<PERL_MAGIC_ext> and C<PERL_MAGIC_uvar> magic types are defined
 specifically for use by extensions and will not be used by perl itself.

diff --git a/sv.c b/sv.c
index 9bdfe15..07d7453 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -3581,6 +3581,12 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
     dtype = SvTYPE(dstr);
 
     SvAMAGIC_off(dstr);
+    if ( SvVOK(dstr) ) 
+    {
+       /* need to nuke the magic */
+       mg_free(dstr);
+       SvRMAGICAL_off(dstr);
+    }
 
     /* There's a lot of redundancy below but we're going for speed here */
 
@@ -3962,6 +3968,12 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
                SvIsUV_on(dstr);
            SvIVX(dstr) = SvIVX(sstr);
        }
+       if ( SvVOK(sstr) ) {
+           MAGIC *smg = mg_find(sstr,PERL_MAGIC_vstring);
+           sv_magic(dstr, NULL, PERL_MAGIC_vstring,
+                    smg->mg_ptr, smg->mg_len);
+           SvRMAGICAL_on(dstr);
+       } 
     }
     else if (sflags & SVp_IOK) {
        if (sflags & SVf_IOK)
@@ -4650,6 +4662,9 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam
     case PERL_MAGIC_vec:
        vtable = &PL_vtbl_vec;
        break;
+    case PERL_MAGIC_vstring:
+       vtable = 0;
+       break;
     case PERL_MAGIC_utf8:
         vtable = &PL_vtbl_utf8;
         break;

diff --git a/sv.h b/sv.h
index 9665efe..e65eded 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -577,6 +577,7 @@ Set the length of the string which is in the SV.  See C<SvCUR>.
 #define SvIOK_notUV(sv)                ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV))   \
                                 == SVf_IOK)
 
+#define SvVOK(sv)              (SvMAGICAL(sv) && mg_find(sv,'V'))
 #define SvIsUV(sv)             (SvFLAGS(sv) & SVf_IVisUV)
 #define SvIsUV_on(sv)          (SvFLAGS(sv) |= SVf_IVisUV)
 #define SvIsUV_off(sv)         (SvFLAGS(sv) &= ~SVf_IVisUV)

diff --git a/t/op/ver.t b/t/op/ver.t
index 1634cc3..7fe3e67 100755 (executable)
--- a/t/op/ver.t
+++ b/t/op/ver.t
@@ -11,7 +11,7 @@ $DOWARN = 1; # enable run-time warnings now
 use Config;
 
 require "test.pl";
-plan( tests => 47 );
+plan( tests => 50 );
 
 eval { use v5.5.640; };
 is( $@, '', "use v5.5.640; $@");
@@ -245,3 +245,12 @@ SKIP: {
     }
   }
 }
+
+# Tests for magic v-strings
+
+$v = 1.2.3;
+is( ref(\$v), 'SCALAR', 'v-strings are just scalars' );
+
+$v = v1.2_3;
+is( ref(\$v), 'SCALAR', 'v-strings with v are just scalars' );
+is( sprintf("%vd", $v), '1.23', 'v-string ignores underscores' );

diff --git a/util.c b/util.c
index 8bc748e..debc8c2 100644 (file)
--- a/util.c
+++ b/util.c
@@ -3933,6 +3933,7 @@ char *
 Perl_new_vstring(pTHX_ char *s, SV *sv)
 {
     char *pos = s;
+    char *start = s;
     if (*pos == 'v') pos++;  /* get past 'v' */
     while (isDIGIT(*pos) || *pos == '_')
     pos++;
@@ -3951,11 +3952,10 @@ Perl_new_vstring(pTHX_ char *s, SV *sv)
                 /* this is atoi() that tolerates underscores */
                 char *end = pos;
                 UV mult = 1;
-                if ( s > pos && *(s-1) == '_') {
-                     mult = 10;
-                }
                 while (--end >= s) {
                      UV orev;
+                     if (*end == '_' )
+                          continue;
                      orev = rev;
                      rev += (*end - '0') * mult;
                      mult *= 10;
@@ -3973,17 +3973,18 @@ Perl_new_vstring(pTHX_ char *s, SV *sv)
            sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
            if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
                 SvUTF8_on(sv);
-           if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1]))
+           if ( *pos == '.' && isDIGIT(pos[1]) )
                 s = ++pos;
            else {
                 s = pos;
                 break;
            }
-           while (isDIGIT(*pos) )
+           while ( isDIGIT(*pos) || *pos == '_' ) 
                 pos++;
        }
        SvPOK_on(sv);
-       SvREADONLY_on(sv);
+       sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
+       SvRMAGICAL_on(sv);
     }
     return s;
 }