This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
skip appropriately when XS::APItest isn't available
[perl5.git] / t / mro / method_caching.t
CommitLineData
e1a479c5
BB
1#!./perl
2
3use strict;
978a498e 4no strict 'refs'; # we do a lot of this
e1a479c5
BB
5use warnings;
6no warnings 'redefine'; # we do a lot of this
7no warnings 'prototype'; # we do a lot of this
8
9BEGIN {
10 unless (-d 'blib') {
11 chdir 't' if -d 't';
12 @INC = '../lib';
13 }
af5aa9e3 14 require './test.pl';
e1a479c5
BB
15}
16
e1a479c5
BB
17{
18 package MCTest::Base;
19 sub foo { return $_[1]+1 };
e1a479c5
BB
20
21 package MCTest::Derived;
22 our @ISA = qw/MCTest::Base/;
dd69841b
BB
23
24 package Foo; our @FOO = qw//;
e1a479c5
BB
25}
26
27# These are various ways of re-defining MCTest::Base::foo and checking whether the method is cached when it shouldn't be
28my @testsubs = (
dd69841b 29 sub { is(MCTest::Derived->foo(0), 1); },
e1a479c5
BB
30 sub { eval 'sub MCTest::Base::foo { return $_[1]+2 }'; is(MCTest::Derived->foo(0), 2); },
31 sub { eval 'sub MCTest::Base::foo($) { return $_[1]+3 }'; is(MCTest::Derived->foo(0), 3); },
32 sub { eval 'sub MCTest::Base::foo($) { 4 }'; is(MCTest::Derived->foo(0), 4); },
33 sub { *MCTest::Base::foo = sub { $_[1]+5 }; is(MCTest::Derived->foo(0), 5); },
34 sub { local *MCTest::Base::foo = sub { $_[1]+6 }; is(MCTest::Derived->foo(0), 6); },
35 sub { is(MCTest::Derived->foo(0), 5); },
dd69841b 36 sub { sub FFF { $_[1]+7 }; local *MCTest::Base::foo = *FFF; is(MCTest::Derived->foo(0), 7); },
e1a479c5 37 sub { is(MCTest::Derived->foo(0), 5); },
4e52a9b6
FC
38 sub { { local *MCTest::Base::can = sub { "tomatoes" };
39 MCTest::Derived->can(0); }
4e52a9b6
FC
40 is(MCTest::Derived->can("isa"), \&UNIVERSAL::isa,
41 'removing method when unwinding local *method=sub{}'); },
42 sub { sub peas { "peas" }
43 { local *MCTest::Base::can = *peas;
44 MCTest::Derived->can(0); }
45 is(MCTest::Derived->can("isa"), \&UNIVERSAL::isa,
46 'removing method when unwinding local *method=*other'); },
dd69841b
BB
47 sub { sub DDD { $_[1]+8 }; *MCTest::Base::foo = *DDD; is(MCTest::Derived->foo(0), 8); },
48 sub { *ASDF::asdf = sub { $_[1]+9 }; *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 9); },
49 sub { undef *MCTest::Base::foo; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); },
50 sub { eval "sub MCTest::Base::foo($);"; *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 9); },
51 sub { *XYZ = sub { $_[1]+10 }; ${MCTest::Base::}{foo} = \&XYZ; is(MCTest::Derived->foo(0), 10); },
52 sub { ${MCTest::Base::}{foo} = sub { $_[1]+11 }; is(MCTest::Derived->foo(0), 11); },
53
e1a479c5 54 sub { undef *MCTest::Base::foo; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); },
dd69841b
BB
55 sub { eval 'package MCTest::Base; sub foo { $_[1]+12 }'; is(MCTest::Derived->foo(0), 12); },
56 sub { eval 'package ZZZ; sub foo { $_[1]+13 }'; *MCTest::Base::foo = \&ZZZ::foo; is(MCTest::Derived->foo(0), 13); },
57 sub { ${MCTest::Base::}{foo} = sub { $_[1]+14 }; is(MCTest::Derived->foo(0), 14); },
58 # 5.8.8 fails this one
59 sub { undef *{MCTest::Base::}; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); },
60 sub { eval 'package MCTest::Base; sub foo { $_[1]+15 }'; is(MCTest::Derived->foo(0), 15); },
61 sub { undef %{MCTest::Base::}; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); },
62 sub { eval 'package MCTest::Base; sub foo { $_[1]+16 }'; is(MCTest::Derived->foo(0), 16); },
63 sub { %{MCTest::Base::} = (); eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); },
64 sub { eval 'package MCTest::Base; sub foo { $_[1]+17 }'; is(MCTest::Derived->foo(0), 17); },
65 # 5.8.8 fails this one too
66 sub { *{MCTest::Base::} = *{Foo::}; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); },
5f2fca8a 67 sub { *MCTest::Derived::foo = \&MCTest::Base::foo; eval { MCTest::Derived::foo(0,0) }; ok(!$@); undef *MCTest::Derived::foo },
dd69841b 68 sub { eval 'package MCTest::Base; sub foo { $_[1]+18 }'; is(MCTest::Derived->foo(0), 18); },
978a498e
FC
69
70 # Redefining through a glob alias
71 sub { *A = *{'MCTest::Base::foo'}; eval 'sub A { $_[1]+19 }';
72 is(MCTest::Derived->foo(0), 19,
73 'redefining sub through glob alias via decl'); },
74 sub { SKIP: {
2ae3365f
TC
75 skip_if_miniperl("no XS");
76 eval { require XS::APItest; }
77 or skip "XS::APItest not available", 1;
978a498e
FC
78 *A = *{'MCTest::Base::foo'};
79 XS::APItest::newCONSTSUB(\%main::, "A", 0, 20);
80 is (MCTest::Derived->foo(0), 20,
81 'redefining sub through glob alias via newXS');
82 } },
83 sub { undef *{'MCTest::Base::foo'}; *A = *{'MCTest::Base::foo'};
84 eval { no warnings 'once'; local *UNIVERSAL::foo = sub {96};
85 MCTest::Derived->foo };
86 ()=\&A;
87 eval { MCTest::Derived->foo };
88 like($@, qr/Undefined subroutine/,
89 'redefining sub through glob alias via stub vivification'); },
90 sub { *A = *{'MCTest::Base::foo'};
91 local *A = sub { 21 };
92 is(MCTest::Derived->foo, 21,
93 'redef sub through glob alias via local cv-to-glob assign'); },
94 sub { *A = *{'MCTest::Base::foo'};
95 eval 'sub MCTest::Base::foo { 22 }';
96 { local *A = sub { 23 }; MCTest::Derived->foo }
97 is(MCTest::Derived->foo, 22,
98 'redef sub through glob alias via localisation unwinding'); },
99 sub { *A = *{'MCTest::Base::foo'}; *A = sub { 24 };
100 is(MCTest::Derived->foo(0), 24,
101 'redefining sub through glob alias via cv-to-glob assign'); },
e1a479c5
BB
102);
103
dd69841b 104plan(tests => scalar(@testsubs));
e1a479c5 105
e1a479c5 106$_->() for (@testsubs);