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..75\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;
  25   print " @_[2..$#_]" if @_ > 2;
  26   print "\n";
  27 }
  28
  29 # First, some basic checks of method-calling syntax:
  30 $obj = bless [], "Pack";
  31 sub Pack::method { shift; join(",", "method", @_) }
  32 $mname = "method";
  33
  34 test(Pack->method("a","b","c"), "method,a,b,c");
  35 test(Pack->$mname("a","b","c"), "method,a,b,c");
  36 test(method Pack ("a","b","c"), "method,a,b,c");
  37 test((method Pack "a","b","c"), "method,a,b,c");
  38
  39 test(Pack->method(), "method");
  40 test(Pack->$mname(), "method");
  41 test(method Pack (), "method");
  42 test(Pack->method, "method");
  43 test(Pack->$mname, "method");
  44 test(method Pack, "method");
  45
  46 test($obj->method("a","b","c"), "method,a,b,c");
  47 test($obj->$mname("a","b","c"), "method,a,b,c");
  48 test((method $obj ("a","b","c")), "method,a,b,c");
  49 test((method $obj "a","b","c"), "method,a,b,c");
  50
  51 test($obj->method(0), "method,0");
  52 test($obj->method(1), "method,1");
  53
  54 test($obj->method(), "method");
  55 test($obj->$mname(), "method");
  56 test((method $obj ()), "method");
  57 test($obj->method, "method");
  58 test($obj->$mname, "method");
  59 test(method $obj, "method");
  60
  61 test( A->d, "C::d");            # Update hash table;
  62
  63 *B::d = \&D::d;                 # Import now.
  64 test (A->d, "D::d");            # Update hash table;
  65
  66 {
  67     local @A::ISA = qw(C);      # Update hash table with split() assignment
  68     test (A->d, "C::d");
  69     $#A::ISA = -1;
  70     test (eval { A->d } || "fail", "fail");
  71 }
  72 test (A->d, "D::d");
  73
  74 {
  75     local *B::d;
  76     eval 'sub B::d {"B::d1"}';  # Import now.
  77     test (A->d, "B::d1");       # Update hash table;
  78     undef &B::d;
  79     test ((eval { A->d }, ($@ =~ /Undefined subroutine/)), 1);
  80 }
  81
  82 test (A->d, "D::d");            # Back to previous state
  83
  84 eval 'sub B::d {"B::d2"}';      # Import now.
  85 test (A->d, "B::d2");           # Update hash table;
  86
  87 # What follows is hardly guarantied to work, since the names in scripts
  88 # are already linked to "pruned" globs. Say, `undef &B::d' if it were
  89 # after `delete $B::{d}; sub B::d {}' would reach an old subroutine.
  90
  91 undef &B::d;
  92 delete $B::{d};
  93 test (A->d, "C::d");            # Update hash table;
  94
  95 eval 'sub B::d {"B::d3"}';      # Import now.
  96 test (A->d, "B::d3");           # Update hash table;
  97
  98 delete $B::{d};
  99 *dummy::dummy = sub {};         # Mark as updated
 100 test (A->d, "C::d");
 101
 102 eval 'sub B::d {"B::d4"}';      # Import now.
 103 test (A->d, "B::d4");           # Update hash table;
 104
 105 delete $B::{d};                 # Should work without any help too
 106 test (A->d, "C::d");
 107
 108 {
 109     local *C::d;
 110     test (eval { A->d } || "nope", "nope");
 111 }
 112 test (A->d, "C::d");
 113
 114 *A::x = *A::d;                  # See if cache incorrectly follows synonyms
 115 A->d;
 116 test (eval { A->x } || "nope", "nope");
 117
 118 eval <<'EOF';
 119 sub C::e;
 120 BEGIN { *B::e = \&C::e }        # Shouldn't prevent AUTOLOAD in original pkg
 121 sub Y::f;
 122 $counter = 0;
 123
 124 @X::ISA = 'Y';
 125 @Y::ISA = 'B';
 126
 127 sub B::AUTOLOAD {
 128   my $c = ++$counter;
 129   my $method = $B::AUTOLOAD;
 130   my $msg = "B: In $method, $c";
 131   eval "sub $method { \$msg }";
 132   goto &$method;
 133 }
 134 sub C::AUTOLOAD {
 135   my $c = ++$counter;
 136   my $method = $C::AUTOLOAD;
 137   my $msg = "C: In $method, $c";
 138   eval "sub $method { \$msg }";
 139   goto &$method;
 140 }
 141 EOF
 142
 143 test(A->e(), "C: In C::e, 1");  # We get a correct autoload
 144 test(A->e(), "C: In C::e, 1");  # Which sticks
 145
 146 test(A->ee(), "B: In A::ee, 2"); # We get a generic autoload, method in top
 147 test(A->ee(), "B: In A::ee, 2"); # Which sticks
 148
 149 test(Y->f(), "B: In Y::f, 3");  # We vivify a correct method
 150 test(Y->f(), "B: In Y::f, 3");  # Which sticks
 151
 152 # This test is not intended to be reasonable. It is here just to let you
 153 # know that you broke some old construction. Feel free to rewrite the test
 154 # if your patch breaks it.
 155
 156 *B::AUTOLOAD = sub {
 157   my $c = ++$counter;
 158   my $method = $AUTOLOAD;
 159   *$AUTOLOAD = sub { "new B: In $method, $c" };
 160   goto &$AUTOLOAD;
 161 };
 162
 163 test(A->eee(), "new B: In A::eee, 4");  # We get a correct $autoload
 164 test(A->eee(), "new B: In A::eee, 4");  # Which sticks
 165
 166 # this test added due to bug discovery
 167 test(defined(@{"unknown_package::ISA"}) ? "defined" : "undefined", "undefined");
 168
 169 # test that failed subroutine calls don't affect method calls
 170 {
 171     package A1;
 172     sub foo { "foo" }
 173     package A2;
 174     @ISA = 'A1';
 175     package main;
 176     test(A2->foo(), "foo");
 177     test(do { eval 'A2::foo()'; $@ ? 1 : 0}, 1);
 178     test(A2->foo(), "foo");
 179 }
 180
 181 ## This test was totally misguided.  It passed before only because the
 182 ## code to determine if a package was loaded used to look for the hash
 183 ## %Foo::Bar instead of the package Foo::Bar:: -- and Config.pm just
 184 ## happens to export %Config.
 185 #  {
 186 #      test(do { use Config; eval 'Config->foo()';
 187 #             $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1);
 188 #      test(do { use Config; eval '$d = bless {}, "Config"; $d->foo()';
 189 #             $@ =~ /^\QCan't locate object method "foo" via package "Config" at/ ? 1 : $@}, 1);
 190 #  }
 191
 192
 193 # test error messages if method loading fails
 194 test(do { eval '$e = bless {}, "E::A"; E::A->foo()';
 195           $@ =~ /^\QCan't locate object method "foo" via package "E::A" at/ ? 1 : $@}, 1);
 196 test(do { eval '$e = bless {}, "E::B"; $e->foo()';
 197           $@ =~ /^\QCan't locate object method "foo" via package "E::B" at/ ? 1 : $@}, 1);
 198 test(do { eval 'E::C->foo()';
 199           $@ =~ /^\QCan't locate object method "foo" via package "E::C" (perhaps / ? 1 : $@}, 1);
 200
 201 test(do { eval 'UNIVERSAL->E::D::foo()';
 202           $@ =~ /^\QCan't locate object method "foo" via package "E::D" (perhaps / ? 1 : $@}, 1);
 203 test(do { eval '$e = bless {}, "UNIVERSAL"; $e->E::E::foo()';
 204           $@ =~ /^\QCan't locate object method "foo" via package "E::E" (perhaps / ? 1 : $@}, 1);
 205
 206 $e = bless {}, "E::F";  # force package to exist
 207 test(do { eval 'UNIVERSAL->E::F::foo()';
 208           $@ =~ /^\QCan't locate object method "foo" via package "E::F" at/ ? 1 : $@}, 1);
 209 test(do { eval '$e = bless {}, "UNIVERSAL"; $e->E::F::foo()';
 210           $@ =~ /^\QCan't locate object method "foo" via package "E::F" at/ ? 1 : $@}, 1);
 211
 212 # TODO: we need some tests for the SUPER:: pseudoclass
 213
 214 # failed method call or UNIVERSAL::can() should not autovivify packages
 215 test( $::{"Foo::"} || "none", "none");  # sanity check 1
 216 test( $::{"Foo::"} || "none", "none");  # sanity check 2
 217
 218 test( UNIVERSAL::can("Foo", "boogie") ? "yes":"no", "no" );
 219 test( $::{"Foo::"} || "none", "none");  # still missing?
 220
 221 test( Foo->UNIVERSAL::can("boogie")   ? "yes":"no", "no" );
 222 test( $::{"Foo::"} || "none", "none");  # still missing?
 223
 224 test( Foo->can("boogie")              ? "yes":"no", "no" );
 225 test( $::{"Foo::"} || "none", "none");  # still missing?
 226
 227 test( eval 'Foo->boogie(); 1'         ? "yes":"no", "no" );
 228 test( $::{"Foo::"} || "none", "none");  # still missing?
 229
 230 test(do { eval 'Foo->boogie()';
 231           $@ =~ /^\QCan't locate object method "boogie" via package "Foo" (perhaps / ? 1 : $@}, 1);
 232
 233 eval 'sub Foo::boogie { "yes, sir!" }';
 234 test( $::{"Foo::"} ? "ok" : "none", "ok");  # should exist now
 235 test( Foo->boogie(), "yes, sir!");
 236
 237 # Some simpleminded tests for the SUPER:: pseudoclass.
 238 # Note that, right now, SUPER:: seems to start looking in the package
 239 # it was compiled in, rather than in the class it was called in.
 240 # Which is wrong. Hence the two TODO tests.
 241 package Parent;
 242
 243 sub foo { 1 };
 244
 245 package Child;
 246
 247 @Child::ISA = 'Parent';
 248
 249 sub child_foo {
 250     my $self = shift;
 251     $self->SUPER::foo;
 252 }
 253
 254 package main;
 255
 256 sub Child::main_foo { $_[0]->SUPER::foo }
 257
 258 *Child::late_foo = sub { $_[0]->SUPER::foo };
 259
 260
 261 test( scalar(eval {Child->child_foo}), 1 );
 262 test( scalar(eval {Child->main_foo}), 1, "# TODO SUPER:: non intuitive");
 263 test( scalar(eval {Child->late_foo}), 1, "# TODO SUPER:: non intuitive");
 264
 265 # TODO: universal.t should test NoSuchPackage->isa()/can()
 266
 267 # This is actually testing parsing of indirect objects and undefined subs
 268 #   print foo("bar") where foo does not exist is not an indirect object.
 269 #   print foo "bar"  where foo does not exist is an indirect object.
 270 eval { sub AUTOLOAD { "ok ", shift, "\n"; } };
 271 print nonsuch(++$cnt);
 272
 273 print "# $cnt tests completed\n";