Move Attribute::Handlers from ext/ to dist/
[perl.git] / dist / Attribute-Handlers / t / multi.t
1 #!perl
2
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
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
20 sub ok { $::count++; push @::results, [$_[1], $_[0]?"":"not ", defined($_[2])?$_[2]:""]; }
21
22 END { print "1..$::count\n";
23       print map "$_->[1]ok $_->[0] $_->[2]\n",
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
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
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
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'; }
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 }
173 # are lexical attributes reapplied correctly?
174 sub dummy { my $dummy : Dummy; }
175 $applied = 0;
176 dummy(); dummy();
177 if($] < 5.008) {
178 ok(1, 47, " # skip does not work with perl prior to 5.8");
179 } else {
180 ok( $applied == 2, 47 );
181 }
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 );
186 { no warnings; our $dummy : Dummy;  $dummy = bless {}, 'Dummy'; }
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?
192 sub dummy_our { no warnings; our $banjo : Dummy; }
193 $applied = 0;
194 dummy_our(); dummy_our();
195 ok( $applied == 0, 51 );
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/; 
203 if($] < 5.008) {
204 ok(1,52 ,"# Skip, no difference between lexical handlers and normal handlers prior to 5.8");
205 } else {
206 ok( $match, 52 );
207 }
208
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 );