generalize "%v" format into a flag for any integral format type:

"%vd", "%v#o", "%*vX", etc are allowed

p4raw-id: //depot/perl@5181

6 files changed, 137 insertions, 77 deletions

diff --git a/perl.c b/perl.c
index eba7e5cd65..cce5c514e0 100644
--- a/perl.c
+++ b/perl.c
@@ -2122,7 +2122,7 @@ Perl_moreswitches(pTHX_ char *s)
 	s++;
 	return s;
     case 'v':
-	printf(Perl_form(aTHX_ "\nThis is perl, v%v built for %s",
+	printf(Perl_form(aTHX_ "\nThis is perl, v%vd built for %s",
 			 PL_patchlevel, ARCHNAME));
 #if defined(LOCAL_PATCH_COUNT)
 	if (LOCAL_PATCH_COUNT > 0)
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 682f275045..ab025d9415 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -478,13 +478,15 @@ check if you're running a particular version of Perl.
 
 C<require> and C<use> also support such literals:
 
-    require v5.6.0;	# croak if $^V lt v5.6.0
-    use v5.6.0;		# same, but croaks at compile-time
+    require v5.6.0;		# croak if $^V lt v5.6.0
+    use v5.6.0;			# same, but croaks at compile-time
 
-C<sprintf> and C<printf> support the Perl-specific format type C<%v>
-to print arbitrary strings as dotted tuples.
+C<sprintf> and C<printf> support the Perl-specific format flag C<%v>
+to print ordinals of characters in arbitrary strings:
 
-    printf "v%v", $^V;	# prints current version, such as "v5.5.650"
+    printf "v%vd", $^V;		# prints current version, such as "v5.5.650"
+    printf "%*vX", ":", $addr;	# formats IPv6 address
+    printf "%*vb", "", $bits;	# displays bitstring as contiguous 0's and 1's
 
 =head2 Weak references
 
diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index e11364d509..2dd496ab21 100644
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -4337,10 +4337,6 @@ 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:
 
@@ -4366,9 +4362,13 @@ and the conversion letter:
    h       interpret integer as C type "short" or "unsigned short"
            If no flags, interpret integer as C type "int" or "unsigned"
 
-There is also one Perl-specific flag:
+There is also two Perl-specific flags:
 
    V       interpret integer as Perl's standard integer type
+   v       interpret string as a vector of integers, output as
+           numbers separated either by dots, or by an arbitrary
+	   string received from the argument list when the flag
+	   is preceded by C<*>
 
 Where a number would appear in the flags, an asterisk (C<*>) may be
 used instead, in which case Perl uses the next item in the parameter
@@ -4376,6 +4376,13 @@ list as the given number (that is, as the field width or precision).
 If a field width obtained through C<*> is negative, it has the same
 effect as the C<-> flag: left-justification.
 
+The C<v> flag is useful for displaying ordinal values of characters
+in arbitrary strings:
+
+    printf "version is v%vd\n", $^V;		# Perl's version
+    printf "address is %*vX\n", ":", $addr;	# IPv6 address
+    printf "bits are %*vb\n", "", $bits;	# random bitstring
+
 If C<use locale> is in effect, the character used for the decimal
 point in formatted real numbers is affected by the LC_NUMERIC locale.
 See L<perllocale>.
diff --git a/sv.c b/sv.c
index fcabe6b63d..f6c0a1ee76 100644
--- a/sv.c
+++ b/sv.c
@@ -5729,6 +5729,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
     for (p = (char*)pat; p < patend; p = q) {
 	bool alt = FALSE;
 	bool left = FALSE;
+	bool vectorize = FALSE;
+	bool utf = FALSE;
 	char fill = ' ';
 	char plus = 0;
 	char intsize = 0;
@@ -5750,6 +5752,10 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	char ebuf[IV_DIG * 4 + NV_DIG + 32];
         /* large enough for "%#.#f" --chip */
 	/* what about long double NVs? --jhi */
+
+	SV *vecsv;
+	char *vecstr = Nullch;
+	STRLEN veclen = 0;
 	char c;
 	int i;
 	unsigned base;
@@ -5759,6 +5765,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	STRLEN have;
 	STRLEN need;
 	STRLEN gap;
+	char *dotstr = ".";
+	STRLEN dotstrlen = 1;
 
 	for (q = p; q < patend && *q != '%'; ++q) ;
 	if (q > p) {
@@ -5791,6 +5799,30 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 		q++;
 		continue;
 
+	    case '*':			/* printf("%*vX",":",$ipv6addr) */
+		if (q[1] != 'v')
+		    break;
+		q++;
+		if (args)
+		    vecsv = va_arg(*args, SV*);
+		else if (svix < svmax)
+		    vecsv = svargs[svix++];
+		dotstr = SvPVx(vecsv,dotstrlen);
+		if (DO_UTF8(vecsv))
+		    is_utf = TRUE;
+		/* FALL THROUGH */
+
+	    case 'v':
+		vectorize = TRUE;
+		q++;
+		if (args)
+		    vecsv = va_arg(*args, SV*);
+		else if (svix < svmax)
+		    vecsv = svargs[svix++];
+		vecstr = SvPVx(vecsv,veclen);
+		utf = DO_UTF8(vecsv);
+		continue;
+
 	    default:
 		break;
 	    }
@@ -5926,63 +5958,6 @@ 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+1;
-		SV *vsv = NEWSV(73,vlen);
-		I32 ulen;
-		I32 vfree = vlen;
-		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;
-		    do {
-			*--eptr = '0' + uv % 10;
-		    } while (uv /= 10);
-		    elen = (ebuf + sizeof ebuf) - eptr;
-		    while (elen >= vfree-1) {
-			STRLEN off = vptr - (U8*)SvPVX(vsv);
-			vfree += vlen;
-			vlen *= 2;
-			SvGROW(vsv, vlen);
-			vptr = (U8*)SvPVX(vsv) + off;
-		    }
-		    memcpy(vptr, eptr, elen);
-		    vptr += elen;
-		    *vptr++ = '.';
-		    vfree -= elen + 1;
-		    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,
@@ -5997,6 +5972,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 		is_utf = TRUE;
 
 	string:
+	    vectorize = FALSE;
 	    if (has_precis && elen > precis)
 		elen = precis;
 	    break;
@@ -6020,7 +5996,22 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	    /* FALL THROUGH */
 	case 'd':
 	case 'i':
-	    if (args) {
+	    if (vectorize) {
+		I32 ulen;
+		if (!veclen) {
+		    vectorize = FALSE;
+		    break;
+		}
+		if (utf)
+		    iv = (IV)utf8_to_uv(vecstr, &ulen);
+		else {
+		    iv = (U8)*vecstr;
+		    ulen = 1;
+		}
+		vecstr += ulen;
+		veclen -= ulen;
+	    }
+	    else if (args) {
 		switch (intsize) {
 		case 'h':	iv = (short)va_arg(*args, int); break;
 		default:	iv = va_arg(*args, int); break;
@@ -6086,7 +6077,23 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	    base = 16;
 
 	uns_integer:
-	    if (args) {
+	    if (vectorize) {
+		I32 ulen;
+	vector:
+		if (!veclen) {
+		    vectorize = FALSE;
+		    break;
+		}
+		if (utf)
+		    uv = utf8_to_uv(vecstr, &ulen);
+		else {
+		    uv = (U8)*vecstr;
+		    ulen = 1;
+		}
+		vecstr += ulen;
+		veclen -= ulen;
+	    }
+	    else if (args) {
 		switch (intsize) {
 		case 'h':  uv = (unsigned short)va_arg(*args, unsigned); break;
 		default:   uv = va_arg(*args, unsigned); break;
@@ -6186,6 +6193,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 
 	    /* This is evil, but floating point is even more evil */
 
+	    vectorize = FALSE;
 	    if (args)
 		nv = va_arg(*args, NV);
 	    else
@@ -6253,6 +6261,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	    /* SPECIAL */
 
 	case 'n':
+	    vectorize = FALSE;
 	    i = SvCUR(sv) - origlen;
 	    if (args) {
 		switch (intsize) {
@@ -6273,6 +6282,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 
 	default:
       unknown:
+	    vectorize = FALSE;
 	    if (!args && ckWARN(WARN_PRINTF) &&
 		  (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
 		SV *msg = sv_newmortal();
@@ -6311,7 +6321,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	need = (have > width ? have : width);
 	gap = need - have;
 
-	SvGROW(sv, SvCUR(sv) + need + 1);
+	SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
 	p = SvEND(sv);
 	if (esignlen && fill == '0') {
 	    for (i = 0; i < esignlen; i++)
@@ -6337,10 +6347,22 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 	    memset(p, ' ', gap);
 	    p += gap;
 	}
+	if (vectorize) {
+	    if (veclen) {
+		memcpy(p, dotstr, dotstrlen);
+		p += dotstrlen;
+	    }
+	    else
+		vectorize = FALSE;		/* done iterating over vecstr */
+	}
 	if (is_utf)
 	    SvUTF8_on(sv);
 	*p = '\0';
 	SvCUR(sv) = p - SvPVX(sv);
+	if (vectorize) {
+	    esignlen = 0;
+	    goto vector;
+	}
     }
 }
 
diff --git a/t/op/ver.t b/t/op/ver.t
index 66e8378d98..cfbf63a2d5 100755
--- a/t/op/ver.t
+++ b/t/op/ver.t
@@ -5,7 +5,7 @@ BEGIN {
     unshift @INC, "../lib";
 }
 
-print "1..6\n";
+print "1..15\n";
 
 my $test = 1;
 
@@ -19,15 +19,44 @@ 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 "not " unless sprintf("%vd", "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 "not " unless sprintf("%vd", v1.22.333.4444) eq '1.22.333.4444';
+print "ok $test\n";  ++$test;
+
+print "not " unless sprintf("%vx", "Perl") eq '50.65.72.6c';
+print "ok $test\n";  ++$test;
+
+print "not " unless sprintf("%vX", v1.22.333.4444) eq '1.16.14D.115C';
+print "ok $test\n";  ++$test;
+
+print "not " unless sprintf("%*v#o", ":", "Perl") eq '0120:0145:0162:0154';
+print "ok $test\n";  ++$test;
+
+print "not " unless sprintf("%*vb", "##", v1.22.333.4444)
+    eq '1##10110##101001101##1000101011100';
 print "ok $test\n";  ++$test;
 
 {
     use bytes;
+    print "not " unless sprintf("%vd", "Perl") eq '80.101.114.108';
+    print "ok $test\n";  ++$test;
+
     print "not " unless
-        sprintf("%v", v1.22.333.4444) eq '1.22.197.141.225.133.156';
+        sprintf("%vd", v1.22.333.4444) eq '1.22.197.141.225.133.156';
+    print "ok $test\n";  ++$test;
+
+    print "not " unless sprintf("%vx", "Perl") eq '50.65.72.6c';
+    print "ok $test\n";  ++$test;
+
+    print "not " unless sprintf("%vX", v1.22.333.4444) eq '1.16.C5.8D.E1.85.9C';
+    print "ok $test\n";  ++$test;
+
+    print "not " unless sprintf("%*v#o", ":", "Perl") eq '0120:0145:0162:0154';
+    print "ok $test\n";  ++$test;
+
+    print "not " unless sprintf("%*vb", "##", v1.22.333.4444)
+	eq '1##10110##11000101##10001101##11100001##10000101##10011100';
     print "ok $test\n";  ++$test;
 }
diff --git a/utils/perlbug.PL b/utils/perlbug.PL
index 97f8d867da..f46564ea5f 100644
--- a/utils/perlbug.PL
+++ b/utils/perlbug.PL
@@ -57,7 +57,7 @@ print "Extracting $file (with variable substitutions)\n";
 # In this section, perl variables will be expanded during extraction.
 # You can use $Config{...} to use Configure variables.
 
-my $extract_version = sprintf("v%v", $^V);
+my $extract_version = sprintf("v%vd", $^V);
 
 print OUT <<"!GROK!THIS!";
 $Config{startperl}
@@ -133,7 +133,7 @@ my( $file, $usefile, $cc, $address, $perlbug, $testaddress, $filename,
     $subject, $from, $verbose, $ed, $outfile, $Is_MacOS,
     $fh, $me, $Is_MSWin32, $Is_VMS, $msg, $body, $andcc, %REP, $ok);
 
-my $perl_version = $^V ? sprintf("v%v", $^V) : $];
+my $perl_version = $^V ? sprintf("v%vd", $^V) : $];
 
 my $config_tag2 = "$perl_version - $Config{cf_time}";