Re: Bug stomping fun. [PATCH: bug #1016]

Message-Id: <1051872303.26203.104.camel@supox>
(plus perldiag nit)

p4raw-id: //depot/perl@19505

8 files changed, 56 insertions, 12 deletions

diff --git a/dump.c b/dump.c
index 119bfa3082..61cd8e0cf6 100644
--- a/dump.c
+++ b/dump.c
@@ -944,7 +944,7 @@ Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, char *name, GV *sv)
     Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv));
     if (sv && GvNAME(sv)) {
 	PerlIO_printf(file, "\t\"");
-	if (GvSTASH(sv))
+	if (GvSTASH(sv) && HvNAME(GvSTASH(sv)))
 	    PerlIO_printf(file, "%s\" :: \"", HvNAME(GvSTASH(sv)));
 	PerlIO_printf(file, "%s\"\n", GvNAME(sv));
     }
diff --git a/gv.c b/gv.c
index 489ed0bdef..95d4d36c67 100644
--- a/gv.c
+++ b/gv.c
@@ -194,6 +194,10 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
 	    return 0;
     }
 
+    if (!HvNAME(stash))
+      Perl_croak(aTHX_
+		 "Can't use anonymous symbol table for method lookup");
+
     if ((level > 100) || (level < -100))
 	Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
 	      name, HvNAME(stash));
@@ -1064,14 +1068,20 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
 void
 Perl_gv_fullname4(pTHX_ SV *sv, GV *gv, const char *prefix, bool keepmain)
 {
+    char *name;
     HV *hv = GvSTASH(gv);
     if (!hv) {
 	(void)SvOK_off(sv);
 	return;
     }
     sv_setpv(sv, prefix ? prefix : "");
-    if (keepmain || strNE(HvNAME(hv), "main")) {
-	sv_catpv(sv,HvNAME(hv));
+    
+    if (!HvNAME(hv))
+	name = "__ANON__";
+    else 
+	name = HvNAME(hv);
+    if (keepmain || strNE(name, "main")) {
+	sv_catpv(sv,name);
 	sv_catpvn(sv,"::", 2);
     }
     sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
@@ -1393,7 +1403,7 @@ Perl_gv_handler(pTHX_ HV *stash, I32 id)
     AMT *amtp;
     CV *ret;
 
-    if (!stash)
+    if (!stash || !HvNAME(stash))
         return Nullcv;
     mg = mg_find((SV*)stash, PERL_MAGIC_overload_table);
     if (!mg) {
diff --git a/hv.c b/hv.c
index f5508bfbcf..6544e08262 100644
--- a/hv.c
+++ b/hv.c
@@ -279,6 +279,8 @@ S_hv_fetch_flags(pTHX_ HV *hv, const char *key, I32 klen, I32 lval, int flags)
     /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
     for (; entry; entry = HeNEXT(entry)) {
+	if (!HeKEY_hek(entry))
+	    continue;
 	if (HeHASH(entry) != hash)		/* strings can't be equal */
 	    continue;
 	if (HeKLEN(entry) != (I32)klen)
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 8a744b9835..bc164599ba 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -1029,7 +1029,7 @@ calling sv_upgrade.
 
 =item Can't use anonymous symbol table for method lookup
 
-(P) The internal routine that does method lookup was handed a symbol
+(F) The internal routine that does method lookup was handed a symbol
 table that doesn't have a name.  Symbol tables can become anonymous
 for example by undefining stashes: C<undef %Some::Package::>.
 
diff --git a/pp.c b/pp.c
index 7acc1da8da..bcf1633c1d 100644
--- a/pp.c
+++ b/pp.c
@@ -595,7 +595,10 @@ PP(pp_gelem)
 	break;
     case 'P':
 	if (strEQ(elem, "PACKAGE"))
-	    sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
+	    if (HvNAME(GvSTASH(gv)))
+		sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
+	    else
+		sv = newSVpv("__ANON__",0);
 	break;
     case 'S':
 	if (strEQ(elem, "SCALAR"))
diff --git a/pp_hot.c b/pp_hot.c
index 926a1f84c8..fc2b9c5925 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -3024,7 +3024,11 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
 	    /* the method name is unqualified or starts with SUPER:: */ 
 	    packname = sep ? CopSTASHPV(PL_curcop) :
 		stash ? HvNAME(stash) : packname;
-	    packlen = strlen(packname);
+	    if (!packname)
+		Perl_croak(aTHX_
+			   "Can't use anonymous symbol table for method lookup");
+	    else
+		packlen = strlen(packname);
 	}
 	else {
 	    /* the method name is qualified */
diff --git a/sv.c b/sv.c
index 423bb0487f..d82e354341 100644
--- a/sv.c
+++ b/sv.c
@@ -3080,7 +3080,10 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
 		}
 		tsv = NEWSV(0,0);
 		if (SvOBJECT(sv))
-		    Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
+		    if (HvNAME(SvSTASH(sv)))
+			Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
+		    else
+			Perl_sv_setpvf(aTHX_ tsv, "__ANON__=%s", s);
 		else
 		    sv_setpv(tsv, s);
 		Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
@@ -7773,7 +7776,10 @@ char *
 Perl_sv_reftype(pTHX_ SV *sv, int ob)
 {
     if (ob && SvOBJECT(sv)) {
-	return HvNAME(SvSTASH(sv));
+	if (HvNAME(SvSTASH(sv)))
+	    return HvNAME(SvSTASH(sv));
+	else
+	    return "__ANON__";
     }
     else {
 	switch (SvTYPE(sv)) {
@@ -7851,6 +7857,8 @@ Perl_sv_isa(pTHX_ SV *sv, const char *name)
     sv = (SV*)SvRV(sv);
     if (!SvOBJECT(sv))
 	return 0;
+    if (!HvNAME(SvSTASH(sv)))
+	return 0;
 
     return strEQ(HvNAME(SvSTASH(sv)), name);
 }
diff --git a/t/comp/package.t b/t/comp/package.t
index 4982256db7..6781be4b4f 100755
--- a/t/comp/package.t
+++ b/t/comp/package.t
@@ -1,12 +1,14 @@
 #!./perl
 
-print "1..8\n";
+print "1..12\n";
 
 $blurfl = 123;
 $foo = 3;
 
 package xyz;
 
+sub new {bless [];}
+
 $bar = 4;
 
 {
@@ -24,9 +26,9 @@ $xyz = join(':', sort(keys %xyz::));
 $ABC = join(':', sort(keys %ABC::));
 
 if ('a' lt 'A') {
-    print $xyz eq 'bar:main:xyz:ABC' ? "ok 1\n" : "not ok 1 '$xyz'\n";
+    print $xyz eq 'bar:main:new:xyz:ABC' ? "ok 1\n" : "not ok 1 '$xyz'\n";
 } else {
-    print $xyz eq 'ABC:bar:main:xyz' ? "ok 1\n" : "not ok 1 '$xyz'\n";
+    print $xyz eq 'ABC:bar:main:new:xyz' ? "ok 1\n" : "not ok 1 '$xyz'\n";
 }    
 print $ABC eq 'blurfl:dyick' ? "ok 2\n" : "not ok 2 '$ABC'\n";
 print $main'blurfl == 123 ? "ok 3\n" : "not ok 3\n";
@@ -51,3 +53,18 @@ sub foo {
 }
 
 print((foo(1))[0] eq 'PQR' ? "ok 8\n" : "not ok 8\n");
+
+my $Q = xyz->new();
+undef %xyz::;
+eval { $a = *xyz::new{PACKAGE}; };
+print $a eq "__ANON__" ? "ok 9\n" : "not ok 9\n";
+
+eval { $Q->param; };
+print $@ =~ /^Can't use anonymous symbol table for method lookup/ ?
+  "ok 10\n" : "not ok 10\n";
+
+print "$Q" =~ /^__ANON__=/ ? "ok 11\n" : "not ok 11\n";
+
+print ref $Q eq "__ANON__" ? "ok 12\n" : "not ok 12\n";
+
+