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

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

p4raw-id: //depot/perl@19505

diff --git a/dump.c b/dump.c
index 119bfa3..61cd8e0 100644 (file)
--- 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 489ed0b..95d4d36 100644 (file)
--- 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 f5508bf..6544e08 100644 (file)
--- 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 8a744b9..bc16459 100644 (file)
--- 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 7acc1da..bcf1633 100644 (file)
--- 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 926a1f8..fc2b9c5 100644 (file)
--- 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 423bb04..d82e354 100644 (file)
--- 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 4982256..6781be4 100755 (executable)
--- 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";
+
+