Commit | Line | Data |
---|---|---|
9c6390c7 | 1 | #!./perl |
09bef843 SB |
2 | |
3 | # Regression tests for attributes.pm and the C< : attrs> syntax. | |
4 | ||
9c6390c7 RGS |
5 | use warnings; |
6 | ||
09bef843 SB |
7 | BEGIN { |
8 | chdir 't' if -d 't'; | |
20822f61 | 9 | @INC = '../lib'; |
1ce0b88c | 10 | require './test.pl'; |
09bef843 SB |
11 | } |
12 | ||
77c9267e | 13 | plan 'no_plan'; |
09bef843 SB |
14 | |
15 | $SIG{__WARN__} = sub { die @_ }; | |
16 | ||
42262798 NC |
17 | sub eval_ok ($;$) { |
18 | eval shift; | |
19 | is( $@, '', @_); | |
09bef843 SB |
20 | } |
21 | ||
1ce0b88c RGS |
22 | eval_ok 'sub t1 ($) : locked { $_[0]++ }'; |
23 | eval_ok 'sub t2 : locked { $_[0]++ }'; | |
24 | eval_ok 'sub t3 ($) : locked ;'; | |
25 | eval_ok 'sub t4 : locked ;'; | |
26 | our $anon1; eval_ok '$anon1 = sub ($) : locked:method { $_[0]++ }'; | |
27 | our $anon2; eval_ok '$anon2 = sub : locked : method { $_[0]++ }'; | |
28 | our $anon3; eval_ok '$anon3 = sub : method { $_[0]->[1] }'; | |
09bef843 SB |
29 | |
30 | eval 'sub e1 ($) : plugh ;'; | |
1ce0b88c | 31 | like $@, qr/^Invalid CODE attributes?: ["']?plugh["']? at/; |
09bef843 SB |
32 | |
33 | eval 'sub e2 ($) : plugh(0,0) xyzzy ;'; | |
1ce0b88c | 34 | like $@, qr/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /; |
09bef843 SB |
35 | |
36 | eval 'sub e3 ($) : plugh(0,0 xyzzy ;'; | |
1ce0b88c | 37 | like $@, qr/Unterminated attribute parameter in attribute list at/; |
09bef843 SB |
38 | |
39 | eval 'sub e4 ($) : plugh + xyzzy ;'; | |
1ce0b88c RGS |
40 | like $@, qr/Invalid separator character '[+]' in attribute list at/; |
41 | ||
42 | eval_ok 'my main $x : = 0;'; | |
43 | eval_ok 'my $x : = 0;'; | |
44 | eval_ok 'my $x ;'; | |
45 | eval_ok 'my ($x) : = 0;'; | |
46 | eval_ok 'my ($x) ;'; | |
47 | eval_ok 'my ($x) : ;'; | |
48 | eval_ok 'my ($x,$y) : = 0;'; | |
49 | eval_ok 'my ($x,$y) ;'; | |
50 | eval_ok 'my ($x,$y) : ;'; | |
09bef843 SB |
51 | |
52 | eval 'my ($x,$y) : plugh;'; | |
1ce0b88c | 53 | like $@, qr/^Invalid SCALAR attribute: ["']?plugh["']? at/; |
09bef843 | 54 | |
8e7ae056 RGS |
55 | # bug #16080 |
56 | eval '{my $x : plugh}'; | |
57 | like $@, qr/^Invalid SCALAR attribute: ["']?plugh["']? at/; | |
58 | eval '{my ($x,$y) : plugh(})}'; | |
59 | like $@, qr/^Invalid SCALAR attribute: ["']?plugh\(}\)["']? at/; | |
60 | ||
c9124e92 RGS |
61 | # More syntax tests from the attributes manpage |
62 | eval 'my $x : switch(10,foo(7,3)) : expensive;'; | |
63 | like $@, qr/^Invalid SCALAR attributes: ["']?switch\(10,foo\(7,3\)\) : expensive["']? at/; | |
64 | eval q/my $x : Ugly('\(") :Bad;/; | |
65 | like $@, qr/^Invalid SCALAR attributes: ["']?Ugly\('\\\("\) : Bad["']? at/; | |
66 | eval 'my $x : _5x5;'; | |
67 | like $@, qr/^Invalid SCALAR attribute: ["']?_5x5["']? at/; | |
68 | eval 'my $x : locked method;'; | |
69 | like $@, qr/^Invalid SCALAR attributes: ["']?locked : method["']? at/; | |
70 | eval 'my $x : switch(10,foo();'; | |
71 | like $@, qr/^Unterminated attribute parameter in attribute list at/; | |
72 | eval q/my $x : Ugly('(');/; | |
73 | like $@, qr/^Unterminated attribute parameter in attribute list at/; | |
74 | eval 'my $x : 5x5;'; | |
75 | like $@, qr/error/; | |
76 | eval 'my $x : Y2::north;'; | |
77 | like $@, qr/Invalid separator character ':' in attribute list at/; | |
78 | ||
09bef843 SB |
79 | sub A::MODIFY_SCALAR_ATTRIBUTES { return } |
80 | eval 'my A $x : plugh;'; | |
1ce0b88c | 81 | like $@, qr/^SCALAR package attribute may clash with future reserved word: ["']?plugh["']? at/; |
09bef843 SB |
82 | |
83 | eval 'my A $x : plugh plover;'; | |
1ce0b88c | 84 | like $@, qr/^SCALAR package attributes may clash with future reserved words: ["']?plugh["']? /; |
09bef843 | 85 | |
9c6390c7 RGS |
86 | no warnings 'reserved'; |
87 | eval 'my A $x : plugh;'; | |
88 | is $@, ''; | |
89 | ||
3f8f4626 | 90 | eval 'package Cat; my Cat @socks;'; |
1ce0b88c | 91 | like $@, qr/^Can't declare class for non-scalar \@socks in "my"/; |
3f8f4626 | 92 | |
09bef843 SB |
93 | sub X::MODIFY_CODE_ATTRIBUTES { die "$_[0]" } |
94 | sub X::foo { 1 } | |
95 | *Y::bar = \&X::foo; | |
96 | *Y::bar = \&X::foo; # second time for -w | |
0256094b | 97 | eval 'package Z; sub Y::bar : foo'; |
1ce0b88c | 98 | like $@, qr/^X at /; |
09bef843 | 99 | |
0256094b DM |
100 | eval 'package Z; sub Y::baz : locked {}'; |
101 | my @attrs = eval 'attributes::get \&Y::baz'; | |
1ce0b88c | 102 | is "@attrs", "locked"; |
09bef843 SB |
103 | |
104 | @attrs = eval 'attributes::get $anon1'; | |
1ce0b88c | 105 | is "@attrs", "locked method"; |
09bef843 SB |
106 | |
107 | sub Z::DESTROY { } | |
108 | sub Z::FETCH_CODE_ATTRIBUTES { return 'Z' } | |
109 | my $thunk = eval 'bless +sub : method locked { 1 }, "Z"'; | |
1ce0b88c | 110 | is ref($thunk), "Z"; |
09bef843 SB |
111 | |
112 | @attrs = eval 'attributes::get $thunk'; | |
1ce0b88c | 113 | is "@attrs", "locked method Z"; |
09bef843 | 114 | |
61dbb99a SF |
115 | # Test attributes on predeclared subroutines: |
116 | eval 'package A; sub PS : lvalue'; | |
117 | @attrs = eval 'attributes::get \&A::PS'; | |
118 | is "@attrs", "lvalue"; | |
119 | ||
d3cea301 SB |
120 | # Test ability to modify existing sub's (or XSUB's) attributes. |
121 | eval 'package A; sub X { $_[0] } sub X : lvalue'; | |
122 | @attrs = eval 'attributes::get \&A::X'; | |
1ce0b88c | 123 | is "@attrs", "lvalue"; |
d3cea301 | 124 | |
020f0e03 SB |
125 | # Above not with just 'pure' built-in attributes. |
126 | sub Z::MODIFY_CODE_ATTRIBUTES { (); } | |
127 | eval 'package Z; sub L { $_[0] } sub L : Z lvalue'; | |
128 | @attrs = eval 'attributes::get \&Z::L'; | |
1ce0b88c | 129 | is "@attrs", "lvalue 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 | ||
77c9267e NC |
161 | my @code = qw(lvalue locked method); |
162 | unshift @code, 'assertion' if $] >= 5.009; | |
42262798 NC |
163 | my @other = qw(shared unique); |
164 | my %valid; | |
165 | $valid{CODE} = {map {$_ => 1} @code}; | |
166 | $valid{SCALAR} = {map {$_ => 1} @other}; | |
167 | $valid{ARRAY} = $valid{HASH} = $valid{SCALAR}; | |
168 | ||
adb2fcba | 169 | our ($scalar, @array, %hash); |
42262798 NC |
170 | foreach my $value (\&foo, \$scalar, \@array, \%hash) { |
171 | my $type = ref $value; | |
172 | foreach my $negate ('', '-') { | |
173 | foreach my $attr (@code, @other) { | |
174 | my $attribute = $negate . $attr; | |
175 | eval "use attributes __PACKAGE__, \$value, '$attribute'"; | |
176 | if ($valid{$type}{$attr}) { | |
177 | if ($attribute eq '-shared') { | |
178 | like $@, qr/^A variable may not be unshared/; | |
179 | } else { | |
180 | is( $@, '', "$type attribute $attribute"); | |
181 | } | |
182 | } else { | |
183 | like $@, qr/^Invalid $type attribute: $attribute/, | |
184 | "Bogus $type attribute $attribute should fail"; | |
185 | } | |
186 | } | |
187 | } | |
188 | } |