summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gv.c15
-rw-r--r--pp_hot.c41
-rwxr-xr-xt/op/method.t70
3 files changed, 101 insertions, 25 deletions
diff --git a/gv.c b/gv.c
index 2f31585c51..00416937fd 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 1c0c417161..ddb3ed7f03 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 ceb39be7da..4e4ac97c19 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";
View Lorry Controller Status