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