[patch] Fwd: CPAN Upload: J/JP/JPEACOCK/version-0.64.tar.gz

Message-ID: <4488CB5C.4070702@rowman.com>

p4raw-id: //depot/perl@28375

5 files changed, 64 insertions, 22 deletions

diff --git a/lib/version.pm b/lib/version.pm
index 3fcb6b1ba1..74313c3c51 100644
--- a/lib/version.pm
+++ b/lib/version.pm
@@ -6,8 +6,7 @@ use strict;
 
 use vars qw(@ISA $VERSION $CLASS *qv);
 
-$VERSION = "0.60_02";
-$VERSION = eval($VERSION);
+$VERSION = 0.64;
 
 $CLASS = 'version';
 
@@ -19,7 +18,7 @@ sub import {
     
     *{$callpkg."::qv"} = 
 	    sub {return bless version::qv(shift), $class }
-	unless $callpkg->can('qv');
+	unless defined (&{"$callpkg\::qv"});
 
 }
 
diff --git a/lib/version.pod b/lib/version.pod
index a8742033fe..0f4f20d45e 100644
--- a/lib/version.pod
+++ b/lib/version.pod
@@ -261,6 +261,19 @@ must be quoted to be converted properly.  For this reason, it is strongly
 recommended that all initializers to qv() be quoted strings instead of
 bare numbers.
 
+To prevent the C<qv()> function from being exported to the caller's namespace,
+either use version with a null parameter:
+
+  use version ();
+
+or just require version, like this:
+
+  require version;
+
+Both methods will prevent the import() method from firing and exporting the
+C<qv()> sub.  This is true of subclasses of version as well, see
+L<SUBCLASSING> for details.
+
 =back
 
 For the subsequent examples, the following three objects will be used:
@@ -570,14 +583,10 @@ derived class:
 See also L<version::AlphaBeta> on CPAN for an alternate representation of
 version strings.
 
-B<NOTE:> the L<qv> operator is not a class method and will not be inherited
-in the same way as the other methods.  L<qv> will always return an object of
-type L<version> and not an object in the derived class.  If you need to
-have L<qv> return an object in your derived class, add something like this:
-
-  *::qv = sub { return bless version::qv(shift), __PACKAGE__ };
-
-as seen in the test file F<t/02derived.t>.
+B<NOTE:> Although the L<qv> operator is not a true class method, but rather a
+function exported into the caller's namespace, a subclass of version will 
+inherit an import() function which will perform the correct magic on behalf
+of the subclass.
 
 =head1 EXPORT
 
diff --git a/lib/version.t b/lib/version.t
index 055531ce36..c9da642ae2 100644
--- a/lib/version.t
+++ b/lib/version.t
@@ -414,6 +414,23 @@ SKIP: 	{
 	$version = $CLASS->new(" 1.7");
 	ok($version->numify eq "1.700", "leading space ignored");
 
+	# RT 19517 - deal with undef and 'undef' initialization
+	ok($version ne 'undef', "Undef version comparison #1");
+	ok($version ne undef, "Undef version comparison #2");
+	$version = $CLASS->new('undef');
+	unlike($warning, qr/^Version string 'undef' contains invalid data/,
+	    "Version string 'undef'");
+
+	$version = $CLASS->new(undef);
+	like($warning, qr/^Use of uninitialized value/,
+	    "Version string 'undef'");
+	ok($version eq 'undef', "Undef version comparison #3");
+	ok($version eq undef, "Undef version comparison #4");
+	eval "\$version = \$CLASS->new()"; # no parameter at all
+	unlike($@, qr/^Bizarre copy of CODE/, "No initializer at all");
+	ok($version eq 'undef', "Undef version comparison #5");
+	ok($version eq undef, "Undef version comparison #6");
+
 SKIP:	{
 
 	    # dummy up a legal module for testing RT#19017
@@ -443,6 +460,21 @@ EOF
 
 	    unlink 'www.pm';
 	}
+ 
+	open F, ">vvv.pm" or die "Cannot open vvv.pm: $!\n";
+	print F <<"EOF";
+package vvv;
+use base qw(version);
+1;
+EOF
+	close F;
+	# need to eliminate any other qv()'s
+	undef *main::qv;
+	ok(!defined(&{"main\::qv"}), "make sure we cleared qv() properly");
+	eval "use lib '.'; use vvv;";
+	ok(defined(&{"main\::qv"}), "make sure we exported qv() properly");
+	isa_ok( qv(1.2), "vvv");
+	unlink 'vvv.pm';
 }
 
 1;
diff --git a/universal.c b/universal.c
index 705573e9f9..a1e91b7937 100644
--- a/universal.c
+++ b/universal.c
@@ -413,14 +413,10 @@ XS(XS_version_new)
 		? HvNAME(SvSTASH(SvRV(ST(0))))
 		: (char *)SvPV_nolen(ST(0));
 
-	if ( items == 1 ) {
-	    /* no parameter provided */
-	    if ( sv_isobject(ST(0)) )
-	    {
-		/* create empty object */
-		vs = sv_newmortal();
-		sv_setpvn(vs,"",0);
-	    }
+	if ( items == 1 || vs == &PL_sv_undef ) { /* no param or explicit undef */
+	    /* create empty object */
+	    vs = sv_newmortal();
+	    sv_setpvn(vs,"",0);
 	}
 	else if ( items == 3 ) {
 	    vs = sv_newmortal();
diff --git a/util.c b/util.c
index e4832deb5a..07dd4d4650 100644
--- a/util.c
+++ b/util.c
@@ -4192,6 +4192,11 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
     if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */
 	av_push(av, newSViv(0));
 
+    /* fix RT#19517 - special case 'undef' as string */
+    if ( *s == 'u' && strEQ(s,"undef") ) {
+	s += 5;
+    }
+
     /* And finally, store the AV in the hash */
     hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0);
     return s;
@@ -4311,12 +4316,13 @@ Perl_upg_version(pTHX_ SV *ver)
     {
 	version = savepv(SvPV_nolen(ver));
     }
+
     s = scan_version(version, ver, qv);
     if ( *s != '\0' ) 
-        if(ckWARN(WARN_MISC))
+	if(ckWARN(WARN_MISC))
 	    Perl_warner(aTHX_ packWARN(WARN_MISC), 
-                "Version string '%s' contains invalid data; "
-	        "ignoring: '%s'", version, s);
+		"Version string '%s' contains invalid data; "
+		"ignoring: '%s'", version, s);
     Safefree(version);
     return ver;
 }