home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / op / attrs.t < prev    next >
Text File  |  2000-01-26  |  3KB  |  177 lines
  1. #!./perl -w
  2.  
  3. # Regression tests for attributes.pm and the C< : attrs> syntax.
  4.  
  5. BEGIN {
  6.     chdir 't' if -d 't';
  7.     unshift @INC, '../lib';
  8. }
  9.  
  10. sub NTESTS () ;
  11.  
  12. my ($test, $ntests);
  13. BEGIN {$ntests=0}
  14. $test=0;
  15. my $failed = 0;
  16.  
  17. print "1..".NTESTS."\n";
  18.  
  19. $SIG{__WARN__} = sub { die @_ };
  20.  
  21. sub mytest {
  22.     if (!$@ ne !$_[0] || $_[0] && $@ !~ $_[0]) {
  23.     if ($@) {
  24.         my $x = $@;
  25.         $x =~ s/\n.*\z//s;
  26.         print "# Got: $x\n"
  27.     }
  28.     else {
  29.         print "# Got unexpected success\n";
  30.     }
  31.     if ($_[0]) {
  32.         print "# Expected: $_[0]\n";
  33.     }
  34.     else {
  35.         print "# Expected success\n";
  36.     }
  37.     $failed = 1;
  38.     print "not ";
  39.     }
  40.     elsif (@_ == 3 && $_[1] ne $_[2]) {
  41.     print "# Got: $_[1]\n";
  42.     print "# Expected: $_[2]\n";
  43.     $failed = 1;
  44.     print "not ";
  45.     }
  46.     print "ok ",++$test,"\n";
  47. }
  48.  
  49. eval 'sub t1 ($) : locked { $_[0]++ }';
  50. mytest;
  51. BEGIN {++$ntests}
  52.  
  53. eval 'sub t2 : locked { $_[0]++ }';
  54. mytest;
  55. BEGIN {++$ntests}
  56.  
  57. eval 'sub t3 ($) : locked ;';
  58. mytest;
  59. BEGIN {++$ntests}
  60.  
  61. eval 'sub t4 : locked ;';
  62. mytest;
  63. BEGIN {++$ntests}
  64.  
  65. my $anon1;
  66. eval '$anon1 = sub ($) : locked:method { $_[0]++ }';
  67. mytest;
  68. BEGIN {++$ntests}
  69.  
  70. my $anon2;
  71. eval '$anon2 = sub : locked : method { $_[0]++ }';
  72. mytest;
  73. BEGIN {++$ntests}
  74.  
  75. my $anon3;
  76. eval '$anon3 = sub : method { $_[0]->[1] }';
  77. mytest;
  78. BEGIN {++$ntests}
  79.  
  80. eval 'sub e1 ($) : plugh ;';
  81. mytest qr/^Invalid CODE attributes?: ["']?plugh["']? at/;
  82. BEGIN {++$ntests}
  83.  
  84. eval 'sub e2 ($) : plugh(0,0) xyzzy ;';
  85. mytest qr/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /;
  86. BEGIN {++$ntests}
  87.  
  88. eval 'sub e3 ($) : plugh(0,0 xyzzy ;';
  89. mytest qr/Unterminated attribute parameter in attribute list at/;
  90. BEGIN {++$ntests}
  91.  
  92. eval 'sub e4 ($) : plugh + xyzzy ;';
  93. mytest qr/Invalid separator character '[+]' in attribute list at/;
  94. BEGIN {++$ntests}
  95.  
  96. eval 'my main $x : = 0;';
  97. mytest;
  98. BEGIN {++$ntests}
  99.  
  100. eval 'my $x : = 0;';
  101. mytest;
  102. BEGIN {++$ntests}
  103.  
  104. eval 'my $x ;';
  105. mytest;
  106. BEGIN {++$ntests}
  107.  
  108. eval 'my ($x) : = 0;';
  109. mytest;
  110. BEGIN {++$ntests}
  111.  
  112. eval 'my ($x) ;';
  113. mytest;
  114. BEGIN {++$ntests}
  115.  
  116. eval 'my ($x) : ;';
  117. mytest;
  118. BEGIN {++$ntests}
  119.  
  120. eval 'my ($x,$y) : = 0;';
  121. mytest;
  122. BEGIN {++$ntests}
  123.  
  124. eval 'my ($x,$y) ;';
  125. mytest;
  126. BEGIN {++$ntests}
  127.  
  128. eval 'my ($x,$y) : ;';
  129. mytest;
  130. BEGIN {++$ntests}
  131.  
  132. eval 'my ($x,$y) : plugh;';
  133. mytest qr/^Invalid SCALAR attribute: ["']?plugh["']? at/;
  134. BEGIN {++$ntests}
  135.  
  136. sub A::MODIFY_SCALAR_ATTRIBUTES { return }
  137. eval 'my A $x : plugh;';
  138. mytest qr/^SCALAR package attribute may clash with future reserved word: ["']?plugh["']? at/;
  139. BEGIN {++$ntests}
  140.  
  141. eval 'my A $x : plugh plover;';
  142. mytest qr/^SCALAR package attributes may clash with future reserved words: ["']?plugh["']? /;
  143. BEGIN {++$ntests}
  144.  
  145. sub X::MODIFY_CODE_ATTRIBUTES { die "$_[0]" }
  146. sub X::foo { 1 }
  147. *Y::bar = \&X::foo;
  148. *Y::bar = \&X::foo;    # second time for -w
  149. eval 'package Z; sub Y::bar : locked';
  150. mytest qr/^X at /;
  151. BEGIN {++$ntests}
  152.  
  153. my @attrs = eval 'attributes::get \&Y::bar';
  154. mytest '', "@attrs", "locked";
  155. BEGIN {++$ntests}
  156.  
  157. @attrs = eval 'attributes::get $anon1';
  158. mytest '', "@attrs", "locked method";
  159. BEGIN {++$ntests}
  160.  
  161. sub Z::DESTROY { }
  162. sub Z::FETCH_CODE_ATTRIBUTES { return 'Z' }
  163. my $thunk = eval 'bless +sub : method locked { 1 }, "Z"';
  164. mytest '', ref($thunk), "Z";
  165. BEGIN {++$ntests}
  166.  
  167. @attrs = eval 'attributes::get $thunk';
  168. mytest '', "@attrs", "locked method Z";
  169. BEGIN {++$ntests}
  170.  
  171.  
  172. # Other tests should be added above this line
  173.  
  174. sub NTESTS () { $ntests }
  175.  
  176. exit $failed;
  177.