Commit | Line | Data |
---|---|---|
09bef843 SB |
1 | #!./perl -w |
2 | ||
3 | # Regression tests for attributes.pm and the C< : attrs> syntax. | |
4 | ||
5 | BEGIN { | |
6 | chdir 't' if -d 't'; | |
20822f61 | 7 | @INC = '../lib'; |
09bef843 SB |
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 | if (!$@ ne !$_[0] || $_[0] && $@ !~ $_[0]) { | |
23 | if ($@) { | |
24 | my $x = $@; | |
25 | $x =~ s/\n.*\z//s; | |
26 | print "# Got: $x\n" | |
27 | } | |
28 | else { | |
29 | print "# Got unexpected success\n"; | |
30 | } | |
31 | if ($_[0]) { | |
32 | print "# Expected: $_[0]\n"; | |
33 | } | |
34 | else { | |
35 | print "# Expected success\n"; | |
36 | } | |
37 | $failed = 1; | |
38 | print "not "; | |
39 | } | |
40 | elsif (@_ == 3 && $_[1] ne $_[2]) { | |
41 | print "# Got: $_[1]\n"; | |
42 | print "# Expected: $_[2]\n"; | |
43 | $failed = 1; | |
44 | print "not "; | |
45 | } | |
46 | print "ok ",++$test,"\n"; | |
47 | } | |
48 | ||
49 | eval 'sub t1 ($) : locked { $_[0]++ }'; | |
50 | mytest; | |
51 | BEGIN {++$ntests} | |
52 | ||
53 | eval 'sub t2 : locked { $_[0]++ }'; | |
54 | mytest; | |
55 | BEGIN {++$ntests} | |
56 | ||
57 | eval 'sub t3 ($) : locked ;'; | |
58 | mytest; | |
59 | BEGIN {++$ntests} | |
60 | ||
61 | eval 'sub t4 : locked ;'; | |
62 | mytest; | |
63 | BEGIN {++$ntests} | |
64 | ||
65 | my $anon1; | |
0120eecf | 66 | eval '$anon1 = sub ($) : locked:method { $_[0]++ }'; |
09bef843 SB |
67 | mytest; |
68 | BEGIN {++$ntests} | |
69 | ||
70 | my $anon2; | |
0120eecf | 71 | eval '$anon2 = sub : locked : method { $_[0]++ }'; |
09bef843 SB |
72 | mytest; |
73 | BEGIN {++$ntests} | |
74 | ||
75 | my $anon3; | |
76 | eval '$anon3 = sub : method { $_[0]->[1] }'; | |
77 | mytest; | |
78 | BEGIN {++$ntests} | |
79 | ||
80 | eval 'sub e1 ($) : plugh ;'; | |
81 | mytest qr/^Invalid CODE attributes?: ["']?plugh["']? at/; | |
82 | BEGIN {++$ntests} | |
83 | ||
84 | eval 'sub e2 ($) : plugh(0,0) xyzzy ;'; | |
85 | mytest qr/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /; | |
86 | BEGIN {++$ntests} | |
87 | ||
88 | eval 'sub e3 ($) : plugh(0,0 xyzzy ;'; | |
89 | mytest qr/Unterminated attribute parameter in attribute list at/; | |
90 | BEGIN {++$ntests} | |
91 | ||
92 | eval 'sub e4 ($) : plugh + xyzzy ;'; | |
93 | mytest qr/Invalid separator character '[+]' in attribute list at/; | |
94 | BEGIN {++$ntests} | |
95 | ||
96 | eval 'my main $x : = 0;'; | |
97 | mytest; | |
98 | BEGIN {++$ntests} | |
99 | ||
100 | eval 'my $x : = 0;'; | |
101 | mytest; | |
102 | BEGIN {++$ntests} | |
103 | ||
104 | eval 'my $x ;'; | |
105 | mytest; | |
106 | BEGIN {++$ntests} | |
107 | ||
108 | eval 'my ($x) : = 0;'; | |
109 | mytest; | |
110 | BEGIN {++$ntests} | |
111 | ||
112 | eval 'my ($x) ;'; | |
113 | mytest; | |
114 | BEGIN {++$ntests} | |
115 | ||
116 | eval 'my ($x) : ;'; | |
117 | mytest; | |
118 | BEGIN {++$ntests} | |
119 | ||
120 | eval 'my ($x,$y) : = 0;'; | |
121 | mytest; | |
122 | BEGIN {++$ntests} | |
123 | ||
124 | eval 'my ($x,$y) ;'; | |
125 | mytest; | |
126 | BEGIN {++$ntests} | |
127 | ||
128 | eval 'my ($x,$y) : ;'; | |
129 | mytest; | |
130 | BEGIN {++$ntests} | |
131 | ||
132 | eval 'my ($x,$y) : plugh;'; | |
133 | mytest qr/^Invalid SCALAR attribute: ["']?plugh["']? at/; | |
134 | BEGIN {++$ntests} | |
135 | ||
136 | sub A::MODIFY_SCALAR_ATTRIBUTES { return } | |
137 | eval 'my A $x : plugh;'; | |
138 | mytest qr/^SCALAR package attribute may clash with future reserved word: ["']?plugh["']? at/; | |
139 | BEGIN {++$ntests} | |
140 | ||
141 | eval 'my A $x : plugh plover;'; | |
142 | mytest qr/^SCALAR package attributes may clash with future reserved words: ["']?plugh["']? /; | |
143 | BEGIN {++$ntests} | |
144 | ||
3f8f4626 DC |
145 | eval 'package Cat; my Cat @socks;'; |
146 | mytest qr/^Can't declare class for non-scalar \@socks in "my"/; | |
147 | BEGIN {++$ntests} | |
148 | ||
09bef843 SB |
149 | sub X::MODIFY_CODE_ATTRIBUTES { die "$_[0]" } |
150 | sub X::foo { 1 } | |
151 | *Y::bar = \&X::foo; | |
152 | *Y::bar = \&X::foo; # second time for -w | |
0256094b | 153 | eval 'package Z; sub Y::bar : foo'; |
09bef843 SB |
154 | mytest qr/^X at /; |
155 | BEGIN {++$ntests} | |
156 | ||
0256094b DM |
157 | eval 'package Z; sub Y::baz : locked {}'; |
158 | my @attrs = eval 'attributes::get \&Y::baz'; | |
09bef843 SB |
159 | mytest '', "@attrs", "locked"; |
160 | BEGIN {++$ntests} | |
161 | ||
162 | @attrs = eval 'attributes::get $anon1'; | |
163 | mytest '', "@attrs", "locked method"; | |
164 | BEGIN {++$ntests} | |
165 | ||
166 | sub Z::DESTROY { } | |
167 | sub Z::FETCH_CODE_ATTRIBUTES { return 'Z' } | |
168 | my $thunk = eval 'bless +sub : method locked { 1 }, "Z"'; | |
169 | mytest '', ref($thunk), "Z"; | |
170 | BEGIN {++$ntests} | |
171 | ||
172 | @attrs = eval 'attributes::get $thunk'; | |
173 | mytest '', "@attrs", "locked method Z"; | |
174 | BEGIN {++$ntests} | |
175 | ||
176 | ||
177 | # Other tests should be added above this line | |
178 | ||
179 | sub NTESTS () { $ntests } | |
180 | ||
181 | exit $failed; |