add missing locks for op refcounts

[p5sagit/p5-mst-13.2.git] / universal.c

diff --git a/universal.c b/universal.c
index 1e5a1a0..f6b25a4 100644 (file)
--- 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);
@@ -140,6 +138,10 @@ XS(XS_UNIVERSAL_isa)
        Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
 
     sv = ST(0);
+
+    if (!SvOK(sv) || !(SvROK(sv) || SvCUR(sv)))
+       XSRETURN_UNDEF;
+
     name = (char *)SvPV(ST(1),n_a);
 
     ST(0) = boolSV(sv_derived_from(sv, name));
@@ -159,6 +161,10 @@ XS(XS_UNIVERSAL_can)
        Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
 
     sv = ST(0);
+
+    if (!SvOK(sv) || !(SvROK(sv) || SvCUR(sv)))
+       XSRETURN_UNDEF;
+
     name = (char *)SvPV(ST(1),n_a);
     rv = &PL_sv_undef;
 
@@ -189,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);
     }
@@ -214,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);