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