In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/89269094eac2074a779834560b45a2b374322023?hp=daef195c35291c889b77ed7da9fc76644092aa45>
- Log ----------------------------------------------------------------- commit 89269094eac2074a779834560b45a2b374322023 Author: Father Chrysostomos <[email protected]> Date: Wed Jul 4 12:51:31 2012 -0700 pp_hot.c: Clean up after the prev commit Even before that it was more complicated than necessary, as SvPV_nomg_const never returns null. M pp_hot.c commit 7156e69abfd37267e85105c6ec0c449ce4e41523 Author: Father Chrysostomos <[email protected]> Date: Thu Sep 20 08:56:38 2012 -0700 [perl #105922] Allow any string before ->meth The rules for filtering out what do not look like package names are not logical and disallow valid things like "::main", while allowing q"_#@*$!@*^(". This commit simply lets any non-empty string be used as a package name. If it is a typo, youâll get an error anyway. This allows autobox-style calls like "3foo"->CORE::uc, or even "3foo"->uc if you set up @ISA first. I made an exception for the empty string because it messes up caches somehow and causes subsequent method calls all to be called on the main package. I havenât looked into that yet. I donât know whether itâs worth it. The changes to the tests in cpan/Test-Simple have been submit- ted upstream. M cpan/Test-Simple/t/fail-more.t M pp_hot.c M t/op/method.t M t/run/fresh_perl.t ----------------------------------------------------------------------- Summary of changes: cpan/Test-Simple/t/fail-more.t | 12 ++++++------ pp_hot.c | 31 +++++++++++-------------------- t/op/method.t | 14 +++++++++++++- t/run/fresh_perl.t | 2 +- 4 files changed, 31 insertions(+), 28 deletions(-) diff --git a/cpan/Test-Simple/t/fail-more.t b/cpan/Test-Simple/t/fail-more.t index 0fc6a71..72b5a51 100644 --- a/cpan/Test-Simple/t/fail-more.t +++ b/cpan/Test-Simple/t/fail-more.t @@ -248,22 +248,22 @@ ERR #line 248 isa_ok(42, "Wibble", "My Wibble"); -out_ok( <<OUT, <<ERR ); +out_like( <<OUT, <<ERR ); not ok - My Wibble isa Wibble OUT # Failed test 'My Wibble isa Wibble' # at $0 line 248. -# My Wibble isn't a class or reference +# My Wibble isn't a .* ERR #line 248 isa_ok(42, "Wibble"); -out_ok( <<OUT, <<ERR ); -not ok - The thing isa Wibble +out_like( <<OUT, <<ERR ); +not ok - The (thing|class) isa Wibble OUT -# Failed test 'The thing isa Wibble' +# Failed test 'The (thing|class) isa Wibble' # at $0 line 248. -# The thing isn't a class or reference +# The (thing|class) isn't a .* ERR #line 258 diff --git a/pp_hot.c b/pp_hot.c index 45c5eb7..4100ae2 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -2956,51 +2956,42 @@ S_method_common(pTHX_ SV* meth, U32* hashp) PERL_ARGS_ASSERT_METHOD_COMMON; if (!sv) + undefined: Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value", SVfARG(meth)); SvGETMAGIC(sv); if (SvROK(sv)) ob = MUTABLE_SV(SvRV(sv)); + else if (!SvOK(sv)) goto undefined; else { + /* this isn't a reference */ GV* iogv; STRLEN packlen; - const char * packname = NULL; + const char * const packname = SvPV_nomg_const(sv, packlen); bool packname_is_utf8 = FALSE; - - /* this isn't a reference */ - if(SvOK(sv) && (packname = SvPV_nomg_const(sv, packlen))) { - const HE* const he = + const HE* const he = (const HE *)hv_common_key_len( PL_stashcache, packname, packlen * -(packname_is_utf8 = !!SvUTF8(sv)), 0, NULL, 0 ); - if (he) { + if (he) { stash = INT2PTR(HV*,SvIV(HeVAL(he))); goto fetch; - } } - if (!SvOK(sv) || - !(packname) || - !(iogv = gv_fetchpvn_flags( + if (!(iogv = gv_fetchpvn_flags( packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO )) || !(ob=MUTABLE_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) - : !isIDFIRST_L1((U8)*packname) - )) + if (!packlen) { - /* diag_listed_as: Can't call method "%s" without a package or object reference */ - Perl_croak(aTHX_ "Can't call method \"%"SVf"\" %s", - SVfARG(meth), - SvOK(sv) ? "without a package or object reference" - : "on an undefined value"); + Perl_croak(aTHX_ "Can't call method \"%"SVf"\" " + "without a package or object reference", + SVfARG(meth)); } /* assume it's a package name */ stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0); diff --git a/t/op/method.t b/t/op/method.t index 99a244c..799eda0 100644 --- a/t/op/method.t +++ b/t/op/method.t @@ -13,7 +13,7 @@ BEGIN { use strict; no warnings 'once'; -plan(tests => 111); +plan(tests => 116); @A::ISA = 'B'; @B::ISA = 'C'; @@ -477,3 +477,15 @@ package egakacp { @SUPER::ISA = "SUPPER"; sub SUPPER::foo { "supper" } is "SUPER"->foo, 'supper', 'SUPER->method'; + +sub flomp { "flimp" } +sub main::::flomp { "flump" } +is "::"->flomp, 'flump', 'method call on ::'; +is "::main"->flomp, 'flimp', 'method call on ::main'; +eval { ""->flomp }; +like $@, + qr/^Can't call method "flomp" without a package or object reference/, + 'method call on empty string'; +is "3foo"->CORE::uc, '3FOO', '"3foo"->CORE::uc'; +{ no strict; @{"3foo::ISA"} = "CORE"; } +is "3foo"->uc, '3FOO', '"3foo"->uc (autobox style!)'; diff --git a/t/run/fresh_perl.t b/t/run/fresh_perl.t index cd5899a..376ceaf 100644 --- a/t/run/fresh_perl.t +++ b/t/run/fresh_perl.t @@ -81,7 +81,7 @@ $array[128]=1 ######## $x=0x0eabcd; print $x->ref; EXPECT -Can't call method "ref" without a package or object reference at - line 1. +Can't locate object method "ref" via package "961485" (perhaps you forgot to load "961485"?) at - line 1. ######## chop ($str .= <DATA>); ######## -- Perl5 Master Repository
