[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.

diff --git a/cpan/Test-Simple/t/fail-more.t b/cpan/Test-Simple/t/fail-more.t
index 0fc6a71..72b5a51 100644 (file)
--- 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..7b71474 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2956,12 +2956,14 @@ 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 {
        GV* iogv;
         STRLEN packlen;
@@ -2990,17 +2992,11 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
            !(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 (!packname || !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 (file)
--- 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 (file)
--- 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>);
 ########