diff options
| -rw-r--r-- | dump.c | 2 | ||||
| -rw-r--r-- | gv.c | 16 | ||||
| -rw-r--r-- | hv.c | 2 | ||||
| -rw-r--r-- | pod/perldiag.pod | 2 | ||||
| -rw-r--r-- | pp.c | 5 | ||||
| -rw-r--r-- | pp_hot.c | 6 | ||||
| -rw-r--r-- | sv.c | 12 | ||||
| -rwxr-xr-x | t/comp/package.t | 23 |
8 files changed, 56 insertions, 12 deletions
@@ -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)); } @@ -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) { @@ -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::>. @@ -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")) @@ -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 */ @@ -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"; + + |