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 { |
b3ac6de7 |
51 | $test++; |
52 | if (@_ > 1) { |
53 | if ($_[0] eq $_[1]) { |
54 | print "ok $test\n"; |
55 | } else { |
56 | print "not ok $test: '$_[0]' ne '$_[1]'\n"; |
57 | } |
58 | } else { |
59 | if (shift) { |
60 | print "ok $test\n"; |
61 | } else { |
62 | print "not ok $test\n"; |
63 | } |
64 | } |
8ebc5c01 |
65 | } |
66 | |
67 | $a = new Oscalar "087"; |
68 | $b= "$a"; |
69 | |
70 | # All test numbers in comments are off by 1. |
71 | # So much for hard-wiring them in :-) To fix this: |
72 | test(1); # 1 |
73 | |
74 | test ($b eq $a); # 2 |
75 | test ($b eq "087"); # 3 |
76 | test (ref $a eq "Oscalar"); # 4 |
77 | test ($a eq $a); # 5 |
78 | test ($a eq "087"); # 6 |
79 | |
80 | $c = $a + 7; |
81 | |
82 | test (ref $c eq "Oscalar"); # 7 |
83 | test (!($c eq $a)); # 8 |
84 | test ($c eq "94"); # 9 |
85 | |
86 | $b=$a; |
87 | |
88 | test (ref $a eq "Oscalar"); # 10 |
89 | |
90 | $b++; |
91 | |
92 | test (ref $b eq "Oscalar"); # 11 |
93 | test ( $a eq "087"); # 12 |
94 | test ( $b eq "88"); # 13 |
95 | test (ref $a eq "Oscalar"); # 14 |
96 | |
97 | $c=$b; |
98 | $c-=$a; |
99 | |
100 | test (ref $c eq "Oscalar"); # 15 |
101 | test ( $a eq "087"); # 16 |
102 | test ( $c eq "1"); # 17 |
103 | test (ref $a eq "Oscalar"); # 18 |
104 | |
105 | $b=1; |
106 | $b+=$a; |
107 | |
108 | test (ref $b eq "Oscalar"); # 19 |
109 | test ( $a eq "087"); # 20 |
110 | test ( $b eq "88"); # 21 |
111 | test (ref $a eq "Oscalar"); # 22 |
112 | |
113 | eval q[ package Oscalar; use overload ('++' => sub { $ {$_[0]}++;$_[0] } ) ]; |
114 | |
115 | $b=$a; |
116 | |
117 | test (ref $a eq "Oscalar"); # 23 |
118 | |
119 | $b++; |
120 | |
121 | test (ref $b eq "Oscalar"); # 24 |
122 | test ( $a eq "087"); # 25 |
123 | test ( $b eq "88"); # 26 |
124 | test (ref $a eq "Oscalar"); # 27 |
125 | |
126 | package Oscalar; |
127 | $dummy=bless \$dummy; # Now cache of method should be reloaded |
128 | package main; |
129 | |
130 | $b=$a; |
131 | $b++; |
132 | |
133 | test (ref $b eq "Oscalar"); # 28 |
134 | test ( $a eq "087"); # 29 |
135 | test ( $b eq "88"); # 30 |
136 | test (ref $a eq "Oscalar"); # 31 |
137 | |
138 | |
139 | eval q[package Oscalar; use overload ('++' => sub { $ {$_[0]} += 2; $_[0] } ) ]; |
140 | |
141 | $b=$a; |
142 | |
143 | test (ref $a eq "Oscalar"); # 32 |
144 | |
145 | $b++; |
146 | |
147 | test (ref $b eq "Oscalar"); # 33 |
148 | test ( $a eq "087"); # 34 |
149 | test ( $b eq "88"); # 35 |
150 | test (ref $a eq "Oscalar"); # 36 |
151 | |
152 | package Oscalar; |
153 | $dummy=bless \$dummy; # Now cache of method should be reloaded |
154 | package main; |
155 | |
156 | $b++; |
157 | |
158 | test (ref $b eq "Oscalar"); # 37 |
159 | test ( $a eq "087"); # 38 |
160 | test ( $b eq "90"); # 39 |
161 | test (ref $a eq "Oscalar"); # 40 |
162 | |
163 | $b=$a; |
164 | $b++; |
165 | |
166 | test (ref $b eq "Oscalar"); # 41 |
167 | test ( $a eq "087"); # 42 |
168 | test ( $b eq "89"); # 43 |
169 | test (ref $a eq "Oscalar"); # 44 |
170 | |
171 | |
172 | test ($b? 1:0); # 45 |
173 | |
174 | eval q[ package Oscalar; use overload ('=' => sub {$main::copies++; |
175 | package Oscalar; |
176 | local $new=$ {$_[0]}; |
177 | bless \$new } ) ]; |
178 | |
179 | $b=new Oscalar "$a"; |
180 | |
181 | test (ref $b eq "Oscalar"); # 46 |
182 | test ( $a eq "087"); # 47 |
183 | test ( $b eq "087"); # 48 |
184 | test (ref $a eq "Oscalar"); # 49 |
185 | |
186 | $b++; |
187 | |
188 | test (ref $b eq "Oscalar"); # 50 |
189 | test ( $a eq "087"); # 51 |
190 | test ( $b eq "89"); # 52 |
191 | test (ref $a eq "Oscalar"); # 53 |
192 | test ($copies == 0); # 54 |
193 | |
194 | $b+=1; |
195 | |
196 | test (ref $b eq "Oscalar"); # 55 |
197 | test ( $a eq "087"); # 56 |
198 | test ( $b eq "90"); # 57 |
199 | test (ref $a eq "Oscalar"); # 58 |
200 | test ($copies == 0); # 59 |
201 | |
202 | $b=$a; |
203 | $b+=1; |
204 | |
205 | test (ref $b eq "Oscalar"); # 60 |
206 | test ( $a eq "087"); # 61 |
207 | test ( $b eq "88"); # 62 |
208 | test (ref $a eq "Oscalar"); # 63 |
209 | test ($copies == 0); # 64 |
210 | |
211 | $b=$a; |
212 | $b++; |
213 | |
214 | test (ref $b eq "Oscalar") || print ref $b,"=ref(b)\n"; # 65 |
215 | test ( $a eq "087"); # 66 |
216 | test ( $b eq "89"); # 67 |
217 | test (ref $a eq "Oscalar"); # 68 |
218 | test ($copies == 1); # 69 |
219 | |
220 | eval q[package Oscalar; use overload ('+=' => sub {$ {$_[0]} += 3*$_[1]; |
221 | $_[0] } ) ]; |
222 | $c=new Oscalar; # Cause rehash |
223 | |
224 | $b=$a; |
225 | $b+=1; |
226 | |
227 | test (ref $b eq "Oscalar"); # 70 |
228 | test ( $a eq "087"); # 71 |
229 | test ( $b eq "90"); # 72 |
230 | test (ref $a eq "Oscalar"); # 73 |
231 | test ($copies == 2); # 74 |
232 | |
233 | $b+=$b; |
234 | |
235 | test (ref $b eq "Oscalar"); # 75 |
236 | test ( $b eq "360"); # 76 |
237 | test ($copies == 2); # 77 |
238 | $b=-$b; |
239 | |
240 | test (ref $b eq "Oscalar"); # 78 |
241 | test ( $b eq "-360"); # 79 |
242 | test ($copies == 2); # 80 |
243 | |
244 | $b=abs($b); |
245 | |
246 | test (ref $b eq "Oscalar"); # 81 |
247 | test ( $b eq "360"); # 82 |
248 | test ($copies == 2); # 83 |
249 | |
250 | $b=abs($b); |
251 | |
252 | test (ref $b eq "Oscalar"); # 84 |
253 | test ( $b eq "360"); # 85 |
254 | test ($copies == 2); # 86 |
255 | |
256 | eval q[package Oscalar; |
257 | use overload ('x' => sub {new Oscalar ( $_[2] ? "_.$_[1]._" x $ {$_[0]} |
258 | : "_.${$_[0]}._" x $_[1])}) ]; |
259 | |
260 | $a=new Oscalar "yy"; |
261 | $a x= 3; |
262 | test ($a eq "_.yy.__.yy.__.yy._"); # 87 |
263 | |
264 | eval q[package Oscalar; |
265 | use overload ('.' => sub {new Oscalar ( $_[2] ? |
266 | "_.$_[1].__.$ {$_[0]}._" |
267 | : "_.$ {$_[0]}.__.$_[1]._")}) ]; |
268 | |
269 | $a=new Oscalar "xx"; |
270 | |
271 | test ("b${a}c" eq "_._.b.__.xx._.__.c._"); # 88 |
272 | |
273 | # Check inheritance of overloading; |
274 | { |
275 | package OscalarI; |
276 | @ISA = 'Oscalar'; |
277 | } |
278 | |
279 | $aI = new OscalarI "$a"; |
280 | test (ref $aI eq "OscalarI"); # 89 |
281 | test ("$aI" eq "xx"); # 90 |
282 | test ($aI eq "xx"); # 91 |
283 | test ("b${aI}c" eq "_._.b.__.xx._.__.c._"); # 92 |
284 | |
285 | # Here we test blessing to a package updates hash |
286 | |
287 | eval "package Oscalar; no overload '.'"; |
288 | |
289 | test ("b${a}" eq "_.b.__.xx._"); # 93 |
290 | $x="1"; |
291 | bless \$x, Oscalar; |
292 | test ("b${a}c" eq "bxxc"); # 94 |
293 | new Oscalar 1; |
294 | test ("b${a}c" eq "bxxc"); # 95 |
295 | |
296 | # Negative overloading: |
297 | |
298 | $na = eval { ~$a }; |
299 | test($@ =~ /no method found/); # 96 |
300 | |
301 | # Check AUTOLOADING: |
302 | |
303 | *Oscalar::AUTOLOAD = |
304 | sub { *{"Oscalar::$AUTOLOAD"} = sub {"_!_" . shift() . "_!_"} ; |
305 | goto &{"Oscalar::$AUTOLOAD"}}; |
306 | |
44a8e56a |
307 | eval "package Oscalar; sub comple; use overload '~' => 'comple'"; |
8ebc5c01 |
308 | |
309 | $na = eval { ~$a }; # Hash was not updated |
310 | test($@ =~ /no method found/); # 97 |
311 | |
312 | bless \$x, Oscalar; |
313 | |
314 | $na = eval { ~$a }; # Hash updated |
44a8e56a |
315 | warn "`$na', $@" if $@; |
8ebc5c01 |
316 | test !$@; # 98 |
317 | test($na eq '_!_xx_!_'); # 99 |
318 | |
319 | $na = 0; |
320 | |
321 | $na = eval { ~$aI }; # Hash was not updated |
322 | test($@ =~ /no method found/); # 100 |
323 | |
324 | bless \$x, OscalarI; |
325 | |
326 | $na = eval { ~$aI }; |
327 | print $@; |
328 | |
329 | test !$@; # 101 |
330 | test($na eq '_!_xx_!_'); # 102 |
331 | |
44a8e56a |
332 | eval "package Oscalar; sub rshft; use overload '>>' => 'rshft'"; |
8ebc5c01 |
333 | |
334 | $na = eval { $aI >> 1 }; # Hash was not updated |
335 | test($@ =~ /no method found/); # 103 |
336 | |
337 | bless \$x, OscalarI; |
338 | |
339 | $na = 0; |
340 | |
341 | $na = eval { $aI >> 1 }; |
342 | print $@; |
343 | |
344 | test !$@; # 104 |
345 | test($na eq '_!_xx_!_'); # 105 |
346 | |
44a8e56a |
347 | # warn overload::Method($a, '0+'), "\n"; |
8ebc5c01 |
348 | test (overload::Method($a, '0+') eq \&Oscalar::numify); # 106 |
349 | test (overload::Method($aI,'0+') eq \&Oscalar::numify); # 107 |
350 | test (overload::Overloaded($aI)); # 108 |
351 | test (!overload::Overloaded('overload')); # 109 |
352 | |
353 | test (! defined overload::Method($aI, '<<')); # 110 |
354 | test (! defined overload::Method($a, '<')); # 111 |
355 | |
356 | test (overload::StrVal($aI) =~ /^OscalarI=SCALAR\(0x[\da-fA-F]+\)$/); # 112 |
357 | test (overload::StrVal(\$aI) eq "@{[\$aI]}"); # 113 |
358 | |
44a8e56a |
359 | # Check overloading by methods (specified deep in the ISA tree). |
360 | { |
361 | package OscalarII; |
362 | @ISA = 'OscalarI'; |
363 | sub Oscalar::lshft {"_<<_" . shift() . "_<<_"} |
364 | eval "package OscalarI; use overload '<<' => 'lshft', '|' => 'lshft'"; |
365 | } |
366 | |
367 | $aaII = "087"; |
368 | $aII = \$aaII; |
369 | bless $aII, 'OscalarII'; |
370 | bless \$fake, 'OscalarI'; # update the hash |
371 | test(($aI | 3) eq '_<<_xx_<<_'); # 114 |
372 | # warn $aII << 3; |
373 | test(($aII << 3) eq '_<<_087_<<_'); # 115 |
374 | |
b3ac6de7 |
375 | { |
376 | BEGIN { $int = 7; overload::constant 'integer' => sub {$int++; shift}; } |
377 | $out = 2**10; |
378 | } |
379 | test($int, 9); # 116 |
380 | test($out, 1024); # 117 |
381 | |
382 | $foo = 'foo'; |
383 | $foo1 = 'f\'o\\o'; |
384 | { |
385 | BEGIN { $q = $qr = 7; |
386 | overload::constant 'q' => sub {$q++; push @q, shift, ($_[1] || 'none'); shift}, |
387 | 'qr' => sub {$qr++; push @qr, shift, ($_[1] || 'none'); shift}; } |
388 | $out = 'foo'; |
389 | $out1 = 'f\'o\\o'; |
390 | $out2 = "a\a$foo,\,"; |
391 | /b\b$foo.\./; |
392 | } |
393 | |
394 | test($out, 'foo'); # 118 |
395 | test($out, $foo); # 119 |
396 | test($out1, 'f\'o\\o'); # 120 |
397 | test($out1, $foo1); # 121 |
398 | test($out2, "a\afoo,\,"); # 122 |
399 | test("@q", "foo q f'o\\\\o q a\\a qq ,\\, qq"); # 123 |
400 | test($q, 11); # 124 |
401 | test("@qr", "b\\b qq .\\. qq"); # 125 |
402 | test($qr, 9); # 126 |
403 | |
404 | { |
405 | $_ = '!<b>!foo!<-.>!'; |
406 | BEGIN { overload::constant 'q' => sub {push @q1, shift, ($_[1] || 'none'); "_<" . (shift) . ">_"}, |
407 | 'qr' => sub {push @qr1, shift, ($_[1] || 'none'); "!<" . (shift) . ">!"}; } |
408 | $out = 'foo'; |
409 | $out1 = 'f\'o\\o'; |
410 | $out2 = "a\a$foo,\,"; |
411 | $res = /b\b$foo.\./; |
412 | $a = <<EOF; |
413 | oups |
414 | EOF |
415 | $b = <<'EOF'; |
416 | oups1 |
417 | EOF |
418 | $c = bareword; |
419 | m'try it'; |
420 | s'first part'second part'; |
421 | s/yet another/tail here/; |
422 | tr/z-Z/z-Z/; |
423 | } |
424 | |
425 | test($out, '_<foo>_'); # 117 |
426 | test($out1, '_<f\'o\\o>_'); # 128 |
427 | test($out2, "_<a\a>_foo_<,\,>_"); # 129 |
428 | test("@q1", "foo q f'o\\\\o q a\\a qq ,\\, qq oups |
429 | qq oups1 |
430 | q second part q tail here s z-Z tr z-Z tr"); # 130 |
431 | test("@qr1", "b\\b qq .\\. qq try it q first part q yet another qq"); # 131 |
432 | test($res, 1); # 132 |
433 | test($a, "_<oups |
434 | >_"); # 133 |
435 | test($b, "_<oups1 |
436 | >_"); # 134 |
437 | test($c, "bareword"); # 135 |
438 | |
439 | |
8ebc5c01 |
440 | # Last test is: |
b3ac6de7 |
441 | sub last {135} |