| 1 | #!./perl |
| 2 | |
| 3 | use strict; |
| 4 | no strict 'refs'; # we do a lot of this |
| 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 | } |
| 14 | require './test.pl'; |
| 15 | } |
| 16 | |
| 17 | { |
| 18 | package MCTest::Base; |
| 19 | sub foo { return $_[1]+1 }; |
| 20 | |
| 21 | package MCTest::Derived; |
| 22 | our @ISA = qw/MCTest::Base/; |
| 23 | |
| 24 | package Foo; our @FOO = qw//; |
| 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 = ( |
| 29 | sub { is(MCTest::Derived->foo(0), 1); }, |
| 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); }, |
| 36 | sub { sub FFF { $_[1]+7 }; local *MCTest::Base::foo = *FFF; is(MCTest::Derived->foo(0), 7); }, |
| 37 | sub { is(MCTest::Derived->foo(0), 5); }, |
| 38 | sub { { local *MCTest::Base::can = sub { "tomatoes" }; |
| 39 | MCTest::Derived->can(0); } |
| 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'); }, |
| 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 | |
| 54 | sub { undef *MCTest::Base::foo; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); }, |
| 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/); }, |
| 67 | sub { *MCTest::Derived::foo = \&MCTest::Base::foo; eval { MCTest::Derived::foo(0,0) }; ok(!$@); undef *MCTest::Derived::foo }, |
| 68 | sub { eval 'package MCTest::Base; sub foo { $_[1]+18 }'; is(MCTest::Derived->foo(0), 18); }, |
| 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"); |
| 76 | eval { require XS::APItest; } |
| 77 | or skip "XS::APItest not available", 1; |
| 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'); }, |
| 102 | ); |
| 103 | |
| 104 | plan(tests => scalar(@testsubs)); |
| 105 | |
| 106 | $_->() for (@testsubs); |