[perl #127494] don't cache AUTOLOAD as DESTROY

[perl5.git] / t / op / method.t

diff --git a/t/op/method.t b/t/op/method.t
index 821f604..b915306 100644 (file)
--- a/t/op/method.t
+++ b/t/op/method.t
@@ -6,14 +6,14 @@
 
 BEGIN {
     chdir 't' if -d 't';
-    @INC = qw(. ../lib lib);
-    require "test.pl";
+    @INC = qw(. ../lib lib ../dist/base/lib);
+    require "./test.pl";
 }
 
 use strict;
 no warnings 'once';
 
-plan(tests => 142);
+plan(tests => 150);
 
 @A::ISA = 'B';
 @B::ISA = 'C';
@@ -170,15 +170,6 @@ no warnings 'redefine';
 is(A->eee(), "new B: In A::eee, 4");   # We get a correct $autoload
 is(A->eee(), "new B: In A::eee, 4");   # Which sticks
 
-{
-    no strict 'refs';
-    no warnings 'deprecated';
-    # this test added due to bug discovery (in 5.004_04, fb73857aa0bfa8ed)
-    # Possibly kill this test now that defined @::array is finally properly
-    # deprecated?
-    is(defined(@{"unknown_package::ISA"}) ? "defined" : "undefined", "undefined");
-}
-
 # test that failed subroutine calls don't affect method calls
 {
     package A1;
@@ -268,6 +259,27 @@ sub OtherSouper::method { "Isidore Ropen, Draft Manager" }
         'SUPER inside moved package respects method changes';
 }
 
+package foo120694 {
+    BEGIN { our @ISA = qw(bar120694) }
+
+    sub AUTOLOAD {
+        my $self = shift;
+        local our $recursive = $recursive;
+        return "recursive" if $recursive++;
+        return if our $AUTOLOAD eq 'DESTROY';
+        $AUTOLOAD = "SUPER:" . substr $AUTOLOAD, rindex($AUTOLOAD, ':');
+        return $self->$AUTOLOAD(@_);
+    }
+}
+package bar120694 {
+    sub AUTOLOAD {
+        return "xyzzy";
+    }
+}
+is bless( [] => "foo120694" )->plugh, 'xyzzy',
+    '->SUPER::method autoloading uses parent of current pkg';
+
+
 # failed method call or UNIVERSAL::can() should not autovivify packages
 is( $::{"Foo::"} || "none", "none");  # sanity check 1
 is( $::{"Foo::"} || "none", "none");  # sanity check 2
@@ -349,6 +361,7 @@ for my $meth (['Bar', 'Foo::Bar'],
 {
     fresh_perl_is(<<EOT,
 package UNIVERSAL; sub AUTOLOAD { my \$c = shift; print "\$c \$AUTOLOAD\\n" }
+sub DESTROY {} # prevent AUTOLOAD being called on DESTROY
 package Xyz;
 package main; Foo->$meth->[0]();
 EOT
@@ -392,7 +405,7 @@ is $kalled, 1, 'calling a class method via a magic variable';
 
     *NulTest::AUTOLOAD = sub { our $AUTOLOAD; return $AUTOLOAD };
 
-    like(NulTest->${ \"nul\0test" }, "nul\0test", "AUTOLOAD is nul-clean");
+    like(NulTest->${ \"nul\0test" }, qr/nul\0test/, "AUTOLOAD is nul-clean");
 }
 
 
@@ -448,6 +461,35 @@ is $kalled, 1, 'calling a class method via a magic variable';
    { bless {}, "NoSub"; }
 }
 
+{
+    # [perl #124387]
+    my $autoloaded;
+    package AutoloadDestroy;
+    sub AUTOLOAD { $autoloaded = 1 }
+    package main;
+    bless {}, "AutoloadDestroy";
+    ok($autoloaded, "AUTOLOAD called for DESTROY");
+
+    # 127494 - AUTOLOAD for DESTROY was called without setting $AUTOLOAD
+    my %methods;
+    package AutoloadDestroy2;
+    sub AUTOLOAD {
+        our $AUTOLOAD;
+        (my $method = $AUTOLOAD) =~ s/.*:://;
+        ++$methods{$method};
+    }
+    package main;
+    # this cached AUTOLOAD as the DESTROY method
+    bless {}, "AutoloadDestroy2";
+    %methods = ();
+    my $o = bless {}, "AutoloadDestroy2";
+    # this sets $AUTOLOAD to "AutoloadDestroy2::foo"
+    $o->foo;
+    # this would call AUTOLOAD without setting $AUTOLOAD
+    undef $o;
+    ok($methods{DESTROY}, "\$AUTOLOAD set correctly for DESTROY");
+}
+
 eval { () = 3; new {} };
 like $@,
      qr/^Can't call method "new" without a package or object reference/,
@@ -490,6 +532,24 @@ is "3foo"->CORE::uc, '3FOO', '"3foo"->CORE::uc';
 { no strict; @{"3foo::ISA"} = "CORE"; }
 is "3foo"->uc, '3FOO', '"3foo"->uc (autobox style!)';
 
+# *foo vs (\*foo)
+sub myclass::squeak { 'eek' }
+eval { *myclass->squeak };
+like $@,
+     qr/^Can't call method "squeak" without a package or object reference/,
+    'method call on typeglob ignores package';
+eval { (\*myclass)->squeak };
+like $@,
+     qr/^Can't call method "squeak" on unblessed reference/,
+    'method call on \*typeglob';
+*stdout2 = *STDOUT;  # stdout2 now stringifies as *main::STDOUT
+sub IO::Handle::self { $_[0] }
+# This used to stringify the glob:
+is *stdout2->self, (\*stdout2)->self,
+  '*glob->method is equiv to (\*glob)->method';
+sub { $_[0] = *STDOUT; is $_[0]->self, \$::h{k}, '$pvlv_glob->method' }
+ ->($::h{k});
+
 # Test that PL_stashcache doesn't change the resolution behaviour for file
 # handles and package names.
 SKIP: {
@@ -604,7 +664,7 @@ SKIP: {
     seek DATA, $data_start, Fcntl::SEEK_SET() or die $!;
 
     is(Colour::H1->getline(), <DATA>, 'read from a file');
-    is(C3::H1->getline(), 'method in C3::H1', 'intial resolution is a method');
+    is(C3::H1->getline(), 'method in C3::H1', 'initial resolution is a method');
 
     *Copy:: = \*C3::;
     *C3:: = \*Colour::;
@@ -619,6 +679,31 @@ SKIP: {
        'restoring the stash returns to a method');
 }
 
+# RT #123619 constant class name should be read-only
+
+{
+    sub RT123619::f { chop $_[0] }
+    eval { 'RT123619'->f(); };
+    like ($@, qr/Modification of a read-only value attempted/, 'RT #123619');
+}
+
+{
+    # RT #126042 &{1==1} * &{1==1} would crash
+
+    # pp_entersub and pp_method_named cooperate to prevent calls to an
+    # undefined import() or unimport() method from croaking.
+    # If pp_method_named can't find the method it pushes &PL_sv_yes, and
+    # pp_entersub checks for that specific SV to avoid croaking.
+    # Ideally they wouldn't use that hack but...
+    # Unfortunately pp_entersub's handling of that case is broken in scalar context.
+
+    # Rather than using the test case from the ticket, since &{1==1}
+    # isn't documented (and may not be supported in future perls) test
+    # calls to undefined import method, which also crashes.
+    fresh_perl_is('Unknown->import() * Unknown->unimport(); print "ok\n"', "ok\n", {},
+                  "check unknown import() methods don't corrupt the stack");
+}
+
 __END__
 #FF9900
 #F78C08