support sprintf("v%v", v1.2.3) (works on any string argument, in

fact); add tests for version tuples

p4raw-id: //depot/perl@4998

diff --git a/MANIFEST b/MANIFEST
index 4753599..c3bbfee 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1388,6 +1388,7 @@ t/op/undef.t              See if undef works
 t/op/universal.t       See if UNIVERSAL class works
 t/op/unshift.t         See if unshift works
 t/op/vec.t             See if vectors work
+t/op/ver.t             See if version tuples work
 t/op/wantarray.t       See if wantarray works
 t/op/write.t           See if write works
 t/pod/emptycmd.t       Test empty pod directives

diff --git a/perl.c b/perl.c
index 3153f59..186b85c 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -2028,8 +2028,8 @@ Perl_moreswitches(pTHX_ char *s)
        s++;
        return s;
     case 'v':
-       printf("\nThis is perl, v%"UVuf".%"UVuf".%"UVuf" built for %s",
-              (UV)PERL_REVISION, (UV)PERL_VERSION, (UV)PERL_SUBVERSION, ARCHNAME);
+       printf(Perl_form(aTHX_ "\nThis is perl, v%v built for %s",
+                        PL_patchlevel, ARCHNAME));
 #if defined(LOCAL_PATCH_COUNT)
        if (LOCAL_PATCH_COUNT > 0)
            printf("\n(with %d registered patch%s, see perl -V for more detail)",

diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index b7e115f..7891bc2 100644 (file)
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -2170,6 +2170,12 @@ on portability concerns.
 
 See also L<perlport> for writing portable code.
 
+=item Octal number in vector unsupported
+
+(F) Numbers with a leading C<0> are not currently allowed in vectors.  The
+octal number interpretation of such numbers may be supported in a future
+version.
+
 =item Odd number of elements in hash assignment
 
 (W) You specified an odd number of elements to initialize a hash, which

diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index fa8504e..c9efcd1 100644 (file)
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -4310,6 +4310,10 @@ In addition, Perl permits the following widely-supported conversions:
    %n  special: *stores* the number of characters output so far
         into the next variable in the parameter list 
 
+And the following Perl-specific conversion:
+
+   %v   a string, output as a tuple of integers ("Perl" is 80.101.114.108)
+
 Finally, for backward (and we do mean "backward") compatibility, Perl
 permits these unnecessary but widely-supported conversions:
 

diff --git a/pod/perlop.pod b/pod/perlop.pod
index 150813e..d932704 100644 (file)
--- a/pod/perlop.pod
+++ b/pod/perlop.pod
@@ -1804,14 +1804,15 @@ in a bit vector.
 
 =head2 Version tuples
 
-A version number of the form C<v1.2.3.4> is parsed as a dual-valued literal.
-It has the string value of C<"\x{1}\x{2}\x{3}\x{4}"> (i.e., a utf8 string)
-and a numeric value of C<1 + 2/1000 + 3/1000000 + 4/1000000000>.  This is
-useful for representing and comparing version numbers.
-
-Version tuples are accepted by both C<require> and C<use>.  The C<$^V> variable
-contains the running Perl interpreter's version in this format.
-See L<perlvar/$^V>.
+A literal of the form C<v1.20.300.4000> is parsed as a dual-valued quantity.
+It has the string value of C<"\x{1}\x{14}\x{12c}\x{fa0}"> (i.e., a UTF-8
+string) and a numeric value of C<1 + 20/1000 + 300/1000000 + 4000/1000000000>.
+This is useful for representing Unicode strings, and for comparing version
+numbers using the string comparison operators, C<cmp>, C<gt>, C<lt> etc.
+
+Such "version tuples" or "vectors" are accepted by both C<require> and
+C<use>.  The C<$^V> variable contains the running Perl interpreter's
+version in this format.  See L<perlvar/$^V>.
 
 =head2 Integer Arithmetic
 

diff --git a/sv.c b/sv.c
index 94fbced..586c0dd 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -5875,6 +5875,60 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            }
            goto string;
 
+       case 'v':
+           if (args)
+               argsv = va_arg(*args, SV*);
+           else if (svix < svmax)
+               argsv = svargs[svix++];
+           {
+               STRLEN len;
+               U8 *str = (U8*)SvPVx(argsv,len);
+               I32 vlen = len*3;
+               SV *vsv = NEWSV(73,vlen);
+               I32 ulen;
+               U8 *vptr = (U8*)SvPVX(vsv);
+               STRLEN vcur = 0;
+               bool utf = DO_UTF8(argsv);
+
+               if (utf)
+                   is_utf = TRUE;
+               while (len) {
+                   UV uv;
+
+                   if (utf)
+                       uv = utf8_to_uv(str, &ulen);
+                   else {
+                       uv = *str;
+                       ulen = 1;
+                   }
+                   str += ulen;
+                   len -= ulen;
+                   eptr = ebuf + sizeof ebuf;
+                   if (elen >= vlen-1) {
+                       STRLEN off = vptr - (U8*)SvPVX(vsv);
+                       vlen *= 2;
+                       SvGROW(vsv, vlen);
+                       vptr = SvPVX(vsv) + off;
+                   }
+                   do {
+                       *--eptr = '0' + uv % 10;
+                   } while (uv /= 10);
+                   elen = (ebuf + sizeof ebuf) - eptr;
+                   memcpy(vptr, eptr, elen);
+                   vptr += elen;
+                   *vptr++ = '.';
+                   vcur += elen + 1;
+               }
+               if (vcur) {
+                   vcur--;
+                   vptr[-1] = '\0';
+               }
+               SvCUR_set(vsv,vcur);
+               eptr = SvPVX(vsv);
+               elen = vcur;
+           }
+           goto string;
+
        case '_':
            /*
             * The "%_" hack might have to be changed someday,

diff --git a/t/op/ver.t b/t/op/ver.t
new file mode 100755 (executable)
index 0000000..e052646
--- /dev/null
+++ b/t/op/ver.t
@@ -0,0 +1,33 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    unshift @INC, "../lib";
+}
+
+print "1..6\n";
+
+my $test = 1;
+
+use v5.5.640;
+require v5.5.640;
+print "ok $test\n";  ++$test;
+
+print "not " unless v1.20.300.4000 eq "\x{1}\x{14}\x{12c}\x{fa0}";
+print "ok $test\n";  ++$test;
+
+print "not " unless v1.20.300.4000 > 1.0203039 and v1.20.300.4000 < 1.0203041;
+print "ok $test\n";  ++$test;
+
+print "not " unless sprintf("%v", "Perl") eq '80.101.114.108';
+print "ok $test\n";  ++$test;
+
+print "not " unless sprintf("%v", v1.22.333.4444) eq '1.22.333.4444';
+print "ok $test\n";  ++$test;
+
+{
+    use byte;
+    print "not " unless
+        sprintf("%v", v1.22.333.4444) eq '1.22.197.141.225.133.156';
+    print "ok $test\n";  ++$test;
+}

diff --git a/toke.c b/toke.c
index 55ffda3..22db523 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -1675,7 +1675,7 @@ S_intuit_more(pTHX_ register char *s)
  * Not a method if it's really "print foo $bar"
  * Method if it's really "foo package::" (interpreted as package->foo)
  * Not a method if bar is known to be a subroutne ("sub bar; foo bar")
- * Not a method if bar is a filehandle or package, but is quotd with
+ * Not a method if bar is a filehandle or package, but is quoted with
  *   =>
  */
 
@@ -6894,6 +6894,8 @@ Perl_scan_num(pTHX_ char *start)
                sv_setpvn(sv, "", 0);
 
                do {
+                   if (*s == '0' && isDIGIT(s[1]))
+                       yyerror("Octal number in vector unsupported");
                    rev = atoi(s);
                    s = ++pos;
                    while (isDIGIT(*pos))
@@ -6907,6 +6909,8 @@ Perl_scan_num(pTHX_ char *start)
                    nshift *= 1000;
                } while (*pos == '.' && isDIGIT(pos[1]));
 
+               if (*s == '0' && isDIGIT(s[1]))
+                   yyerror("Octal number in vector unsupported");
                rev = atoi(s);
                s = pos;
                tmpend = uv_to_utf8(tmpbuf, rev);