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