X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=universal.c;h=f6b25a4d330a575b4d4648288d6763e0a2e6674b;hb=e4783991709775389a3fc70c841522b0165cd076;hp=6ccff2f00350be9d6c24d3ab066185078e8140a0;hpb=f8f703809bcc262bbe169574d2c0b30abd6f26ad;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/universal.c b/universal.c
index 6ccff2f..f6b25a4 100644
--- a/universal.c
+++ b/universal.c
@@ -86,7 +86,6 @@ for class names as well as for objects.
 bool
 Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
 {
-    SV *rv;
     char *type;
     HV *stash;
   
@@ -110,7 +109,6 @@ Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
             (stash && isa_lookup(stash, name, strlen(name), 0) == &PL_sv_yes)
         ? TRUE
         : FALSE ;
- 
 }
 
 void XS_UNIVERSAL_isa(pTHXo_ CV *cv);
@@ -197,11 +195,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 +219,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 */
+		(void)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);