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