5 unshift @INC, '../lib';
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]} :
22 '%' => sub {new Oscalar
23 $_[2]? $_[1]%${$_[0]} : ${$_[0]}%$_[1]},
24 '**' => sub {new Oscalar
25 $_[2]? $_[1]**${$_[0]} : ${$_[0]}-$_[1]},
29 0+ numify) # Order of arguments unsignificant
37 sub stringify { "${$_[0]}" }
38 sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead
39 # comparing to direct compilation based on
46 print "1..",&last,"\n";
54 print "not ok $test: '$_[0]' ne '$_[1]'\n";
60 print "not ok $test\n";
65 $a = new Oscalar "087";
68 # All test numbers in comments are off by 1.
69 # So much for hard-wiring them in :-) To fix this:
73 test ($b eq "087"); # 3
74 test (ref $a eq "Oscalar"); # 4
76 test ($a eq "087"); # 6
80 test (ref $c eq "Oscalar"); # 7
81 test (!($c eq $a)); # 8
82 test ($c eq "94"); # 9
86 test (ref $a eq "Oscalar"); # 10
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
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
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
111 eval q[ package Oscalar; use overload ('++' => sub { $ {$_[0]}++;$_[0] } ) ];
115 test (ref $a eq "Oscalar"); # 23
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
125 $dummy=bless \$dummy; # Now cache of method should be reloaded
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
137 eval q[package Oscalar; use overload ('++' => sub { $ {$_[0]} += 2; $_[0] } ) ];
141 test (ref $a eq "Oscalar"); # 32
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
151 $dummy=bless \$dummy; # Now cache of method should be reloaded
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
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
172 eval q[ package Oscalar; use overload ('=' => sub {$main::copies++;
174 local $new=$ {$_[0]};
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
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
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
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
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
218 eval q[package Oscalar; use overload ('+=' => sub {$ {$_[0]} += 3*$_[1];
220 $c=new Oscalar; # Cause rehash
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
233 test (ref $b eq "Oscalar"); # 75
234 test ( $b eq "360"); # 76
235 test ($copies == 2); # 77
238 test (ref $b eq "Oscalar"); # 78
239 test ( $b eq "-360"); # 79
240 test ($copies == 2); # 80
244 test (ref $b eq "Oscalar"); # 81
245 test ( $b eq "360"); # 82
246 test ($copies == 2); # 83
250 test (ref $b eq "Oscalar"); # 84
251 test ( $b eq "360"); # 85
252 test ($copies == 2); # 86
254 eval q[package Oscalar;
255 use overload ('x' => sub {new Oscalar ( $_[2] ? "_.$_[1]._" x $ {$_[0]}
256 : "_.${$_[0]}._" x $_[1])}) ];
260 test ($a eq "_.yy.__.yy.__.yy._"); # 87
262 eval q[package Oscalar;
263 use overload ('.' => sub {new Oscalar ( $_[2] ?
264 "_.$_[1].__.$ {$_[0]}._"
265 : "_.$ {$_[0]}.__.$_[1]._")}) ];
269 test ("b${a}c" eq "_._.b.__.xx._.__.c._"); # 88
271 # Check inheritance of overloading;
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
283 # Here we test blessing to a package updates hash
285 eval "package Oscalar; no overload '.'";
287 test ("b${a}" eq "_.b.__.xx._"); # 93
290 test ("b${a}c" eq "bxxc"); # 94
292 test ("b${a}c" eq "bxxc"); # 95
294 # Negative overloading:
297 test($@ =~ /no method found/); # 96
302 sub { *{"Oscalar::$AUTOLOAD"} = sub {"_!_" . shift() . "_!_"} ;
303 goto &{"Oscalar::$AUTOLOAD"}};
305 eval "package Oscalar; sub comple; use overload '~' => 'comple'";
307 $na = eval { ~$a }; # Hash was not updated
308 test($@ =~ /no method found/); # 97
312 $na = eval { ~$a }; # Hash updated
313 warn "`$na', $@" if $@;
315 test($na eq '_!_xx_!_'); # 99
319 $na = eval { ~$aI }; # Hash was not updated
320 test($@ =~ /no method found/); # 100
328 test($na eq '_!_xx_!_'); # 102
330 eval "package Oscalar; sub rshft; use overload '>>' => 'rshft'";
332 $na = eval { $aI >> 1 }; # Hash was not updated
333 test($@ =~ /no method found/); # 103
339 $na = eval { $aI >> 1 };
343 test($na eq '_!_xx_!_'); # 105
345 # warn overload::Method($a, '0+'), "\n";
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
351 test (! defined overload::Method($aI, '<<')); # 110
352 test (! defined overload::Method($a, '<')); # 111
354 test (overload::StrVal($aI) =~ /^OscalarI=SCALAR\(0x[\da-fA-F]+\)$/); # 112
355 test (overload::StrVal(\$aI) eq "@{[\$aI]}"); # 113
357 # Check overloading by methods (specified deep in the ISA tree).
361 sub Oscalar::lshft {"_<<_" . shift() . "_<<_"}
362 eval "package OscalarI; use overload '<<' => 'lshft', '|' => 'lshft'";
367 bless $aII, 'OscalarII';
368 bless \$fake, 'OscalarI'; # update the hash
369 test(($aI | 3) eq '_<<_xx_<<_'); # 114
371 test(($aII << 3) eq '_<<_087_<<_'); # 115
374 BEGIN { $int = 7; overload::constant 'integer' => sub {$int++; shift}; }
378 test($out, 1024); # 117
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}; }
388 $out2 = "a\a$foo,\,";
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
399 test("@qr", "b\\b qq .\\. qq"); # 125
403 $_ = '!<b>!foo!<-.>!';
404 BEGIN { overload::constant 'q' => sub {push @q1, shift, ($_[1] || 'none'); "_<" . (shift) . ">_"},
405 'qr' => sub {push @qr1, shift, ($_[1] || 'none'); "!<" . (shift) . ">!"}; }
408 $out2 = "a\a$foo,\,";
418 s'first part'second part';
419 s/yet another/tail here/;
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
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
435 test($c, "bareword"); # 135
438 package symbolic; # Primitive symbolic calculator
439 use overload nomethod => \&wrap, '""' => \&str, '0+' => \&num,
440 '=' => \&cpy, '++' => \&inc, '--' => \&dec;
442 sub new { shift; bless ['n', @_] }
445 bless [@$self], ref $self;
447 sub inc { $_[0] = bless ['++', $_[0], 1]; }
448 sub dec { $_[0] = bless ['--', $_[0], 1]; }
450 my ($obj, $other, $inv, $meth) = @_;
451 if ($meth eq '++' or $meth eq '--') {
452 @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference
455 ($obj, $other) = ($other, $obj) if $inv;
456 bless [$meth, $obj, $other];
459 my ($meth, $a, $b) = @{+shift};
460 $a = 'u' unless defined $a;
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()}";
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()}";
475 foreach my $op (split " ", "@overload::ops{qw(unary func)}") {
476 $subr{$op} = eval "sub {$op shift()}";
478 $subr{'++'} = $subr{'+'};
479 $subr{'--'} = $subr{'-'};
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__;
489 sub TIESCALAR { my $pack = shift; $pack->new(@_) }
491 sub nop { } # Around a bug
492 sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; }
496 @$obj->[0,1] = ('=', shift);
501 my $foo = new symbolic 11;
503 test( (sprintf "%d", $foo), '12');
504 test( (sprintf "%d", $baz), '11');
507 test( (sprintf "%d", $foo), '13');
508 test( (sprintf "%d", $bar), '12');
509 test( (sprintf "%d", $baz), '13');
512 test( (sprintf "%d", $foo), '14');
513 test( (sprintf "%d", $bar), '12');
514 test( (sprintf "%d", $baz), '14');
515 test( (sprintf "%d", $ban), '13');
518 test( (sprintf "%d", $foo), '15');
519 test( (sprintf "%d", $baz), '14');
520 test( "$foo", '[++ [+= [++ [++ [n 11] 1] 1] 1] 1]');
524 my $iter = new symbolic 2;
525 my $side = new symbolic 1;
529 $cnt = $cnt - 1; # The "simple" way
530 $side = (sqrt(1 + $side**2) - 1)/$side;
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');
538 my $iter = new symbolic 2;
539 my $side = new symbolic 1;
543 $side = (sqrt(1 + $side**2) - 1)/$side;
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');
552 symbolic->vars($a, $b);
553 my $c = sqrt($a**2 + $b**2);
555 test( (sprintf "%d", $c), '5');
557 test( (sprintf "%d", $c), '13');
561 package symbolic1; # Primitive symbolic calculator
563 use overload nomethod => \&wrap, '""' => \&str, '0+' => \&num, '=' => \&cpy;
565 sub new { shift; bless ['n', @_] }
568 bless [@$self], ref $self;
571 my ($obj, $other, $inv, $meth) = @_;
572 if ($meth eq '++' or $meth eq '--') {
573 @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference
576 ($obj, $other) = ($other, $obj) if $inv;
577 bless [$meth, $obj, $other];
580 my ($meth, $a, $b) = @{+shift};
581 $a = 'u' unless defined $a;
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()}";
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()}";
596 foreach my $op (split " ", "@overload::ops{qw(unary func)}") {
597 $subr{$op} = eval "sub {$op shift()}";
599 $subr{'++'} = $subr{'+'};
600 $subr{'--'} = $subr{'-'};
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__;
610 sub TIESCALAR { my $pack = shift; $pack->new(@_) }
612 sub nop { } # Around a bug
613 sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; }
617 @$obj->[0,1] = ('=', shift);
622 my $foo = new symbolic1 11;
624 test( (sprintf "%d", $foo), '12');
625 test( (sprintf "%d", $baz), '11');
628 test( (sprintf "%d", $foo), '13');
629 test( (sprintf "%d", $bar), '12');
630 test( (sprintf "%d", $baz), '13');
633 test( (sprintf "%d", $foo), '14');
634 test( (sprintf "%d", $bar), '12');
635 test( (sprintf "%d", $baz), '14');
636 test( (sprintf "%d", $ban), '13');
639 test( (sprintf "%d", $foo), '15');
640 test( (sprintf "%d", $baz), '14');
641 test( "$foo", '[++ [+= [++ [++ [n 11] 1] 1] 1] 1]');
645 my $iter = new symbolic1 2;
646 my $side = new symbolic1 1;
650 $cnt = $cnt - 1; # The "simple" way
651 $side = (sqrt(1 + $side**2) - 1)/$side;
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');
659 my $iter = new symbolic1 2;
660 my $side = new symbolic1 1;
664 $side = (sqrt(1 + $side**2) - 1)/$side;
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');
673 symbolic1->vars($a, $b);
674 my $c = sqrt($a**2 + $b**2);
676 test( (sprintf "%d", $c), '5');
678 test( (sprintf "%d", $c), '13');
682 package two_face; # Scalars with separate string and
684 sub new { my $p = shift; bless [@_], $p }
685 use overload '""' => \&str, '0+' => \&num, fallback => 1;
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')
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 }
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';
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--; }
716 my $iter = iterator->new(5);
719 $acc .= " $out" while $out = <${iter}>;
720 test $acc, ' 5 4 3 2 1 0'; # 175
721 $iter = iterator->new(5);
722 test scalar <${iter}>, '5'; # 176
724 $acc .= " $out" while $out = <$iter>;
725 test $acc, ' 4 3 2 1 0'; # 177
729 use overload '%{}' => \&hderef, '&{}' => \&cderef,
730 '*{}' => \&gderef, '${}' => \&sderef, '@{}' => \&aderef;
731 sub new { my ($p, $v) = @_; bless \$v, $p }
733 my ($self, $key) = (shift, shift);
734 my $class = ref $self;
735 bless $self, 'deref::dummy'; # Disable overloading of %{}
736 my $out = $self->{$key};
737 bless $self, $class; # Restore overloading
740 sub hderef {shift->deref('h')}
741 sub aderef {shift->deref('a')}
742 sub cderef {shift->deref('c')}
743 sub gderef {shift->deref('g')}
744 sub sderef {shift->deref('s')}
747 my $deref = bless { h => { foo => 5 , fake => 23 },
748 c => sub {return shift() + 34},
754 my @cont = sort %$deref;
755 test "@cont", '23 5 fake foo'; # 178
756 my @keys = sort keys %$deref;
757 test "@keys", 'fake foo'; # 179
758 my @val = sort values %$deref;
759 test "@val", '23 5'; # 180
760 test $deref->{foo}, 5; # 181
761 test defined $deref->{bar}, ''; # 182
764 push @keys, $key while $key = each %$deref;
766 test "@keys", 'fake foo'; # 183
767 test exists $deref->{bar}, ''; # 184
768 test exists $deref->{foo}, 1; # 185
770 test $deref->(5), 39; # 186
771 test &$deref(6), 40; # 187
772 sub xxx_goto { goto &$deref }
773 test xxx_goto(7), 41; # 188
774 my $srt = bless { c => sub {$b <=> $a}
777 my @sorted = sort srt 11, 2, 5, 1, 22;
778 test "@sorted", '22 11 5 2 1'; # 189
780 test $$deref, 123; # 190
782 @sorted = sort $srt 11, 2, 5, 1, 22;
783 test "@sorted", '22 11 5 2 1'; # 191
785 test "@$deref", '11 12 13'; # 192
786 test $#$deref, '2'; # 193
789 test $deref->[2], '13'; # 195
793 test $deref->[$l], '12'; # 197
794 # Repeated dereference
795 my $double = bless { h => $deref,
797 test $double->{foo}, 5; # 198
802 use overload '%{}' => \&gethash, '@{}' => sub { ${shift()} };
810 tie %h, ref $self, $self;
814 sub TIEHASH { my $p = shift; bless \ shift, $p }
817 $fields{$_} = $i++ foreach qw{zero one two three};
819 my $self = ${shift()};
820 my $key = $fields{shift()};
821 defined $key or die "Out of band access";
822 $$self->[$key] = shift;
825 my $self = ${shift()};
826 my $key = $fields{shift()};
827 defined $key or die "Out of band access";
832 my $bar = new two_refs 3,4,5,6;
834 test $bar->{two}, 11; # 199
836 test $bar->[3], 13; # 200
843 $bar = new two_refs_o 3,4,5,6;
845 test $bar->{two}, 11; # 201
847 test $bar->[3], 13; # 202
851 use overload '%{}' => sub { ${shift()}->[1] },
852 '@{}' => sub { ${shift()}->[0] };
858 bless \ [$a, \%h], $p;
863 tie %h, ref $self, $self;
867 sub TIEHASH { my $p = shift; bless \ shift, $p }
870 $fields{$_} = $i++ foreach qw{zero one two three};
873 my $key = $fields{shift()};
874 defined $key or die "Out of band access";
879 my $key = $fields{shift()};
880 defined $key or die "Out of band access";
885 $bar = new two_refs_o 3,4,5,6;
887 test $bar->{two}, 11; # 203
889 test $bar->[3], 13; # 204
893 @ISA = ('two_refs1');
896 $bar = new two_refs1_o 3,4,5,6;
898 test $bar->{two}, 11; # 205
900 test $bar->[3], 13; # 206
904 use overload bool => sub { ${+shift} };
908 { my $bbbb = 0; $aaa = bless \$bbbb, B }