X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=universal.c;h=ae12e27984e80eeaa60b8e591af2052fad2cf6bd;hb=2659725b692c235823f5ea11c58cf1b2adff0f86;hp=8b2044393b82bf202b0582cf4b3e300c7d25c070;hpb=0562c0e3630958db13a0e70db1b90c05d3fee158;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/universal.c b/universal.c
index 8b20443..ae12e27 100644
--- a/universal.c
+++ b/universal.c
@@ -1,3 +1,18 @@
+/*    universal.c
+ *
+ *    Copyright (c) 1997-2002, Larry Wall
+ *
+ *    You may distribute under the terms of either the GNU General Public
+ *    License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ * "The roots of those mountains must be roots indeed; there must be
+ * great secrets buried there which have not been discovered since the
+ * beginning." --Gandalf, relating Gollum's story
+ */
+
 #include "EXTERN.h"
 #define PERL_IN_UNIVERSAL_C
 #include "perl.h"
@@ -8,7 +23,8 @@
  */
 
 STATIC SV *
-S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level)
+S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash,
+             int len, int level)
 {
     AV* av;
     GV* gv;
@@ -16,8 +32,10 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level)
     HV* hv = Nullhv;
     SV* subgen = Nullsv;
 
-    if (!stash)
-	return &PL_sv_undef;
+    /* A stash/class can go by many names (ie. User == main::User), so 
+       we compare the stash itself just in case */
+    if (name_stash && (stash == name_stash))
+        return &PL_sv_yes;
 
     if (strEQ(HvNAME(stash), name))
 	return &PL_sv_yes;
@@ -75,12 +93,13 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level)
 		HV* basestash = gv_stashsv(sv, FALSE);
 		if (!basestash) {
 		    if (ckWARN(WARN_MISC))
-			Perl_warner(aTHX_ WARN_SYNTAX,
+			Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 		             "Can't locate package %s for @%s::ISA",
 			    SvPVX(sv), HvNAME(stash));
 		    continue;
 		}
-		if (&PL_sv_yes == isa_lookup(basestash, name, len, level + 1)) {
+		if (&PL_sv_yes == isa_lookup(basestash, name, name_stash, 
+                                             len, level + 1)) {
 		    (void)hv_store(hv,name,len,&PL_sv_yes,0);
 		    return &PL_sv_yes;
 		}
@@ -93,6 +112,8 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level)
 }
 
 /*
+=head1 SV Manipulation Functions
+
 =for apidoc sv_derived_from
 
 Returns a boolean indicating whether the SV is derived from the specified
@@ -107,6 +128,7 @@ Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
 {
     char *type;
     HV *stash;
+    HV *name_stash;
 
     stash = Nullhv;
     type = Nullch;
@@ -124,17 +146,20 @@ Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
         stash = gv_stashsv(sv, FALSE);
     }
 
+    name_stash = gv_stashpv(name, FALSE);
+
     return (type && strEQ(type,name)) ||
-            (stash && isa_lookup(stash, name, strlen(name), 0) == &PL_sv_yes)
+            (stash && isa_lookup(stash, name, name_stash, strlen(name), 0) 
+             == &PL_sv_yes)
         ? TRUE
         : FALSE ;
 }
 
 #include "XSUB.h"
 
-void XS_UNIVERSAL_isa(pTHXo_ CV *cv);
-void XS_UNIVERSAL_can(pTHXo_ CV *cv);
-void XS_UNIVERSAL_VERSION(pTHXo_ CV *cv);
+void XS_UNIVERSAL_isa(pTHX_ CV *cv);
+void XS_UNIVERSAL_can(pTHX_ CV *cv);
+void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
 XS(XS_utf8_valid);
 XS(XS_utf8_encode);
 XS(XS_utf8_decode);
@@ -263,10 +288,18 @@ XS(XS_UNIVERSAL_VERSION)
 	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 (undef) {
+	     if (pkg)
+		  Perl_croak(aTHX_
+			     "%s does not define $%s::VERSION--version check failed",
+			     HvNAME(pkg), HvNAME(pkg));
+	     else {
+		  char *str = SvPVx(ST(0), len);
+
+		  Perl_croak(aTHX_
+			     "%s defines neither package nor VERSION--version check failed", str);
+	     }
+	}
 	if (!SvNIOK(sv) && SvPOK(sv)) {
 	    char *str = SvPVx(sv,len);
 	    while (len) {
@@ -303,10 +336,9 @@ XS(XS_UNIVERSAL_VERSION)
 	    sv_setnv(req, n);
 	}
 
-	if (SvNV(req) > SvNV(sv)) {
+	if (SvNV(req) > SvNV(sv))
 	    Perl_croak(aTHX_ "%s version %s required--this is only version %s",
-		       HvNAME(pkg), SvPV_nolen(req), SvPV_nolen(sv,len));
-	}
+		       HvNAME(pkg), SvPV_nolen(req), SvPV_nolen(sv));
     }
 
 finish:
@@ -426,4 +458,3 @@ XS(XS_utf8_unicode_to_native)
  XSRETURN(1);
 }
 
-