Commit | Line | Data |
---|---|---|
e1a479c5 BB |
1 | #!./perl |
2 | ||
3 | use strict; | |
978a498e | 4 | no strict 'refs'; # we do a lot of this |
e1a479c5 BB |
5 | use warnings; |
6 | no warnings 'redefine'; # we do a lot of this | |
7 | no warnings 'prototype'; # we do a lot of this | |
8 | ||
9 | BEGIN { | |
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 | |
28 | my @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: { | |
75 | skip_if_miniperl("no XS"); require XS::APItest; | |
76 | *A = *{'MCTest::Base::foo'}; | |
77 | XS::APItest::newCONSTSUB(\%main::, "A", 0, 20); | |
78 | is (MCTest::Derived->foo(0), 20, | |
79 | 'redefining sub through glob alias via newXS'); | |
80 | } }, | |
81 | sub { undef *{'MCTest::Base::foo'}; *A = *{'MCTest::Base::foo'}; | |
82 | eval { no warnings 'once'; local *UNIVERSAL::foo = sub {96}; | |
83 | MCTest::Derived->foo }; | |
84 | ()=\&A; | |
85 | eval { MCTest::Derived->foo }; | |
86 | like($@, qr/Undefined subroutine/, | |
87 | 'redefining sub through glob alias via stub vivification'); }, | |
88 | sub { *A = *{'MCTest::Base::foo'}; | |
89 | local *A = sub { 21 }; | |
90 | is(MCTest::Derived->foo, 21, | |
91 | 'redef sub through glob alias via local cv-to-glob assign'); }, | |
92 | sub { *A = *{'MCTest::Base::foo'}; | |
93 | eval 'sub MCTest::Base::foo { 22 }'; | |
94 | { local *A = sub { 23 }; MCTest::Derived->foo } | |
95 | is(MCTest::Derived->foo, 22, | |
96 | 'redef sub through glob alias via localisation unwinding'); }, | |
97 | sub { *A = *{'MCTest::Base::foo'}; *A = sub { 24 }; | |
98 | is(MCTest::Derived->foo(0), 24, | |
99 | 'redefining sub through glob alias via cv-to-glob assign'); }, | |
e1a479c5 BB |
100 | ); |
101 | ||
dd69841b | 102 | plan(tests => scalar(@testsubs)); |
e1a479c5 | 103 | |
e1a479c5 | 104 | $_->() for (@testsubs); |