In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/a0e8d7b965a2c48cce7daf93090631f0d7a9a72f?hp=c3ea6d286d7ce2cab156ba526ee6161272c45eb3>
- Log -----------------------------------------------------------------
commit a0e8d7b965a2c48cce7daf93090631f0d7a9a72f
Author: John Peacock <john.peac...@havurah-software.org>
Date: Wed Jul 27 16:16:53 2011 -0700
[perl #95544] Test that UNIVERSAL::VERSION returns $VERSION
M lib/version.t
commit 9bf41c1df182ebe0899a6987bf04ea02cb385489
Author: Father Chrysostomos <spr...@cpan.org>
Date: Wed Jul 27 16:09:28 2011 -0700
[perl #95544] Make UNIVERSAL::VERSION return $VERSION
With this patch:
$ ./miniperl -le ' $VERSION = "3alpha"; print "main"->VERSION'
3alpha
$ ./miniperl -le ' $VERSION = "3alpha"; print "main"->VERSION(4)'
Invalid version format (non-numeric data) at -e line 1.
See the discussion starting at:
http://www.nntp.perl.org/group/perl.perl5.porters/2011/06/msg173710.html
Basically, this patch allows custom version parsers to call ->VERSION
to retrieve the version, even if the default parser would choke on it.
M universal.c
-----------------------------------------------------------------------
Summary of changes:
lib/version.t | 17 ++++++++++++++++-
universal.c | 19 ++++++++-----------
2 files changed, 24 insertions(+), 12 deletions(-)
diff --git a/lib/version.t b/lib/version.t
index bee9078..dd47e87 100644
--- a/lib/version.t
+++ b/lib/version.t
@@ -474,6 +474,22 @@ SKIP: {
'Replacement handles modules without VERSION');
unlink $filename;
}
+SKIP: { # https://rt.perl.org/rt3/Ticket/Display.html?id=95544
+ skip "version require'd instead of use'd, cannot test
UNIVERSAL::VERSION", 2
+ unless defined $qv_declare;
+ my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK =>
1);
+ (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 1;";
+ like ($@, qr/Invalid version format \(non-numeric data\)/,
+ 'Warn about bad $VERSION when asked');
+ }
SKIP: {
skip 'Cannot test bare v-strings with Perl < 5.6.0', 4
@@ -624,7 +640,6 @@ SKIP: {
my $warning;
local $SIG{__WARN__} = sub { $warning = $_[0] };
-$DB::single = 1;
my $v = eval { $CLASS->$method('1,7') };
# is( $@, "", 'Directly test comma as decimal compliance');
diff --git a/universal.c b/universal.c
index 3295fc5..c891b54 100644
--- a/universal.c
+++ b/universal.c
@@ -311,6 +311,7 @@ XS(XS_UNIVERSAL_VERSION)
GV **gvp;
GV *gv;
SV *sv;
+ SV *ret;
const char *undef;
PERL_UNUSED_ARG(cv);
@@ -327,15 +328,12 @@ XS(XS_UNIVERSAL_VERSION)
gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL;
if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) {
- SV * const nsv = sv_newmortal();
- sv_setsv(nsv, sv);
- sv = nsv;
- if ( !sv_derived_from(sv, "version"))
- upg_version(sv, FALSE);
+ ret = sv_newmortal();
+ sv_setsv(ret, sv);
undef = NULL;
}
else {
- sv = &PL_sv_undef;
+ sv = ret = &PL_sv_undef;
undef = "(undef)";
}
@@ -355,6 +353,9 @@ XS(XS_UNIVERSAL_VERSION)
}
}
+ if ( !sv_derived_from(sv, "version"))
+ upg_version(sv, FALSE);
+
if ( !sv_derived_from(req, "version")) {
/* req may very well be R/O, so create a new object */
req = sv_2mortal( new_version(req) );
@@ -376,11 +377,7 @@ XS(XS_UNIVERSAL_VERSION)
}
- if ( SvOK(sv) && sv_derived_from(sv, "version") ) {
- ST(0) = sv_2mortal(vstringify(sv));
- } else {
- ST(0) = sv;
- }
+ ST(0) = ret;
XSRETURN(1);
}
--
Perl5 Master Repository
