home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / t / lib / attrs.t < prev    next >
Text File  |  2000-03-14  |  3KB  |  139 lines
  1. #!./perl
  2.  
  3. # Regression tests for attrs.pm and the C<sub x : attrs> syntax.
  4.  
  5. BEGIN {
  6.     chdir 't' if -d 't';
  7.     unshift @INC, '../lib';
  8.     eval 'require attrs; 1' or do {
  9.     print "1..0\n";
  10.     exit 0;
  11.     }
  12. }
  13.  
  14. sub NTESTS () ;
  15.  
  16. my $test, $ntests;
  17. BEGIN {$ntests=0}
  18. $test=0;
  19. my $failed = 0;
  20.  
  21. print "1..".NTESTS."\n";
  22.  
  23. eval 'sub t1 ($) { use attrs "locked"; $_[0]++ }';
  24. (print "not "), $failed=1 if $@;
  25. print "ok ",++$test,"\n";
  26. BEGIN {++$ntests}
  27.  
  28. eval 'sub t2 { use attrs "locked"; $_[0]++ }';
  29. (print "not "), $failed=1 if $@;
  30. print "ok ",++$test,"\n";
  31. BEGIN {++$ntests}
  32.  
  33. eval 'sub t3 ($) : locked ;';
  34. (print "not "), $failed=1 if $@;
  35. print "ok ",++$test,"\n";
  36. BEGIN {++$ntests}
  37.  
  38. eval 'sub t4 : locked ;';
  39. (print "not "), $failed=1 if $@;
  40. print "ok ",++$test,"\n";
  41. BEGIN {++$ntests}
  42.  
  43. my $anon1;
  44. eval '$anon1 = sub ($) { use attrs qw(locked method); $_[0]++ }';
  45. (print "not "), $failed=1 if $@;
  46. print "ok ",++$test,"\n";
  47. BEGIN {++$ntests}
  48.  
  49. my $anon2;
  50. eval '$anon2 = sub { use attrs qw(locked method); $_[0]++ }';
  51. (print "not "), $failed=1 if $@;
  52. print "ok ",++$test,"\n";
  53. BEGIN {++$ntests}
  54.  
  55. my $anon3;
  56. eval '$anon3 = sub { use attrs "method"; $_[0]->[1] }';
  57. (print "not "), $failed=1 if $@;
  58. print "ok ",++$test,"\n";
  59. BEGIN {++$ntests}
  60.  
  61. my @attrs = attrs::get($anon3 ? $anon3 : \&ns);
  62. (print "not "), $failed=1 unless "@attrs" eq "method";
  63. print "ok ",++$test,"\n";
  64. BEGIN {++$ntests}
  65.  
  66. @attrs = sort +attrs::get($anon2 ? $anon2 : \&ns);
  67. (print "not "), $failed=1 unless "@attrs" eq "locked method";
  68. print "ok ",++$test,"\n";
  69. BEGIN {++$ntests}
  70.  
  71. @attrs = sort +attrs::get($anon1 ? $anon1 : \&ns);
  72. (print "not "), $failed=1 unless "@attrs" eq "locked method";
  73. print "ok ",++$test,"\n";
  74. BEGIN {++$ntests}
  75.  
  76. eval 'sub e1 ($) : plugh ;';
  77. unless ($@ && $@ =~ m/^Invalid CODE attribute: ["']?plugh["']? at/) {
  78.     my $x = $@;
  79.     $x =~ s/\n.*\z//s;
  80.     print "# $x\n";
  81.     print "not ";
  82.     $failed = 1;
  83. }
  84. print "ok ",++$test,"\n";
  85. BEGIN {++$ntests}
  86.  
  87. eval 'sub e2 ($) : plugh(0,0) xyzzy ;';
  88. unless ($@ && $@ =~ m/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /) {
  89.     my $x = $@;
  90.     $x =~ s/\n.*\z//s;
  91.     print "# $x\n";
  92.     print "not ";
  93.     $failed = 1;
  94. }
  95. print "ok ",++$test,"\n";
  96. BEGIN {++$ntests}
  97.  
  98. eval 'sub e3 ($) : plugh(0,0 xyzzy ;';
  99. unless ($@ && $@ =~ m/Unterminated attribute parameter in attribute list at/) {
  100.     my $x = $@;
  101.     $x =~ s/\n.*\z//s;
  102.     print "# $x\n";
  103.     print "not ";
  104.     $failed = 1;
  105. }
  106. print "ok ",++$test,"\n";
  107. BEGIN {++$ntests}
  108.  
  109. eval 'sub e4 ($) : plugh + xyzzy ;';
  110. unless ($@ && $@ =~ m/Invalid separator character '[+]' in attribute list at/) {
  111.     my $x = $@;
  112.     $x =~ s/\n.*\z//s;
  113.     print "# $x\n";
  114.     print "not ";
  115.     $failed = 1;
  116. }
  117. print "ok ",++$test,"\n";
  118. BEGIN {++$ntests}
  119.  
  120. {
  121.     my $w = "" ;
  122.     local $SIG{__WARN__} = sub {$w = @_[0]} ;
  123.     eval 'sub w1 ($) { use warnings "deprecated"; use attrs "locked"; $_[0]++ }';
  124.     (print "not "), $failed=1 if $@;
  125.     print "ok ",++$test,"\n";
  126.     BEGIN {++$ntests}
  127.     (print "not "), $failed=1 
  128.     if $w !~ /^pragma "attrs" is deprecated, use "sub NAME : ATTRS" instead at/;
  129.     print "ok ",++$test,"\n";
  130.     BEGIN {++$ntests}
  131. }
  132.  
  133.  
  134. # Other tests should be added above this line
  135.  
  136. sub NTESTS () { $ntests }
  137.  
  138. exit $failed;
  139.