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";
52 $comment = " # " . $_ [2] if @_ > 2;
54 print "ok $test$comment\n";
56 $comment .= ": '$_[0]' ne '$_[1]'";
57 print "not ok $test$comment\n";
63 print "not ok $test\n";
68 $a = new Oscalar "087";
71 # All test numbers in comments are off by 1.
72 # So much for hard-wiring them in :-) To fix this:
76 test ($b eq "087"); # 3
77 test (ref $a eq "Oscalar"); # 4
79 test ($a eq "087"); # 6
83 test (ref $c eq "Oscalar"); # 7
84 test (!($c eq $a)); # 8
85 test ($c eq "94"); # 9
89 test (ref $a eq "Oscalar"); # 10
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
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
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
114 eval q[ package Oscalar; use overload ('++' => sub { $ {$_[0]}++;$_[0] } ) ];
118 test (ref $a eq "Oscalar"); # 23
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
128 $dummy=bless \$dummy; # Now cache of method should be reloaded
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
139 undef $b; # Destroying updates tables too...
141 eval q[package Oscalar; use overload ('++' => sub { $ {$_[0]} += 2; $_[0] } ) ];
145 test (ref $a eq "Oscalar"); # 32
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
155 $dummy=bless \$dummy; # Now cache of method should be reloaded
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
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
176 eval q[ package Oscalar; use overload ('=' => sub {$main::copies++;
178 local $new=$ {$_[0]};
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
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
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
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
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
222 eval q[package Oscalar; use overload ('+=' => sub {$ {$_[0]} += 3*$_[1];
224 $c=new Oscalar; # Cause rehash
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
237 test (ref $b eq "Oscalar"); # 75
238 test ( $b eq "360"); # 76
239 test ($copies == 2); # 77
242 test (ref $b eq "Oscalar"); # 78
243 test ( $b eq "-360"); # 79
244 test ($copies == 2); # 80
248 test (ref $b eq "Oscalar"); # 81
249 test ( $b eq "360"); # 82
250 test ($copies == 2); # 83
254 test (ref $b eq "Oscalar"); # 84
255 test ( $b eq "360"); # 85
256 test ($copies == 2); # 86
258 eval q[package Oscalar;
259 use overload ('x' => sub {new Oscalar ( $_[2] ? "_.$_[1]._" x $ {$_[0]}
260 : "_.${$_[0]}._" x $_[1])}) ];
264 test ($a eq "_.yy.__.yy.__.yy._"); # 87
266 eval q[package Oscalar;
267 use overload ('.' => sub {new Oscalar ( $_[2] ?
268 "_.$_[1].__.$ {$_[0]}._"
269 : "_.$ {$_[0]}.__.$_[1]._")}) ];
273 test ("b${a}c" eq "_._.b.__.xx._.__.c._"); # 88
275 # Check inheritance of overloading;
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
287 # Here we test blessing to a package updates hash
289 eval "package Oscalar; no overload '.'";
291 test ("b${a}" eq "_.b.__.xx._"); # 93
294 test ("b${a}c" eq "bxxc"); # 94
296 test ("b${a}c" eq "bxxc"); # 95
298 # Negative overloading:
301 test($@ =~ /no method found/); # 96
306 sub { *{"Oscalar::$AUTOLOAD"} = sub {"_!_" . shift() . "_!_"} ;
307 goto &{"Oscalar::$AUTOLOAD"}};
309 eval "package Oscalar; sub comple; use overload '~' => 'comple'";
311 $na = eval { ~$a }; # Hash was not updated
312 test($@ =~ /no method found/); # 97
316 $na = eval { ~$a }; # Hash updated
317 warn "`$na', $@" if $@;
319 test($na eq '_!_xx_!_'); # 99
323 $na = eval { ~$aI }; # Hash was not updated
324 test($@ =~ /no method found/); # 100
332 test($na eq '_!_xx_!_'); # 102
334 eval "package Oscalar; sub rshft; use overload '>>' => 'rshft'";
336 $na = eval { $aI >> 1 }; # Hash was not updated
337 test($@ =~ /no method found/); # 103
343 $na = eval { $aI >> 1 };
347 test($na eq '_!_xx_!_'); # 105
349 # warn overload::Method($a, '0+'), "\n";
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
355 test (! defined overload::Method($aI, '<<')); # 110
356 test (! defined overload::Method($a, '<')); # 111
358 test (overload::StrVal($aI) =~ /^OscalarI=SCALAR\(0x[\da-fA-F]+\)$/); # 112
359 test (overload::StrVal(\$aI) eq "@{[\$aI]}"); # 113
361 # Check overloading by methods (specified deep in the ISA tree).
365 sub Oscalar::lshft {"_<<_" . shift() . "_<<_"}
366 eval "package OscalarI; use overload '<<' => 'lshft', '|' => 'lshft'";
371 bless $aII, 'OscalarII';
372 bless \$fake, 'OscalarI'; # update the hash
373 test(($aI | 3) eq '_<<_xx_<<_'); # 114
375 test(($aII << 3) eq '_<<_087_<<_'); # 115
378 BEGIN { $int = 7; overload::constant 'integer' => sub {$int++; shift}; }
382 test($out, 1024); # 117
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}; }
392 $out2 = "a\a$foo,\,";
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
403 test("@qr", "b\\b qq .\\. qq"); # 125
407 $_ = '!<b>!foo!<-.>!';
408 BEGIN { overload::constant 'q' => sub {push @q1, shift, ($_[1] || 'none'); "_<" . (shift) . ">_"},
409 'qr' => sub {push @qr1, shift, ($_[1] || 'none'); "!<" . (shift) . ">!"}; }
412 $out2 = "a\a$foo,\,";
422 s'first part'second part';
423 s/yet another/tail here/;
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
432 q second part q tail here s A-Z tr a-z tr"); # 130
433 test("@qr1", "b\\b qq .\\. qq try it q first part q yet another qq"); # 131
439 test($c, "bareword"); # 135
442 package symbolic; # Primitive symbolic calculator
443 use overload nomethod => \&wrap, '""' => \&str, '0+' => \&num,
444 '=' => \&cpy, '++' => \&inc, '--' => \&dec;
446 sub new { shift; bless ['n', @_] }
449 bless [@$self], ref $self;
451 sub inc { $_[0] = bless ['++', $_[0], 1]; }
452 sub dec { $_[0] = bless ['--', $_[0], 1]; }
454 my ($obj, $other, $inv, $meth) = @_;
455 if ($meth eq '++' or $meth eq '--') {
456 @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference
459 ($obj, $other) = ($other, $obj) if $inv;
460 bless [$meth, $obj, $other];
463 my ($meth, $a, $b) = @{+shift};
464 $a = 'u' unless defined $a;
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()}";
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()}";
479 foreach my $op (split " ", "@overload::ops{qw(unary func)}") {
480 $subr{$op} = eval "sub {$op shift()}";
482 $subr{'++'} = $subr{'+'};
483 $subr{'--'} = $subr{'-'};
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__;
493 sub TIESCALAR { my $pack = shift; $pack->new(@_) }
495 sub nop { } # Around a bug
496 sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; }
505 my $foo = new symbolic 11;
507 test( (sprintf "%d", $foo), '12');
508 test( (sprintf "%d", $baz), '11');
511 test( (sprintf "%d", $foo), '13');
512 test( (sprintf "%d", $bar), '12');
513 test( (sprintf "%d", $baz), '13');
516 test( (sprintf "%d", $foo), '14');
517 test( (sprintf "%d", $bar), '12');
518 test( (sprintf "%d", $baz), '14');
519 test( (sprintf "%d", $ban), '13');
522 test( (sprintf "%d", $foo), '15');
523 test( (sprintf "%d", $baz), '14');
524 test( "$foo", '[++ [+= [++ [++ [n 11] 1] 1] 1] 1]');
528 my $iter = new symbolic 2;
529 my $side = new symbolic 1;
533 $cnt = $cnt - 1; # The "simple" way
534 $side = (sqrt(1 + $side**2) - 1)/$side;
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');
542 my $iter = new symbolic 2;
543 my $side = new symbolic 1;
547 $side = (sqrt(1 + $side**2) - 1)/$side;
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');
556 symbolic->vars($a, $b);
557 my $c = sqrt($a**2 + $b**2);
559 test( (sprintf "%d", $c), '5');
561 test( (sprintf "%d", $c), '13');
565 package symbolic1; # Primitive symbolic calculator
567 use overload nomethod => \&wrap, '""' => \&str, '0+' => \&num, '=' => \&cpy;
569 sub new { shift; bless ['n', @_] }
572 bless [@$self], ref $self;
575 my ($obj, $other, $inv, $meth) = @_;
576 if ($meth eq '++' or $meth eq '--') {
577 @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference
580 ($obj, $other) = ($other, $obj) if $inv;
581 bless [$meth, $obj, $other];
584 my ($meth, $a, $b) = @{+shift};
585 $a = 'u' unless defined $a;
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()}";
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()}";
600 foreach my $op (split " ", "@overload::ops{qw(unary func)}") {
601 $subr{$op} = eval "sub {$op shift()}";
603 $subr{'++'} = $subr{'+'};
604 $subr{'--'} = $subr{'-'};
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__;
614 sub TIESCALAR { my $pack = shift; $pack->new(@_) }
616 sub nop { } # Around a bug
617 sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; }
626 my $foo = new symbolic1 11;
628 test( (sprintf "%d", $foo), '12');
629 test( (sprintf "%d", $baz), '11');
632 test( (sprintf "%d", $foo), '13');
633 test( (sprintf "%d", $bar), '12');
634 test( (sprintf "%d", $baz), '13');
637 test( (sprintf "%d", $foo), '14');
638 test( (sprintf "%d", $bar), '12');
639 test( (sprintf "%d", $baz), '14');
640 test( (sprintf "%d", $ban), '13');
643 test( (sprintf "%d", $foo), '15');
644 test( (sprintf "%d", $baz), '14');
645 test( "$foo", '[++ [+= [++ [++ [n 11] 1] 1] 1] 1]');
649 my $iter = new symbolic1 2;
650 my $side = new symbolic1 1;
654 $cnt = $cnt - 1; # The "simple" way
655 $side = (sqrt(1 + $side**2) - 1)/$side;
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');
663 my $iter = new symbolic1 2;
664 my $side = new symbolic1 1;
668 $side = (sqrt(1 + $side**2) - 1)/$side;
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');
677 symbolic1->vars($a, $b);
678 my $c = sqrt($a**2 + $b**2);
680 test( (sprintf "%d", $c), '5');
682 test( (sprintf "%d", $c), '13');
686 package two_face; # Scalars with separate string and
688 sub new { my $p = shift; bless [@_], $p }
689 use overload '""' => \&str, '0+' => \&num, fallback => 1;
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')
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 }
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';
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--; }
720 # XXX iterator overload not intended to work with CORE::GLOBAL?
721 if (defined &CORE::GLOBAL::glob) {
727 my $iter = iterator->new(5);
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
735 $acc .= " $out" while $out = <$iter>;
736 test $acc, ' 4 3 2 1 0'; # 177
740 use overload '%{}' => \&hderef, '&{}' => \&cderef,
741 '*{}' => \&gderef, '${}' => \&sderef, '@{}' => \&aderef;
742 sub new { my ($p, $v) = @_; bless \$v, $p }
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
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')}
758 my $deref = bless { h => { foo => 5 , fake => 23 },
759 c => sub {return shift() + 34},
765 my @cont = sort %$deref;
766 if ("\t" eq "\011") { # ascii
767 test "@cont", '23 5 fake foo'; # 178
769 else { # ebcdic alpha-numeric sort order
770 test "@cont", 'fake foo 23 5'; # 178
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
780 push @keys, $key while $key = each %$deref;
782 test "@keys", 'fake foo'; # 183
783 test exists $deref->{bar}, ''; # 184
784 test exists $deref->{foo}, 1; # 185
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}
793 my @sorted = sort srt 11, 2, 5, 1, 22;
794 test "@sorted", '22 11 5 2 1'; # 189
796 test $$deref, 123; # 190
798 @sorted = sort $srt 11, 2, 5, 1, 22;
799 test "@sorted", '22 11 5 2 1'; # 191
801 test "@$deref", '11 12 13'; # 192
802 test $#$deref, '2'; # 193
805 test $deref->[2], '13'; # 195
809 test $deref->[$l], '12'; # 197
810 # Repeated dereference
811 my $double = bless { h => $deref,
813 test $double->{foo}, 5; # 198
818 use overload '%{}' => \&gethash, '@{}' => sub { ${shift()} };
826 tie %h, ref $self, $self;
830 sub TIEHASH { my $p = shift; bless \ shift, $p }
833 $fields{$_} = $i++ foreach qw{zero one two three};
835 my $self = ${shift()};
836 my $key = $fields{shift()};
837 defined $key or die "Out of band access";
838 $$self->[$key] = shift;
841 my $self = ${shift()};
842 my $key = $fields{shift()};
843 defined $key or die "Out of band access";
848 my $bar = new two_refs 3,4,5,6;
850 test $bar->{two}, 11; # 199
852 test $bar->[3], 13; # 200
859 $bar = new two_refs_o 3,4,5,6;
861 test $bar->{two}, 11; # 201
863 test $bar->[3], 13; # 202
867 use overload '%{}' => sub { ${shift()}->[1] },
868 '@{}' => sub { ${shift()}->[0] };
874 bless \ [$a, \%h], $p;
879 tie %h, ref $self, $self;
883 sub TIEHASH { my $p = shift; bless \ shift, $p }
886 $fields{$_} = $i++ foreach qw{zero one two three};
889 my $key = $fields{shift()};
890 defined $key or die "Out of band access";
895 my $key = $fields{shift()};
896 defined $key or die "Out of band access";
901 $bar = new two_refs_o 3,4,5,6;
903 test $bar->{two}, 11; # 203
905 test $bar->[3], 13; # 204
909 @ISA = ('two_refs1');
912 $bar = new two_refs1_o 3,4,5,6;
914 test $bar->{two}, 11; # 205
916 test $bar->[3], 13; # 206
920 use overload bool => sub { ${+shift} };
924 { my $bbbb = 0; $aaa = bless \$bbbb, B }
929 test 'ok', 'ok'; # 208
931 test 'is not', 'ok'; # 208
934 # check that overload isn't done twice by join
937 use overload '""' => sub { $c++ };
938 my $x = join '', bless([]), 'pq', bless([]);
939 main::test $x, '0pq1'; # 209
942 # Test module-specific warning
944 # check the Odd number of arguments for overload::constant warning
946 local $SIG{__WARN__} = sub {$a = $_[0]} ;
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
955 # check the `$_[0]' is not an overloadable type warning
957 local $SIG{__WARN__} = sub {$a = $_[0]} ;
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
966 # check the `$_[1]' is not a code reference warning
968 local $SIG{__WARN__} = sub {$a = $_[0]} ;
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
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}
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}
991 use overload '""' => sub { 2+shift->[0] },
992 '0+' => sub { 9+shift->[0] };
993 sub new {my $p = shift; bless [shift], $p}
997 my $x = new noov_int 11;
999 main::test("$int_x" eq 20); # 216
1000 $x = new ov_int1 31;
1002 main::test("$int_x" eq 131); # 217
1003 $x = new ov_int2 51;
1005 main::test("$int_x" eq 1054); # 218
1008 # make sure that we don't inifinitely recurse
1012 use overload '""' => sub { shift },
1013 '0+' => sub { shift },
1014 'bool' => sub { shift },
1017 main::test("$x" =~ /Recurse=ARRAY/); # 219
1018 main::test($x); # 220
1019 main::test($x+0 =~ /Recurse=ARRAY/); # 221
1022 # BugID 20010422.003
1026 'bool' => sub { return !$_[0]->is_zero() || undef; }
1032 return $self->{var} == 0;
1039 $self->{var} = shift;
1047 my $r = Foo->new(8);
1050 test(($r || 0) == 0); # 222
1055 '""' => sub { return $_[0]->{var}; }
1062 $self->{var} = shift;
1069 my $utfvar = new utf8_o 200.2.1;
1070 test("$utfvar" eq 200.2.1); # 223 - stringify
1071 test("a$utfvar" eq "a".200.2.1); # 224 - overload via sv_2pv_flags
1073 # 225..227 -- more %{} tests. Hangs in 5.6.0, okay in later releases.
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.
1078 use overload '%{}' => sub { (caller(0))[0] eq 'Foo' ? $_[0] : die "zap" };
1080 @Foo::ISA = 'Hderef';
1081 sub new { bless {}, shift }
1082 sub xet { @_ == 2 ? $_[0]->{$_[1]} :
1083 @_ == 3 ? ($_[0]->{$_[1]} = $_[2]) : undef }
1087 test ($a->xet('b'), 42);
1088 test (!defined eval { $a->{b} });
1091 test (overload::StrVal(qr/a/) =~ /^Regexp=SCALAR\(0x[0-9a-f]+\)$/);
1095 use overload '=' => sub { 42 },
1096 '++' => sub { my $x = ${$_[0]}; $_[0] };
1097 sub new { my $x = 42; bless \$x }
1101 local $SIG{__WARN__} = sub { $warn++ };
1106 main::test (!$warn);
1110 my ($int, $out1, $out2);
1112 BEGIN { $int = 0; overload::constant 'integer' => sub {$int++; 17}; }
1116 test($int, 2, "#24313"); # 230
1117 test($out1, 17, "#24313"); # 231
1118 test($out2, 17, "#24313"); # 232