contrib/perl5/t/op/method.t

   1 #!./perl
   2
   3 #
   4 # test method calls and autoloading.
   5 #
   6
   7 print "1..26\n";
   8
   9 @A::ISA = 'B';
  10 @B::ISA = 'C';
  11
  12 sub C::d {"C::d"}
  13 sub D::d {"D::d"}
  14
  15 my $cnt = 0;
  16 sub test {
  17   print "# got `$_[0]', expected `$_[1]'\nnot " unless $_[0] eq $_[1];
  18   # print "not " unless shift eq shift;
  19   print "ok ", ++$cnt, "\n"
  20 }
  21
  22 test( A->d, "C::d");            # Update hash table;
  23
  24 *B::d = \&D::d;                 # Import now.
  25 test (A->d, "D::d");            # Update hash table;
  26
  27 {
  28     local @A::ISA = qw(C);      # Update hash table with split() assignment
  29     test (A->d, "C::d");
  30     $#A::ISA = -1;
  31     test (eval { A->d } || "fail", "fail");
  32 }
  33 test (A->d, "D::d");
  34
  35 {
  36     local *B::d;
  37     eval 'sub B::d {"B::d1"}';  # Import now.
  38     test (A->d, "B::d1");       # Update hash table;
  39     undef &B::d;
  40     test ((eval { A->d }, ($@ =~ /Undefined subroutine/)), 1);
  41 }
  42
  43 test (A->d, "D::d");            # Back to previous state
  44
  45 eval 'sub B::d {"B::d2"}';      # Import now.
  46 test (A->d, "B::d2");           # Update hash table;
  47
  48 # What follows is hardly guarantied to work, since the names in scripts
  49 # are already linked to "pruned" globs. Say, `undef &B::d' if it were
  50 # after `delete $B::{d}; sub B::d {}' would reach an old subroutine.
  51
  52 undef &B::d;
  53 delete $B::{d};
  54 test (A->d, "C::d");            # Update hash table;
  55
  56 eval 'sub B::d {"B::d3"}';      # Import now.
  57 test (A->d, "B::d3");           # Update hash table;
  58
  59 delete $B::{d};
  60 *dummy::dummy = sub {};         # Mark as updated
  61 test (A->d, "C::d");
  62
  63 eval 'sub B::d {"B::d4"}';      # Import now.
  64 test (A->d, "B::d4");           # Update hash table;
  65
  66 delete $B::{d};                 # Should work without any help too
  67 test (A->d, "C::d");
  68
  69 {
  70     local *C::d;
  71     test (eval { A->d } || "nope", "nope");
  72 }
  73 test (A->d, "C::d");
  74
  75 *A::x = *A::d;                  # See if cache incorrectly follows synonyms
  76 A->d;
  77 test (eval { A->x } || "nope", "nope");
  78
  79 eval <<'EOF';
  80 sub C::e;
  81 BEGIN { *B::e = \&C::e }        # Shouldn't prevent AUTOLOAD in original pkg
  82 sub Y::f;
  83 $counter = 0;
  84
  85 @X::ISA = 'Y';
  86 @Y::ISA = 'B';
  87
  88 sub B::AUTOLOAD {
  89   my $c = ++$counter;
  90   my $method = $B::AUTOLOAD;
  91   my $msg = "B: In $method, $c";
  92   eval "sub $method { \$msg }";
  93   goto &$method;
  94 }
  95 sub C::AUTOLOAD {
  96   my $c = ++$counter;
  97   my $method = $C::AUTOLOAD;
  98   my $msg = "C: In $method, $c";
  99   eval "sub $method { \$msg }";
 100   goto &$method;
 101 }
 102 EOF
 103
 104 test(A->e(), "C: In C::e, 1");  # We get a correct autoload
 105 test(A->e(), "C: In C::e, 1");  # Which sticks
 106
 107 test(A->ee(), "B: In A::ee, 2"); # We get a generic autoload, method in top
 108 test(A->ee(), "B: In A::ee, 2"); # Which sticks
 109
 110 test(Y->f(), "B: In Y::f, 3");  # We vivify a correct method
 111 test(Y->f(), "B: In Y::f, 3");  # Which sticks
 112
 113 # This test is not intended to be reasonable. It is here just to let you
 114 # know that you broke some old construction. Feel free to rewrite the test
 115 # if your patch breaks it.
 116
 117 *B::AUTOLOAD = sub {
 118   my $c = ++$counter;
 119   my $method = $AUTOLOAD;
 120   *$AUTOLOAD = sub { "new B: In $method, $c" };
 121   goto &$AUTOLOAD;
 122 };
 123
 124 test(A->eee(), "new B: In A::eee, 4");  # We get a correct $autoload
 125 test(A->eee(), "new B: In A::eee, 4");  # Which sticks
 126
 127 # this test added due to bug discovery
 128 test(defined(@{"unknown_package::ISA"}) ? "defined" : "undefined", "undefined");