From: Rafael Garcia-Suarez <rgarciasuarez@gmail.com>
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<upg_version>
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);