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