Commit | Line | Data |
9c6390c7 |
1 | #!./perl |
09bef843 |
2 | |
3 | # Regression tests for attributes.pm and the C< : attrs> syntax. |
4 | |
9c6390c7 |
5 | use warnings; |
6 | |
09bef843 |
7 | BEGIN { |
8 | chdir 't' if -d 't'; |
20822f61 |
9 | @INC = '../lib'; |
1ce0b88c |
10 | require './test.pl'; |
09bef843 |
11 | } |
12 | |
d5e98372 |
13 | plan 84; |
09bef843 |
14 | |
15 | $SIG{__WARN__} = sub { die @_ }; |
16 | |
42262798 |
17 | sub eval_ok ($;$) { |
18 | eval shift; |
19 | is( $@, '', @_); |
09bef843 |
20 | } |
21 | |
8e5dadda |
22 | our $anon1; eval_ok '$anon1 = sub : method { $_[0]++ }'; |
09bef843 |
23 | |
24 | eval 'sub e1 ($) : plugh ;'; |
1ce0b88c |
25 | like $@, qr/^Invalid CODE attributes?: ["']?plugh["']? at/; |
09bef843 |
26 | |
27 | eval 'sub e2 ($) : plugh(0,0) xyzzy ;'; |
1ce0b88c |
28 | like $@, qr/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /; |
09bef843 |
29 | |
30 | eval 'sub e3 ($) : plugh(0,0 xyzzy ;'; |
1ce0b88c |
31 | like $@, qr/Unterminated attribute parameter in attribute list at/; |
09bef843 |
32 | |
33 | eval 'sub e4 ($) : plugh + xyzzy ;'; |
1ce0b88c |
34 | like $@, qr/Invalid separator character '[+]' in attribute list at/; |
35 | |
36 | eval_ok 'my main $x : = 0;'; |
37 | eval_ok 'my $x : = 0;'; |
38 | eval_ok 'my $x ;'; |
39 | eval_ok 'my ($x) : = 0;'; |
40 | eval_ok 'my ($x) ;'; |
41 | eval_ok 'my ($x) : ;'; |
42 | eval_ok 'my ($x,$y) : = 0;'; |
43 | eval_ok 'my ($x,$y) ;'; |
44 | eval_ok 'my ($x,$y) : ;'; |
09bef843 |
45 | |
46 | eval 'my ($x,$y) : plugh;'; |
1ce0b88c |
47 | like $@, qr/^Invalid SCALAR attribute: ["']?plugh["']? at/; |
09bef843 |
48 | |
8e7ae056 |
49 | # bug #16080 |
50 | eval '{my $x : plugh}'; |
51 | like $@, qr/^Invalid SCALAR attribute: ["']?plugh["']? at/; |
52 | eval '{my ($x,$y) : plugh(})}'; |
53 | like $@, qr/^Invalid SCALAR attribute: ["']?plugh\(}\)["']? at/; |
54 | |
c9124e92 |
55 | # More syntax tests from the attributes manpage |
56 | eval 'my $x : switch(10,foo(7,3)) : expensive;'; |
57 | like $@, qr/^Invalid SCALAR attributes: ["']?switch\(10,foo\(7,3\)\) : expensive["']? at/; |
58 | eval q/my $x : Ugly('\(") :Bad;/; |
59 | like $@, qr/^Invalid SCALAR attributes: ["']?Ugly\('\\\("\) : Bad["']? at/; |
60 | eval 'my $x : _5x5;'; |
61 | like $@, qr/^Invalid SCALAR attribute: ["']?_5x5["']? at/; |
62 | eval 'my $x : locked method;'; |
63 | like $@, qr/^Invalid SCALAR attributes: ["']?locked : method["']? at/; |
64 | eval 'my $x : switch(10,foo();'; |
65 | like $@, qr/^Unterminated attribute parameter in attribute list at/; |
66 | eval q/my $x : Ugly('(');/; |
67 | like $@, qr/^Unterminated attribute parameter in attribute list at/; |
68 | eval 'my $x : 5x5;'; |
69 | like $@, qr/error/; |
70 | eval 'my $x : Y2::north;'; |
71 | like $@, qr/Invalid separator character ':' in attribute list at/; |
72 | |
09bef843 |
73 | sub A::MODIFY_SCALAR_ATTRIBUTES { return } |
74 | eval 'my A $x : plugh;'; |
1ce0b88c |
75 | like $@, qr/^SCALAR package attribute may clash with future reserved word: ["']?plugh["']? at/; |
09bef843 |
76 | |
77 | eval 'my A $x : plugh plover;'; |
1ce0b88c |
78 | like $@, qr/^SCALAR package attributes may clash with future reserved words: ["']?plugh["']? /; |
09bef843 |
79 | |
9c6390c7 |
80 | no warnings 'reserved'; |
81 | eval 'my A $x : plugh;'; |
82 | is $@, ''; |
83 | |
3f8f4626 |
84 | eval 'package Cat; my Cat @socks;'; |
d5e98372 |
85 | like $@, ''; |
86 | |
87 | eval 'my Cat %nap;'; |
88 | like $@, ''; |
3f8f4626 |
89 | |
09bef843 |
90 | sub X::MODIFY_CODE_ATTRIBUTES { die "$_[0]" } |
91 | sub X::foo { 1 } |
92 | *Y::bar = \&X::foo; |
93 | *Y::bar = \&X::foo; # second time for -w |
0256094b |
94 | eval 'package Z; sub Y::bar : foo'; |
1ce0b88c |
95 | like $@, qr/^X at /; |
09bef843 |
96 | |
09bef843 |
97 | @attrs = eval 'attributes::get $anon1'; |
8e5dadda |
98 | is "@attrs", "method"; |
09bef843 |
99 | |
100 | sub Z::DESTROY { } |
101 | sub Z::FETCH_CODE_ATTRIBUTES { return 'Z' } |
8e5dadda |
102 | my $thunk = eval 'bless +sub : method { 1 }, "Z"'; |
1ce0b88c |
103 | is ref($thunk), "Z"; |
09bef843 |
104 | |
105 | @attrs = eval 'attributes::get $thunk'; |
8e5dadda |
106 | is "@attrs", "method Z"; |
09bef843 |
107 | |
61dbb99a |
108 | # Test attributes on predeclared subroutines: |
109 | eval 'package A; sub PS : lvalue'; |
110 | @attrs = eval 'attributes::get \&A::PS'; |
111 | is "@attrs", "lvalue"; |
112 | |
d3cea301 |
113 | # Test ability to modify existing sub's (or XSUB's) attributes. |
114 | eval 'package A; sub X { $_[0] } sub X : lvalue'; |
115 | @attrs = eval 'attributes::get \&A::X'; |
1ce0b88c |
116 | is "@attrs", "lvalue"; |
d3cea301 |
117 | |
020f0e03 |
118 | # Above not with just 'pure' built-in attributes. |
119 | sub Z::MODIFY_CODE_ATTRIBUTES { (); } |
120 | eval 'package Z; sub L { $_[0] } sub L : Z lvalue'; |
121 | @attrs = eval 'attributes::get \&Z::L'; |
1ce0b88c |
122 | is "@attrs", "lvalue Z"; |
020f0e03 |
123 | |
95f0a2f1 |
124 | # Begin testing attributes that tie |
125 | |
126 | { |
127 | package Ttie; |
128 | sub DESTROY {} |
129 | sub TIESCALAR { my $x = $_[1]; bless \$x, $_[0]; } |
130 | sub FETCH { ${$_[0]} } |
131 | sub STORE { |
1ce0b88c |
132 | ::pass; |
95f0a2f1 |
133 | ${$_[0]} = $_[1]*2; |
134 | } |
135 | package Tloop; |
136 | sub MODIFY_SCALAR_ATTRIBUTES { tie ${$_[1]}, 'Ttie', -1; (); } |
137 | } |
138 | |
1ce0b88c |
139 | eval_ok ' |
95f0a2f1 |
140 | package Tloop; |
141 | for my $i (0..2) { |
142 | my $x : TieLoop = $i; |
1ce0b88c |
143 | $x != $i*2 and ::is $x, $i*2; |
95f0a2f1 |
144 | } |
145 | '; |
09bef843 |
146 | |
1ce0b88c |
147 | # bug #15898 |
148 | eval 'our ${""} : foo = 1'; |
fab01b8e |
149 | like $@, qr/Can't declare scalar dereference in "our"/; |
1ce0b88c |
150 | eval 'my $$foo : bar = 1'; |
fab01b8e |
151 | like $@, qr/Can't declare scalar dereference in "my"/; |
42262798 |
152 | |
153 | |
c32124fe |
154 | my @code = qw(lvalue method); |
f1a3ce43 |
155 | my @other = qw(shared); |
156 | my @deprecated = qw(locked unique); |
42262798 |
157 | my %valid; |
158 | $valid{CODE} = {map {$_ => 1} @code}; |
159 | $valid{SCALAR} = {map {$_ => 1} @other}; |
160 | $valid{ARRAY} = $valid{HASH} = $valid{SCALAR}; |
c32124fe |
161 | my %deprecated; |
162 | $deprecated{CODE} = { locked => 1 }; |
f1a3ce43 |
163 | $deprecated{ARRAY} = $deprecated{HASH} = $deprecated{SCALAR} = { unique => 1 }; |
42262798 |
164 | |
adb2fcba |
165 | our ($scalar, @array, %hash); |
42262798 |
166 | foreach my $value (\&foo, \$scalar, \@array, \%hash) { |
167 | my $type = ref $value; |
168 | foreach my $negate ('', '-') { |
c32124fe |
169 | foreach my $attr (@code, @other, @deprecated) { |
42262798 |
170 | my $attribute = $negate . $attr; |
171 | eval "use attributes __PACKAGE__, \$value, '$attribute'"; |
c32124fe |
172 | if ($deprecated{$type}{$attr}) { |
173 | like $@, qr/^Attribute "$attr" is deprecated at \(eval \d+\)/, |
174 | "$type attribute $attribute deprecated"; |
175 | } elsif ($valid{$type}{$attr}) { |
42262798 |
176 | if ($attribute eq '-shared') { |
177 | like $@, qr/^A variable may not be unshared/; |
178 | } else { |
179 | is( $@, '', "$type attribute $attribute"); |
180 | } |
181 | } else { |
182 | like $@, qr/^Invalid $type attribute: $attribute/, |
183 | "Bogus $type attribute $attribute should fail"; |
184 | } |
185 | } |
186 | } |
187 | } |
6e592b3a |
188 | |
189 | # this will segfault if it fails |
190 | sub PVBM () { 'foo' } |
191 | { my $dummy = index 'foo', PVBM } |
192 | |
193 | ok !defined(attributes::get(\PVBM)), |
194 | 'PVBMs don\'t segfault attributes::get'; |