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