t/op/method.t

   1 #!./perl
   2
   3 #
   4 # test method calls and autoloading.
   5 #
   6
   7 print "1..20\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 *B::d;
  29     eval 'sub B::d {"B::d1"}';  # Import now.
  30     test (A->d, "B::d1");       # Update hash table;
  31     undef &B::d;
  32     test ((eval { A->d }, ($@ =~ /Undefined subroutine/)), 1);
  33 }
  34
  35 test (A->d, "D::d");            # Back to previous state
  36
  37 eval 'sub B::d {"B::d2"}';      # Import now.
  38 test (A->d, "B::d2");           # Update hash table;
  39
  40 # What follows is hardly guarantied to work, since the names in scripts
  41 # are already linked to "pruned" globs. Say, `undef &B::d' if it were
  42 # after `delete $B::{d}; sub B::d {}' would reach an old subroutine.
  43
  44 undef &B::d;
  45 delete $B::{d};
  46 test (A->d, "C::d");            # Update hash table;
  47
  48 eval 'sub B::d {"B::d3"}';      # Import now.
  49 test (A->d, "B::d3");           # Update hash table;
  50
  51 delete $B::{d};
  52 *dummy::dummy = sub {};         # Mark as updated
  53 test (A->d, "C::d");
  54
  55 eval 'sub B::d {"B::d4"}';      # Import now.
  56 test (A->d, "B::d4");           # Update hash table;
  57
  58 delete $B::{d};                 # Should work without any help too
  59 test (A->d, "C::d");
  60
  61 *A::x = *A::d;                  # See if cache incorrectly follows synonyms
  62 A->d;
  63 test (eval { A->x } || "nope", "nope");
  64
  65 eval <<'EOF';
  66 sub C::e;
  67 BEGIN { *B::e = \&C::e }        # Shouldn't prevent AUTOLOAD in original pkg
  68 sub Y::f;
  69 $counter = 0;
  70
  71 @X::ISA = 'Y';
  72 @Y::ISA = 'B';
  73
  74 sub B::AUTOLOAD {
  75   my $c = ++$counter;
  76   my $method = $B::AUTOLOAD;
  77   my $msg = "B: In $method, $c";
  78   eval "sub $method { \$msg }";
  79   goto &$method;
  80 }
  81 sub C::AUTOLOAD {
  82   my $c = ++$counter;
  83   my $method = $C::AUTOLOAD;
  84   my $msg = "C: In $method, $c";
  85   eval "sub $method { \$msg }";
  86   goto &$method;
  87 }
  88 EOF
  89
  90 test(A->e(), "C: In C::e, 1");  # We get a correct autoload
  91 test(A->e(), "C: In C::e, 1");  # Which sticks
  92
  93 test(A->ee(), "B: In A::ee, 2"); # We get a generic autoload, method in top
  94 test(A->ee(), "B: In A::ee, 2"); # Which sticks
  95
  96 test(Y->f(), "B: In Y::f, 3");  # We vivify a correct method
  97 test(Y->f(), "B: In Y::f, 3");  # Which sticks
  98
  99 # This test is not intended to be reasonable. It is here just to let you
 100 # know that you broke some old construction. Feel free to rewrite the test
 101 # if your patch breaks it.
 102
 103 *B::AUTOLOAD = sub {
 104   my $c = ++$counter;
 105   my $method = $AUTOLOAD;
 106   *$AUTOLOAD = sub { "new B: In $method, $c" };
 107   goto &$AUTOLOAD;
 108 };
 109
 110 test(A->eee(), "new B: In A::eee, 4");  # We get a correct $autoload
 111 test(A->eee(), "new B: In A::eee, 4");  # Which sticks