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