Commit | Line | Data |
8ebc5c01 |
1 | #!./perl |
2 | |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
5 | @INC = '../lib'; |
6 | } |
7 | |
8 | use Config; |
9 | |
10 | package Oscalar; |
11 | use overload ( |
12 | # Anonymous subroutines: |
13 | '+' => sub {new Oscalar $ {$_[0]}+$_[1]}, |
14 | '-' => sub {new Oscalar |
15 | $_[2]? $_[1]-${$_[0]} : ${$_[0]}-$_[1]}, |
16 | '<=>' => sub {new Oscalar |
17 | $_[2]? $_[1]-${$_[0]} : ${$_[0]}-$_[1]}, |
18 | 'cmp' => sub {new Oscalar |
19 | $_[2]? ($_[1] cmp ${$_[0]}) : (${$_[0]} cmp $_[1])}, |
20 | '*' => sub {new Oscalar ${$_[0]}*$_[1]}, |
21 | '/' => sub {new Oscalar |
22 | $_[2]? $_[1]/${$_[0]} : |
23 | ${$_[0]}/$_[1]}, |
24 | '%' => sub {new Oscalar |
25 | $_[2]? $_[1]%${$_[0]} : ${$_[0]}%$_[1]}, |
26 | '**' => sub {new Oscalar |
27 | $_[2]? $_[1]**${$_[0]} : ${$_[0]}-$_[1]}, |
28 | |
29 | qw( |
30 | "" stringify |
31 | 0+ numify) # Order of arguments unsignificant |
32 | ); |
33 | |
34 | sub new { |
35 | my $foo = $_[1]; |
36 | bless \$foo, $_[0]; |
37 | } |
38 | |
39 | sub stringify { "${$_[0]}" } |
40 | sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead |
41 | # comparing to direct compilation based on |
42 | # stringify |
43 | |
44 | package main; |
45 | |
46 | $test = 0; |
47 | $| = 1; |
48 | print "1..",&last,"\n"; |
49 | |
50 | sub test { |
51 | $test++; if (shift) {print "ok $test\n";1} else {print "not ok $test\n";0} |
52 | } |
53 | |
54 | $a = new Oscalar "087"; |
55 | $b= "$a"; |
56 | |
57 | # All test numbers in comments are off by 1. |
58 | # So much for hard-wiring them in :-) To fix this: |
59 | test(1); # 1 |
60 | |
61 | test ($b eq $a); # 2 |
62 | test ($b eq "087"); # 3 |
63 | test (ref $a eq "Oscalar"); # 4 |
64 | test ($a eq $a); # 5 |
65 | test ($a eq "087"); # 6 |
66 | |
67 | $c = $a + 7; |
68 | |
69 | test (ref $c eq "Oscalar"); # 7 |
70 | test (!($c eq $a)); # 8 |
71 | test ($c eq "94"); # 9 |
72 | |
73 | $b=$a; |
74 | |
75 | test (ref $a eq "Oscalar"); # 10 |
76 | |
77 | $b++; |
78 | |
79 | test (ref $b eq "Oscalar"); # 11 |
80 | test ( $a eq "087"); # 12 |
81 | test ( $b eq "88"); # 13 |
82 | test (ref $a eq "Oscalar"); # 14 |
83 | |
84 | $c=$b; |
85 | $c-=$a; |
86 | |
87 | test (ref $c eq "Oscalar"); # 15 |
88 | test ( $a eq "087"); # 16 |
89 | test ( $c eq "1"); # 17 |
90 | test (ref $a eq "Oscalar"); # 18 |
91 | |
92 | $b=1; |
93 | $b+=$a; |
94 | |
95 | test (ref $b eq "Oscalar"); # 19 |
96 | test ( $a eq "087"); # 20 |
97 | test ( $b eq "88"); # 21 |
98 | test (ref $a eq "Oscalar"); # 22 |
99 | |
100 | eval q[ package Oscalar; use overload ('++' => sub { $ {$_[0]}++;$_[0] } ) ]; |
101 | |
102 | $b=$a; |
103 | |
104 | test (ref $a eq "Oscalar"); # 23 |
105 | |
106 | $b++; |
107 | |
108 | test (ref $b eq "Oscalar"); # 24 |
109 | test ( $a eq "087"); # 25 |
110 | test ( $b eq "88"); # 26 |
111 | test (ref $a eq "Oscalar"); # 27 |
112 | |
113 | package Oscalar; |
114 | $dummy=bless \$dummy; # Now cache of method should be reloaded |
115 | package main; |
116 | |
117 | $b=$a; |
118 | $b++; |
119 | |
120 | test (ref $b eq "Oscalar"); # 28 |
121 | test ( $a eq "087"); # 29 |
122 | test ( $b eq "88"); # 30 |
123 | test (ref $a eq "Oscalar"); # 31 |
124 | |
125 | |
126 | eval q[package Oscalar; use overload ('++' => sub { $ {$_[0]} += 2; $_[0] } ) ]; |
127 | |
128 | $b=$a; |
129 | |
130 | test (ref $a eq "Oscalar"); # 32 |
131 | |
132 | $b++; |
133 | |
134 | test (ref $b eq "Oscalar"); # 33 |
135 | test ( $a eq "087"); # 34 |
136 | test ( $b eq "88"); # 35 |
137 | test (ref $a eq "Oscalar"); # 36 |
138 | |
139 | package Oscalar; |
140 | $dummy=bless \$dummy; # Now cache of method should be reloaded |
141 | package main; |
142 | |
143 | $b++; |
144 | |
145 | test (ref $b eq "Oscalar"); # 37 |
146 | test ( $a eq "087"); # 38 |
147 | test ( $b eq "90"); # 39 |
148 | test (ref $a eq "Oscalar"); # 40 |
149 | |
150 | $b=$a; |
151 | $b++; |
152 | |
153 | test (ref $b eq "Oscalar"); # 41 |
154 | test ( $a eq "087"); # 42 |
155 | test ( $b eq "89"); # 43 |
156 | test (ref $a eq "Oscalar"); # 44 |
157 | |
158 | |
159 | test ($b? 1:0); # 45 |
160 | |
161 | eval q[ package Oscalar; use overload ('=' => sub {$main::copies++; |
162 | package Oscalar; |
163 | local $new=$ {$_[0]}; |
164 | bless \$new } ) ]; |
165 | |
166 | $b=new Oscalar "$a"; |
167 | |
168 | test (ref $b eq "Oscalar"); # 46 |
169 | test ( $a eq "087"); # 47 |
170 | test ( $b eq "087"); # 48 |
171 | test (ref $a eq "Oscalar"); # 49 |
172 | |
173 | $b++; |
174 | |
175 | test (ref $b eq "Oscalar"); # 50 |
176 | test ( $a eq "087"); # 51 |
177 | test ( $b eq "89"); # 52 |
178 | test (ref $a eq "Oscalar"); # 53 |
179 | test ($copies == 0); # 54 |
180 | |
181 | $b+=1; |
182 | |
183 | test (ref $b eq "Oscalar"); # 55 |
184 | test ( $a eq "087"); # 56 |
185 | test ( $b eq "90"); # 57 |
186 | test (ref $a eq "Oscalar"); # 58 |
187 | test ($copies == 0); # 59 |
188 | |
189 | $b=$a; |
190 | $b+=1; |
191 | |
192 | test (ref $b eq "Oscalar"); # 60 |
193 | test ( $a eq "087"); # 61 |
194 | test ( $b eq "88"); # 62 |
195 | test (ref $a eq "Oscalar"); # 63 |
196 | test ($copies == 0); # 64 |
197 | |
198 | $b=$a; |
199 | $b++; |
200 | |
201 | test (ref $b eq "Oscalar") || print ref $b,"=ref(b)\n"; # 65 |
202 | test ( $a eq "087"); # 66 |
203 | test ( $b eq "89"); # 67 |
204 | test (ref $a eq "Oscalar"); # 68 |
205 | test ($copies == 1); # 69 |
206 | |
207 | eval q[package Oscalar; use overload ('+=' => sub {$ {$_[0]} += 3*$_[1]; |
208 | $_[0] } ) ]; |
209 | $c=new Oscalar; # Cause rehash |
210 | |
211 | $b=$a; |
212 | $b+=1; |
213 | |
214 | test (ref $b eq "Oscalar"); # 70 |
215 | test ( $a eq "087"); # 71 |
216 | test ( $b eq "90"); # 72 |
217 | test (ref $a eq "Oscalar"); # 73 |
218 | test ($copies == 2); # 74 |
219 | |
220 | $b+=$b; |
221 | |
222 | test (ref $b eq "Oscalar"); # 75 |
223 | test ( $b eq "360"); # 76 |
224 | test ($copies == 2); # 77 |
225 | $b=-$b; |
226 | |
227 | test (ref $b eq "Oscalar"); # 78 |
228 | test ( $b eq "-360"); # 79 |
229 | test ($copies == 2); # 80 |
230 | |
231 | $b=abs($b); |
232 | |
233 | test (ref $b eq "Oscalar"); # 81 |
234 | test ( $b eq "360"); # 82 |
235 | test ($copies == 2); # 83 |
236 | |
237 | $b=abs($b); |
238 | |
239 | test (ref $b eq "Oscalar"); # 84 |
240 | test ( $b eq "360"); # 85 |
241 | test ($copies == 2); # 86 |
242 | |
243 | eval q[package Oscalar; |
244 | use overload ('x' => sub {new Oscalar ( $_[2] ? "_.$_[1]._" x $ {$_[0]} |
245 | : "_.${$_[0]}._" x $_[1])}) ]; |
246 | |
247 | $a=new Oscalar "yy"; |
248 | $a x= 3; |
249 | test ($a eq "_.yy.__.yy.__.yy._"); # 87 |
250 | |
251 | eval q[package Oscalar; |
252 | use overload ('.' => sub {new Oscalar ( $_[2] ? |
253 | "_.$_[1].__.$ {$_[0]}._" |
254 | : "_.$ {$_[0]}.__.$_[1]._")}) ]; |
255 | |
256 | $a=new Oscalar "xx"; |
257 | |
258 | test ("b${a}c" eq "_._.b.__.xx._.__.c._"); # 88 |
259 | |
260 | # Check inheritance of overloading; |
261 | { |
262 | package OscalarI; |
263 | @ISA = 'Oscalar'; |
264 | } |
265 | |
266 | $aI = new OscalarI "$a"; |
267 | test (ref $aI eq "OscalarI"); # 89 |
268 | test ("$aI" eq "xx"); # 90 |
269 | test ($aI eq "xx"); # 91 |
270 | test ("b${aI}c" eq "_._.b.__.xx._.__.c._"); # 92 |
271 | |
272 | # Here we test blessing to a package updates hash |
273 | |
274 | eval "package Oscalar; no overload '.'"; |
275 | |
276 | test ("b${a}" eq "_.b.__.xx._"); # 93 |
277 | $x="1"; |
278 | bless \$x, Oscalar; |
279 | test ("b${a}c" eq "bxxc"); # 94 |
280 | new Oscalar 1; |
281 | test ("b${a}c" eq "bxxc"); # 95 |
282 | |
283 | # Negative overloading: |
284 | |
285 | $na = eval { ~$a }; |
286 | test($@ =~ /no method found/); # 96 |
287 | |
288 | # Check AUTOLOADING: |
289 | |
290 | *Oscalar::AUTOLOAD = |
291 | sub { *{"Oscalar::$AUTOLOAD"} = sub {"_!_" . shift() . "_!_"} ; |
292 | goto &{"Oscalar::$AUTOLOAD"}}; |
293 | |
44a8e56a |
294 | eval "package Oscalar; sub comple; use overload '~' => 'comple'"; |
8ebc5c01 |
295 | |
296 | $na = eval { ~$a }; # Hash was not updated |
297 | test($@ =~ /no method found/); # 97 |
298 | |
299 | bless \$x, Oscalar; |
300 | |
301 | $na = eval { ~$a }; # Hash updated |
44a8e56a |
302 | warn "`$na', $@" if $@; |
8ebc5c01 |
303 | test !$@; # 98 |
304 | test($na eq '_!_xx_!_'); # 99 |
305 | |
306 | $na = 0; |
307 | |
308 | $na = eval { ~$aI }; # Hash was not updated |
309 | test($@ =~ /no method found/); # 100 |
310 | |
311 | bless \$x, OscalarI; |
312 | |
313 | $na = eval { ~$aI }; |
314 | print $@; |
315 | |
316 | test !$@; # 101 |
317 | test($na eq '_!_xx_!_'); # 102 |
318 | |
44a8e56a |
319 | eval "package Oscalar; sub rshft; use overload '>>' => 'rshft'"; |
8ebc5c01 |
320 | |
321 | $na = eval { $aI >> 1 }; # Hash was not updated |
322 | test($@ =~ /no method found/); # 103 |
323 | |
324 | bless \$x, OscalarI; |
325 | |
326 | $na = 0; |
327 | |
328 | $na = eval { $aI >> 1 }; |
329 | print $@; |
330 | |
331 | test !$@; # 104 |
332 | test($na eq '_!_xx_!_'); # 105 |
333 | |
44a8e56a |
334 | # warn overload::Method($a, '0+'), "\n"; |
8ebc5c01 |
335 | test (overload::Method($a, '0+') eq \&Oscalar::numify); # 106 |
336 | test (overload::Method($aI,'0+') eq \&Oscalar::numify); # 107 |
337 | test (overload::Overloaded($aI)); # 108 |
338 | test (!overload::Overloaded('overload')); # 109 |
339 | |
340 | test (! defined overload::Method($aI, '<<')); # 110 |
341 | test (! defined overload::Method($a, '<')); # 111 |
342 | |
343 | test (overload::StrVal($aI) =~ /^OscalarI=SCALAR\(0x[\da-fA-F]+\)$/); # 112 |
344 | test (overload::StrVal(\$aI) eq "@{[\$aI]}"); # 113 |
345 | |
44a8e56a |
346 | # Check overloading by methods (specified deep in the ISA tree). |
347 | { |
348 | package OscalarII; |
349 | @ISA = 'OscalarI'; |
350 | sub Oscalar::lshft {"_<<_" . shift() . "_<<_"} |
351 | eval "package OscalarI; use overload '<<' => 'lshft', '|' => 'lshft'"; |
352 | } |
353 | |
354 | $aaII = "087"; |
355 | $aII = \$aaII; |
356 | bless $aII, 'OscalarII'; |
357 | bless \$fake, 'OscalarI'; # update the hash |
358 | test(($aI | 3) eq '_<<_xx_<<_'); # 114 |
359 | # warn $aII << 3; |
360 | test(($aII << 3) eq '_<<_087_<<_'); # 115 |
361 | |
8ebc5c01 |
362 | # Last test is: |
44a8e56a |
363 | sub last {115} |