Commit | Line | Data |
---|---|---|
9c6390c7 | 1 | #!./perl |
09bef843 SB |
2 | |
3 | # Regression tests for attributes.pm and the C< : attrs> syntax. | |
4 | ||
5 | BEGIN { | |
98d0ccc7 RGS |
6 | if ($ENV{PERL_CORE_MINITEST}) { |
7 | print "1..0 # skip: miniperl can't load attributes\n"; | |
8 | exit 0; | |
9 | } | |
09bef843 | 10 | chdir 't' if -d 't'; |
20822f61 | 11 | @INC = '../lib'; |
1ce0b88c | 12 | require './test.pl'; |
09bef843 SB |
13 | } |
14 | ||
98d0ccc7 RGS |
15 | use warnings; |
16 | ||
8314a0a6 | 17 | plan 91; |
09bef843 SB |
18 | |
19 | $SIG{__WARN__} = sub { die @_ }; | |
20 | ||
42262798 NC |
21 | sub eval_ok ($;$) { |
22 | eval shift; | |
23 | is( $@, '', @_); | |
09bef843 SB |
24 | } |
25 | ||
8e5dadda | 26 | our $anon1; eval_ok '$anon1 = sub : method { $_[0]++ }'; |
09bef843 SB |
27 | |
28 | eval 'sub e1 ($) : plugh ;'; | |
1ce0b88c | 29 | like $@, qr/^Invalid CODE attributes?: ["']?plugh["']? at/; |
09bef843 SB |
30 | |
31 | eval 'sub e2 ($) : plugh(0,0) xyzzy ;'; | |
1ce0b88c | 32 | like $@, qr/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /; |
09bef843 SB |
33 | |
34 | eval 'sub e3 ($) : plugh(0,0 xyzzy ;'; | |
1ce0b88c | 35 | like $@, qr/Unterminated attribute parameter in attribute list at/; |
09bef843 SB |
36 | |
37 | eval 'sub e4 ($) : plugh + xyzzy ;'; | |
1ce0b88c RGS |
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 SB |
49 | |
50 | eval 'my ($x,$y) : plugh;'; | |
1ce0b88c | 51 | like $@, qr/^Invalid SCALAR attribute: ["']?plugh["']? at/; |
09bef843 | 52 | |
8e7ae056 RGS |
53 | # bug #16080 |
54 | eval '{my $x : plugh}'; | |
55 | like $@, qr/^Invalid SCALAR attribute: ["']?plugh["']? at/; | |
56 | eval '{my ($x,$y) : plugh(})}'; | |
57 | like $@, qr/^Invalid SCALAR attribute: ["']?plugh\(}\)["']? at/; | |
58 | ||
c9124e92 RGS |
59 | # More syntax tests from the attributes manpage |
60 | eval 'my $x : switch(10,foo(7,3)) : expensive;'; | |
61 | like $@, qr/^Invalid SCALAR attributes: ["']?switch\(10,foo\(7,3\)\) : expensive["']? at/; | |
62 | eval q/my $x : Ugly('\(") :Bad;/; | |
63 | like $@, qr/^Invalid SCALAR attributes: ["']?Ugly\('\\\("\) : Bad["']? at/; | |
64 | eval 'my $x : _5x5;'; | |
65 | like $@, qr/^Invalid SCALAR attribute: ["']?_5x5["']? at/; | |
66 | eval 'my $x : locked method;'; | |
67 | like $@, qr/^Invalid SCALAR attributes: ["']?locked : method["']? at/; | |
68 | eval 'my $x : switch(10,foo();'; | |
69 | like $@, qr/^Unterminated attribute parameter in attribute list at/; | |
70 | eval q/my $x : Ugly('(');/; | |
71 | like $@, qr/^Unterminated attribute parameter in attribute list at/; | |
72 | eval 'my $x : 5x5;'; | |
73 | like $@, qr/error/; | |
74 | eval 'my $x : Y2::north;'; | |
75 | like $@, qr/Invalid separator character ':' in attribute list at/; | |
76 | ||
09bef843 SB |
77 | sub A::MODIFY_SCALAR_ATTRIBUTES { return } |
78 | eval 'my A $x : plugh;'; | |
1ce0b88c | 79 | like $@, qr/^SCALAR package attribute may clash with future reserved word: ["']?plugh["']? at/; |
09bef843 SB |
80 | |
81 | eval 'my A $x : plugh plover;'; | |
1ce0b88c | 82 | like $@, qr/^SCALAR package attributes may clash with future reserved words: ["']?plugh["']? /; |
09bef843 | 83 | |
9c6390c7 RGS |
84 | no warnings 'reserved'; |
85 | eval 'my A $x : plugh;'; | |
86 | is $@, ''; | |
87 | ||
3f8f4626 | 88 | eval 'package Cat; my Cat @socks;'; |
d5e98372 VP |
89 | like $@, ''; |
90 | ||
91 | eval 'my Cat %nap;'; | |
92 | like $@, ''; | |
3f8f4626 | 93 | |
09bef843 SB |
94 | sub X::MODIFY_CODE_ATTRIBUTES { die "$_[0]" } |
95 | sub X::foo { 1 } | |
96 | *Y::bar = \&X::foo; | |
97 | *Y::bar = \&X::foo; # second time for -w | |
0256094b | 98 | eval 'package Z; sub Y::bar : foo'; |
1ce0b88c | 99 | like $@, qr/^X at /; |
09bef843 | 100 | |
09bef843 | 101 | @attrs = eval 'attributes::get $anon1'; |
8e5dadda | 102 | is "@attrs", "method"; |
09bef843 SB |
103 | |
104 | sub Z::DESTROY { } | |
105 | sub Z::FETCH_CODE_ATTRIBUTES { return 'Z' } | |
8e5dadda | 106 | my $thunk = eval 'bless +sub : method { 1 }, "Z"'; |
1ce0b88c | 107 | is ref($thunk), "Z"; |
09bef843 SB |
108 | |
109 | @attrs = eval 'attributes::get $thunk'; | |
8e5dadda | 110 | is "@attrs", "method Z"; |
09bef843 | 111 | |
61dbb99a SF |
112 | # Test attributes on predeclared subroutines: |
113 | eval 'package A; sub PS : lvalue'; | |
114 | @attrs = eval 'attributes::get \&A::PS'; | |
115 | is "@attrs", "lvalue"; | |
116 | ||
d3cea301 SB |
117 | # Test ability to modify existing sub's (or XSUB's) attributes. |
118 | eval 'package A; sub X { $_[0] } sub X : lvalue'; | |
119 | @attrs = eval 'attributes::get \&A::X'; | |
1ce0b88c | 120 | is "@attrs", "lvalue"; |
d3cea301 | 121 | |
020f0e03 SB |
122 | # Above not with just 'pure' built-in attributes. |
123 | sub Z::MODIFY_CODE_ATTRIBUTES { (); } | |
124 | eval 'package Z; sub L { $_[0] } sub L : Z lvalue'; | |
125 | @attrs = eval 'attributes::get \&Z::L'; | |
1ce0b88c | 126 | is "@attrs", "lvalue Z"; |
020f0e03 | 127 | |
95f0a2f1 SB |
128 | # Begin testing attributes that tie |
129 | ||
130 | { | |
131 | package Ttie; | |
132 | sub DESTROY {} | |
133 | sub TIESCALAR { my $x = $_[1]; bless \$x, $_[0]; } | |
134 | sub FETCH { ${$_[0]} } | |
135 | sub STORE { | |
1ce0b88c | 136 | ::pass; |
95f0a2f1 SB |
137 | ${$_[0]} = $_[1]*2; |
138 | } | |
139 | package Tloop; | |
140 | sub MODIFY_SCALAR_ATTRIBUTES { tie ${$_[1]}, 'Ttie', -1; (); } | |
141 | } | |
142 | ||
1ce0b88c | 143 | eval_ok ' |
95f0a2f1 SB |
144 | package Tloop; |
145 | for my $i (0..2) { | |
146 | my $x : TieLoop = $i; | |
1ce0b88c | 147 | $x != $i*2 and ::is $x, $i*2; |
95f0a2f1 SB |
148 | } |
149 | '; | |
09bef843 | 150 | |
1ce0b88c RGS |
151 | # bug #15898 |
152 | eval 'our ${""} : foo = 1'; | |
fab01b8e | 153 | like $@, qr/Can't declare scalar dereference in "our"/; |
1ce0b88c | 154 | eval 'my $$foo : bar = 1'; |
fab01b8e | 155 | like $@, qr/Can't declare scalar dereference in "my"/; |
42262798 NC |
156 | |
157 | ||
c32124fe | 158 | my @code = qw(lvalue method); |
f1a3ce43 NC |
159 | my @other = qw(shared); |
160 | my @deprecated = qw(locked unique); | |
42262798 NC |
161 | my %valid; |
162 | $valid{CODE} = {map {$_ => 1} @code}; | |
163 | $valid{SCALAR} = {map {$_ => 1} @other}; | |
164 | $valid{ARRAY} = $valid{HASH} = $valid{SCALAR}; | |
c32124fe NC |
165 | my %deprecated; |
166 | $deprecated{CODE} = { locked => 1 }; | |
f1a3ce43 | 167 | $deprecated{ARRAY} = $deprecated{HASH} = $deprecated{SCALAR} = { unique => 1 }; |
42262798 | 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 ('', '-') { | |
c32124fe | 173 | foreach my $attr (@code, @other, @deprecated) { |
42262798 NC |
174 | my $attribute = $negate . $attr; |
175 | eval "use attributes __PACKAGE__, \$value, '$attribute'"; | |
c32124fe NC |
176 | if ($deprecated{$type}{$attr}) { |
177 | like $@, qr/^Attribute "$attr" is deprecated at \(eval \d+\)/, | |
178 | "$type attribute $attribute deprecated"; | |
179 | } elsif ($valid{$type}{$attr}) { | |
42262798 NC |
180 | if ($attribute eq '-shared') { |
181 | like $@, qr/^A variable may not be unshared/; | |
182 | } else { | |
183 | is( $@, '', "$type attribute $attribute"); | |
184 | } | |
185 | } else { | |
186 | like $@, qr/^Invalid $type attribute: $attribute/, | |
187 | "Bogus $type attribute $attribute should fail"; | |
188 | } | |
189 | } | |
190 | } | |
191 | } | |
6e592b3a BM |
192 | |
193 | # this will segfault if it fails | |
194 | sub PVBM () { 'foo' } | |
195 | { my $dummy = index 'foo', PVBM } | |
196 | ||
197 | ok !defined(attributes::get(\PVBM)), | |
198 | 'PVBMs don\'t segfault attributes::get'; | |
09330df8 | 199 | |
8314a0a6 NC |
200 | { |
201 | # [perl #49472] Attributes + Unkown Error | |
202 | eval ' | |
203 | use strict; | |
204 | sub MODIFY_CODE_ATTRIBUTE{} | |
205 | sub f:Blah {$nosuchvar}; | |
206 | '; | |
207 | ||
208 | my $err = $@; | |
209 | like ($err, qr/Global symbol "\$nosuchvar" requires /, 'perl #49472'); | |
210 | } | |
211 | ||
09330df8 Z |
212 | # Test that code attributes always get applied to the same CV that |
213 | # we're left with at the end (bug#66970). | |
214 | { | |
215 | package bug66970; | |
216 | our $c; | |
217 | sub MODIFY_CODE_ATTRIBUTES { $c = $_[1]; () } | |
218 | $c=undef; eval 'sub t0 :Foo'; | |
219 | main::ok $c == \&{"t0"}; | |
220 | $c=undef; eval 'sub t1 :Foo { }'; | |
221 | main::ok $c == \&{"t1"}; | |
222 | $c=undef; eval 'sub t2'; | |
223 | our $t2a = \&{"t2"}; | |
224 | $c=undef; eval 'sub t2 :Foo'; | |
225 | main::ok $c == \&{"t2"} && $c == $t2a; | |
226 | $c=undef; eval 'sub t3'; | |
227 | our $t3a = \&{"t3"}; | |
228 | $c=undef; eval 'sub t3 :Foo { }'; | |
229 | main::ok $c == \&{"t3"} && $c == $t3a; | |
230 | $c=undef; eval 'sub t4 :Foo'; | |
231 | our $t4a = \&{"t4"}; | |
232 | our $t4b = $c; | |
233 | $c=undef; eval 'sub t4 :Foo'; | |
234 | main::ok $c == \&{"t4"} && $c == $t4b && $c == $t4a; | |
235 | $c=undef; eval 'sub t5 :Foo'; | |
236 | our $t5a = \&{"t5"}; | |
237 | our $t5b = $c; | |
238 | $c=undef; eval 'sub t5 :Foo { }'; | |
239 | main::ok $c == \&{"t5"} && $c == $t5b && $c == $t5a; | |
240 | } |