From: Gurusamy Sarathy Date: Mon, 21 Feb 2000 16:53:39 +0000 (+0000) Subject: generalize "%v" format into a flag for any integral format type: X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b22c7a20398f928f9697b491d180b979ff211bd6;p=p5sagit%2Fp5-mst-13.2.git generalize "%v" format into a flag for any integral format type: "%vd", "%v#o", "%*vX", etc are allowed p4raw-id: //depot/perl@5181 --- diff --git a/perl.c b/perl.c index eba7e5c..cce5c51 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 682f275..ab025d9 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -478,13 +478,15 @@ check if you're running a particular version of Perl. C and C 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 and C support the Perl-specific format type C<%v> -to print arbitrary strings as dotted tuples. +C and C 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 e11364d..2dd496a 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 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 is in effect, the character used for the decimal point in formatted real numbers is affected by the LC_NUMERIC locale. See L. diff --git a/sv.c b/sv.c index fcabe6b..f6c0a1e 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 66e8378..cfbf63a 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 97f8d86..f46564e 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}";