From: Rafael Garcia-Suarez Date: Mon, 19 Mar 2007 08:58:08 +0000 (+0000) Subject: Upgrade to version.pm 0.71, by John Peacock X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ac0e6a2fd2970df72270aecb94d407fe170b43a7;p=p5sagit%2Fp5-mst-13.2.git Upgrade to version.pm 0.71, by John Peacock p4raw-id: //depot/perl@30629 --- diff --git a/embed.fnc b/embed.fnc index b9d46a2..1686b3c 100644 --- a/embed.fnc +++ b/embed.fnc @@ -599,7 +599,7 @@ Apa |PERL_SI*|new_stackinfo|I32 stitems|I32 cxitems Ap |char* |scan_vstring |NN const char *vstr|NN SV *sv Apd |const char* |scan_version |NN const char *vstr|NN SV *sv|bool qv Apd |SV* |new_version |NN SV *ver -Apd |SV* |upg_version |NN SV *ver +Apd |SV* |upg_version |NN SV *ver|bool qv Apd |bool |vverify |NN SV *vs Apd |SV* |vnumify |NN SV *vs Apd |SV* |vnormal |NN SV *vs diff --git a/embed.h b/embed.h index 78d4b56..c930c91 100644 --- a/embed.h +++ b/embed.h @@ -2813,7 +2813,7 @@ #define scan_vstring(a,b) Perl_scan_vstring(aTHX_ a,b) #define scan_version(a,b,c) Perl_scan_version(aTHX_ a,b,c) #define new_version(a) Perl_new_version(aTHX_ a) -#define upg_version(a) Perl_upg_version(aTHX_ a) +#define upg_version(a,b) Perl_upg_version(aTHX_ a,b) #define vverify(a) Perl_vverify(aTHX_ a) #define vnumify(a) Perl_vnumify(aTHX_ a) #define vnormal(a) Perl_vnormal(aTHX_ a) diff --git a/gv.c b/gv.c index 26308bb..f48ef98 100644 --- a/gv.c +++ b/gv.c @@ -1287,7 +1287,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, { SV * const sv = GvSVn(gv); if (!sv_derived_from(PL_patchlevel, "version")) - upg_version(PL_patchlevel); + upg_version(PL_patchlevel, TRUE); GvSV(gv) = vnumify(PL_patchlevel); SvREADONLY_on(GvSV(gv)); SvREFCNT_dec(sv); diff --git a/lib/version.t b/lib/version.t index 2438a30..11a6b07 100644 --- a/lib/version.t +++ b/lib/version.t @@ -400,8 +400,8 @@ SKIP: { } SKIP: { - skip 'Cannot test bare v-strings with Perl < 5.8.1', 4 - if $] < 5.008_001; + skip 'Cannot test bare v-strings with Perl < 5.6.0', 4 + if $] < 5.006_000; diag "Tests with v-strings" if $Verbose; $version = $CLASS->new(1.2.3); ok("$version" eq "v1.2.3", '"$version" eq 1.2.3'); @@ -468,26 +468,26 @@ EOF close F; eval "use lib '.'; use www 0.000008;"; - like ($@, qr/^www version 0.000008 \(v0.0.8\) required/, + like ($@, qr/^www version 0.000008 required/, "Make sure very small versions don't freak"); eval "use lib '.'; use www 1;"; - like ($@, qr/^www version 1.000 \(v1.0.0\) required/, + like ($@, qr/^www version 1.000 required/, "Comparing vs. version with no decimal"); eval "use lib '.'; use www 1.;"; - like ($@, qr/^www version 1.000 \(v1.0.0\) required/, + like ($@, qr/^www version 1.000 required/, "Comparing vs. version with decimal only"); - if ( $] < 5.006_002 ) { + if ( $] < 5.006_000 ) { unlink 'www.pm'; - skip 'Cannot "use" extended versions with Perl < 5.6.2', 3; + skip 'Cannot "use" extended versions with Perl < 5.6.0', 3; } - eval "use lib '.'; use www 0.0.8;"; - like ($@, qr/^www version 0.000008 \(v0.0.8\) required/, - "Make sure very small versions don't freak"); + eval "use lib '.'; use www v0.0.8;"; + my $regex = "^www version v0.0.8 required"; + like ($@, qr/$regex/, "Make sure very small versions don't freak"); - eval "use lib '.'; use www 0.0.4;"; - unlike($@, qr/^www version 0.000004 \(v0.0.4\) required/, - 'Succeed - required == VERSION'); + $regex =~ s/8/4/; # set for second test + eval "use lib '.'; use www v0.0.4;"; + unlike($@, qr/$regex/, 'Succeed - required == VERSION'); cmp_ok ( "www"->VERSION, 'eq', '0.000004', 'No undef warnings' ); unlink 'www.pm'; @@ -509,6 +509,26 @@ EOF unlink 'vvv.pm'; SKIP: { + if ( $] < 5.006_000 ) { + skip 'Cannot "use" extended versions with Perl < 5.6.0', 3; + } + open F, ">uuu.pm" or die "Cannot open uuu.pm: $!\n"; + print F <<"EOF"; +package uuu; +\$VERSION = 1.0; +1; +EOF + close F; + eval "use lib '.'; use uuu 1.001;"; + like ($@, qr/^uuu version 1.001 required/, + "User typed numeric so we error with numeric"); + eval "use lib '.'; use uuu v1.1.0;"; + like ($@, qr/^uuu version v1.1.0 required/, + "User typed extended so we error with extended"); + unlink 'uuu.pm'; + } + +SKIP: { # test locale handling my $warning; local $SIG{__WARN__} = sub { $warning = $_[0] }; @@ -534,6 +554,7 @@ SKIP: { eval 'my $v = $CLASS->new("1._1");'; unlike($@, qr/^Invalid version format \(alpha with zero width\)/, "Invalid version format 1._1"); + } 1; diff --git a/perl.c b/perl.c index 3090375..982ec89 100644 --- a/perl.c +++ b/perl.c @@ -3279,7 +3279,7 @@ Perl_moreswitches(pTHX_ char *s) return s; case 'v': if (!sv_derived_from(PL_patchlevel, "version")) - upg_version(PL_patchlevel); + upg_version(PL_patchlevel, TRUE); #if !defined(DGUX) PerlIO_printf(PerlIO_stdout(), Perl_form(aTHX_ "\nThis is perl, %"SVf diff --git a/pod/perlapi.pod b/pod/perlapi.pod index 3f0adf1..7f82d8b 100644 --- a/pod/perlapi.pod +++ b/pod/perlapi.pod @@ -2656,11 +2656,12 @@ X In-place upgrade of the supplied SV to a version object. - SV *sv = upg_version(SV *sv); + SV *sv = upg_version(SV *sv, bool qv); -Returns a pointer to the upgraded SV. +Returns a pointer to the upgraded SV. Set the boolean qv if you want +to force this SV to be interpreted as an "extended" version. - SV* upg_version(SV *ver) + SV* upg_version(SV *ver, bool qv) =for hackers Found in file util.c diff --git a/pp_ctl.c b/pp_ctl.c index f818869..25cfe5f 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -3089,7 +3089,7 @@ PP(pp_require) sv = new_version(sv); if (!sv_derived_from(PL_patchlevel, "version")) - upg_version(PL_patchlevel); + upg_version(PL_patchlevel, TRUE); if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) { if ( vcmp(sv,PL_patchlevel) <= 0 ) DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped", @@ -3104,7 +3104,7 @@ PP(pp_require) /* If we request a version >= 5.9.5, load feature.pm with the * feature bundle that corresponds to the required version. * We do this only with use, not require. */ - if (PL_compcv && vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005)))) >= 0) { + if (PL_compcv && vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) { SV *const importsv = vnormal(sv); *SvPVX_mutable(importsv) = ':'; ENTER; diff --git a/proto.h b/proto.h index 25dc06a..54c98f4 100644 --- a/proto.h +++ b/proto.h @@ -1674,7 +1674,7 @@ PERL_CALLCONV const char* Perl_scan_version(pTHX_ const char *vstr, SV *sv, bool PERL_CALLCONV SV* Perl_new_version(pTHX_ SV *ver) __attribute__nonnull__(pTHX_1); -PERL_CALLCONV SV* Perl_upg_version(pTHX_ SV *ver) +PERL_CALLCONV SV* Perl_upg_version(pTHX_ SV *ver, bool qv) __attribute__nonnull__(pTHX_1); PERL_CALLCONV bool Perl_vverify(pTHX_ SV *vs) diff --git a/t/comp/use.t b/t/comp/use.t index a6ea3e6..9df08d2 100755 --- a/t/comp/use.t +++ b/t/comp/use.t @@ -139,39 +139,39 @@ if ($^O eq 'MacOS') { is ($@, ''); eval "use lib v100.105"; - like ($@, qr/lib version 100.105 \(v100\.105\.0\) required--this is only version 35.360 \(v35\.360\.0\)/); + like ($@, qr/lib version v100.105.0 required--this is only version v35\.360\.0/); eval "use lib 33.55"; is ($@, ''); eval "use lib 100.105"; - like ($@, qr/lib version 100.105 \(v100\.105\.0\) required--this is only version 35.360 \(v35\.360\.0\)/); + like ($@, qr/lib version 100.105 required--this is only version 35.360/); local $lib::VERSION = '35.36'; eval "use lib v33.55"; like ($@, ''); eval "use lib v100.105"; - like ($@, qr/lib version 100.105 \(v100\.105\.0\) required--this is only version 35.360 \(v35\.360\.0\)/); + like ($@, qr/lib version v100.105.0 required--this is only version v35\.360\.0/); eval "use lib 33.55"; is ($@, ''); eval "use lib 100.105"; - like ($@, qr/lib version 100.105 \(v100\.105\.0\) required--this is only version 35.360 \(v35\.360\.0\)/); + like ($@, qr/lib version 100.105 required--this is only version 35.360/); local $lib::VERSION = v35.36; eval "use lib v33.55"; is ($@, ''); eval "use lib v100.105"; - like ($@, qr/lib version 100.105 \(v100\.105\.0\) required--this is only version 35.036000 \(v35\.36\.0\)/); + like ($@, qr/lib version v100.105.0 required--this is only version v35\.36\.0/); eval "use lib 33.55"; is ($@, ''); eval "use lib 100.105"; - like ($@, qr/lib version 100.105 \(v100\.105\.0\) required--this is only version 35.036000 \(v35\.36\.0\)/); + like ($@, qr/lib version 100.105 required--this is only version 35.036000/); } diff --git a/t/op/universal.t b/t/op/universal.t index 5e7fb1e..69067e8 100755 --- a/t/op/universal.t +++ b/t/op/universal.t @@ -114,7 +114,7 @@ ok ! $a->can("export_tags"); # a method in Exporter cmp_ok eval { $a->VERSION }, '==', 2.718; ok ! (eval { $a->VERSION(2.719) }); -like $@, qr/^Alice version 2.719 \(v2\.719\.0\) required--this is only version 2.718 \(v2\.718\.0\) at /; +like $@, qr/^Alice version 2.719 required--this is only version 2.718 at /; ok (eval { $a->VERSION(2.718) }); is $@, ''; diff --git a/universal.c b/universal.c index 69c31f1..0d2ec1c 100644 --- a/universal.c +++ b/universal.c @@ -457,7 +457,7 @@ XS(XS_UNIVERSAL_VERSION) sv_setsv(nsv, sv); sv = nsv; if ( !sv_derived_from(sv, "version")) - upg_version(sv); + upg_version(sv, FALSE); undef = NULL; } else { @@ -483,19 +483,23 @@ XS(XS_UNIVERSAL_VERSION) if ( !sv_derived_from(req, "version")) { /* req may very well be R/O, so create a new object */ - SV * const nsv = sv_newmortal(); - sv_setsv(nsv, req); - req = nsv; - upg_version(req); + req = sv_2mortal( new_version(req) ); } - if ( vcmp( req, sv ) > 0 ) - Perl_croak(aTHX_ "%s version %"SVf" (%"SVf") required--" - "this is only version %"SVf" (%"SVf")", HvNAME_get(pkg), - SVfARG(vnumify(req)), + if ( vcmp( req, sv ) > 0 ) { + if ( hv_exists((HV*)SvRV(req), "qv", 2 ) ) { + Perl_croak(aTHX_ "%s version %"SVf" required--" + "this is only version %"SVf"", HvNAME_get(pkg), SVfARG(vnormal(req)), - SVfARG(vnumify(sv)), SVfARG(vnormal(sv))); + } else { + Perl_croak(aTHX_ "%s version %"SVf" required--" + "this is only version %"SVf"", HvNAME_get(pkg), + SVfARG(vnumify(req)), + SVfARG(vnumify(sv))); + } + } + } if ( SvOK(sv) && sv_derived_from(sv, "version") ) { @@ -728,29 +732,10 @@ XS(XS_version_qv) { SV * ver = ST(0); if ( !SvVOK(ver) ) { /* only need to do with if not already v-string */ - SV * const vs = sv_newmortal(); - char *version; - if ( SvNOK(ver) ) /* may get too much accuracy */ - { - char tbuf[64]; -#ifdef USE_LOCALE_NUMERIC - char *loc = setlocale(LC_NUMERIC, "C"); -#endif - STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVgf, SvNVX(ver)); -#ifdef USE_LOCALE_NUMERIC - setlocale(LC_NUMERIC, loc); -#endif - while (tbuf[len-1] == '0' && len > 0) len--; - version = savepvn(tbuf, len); - } - else - { - version = savesvpv(ver); - } - (void)scan_version(version,vs,TRUE); - Safefree(version); - - PUSHs(vs); + SV * const rv = sv_newmortal(); + sv_setsv(rv,ver); /* make a duplicate */ + upg_version(rv, TRUE); + PUSHs(rv); } else { diff --git a/util.c b/util.c index c25402f..5a95d68 100644 --- a/util.c +++ b/util.c @@ -4326,7 +4326,7 @@ Perl_new_version(pTHX_ SV *ver) } } #endif - return upg_version(rv); + return upg_version(rv, FALSE); } /* @@ -4334,24 +4334,25 @@ Perl_new_version(pTHX_ SV *ver) In-place upgrade of the supplied SV to a version object. - SV *sv = upg_version(SV *sv); + SV *sv = upg_version(SV *sv, bool qv); -Returns a pointer to the upgraded SV. +Returns a pointer to the upgraded SV. Set the boolean qv if you want +to force this SV to be interpreted as an "extended" version. =cut */ SV * -Perl_upg_version(pTHX_ SV *ver) +Perl_upg_version(pTHX_ SV *ver, bool qv) { const char *version, *s; - bool qv = 0; #ifdef SvVOK const MAGIC *mg; #endif - if ( SvNOK(ver) ) /* may get too much accuracy */ + if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) ) { + /* may get too much accuracy */ char tbuf[64]; #ifdef USE_LOCALE_NUMERIC char *loc = setlocale(LC_NUMERIC, "C"); @@ -4371,7 +4372,35 @@ Perl_upg_version(pTHX_ SV *ver) #endif else /* must be a string or something like a string */ { - version = savepv(SvPV_nolen(ver)); + STRLEN len; + version = savepv(SvPV(ver,len)); +#ifndef SvVOK +# if PERL_VERSION > 5 + /* This will only be executed for 5.6.0 - 5.8.0 inclusive */ + if ( len == 3 && !instr(version,".") && !instr(version,"_") ) { + /* may be a v-string */ + SV * const nsv = sv_newmortal(); + const char *nver; + const char *pos; + int saw_period = 0; + sv_setpvf(nsv,"%vd",ver); + pos = nver = savepv(SvPV_nolen(nsv)); + + /* scan the resulting formatted string */ + while ( *pos == '.' || isDIGIT(*pos) ) { + if ( *pos == '.' ) + saw_period++ ; + pos++; + } + + /* is definitely a v-string */ + if ( saw_period == 2 ) { + Safefree(version); + version = nver; + } + } +# endif +#endif } s = scan_version(version, ver, qv);