Commit | Line | Data |
cab6c672 |
1 | #!perl |
2 | |
d5e98372 |
3 | # This test file contains 57 tests. |
4 | # You need to number them manually. Don't forget to update this line for the |
5 | # next kind hacker. |
6 | |
0e9b9e0c |
7 | END {print "not ok 1\n" unless $loaded;} |
8 | use v5.6.0; |
9 | use Attribute::Handlers; |
10 | $loaded = 1; |
11 | |
12 | CHECK { $main::phase++ } |
13 | |
14 | ######################### End of black magic. |
15 | |
16 | # Insert your test code below (better if it prints "ok 13" |
17 | # (correspondingly "not ok 13") depending on the success of chunk 13 |
18 | # of the test code): |
19 | |
d473d728 |
20 | sub ok { $::count++; push @::results, [$_[1], $_[0]?"":"not ", defined($_[2])?$_[2]:""]; } |
0e9b9e0c |
21 | |
22 | END { print "1..$::count\n"; |
d473d728 |
23 | print map "$_->[1]ok $_->[0] $_->[2]\n", |
0e9b9e0c |
24 | sort {$a->[0]<=>$b->[0]} |
25 | grep $_->[0], @::results } |
26 | |
27 | package Test; |
28 | use warnings; |
29 | no warnings 'redefine'; |
30 | |
31 | sub UNIVERSAL::Lastly :ATTR(INIT) { ::ok $_[4][0] && $main::phase, $_[4][1] } |
32 | |
33 | sub UNIVERSAL::Okay :ATTR(BEGIN) { |
34 | ::ok $_[4][0] && (!$main::phase || !ref $_[1] && $_[1] eq 'LEXICAL'), $_[4][1]; |
35 | } |
36 | |
37 | sub Dokay :ATTR(SCALAR) { ::ok @{$_[4]} } |
38 | sub Dokay :ATTR(HASH) { ::ok @{$_[4]} } |
39 | sub Dokay :ATTR(ARRAY) { ::ok @{$_[4]} } |
40 | sub Dokay :ATTR(CODE) { ::ok @{$_[4]} } |
41 | |
42 | sub Vokay :ATTR(VAR) { ::ok @{$_[4]} } |
43 | |
44 | sub Aokay :ATTR(ANY) { ::ok @{$_[4]} } |
45 | |
46 | package main; |
47 | use warnings; |
48 | |
49 | my $x1 :Lastly(1,41); |
50 | my @x1 :Lastly(1=>42); |
51 | my %x1 :Lastly(1,43); |
52 | sub x1 :Lastly(1,44) {} |
53 | |
54 | my Test $x2 :Dokay(1,5); |
55 | |
d5e98372 |
56 | if ($] < 5.011) { |
57 | ::ok(1, $_, '# skip : invalid before 5.11') for 55 .. 57; |
58 | } else { |
59 | my $c = $::count; |
60 | eval ' |
61 | my Test @x2 :Dokay(1,55); |
62 | my Test %x2 :Dokay(1,56); |
63 | '; |
64 | $c = $c + 2 - $::count; |
65 | while ($c > 0) { |
66 | ::ok(0, 57 - $c); |
67 | --$c; |
68 | } |
69 | ::ok(!$@, 57); |
70 | } |
71 | |
0e9b9e0c |
72 | package Test; |
73 | my $x3 :Dokay(1,6); |
74 | my Test $x4 :Dokay(1,7); |
75 | sub x3 :Dokay(1,8) {} |
76 | |
77 | my $y1 :Okay(1,9); |
78 | my @y1 :Okay(1,10); |
79 | my %y1 :Okay(1,11); |
80 | sub y1 :Okay(1,12) {} |
81 | |
82 | my $y2 :Vokay(1,13); |
83 | my @y2 :Vokay(1,14); |
84 | my %y2 :Vokay(1,15); |
85 | # BEGIN {eval 'sub y2 :Vokay(0,16) {}; 1' or |
86 | ::ok(1,16); |
87 | # } |
88 | |
89 | my $z :Aokay(1,17); |
90 | my @z :Aokay(1,18); |
91 | my %z :Aokay(1,19); |
92 | sub z :Aokay(1,20) {}; |
93 | |
94 | package DerTest; |
95 | use base 'Test'; |
96 | use warnings; |
97 | |
98 | my $x5 :Dokay(1,21); |
99 | my Test $x6 :Dokay(1,22); |
100 | sub x5 :Dokay(1,23); |
101 | |
102 | my $y3 :Okay(1,24); |
103 | my @y3 :Okay(1,25); |
104 | my %y3 :Okay(1,26); |
105 | sub y3 :Okay(1,27) {} |
106 | |
107 | package Unrelated; |
108 | |
109 | my $x11 :Okay(1,1); |
110 | my @x11 :Okay(1=>2); |
111 | my %x11 :Okay(1,3); |
112 | sub x11 :Okay(1,4) {} |
113 | |
114 | BEGIN { eval 'my $x7 :Dokay(0,28)' or ::ok(1,28); } |
115 | my Test $x8 :Dokay(1,29); |
116 | eval 'sub x7 :Dokay(0,30) {}' or ::ok(1,30); |
117 | |
118 | |
119 | package Tie::Loud; |
120 | |
121 | sub TIESCALAR { ::ok(1,31); bless {}, $_[0] } |
122 | sub FETCH { ::ok(1,32); return 1 } |
123 | sub STORE { ::ok(1,33); return 1 } |
124 | |
125 | package Tie::Noisy; |
126 | |
127 | sub TIEARRAY { ::ok(1,$_[1]); bless {}, $_[0] } |
128 | sub FETCH { ::ok(1,35); return 1 } |
129 | sub STORE { ::ok(1,36); return 1 } |
130 | sub FETCHSIZE { 100 } |
131 | |
132 | package Tie::Row::dy; |
133 | |
134 | sub TIEHASH { ::ok(1,$_[1]); bless {}, $_[0] } |
135 | sub FETCH { ::ok(1,38); return 1 } |
136 | sub STORE { ::ok(1,39); return 1 } |
137 | |
138 | package main; |
139 | |
140 | eval 'sub x7 :ATTR(SCALAR) :ATTR(CODE) {}' and ::ok(0,40) or ::ok(1,40); |
141 | |
142 | use Attribute::Handlers autotie => { Other::Loud => Tie::Loud, |
143 | Noisy => Tie::Noisy, |
144 | UNIVERSAL::Rowdy => Tie::Row::dy, |
145 | }; |
146 | |
147 | my Other $loud : Loud; |
148 | $loud++; |
149 | |
150 | my @noisy : Noisy(34); |
151 | $noisy[0]++; |
152 | |
153 | my %rowdy : Rowdy(37,'this arg should be ignored'); |
154 | $rowdy{key}++; |
155 | |
18880e27 |
156 | |
157 | # check that applying attributes to lexicals doesn't unduly worry |
158 | # their refcounts |
159 | my $out = "begin\n"; |
160 | my $applied; |
161 | sub UNIVERSAL::Dummy :ATTR { ++$applied }; |
162 | sub Dummy::DESTROY { $out .= "bye\n" } |
163 | |
164 | { my $dummy; $dummy = bless {}, 'Dummy'; } |
165 | ok( $out eq "begin\nbye\n", 45 ); |
166 | |
167 | { my $dummy : Dummy; $dummy = bless {}, 'Dummy'; } |
d473d728 |
168 | if($] < 5.008) { |
169 | ok( 1, 46, " # skip lexicals are not runtime prior to 5.8"); |
170 | } else { |
171 | ok( $out eq "begin\nbye\nbye\n", 46); |
172 | } |
18880e27 |
173 | # are lexical attributes reapplied correctly? |
174 | sub dummy { my $dummy : Dummy; } |
175 | $applied = 0; |
176 | dummy(); dummy(); |
448fed50 |
177 | if($] < 5.008) { |
d473d728 |
178 | ok(1, 47, " # skip does not work with perl prior to 5.8"); |
448fed50 |
179 | } else { |
18880e27 |
180 | ok( $applied == 2, 47 ); |
448fed50 |
181 | } |
18880e27 |
182 | # 45-47 again, but for our variables |
183 | $out = "begin\n"; |
184 | { our $dummy; $dummy = bless {}, 'Dummy'; } |
185 | ok( $out eq "begin\n", 48 ); |
448fed50 |
186 | { no warnings; our $dummy : Dummy; $dummy = bless {}, 'Dummy'; } |
18880e27 |
187 | ok( $out eq "begin\nbye\n", 49 ); |
188 | undef $::dummy; |
189 | ok( $out eq "begin\nbye\nbye\n", 50 ); |
190 | |
191 | # are lexical attributes reapplied correctly? |
448fed50 |
192 | sub dummy_our { no warnings; our $banjo : Dummy; } |
18880e27 |
193 | $applied = 0; |
194 | dummy_our(); dummy_our(); |
195 | ok( $applied == 0, 51 ); |
24952a9c |
196 | |
197 | sub UNIVERSAL::Stooge :ATTR(END) {}; |
198 | eval { |
199 | local $SIG{__WARN__} = sub { die @_ }; |
200 | my $groucho : Stooge; |
201 | }; |
202 | my $match = $@ =~ /^Won't be able to apply END handler/; |
448fed50 |
203 | if($] < 5.008) { |
d473d728 |
204 | ok(1,52 ,"# Skip, no difference between lexical handlers and normal handlers prior to 5.8"); |
448fed50 |
205 | } else { |
24952a9c |
206 | ok( $match, 52 ); |
448fed50 |
207 | } |
208 | |
c760c918 |
209 | |
210 | # The next two check for the phase invariance that Marcel spotted. |
211 | # Subject: Attribute::Handlers phase variance |
212 | # Message-Id: <54EDDB80-FD75-11D6-A18D-00039379E28A@noug.at> |
213 | |
214 | my ($code_applied, $scalar_applied); |
215 | sub Scotty :ATTR(CODE,BEGIN) { $code_applied = $_[5] } |
216 | { |
217 | no warnings 'redefine'; |
218 | sub Scotty :ATTR(SCALAR,CHECK) { $scalar_applied = $_[5] } |
219 | } |
220 | |
221 | sub warp_coil :Scotty {} |
222 | my $photon_torpedo :Scotty; |
223 | |
224 | ok( $code_applied eq 'BEGIN', 53, "# phase variance" ); |
225 | ok( $scalar_applied eq 'CHECK', 54 ); |