From: Ilmari Karonen Date: Thu, 24 May 2001 01:51:48 +0000 (+0300) Subject: stash autovivification and method call error messages X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=af09ea45cb052770572c0a2caa4e487853f703c8;p=p5sagit%2Fp5-mst-13.2.git stash autovivification and method call error messages Message-ID: p4raw-id: //depot/perl@10205 --- diff --git a/gv.c b/gv.c index 2f31585..0041693 100644 --- a/gv.c +++ b/gv.c @@ -188,8 +188,13 @@ Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level) GV** gvp; CV* cv; - if (!stash) - return 0; + /* UNIVERSAL methods should be callable without a stash */ + if (!stash) { + level = -1; /* probably appropriate */ + if(!(stash = gv_stashpvn("UNIVERSAL", 9, FALSE))) + return 0; + } + if (!HvNAME(stash)) Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); if ((level > 100) || (level < -100)) @@ -365,12 +370,14 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) /* ->SUPER::method should really be looked up in original stash */ SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER", CopSTASHPV(PL_curcop))); + /* __PACKAGE__::SUPER stash should be autovivified */ stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE); DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", origname, HvNAME(stash), name) ); } else - stash = gv_stashpvn(origname, nsplit - origname, TRUE); + /* don't autovifify if ->NoSuchStash::method */ + stash = gv_stashpvn(origname, nsplit - origname, FALSE); } gv = gv_fetchmeth(stash, name, nend - name, 0); @@ -414,6 +421,8 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method) GV* vargv; SV* varsv; + if (!stash) + return Nullgv; /* UNIVERSAL::AUTOLOAD could cause trouble */ if (len == autolen && strnEQ(name, autoload, autolen)) return Nullgv; if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE))) diff --git a/pp_hot.c b/pp_hot.c index 1c0c417..ddb3ed7 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -2996,18 +2996,20 @@ S_method_common(pTHX_ SV* meth, U32* hashp) Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name); if (SvGMAGICAL(sv)) - mg_get(sv); + mg_get(sv); if (SvROK(sv)) ob = (SV*)SvRV(sv); else { GV* iogv; + /* this isn't a reference */ packname = Nullch; if (!SvOK(sv) || !(packname = SvPV(sv, packlen)) || !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) || !(ob=(SV*)GvIO(iogv))) { + /* this isn't the name of a filehandle either */ if (!packname || ((UTF8_IS_START(*packname) && DO_UTF8(sv)) ? !isIDFIRST_utf8((U8*)packname) @@ -3018,12 +3020,15 @@ S_method_common(pTHX_ SV* meth, U32* hashp) SvOK(sv) ? "without a package or object reference" : "on an undefined value"); } - stash = gv_stashpvn(packname, packlen, TRUE); + /* assume it's a package name */ + stash = gv_stashpvn(packname, packlen, FALSE); goto fetch; } + /* it _is_ a filehandle name -- replace with a reference */ *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv)); } + /* if we got here, ob should be a reference or a glob */ if (!ob || !(SvOBJECT(ob) || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob)) && SvOBJECT(ob)))) @@ -3035,6 +3040,9 @@ S_method_common(pTHX_ SV* meth, U32* hashp) stash = SvSTASH(ob); fetch: + /* NOTE: stash may be null, hope hv_fetch_ent and + gv_fetchmethod can cope (it seems they can) */ + /* shortcut for simple names */ if (hashp) { HE* he = hv_fetch_ent(stash, meth, 0, *hashp); @@ -3047,11 +3055,18 @@ S_method_common(pTHX_ SV* meth, U32* hashp) } gv = gv_fetchmethod(stash, name); + if (!gv) { + /* This code tries to figure out just what went wrong with + gv_fetchmethod. It therefore needs to duplicate a lot of + the internals of that function. We can't move it inside + Perl_gv_fetchmethod_autoload(), however, since that would + cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we + don't want that. + */ char* leaf = name; char* sep = Nullch; char* p; - GV* gv; for (p = name; *p; p++) { if (*p == '\'') @@ -3060,24 +3075,28 @@ S_method_common(pTHX_ SV* meth, U32* hashp) sep = p, leaf = p + 2; } if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) { - packname = sep ? CopSTASHPV(PL_curcop) : HvNAME(stash); + /* the method name is unqualified or starts with SUPER:: */ + packname = sep ? CopSTASHPV(PL_curcop) : + stash ? HvNAME(stash) : packname; packlen = strlen(packname); } else { + /* the method name is qualified */ packname = name; packlen = sep - name; } - gv = gv_fetchpv(packname, 0, SVt_PVHV); - if (gv && isGV(gv)) { + + /* we're relying on gv_fetchmethod not autovivifying the stash */ + if (gv_stashpvn(packname, packlen, FALSE)) { Perl_croak(aTHX_ - "Can't locate object method \"%s\" via package \"%s\"", - leaf, packname); + "Can't locate object method \"%s\" via package \"%.*s\"", + leaf, (int)packlen, packname); } else { Perl_croak(aTHX_ - "Can't locate object method \"%s\" via package \"%s\"" - " (perhaps you forgot to load \"%s\"?)", - leaf, packname, packname); + "Can't locate object method \"%s\" via package \"%.*s\"" + " (perhaps you forgot to load \"%.*s\"?)", + leaf, (int)packlen, packname, (int)packlen, packname); } } return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv; diff --git a/t/op/method.t b/t/op/method.t index ceb39be..4e4ac97 100755 --- a/t/op/method.t +++ b/t/op/method.t @@ -9,7 +9,7 @@ BEGIN { @INC = '../lib'; } -print "1..56\n"; +print "1..72\n"; @A::ISA = 'B'; @B::ISA = 'C'; @@ -176,20 +176,68 @@ test(defined(@{"unknown_package::ISA"}) ? "defined" : "undefined", "undefined"); test(A2->foo(), "foo"); } -{ - test(do { use Config; eval 'Config->foo()'; - $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1); - test(do { use Config; eval '$d = bless {}, "Config"; $d->foo()'; - $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1); -} +## This test was totally misguided. It passed before only because the +## code to determine if a package was loaded used to look for the hash +## %Foo::Bar instead of the package Foo::Bar:: -- and Config.pm just +## happens to export %Config. +# { +# test(do { use Config; eval 'Config->foo()'; +# $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1); +# test(do { use Config; eval '$d = bless {}, "Config"; $d->foo()'; +# $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1); +# } + + +# test error messages if method loading fails +test(do { eval '$e = bless {}, "E::A"; E::A->foo()'; + $@ =~ /^\QCan't locate object method "foo" via package "E::A" at/ ? 1 : $@}, 1); +test(do { eval '$e = bless {}, "E::B"; $e->foo()'; + $@ =~ /^\QCan't locate object method "foo" via package "E::B" at/ ? 1 : $@}, 1); +test(do { eval 'E::C->foo()'; + $@ =~ /^\QCan't locate object method "foo" via package "E::C" (perhaps / ? 1 : $@}, 1); + +test(do { eval 'UNIVERSAL->E::D::foo()'; + $@ =~ /^\QCan't locate object method "foo" via package "E::D" (perhaps / ? 1 : $@}, 1); +test(do { eval '$e = bless {}, "UNIVERSAL"; $e->E::E::foo()'; + $@ =~ /^\QCan't locate object method "foo" via package "E::E" (perhaps / ? 1 : $@}, 1); + +$e = bless {}, "E::F"; # force package to exist +test(do { eval 'UNIVERSAL->E::F::foo()'; + $@ =~ /^\QCan't locate object method "foo" via package "E::F" at/ ? 1 : $@}, 1); +test(do { eval '$e = bless {}, "UNIVERSAL"; $e->E::F::foo()'; + $@ =~ /^\QCan't locate object method "foo" via package "E::F" at/ ? 1 : $@}, 1); + +# TODO: we need some tests for the SUPER:: pseudoclass + +# failed method call or UNIVERSAL::can() should not autovivify packages +test( $::{"Foo::"} || "none", "none"); # sanity check 1 +test( $::{"Foo::"} || "none", "none"); # sanity check 2 -test(do { eval 'E->foo()'; - $@ =~ /^\QCan't locate object method "foo" via package "E" (perhaps / ? 1 : $@}, 1); -test(do { eval '$e = bless {}, "E"; $e->foo()'; - $@ =~ /^\QCan't locate object method "foo" via package "E" (perhaps / ? 1 : $@}, 1); +test( UNIVERSAL::can("Foo", "boogie") ? "yes":"no", "no" ); +test( $::{"Foo::"} || "none", "none"); # still missing? + +test( Foo->UNIVERSAL::can("boogie") ? "yes":"no", "no" ); +test( $::{"Foo::"} || "none", "none"); # still missing? + +test( Foo->can("boogie") ? "yes":"no", "no" ); +test( $::{"Foo::"} || "none", "none"); # still missing? + +test( eval 'Foo->boogie(); 1' ? "yes":"no", "no" ); +test( $::{"Foo::"} || "none", "none"); # still missing? + +test(do { eval 'Foo->boogie()'; + $@ =~ /^\QCan't locate object method "boogie" via package "Foo" (perhaps / ? 1 : $@}, 1); + +eval 'sub Foo::boogie { "yes, sir!" }'; +test( $::{"Foo::"} ? "ok" : "none", "ok"); # should exist now +test( Foo->boogie(), "yes, sir!"); + +# TODO: universal.t should test NoSuchPackage->isa()/can() # This is actually testing parsing of indirect objects and undefined subs # print foo("bar") where foo does not exist is not an indirect object. # print foo "bar" where foo does not exist is an indirect object. eval { sub AUTOLOAD { "ok ", shift, "\n"; } }; print nonsuch(++$cnt); + +print "# $cnt tests completed\n";