Commit | Line | Data |
---|---|---|
09bef843 SB |
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'; | |
20822f61 | 7 | @INC = '../lib'; |
09bef843 SB |
8 | eval 'require attrs; 1' or do { |
9 | print "1..0\n"; | |
10 | exit 0; | |
11 | } | |
12 | } | |
13 | ||
b75c8c73 MS |
14 | use warnings; |
15 | no warnings qw(deprecated); # else attrs cries. | |
16 | ||
09bef843 SB |
17 | sub NTESTS () ; |
18 | ||
b75c8c73 | 19 | my ($test, $ntests); |
09bef843 SB |
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 | ||
8cd79558 GS |
123 | { |
124 | my $w = "" ; | |
b75c8c73 | 125 | local $SIG{__WARN__} = sub {$w = shift} ; |
8cd79558 GS |
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 | ||
09bef843 SB |
136 | |
137 | # Other tests should be added above this line | |
138 | ||
139 | sub NTESTS () { $ntests } | |
140 | ||
141 | exit $failed; |