Commit | Line | Data |
---|---|---|
9c6390c7 | 1 | #!./perl |
09bef843 SB |
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'; |
1ce0b88c | 8 | require './test.pl'; |
62e452a4 | 9 | skip_all_if_miniperl("miniperl can't load attributes"); |
09bef843 SB |
10 | } |
11 | ||
98d0ccc7 RGS |
12 | use warnings; |
13 | ||
09bef843 SB |
14 | $SIG{__WARN__} = sub { die @_ }; |
15 | ||
42262798 NC |
16 | sub eval_ok ($;$) { |
17 | eval shift; | |
18 | is( $@, '', @_); | |
09bef843 SB |
19 | } |
20 | ||
ab53f67c FC |
21 | fresh_perl_is 'use attributes; print "ok"', 'ok', |
22 | 'attributes.pm can load without warnings.pm already loaded'; | |
23 | ||
8e5dadda | 24 | our $anon1; eval_ok '$anon1 = sub : method { $_[0]++ }'; |
09bef843 SB |
25 | |
26 | eval 'sub e1 ($) : plugh ;'; | |
1ce0b88c | 27 | like $@, qr/^Invalid CODE attributes?: ["']?plugh["']? at/; |
09bef843 SB |
28 | |
29 | eval 'sub e2 ($) : plugh(0,0) xyzzy ;'; | |
1ce0b88c | 30 | like $@, qr/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /; |
09bef843 SB |
31 | |
32 | eval 'sub e3 ($) : plugh(0,0 xyzzy ;'; | |
1ce0b88c | 33 | like $@, qr/Unterminated attribute parameter in attribute list at/; |
09bef843 | 34 | |
5f211341 | 35 | eval 'sub e4 ($) : plugh + XYZZY ;'; |
1ce0b88c RGS |
36 | like $@, qr/Invalid separator character '[+]' in attribute list at/; |
37 | ||
38 | eval_ok 'my main $x : = 0;'; | |
39 | eval_ok 'my $x : = 0;'; | |
40 | eval_ok 'my $x ;'; | |
41 | eval_ok 'my ($x) : = 0;'; | |
42 | eval_ok 'my ($x) ;'; | |
43 | eval_ok 'my ($x) : ;'; | |
44 | eval_ok 'my ($x,$y) : = 0;'; | |
45 | eval_ok 'my ($x,$y) ;'; | |
46 | eval_ok 'my ($x,$y) : ;'; | |
09bef843 SB |
47 | |
48 | eval 'my ($x,$y) : plugh;'; | |
1ce0b88c | 49 | like $@, qr/^Invalid SCALAR attribute: ["']?plugh["']? at/; |
09bef843 | 50 | |
8e7ae056 RGS |
51 | # bug #16080 |
52 | eval '{my $x : plugh}'; | |
53 | like $@, qr/^Invalid SCALAR attribute: ["']?plugh["']? at/; | |
54 | eval '{my ($x,$y) : plugh(})}'; | |
55 | like $@, qr/^Invalid SCALAR attribute: ["']?plugh\(}\)["']? at/; | |
56 | ||
c9124e92 RGS |
57 | # More syntax tests from the attributes manpage |
58 | eval 'my $x : switch(10,foo(7,3)) : expensive;'; | |
59 | like $@, qr/^Invalid SCALAR attributes: ["']?switch\(10,foo\(7,3\)\) : expensive["']? at/; | |
60 | eval q/my $x : Ugly('\(") :Bad;/; | |
61 | like $@, qr/^Invalid SCALAR attributes: ["']?Ugly\('\\\("\) : Bad["']? at/; | |
62 | eval 'my $x : _5x5;'; | |
63 | like $@, qr/^Invalid SCALAR attribute: ["']?_5x5["']? at/; | |
64 | eval 'my $x : locked method;'; | |
65 | like $@, qr/^Invalid SCALAR attributes: ["']?locked : method["']? at/; | |
66 | eval 'my $x : switch(10,foo();'; | |
67 | like $@, qr/^Unterminated attribute parameter in attribute list at/; | |
68 | eval q/my $x : Ugly('(');/; | |
69 | like $@, qr/^Unterminated attribute parameter in attribute list at/; | |
70 | eval 'my $x : 5x5;'; | |
71 | like $@, qr/error/; | |
72 | eval 'my $x : Y2::north;'; | |
73 | like $@, qr/Invalid separator character ':' in attribute list at/; | |
74 | ||
09bef843 SB |
75 | sub A::MODIFY_SCALAR_ATTRIBUTES { return } |
76 | eval 'my A $x : plugh;'; | |
1ce0b88c | 77 | like $@, qr/^SCALAR package attribute may clash with future reserved word: ["']?plugh["']? at/; |
09bef843 SB |
78 | |
79 | eval 'my A $x : plugh plover;'; | |
1ce0b88c | 80 | like $@, qr/^SCALAR package attributes may clash with future reserved words: ["']?plugh["']? /; |
09bef843 | 81 | |
9c6390c7 RGS |
82 | no warnings 'reserved'; |
83 | eval 'my A $x : plugh;'; | |
84 | is $@, ''; | |
85 | ||
3f8f4626 | 86 | eval 'package Cat; my Cat @socks;'; |
d5e98372 VP |
87 | like $@, ''; |
88 | ||
89 | eval 'my Cat %nap;'; | |
90 | like $@, ''; | |
3f8f4626 | 91 | |
09bef843 SB |
92 | sub X::MODIFY_CODE_ATTRIBUTES { die "$_[0]" } |
93 | sub X::foo { 1 } | |
94 | *Y::bar = \&X::foo; | |
95 | *Y::bar = \&X::foo; # second time for -w | |
0256094b | 96 | eval 'package Z; sub Y::bar : foo'; |
1ce0b88c | 97 | like $@, qr/^X at /; |
09bef843 | 98 | |
09bef843 | 99 | @attrs = eval 'attributes::get $anon1'; |
8e5dadda | 100 | is "@attrs", "method"; |
09bef843 SB |
101 | |
102 | sub Z::DESTROY { } | |
103 | sub Z::FETCH_CODE_ATTRIBUTES { return 'Z' } | |
8e5dadda | 104 | my $thunk = eval 'bless +sub : method { 1 }, "Z"'; |
1ce0b88c | 105 | is ref($thunk), "Z"; |
09bef843 SB |
106 | |
107 | @attrs = eval 'attributes::get $thunk'; | |
8e5dadda | 108 | is "@attrs", "method Z"; |
09bef843 | 109 | |
61dbb99a SF |
110 | # Test attributes on predeclared subroutines: |
111 | eval 'package A; sub PS : lvalue'; | |
112 | @attrs = eval 'attributes::get \&A::PS'; | |
113 | is "@attrs", "lvalue"; | |
114 | ||
eac910c8 GG |
115 | # Test attributes on predeclared subroutines, after definition |
116 | eval 'package A; sub PS : lvalue; sub PS { }'; | |
117 | @attrs = eval 'attributes::get \&A::PS'; | |
118 | is "@attrs", "lvalue"; | |
119 | ||
d3cea301 | 120 | # Test ability to modify existing sub's (or XSUB's) attributes. |
885ef6f5 | 121 | eval 'package A; sub X { $_[0] } sub X : method'; |
d3cea301 | 122 | @attrs = eval 'attributes::get \&A::X'; |
885ef6f5 | 123 | is "@attrs", "method"; |
d3cea301 | 124 | |
020f0e03 SB |
125 | # Above not with just 'pure' built-in attributes. |
126 | sub Z::MODIFY_CODE_ATTRIBUTES { (); } | |
885ef6f5 | 127 | eval 'package Z; sub L { $_[0] } sub L : Z method'; |
020f0e03 | 128 | @attrs = eval 'attributes::get \&Z::L'; |
885ef6f5 | 129 | is "@attrs", "method Z"; |
020f0e03 | 130 | |
95f0a2f1 SB |
131 | # Begin testing attributes that tie |
132 | ||
133 | { | |
134 | package Ttie; | |
135 | sub DESTROY {} | |
136 | sub TIESCALAR { my $x = $_[1]; bless \$x, $_[0]; } | |
137 | sub FETCH { ${$_[0]} } | |
138 | sub STORE { | |
1ce0b88c | 139 | ::pass; |
95f0a2f1 SB |
140 | ${$_[0]} = $_[1]*2; |
141 | } | |
142 | package Tloop; | |
143 | sub MODIFY_SCALAR_ATTRIBUTES { tie ${$_[1]}, 'Ttie', -1; (); } | |
144 | } | |
145 | ||
1ce0b88c | 146 | eval_ok ' |
95f0a2f1 SB |
147 | package Tloop; |
148 | for my $i (0..2) { | |
149 | my $x : TieLoop = $i; | |
1ce0b88c | 150 | $x != $i*2 and ::is $x, $i*2; |
95f0a2f1 SB |
151 | } |
152 | '; | |
09bef843 | 153 | |
1ce0b88c RGS |
154 | # bug #15898 |
155 | eval 'our ${""} : foo = 1'; | |
fab01b8e | 156 | like $@, qr/Can't declare scalar dereference in "our"/; |
1ce0b88c | 157 | eval 'my $$foo : bar = 1'; |
fab01b8e | 158 | like $@, qr/Can't declare scalar dereference in "my"/; |
42262798 NC |
159 | |
160 | ||
c32124fe | 161 | my @code = qw(lvalue method); |
f1a3ce43 NC |
162 | my @other = qw(shared); |
163 | my @deprecated = qw(locked unique); | |
42262798 NC |
164 | my %valid; |
165 | $valid{CODE} = {map {$_ => 1} @code}; | |
166 | $valid{SCALAR} = {map {$_ => 1} @other}; | |
167 | $valid{ARRAY} = $valid{HASH} = $valid{SCALAR}; | |
c32124fe NC |
168 | my %deprecated; |
169 | $deprecated{CODE} = { locked => 1 }; | |
f1a3ce43 | 170 | $deprecated{ARRAY} = $deprecated{HASH} = $deprecated{SCALAR} = { unique => 1 }; |
42262798 | 171 | |
adb2fcba | 172 | our ($scalar, @array, %hash); |
42262798 NC |
173 | foreach my $value (\&foo, \$scalar, \@array, \%hash) { |
174 | my $type = ref $value; | |
175 | foreach my $negate ('', '-') { | |
c32124fe | 176 | foreach my $attr (@code, @other, @deprecated) { |
42262798 NC |
177 | my $attribute = $negate . $attr; |
178 | eval "use attributes __PACKAGE__, \$value, '$attribute'"; | |
c32124fe NC |
179 | if ($deprecated{$type}{$attr}) { |
180 | like $@, qr/^Attribute "$attr" is deprecated at \(eval \d+\)/, | |
181 | "$type attribute $attribute deprecated"; | |
182 | } elsif ($valid{$type}{$attr}) { | |
42262798 NC |
183 | if ($attribute eq '-shared') { |
184 | like $@, qr/^A variable may not be unshared/; | |
185 | } else { | |
186 | is( $@, '', "$type attribute $attribute"); | |
187 | } | |
188 | } else { | |
189 | like $@, qr/^Invalid $type attribute: $attribute/, | |
190 | "Bogus $type attribute $attribute should fail"; | |
191 | } | |
192 | } | |
193 | } | |
194 | } | |
6e592b3a BM |
195 | |
196 | # this will segfault if it fails | |
197 | sub PVBM () { 'foo' } | |
198 | { my $dummy = index 'foo', PVBM } | |
199 | ||
55108fc8 | 200 | ok !defined(eval 'attributes::get(\PVBM)'), |
6e592b3a | 201 | 'PVBMs don\'t segfault attributes::get'; |
09330df8 | 202 | |
8314a0a6 | 203 | { |
93f09d7b | 204 | # [perl #49472] Attributes + Unknown Error |
8314a0a6 NC |
205 | eval ' |
206 | use strict; | |
207 | sub MODIFY_CODE_ATTRIBUTE{} | |
208 | sub f:Blah {$nosuchvar}; | |
209 | '; | |
210 | ||
211 | my $err = $@; | |
212 | like ($err, qr/Global symbol "\$nosuchvar" requires /, 'perl #49472'); | |
213 | } | |
214 | ||
09330df8 Z |
215 | # Test that code attributes always get applied to the same CV that |
216 | # we're left with at the end (bug#66970). | |
217 | { | |
218 | package bug66970; | |
219 | our $c; | |
220 | sub MODIFY_CODE_ATTRIBUTES { $c = $_[1]; () } | |
221 | $c=undef; eval 'sub t0 :Foo'; | |
222 | main::ok $c == \&{"t0"}; | |
223 | $c=undef; eval 'sub t1 :Foo { }'; | |
224 | main::ok $c == \&{"t1"}; | |
225 | $c=undef; eval 'sub t2'; | |
226 | our $t2a = \&{"t2"}; | |
227 | $c=undef; eval 'sub t2 :Foo'; | |
228 | main::ok $c == \&{"t2"} && $c == $t2a; | |
229 | $c=undef; eval 'sub t3'; | |
230 | our $t3a = \&{"t3"}; | |
231 | $c=undef; eval 'sub t3 :Foo { }'; | |
232 | main::ok $c == \&{"t3"} && $c == $t3a; | |
233 | $c=undef; eval 'sub t4 :Foo'; | |
234 | our $t4a = \&{"t4"}; | |
235 | our $t4b = $c; | |
236 | $c=undef; eval 'sub t4 :Foo'; | |
237 | main::ok $c == \&{"t4"} && $c == $t4b && $c == $t4a; | |
238 | $c=undef; eval 'sub t5 :Foo'; | |
239 | our $t5a = \&{"t5"}; | |
240 | our $t5b = $c; | |
241 | $c=undef; eval 'sub t5 :Foo { }'; | |
242 | main::ok $c == \&{"t5"} && $c == $t5b && $c == $t5a; | |
243 | } | |
2dc78664 NC |
244 | |
245 | my @tests = grep {/^[^#]/} split /\n/, <<'EOT'; | |
246 | # This one is fine as an empty attribute list | |
247 | my $holy_Einstein : = ''; | |
248 | # This one is deprecated | |
249 | my $krunch := 4; | |
250 | our $FWISK_FWISK_FWIZZACH_FWACH_ZACHITTY_ZICH_SHAZZATZ_FWISK := ''; | |
251 | state $thump := 'Trumpets'; | |
252 | # Lather rinse repeat in my usual obsessive style | |
253 | my @holy_perfect_pitch : = (); | |
254 | my @zok := (); | |
255 | our @GUKGUK := (); | |
256 | # state @widget_mark := (); | |
257 | my %holy_seditives : = (); | |
258 | my %bang := (); | |
259 | our %GIGAZING := (); | |
260 | # state %hex := (); | |
261 | my $holy_giveaways : = ''; | |
262 | my $eee_yow := []; | |
263 | our $TWOYYOYYOING_THUK_UGH := 1 == 1; | |
264 | state $octothorn := 'Tinky Winky'; | |
265 | my @holy_Taj_Mahal : = (); | |
266 | my @touche := (); | |
267 | our @PLAK_DAK_THUK_FRIT := (); | |
268 | # state @hash_mark := (); | |
269 | my %holy_priceless_collection_of_Etruscan_snoods : = (); | |
270 | my %wham_eth := (); | |
271 | our %THWUK := (); | |
272 | # state %octalthorpe := (); | |
273 | my $holy_sewer_pipe : = ''; | |
274 | my $thunk := undef; | |
275 | our $BLIT := time; | |
276 | state $crunch := 'Laa Laa'; | |
277 | my @glurpp := (); | |
278 | my @holy_harem : = (); | |
279 | our @FABADAP := (); | |
280 | # state @square := (); | |
281 | my %holy_pin_cushions : = (); | |
282 | my %swoosh := (); | |
283 | our %RRRRR := (); | |
284 | # state %scratchmark := (); | |
285 | EOT | |
286 | ||
287 | foreach my $test (@tests) { | |
288 | use feature 'state'; | |
289 | eval $test; | |
290 | if ($test =~ /:=/) { | |
291 | like $@, qr/Use of := for an empty attribute list is not allowed/, | |
292 | "Parse error for q{$test}"; | |
293 | } else { | |
294 | is $@, '', "No error for q{$test}"; | |
295 | } | |
296 | } | |
297 | ||
541ed3a9 FC |
298 | # [perl #68560] Calling closure prototypes (only accessible via :attr) |
299 | { | |
300 | package brength; | |
301 | my $proto; | |
302 | sub MODIFY_CODE_ATTRIBUTES { $proto = $_[1]; _: } | |
ba781e0d | 303 | eval q{ |
541ed3a9 FC |
304 | my $x; |
305 | () = sub :a0 { $x }; | |
ba781e0d | 306 | }; |
541ed3a9 FC |
307 | package main; |
308 | eval { $proto->() }; # used to crash in pp_entersub | |
309 | like $@, qr/^Closure prototype called/, | |
310 | "Calling closure proto with (no) args"; | |
311 | eval { () = &$proto }; # used to crash in pp_leavesub | |
312 | like $@, qr/^Closure prototype called/, | |
17e8b60c | 313 | 'Calling closure proto with no @_ that returns a lexical'; |
541ed3a9 FC |
314 | } |
315 | ||
a1fba7eb FC |
316 | # [perl #68658] Attributes on stately variables |
317 | { | |
318 | package thwext; | |
319 | sub MODIFY_SCALAR_ATTRIBUTES { () } | |
320 | my $i = 0; | |
321 | my $x_values = ''; | |
322 | eval 'sub foo { use 5.01; state $x :A0 = $i++; $x_values .= $x }'; | |
323 | foo(); foo(); | |
324 | package main; | |
325 | is $x_values, '00', 'state with attributes'; | |
326 | } | |
327 | ||
f5d1ed10 FC |
328 | { |
329 | package ningnangnong; | |
330 | sub MODIFY_SCALAR_ATTRIBUTES{} | |
331 | sub MODIFY_ARRAY_ATTRIBUTES{ } | |
332 | sub MODIFY_HASH_ATTRIBUTES{ } | |
333 | my ($cows, @go, %bong) : teapots = qw[ jibber jabber joo ]; | |
334 | ::is $cows, 'jibber', 'list assignment to scalar with attrs'; | |
335 | ::is "@go", 'jabber joo', 'list assignment to array with attrs'; | |
336 | } | |
337 | ||
bb3abb05 FC |
338 | { |
339 | my $w; | |
340 | local $SIG{__WARN__} = sub { $w = shift }; | |
341 | sub ent {} | |
342 | sub lent :lvalue {} | |
343 | my $posmsg = | |
344 | 'lvalue attribute ignored after the subroutine has been defined at ' | |
345 | .'\(eval'; | |
346 | my $negmsg = | |
347 | 'lvalue attribute cannot be removed after the subroutine has been ' | |
348 | .'defined at \(eval'; | |
349 | eval 'use attributes __PACKAGE__, \&ent, "lvalue"'; | |
350 | like $w, qr/^$posmsg/, 'lvalue attr warning on def sub'; | |
351 | is join("",&attributes::get(\&ent)), "",'lvalue attr ignored on def sub'; | |
352 | $w = ''; | |
353 | eval 'use attributes __PACKAGE__, \&lent, "lvalue"; 1' or die; | |
354 | is $w, "", 'no lvalue warning on def lvalue sub'; | |
355 | eval 'use attributes __PACKAGE__, \&lent, "-lvalue"'; | |
356 | like $w, qr/^$negmsg/, 'lvalue attr warning on def sub'; | |
357 | is join("",&attributes::get(\&lent)), "lvalue", | |
358 | '-lvalue ignored on def sub'; | |
359 | $w = ''; | |
360 | eval 'use attributes __PACKAGE__, \&ent, "-lvalue"; 1' or die; | |
361 | is $w, "", 'no lvalue warning on def lvalue sub'; | |
362 | no warnings 'misc'; | |
363 | eval 'use attributes __PACKAGE__, \&ent, "lvalue"'; | |
364 | is $w, "", 'no lvalue warnings under no warnings misc'; | |
365 | eval 'use attributes __PACKAGE__, \&lent, "-lvalue"'; | |
366 | is $w, "", 'no -lvalue warnings under no warnings misc'; | |
367 | } | |
368 | ||
2dc78664 | 369 | done_testing(); |