In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/a3e88ad7b21876c5341fd043218d0725ec4c4fcb?hp=73512201d7f34e916ab9c04a5f41248b4740e29a>
- Log -----------------------------------------------------------------
commit a3e88ad7b21876c5341fd043218d0725ec4c4fcb
Author: John Peacock <jpeac...@cpan.org>
Date: Thu Dec 8 20:55:37 2011 -0500
Update UNIVERSAL::VERSION POD to reflect reality.
This should have been done when version objects were originally
added to the core back in 5.10.0. Mea culpa.
[I bumped UNIVERSAL.pm version and added a perldelta entry. -- DG]
Signed-off-by: David Golden <dagol...@cpan.org>
M lib/UNIVERSAL.pm
M pod/perldelta.pod
commit 249f7ddc6a71afa99cbcae72f08451ee2462c7c5
Author: John Peacock <jpeac...@cpan.org>
Date: Tue Dec 6 21:00:36 2011 -0500
Sync up tests with upstream version.pm
Pull in the contents of t/coretests.pm (more or less) from the CPAN
release of version.pm.
Signed-off-by: David Golden <dagol...@cpan.org>
M lib/version.t
commit 573a19fb2c79f41cfc7f3db5a8ad14e14a4dccf9
Author: John Peacock <jpeac...@cpan.org>
Date: Tue Dec 6 20:55:09 2011 -0500
Use syntax from perlguts for testing objects
The following paragraph is in perlguts.pod:
To check if you've got an object derived from a specific class you have
to write:
if (sv_isobject(sv) && sv_derived_from(sv, class)) { ... }
which does the right thing with magical things like tied scalars.
Signed-off-by: David Golden <dagol...@cpan.org>
M sv.c
M universal.c
M util.c
commit a97f6d148c766c74f3c3200d95d9fbf569067b45
Author: John Peacock <jpeac...@cpan.org>
Date: Tue Dec 6 20:52:11 2011 -0500
Revert 9bf41c1d to UNIVERSAL::VERSION
Return the previous behavior where CLASS->VERSION will return a
stringified version object of the contents of $CLASS::VERSION.
Signed-off-by: David Golden <dagol...@cpan.org>
M universal.c
-----------------------------------------------------------------------
Summary of changes:
lib/UNIVERSAL.pm | 7 +++++-
lib/version.t | 63 +++++++++++++++++++++++++++++++++++++---------------
pod/perldelta.pod | 6 +++++
sv.c | 2 +-
universal.c | 40 ++++++++++++++++++---------------
util.c | 4 +-
6 files changed, 82 insertions(+), 40 deletions(-)
diff --git a/lib/UNIVERSAL.pm b/lib/UNIVERSAL.pm
index 4e41223..1adf09c 100644
--- a/lib/UNIVERSAL.pm
+++ b/lib/UNIVERSAL.pm
@@ -1,6 +1,6 @@
package UNIVERSAL;
-our $VERSION = '1.10';
+our $VERSION = '1.11';
# UNIVERSAL should not contain any extra subs/methods beyond those
# that it exists to define. The use of Exporter below is a historical
@@ -168,6 +168,11 @@ it will do a comparison and die if the package version is
not
greater than or equal to C<REQUIRE>, or if either C<$VERSION> or C<REQUIRE>
is not a "lax" version number (as defined by the L<version> module).
+The return from C<VERSION> will actually be the stringified version object
+using the package C<$VERSION> scalar, which is guaranteed to be equivalent
+but may not be precisely the contents of the C<$VERSION> scalar. If you want
+the actual contents of C<$VERSION>, use C<$CLASS::VERSION> instead.
+
C<VERSION> can be called as either a class (static) method or an object
method.
diff --git a/lib/version.t b/lib/version.t
index a92a2ad..0284643 100644
--- a/lib/version.t
+++ b/lib/version.t
@@ -486,14 +486,12 @@ SKIP: { #
https://rt.perl.org/rt3/Ticket/Display.html?id=95544
(my $package = basename($filename)) =~ s/\.pm$//;
print $fh "package $package;\n\$VERSION = '3alpha';\n1;\n";
close $fh;
- eval "use lib '.'; use $package; die $package->VERSION";
- ok ($@ =~ /3alpha/, 'Even a bad $VERSION is returned');
- eval "use lib '.'; use $package;";
- unlike ($@, qr/Invalid version format \(non-numeric data\)/,
- 'Do not warn about bad $VERSION unless asked');
+ eval "use lib '.'; use $package; print $package->VERSION";
+ like ($@, qr/Invalid version format \(non-numeric data\)/,
+ 'Warn about bad \$VERSION');
eval "use lib '.'; use $package 1;";
like ($@, qr/Invalid version format \(non-numeric data\)/,
- 'Warn about bad $VERSION when asked');
+ 'Warn about bad $VERSION');
}
SKIP: {
@@ -720,6 +718,32 @@ EOF
my $badv2 = bless { qv => 1, version => [1,2,3] }, "version";
is $badv2, 'v1.2.3', "Deal with badly serialized versions from YAML ";
}
+
+ {
+ # https://rt.cpan.org/Public/Bug/Display.html?id=70950
+ # test indirect usage of version objects
+ my $sum = 0;
+ eval '$sum += $CLASS->$method("v2.0.0")';
+ like $@, qr/operation not supported with version object/,
+ 'No math operations with version objects';
+ # test direct usage of version objects
+ my $v = $CLASS->$method("v2.0.0");
+ eval '$v += 1';
+ like $@, qr/operation not supported with version object/,
+ 'No math operations with version objects';
+ }
+
+ {
+ # https://rt.cpan.org/Ticket/Display.html?id=72365
+ # https://rt.perl.org/rt3/Ticket/Display.html?id=102586
+ eval 'my $v = $CLASS->$method("version")';
+ like $@, qr/Invalid version format/,
+ 'The string "version" is not a version';
+ eval 'my $v = $CLASS->$method("ver510n")';
+ like $@, qr/Invalid version format/,
+ 'All strings starting with "v" are not versions';
+ }
+
SKIP: {
if ( $] < 5.006_000 ) {
skip 'No v-string support at all < 5.6.0', 2;
@@ -742,20 +766,23 @@ SKIP: {
ok $CLASS->$method("1.2.3") < $CLASS->$method("1.2.3.1"), 'Compare 3
and 4 digit v-strings, quoted';
ok $CLASS->$method("v1.2.3") < $CLASS->$method("v1.2.3.1"), 'Compare 3
and 4 digit v-strings, quoted leading v';
}
-}
-eval { version->new("version") };
-pass('no crash with version->new("version")');
-{
- package _102586;
- sub TIESCALAR { bless [] }
- sub FETCH { "version" }
- sub STORE { }
- tie my $v, __PACKAGE__;
- $v = version->new(1);
- eval { version->new($v) };
+ {
+ eval '$CLASS->$method("version")';
+ pass("no crash with ${CLASS}->${method}('version')");
+ {
+ package _102586;
+ sub TIESCALAR { bless [] }
+ sub FETCH { "version" }
+ sub STORE { }
+ my $v;
+ tie $v, __PACKAGE__;
+ $v = $CLASS->$method(1);
+ eval '$CLASS->$method($v)';
+ }
+ pass('no crash with version->new($tied) where $tied returns "version"');
+ }
}
-pass('no crash with version->new($tied) where $tied returns "version"');
1;
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 85a80ca..42b71f6 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -310,6 +310,12 @@ the locales: ja, ko, zh__big5han, zh__gb2312han,
zh__pinyin, zh__stroke.
Now Locale/*.pl files are searched in @INC.
+=item *
+
+L<UNIVERSAL> has been upgraded from version 1.10 to 1.11.
+
+Documentation change clarifies return values from UNIVERSAL::VERSION.
+
=back
=head2 Removed Modules and Pragmata
diff --git a/sv.c b/sv.c
index ae97f1d..cf29ffa 100644
--- a/sv.c
+++ b/sv.c
@@ -10354,7 +10354,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const
pat, const STRLEN patlen,
* back into v-string notation and then let the
* vectorize happen normally
*/
- if (sv_derived_from(vecsv, "version") && SvROK(vecsv)) {
+ if (sv_isobject(vecsv) && sv_derived_from(vecsv, "version")) {
char *version = savesvpv(vecsv);
if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
diff --git a/universal.c b/universal.c
index aeefca8..a109e7d 100644
--- a/universal.c
+++ b/universal.c
@@ -406,7 +406,6 @@ XS(XS_UNIVERSAL_VERSION)
GV **gvp;
GV *gv;
SV *sv;
- SV *ret;
const char *undef;
PERL_UNUSED_ARG(cv);
@@ -423,12 +422,16 @@ XS(XS_UNIVERSAL_VERSION)
gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
- ret = sv_newmortal();
- sv_setsv(ret, sv);
+ SV * const nsv = sv_newmortal();
+ sv_setsv(nsv, sv);
+ sv = nsv;
+ if ( !sv_isobject(sv) || !sv_derived_from(sv, "version"))
+ upg_version(sv, FALSE);
+
undef = NULL;
}
else {
- sv = ret = &PL_sv_undef;
+ sv = &PL_sv_undef;
undef = "(undef)";
}
@@ -449,10 +452,7 @@ XS(XS_UNIVERSAL_VERSION)
}
}
- if ( !sv_derived_from(sv, "version") || !SvROK(sv))
- upg_version(sv, FALSE);
-
- if ( !sv_derived_from(req, "version") || !SvROK(req)) {
+ if ( !sv_isobject(req) || !sv_derived_from(req, "version")) {
/* req may very well be R/O, so create a new object */
req = sv_2mortal( new_version(req) );
}
@@ -475,7 +475,11 @@ XS(XS_UNIVERSAL_VERSION)
}
- ST(0) = ret;
+ if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
+ ST(0) = sv_2mortal(vstringify(sv));
+ } else {
+ ST(0) = sv;
+ }
XSRETURN(1);
}
@@ -534,7 +538,7 @@ XS(XS_version_stringify)
{
SV * lobj = ST(0);
- if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
+ if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
lobj = SvRV(lobj);
}
else
@@ -557,7 +561,7 @@ XS(XS_version_numify)
{
SV * lobj = ST(0);
- if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
+ if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
lobj = SvRV(lobj);
}
else
@@ -580,7 +584,7 @@ XS(XS_version_normal)
{
SV * lobj = ST(0);
- if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
+ if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
lobj = SvRV(lobj);
}
else
@@ -603,7 +607,7 @@ XS(XS_version_vcmp)
{
SV * lobj = ST(0);
- if (sv_derived_from(lobj, "version") && SvROK(lobj)) {
+ if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) {
lobj = SvRV(lobj);
}
else
@@ -615,7 +619,7 @@ XS(XS_version_vcmp)
SV * robj = ST(1);
const IV swap = (IV)SvIV(ST(2));
- if ( ! sv_derived_from(robj, "version") || !SvROK(robj) )
+ if ( !sv_isobject(robj) || !sv_derived_from(robj, "version") )
{
robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0",
SVs_TEMP));
sv_2mortal(robj);
@@ -646,7 +650,7 @@ XS(XS_version_boolean)
if (items < 1)
croak_xs_usage(cv, "lobj, ...");
SP -= items;
- if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
+ if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
SV * const lobj = SvRV(ST(0));
SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) );
mPUSHs(rs);
@@ -663,7 +667,7 @@ XS(XS_version_noop)
dXSARGS;
if (items < 1)
croak_xs_usage(cv, "lobj, ...");
- if (sv_derived_from(ST(0), "version") && SvROK(ST(0)))
+ if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version"))
Perl_croak(aTHX_ "operation not supported with version object");
else
Perl_croak(aTHX_ "lobj is not of type version");
@@ -679,7 +683,7 @@ XS(XS_version_is_alpha)
if (items != 1)
croak_xs_usage(cv, "lobj");
SP -= items;
- if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
+ if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
SV * const lobj = ST(0);
if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) )
XSRETURN_YES;
@@ -741,7 +745,7 @@ XS(XS_version_is_qv)
if (items != 1)
croak_xs_usage(cv, "lobj");
SP -= items;
- if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) {
+ if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) {
SV * const lobj = ST(0);
if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) )
XSRETURN_YES;
diff --git a/util.c b/util.c
index 052cb2c..316b1cc 100644
--- a/util.c
+++ b/util.c
@@ -4857,7 +4857,7 @@ Perl_new_version(pTHX_ SV *ver)
dVAR;
SV * const rv = newSV(0);
PERL_ARGS_ASSERT_NEW_VERSION;
- if ( sv_derived_from(ver,"version") && SvROK(ver) )
+ if ( sv_isobject(ver) && sv_derived_from(ver, "version") )
/* can just copy directly */
{
I32 key;
@@ -6430,7 +6430,7 @@ Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const
char *xs_p,
}
if (sv) {
SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
- SV *pmsv = sv_derived_from(sv, "version") && SvROK(sv)
+ SV *pmsv = sv_isobject(sv) && sv_derived_from(sv, "version")
? sv : sv_2mortal(new_version(sv));
xssv = upg_version(xssv, 0);
if ( vcmp(pmsv,xssv) ) {
--
Perl5 Master Repository
