t/lib/attrs.t

   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;