t/op/method.t

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