home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / op / method.t < prev    next >
Text File  |  1999-07-20  |  4KB  |  170 lines
  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. }
  170.