Commit | Line | Data |
---|---|---|
09bef843 SB |
1 | #!./perl -w |
2 | ||
3 | # Regression tests for attributes.pm and the C< : attrs> syntax. | |
4 | ||
5 | BEGIN { | |
6 | chdir 't' if -d 't'; | |
20822f61 | 7 | @INC = '../lib'; |
09bef843 SB |
8 | } |
9 | ||
10 | sub NTESTS () ; | |
11 | ||
12 | my ($test, $ntests); | |
13 | BEGIN {$ntests=0} | |
14 | $test=0; | |
15 | my $failed = 0; | |
16 | ||
17 | print "1..".NTESTS."\n"; | |
18 | ||
19 | $SIG{__WARN__} = sub { die @_ }; | |
20 | ||
21 | sub mytest { | |
95f0a2f1 | 22 | my $bad = ''; |
09bef843 SB |
23 | if (!$@ ne !$_[0] || $_[0] && $@ !~ $_[0]) { |
24 | if ($@) { | |
25 | my $x = $@; | |
26 | $x =~ s/\n.*\z//s; | |
27 | print "# Got: $x\n" | |
28 | } | |
29 | else { | |
30 | print "# Got unexpected success\n"; | |
31 | } | |
32 | if ($_[0]) { | |
33 | print "# Expected: $_[0]\n"; | |
34 | } | |
35 | else { | |
36 | print "# Expected success\n"; | |
37 | } | |
38 | $failed = 1; | |
95f0a2f1 | 39 | $bad = 'not '; |
09bef843 SB |
40 | } |
41 | elsif (@_ == 3 && $_[1] ne $_[2]) { | |
42 | print "# Got: $_[1]\n"; | |
43 | print "# Expected: $_[2]\n"; | |
44 | $failed = 1; | |
95f0a2f1 | 45 | $bad = 'not '; |
09bef843 | 46 | } |
95f0a2f1 | 47 | print $bad."ok ".++$test."\n"; |
09bef843 SB |
48 | } |
49 | ||
50 | eval 'sub t1 ($) : locked { $_[0]++ }'; | |
51 | mytest; | |
52 | BEGIN {++$ntests} | |
53 | ||
54 | eval 'sub t2 : locked { $_[0]++ }'; | |
55 | mytest; | |
56 | BEGIN {++$ntests} | |
57 | ||
58 | eval 'sub t3 ($) : locked ;'; | |
59 | mytest; | |
60 | BEGIN {++$ntests} | |
61 | ||
62 | eval 'sub t4 : locked ;'; | |
63 | mytest; | |
64 | BEGIN {++$ntests} | |
65 | ||
66 | my $anon1; | |
0120eecf | 67 | eval '$anon1 = sub ($) : locked:method { $_[0]++ }'; |
09bef843 SB |
68 | mytest; |
69 | BEGIN {++$ntests} | |
70 | ||
71 | my $anon2; | |
0120eecf | 72 | eval '$anon2 = sub : locked : method { $_[0]++ }'; |
09bef843 SB |
73 | mytest; |
74 | BEGIN {++$ntests} | |
75 | ||
76 | my $anon3; | |
77 | eval '$anon3 = sub : method { $_[0]->[1] }'; | |
78 | mytest; | |
79 | BEGIN {++$ntests} | |
80 | ||
81 | eval 'sub e1 ($) : plugh ;'; | |
82 | mytest qr/^Invalid CODE attributes?: ["']?plugh["']? at/; | |
83 | BEGIN {++$ntests} | |
84 | ||
85 | eval 'sub e2 ($) : plugh(0,0) xyzzy ;'; | |
86 | mytest qr/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /; | |
87 | BEGIN {++$ntests} | |
88 | ||
89 | eval 'sub e3 ($) : plugh(0,0 xyzzy ;'; | |
90 | mytest qr/Unterminated attribute parameter in attribute list at/; | |
91 | BEGIN {++$ntests} | |
92 | ||
93 | eval 'sub e4 ($) : plugh + xyzzy ;'; | |
94 | mytest qr/Invalid separator character '[+]' in attribute list at/; | |
95 | BEGIN {++$ntests} | |
96 | ||
97 | eval 'my main $x : = 0;'; | |
98 | mytest; | |
99 | BEGIN {++$ntests} | |
100 | ||
101 | eval 'my $x : = 0;'; | |
102 | mytest; | |
103 | BEGIN {++$ntests} | |
104 | ||
105 | eval 'my $x ;'; | |
106 | mytest; | |
107 | BEGIN {++$ntests} | |
108 | ||
109 | eval 'my ($x) : = 0;'; | |
110 | mytest; | |
111 | BEGIN {++$ntests} | |
112 | ||
113 | eval 'my ($x) ;'; | |
114 | mytest; | |
115 | BEGIN {++$ntests} | |
116 | ||
117 | eval 'my ($x) : ;'; | |
118 | mytest; | |
119 | BEGIN {++$ntests} | |
120 | ||
121 | eval 'my ($x,$y) : = 0;'; | |
122 | mytest; | |
123 | BEGIN {++$ntests} | |
124 | ||
125 | eval 'my ($x,$y) ;'; | |
126 | mytest; | |
127 | BEGIN {++$ntests} | |
128 | ||
129 | eval 'my ($x,$y) : ;'; | |
130 | mytest; | |
131 | BEGIN {++$ntests} | |
132 | ||
133 | eval 'my ($x,$y) : plugh;'; | |
134 | mytest qr/^Invalid SCALAR attribute: ["']?plugh["']? at/; | |
135 | BEGIN {++$ntests} | |
136 | ||
137 | sub A::MODIFY_SCALAR_ATTRIBUTES { return } | |
138 | eval 'my A $x : plugh;'; | |
139 | mytest qr/^SCALAR package attribute may clash with future reserved word: ["']?plugh["']? at/; | |
140 | BEGIN {++$ntests} | |
141 | ||
142 | eval 'my A $x : plugh plover;'; | |
143 | mytest qr/^SCALAR package attributes may clash with future reserved words: ["']?plugh["']? /; | |
144 | BEGIN {++$ntests} | |
145 | ||
3f8f4626 DC |
146 | eval 'package Cat; my Cat @socks;'; |
147 | mytest qr/^Can't declare class for non-scalar \@socks in "my"/; | |
148 | BEGIN {++$ntests} | |
149 | ||
09bef843 SB |
150 | sub X::MODIFY_CODE_ATTRIBUTES { die "$_[0]" } |
151 | sub X::foo { 1 } | |
152 | *Y::bar = \&X::foo; | |
153 | *Y::bar = \&X::foo; # second time for -w | |
0256094b | 154 | eval 'package Z; sub Y::bar : foo'; |
09bef843 SB |
155 | mytest qr/^X at /; |
156 | BEGIN {++$ntests} | |
157 | ||
0256094b DM |
158 | eval 'package Z; sub Y::baz : locked {}'; |
159 | my @attrs = eval 'attributes::get \&Y::baz'; | |
09bef843 SB |
160 | mytest '', "@attrs", "locked"; |
161 | BEGIN {++$ntests} | |
162 | ||
163 | @attrs = eval 'attributes::get $anon1'; | |
164 | mytest '', "@attrs", "locked method"; | |
165 | BEGIN {++$ntests} | |
166 | ||
167 | sub Z::DESTROY { } | |
168 | sub Z::FETCH_CODE_ATTRIBUTES { return 'Z' } | |
169 | my $thunk = eval 'bless +sub : method locked { 1 }, "Z"'; | |
170 | mytest '', ref($thunk), "Z"; | |
171 | BEGIN {++$ntests} | |
172 | ||
173 | @attrs = eval 'attributes::get $thunk'; | |
174 | mytest '', "@attrs", "locked method Z"; | |
175 | BEGIN {++$ntests} | |
176 | ||
95f0a2f1 SB |
177 | # Begin testing attributes that tie |
178 | ||
179 | { | |
180 | package Ttie; | |
181 | sub DESTROY {} | |
182 | sub TIESCALAR { my $x = $_[1]; bless \$x, $_[0]; } | |
183 | sub FETCH { ${$_[0]} } | |
184 | sub STORE { | |
185 | #print "# In Ttie::STORE\n"; | |
186 | ::mytest ''; | |
187 | ${$_[0]} = $_[1]*2; | |
188 | } | |
189 | package Tloop; | |
190 | sub MODIFY_SCALAR_ATTRIBUTES { tie ${$_[1]}, 'Ttie', -1; (); } | |
191 | } | |
192 | ||
193 | eval ' | |
194 | package Tloop; | |
195 | for my $i (0..2) { | |
196 | my $x : TieLoop = $i; | |
197 | $x != $i*2 and ::mytest "", $x, $i*2; | |
198 | } | |
199 | '; | |
200 | mytest; | |
201 | BEGIN {$ntests += 4} | |
09bef843 SB |
202 | |
203 | # Other tests should be added above this line | |
204 | ||
205 | sub NTESTS () { $ntests } | |
206 | ||
207 | exit $failed; |