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)
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
%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:
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
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>.
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;
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;
STRLEN have;
STRLEN need;
STRLEN gap;
+ char *dotstr = ".";
+ STRLEN dotstrlen = 1;
for (q = p; q < patend && *q != '%'; ++q) ;
if (q > p) {
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;
}
}
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,
is_utf = TRUE;
string:
+ vectorize = FALSE;
if (has_precis && elen > precis)
elen = precis;
break;
/* 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;
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;
/* This is evil, but floating point is even more evil */
+ vectorize = FALSE;
if (args)
nv = va_arg(*args, NV);
else
/* SPECIAL */
case 'n':
+ vectorize = FALSE;
i = SvCUR(sv) - origlen;
if (args) {
switch (intsize) {
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();
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++)
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;
+ }
}
}
unshift @INC, "../lib";
}
-print "1..6\n";
+print "1..15\n";
my $test = 1;
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;
}
# 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}
$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}";
projects / p5sagit/p5-mst-13.2.git / commitdiff