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