3 # Regression tests for attrs.pm and the C<sub x : attrs> syntax.
7 unshift @INC, '../lib';
8 eval 'require attrs; 1' or do {
21 print "1..".NTESTS."\n";
23 eval 'sub t1 ($) { use attrs "locked"; $_[0]++ }';
24 (print "not "), $failed=1 if $@;
25 print "ok ",++$test,"\n";
28 eval 'sub t2 { use attrs "locked"; $_[0]++ }';
29 (print "not "), $failed=1 if $@;
30 print "ok ",++$test,"\n";
33 eval 'sub t3 ($) : locked ;';
34 (print "not "), $failed=1 if $@;
35 print "ok ",++$test,"\n";
38 eval 'sub t4 : locked ;';
39 (print "not "), $failed=1 if $@;
40 print "ok ",++$test,"\n";
44 eval '$anon1 = sub ($) { use attrs qw(locked method); $_[0]++ }';
45 (print "not "), $failed=1 if $@;
46 print "ok ",++$test,"\n";
50 eval '$anon2 = sub { use attrs qw(locked method); $_[0]++ }';
51 (print "not "), $failed=1 if $@;
52 print "ok ",++$test,"\n";
56 eval '$anon3 = sub { use attrs "method"; $_[0]->[1] }';
57 (print "not "), $failed=1 if $@;
58 print "ok ",++$test,"\n";
61 my @attrs = attrs::get($anon3 ? $anon3 : \&ns);
62 (print "not "), $failed=1 unless "@attrs" eq "method";
63 print "ok ",++$test,"\n";
66 @attrs = sort +attrs::get($anon2 ? $anon2 : \&ns);
67 (print "not "), $failed=1 unless "@attrs" eq "locked method";
68 print "ok ",++$test,"\n";
71 @attrs = sort +attrs::get($anon1 ? $anon1 : \&ns);
72 (print "not "), $failed=1 unless "@attrs" eq "locked method";
73 print "ok ",++$test,"\n";
76 eval 'sub e1 ($) : plugh ;';
77 unless ($@ && $@ =~ m/^Invalid CODE attribute: ["']?plugh["']? at/) {
84 print "ok ",++$test,"\n";
87 eval 'sub e2 ($) : plugh(0,0) xyzzy ;';
88 unless ($@ && $@ =~ m/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /) {
95 print "ok ",++$test,"\n";
98 eval 'sub e3 ($) : plugh(0,0 xyzzy ;';
99 unless ($@ && $@ =~ m/Unterminated attribute parameter in attribute list at/) {
106 print "ok ",++$test,"\n";
109 eval 'sub e4 ($) : plugh + xyzzy ;';
110 unless ($@ && $@ =~ m/Invalid separator character '[+]' in attribute list at/) {
117 print "ok ",++$test,"\n";
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";
127 (print "not "), $failed=1
128 if $w !~ /^pragma "attrs" is deprecated, use "sub NAME : ATTRS" instead at/;
129 print "ok ",++$test,"\n";
134 # Other tests should be added above this line
136 sub NTESTS () { $ntests }