Bring core up to version-0.9902

The attached patch bring the core Perl version code (including a fairly
significant leak when run in a tight loop) up to parity with CPAN
0.9902.  This deals with all open issues except:

   https://rt.cpan.org/Ticket/Display.html?id=81294

which I am having a hard time modeling.

John

Signed-off-by: Chris 'BinGOs' Williams <chris@bingosnet.co.uk>

diff --git a/lib/version.pm b/lib/version.pm
index 286dc79..27774bd 100644 (file)
--- a/lib/version.pm
+++ b/lib/version.pm
@@ -6,7 +6,7 @@ use strict;
 
 use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);
 
-$VERSION = 0.9901;
+$VERSION = 0.9902;
 
 $CLASS = 'version';
 

diff --git a/lib/version/t/01base.t b/lib/version/t/01base.t
index c84531d..9aa8052 100644 (file)
--- a/lib/version/t/01base.t
+++ b/lib/version/t/01base.t
@@ -9,7 +9,7 @@ use Test::More qw/no_plan/;
 BEGIN {
     (my $coretests = $0) =~ s'[^/]+\.t'coretests.pm';
     require $coretests;
-    use_ok('version', 0.9901);
+    use_ok('version', 0.9902);
 }
 
 diag "Tests with base class" unless $ENV{PERL_CORE};
@@ -32,3 +32,15 @@ my $v = eval {
     return IO::Handle->VERSION;
 };
 ok defined($v), 'Fix for RT #47980';
+
+{ # https://rt.cpan.org/Ticket/Display.html?id=81085
+    eval { version::new() };
+    like $@, qr'Usage: version::new\(class, version\)',
+       'No bus err when called as function';
+    eval { $x = 1; print version::new };
+    like $@, qr'Usage: version::new\(class, version\)',
+       'No implicit object creation when called as function';
+    eval { $x = "version"; print version::new };
+    like $@, qr'Usage: version::new\(class, version\)',
+       'No implicit object creation when called as function';
+}

diff --git a/lib/version/t/02derived.t b/lib/version/t/02derived.t
index ea683a9..c7afe0f 100644 (file)
--- a/lib/version/t/02derived.t
+++ b/lib/version/t/02derived.t
@@ -10,7 +10,7 @@ use File::Temp qw/tempfile/;
 BEGIN {
     (my $coretests = $0) =~ s'[^/]+\.t'coretests.pm';
     require $coretests;
-    use_ok("version", 0.9901);
+    use_ok("version", 0.9902);
     # If we made it this far, we are ok.
 }
 

diff --git a/lib/version/t/03require.t b/lib/version/t/03require.t
index 3d99cb1..66c6bd3 100644 (file)
--- a/lib/version/t/03require.t
+++ b/lib/version/t/03require.t
@@ -14,7 +14,7 @@ BEGIN {
 # Don't want to use, because we need to make sure that the import doesn't
 # fire just yet (some code does this to avoid importing qv() and delare()).
 require_ok("version");
-is $version::VERSION, 0.9901, "Make sure we have the correct class";
+is $version::VERSION, 0.9902, "Make sure we have the correct class";
 ok(!"main"->can("qv"), "We don't have the imported qv()");
 ok(!"main"->can("declare"), "We don't have the imported declare()");
 

diff --git a/lib/version/t/05sigdie.t b/lib/version/t/05sigdie.t
index dd785d5..188f185 100644 (file)
--- a/lib/version/t/05sigdie.t
+++ b/lib/version/t/05sigdie.t
@@ -15,7 +15,7 @@ BEGIN {
 
 
 BEGIN {
-    use version 0.9901;
+    use version 0.9902;
 }
 
 pass "Didn't get caught by the wrong DIE handler, which is a good thing";

diff --git a/lib/version/t/06noop.t b/lib/version/t/06noop.t
index ff556ad..9d113ed 100644 (file)
--- a/lib/version/t/06noop.t
+++ b/lib/version/t/06noop.t
@@ -7,7 +7,7 @@
 use Test::More qw/no_plan/;
 
 BEGIN {
-    use_ok('version', 0.9901);
+    use_ok('version', 0.9902);
 }
 
 my $v1 = version->new('1.2');

diff --git a/lib/version/t/07locale.t b/lib/version/t/07locale.t
index a2005f8..3b67f3d 100644 (file)
--- a/lib/version/t/07locale.t
+++ b/lib/version/t/07locale.t
@@ -11,7 +11,7 @@ use Test::More tests => 7;
 use Config;
 
 BEGIN {
-    use_ok('version', 0.9901);
+    use_ok('version', 0.9902);
 }
 
 SKIP: {

diff --git a/universal.c b/universal.c
index f583817..a72c072 100644 (file)
--- a/universal.c
+++ b/universal.c
@@ -490,7 +490,7 @@ XS(XS_version_new)
 {
     dVAR;
     dXSARGS;
-    if (items > 3)
+    if (items > 3 || items < 1)
        croak_xs_usage(cv, "class, version");
     SP -= items;
     {

diff --git a/util.c b/util.c
index a3fbd3c..2c745bf 100644 (file)
--- a/util.c
+++ b/util.c
@@ -4500,7 +4500,7 @@ it doesn't.
 const char *
 Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
 {
-    const char *start;
+    const char *start = s;
     const char *pos;
     const char *last;
     const char *errstr = NULL;
@@ -4508,17 +4508,11 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
     int width = 3;
     bool alpha = FALSE;
     bool vinf = FALSE;
-    AV * const av = newAV();
-    SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
+    AV * av;
+    SV * hv;
 
     PERL_ARGS_ASSERT_SCAN_VERSION;
 
-    (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
-
-#ifndef NODEFAULT_SHAREKEYS
-    HvSHAREKEYS_on(hv);         /* key-sharing on by default */
-#endif
-
     while (isSPACE(*s)) /* leading whitespace is OK */
        s++;
 
@@ -4526,6 +4520,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
     if (errstr) {
        /* "undef" is a special case and not an error */
        if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
+           Safefree(start);
            Perl_croak(aTHX_ "%s", errstr);
        }
     }
@@ -4535,13 +4530,22 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
        s++;
     pos = s;
 
+    /* Now that we are through the prescan, start creating the object */
+    av = newAV();
+    hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
+    (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
+
+#ifndef NODEFAULT_SHAREKEYS
+    HvSHAREKEYS_on(hv);         /* key-sharing on by default */
+#endif
+
     if ( qv )
        (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
     if ( alpha )
        (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
     if ( !qv && width < 3 )
        (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
-    
+
     while (isDIGIT(*pos))
        pos++;
     if (!isALPHA(*pos)) {
@@ -4712,7 +4716,7 @@ Perl_new_version(pTHX_ SV *ver)
 
        if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
            (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
-       
+
        if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
        {
            const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
@@ -4846,7 +4850,7 @@ Perl_upg_version(pTHX_ SV *ver, bool qv)
                    }
 
                    /* is definitely a v-string */
-                   if ( saw_decimal >= 2 ) {   
+                   if ( saw_decimal >= 2 ) {
                        Safefree(version);
                        version = nver;
                    }