t/op/method.t

   1 #!./perl
   2
   3 #
   4 # test method calls and autoloading.
   5 #
   6
   7 print "1..49\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 # First, some basic checks of method-calling syntax:
  23 $obj = bless [], "Pack";
  24 sub Pack::method { shift; join(",", "method", @_) }
  25 $mname = "method";
  26
  27 test(Pack->method("a","b","c"), "method,a,b,c");
  28 test(Pack->$mname("a","b","c"), "method,a,b,c");
  29 test(method Pack ("a","b","c"), "method,a,b,c");
  30 test((method Pack "a","b","c"), "method,a,b,c");
  31
  32 test(Pack->method(), "method");
  33 test(Pack->$mname(), "method");
  34 test(method Pack (), "method");
  35 test(Pack->method, "method");
  36 test(Pack->$mname, "method");
  37 test(method Pack, "method");
  38
  39 test($obj->method("a","b","c"), "method,a,b,c");
  40 test($obj->$mname("a","b","c"), "method,a,b,c");
  41 test((method $obj ("a","b","c")), "method,a,b,c");
  42 test((method $obj "a","b","c"), "method,a,b,c");
  43
  44 test($obj->method(), "method");
  45 test($obj->$mname(), "method");
  46 test((method $obj ()), "method");
  47 test($obj->method, "method");
  48 test($obj->$mname, "method");
  49 test(method $obj, "method");
  50
  51 test( A->d, "C::d");            # Update hash table;
  52
  53 *B::d = \&D::d;                 # Import now.
  54 test (A->d, "D::d");            # Update hash table;
  55
  56 {
  57     local @A::ISA = qw(C);      # Update hash table with split() assignment
  58     test (A->d, "C::d");
  59     $#A::ISA = -1;
  60     test (eval { A->d } || "fail", "fail");
  61 }
  62 test (A->d, "D::d");
  63
  64 {
  65     local *B::d;
  66     eval 'sub B::d {"B::d1"}';  # Import now.
  67     test (A->d, "B::d1");       # Update hash table;
  68     undef &B::d;
  69     test ((eval { A->d }, ($@ =~ /Undefined subroutine/)), 1);
  70 }
  71
  72 test (A->d, "D::d");            # Back to previous state
  73
  74 eval 'sub B::d {"B::d2"}';      # Import now.
  75 test (A->d, "B::d2");           # Update hash table;
  76
  77 # What follows is hardly guarantied to work, since the names in scripts
  78 # are already linked to "pruned" globs. Say, `undef &B::d' if it were
  79 # after `delete $B::{d}; sub B::d {}' would reach an old subroutine.
  80
  81 undef &B::d;
  82 delete $B::{d};
  83 test (A->d, "C::d");            # Update hash table;
  84
  85 eval 'sub B::d {"B::d3"}';      # Import now.
  86 test (A->d, "B::d3");           # Update hash table;
  87
  88 delete $B::{d};
  89 *dummy::dummy = sub {};         # Mark as updated
  90 test (A->d, "C::d");
  91
  92 eval 'sub B::d {"B::d4"}';      # Import now.
  93 test (A->d, "B::d4");           # Update hash table;
  94
  95 delete $B::{d};                 # Should work without any help too
  96 test (A->d, "C::d");
  97
  98 {
  99     local *C::d;
 100     test (eval { A->d } || "nope", "nope");
 101 }
 102 test (A->d, "C::d");
 103
 104 *A::x = *A::d;                  # See if cache incorrectly follows synonyms
 105 A->d;
 106 test (eval { A->x } || "nope", "nope");
 107
 108 eval <<'EOF';
 109 sub C::e;
 110 BEGIN { *B::e = \&C::e }        # Shouldn't prevent AUTOLOAD in original pkg
 111 sub Y::f;
 112 $counter = 0;
 113
 114 @X::ISA = 'Y';
 115 @Y::ISA = 'B';
 116
 117 sub B::AUTOLOAD {
 118   my $c = ++$counter;
 119   my $method = $B::AUTOLOAD;
 120   my $msg = "B: In $method, $c";
 121   eval "sub $method { \$msg }";
 122   goto &$method;
 123 }
 124 sub C::AUTOLOAD {
 125   my $c = ++$counter;
 126   my $method = $C::AUTOLOAD;
 127   my $msg = "C: In $method, $c";
 128   eval "sub $method { \$msg }";
 129   goto &$method;
 130 }
 131 EOF
 132
 133 test(A->e(), "C: In C::e, 1");  # We get a correct autoload
 134 test(A->e(), "C: In C::e, 1");  # Which sticks
 135
 136 test(A->ee(), "B: In A::ee, 2"); # We get a generic autoload, method in top
 137 test(A->ee(), "B: In A::ee, 2"); # Which sticks
 138
 139 test(Y->f(), "B: In Y::f, 3");  # We vivify a correct method
 140 test(Y->f(), "B: In Y::f, 3");  # Which sticks
 141
 142 # This test is not intended to be reasonable. It is here just to let you
 143 # know that you broke some old construction. Feel free to rewrite the test
 144 # if your patch breaks it.
 145
 146 *B::AUTOLOAD = sub {
 147   my $c = ++$counter;
 148   my $method = $AUTOLOAD;
 149   *$AUTOLOAD = sub { "new B: In $method, $c" };
 150   goto &$AUTOLOAD;
 151 };
 152
 153 test(A->eee(), "new B: In A::eee, 4");  # We get a correct $autoload
 154 test(A->eee(), "new B: In A::eee, 4");  # Which sticks
 155
 156 # this test added due to bug discovery
 157 test(defined(@{"unknown_package::ISA"}) ? "defined" : "undefined", "undefined");
 158
 159 # test that failed subroutine calls don't affect method calls
 160 {
 161     package A1;
 162     sub foo { "foo" }
 163     package A2;
 164     @ISA = 'A1';
 165     package main;
 166     test(A2->foo(), "foo");
 167     test(do { eval 'A2::foo()'; $@ ? 1 : 0}, 1);
 168     test(A2->foo(), "foo");
 169 }