Commit | Line | Data |
09bef843 |
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 | |
8cd79558 |
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 | |
09bef843 |
133 | |
134 | # Other tests should be added above this line |
135 | |
136 | sub NTESTS () { $ntests } |
137 | |
138 | exit $failed; |