Commit | Line | Data |
8ebc5c01 |
1 | #!./perl |
2 | |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
93430cb4 |
5 | unshift @INC, '../lib'; |
8ebc5c01 |
6 | } |
7 | |
8ebc5c01 |
8 | package Oscalar; |
9 | use overload ( |
10 | # Anonymous subroutines: |
11 | '+' => sub {new Oscalar $ {$_[0]}+$_[1]}, |
12 | '-' => sub {new Oscalar |
13 | $_[2]? $_[1]-${$_[0]} : ${$_[0]}-$_[1]}, |
14 | '<=>' => sub {new Oscalar |
15 | $_[2]? $_[1]-${$_[0]} : ${$_[0]}-$_[1]}, |
16 | 'cmp' => sub {new Oscalar |
17 | $_[2]? ($_[1] cmp ${$_[0]}) : (${$_[0]} cmp $_[1])}, |
18 | '*' => sub {new Oscalar ${$_[0]}*$_[1]}, |
19 | '/' => sub {new Oscalar |
20 | $_[2]? $_[1]/${$_[0]} : |
21 | ${$_[0]}/$_[1]}, |
22 | '%' => sub {new Oscalar |
23 | $_[2]? $_[1]%${$_[0]} : ${$_[0]}%$_[1]}, |
24 | '**' => sub {new Oscalar |
25 | $_[2]? $_[1]**${$_[0]} : ${$_[0]}-$_[1]}, |
26 | |
27 | qw( |
28 | "" stringify |
29 | 0+ numify) # Order of arguments unsignificant |
30 | ); |
31 | |
32 | sub new { |
33 | my $foo = $_[1]; |
34 | bless \$foo, $_[0]; |
35 | } |
36 | |
37 | sub stringify { "${$_[0]}" } |
38 | sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead |
39 | # comparing to direct compilation based on |
40 | # stringify |
41 | |
42 | package main; |
43 | |
44 | $test = 0; |
45 | $| = 1; |
46 | print "1..",&last,"\n"; |
47 | |
48 | sub test { |
b3ac6de7 |
49 | $test++; |
50 | if (@_ > 1) { |
51 | if ($_[0] eq $_[1]) { |
52 | print "ok $test\n"; |
53 | } else { |
54 | print "not ok $test: '$_[0]' ne '$_[1]'\n"; |
55 | } |
56 | } else { |
57 | if (shift) { |
58 | print "ok $test\n"; |
59 | } else { |
60 | print "not ok $test\n"; |
61 | } |
62 | } |
8ebc5c01 |
63 | } |
64 | |
65 | $a = new Oscalar "087"; |
66 | $b= "$a"; |
67 | |
68 | # All test numbers in comments are off by 1. |
69 | # So much for hard-wiring them in :-) To fix this: |
70 | test(1); # 1 |
71 | |
72 | test ($b eq $a); # 2 |
73 | test ($b eq "087"); # 3 |
74 | test (ref $a eq "Oscalar"); # 4 |
75 | test ($a eq $a); # 5 |
76 | test ($a eq "087"); # 6 |
77 | |
78 | $c = $a + 7; |
79 | |
80 | test (ref $c eq "Oscalar"); # 7 |
81 | test (!($c eq $a)); # 8 |
82 | test ($c eq "94"); # 9 |
83 | |
84 | $b=$a; |
85 | |
86 | test (ref $a eq "Oscalar"); # 10 |
87 | |
88 | $b++; |
89 | |
90 | test (ref $b eq "Oscalar"); # 11 |
91 | test ( $a eq "087"); # 12 |
92 | test ( $b eq "88"); # 13 |
93 | test (ref $a eq "Oscalar"); # 14 |
94 | |
95 | $c=$b; |
96 | $c-=$a; |
97 | |
98 | test (ref $c eq "Oscalar"); # 15 |
99 | test ( $a eq "087"); # 16 |
100 | test ( $c eq "1"); # 17 |
101 | test (ref $a eq "Oscalar"); # 18 |
102 | |
103 | $b=1; |
104 | $b+=$a; |
105 | |
106 | test (ref $b eq "Oscalar"); # 19 |
107 | test ( $a eq "087"); # 20 |
108 | test ( $b eq "88"); # 21 |
109 | test (ref $a eq "Oscalar"); # 22 |
110 | |
111 | eval q[ package Oscalar; use overload ('++' => sub { $ {$_[0]}++;$_[0] } ) ]; |
112 | |
113 | $b=$a; |
114 | |
115 | test (ref $a eq "Oscalar"); # 23 |
116 | |
117 | $b++; |
118 | |
119 | test (ref $b eq "Oscalar"); # 24 |
120 | test ( $a eq "087"); # 25 |
121 | test ( $b eq "88"); # 26 |
122 | test (ref $a eq "Oscalar"); # 27 |
123 | |
124 | package Oscalar; |
125 | $dummy=bless \$dummy; # Now cache of method should be reloaded |
126 | package main; |
127 | |
128 | $b=$a; |
129 | $b++; |
130 | |
131 | test (ref $b eq "Oscalar"); # 28 |
132 | test ( $a eq "087"); # 29 |
133 | test ( $b eq "88"); # 30 |
134 | test (ref $a eq "Oscalar"); # 31 |
135 | |
136 | |
137 | eval q[package Oscalar; use overload ('++' => sub { $ {$_[0]} += 2; $_[0] } ) ]; |
138 | |
139 | $b=$a; |
140 | |
141 | test (ref $a eq "Oscalar"); # 32 |
142 | |
143 | $b++; |
144 | |
145 | test (ref $b eq "Oscalar"); # 33 |
146 | test ( $a eq "087"); # 34 |
147 | test ( $b eq "88"); # 35 |
148 | test (ref $a eq "Oscalar"); # 36 |
149 | |
150 | package Oscalar; |
151 | $dummy=bless \$dummy; # Now cache of method should be reloaded |
152 | package main; |
153 | |
154 | $b++; |
155 | |
156 | test (ref $b eq "Oscalar"); # 37 |
157 | test ( $a eq "087"); # 38 |
158 | test ( $b eq "90"); # 39 |
159 | test (ref $a eq "Oscalar"); # 40 |
160 | |
161 | $b=$a; |
162 | $b++; |
163 | |
164 | test (ref $b eq "Oscalar"); # 41 |
165 | test ( $a eq "087"); # 42 |
166 | test ( $b eq "89"); # 43 |
167 | test (ref $a eq "Oscalar"); # 44 |
168 | |
169 | |
170 | test ($b? 1:0); # 45 |
171 | |
172 | eval q[ package Oscalar; use overload ('=' => sub {$main::copies++; |
173 | package Oscalar; |
174 | local $new=$ {$_[0]}; |
175 | bless \$new } ) ]; |
176 | |
177 | $b=new Oscalar "$a"; |
178 | |
179 | test (ref $b eq "Oscalar"); # 46 |
180 | test ( $a eq "087"); # 47 |
181 | test ( $b eq "087"); # 48 |
182 | test (ref $a eq "Oscalar"); # 49 |
183 | |
184 | $b++; |
185 | |
186 | test (ref $b eq "Oscalar"); # 50 |
187 | test ( $a eq "087"); # 51 |
188 | test ( $b eq "89"); # 52 |
189 | test (ref $a eq "Oscalar"); # 53 |
190 | test ($copies == 0); # 54 |
191 | |
192 | $b+=1; |
193 | |
194 | test (ref $b eq "Oscalar"); # 55 |
195 | test ( $a eq "087"); # 56 |
196 | test ( $b eq "90"); # 57 |
197 | test (ref $a eq "Oscalar"); # 58 |
198 | test ($copies == 0); # 59 |
199 | |
200 | $b=$a; |
201 | $b+=1; |
202 | |
203 | test (ref $b eq "Oscalar"); # 60 |
204 | test ( $a eq "087"); # 61 |
205 | test ( $b eq "88"); # 62 |
206 | test (ref $a eq "Oscalar"); # 63 |
207 | test ($copies == 0); # 64 |
208 | |
209 | $b=$a; |
210 | $b++; |
211 | |
212 | test (ref $b eq "Oscalar") || print ref $b,"=ref(b)\n"; # 65 |
213 | test ( $a eq "087"); # 66 |
214 | test ( $b eq "89"); # 67 |
215 | test (ref $a eq "Oscalar"); # 68 |
216 | test ($copies == 1); # 69 |
217 | |
218 | eval q[package Oscalar; use overload ('+=' => sub {$ {$_[0]} += 3*$_[1]; |
219 | $_[0] } ) ]; |
220 | $c=new Oscalar; # Cause rehash |
221 | |
222 | $b=$a; |
223 | $b+=1; |
224 | |
225 | test (ref $b eq "Oscalar"); # 70 |
226 | test ( $a eq "087"); # 71 |
227 | test ( $b eq "90"); # 72 |
228 | test (ref $a eq "Oscalar"); # 73 |
229 | test ($copies == 2); # 74 |
230 | |
231 | $b+=$b; |
232 | |
233 | test (ref $b eq "Oscalar"); # 75 |
234 | test ( $b eq "360"); # 76 |
235 | test ($copies == 2); # 77 |
236 | $b=-$b; |
237 | |
238 | test (ref $b eq "Oscalar"); # 78 |
239 | test ( $b eq "-360"); # 79 |
240 | test ($copies == 2); # 80 |
241 | |
242 | $b=abs($b); |
243 | |
244 | test (ref $b eq "Oscalar"); # 81 |
245 | test ( $b eq "360"); # 82 |
246 | test ($copies == 2); # 83 |
247 | |
248 | $b=abs($b); |
249 | |
250 | test (ref $b eq "Oscalar"); # 84 |
251 | test ( $b eq "360"); # 85 |
252 | test ($copies == 2); # 86 |
253 | |
254 | eval q[package Oscalar; |
255 | use overload ('x' => sub {new Oscalar ( $_[2] ? "_.$_[1]._" x $ {$_[0]} |
256 | : "_.${$_[0]}._" x $_[1])}) ]; |
257 | |
258 | $a=new Oscalar "yy"; |
259 | $a x= 3; |
260 | test ($a eq "_.yy.__.yy.__.yy._"); # 87 |
261 | |
262 | eval q[package Oscalar; |
263 | use overload ('.' => sub {new Oscalar ( $_[2] ? |
264 | "_.$_[1].__.$ {$_[0]}._" |
265 | : "_.$ {$_[0]}.__.$_[1]._")}) ]; |
266 | |
267 | $a=new Oscalar "xx"; |
268 | |
269 | test ("b${a}c" eq "_._.b.__.xx._.__.c._"); # 88 |
270 | |
271 | # Check inheritance of overloading; |
272 | { |
273 | package OscalarI; |
274 | @ISA = 'Oscalar'; |
275 | } |
276 | |
277 | $aI = new OscalarI "$a"; |
278 | test (ref $aI eq "OscalarI"); # 89 |
279 | test ("$aI" eq "xx"); # 90 |
280 | test ($aI eq "xx"); # 91 |
281 | test ("b${aI}c" eq "_._.b.__.xx._.__.c._"); # 92 |
282 | |
283 | # Here we test blessing to a package updates hash |
284 | |
285 | eval "package Oscalar; no overload '.'"; |
286 | |
287 | test ("b${a}" eq "_.b.__.xx._"); # 93 |
288 | $x="1"; |
289 | bless \$x, Oscalar; |
290 | test ("b${a}c" eq "bxxc"); # 94 |
291 | new Oscalar 1; |
292 | test ("b${a}c" eq "bxxc"); # 95 |
293 | |
294 | # Negative overloading: |
295 | |
296 | $na = eval { ~$a }; |
297 | test($@ =~ /no method found/); # 96 |
298 | |
299 | # Check AUTOLOADING: |
300 | |
301 | *Oscalar::AUTOLOAD = |
302 | sub { *{"Oscalar::$AUTOLOAD"} = sub {"_!_" . shift() . "_!_"} ; |
303 | goto &{"Oscalar::$AUTOLOAD"}}; |
304 | |
44a8e56a |
305 | eval "package Oscalar; sub comple; use overload '~' => 'comple'"; |
8ebc5c01 |
306 | |
307 | $na = eval { ~$a }; # Hash was not updated |
308 | test($@ =~ /no method found/); # 97 |
309 | |
310 | bless \$x, Oscalar; |
311 | |
312 | $na = eval { ~$a }; # Hash updated |
44a8e56a |
313 | warn "`$na', $@" if $@; |
8ebc5c01 |
314 | test !$@; # 98 |
315 | test($na eq '_!_xx_!_'); # 99 |
316 | |
317 | $na = 0; |
318 | |
319 | $na = eval { ~$aI }; # Hash was not updated |
320 | test($@ =~ /no method found/); # 100 |
321 | |
322 | bless \$x, OscalarI; |
323 | |
324 | $na = eval { ~$aI }; |
325 | print $@; |
326 | |
327 | test !$@; # 101 |
328 | test($na eq '_!_xx_!_'); # 102 |
329 | |
44a8e56a |
330 | eval "package Oscalar; sub rshft; use overload '>>' => 'rshft'"; |
8ebc5c01 |
331 | |
332 | $na = eval { $aI >> 1 }; # Hash was not updated |
333 | test($@ =~ /no method found/); # 103 |
334 | |
335 | bless \$x, OscalarI; |
336 | |
337 | $na = 0; |
338 | |
339 | $na = eval { $aI >> 1 }; |
340 | print $@; |
341 | |
342 | test !$@; # 104 |
343 | test($na eq '_!_xx_!_'); # 105 |
344 | |
44a8e56a |
345 | # warn overload::Method($a, '0+'), "\n"; |
8ebc5c01 |
346 | test (overload::Method($a, '0+') eq \&Oscalar::numify); # 106 |
347 | test (overload::Method($aI,'0+') eq \&Oscalar::numify); # 107 |
348 | test (overload::Overloaded($aI)); # 108 |
349 | test (!overload::Overloaded('overload')); # 109 |
350 | |
351 | test (! defined overload::Method($aI, '<<')); # 110 |
352 | test (! defined overload::Method($a, '<')); # 111 |
353 | |
354 | test (overload::StrVal($aI) =~ /^OscalarI=SCALAR\(0x[\da-fA-F]+\)$/); # 112 |
355 | test (overload::StrVal(\$aI) eq "@{[\$aI]}"); # 113 |
356 | |
44a8e56a |
357 | # Check overloading by methods (specified deep in the ISA tree). |
358 | { |
359 | package OscalarII; |
360 | @ISA = 'OscalarI'; |
361 | sub Oscalar::lshft {"_<<_" . shift() . "_<<_"} |
362 | eval "package OscalarI; use overload '<<' => 'lshft', '|' => 'lshft'"; |
363 | } |
364 | |
365 | $aaII = "087"; |
366 | $aII = \$aaII; |
367 | bless $aII, 'OscalarII'; |
368 | bless \$fake, 'OscalarI'; # update the hash |
369 | test(($aI | 3) eq '_<<_xx_<<_'); # 114 |
370 | # warn $aII << 3; |
371 | test(($aII << 3) eq '_<<_087_<<_'); # 115 |
372 | |
b3ac6de7 |
373 | { |
374 | BEGIN { $int = 7; overload::constant 'integer' => sub {$int++; shift}; } |
375 | $out = 2**10; |
376 | } |
377 | test($int, 9); # 116 |
378 | test($out, 1024); # 117 |
379 | |
380 | $foo = 'foo'; |
381 | $foo1 = 'f\'o\\o'; |
382 | { |
383 | BEGIN { $q = $qr = 7; |
384 | overload::constant 'q' => sub {$q++; push @q, shift, ($_[1] || 'none'); shift}, |
385 | 'qr' => sub {$qr++; push @qr, shift, ($_[1] || 'none'); shift}; } |
386 | $out = 'foo'; |
387 | $out1 = 'f\'o\\o'; |
388 | $out2 = "a\a$foo,\,"; |
389 | /b\b$foo.\./; |
390 | } |
391 | |
392 | test($out, 'foo'); # 118 |
393 | test($out, $foo); # 119 |
394 | test($out1, 'f\'o\\o'); # 120 |
395 | test($out1, $foo1); # 121 |
396 | test($out2, "a\afoo,\,"); # 122 |
397 | test("@q", "foo q f'o\\\\o q a\\a qq ,\\, qq"); # 123 |
398 | test($q, 11); # 124 |
399 | test("@qr", "b\\b qq .\\. qq"); # 125 |
400 | test($qr, 9); # 126 |
401 | |
402 | { |
403 | $_ = '!<b>!foo!<-.>!'; |
404 | BEGIN { overload::constant 'q' => sub {push @q1, shift, ($_[1] || 'none'); "_<" . (shift) . ">_"}, |
405 | 'qr' => sub {push @qr1, shift, ($_[1] || 'none'); "!<" . (shift) . ">!"}; } |
406 | $out = 'foo'; |
407 | $out1 = 'f\'o\\o'; |
408 | $out2 = "a\a$foo,\,"; |
409 | $res = /b\b$foo.\./; |
410 | $a = <<EOF; |
411 | oups |
412 | EOF |
413 | $b = <<'EOF'; |
414 | oups1 |
415 | EOF |
416 | $c = bareword; |
417 | m'try it'; |
418 | s'first part'second part'; |
419 | s/yet another/tail here/; |
420 | tr/z-Z/z-Z/; |
421 | } |
422 | |
423 | test($out, '_<foo>_'); # 117 |
424 | test($out1, '_<f\'o\\o>_'); # 128 |
425 | test($out2, "_<a\a>_foo_<,\,>_"); # 129 |
426 | test("@q1", "foo q f'o\\\\o q a\\a qq ,\\, qq oups |
427 | qq oups1 |
428 | q second part q tail here s z-Z tr z-Z tr"); # 130 |
429 | test("@qr1", "b\\b qq .\\. qq try it q first part q yet another qq"); # 131 |
430 | test($res, 1); # 132 |
431 | test($a, "_<oups |
432 | >_"); # 133 |
433 | test($b, "_<oups1 |
434 | >_"); # 134 |
435 | test($c, "bareword"); # 135 |
436 | |
ee239bfe |
437 | { |
438 | package symbolic; # Primitive symbolic calculator |
439 | use overload nomethod => \&wrap, '""' => \&str, '0+' => \&num, |
440 | '=' => \&cpy, '++' => \&inc, '--' => \&dec; |
441 | |
442 | sub new { shift; bless ['n', @_] } |
443 | sub cpy { |
444 | my $self = shift; |
445 | bless [@$self], ref $self; |
446 | } |
447 | sub inc { $_[0] = bless ['++', $_[0], 1]; } |
448 | sub dec { $_[0] = bless ['--', $_[0], 1]; } |
449 | sub wrap { |
450 | my ($obj, $other, $inv, $meth) = @_; |
451 | if ($meth eq '++' or $meth eq '--') { |
452 | @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference |
453 | return $obj; |
454 | } |
455 | ($obj, $other) = ($other, $obj) if $inv; |
456 | bless [$meth, $obj, $other]; |
457 | } |
458 | sub str { |
459 | my ($meth, $a, $b) = @{+shift}; |
460 | $a = 'u' unless defined $a; |
461 | if (defined $b) { |
462 | "[$meth $a $b]"; |
463 | } else { |
464 | "[$meth $a]"; |
465 | } |
466 | } |
467 | my %subr = ( 'n' => sub {$_[0]} ); |
468 | foreach my $op (split " ", $overload::ops{with_assign}) { |
469 | $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}"; |
470 | } |
471 | my @bins = qw(binary 3way_comparison num_comparison str_comparison); |
472 | foreach my $op (split " ", "@overload::ops{ @bins }") { |
473 | $subr{$op} = eval "sub {shift() $op shift()}"; |
474 | } |
475 | foreach my $op (split " ", "@overload::ops{qw(unary func)}") { |
476 | $subr{$op} = eval "sub {$op shift()}"; |
477 | } |
478 | $subr{'++'} = $subr{'+'}; |
479 | $subr{'--'} = $subr{'-'}; |
480 | |
481 | sub num { |
482 | my ($meth, $a, $b) = @{+shift}; |
483 | my $subr = $subr{$meth} |
484 | or die "Do not know how to ($meth) in symbolic"; |
485 | $a = $a->num if ref $a eq __PACKAGE__; |
486 | $b = $b->num if ref $b eq __PACKAGE__; |
487 | $subr->($a,$b); |
488 | } |
489 | sub TIESCALAR { my $pack = shift; $pack->new(@_) } |
490 | sub FETCH { shift } |
491 | sub nop { } # Around a bug |
492 | sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; } |
493 | sub STORE { |
494 | my $obj = shift; |
495 | $#$obj = 1; |
496 | @$obj->[0,1] = ('=', shift); |
497 | } |
498 | } |
499 | |
500 | { |
501 | my $foo = new symbolic 11; |
502 | my $baz = $foo++; |
503 | test( (sprintf "%d", $foo), '12'); |
504 | test( (sprintf "%d", $baz), '11'); |
505 | my $bar = $foo; |
506 | $baz = ++$foo; |
507 | test( (sprintf "%d", $foo), '13'); |
508 | test( (sprintf "%d", $bar), '12'); |
509 | test( (sprintf "%d", $baz), '13'); |
510 | my $ban = $foo; |
511 | $baz = ($foo += 1); |
512 | test( (sprintf "%d", $foo), '14'); |
513 | test( (sprintf "%d", $bar), '12'); |
514 | test( (sprintf "%d", $baz), '14'); |
515 | test( (sprintf "%d", $ban), '13'); |
516 | $baz = 0; |
517 | $baz = $foo++; |
518 | test( (sprintf "%d", $foo), '15'); |
519 | test( (sprintf "%d", $baz), '14'); |
520 | test( "$foo", '[++ [+= [++ [++ [n 11] 1] 1] 1] 1]'); |
521 | } |
522 | |
523 | { |
524 | my $iter = new symbolic 2; |
525 | my $side = new symbolic 1; |
526 | my $cnt = $iter; |
527 | |
528 | while ($cnt) { |
529 | $cnt = $cnt - 1; # The "simple" way |
530 | $side = (sqrt(1 + $side**2) - 1)/$side; |
531 | } |
532 | my $pi = $side*(2**($iter+2)); |
533 | test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]'; |
534 | test( (sprintf "%f", $pi), '3.182598'); |
535 | } |
536 | |
537 | { |
538 | my $iter = new symbolic 2; |
539 | my $side = new symbolic 1; |
540 | my $cnt = $iter; |
541 | |
542 | while ($cnt--) { |
543 | $side = (sqrt(1 + $side**2) - 1)/$side; |
544 | } |
545 | my $pi = $side*(2**($iter+2)); |
546 | test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]'; |
547 | test( (sprintf "%f", $pi), '3.182598'); |
548 | } |
549 | |
550 | { |
551 | my ($a, $b); |
552 | symbolic->vars($a, $b); |
553 | my $c = sqrt($a**2 + $b**2); |
554 | $a = 3; $b = 4; |
555 | test( (sprintf "%d", $c), '5'); |
556 | $a = 12; $b = 5; |
557 | test( (sprintf "%d", $c), '13'); |
558 | } |
559 | |
560 | { |
561 | package symbolic1; # Primitive symbolic calculator |
562 | # Mutator inc/dec |
563 | use overload nomethod => \&wrap, '""' => \&str, '0+' => \&num, '=' => \&cpy; |
564 | |
565 | sub new { shift; bless ['n', @_] } |
566 | sub cpy { |
567 | my $self = shift; |
568 | bless [@$self], ref $self; |
569 | } |
570 | sub wrap { |
571 | my ($obj, $other, $inv, $meth) = @_; |
572 | if ($meth eq '++' or $meth eq '--') { |
573 | @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference |
574 | return $obj; |
575 | } |
576 | ($obj, $other) = ($other, $obj) if $inv; |
577 | bless [$meth, $obj, $other]; |
578 | } |
579 | sub str { |
580 | my ($meth, $a, $b) = @{+shift}; |
581 | $a = 'u' unless defined $a; |
582 | if (defined $b) { |
583 | "[$meth $a $b]"; |
584 | } else { |
585 | "[$meth $a]"; |
586 | } |
587 | } |
588 | my %subr = ( 'n' => sub {$_[0]} ); |
589 | foreach my $op (split " ", $overload::ops{with_assign}) { |
590 | $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}"; |
591 | } |
592 | my @bins = qw(binary 3way_comparison num_comparison str_comparison); |
593 | foreach my $op (split " ", "@overload::ops{ @bins }") { |
594 | $subr{$op} = eval "sub {shift() $op shift()}"; |
595 | } |
596 | foreach my $op (split " ", "@overload::ops{qw(unary func)}") { |
597 | $subr{$op} = eval "sub {$op shift()}"; |
598 | } |
599 | $subr{'++'} = $subr{'+'}; |
600 | $subr{'--'} = $subr{'-'}; |
601 | |
602 | sub num { |
603 | my ($meth, $a, $b) = @{+shift}; |
604 | my $subr = $subr{$meth} |
605 | or die "Do not know how to ($meth) in symbolic"; |
606 | $a = $a->num if ref $a eq __PACKAGE__; |
607 | $b = $b->num if ref $b eq __PACKAGE__; |
608 | $subr->($a,$b); |
609 | } |
610 | sub TIESCALAR { my $pack = shift; $pack->new(@_) } |
611 | sub FETCH { shift } |
612 | sub nop { } # Around a bug |
613 | sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; } |
614 | sub STORE { |
615 | my $obj = shift; |
616 | $#$obj = 1; |
617 | @$obj->[0,1] = ('=', shift); |
618 | } |
619 | } |
620 | |
621 | { |
622 | my $foo = new symbolic1 11; |
623 | my $baz = $foo++; |
624 | test( (sprintf "%d", $foo), '12'); |
625 | test( (sprintf "%d", $baz), '11'); |
626 | my $bar = $foo; |
627 | $baz = ++$foo; |
628 | test( (sprintf "%d", $foo), '13'); |
629 | test( (sprintf "%d", $bar), '12'); |
630 | test( (sprintf "%d", $baz), '13'); |
631 | my $ban = $foo; |
632 | $baz = ($foo += 1); |
633 | test( (sprintf "%d", $foo), '14'); |
634 | test( (sprintf "%d", $bar), '12'); |
635 | test( (sprintf "%d", $baz), '14'); |
636 | test( (sprintf "%d", $ban), '13'); |
637 | $baz = 0; |
638 | $baz = $foo++; |
639 | test( (sprintf "%d", $foo), '15'); |
640 | test( (sprintf "%d", $baz), '14'); |
641 | test( "$foo", '[++ [+= [++ [++ [n 11] 1] 1] 1] 1]'); |
642 | } |
643 | |
644 | { |
645 | my $iter = new symbolic1 2; |
646 | my $side = new symbolic1 1; |
647 | my $cnt = $iter; |
648 | |
649 | while ($cnt) { |
650 | $cnt = $cnt - 1; # The "simple" way |
651 | $side = (sqrt(1 + $side**2) - 1)/$side; |
652 | } |
653 | my $pi = $side*(2**($iter+2)); |
654 | test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]'; |
655 | test( (sprintf "%f", $pi), '3.182598'); |
656 | } |
657 | |
658 | { |
659 | my $iter = new symbolic1 2; |
660 | my $side = new symbolic1 1; |
661 | my $cnt = $iter; |
662 | |
663 | while ($cnt--) { |
664 | $side = (sqrt(1 + $side**2) - 1)/$side; |
665 | } |
666 | my $pi = $side*(2**($iter+2)); |
667 | test "$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]'; |
668 | test( (sprintf "%f", $pi), '3.182598'); |
669 | } |
670 | |
671 | { |
672 | my ($a, $b); |
673 | symbolic1->vars($a, $b); |
674 | my $c = sqrt($a**2 + $b**2); |
675 | $a = 3; $b = 4; |
676 | test( (sprintf "%d", $c), '5'); |
677 | $a = 12; $b = 5; |
678 | test( (sprintf "%d", $c), '13'); |
679 | } |
680 | |
681 | { |
682 | package two_face; # Scalars with separate string and |
683 | # numeric values. |
684 | sub new { my $p = shift; bless [@_], $p } |
685 | use overload '""' => \&str, '0+' => \&num, fallback => 1; |
686 | sub num {shift->[1]} |
687 | sub str {shift->[0]} |
688 | } |
689 | |
690 | { |
691 | my $seven = new two_face ("vii", 7); |
692 | test( (sprintf "seven=$seven, seven=%d, eight=%d", $seven, $seven+1), |
693 | 'seven=vii, seven=7, eight=8'); |
694 | test( scalar ($seven =~ /i/), '1') |
695 | } |
b3ac6de7 |
696 | |
d0ecd44c |
697 | { |
698 | package sorting; |
699 | use overload 'cmp' => \∁ |
700 | sub new { my ($p, $v) = @_; bless \$v, $p } |
701 | sub comp { my ($x,$y) = @_; ($$x * 3 % 10) <=> ($$y * 3 % 10) or $$x cmp $$y } |
702 | } |
703 | { |
704 | my @arr = map sorting->new($_), 0..12; |
705 | my @sorted1 = sort @arr; |
706 | my @sorted2 = map $$_, @sorted1; |
707 | test "@sorted2", '0 10 7 4 1 11 8 5 12 2 9 6 3'; |
708 | } |
f5284f61 |
709 | { |
710 | package iterator; |
711 | use overload '<>' => \&iter; |
712 | sub new { my ($p, $v) = @_; bless \$v, $p } |
713 | sub iter { my ($x) = @_; return undef if $$x < 0; return $$x--; } |
714 | } |
72b16652 |
715 | |
716 | # XXX iterator overload not intended to work with CORE::GLOBAL? |
717 | if (defined &CORE::GLOBAL::glob) { |
718 | test '1', '1'; # 175 |
719 | test '1', '1'; # 176 |
720 | test '1', '1'; # 177 |
721 | } |
722 | else { |
f5284f61 |
723 | my $iter = iterator->new(5); |
724 | my $acc = ''; |
725 | my $out; |
726 | $acc .= " $out" while $out = <${iter}>; |
727 | test $acc, ' 5 4 3 2 1 0'; # 175 |
728 | $iter = iterator->new(5); |
729 | test scalar <${iter}>, '5'; # 176 |
730 | $acc = ''; |
731 | $acc .= " $out" while $out = <$iter>; |
732 | test $acc, ' 4 3 2 1 0'; # 177 |
733 | } |
734 | { |
735 | package deref; |
736 | use overload '%{}' => \&hderef, '&{}' => \&cderef, |
737 | '*{}' => \&gderef, '${}' => \&sderef, '@{}' => \&aderef; |
738 | sub new { my ($p, $v) = @_; bless \$v, $p } |
739 | sub deref { |
740 | my ($self, $key) = (shift, shift); |
741 | my $class = ref $self; |
742 | bless $self, 'deref::dummy'; # Disable overloading of %{} |
743 | my $out = $self->{$key}; |
744 | bless $self, $class; # Restore overloading |
745 | $out; |
746 | } |
747 | sub hderef {shift->deref('h')} |
748 | sub aderef {shift->deref('a')} |
749 | sub cderef {shift->deref('c')} |
750 | sub gderef {shift->deref('g')} |
751 | sub sderef {shift->deref('s')} |
752 | } |
753 | { |
754 | my $deref = bless { h => { foo => 5 , fake => 23 }, |
755 | c => sub {return shift() + 34}, |
756 | 's' => \123, |
757 | a => [11..13], |
758 | g => \*srt, |
759 | }, 'deref'; |
760 | # Hash: |
761 | my @cont = sort %$deref; |
ee50adbe |
762 | if ("\t" eq "\011") { # ascii |
763 | test "@cont", '23 5 fake foo'; # 178 |
764 | } |
765 | else { # ebcdic alpha-numeric sort order |
766 | test "@cont", 'fake foo 23 5'; # 178 |
767 | } |
f5284f61 |
768 | my @keys = sort keys %$deref; |
769 | test "@keys", 'fake foo'; # 179 |
770 | my @val = sort values %$deref; |
771 | test "@val", '23 5'; # 180 |
772 | test $deref->{foo}, 5; # 181 |
773 | test defined $deref->{bar}, ''; # 182 |
774 | my $key; |
775 | @keys = (); |
776 | push @keys, $key while $key = each %$deref; |
777 | @keys = sort @keys; |
778 | test "@keys", 'fake foo'; # 183 |
779 | test exists $deref->{bar}, ''; # 184 |
780 | test exists $deref->{foo}, 1; # 185 |
781 | # Code: |
782 | test $deref->(5), 39; # 186 |
783 | test &$deref(6), 40; # 187 |
784 | sub xxx_goto { goto &$deref } |
785 | test xxx_goto(7), 41; # 188 |
786 | my $srt = bless { c => sub {$b <=> $a} |
787 | }, 'deref'; |
788 | *srt = \&$srt; |
789 | my @sorted = sort srt 11, 2, 5, 1, 22; |
790 | test "@sorted", '22 11 5 2 1'; # 189 |
791 | # Scalar |
792 | test $$deref, 123; # 190 |
c6e96bcb |
793 | # Code |
794 | @sorted = sort $srt 11, 2, 5, 1, 22; |
f5284f61 |
795 | test "@sorted", '22 11 5 2 1'; # 191 |
796 | # Array |
797 | test "@$deref", '11 12 13'; # 192 |
798 | test $#$deref, '2'; # 193 |
799 | my $l = @$deref; |
800 | test $l, 3; # 194 |
801 | test $deref->[2], '13'; # 195 |
802 | $l = pop @$deref; |
803 | test $l, 13; # 196 |
804 | $l = 1; |
805 | test $deref->[$l], '12'; # 197 |
806 | # Repeated dereference |
807 | my $double = bless { h => $deref, |
808 | }, 'deref'; |
809 | test $double->{foo}, 5; # 198 |
810 | } |
811 | |
812 | { |
813 | package two_refs; |
814 | use overload '%{}' => \&gethash, '@{}' => sub { ${shift()} }; |
815 | sub new { |
816 | my $p = shift; |
817 | bless \ [@_], $p; |
818 | } |
819 | sub gethash { |
820 | my %h; |
821 | my $self = shift; |
822 | tie %h, ref $self, $self; |
823 | \%h; |
824 | } |
825 | |
826 | sub TIEHASH { my $p = shift; bless \ shift, $p } |
827 | my %fields; |
828 | my $i = 0; |
829 | $fields{$_} = $i++ foreach qw{zero one two three}; |
830 | sub STORE { |
831 | my $self = ${shift()}; |
832 | my $key = $fields{shift()}; |
833 | defined $key or die "Out of band access"; |
834 | $$self->[$key] = shift; |
835 | } |
836 | sub FETCH { |
837 | my $self = ${shift()}; |
838 | my $key = $fields{shift()}; |
839 | defined $key or die "Out of band access"; |
840 | $$self->[$key]; |
841 | } |
842 | } |
843 | |
844 | my $bar = new two_refs 3,4,5,6; |
845 | $bar->[2] = 11; |
846 | test $bar->{two}, 11; # 199 |
847 | $bar->{three} = 13; |
848 | test $bar->[3], 13; # 200 |
849 | |
850 | { |
851 | package two_refs_o; |
852 | @ISA = ('two_refs'); |
853 | } |
854 | |
855 | $bar = new two_refs_o 3,4,5,6; |
856 | $bar->[2] = 11; |
857 | test $bar->{two}, 11; # 201 |
858 | $bar->{three} = 13; |
859 | test $bar->[3], 13; # 202 |
860 | |
861 | { |
862 | package two_refs1; |
863 | use overload '%{}' => sub { ${shift()}->[1] }, |
864 | '@{}' => sub { ${shift()}->[0] }; |
865 | sub new { |
866 | my $p = shift; |
867 | my $a = [@_]; |
868 | my %h; |
869 | tie %h, $p, $a; |
870 | bless \ [$a, \%h], $p; |
871 | } |
872 | sub gethash { |
873 | my %h; |
874 | my $self = shift; |
875 | tie %h, ref $self, $self; |
876 | \%h; |
877 | } |
878 | |
879 | sub TIEHASH { my $p = shift; bless \ shift, $p } |
880 | my %fields; |
881 | my $i = 0; |
882 | $fields{$_} = $i++ foreach qw{zero one two three}; |
883 | sub STORE { |
884 | my $a = ${shift()}; |
885 | my $key = $fields{shift()}; |
886 | defined $key or die "Out of band access"; |
887 | $a->[$key] = shift; |
888 | } |
889 | sub FETCH { |
890 | my $a = ${shift()}; |
891 | my $key = $fields{shift()}; |
892 | defined $key or die "Out of band access"; |
893 | $a->[$key]; |
894 | } |
895 | } |
896 | |
897 | $bar = new two_refs_o 3,4,5,6; |
898 | $bar->[2] = 11; |
899 | test $bar->{two}, 11; # 203 |
900 | $bar->{three} = 13; |
901 | test $bar->[3], 13; # 204 |
902 | |
903 | { |
904 | package two_refs1_o; |
905 | @ISA = ('two_refs1'); |
906 | } |
907 | |
908 | $bar = new two_refs1_o 3,4,5,6; |
909 | $bar->[2] = 11; |
910 | test $bar->{two}, 11; # 205 |
911 | $bar->{three} = 13; |
912 | test $bar->[3], 13; # 206 |
913 | |
fe7ac86a |
914 | { |
915 | package B; |
916 | use overload bool => sub { ${+shift} }; |
917 | } |
918 | |
919 | my $aaa; |
920 | { my $bbbb = 0; $aaa = bless \$bbbb, B } |
921 | |
922 | test !$aaa, 1; |
923 | |
924 | unless ($aaa) { |
925 | test 'ok', 'ok'; |
926 | } else { |
927 | test 'is not', 'ok'; |
928 | } |
929 | |
930 | |
8ebc5c01 |
931 | # Last test is: |
fe7ac86a |
932 | sub last {208} |