Commit | Line | Data |
09bef843 |
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 |
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 |
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 |
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 |
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 |
68 | mytest; |
69 | BEGIN {++$ntests} |
70 | |
71 | my $anon2; |
0120eecf |
72 | eval '$anon2 = sub : locked : method { $_[0]++ }'; |
09bef843 |
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 |
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 |
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 |
155 | mytest qr/^X at /; |
156 | BEGIN {++$ntests} |
157 | |
0256094b |
158 | eval 'package Z; sub Y::baz : locked {}'; |
159 | my @attrs = eval 'attributes::get \&Y::baz'; |
09bef843 |
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 |
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 |
202 | |
203 | # Other tests should be added above this line |
204 | |
205 | sub NTESTS () { $ntests } |
206 | |
207 | exit $failed; |