support for version vectors in UNIVERSAL::VERSION(), so that

C<use Foo v1.2.3> etc., work; tests for the same

TODO: XS_VERSION_BOOTCHECK needs to be revisited in light of this

p4raw-id: //depot/perl@5265

diff --git a/embed.h b/embed.h
index d0e0946..f03f499 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -686,6 +686,7 @@
 #define sv_usepvn              Perl_sv_usepvn
 #define sv_vcatpvfn            Perl_sv_vcatpvfn
 #define sv_vsetpvfn            Perl_sv_vsetpvfn
+#define str_to_version         Perl_str_to_version
 #define swash_init             Perl_swash_init
 #define swash_fetch            Perl_swash_fetch
 #define taint_env              Perl_taint_env
@@ -2113,6 +2114,7 @@
 #define sv_usepvn(a,b,c)       Perl_sv_usepvn(aTHX_ a,b,c)
 #define sv_vcatpvfn(a,b,c,d,e,f,g)     Perl_sv_vcatpvfn(aTHX_ a,b,c,d,e,f,g)
 #define sv_vsetpvfn(a,b,c,d,e,f,g)     Perl_sv_vsetpvfn(aTHX_ a,b,c,d,e,f,g)
+#define str_to_version(a)      Perl_str_to_version(aTHX_ a)
 #define swash_init(a,b,c,d,e)  Perl_swash_init(aTHX_ a,b,c,d,e)
 #define swash_fetch(a,b)       Perl_swash_fetch(aTHX_ a,b)
 #define taint_env()            Perl_taint_env(aTHX)
@@ -4145,6 +4147,8 @@
 #define sv_vcatpvfn            Perl_sv_vcatpvfn
 #define Perl_sv_vsetpvfn       CPerlObj::Perl_sv_vsetpvfn
 #define sv_vsetpvfn            Perl_sv_vsetpvfn
+#define Perl_str_to_version    CPerlObj::Perl_str_to_version
+#define str_to_version         Perl_str_to_version
 #define Perl_swash_init                CPerlObj::Perl_swash_init
 #define swash_init             Perl_swash_init
 #define Perl_swash_fetch       CPerlObj::Perl_swash_fetch

diff --git a/embed.pl b/embed.pl
index a3f9ef3..d4fe1f2 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -2004,6 +2004,7 @@ Apd       |void   |sv_vcatpvfn    |SV* sv|const char* pat|STRLEN patlen \
 Apd    |void   |sv_vsetpvfn    |SV* sv|const char* pat|STRLEN patlen \
                                |va_list* args|SV** svargs|I32 svmax \
                                |bool *maybe_tainted
+Ap     |NV     |str_to_version |SV *sv
 Ap     |SV*    |swash_init     |char* pkg|char* name|SV* listsv \
                                |I32 minbits|I32 none
 Ap     |UV     |swash_fetch    |SV *sv|U8 *ptr

diff --git a/global.sym b/global.sym
index fee7614..b38fc6f 100644 (file)
--- a/global.sym
+++ b/global.sym
@@ -431,6 +431,7 @@ Perl_sv_upgrade
 Perl_sv_usepvn
 Perl_sv_vcatpvfn
 Perl_sv_vsetpvfn
+Perl_str_to_version
 Perl_swash_init
 Perl_swash_fetch
 Perl_taint_env

diff --git a/objXSUB.h b/objXSUB.h
index 44dc1e9..86200bc 100644 (file)
--- a/objXSUB.h
+++ b/objXSUB.h
@@ -1737,6 +1737,10 @@
 #define Perl_sv_vsetpvfn       pPerl->Perl_sv_vsetpvfn
 #undef  sv_vsetpvfn
 #define sv_vsetpvfn            Perl_sv_vsetpvfn
+#undef  Perl_str_to_version
+#define Perl_str_to_version    pPerl->Perl_str_to_version
+#undef  str_to_version
+#define str_to_version         Perl_str_to_version
 #undef  Perl_swash_init
 #define Perl_swash_init                pPerl->Perl_swash_init
 #undef  swash_init

diff --git a/perlapi.c b/perlapi.c
index add96c4..e26f9f1 100644 (file)
--- a/perlapi.c
+++ b/perlapi.c
@@ -3140,6 +3140,13 @@ Perl_sv_vsetpvfn(pTHXo_ SV* sv, const char* pat, STRLEN patlen, va_list* args, S
     ((CPerlObj*)pPerl)->Perl_sv_vsetpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
 }
 
+#undef  Perl_str_to_version
+NV
+Perl_str_to_version(pTHXo_ SV *sv)
+{
+    return ((CPerlObj*)pPerl)->Perl_str_to_version(sv);
+}
+
 #undef  Perl_swash_init
 SV*
 Perl_swash_init(pTHXo_ char* pkg, char* name, SV* listsv, I32 minbits, I32 none)

diff --git a/proto.h b/proto.h
index c7b6aa4..3013bd7 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -768,6 +768,7 @@ PERL_CALLCONV bool  Perl_sv_upgrade(pTHX_ SV* sv, U32 mt);
 PERL_CALLCONV void     Perl_sv_usepvn(pTHX_ SV* sv, char* ptr, STRLEN len);
 PERL_CALLCONV void     Perl_sv_vcatpvfn(pTHX_ SV* sv, const char* pat, STRLEN patlen, va_list* args, SV** svargs, I32 svmax, bool *maybe_tainted);
 PERL_CALLCONV void     Perl_sv_vsetpvfn(pTHX_ SV* sv, const char* pat, STRLEN patlen, va_list* args, SV** svargs, I32 svmax, bool *maybe_tainted);
+PERL_CALLCONV NV       Perl_str_to_version(pTHX_ SV *sv);
 PERL_CALLCONV SV*      Perl_swash_init(pTHX_ char* pkg, char* name, SV* listsv, I32 minbits, I32 none);
 PERL_CALLCONV UV       Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr);
 PERL_CALLCONV void     Perl_taint_env(pTHX);

diff --git a/t/comp/use.t b/t/comp/use.t
index dbbda5c..c3cdb70 100755 (executable)
--- a/t/comp/use.t
+++ b/t/comp/use.t
@@ -5,7 +5,7 @@ BEGIN {
     unshift @INC, '../lib';
 }
 
-print "1..15\n";
+print "1..27\n";
 
 my $i = 1;
 eval "use 5.000";      # implicit semicolon
@@ -103,3 +103,68 @@ print "ok ",$i++,"\n";
 
 print "not " if $INC[0] eq "freda";
 print "ok ",$i++,"\n";
+
+{
+    local $lib::VERSION = 35.36;
+    eval "use lib v33.55";
+    print "not " if $@;
+    print "ok ",$i++,"\n";
+
+    eval "use lib v100.105";
+    unless ($@ =~ /lib version 100\.105 required--this is only version 35\.36/) {
+       print "not ";
+    }
+    print "ok ",$i++,"\n";
+
+    eval "use lib 33.55";
+    print "not " if $@;
+    print "ok ",$i++,"\n";
+
+    eval "use lib 100.105";
+    unless ($@ =~ /lib version 100\.105 required--this is only version 35\.36/) {
+       print "not ";
+    }
+    print "ok ",$i++,"\n";
+
+    local $lib::VERSION = '35.36';
+    eval "use lib v33.55";
+    print "not " if $@;
+    print "ok ",$i++,"\n";
+
+    eval "use lib v100.105";
+    unless ($@ =~ /lib version 100\.105 required--this is only version 35\.36/) {
+       print "not ";
+    }
+    print "ok ",$i++,"\n";
+
+    eval "use lib 33.55";
+    print "not " if $@;
+    print "ok ",$i++,"\n";
+
+    eval "use lib 100.105";
+    unless ($@ =~ /lib version 100\.105 required--this is only version 35\.36/) {
+       print "not ";
+    }
+    print "ok ",$i++,"\n";
+
+    local $lib::VERSION = v35.36;
+    eval "use lib v33.55";
+    print "not " if $@;
+    print "ok ",$i++,"\n";
+
+    eval "use lib v100.105";
+    unless ($@ =~ /lib version v100\.105 required--this is only version v35\.36/) {
+       print "not ";
+    }
+    print "ok ",$i++,"\n";
+
+    eval "use lib 33.55";
+    print "not " if $@;
+    print "ok ",$i++,"\n";
+
+    eval "use lib 100.105";
+    unless ($@ =~ /lib version 100\.105 required--this is only version 35\.036/) {
+       print "not ";
+    }
+    print "ok ",$i++,"\n";
+}

diff --git a/toke.c b/toke.c
index 5347ecd..e18a4c8 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -812,6 +812,31 @@ S_force_ident(pTHX_ register char *s, int kind)
     }
 }
 
+NV
+Perl_str_to_version(pTHX_ SV *sv)
+{
+    NV retval = 0.0;
+    NV nshift = 1.0;
+    STRLEN len;
+    char *start = SvPVx(sv,len);
+    bool utf = SvUTF8(sv);
+    char *end = start + len;
+    while (start < end) {
+       I32 skip;
+       UV n;
+       if (utf)
+           n = utf8_to_uv((U8*)start, &skip);
+       else {
+           n = *(U8*)start;
+           skip = 1;
+       }
+       retval += ((NV)n)/nshift;
+       start += skip;
+       nshift *= 1000;
+    }
+    return retval;
+}
+
 /* 
  * S_force_version
  * Forces the next token to be a version number.
@@ -833,12 +858,12 @@ S_force_version(pTHX_ char *s)
         if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
            SV *ver;
             s = scan_num(s);
-            /* real VERSION number -- GBARR */
             version = yylval.opval;
            ver = cSVOPx(version)->op_sv;
            if (SvPOK(ver) && !SvNIOK(ver)) {
-               SvUPGRADE(ver, SVt_PVIV);
-               SvIOKp_on(ver);         /* hint that it is a version */
+               SvUPGRADE(ver, SVt_PVNV);
+               SvNVX(ver) = str_to_version(ver);
+               SvNOK_on(ver);          /* hint that it is a version */
            }
         }
     }

diff --git a/universal.c b/universal.c
index 6ccff2f..0e5a89b 100644 (file)
--- a/universal.c
+++ b/universal.c
@@ -197,11 +197,10 @@ XS(XS_UNIVERSAL_VERSION)
     GV *gv;
     SV *sv;
     char *undef;
-    NV req;
 
-    if(SvROK(ST(0))) {
+    if (SvROK(ST(0))) {
         sv = (SV*)SvRV(ST(0));
-        if(!SvOBJECT(sv))
+        if (!SvOBJECT(sv))
             Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
         pkg = SvSTASH(sv);
     }
@@ -222,12 +221,56 @@ XS(XS_UNIVERSAL_VERSION)
         undef = "(undef)";
     }
 
-    if (items > 1 && (undef || (req = SvNV(ST(1)), req > SvNV(sv)))) {
-       STRLEN n_a;
-       Perl_croak(aTHX_ "%s version %s required--this is only version %s",
-             HvNAME(pkg), SvPV(ST(1),n_a), undef ? undef : SvPV(sv,n_a));
+    if (items > 1) {
+       STRLEN len;
+       SV *req = ST(1);
+
+       if (undef)
+           Perl_croak(aTHX_ "%s does not define $%s::VERSION--version check failed",
+                      HvNAME(pkg), HvNAME(pkg));
+
+       if (!SvNIOK(sv) && SvPOK(sv)) {
+           char *str = SvPVx(sv,len);
+           while (len) {
+               --len;
+               /* XXX could DWIM "1.2.3" here */
+               if (!isDIGIT(str[len]) && str[len] != '.' && str[len] != '_')
+                   break;
+           }
+           if (len) {
+               if (SvNIOKp(req) && SvPOK(req)) {
+                   /* they said C<use Foo v1.2.3> and $Foo::VERSION
+                    * doesn't look like a float: do string compare */
+                   if (sv_cmp(req,sv) == 1) {
+                       Perl_croak(aTHX_ "%s version v%vd required--"
+                                  "this is only version v%vd",
+                                  HvNAME(pkg), req, sv);
+                   }
+                   goto finish;
+               }
+               /* they said C<use Foo 1.002_003> and $Foo::VERSION
+                * doesn't look like a float: force numeric compare */
+               SvUPGRADE(sv, SVt_PVNV);
+               SvNVX(sv) = str_to_version(sv);
+               SvPOK_off(sv);
+               SvNOK_on(sv);
+           }
+       }
+       /* if we get here, we're looking for a numeric comparison,
+        * so force the required version into a float, even if they
+        * said C<use Foo v1.2.3> */
+       if (SvNIOKp(req) && SvPOK(req)) {
+           NV n = SvNV(req);
+           req = sv_newmortal();
+           sv_setnv(req, n);
+       }
+
+       if (SvNV(req) > SvNV(sv))
+           Perl_croak(aTHX_ "%s version %s required--this is only version %s",
+                 HvNAME(pkg), SvPV(req,len), SvPV(sv,len));
     }
 
+finish:
     ST(0) = sv;
 
     XSRETURN(1);