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'; |
1ce0b88c |
8 | require './test.pl'; |
09bef843 |
9 | } |
10 | |
1ce0b88c |
11 | plan tests => 37; |
09bef843 |
12 | |
13 | $SIG{__WARN__} = sub { die @_ }; |
14 | |
1ce0b88c |
15 | sub eval_ok ($) { |
16 | eval $_[0]; |
17 | is( $@, '' ); |
09bef843 |
18 | } |
19 | |
1ce0b88c |
20 | eval_ok 'sub t1 ($) : locked { $_[0]++ }'; |
21 | eval_ok 'sub t2 : locked { $_[0]++ }'; |
22 | eval_ok 'sub t3 ($) : locked ;'; |
23 | eval_ok 'sub t4 : locked ;'; |
24 | our $anon1; eval_ok '$anon1 = sub ($) : locked:method { $_[0]++ }'; |
25 | our $anon2; eval_ok '$anon2 = sub : locked : method { $_[0]++ }'; |
26 | our $anon3; eval_ok '$anon3 = sub : method { $_[0]->[1] }'; |
09bef843 |
27 | |
28 | eval 'sub e1 ($) : plugh ;'; |
1ce0b88c |
29 | like $@, qr/^Invalid CODE attributes?: ["']?plugh["']? at/; |
09bef843 |
30 | |
31 | eval 'sub e2 ($) : plugh(0,0) xyzzy ;'; |
1ce0b88c |
32 | like $@, qr/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /; |
09bef843 |
33 | |
34 | eval 'sub e3 ($) : plugh(0,0 xyzzy ;'; |
1ce0b88c |
35 | like $@, qr/Unterminated attribute parameter in attribute list at/; |
09bef843 |
36 | |
37 | eval 'sub e4 ($) : plugh + xyzzy ;'; |
1ce0b88c |
38 | like $@, qr/Invalid separator character '[+]' in attribute list at/; |
39 | |
40 | eval_ok 'my main $x : = 0;'; |
41 | eval_ok 'my $x : = 0;'; |
42 | eval_ok 'my $x ;'; |
43 | eval_ok 'my ($x) : = 0;'; |
44 | eval_ok 'my ($x) ;'; |
45 | eval_ok 'my ($x) : ;'; |
46 | eval_ok 'my ($x,$y) : = 0;'; |
47 | eval_ok 'my ($x,$y) ;'; |
48 | eval_ok 'my ($x,$y) : ;'; |
09bef843 |
49 | |
50 | eval 'my ($x,$y) : plugh;'; |
1ce0b88c |
51 | like $@, qr/^Invalid SCALAR attribute: ["']?plugh["']? at/; |
09bef843 |
52 | |
53 | sub A::MODIFY_SCALAR_ATTRIBUTES { return } |
54 | eval 'my A $x : plugh;'; |
1ce0b88c |
55 | like $@, qr/^SCALAR package attribute may clash with future reserved word: ["']?plugh["']? at/; |
09bef843 |
56 | |
57 | eval 'my A $x : plugh plover;'; |
1ce0b88c |
58 | like $@, qr/^SCALAR package attributes may clash with future reserved words: ["']?plugh["']? /; |
09bef843 |
59 | |
3f8f4626 |
60 | eval 'package Cat; my Cat @socks;'; |
1ce0b88c |
61 | like $@, qr/^Can't declare class for non-scalar \@socks in "my"/; |
3f8f4626 |
62 | |
09bef843 |
63 | sub X::MODIFY_CODE_ATTRIBUTES { die "$_[0]" } |
64 | sub X::foo { 1 } |
65 | *Y::bar = \&X::foo; |
66 | *Y::bar = \&X::foo; # second time for -w |
0256094b |
67 | eval 'package Z; sub Y::bar : foo'; |
1ce0b88c |
68 | like $@, qr/^X at /; |
09bef843 |
69 | |
0256094b |
70 | eval 'package Z; sub Y::baz : locked {}'; |
71 | my @attrs = eval 'attributes::get \&Y::baz'; |
1ce0b88c |
72 | is "@attrs", "locked"; |
09bef843 |
73 | |
74 | @attrs = eval 'attributes::get $anon1'; |
1ce0b88c |
75 | is "@attrs", "locked method"; |
09bef843 |
76 | |
77 | sub Z::DESTROY { } |
78 | sub Z::FETCH_CODE_ATTRIBUTES { return 'Z' } |
79 | my $thunk = eval 'bless +sub : method locked { 1 }, "Z"'; |
1ce0b88c |
80 | is ref($thunk), "Z"; |
09bef843 |
81 | |
82 | @attrs = eval 'attributes::get $thunk'; |
1ce0b88c |
83 | is "@attrs", "locked method Z"; |
09bef843 |
84 | |
d3cea301 |
85 | # Test ability to modify existing sub's (or XSUB's) attributes. |
86 | eval 'package A; sub X { $_[0] } sub X : lvalue'; |
87 | @attrs = eval 'attributes::get \&A::X'; |
1ce0b88c |
88 | is "@attrs", "lvalue"; |
d3cea301 |
89 | |
020f0e03 |
90 | # Above not with just 'pure' built-in attributes. |
91 | sub Z::MODIFY_CODE_ATTRIBUTES { (); } |
92 | eval 'package Z; sub L { $_[0] } sub L : Z lvalue'; |
93 | @attrs = eval 'attributes::get \&Z::L'; |
1ce0b88c |
94 | is "@attrs", "lvalue Z"; |
020f0e03 |
95 | |
95f0a2f1 |
96 | # Begin testing attributes that tie |
97 | |
98 | { |
99 | package Ttie; |
100 | sub DESTROY {} |
101 | sub TIESCALAR { my $x = $_[1]; bless \$x, $_[0]; } |
102 | sub FETCH { ${$_[0]} } |
103 | sub STORE { |
1ce0b88c |
104 | ::pass; |
95f0a2f1 |
105 | ${$_[0]} = $_[1]*2; |
106 | } |
107 | package Tloop; |
108 | sub MODIFY_SCALAR_ATTRIBUTES { tie ${$_[1]}, 'Ttie', -1; (); } |
109 | } |
110 | |
1ce0b88c |
111 | eval_ok ' |
95f0a2f1 |
112 | package Tloop; |
113 | for my $i (0..2) { |
114 | my $x : TieLoop = $i; |
1ce0b88c |
115 | $x != $i*2 and ::is $x, $i*2; |
95f0a2f1 |
116 | } |
117 | '; |
09bef843 |
118 | |
1ce0b88c |
119 | # bug #15898 |
120 | eval 'our ${""} : foo = 1'; |
121 | like $@, qr/Can't declare scalar dereference in our/; |
122 | eval 'my $$foo : bar = 1'; |
123 | like $@, qr/Can't declare scalar dereference in my/; |