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