This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Additions to README.win32 and win32/Makefile based on comments from
[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 50$| = 1;
11e3e2e4 51use Test::More tests=>498;
8ebc5c01
PP
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";
0bdaccee 60 return 1;
b3ac6de7 61 } else {
61f33854
RGS
62 $comment .= ": '$_[0]' ne '$_[1]'";
63 print "not ok $test$comment\n";
0bdaccee 64 return 0;
b3ac6de7
IZ
65 }
66 } else {
67 if (shift) {
68 print "ok $test\n";
0bdaccee 69 return 1;
b3ac6de7
IZ
70 } else {
71 print "not ok $test\n";
0bdaccee
NC
72 return 0;
73 }
b3ac6de7 74 }
8ebc5c01
PP
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
PP
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
PP
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
PP
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
PP
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
PP
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
PP
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
IZ
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
IZ
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
IZ
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
IZ
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
IZ
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
IZ
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{
7bf00c86
NC
711 my $Test = Test::Builder->new;
712 $Test->current_test(173);
713}
714{
d0ecd44c
IZ
715 package sorting;
716 use overload 'cmp' => \&comp;
717 sub new { my ($p, $v) = @_; bless \$v, $p }
718 sub comp { my ($x,$y) = @_; ($$x * 3 % 10) <=> ($$y * 3 % 10) or $$x cmp $$y }
719}
720{
721 my @arr = map sorting->new($_), 0..12;
722 my @sorted1 = sort @arr;
723 my @sorted2 = map $$_, @sorted1;
7bf00c86 724 is("@sorted2", '0 10 7 4 1 11 8 5 12 2 9 6 3');
d0ecd44c 725}
f5284f61
IZ
726{
727 package iterator;
728 use overload '<>' => \&iter;
729 sub new { my ($p, $v) = @_; bless \$v, $p }
730 sub iter { my ($x) = @_; return undef if $$x < 0; return $$x--; }
731}
72b16652
GS
732
733# XXX iterator overload not intended to work with CORE::GLOBAL?
734if (defined &CORE::GLOBAL::glob) {
7bf00c86
NC
735 is('1', '1');
736 is('1', '1');
737 is('1', '1');
72b16652
GS
738}
739else {
f5284f61
IZ
740 my $iter = iterator->new(5);
741 my $acc = '';
742 my $out;
743 $acc .= " $out" while $out = <${iter}>;
7bf00c86 744 is($acc, ' 5 4 3 2 1 0');
f5284f61 745 $iter = iterator->new(5);
7bf00c86 746 is(scalar <${iter}>, '5');
f5284f61 747 $acc = '';
b04ef359 748 $acc .= " $out" while $out = <$iter>;
7bf00c86 749 is($acc, ' 4 3 2 1 0');
f5284f61
IZ
750}
751{
752 package deref;
753 use overload '%{}' => \&hderef, '&{}' => \&cderef,
754 '*{}' => \&gderef, '${}' => \&sderef, '@{}' => \&aderef;
755 sub new { my ($p, $v) = @_; bless \$v, $p }
756 sub deref {
757 my ($self, $key) = (shift, shift);
758 my $class = ref $self;
759 bless $self, 'deref::dummy'; # Disable overloading of %{}
760 my $out = $self->{$key};
761 bless $self, $class; # Restore overloading
762 $out;
763 }
764 sub hderef {shift->deref('h')}
765 sub aderef {shift->deref('a')}
766 sub cderef {shift->deref('c')}
767 sub gderef {shift->deref('g')}
768 sub sderef {shift->deref('s')}
769}
770{
771 my $deref = bless { h => { foo => 5 , fake => 23 },
772 c => sub {return shift() + 34},
773 's' => \123,
774 a => [11..13],
775 g => \*srt,
776 }, 'deref';
777 # Hash:
778 my @cont = sort %$deref;
f70c35af 779 if ("\t" eq "\011") { # ascii
7bf00c86 780 is("@cont", '23 5 fake foo');
f70c35af
GS
781 }
782 else { # ebcdic alpha-numeric sort order
7bf00c86 783 is("@cont", 'fake foo 23 5');
f70c35af 784 }
f5284f61 785 my @keys = sort keys %$deref;
7bf00c86 786 is("@keys", 'fake foo');
f5284f61 787 my @val = sort values %$deref;
7bf00c86
NC
788 is("@val", '23 5');
789 is($deref->{foo}, 5);
790 is(defined $deref->{bar}, '');
f5284f61
IZ
791 my $key;
792 @keys = ();
793 push @keys, $key while $key = each %$deref;
794 @keys = sort @keys;
7bf00c86
NC
795 is("@keys", 'fake foo');
796 is(exists $deref->{bar}, '');
797 is(exists $deref->{foo}, 1);
f5284f61 798 # Code:
7bf00c86
NC
799 is($deref->(5), 39);
800 is(&$deref(6), 40);
f5284f61 801 sub xxx_goto { goto &$deref }
7bf00c86 802 is(xxx_goto(7), 41);
f5284f61
IZ
803 my $srt = bless { c => sub {$b <=> $a}
804 }, 'deref';
805 *srt = \&$srt;
806 my @sorted = sort srt 11, 2, 5, 1, 22;
7bf00c86 807 is("@sorted", '22 11 5 2 1');
f5284f61 808 # Scalar
7bf00c86 809 is($$deref, 123);
c6e96bcb
GS
810 # Code
811 @sorted = sort $srt 11, 2, 5, 1, 22;
7bf00c86 812 is("@sorted", '22 11 5 2 1');
f5284f61 813 # Array
7bf00c86
NC
814 is("@$deref", '11 12 13');
815 is($#$deref, '2');
f5284f61 816 my $l = @$deref;
7bf00c86
NC
817 is($l, 3);
818 is($deref->[2], '13');
f5284f61 819 $l = pop @$deref;
7bf00c86 820 is($l, 13);
f5284f61 821 $l = 1;
7bf00c86 822 is($deref->[$l], '12');
f5284f61
IZ
823 # Repeated dereference
824 my $double = bless { h => $deref,
825 }, 'deref';
7bf00c86 826 is($double->{foo}, 5);
f5284f61
IZ
827}
828
829{
830 package two_refs;
831 use overload '%{}' => \&gethash, '@{}' => sub { ${shift()} };
832 sub new {
833 my $p = shift;
834 bless \ [@_], $p;
835 }
836 sub gethash {
837 my %h;
838 my $self = shift;
839 tie %h, ref $self, $self;
840 \%h;
841 }
842
843 sub TIEHASH { my $p = shift; bless \ shift, $p }
844 my %fields;
845 my $i = 0;
846 $fields{$_} = $i++ foreach qw{zero one two three};
847 sub STORE {
848 my $self = ${shift()};
849 my $key = $fields{shift()};
850 defined $key or die "Out of band access";
851 $$self->[$key] = shift;
852 }
853 sub FETCH {
854 my $self = ${shift()};
855 my $key = $fields{shift()};
856 defined $key or die "Out of band access";
857 $$self->[$key];
858 }
859}
860
861my $bar = new two_refs 3,4,5,6;
862$bar->[2] = 11;
7bf00c86 863is($bar->{two}, 11);
f5284f61 864$bar->{three} = 13;
7bf00c86 865is($bar->[3], 13);
f5284f61
IZ
866
867{
868 package two_refs_o;
869 @ISA = ('two_refs');
870}
871
872$bar = new two_refs_o 3,4,5,6;
873$bar->[2] = 11;
7bf00c86 874is($bar->{two}, 11);
f5284f61 875$bar->{three} = 13;
7bf00c86 876is($bar->[3], 13);
f5284f61
IZ
877
878{
879 package two_refs1;
880 use overload '%{}' => sub { ${shift()}->[1] },
881 '@{}' => sub { ${shift()}->[0] };
882 sub new {
883 my $p = shift;
884 my $a = [@_];
885 my %h;
886 tie %h, $p, $a;
887 bless \ [$a, \%h], $p;
888 }
889 sub gethash {
890 my %h;
891 my $self = shift;
892 tie %h, ref $self, $self;
893 \%h;
894 }
895
896 sub TIEHASH { my $p = shift; bless \ shift, $p }
897 my %fields;
898 my $i = 0;
899 $fields{$_} = $i++ foreach qw{zero one two three};
900 sub STORE {
901 my $a = ${shift()};
902 my $key = $fields{shift()};
903 defined $key or die "Out of band access";
904 $a->[$key] = shift;
905 }
906 sub FETCH {
907 my $a = ${shift()};
908 my $key = $fields{shift()};
909 defined $key or die "Out of band access";
910 $a->[$key];
911 }
912}
913
914$bar = new two_refs_o 3,4,5,6;
915$bar->[2] = 11;
7bf00c86 916is($bar->{two}, 11);
f5284f61 917$bar->{three} = 13;
7bf00c86 918is($bar->[3], 13);
f5284f61
IZ
919
920{
921 package two_refs1_o;
922 @ISA = ('two_refs1');
923}
924
925$bar = new two_refs1_o 3,4,5,6;
926$bar->[2] = 11;
7bf00c86 927is($bar->{two}, 11);
f5284f61 928$bar->{three} = 13;
7bf00c86 929is($bar->[3], 13);
f5284f61 930
fe7ac86a
IZ
931{
932 package B;
933 use overload bool => sub { ${+shift} };
934}
935
936my $aaa;
937{ my $bbbb = 0; $aaa = bless \$bbbb, B }
938
7bf00c86 939is !$aaa, 1;
fe7ac86a
IZ
940
941unless ($aaa) {
7bf00c86 942 pass();
fe7ac86a 943} else {
7bf00c86 944 fail();
fe7ac86a
IZ
945}
946
1426bbf4
MG
947# check that overload isn't done twice by join
948{ my $c = 0;
949 package Join;
950 use overload '""' => sub { $c++ };
951 my $x = join '', bless([]), 'pq', bless([]);
7bf00c86 952 main::is $x, '0pq1';
1426bbf4 953};
fe7ac86a 954
4498a751
PM
955# Test module-specific warning
956{
957 # check the Odd number of arguments for overload::constant warning
958 my $a = "" ;
0a911d86 959 local $SIG{__WARN__} = sub {$a = $_[0]} ;
4498a751 960 $x = eval ' overload::constant "integer" ; ' ;
7bf00c86 961 is($a, "");
4498a751
PM
962 use warnings 'overload' ;
963 $x = eval ' overload::constant "integer" ; ' ;
7bf00c86 964 like($a, qr/^Odd number of arguments for overload::constant at/);
4498a751
PM
965}
966
967{
968 # check the `$_[0]' is not an overloadable type warning
969 my $a = "" ;
0a911d86 970 local $SIG{__WARN__} = sub {$a = $_[0]} ;
4498a751 971 $x = eval ' overload::constant "fred" => sub {} ; ' ;
7bf00c86 972 is($a, "");
4498a751
PM
973 use warnings 'overload' ;
974 $x = eval ' overload::constant "fred" => sub {} ; ' ;
7bf00c86 975 like($a, qr/^`fred' is not an overloadable type at/);
4498a751
PM
976}
977
978{
979 # check the `$_[1]' is not a code reference warning
980 my $a = "" ;
0a911d86 981 local $SIG{__WARN__} = sub {$a = $_[0]} ;
4498a751 982 $x = eval ' overload::constant "integer" => 1; ' ;
7bf00c86 983 is($a, "");
4498a751
PM
984 use warnings 'overload' ;
985 $x = eval ' overload::constant "integer" => 1; ' ;
7bf00c86 986 like($a, qr/^`1' is not a code reference at/);
4498a751
PM
987}
988
78f67eb5
JH
989{
990 my $c = 0;
991 package ov_int1;
992 use overload '""' => sub { 3+shift->[0] },
993 '0+' => sub { 10+shift->[0] },
994 'int' => sub { 100+shift->[0] };
995 sub new {my $p = shift; bless [shift], $p}
996
997 package ov_int2;
998 use overload '""' => sub { 5+shift->[0] },
999 '0+' => sub { 30+shift->[0] },
1000 'int' => sub { 'ov_int1'->new(1000+shift->[0]) };
1001 sub new {my $p = shift; bless [shift], $p}
1002
1003 package noov_int;
1004 use overload '""' => sub { 2+shift->[0] },
1005 '0+' => sub { 9+shift->[0] };
1006 sub new {my $p = shift; bless [shift], $p}
1007
1008 package main;
1009
1010 my $x = new noov_int 11;
1011 my $int_x = int $x;
7bf00c86 1012 main::is("$int_x", 20);
78f67eb5
JH
1013 $x = new ov_int1 31;
1014 $int_x = int $x;
7bf00c86 1015 main::is("$int_x", 131);
78f67eb5
JH
1016 $x = new ov_int2 51;
1017 $int_x = int $x;
7bf00c86 1018 main::is("$int_x", 1054);
78f67eb5
JH
1019}
1020
1554e226
DC
1021# make sure that we don't inifinitely recurse
1022{
1023 my $c = 0;
1024 package Recurse;
1025 use overload '""' => sub { shift },
1026 '0+' => sub { shift },
1027 'bool' => sub { shift },
1028 fallback => 1;
1029 my $x = bless([]);
7bf00c86
NC
1030 # For some reason beyond me these have to be oks rather than likes.
1031 main::ok("$x" =~ /Recurse=ARRAY/);
1032 main::ok($x);
1033 main::ok($x+0 =~ qr/Recurse=ARRAY/);
11e3e2e4 1034}
78f67eb5 1035
1dc13c17
SC
1036# BugID 20010422.003
1037package Foo;
1038
1039use overload
1040 'bool' => sub { return !$_[0]->is_zero() || undef; }
1041;
1042
1043sub is_zero
1044 {
1045 my $self = shift;
1046 return $self->{var} == 0;
1047 }
1048
1049sub new
1050 {
1051 my $class = shift;
1052 my $self = {};
1053 $self->{var} = shift;
1054 bless $self,$class;
1055 }
1056
1057package main;
1058
1059use strict;
1060
1061my $r = Foo->new(8);
1062$r = Foo->new(0);
78f67eb5 1063
11e3e2e4 1064is(($r || 0), 0);
1554e226 1065
6050d10e
JP
1066package utf8_o;
1067
1068use overload
1069 '""' => sub { return $_[0]->{var}; }
1070 ;
1071
1072sub new
1073 {
1074 my $class = shift;
1075 my $self = {};
1076 $self->{var} = shift;
1077 bless $self,$class;
1078 }
1079
1080package main;
1081
1082
1083my $utfvar = new utf8_o 200.2.1;
11e3e2e4
NC
1084is("$utfvar", 200.2.1); # 223 - stringify
1085is("a$utfvar", "a".200.2.1); # 224 - overload via sv_2pv_flags
6050d10e 1086
446eaa42 1087# 225..227 -- more %{} tests. Hangs in 5.6.0, okay in later releases.
41cb1005
JH
1088# Basically this example implements strong encapsulation: if Hderef::import()
1089# were to eval the overload code in the caller's namespace, the privatisation
1090# would be quite transparent.
1091package Hderef;
1092use overload '%{}' => sub { (caller(0))[0] eq 'Foo' ? $_[0] : die "zap" };
1093package Foo;
1094@Foo::ISA = 'Hderef';
1095sub new { bless {}, shift }
1096sub xet { @_ == 2 ? $_[0]->{$_[1]} :
1097 @_ == 3 ? ($_[0]->{$_[1]} = $_[2]) : undef }
1098package main;
1099my $a = Foo->new;
1100$a->xet('b', 42);
11e3e2e4
NC
1101is ($a->xet('b'), 42);
1102ok (!defined eval { $a->{b} });
1103like ($@, qr/zap/);
41cb1005 1104
29ddfe35
RD
1105{
1106 package t229;
1107 use overload '=' => sub { 42 },
1108 '++' => sub { my $x = ${$_[0]}; $_[0] };
1109 sub new { my $x = 42; bless \$x }
1110
1111 my $warn;
1112 {
1113 local $SIG{__WARN__} = sub { $warn++ };
1114 my $x = t229->new;
1115 my $y = $x;
1116 eval { $y++ };
1117 }
11e3e2e4 1118 main::ok (!$warn);
61f33854
RGS
1119}
1120
1121{
1122 my ($int, $out1, $out2);
1123 {
1124 BEGIN { $int = 0; overload::constant 'integer' => sub {$int++; 17}; }
1125 $out1 = 0;
1126 $out2 = 1;
1127 }
11e3e2e4
NC
1128 is($int, 2, "#24313"); # 230
1129 is($out1, 17, "#24313"); # 231
1130 is($out2, 17, "#24313"); # 232
29ddfe35
RD
1131}
1132
0bdaccee
NC
1133{
1134 package Numify;
1135 use overload (qw(0+ numify fallback 1));
1136
1137 sub new {
1138 my $val = $_[1];
1139 bless \$val, $_[0];
1140 }
1141
1142 sub numify { ${$_[0]} }
1143}
1144
d411a6a9
RD
1145{
1146 package perl31793;
1b1d102f
RD
1147 use overload cmp => sub { 0 };
1148 package perl31793_fb;
76c43448 1149 use overload cmp => sub { 0 }, fallback => 1;
d411a6a9
RD
1150 package main;
1151 my $o = bless [], 'perl31793';
1b1d102f 1152 my $of = bless [], 'perl31793_fb';
d411a6a9 1153 my $no = bless [], 'no_overload';
11e3e2e4
NC
1154 like(overload::StrVal(\"scalar"), qr/^SCALAR\(0x[0-9a-f]+\)$/);
1155 like(overload::StrVal([]), qr/^ARRAY\(0x[0-9a-f]+\)$/);
1156 like(overload::StrVal({}), qr/^HASH\(0x[0-9a-f]+\)$/);
1157 like(overload::StrVal(sub{1}), qr/^CODE\(0x[0-9a-f]+\)$/);
1158 like(overload::StrVal(\*GLOB), qr/^GLOB\(0x[0-9a-f]+\)$/);
1159 like(overload::StrVal(\$o), qr/^REF\(0x[0-9a-f]+\)$/);
1160 like(overload::StrVal(qr/a/), qr/^Regexp=SCALAR\(0x[0-9a-f]+\)$/);
1161 like(overload::StrVal($o), qr/^perl31793=ARRAY\(0x[0-9a-f]+\)$/);
1162 like(overload::StrVal($of), qr/^perl31793_fb=ARRAY\(0x[0-9a-f]+\)$/);
1163 like(overload::StrVal($no), qr/^no_overload=ARRAY\(0x[0-9a-f]+\)$/);
d411a6a9
RD
1164}
1165
0bdaccee
NC
1166# These are all check that overloaded values rather than reference addressess
1167# are what is getting tested.
1168my ($two, $one, $un, $deux) = map {new Numify $_} 2, 1, 1, 2;
1169my ($ein, $zwei) = (1, 2);
1170
1171my %map = (one => 1, un => 1, ein => 1, deux => 2, two => 2, zwei => 2);
1172foreach my $op (qw(<=> == != < <= > >=)) {
1173 foreach my $l (keys %map) {
1174 foreach my $r (keys %map) {
1175 my $ocode = "\$$l $op \$$r";
1176 my $rcode = "$map{$l} $op $map{$r}";
1177
1178 my $got = eval $ocode;
1179 die if $@;
1180 my $expect = eval $rcode;
1181 die if $@;
11e3e2e4 1182 is ($got, $expect, $ocode) or print "# $rcode\n";
0bdaccee
NC
1183 }
1184 }
1185}
131b3ad0
DM
1186{
1187 # check that overloading works in regexes
1188 {
1189 package Foo493;
1190 use overload
1191 '""' => sub { "^$_[0][0]\$" },
1192 '.' => sub {
1193 bless [
1194 $_[2]
1195 ? (ref $_[1] ? $_[1][0] : $_[1]) . ':' .$_[0][0]
1196 : $_[0][0] . ':' . (ref $_[1] ? $_[1][0] : $_[1])
1197 ], 'Foo493'
1198 };
1199 }
1200
1201 my $a = bless [ "a" ], 'Foo493';
11e3e2e4
NC
1202 like('a', qr/$a/);
1203 like('x:a', qr/x$a/);
1204 like('x:a:=', qr/x$a=$/);
1205 like('x:a:a:=', qr/x$a$a=$/);
131b3ad0
DM
1206
1207}
1208
705c898c
RH
1209{
1210 my $twenty_three = 23;
1211 # Check that constant overloading propagates into evals
1212 BEGIN { overload::constant integer => sub { 23 } }
11e3e2e4 1213 is(eval "17", $twenty_three);
705c898c 1214}