t/mro/method_caching.t

   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 }
  15
  16 require './test.pl';
  17
  18 {
  19     package MCTest::Base;
  20     sub foo { return $_[1]+1 };
  21
  22     package MCTest::Derived;
  23     our @ISA = qw/MCTest::Base/;
  24
  25     package Foo; our @FOO = qw//;
  26 }
  27
  28 # These are various ways of re-defining MCTest::Base::foo and checking whether the method is cached when it shouldn't be
  29 my @testsubs = (
  30     sub { is(MCTest::Derived->foo(0), 1); },
  31     sub { eval 'sub MCTest::Base::foo { return $_[1]+2 }'; is(MCTest::Derived->foo(0), 2); },
  32     sub { eval 'sub MCTest::Base::foo($) { return $_[1]+3 }'; is(MCTest::Derived->foo(0), 3); },
  33     sub { eval 'sub MCTest::Base::foo($) { 4 }'; is(MCTest::Derived->foo(0), 4); },
  34     sub { *MCTest::Base::foo = sub { $_[1]+5 }; is(MCTest::Derived->foo(0), 5); },
  35     sub { local *MCTest::Base::foo = sub { $_[1]+6 }; is(MCTest::Derived->foo(0), 6); },
  36     sub { is(MCTest::Derived->foo(0), 5); },
  37     sub { sub FFF { $_[1]+7 }; local *MCTest::Base::foo = *FFF; is(MCTest::Derived->foo(0), 7); },
  38     sub { is(MCTest::Derived->foo(0), 5); },
  39     sub { sub DDD { $_[1]+8 }; *MCTest::Base::foo = *DDD; is(MCTest::Derived->foo(0), 8); },
  40     sub { *ASDF::asdf = sub { $_[1]+9 }; *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 9); },
  41     sub { undef *MCTest::Base::foo; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); },
  42     sub { eval "sub MCTest::Base::foo($);"; *MCTest::Base::foo = \&ASDF::asdf; is(MCTest::Derived->foo(0), 9); },
  43     sub { *XYZ = sub { $_[1]+10 }; ${MCTest::Base::}{foo} = \&XYZ; is(MCTest::Derived->foo(0), 10); },
  44     sub { ${MCTest::Base::}{foo} = sub { $_[1]+11 }; is(MCTest::Derived->foo(0), 11); },
  45
  46     sub { undef *MCTest::Base::foo; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); },
  47     sub { eval 'package MCTest::Base; sub foo { $_[1]+12 }'; is(MCTest::Derived->foo(0), 12); },
  48     sub { eval 'package ZZZ; sub foo { $_[1]+13 }'; *MCTest::Base::foo = \&ZZZ::foo; is(MCTest::Derived->foo(0), 13); },
  49     sub { ${MCTest::Base::}{foo} = sub { $_[1]+14 }; is(MCTest::Derived->foo(0), 14); },
  50     # 5.8.8 fails this one
  51     sub { undef *{MCTest::Base::}; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); },
  52     sub { eval 'package MCTest::Base; sub foo { $_[1]+15 }'; is(MCTest::Derived->foo(0), 15); },
  53     sub { undef %{MCTest::Base::}; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); },
  54     sub { eval 'package MCTest::Base; sub foo { $_[1]+16 }'; is(MCTest::Derived->foo(0), 16); },
  55     sub { %{MCTest::Base::} = (); eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); },
  56     sub { eval 'package MCTest::Base; sub foo { $_[1]+17 }'; is(MCTest::Derived->foo(0), 17); },
  57     # 5.8.8 fails this one too
  58     sub { *{MCTest::Base::} = *{Foo::}; eval { MCTest::Derived->foo(0) }; like($@, qr/locate object method/); },
  59     sub { *MCTest::Derived::foo = \&MCTest::Base::foo; eval { MCTest::Derived::foo(0,0) }; ok(!$@); undef *MCTest::Derived::foo },
  60     sub { eval 'package MCTest::Base; sub foo { $_[1]+18 }'; is(MCTest::Derived->foo(0), 18); },
  61
  62     # Redefining through a glob alias
  63     sub { *A = *{'MCTest::Base::foo'}; eval 'sub A { $_[1]+19 }';
  64           is(MCTest::Derived->foo(0), 19,
  65             'redefining sub through glob alias via decl'); },
  66     sub { SKIP: {
  67               skip_if_miniperl("no XS"); require XS::APItest;
  68               *A = *{'MCTest::Base::foo'};
  69               XS::APItest::newCONSTSUB(\%main::, "A", 0, 20);
  70               is (MCTest::Derived->foo(0), 20,
  71                   'redefining sub through glob alias via newXS');
  72         } },
  73     sub { undef *{'MCTest::Base::foo'}; *A = *{'MCTest::Base::foo'};
  74           eval { no warnings 'once'; local *UNIVERSAL::foo = sub {96};
  75                  MCTest::Derived->foo };
  76           ()=\&A;
  77           eval { MCTest::Derived->foo };
  78           like($@, qr/Undefined subroutine/,
  79             'redefining sub through glob alias via stub vivification'); },
  80     sub { *A = *{'MCTest::Base::foo'};
  81           local *A = sub { 21 };
  82           is(MCTest::Derived->foo, 21,
  83             'redef sub through glob alias via local cv-to-glob assign'); },
  84     sub { *A = *{'MCTest::Base::foo'};
  85           eval 'sub MCTest::Base::foo { 22 }';
  86           { local *A = sub { 23 }; MCTest::Derived->foo }
  87           is(MCTest::Derived->foo, 22,
  88             'redef sub through glob alias via localisation unwinding'); },
  89     sub { *A = *{'MCTest::Base::foo'}; *A = sub { 24 };
  90           is(MCTest::Derived->foo(0), 24,
  91             'redefining sub through glob alias via cv-to-glob assign'); },
  92 );
  93
  94 plan(tests => scalar(@testsubs));
  95
  96 $_->() for (@testsubs);