1#!./perl 2 3# Regression tests for attrs.pm and the C<sub x : attrs> syntax. 4 5BEGIN { 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 14use warnings; 15no warnings qw(deprecated); # else attrs cries. 16 17sub NTESTS () ; 18 19my ($test, $ntests); 20BEGIN {$ntests=0} 21$test=0; 22my $failed = 0; 23 24print "1..".NTESTS."\n"; 25 26eval 'sub t1 ($) { use attrs "locked"; $_[0]++ }'; 27(print "not "), $failed=1 if $@; 28print "ok ",++$test,"\n"; 29BEGIN {++$ntests} 30 31eval 'sub t2 { use attrs "locked"; $_[0]++ }'; 32(print "not "), $failed=1 if $@; 33print "ok ",++$test,"\n"; 34BEGIN {++$ntests} 35 36eval 'sub t3 ($) : locked ;'; 37(print "not "), $failed=1 if $@; 38print "ok ",++$test,"\n"; 39BEGIN {++$ntests} 40 41eval 'sub t4 : locked ;'; 42(print "not "), $failed=1 if $@; 43print "ok ",++$test,"\n"; 44BEGIN {++$ntests} 45 46my $anon1; 47eval '$anon1 = sub ($) { use attrs qw(locked method); $_[0]++ }'; 48(print "not "), $failed=1 if $@; 49print "ok ",++$test,"\n"; 50BEGIN {++$ntests} 51 52my $anon2; 53eval '$anon2 = sub { use attrs qw(locked method); $_[0]++ }'; 54(print "not "), $failed=1 if $@; 55print "ok ",++$test,"\n"; 56BEGIN {++$ntests} 57 58my $anon3; 59eval '$anon3 = sub { use attrs "method"; $_[0]->[1] }'; 60(print "not "), $failed=1 if $@; 61print "ok ",++$test,"\n"; 62BEGIN {++$ntests} 63 64my @attrs = attrs::get($anon3 ? $anon3 : \&ns); 65(print "not "), $failed=1 unless "@attrs" eq "method"; 66print "ok ",++$test,"\n"; 67BEGIN {++$ntests} 68 69@attrs = sort +attrs::get($anon2 ? $anon2 : \&ns); 70(print "not "), $failed=1 unless "@attrs" eq "locked method"; 71print "ok ",++$test,"\n"; 72BEGIN {++$ntests} 73 74@attrs = sort +attrs::get($anon1 ? $anon1 : \&ns); 75(print "not "), $failed=1 unless "@attrs" eq "locked method"; 76print "ok ",++$test,"\n"; 77BEGIN {++$ntests} 78 79eval 'sub e1 ($) : plugh ;'; 80unless ($@ && $@ =~ 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} 87print "ok ",++$test,"\n"; 88BEGIN {++$ntests} 89 90eval 'sub e2 ($) : plugh(0,0) xyzzy ;'; 91unless ($@ && $@ =~ 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} 98print "ok ",++$test,"\n"; 99BEGIN {++$ntests} 100 101eval 'sub e3 ($) : plugh(0,0 xyzzy ;'; 102unless ($@ && $@ =~ 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} 109print "ok ",++$test,"\n"; 110BEGIN {++$ntests} 111 112eval 'sub e4 ($) : plugh + xyzzy ;'; 113unless ($@ && $@ =~ 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} 120print "ok ",++$test,"\n"; 121BEGIN {++$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 139sub NTESTS () { $ntests } 140 141exit $failed; 142