From: Michael G. Schwern <schwern@pobox.com>
Date: Mon, 21 Jan 2002 15:16:42 +0000 (-0500)
Subject: Re: bless() bug ? Why fails reblessing of 'main::Object' to 'Object' ?
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=301daebccb7cf8ef4420fe0ae3cdddd299f11568;p=p5sagit%2Fp5-mst-13.2.git

Re: bless() bug ? Why fails reblessing of 'main::Object' to 'Object' ?
Message-ID: <20020121201642.GA6659@blackrider>

p4raw-id: //depot/perl@14385
---

diff --git a/embed.fnc b/embed.fnc
index 9cf223e..f86c780 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1287,7 +1287,7 @@ s	|I32	|cr_textfilter	|int idx|SV *sv|int maxlen
 #endif
 
 #if defined(PERL_IN_UNIVERSAL_C) || defined(PERL_DECL_PROT)
-s	|SV*|isa_lookup	|HV *stash|const char *name|int len|int level
+s	|SV*|isa_lookup	|HV *stash|const char *name|HV *name_stash|int len|int level
 #endif
 
 #if defined(PERL_IN_LOCALE_C) || defined(PERL_DECL_PROT)
diff --git a/embed.h b/embed.h
index 49ca595..cb7c1b3 100644
--- a/embed.h
+++ b/embed.h
@@ -2735,7 +2735,7 @@
 #  endif
 #endif
 #if defined(PERL_IN_UNIVERSAL_C) || defined(PERL_DECL_PROT)
-#define isa_lookup(a,b,c,d)	S_isa_lookup(aTHX_ a,b,c,d)
+#define isa_lookup(a,b,c,d,e)	S_isa_lookup(aTHX_ a,b,c,d,e)
 #endif
 #if defined(PERL_IN_LOCALE_C) || defined(PERL_DECL_PROT)
 #define stdize_locale(a)	S_stdize_locale(aTHX_ a)
diff --git a/proto.h b/proto.h
index 1e1888f..83d6bc9 100644
--- a/proto.h
+++ b/proto.h
@@ -1312,7 +1312,7 @@ STATIC I32	S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen);
 #endif
 
 #if defined(PERL_IN_UNIVERSAL_C) || defined(PERL_DECL_PROT)
-STATIC SV*	S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level);
+STATIC SV*	S_isa_lookup(pTHX_ HV *stash, const char *name, HV *name_stash, int len, int level);
 #endif
 
 #if defined(PERL_IN_LOCALE_C) || defined(PERL_DECL_PROT)
diff --git a/t/op/universal.t b/t/op/universal.t
index 00e99fc..2e31d78 100755
--- a/t/op/universal.t
+++ b/t/op/universal.t
@@ -9,7 +9,7 @@ BEGIN {
     $| = 1;
 }
 
-print "1..91\n";
+print "1..93\n";
 
 $a = {};
 bless $a, "Bob";
@@ -57,8 +57,10 @@ package main;
 $a = new Alice;
 
 test $a->isa("Alice");
+test $a->isa("main::Alice");    # check that alternate class names work
 
 test $a->isa("Bob");
+test $a->isa("main::Bob");
 
 test $a->isa("Female");
 
diff --git a/universal.c b/universal.c
index 8fc7d69..53b9e9f 100644
--- a/universal.c
+++ b/universal.c
@@ -8,7 +8,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 +17,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;
@@ -80,7 +83,8 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level)
 			    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;
 		}
@@ -109,6 +113,7 @@ Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
 {
     char *type;
     HV *stash;
+    HV *name_stash;
 
     stash = Nullhv;
     type = Nullch;
@@ -126,8 +131,11 @@ 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 ;
 }