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