This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: perl 5.7.3 + XS lvalue subs
[perl5.git] / t / op / attrs.t
CommitLineData
09bef843
SB
1#!./perl -w
2
3# Regression tests for attributes.pm and the C< : attrs> syntax.
4
5BEGIN {
6 chdir 't' if -d 't';
20822f61 7 @INC = '../lib';
09bef843
SB
8}
9
10sub NTESTS () ;
11
12my ($test, $ntests);
13BEGIN {$ntests=0}
14$test=0;
15my $failed = 0;
16
17print "1..".NTESTS."\n";
18
19$SIG{__WARN__} = sub { die @_ };
20
21sub mytest {
95f0a2f1 22 my $bad = '';
09bef843
SB
23 if (!$@ ne !$_[0] || $_[0] && $@ !~ $_[0]) {
24 if ($@) {
25 my $x = $@;
26 $x =~ s/\n.*\z//s;
27 print "# Got: $x\n"
28 }
29 else {
30 print "# Got unexpected success\n";
31 }
32 if ($_[0]) {
33 print "# Expected: $_[0]\n";
34 }
35 else {
36 print "# Expected success\n";
37 }
38 $failed = 1;
95f0a2f1 39 $bad = 'not ';
09bef843
SB
40 }
41 elsif (@_ == 3 && $_[1] ne $_[2]) {
42 print "# Got: $_[1]\n";
43 print "# Expected: $_[2]\n";
44 $failed = 1;
95f0a2f1 45 $bad = 'not ';
09bef843 46 }
95f0a2f1 47 print $bad."ok ".++$test."\n";
09bef843
SB
48}
49
50eval 'sub t1 ($) : locked { $_[0]++ }';
51mytest;
52BEGIN {++$ntests}
53
54eval 'sub t2 : locked { $_[0]++ }';
55mytest;
56BEGIN {++$ntests}
57
58eval 'sub t3 ($) : locked ;';
59mytest;
60BEGIN {++$ntests}
61
62eval 'sub t4 : locked ;';
63mytest;
64BEGIN {++$ntests}
65
66my $anon1;
0120eecf 67eval '$anon1 = sub ($) : locked:method { $_[0]++ }';
09bef843
SB
68mytest;
69BEGIN {++$ntests}
70
71my $anon2;
0120eecf 72eval '$anon2 = sub : locked : method { $_[0]++ }';
09bef843
SB
73mytest;
74BEGIN {++$ntests}
75
76my $anon3;
77eval '$anon3 = sub : method { $_[0]->[1] }';
78mytest;
79BEGIN {++$ntests}
80
81eval 'sub e1 ($) : plugh ;';
82mytest qr/^Invalid CODE attributes?: ["']?plugh["']? at/;
83BEGIN {++$ntests}
84
85eval 'sub e2 ($) : plugh(0,0) xyzzy ;';
86mytest qr/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /;
87BEGIN {++$ntests}
88
89eval 'sub e3 ($) : plugh(0,0 xyzzy ;';
90mytest qr/Unterminated attribute parameter in attribute list at/;
91BEGIN {++$ntests}
92
93eval 'sub e4 ($) : plugh + xyzzy ;';
94mytest qr/Invalid separator character '[+]' in attribute list at/;
95BEGIN {++$ntests}
96
97eval 'my main $x : = 0;';
98mytest;
99BEGIN {++$ntests}
100
101eval 'my $x : = 0;';
102mytest;
103BEGIN {++$ntests}
104
105eval 'my $x ;';
106mytest;
107BEGIN {++$ntests}
108
109eval 'my ($x) : = 0;';
110mytest;
111BEGIN {++$ntests}
112
113eval 'my ($x) ;';
114mytest;
115BEGIN {++$ntests}
116
117eval 'my ($x) : ;';
118mytest;
119BEGIN {++$ntests}
120
121eval 'my ($x,$y) : = 0;';
122mytest;
123BEGIN {++$ntests}
124
125eval 'my ($x,$y) ;';
126mytest;
127BEGIN {++$ntests}
128
129eval 'my ($x,$y) : ;';
130mytest;
131BEGIN {++$ntests}
132
133eval 'my ($x,$y) : plugh;';
134mytest qr/^Invalid SCALAR attribute: ["']?plugh["']? at/;
135BEGIN {++$ntests}
136
137sub A::MODIFY_SCALAR_ATTRIBUTES { return }
138eval 'my A $x : plugh;';
139mytest qr/^SCALAR package attribute may clash with future reserved word: ["']?plugh["']? at/;
140BEGIN {++$ntests}
141
142eval 'my A $x : plugh plover;';
143mytest qr/^SCALAR package attributes may clash with future reserved words: ["']?plugh["']? /;
144BEGIN {++$ntests}
145
3f8f4626
DC
146eval 'package Cat; my Cat @socks;';
147mytest qr/^Can't declare class for non-scalar \@socks in "my"/;
148BEGIN {++$ntests}
149
09bef843
SB
150sub X::MODIFY_CODE_ATTRIBUTES { die "$_[0]" }
151sub X::foo { 1 }
152*Y::bar = \&X::foo;
153*Y::bar = \&X::foo; # second time for -w
0256094b 154eval 'package Z; sub Y::bar : foo';
09bef843
SB
155mytest qr/^X at /;
156BEGIN {++$ntests}
157
0256094b
DM
158eval 'package Z; sub Y::baz : locked {}';
159my @attrs = eval 'attributes::get \&Y::baz';
09bef843
SB
160mytest '', "@attrs", "locked";
161BEGIN {++$ntests}
162
163@attrs = eval 'attributes::get $anon1';
164mytest '', "@attrs", "locked method";
165BEGIN {++$ntests}
166
167sub Z::DESTROY { }
168sub Z::FETCH_CODE_ATTRIBUTES { return 'Z' }
169my $thunk = eval 'bless +sub : method locked { 1 }, "Z"';
170mytest '', ref($thunk), "Z";
171BEGIN {++$ntests}
172
173@attrs = eval 'attributes::get $thunk';
174mytest '', "@attrs", "locked method Z";
175BEGIN {++$ntests}
176
d3cea301
SB
177# Test ability to modify existing sub's (or XSUB's) attributes.
178eval 'package A; sub X { $_[0] } sub X : lvalue';
179@attrs = eval 'attributes::get \&A::X';
180mytest '', "@attrs", "lvalue";
181BEGIN {++$ntests}
182
95f0a2f1
SB
183# Begin testing attributes that tie
184
185{
186 package Ttie;
187 sub DESTROY {}
188 sub TIESCALAR { my $x = $_[1]; bless \$x, $_[0]; }
189 sub FETCH { ${$_[0]} }
190 sub STORE {
191 #print "# In Ttie::STORE\n";
192 ::mytest '';
193 ${$_[0]} = $_[1]*2;
194 }
195 package Tloop;
196 sub MODIFY_SCALAR_ATTRIBUTES { tie ${$_[1]}, 'Ttie', -1; (); }
197}
198
199eval '
200 package Tloop;
201 for my $i (0..2) {
202 my $x : TieLoop = $i;
203 $x != $i*2 and ::mytest "", $x, $i*2;
204 }
205';
206mytest;
207BEGIN {$ntests += 4}
09bef843
SB
208
209# Other tests should be added above this line
210
211sub NTESTS () { $ntests }
212
213exit $failed;