1#!./perl 2 3use strict; 4no strict 'refs'; # we do a lot of this 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 } 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 28my @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 104plan(tests => scalar(@testsubs)); 105 106$_->() for (@testsubs); 107