This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
sv_2pv_flags and ROK and UTF8 flags
[perl5.git] / lib / overload.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib';
6 }
7
8 package Oscalar;
9 use 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
27 qw(
28 ""      stringify
29 0+      numify)                 # Order of arguments unsignificant
30 );
31
32 sub new {
33   my $foo = $_[1];
34   bless \$foo, $_[0];
35 }
36
37 sub stringify { "${$_[0]}" }
38 sub numify { 0 + "${$_[0]}" }   # Not needed, additional overhead
39                                 # comparing to direct compilation based on
40                                 # stringify
41
42 package main;
43
44 our $test = 0;
45 $| = 1;
46 print "1..",&last,"\n";
47
48 sub test {
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   }
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:
70 test(1);                        # 1
71
72 test ($b eq $a);                # 2
73 test ($b eq "087");             # 3
74 test (ref $a eq "Oscalar");     # 4
75 test ($a eq $a);                # 5
76 test ($a eq "087");             # 6
77
78 $c = $a + 7;
79
80 test (ref $c eq "Oscalar");     # 7
81 test (!($c eq $a));             # 8
82 test ($c eq "94");              # 9
83
84 $b=$a;
85
86 test (ref $a eq "Oscalar");     # 10
87
88 $b++;
89
90 test (ref $b eq "Oscalar");     # 11
91 test ( $a eq "087");            # 12
92 test ( $b eq "88");             # 13
93 test (ref $a eq "Oscalar");     # 14
94
95 $c=$b;
96 $c-=$a;
97
98 test (ref $c eq "Oscalar");     # 15
99 test ( $a eq "087");            # 16
100 test ( $c eq "1");              # 17
101 test (ref $a eq "Oscalar");     # 18
102
103 $b=1;
104 $b+=$a;
105
106 test (ref $b eq "Oscalar");     # 19
107 test ( $a eq "087");            # 20
108 test ( $b eq "88");             # 21
109 test (ref $a eq "Oscalar");     # 22
110
111 eval q[ package Oscalar; use overload ('++' => sub { $ {$_[0]}++;$_[0] } ) ];
112
113 $b=$a;
114
115 test (ref $a eq "Oscalar");     # 23
116
117 $b++;
118
119 test (ref $b eq "Oscalar");     # 24
120 test ( $a eq "087");            # 25
121 test ( $b eq "88");             # 26
122 test (ref $a eq "Oscalar");     # 27
123
124 package Oscalar;
125 $dummy=bless \$dummy;           # Now cache of method should be reloaded
126 package main;
127
128 $b=$a;
129 $b++;                           
130
131 test (ref $b eq "Oscalar");     # 28
132 test ( $a eq "087");            # 29
133 test ( $b eq "88");             # 30
134 test (ref $a eq "Oscalar");     # 31
135
136 undef $b;                       # Destroying updates tables too...
137
138 eval q[package Oscalar; use overload ('++' => sub { $ {$_[0]} += 2; $_[0] } ) ];
139
140 $b=$a;
141
142 test (ref $a eq "Oscalar");     # 32
143
144 $b++;
145
146 test (ref $b eq "Oscalar");     # 33
147 test ( $a eq "087");            # 34
148 test ( $b eq "88");             # 35
149 test (ref $a eq "Oscalar");     # 36
150
151 package Oscalar;
152 $dummy=bless \$dummy;           # Now cache of method should be reloaded
153 package main;
154
155 $b++;                           
156
157 test (ref $b eq "Oscalar");     # 37
158 test ( $a eq "087");            # 38
159 test ( $b eq "90");             # 39
160 test (ref $a eq "Oscalar");     # 40
161
162 $b=$a;
163 $b++;
164
165 test (ref $b eq "Oscalar");     # 41
166 test ( $a eq "087");            # 42
167 test ( $b eq "89");             # 43
168 test (ref $a eq "Oscalar");     # 44
169
170
171 test ($b? 1:0);                 # 45
172
173 eval 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
180 test (ref $b eq "Oscalar");     # 46
181 test ( $a eq "087");            # 47
182 test ( $b eq "087");            # 48
183 test (ref $a eq "Oscalar");     # 49
184
185 $b++;
186
187 test (ref $b eq "Oscalar");     # 50
188 test ( $a eq "087");            # 51
189 test ( $b eq "89");             # 52
190 test (ref $a eq "Oscalar");     # 53
191 test ($copies == 0);            # 54
192
193 $b+=1;
194
195 test (ref $b eq "Oscalar");     # 55
196 test ( $a eq "087");            # 56
197 test ( $b eq "90");             # 57
198 test (ref $a eq "Oscalar");     # 58
199 test ($copies == 0);            # 59
200
201 $b=$a;
202 $b+=1;
203
204 test (ref $b eq "Oscalar");     # 60
205 test ( $a eq "087");            # 61
206 test ( $b eq "88");             # 62
207 test (ref $a eq "Oscalar");     # 63
208 test ($copies == 0);            # 64
209
210 $b=$a;
211 $b++;
212
213 test (ref $b eq "Oscalar") || print ref $b,"=ref(b)\n"; # 65
214 test ( $a eq "087");            # 66
215 test ( $b eq "89");             # 67
216 test (ref $a eq "Oscalar");     # 68
217 test ($copies == 1);            # 69
218
219 eval 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
226 test (ref $b eq "Oscalar");     # 70
227 test ( $a eq "087");            # 71
228 test ( $b eq "90");             # 72
229 test (ref $a eq "Oscalar");     # 73
230 test ($copies == 2);            # 74
231
232 $b+=$b;
233
234 test (ref $b eq "Oscalar");     # 75
235 test ( $b eq "360");            # 76
236 test ($copies == 2);            # 77
237 $b=-$b;
238
239 test (ref $b eq "Oscalar");     # 78
240 test ( $b eq "-360");           # 79
241 test ($copies == 2);            # 80
242
243 $b=abs($b);
244
245 test (ref $b eq "Oscalar");     # 81
246 test ( $b eq "360");            # 82
247 test ($copies == 2);            # 83
248
249 $b=abs($b);
250
251 test (ref $b eq "Oscalar");     # 84
252 test ( $b eq "360");            # 85
253 test ($copies == 2);            # 86
254
255 eval 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;
261 test ($a eq "_.yy.__.yy.__.yy._"); # 87
262
263 eval q[package Oscalar; 
264        use overload ('.' => sub {new Oscalar ( $_[2] ? 
265                                               "_.$_[1].__.$ {$_[0]}._"
266                                               : "_.$ {$_[0]}.__.$_[1]._")}) ];
267
268 $a=new Oscalar "xx";
269
270 test ("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";
279 test (ref $aI eq "OscalarI");   # 89
280 test ("$aI" eq "xx");           # 90
281 test ($aI eq "xx");             # 91
282 test ("b${aI}c" eq "_._.b.__.xx._.__.c._");             # 92
283
284 # Here we test blessing to a package updates hash
285
286 eval "package Oscalar; no overload '.'";
287
288 test ("b${a}" eq "_.b.__.xx._"); # 93
289 $x="1";
290 bless \$x, Oscalar;
291 test ("b${a}c" eq "bxxc");      # 94
292 new Oscalar 1;
293 test ("b${a}c" eq "bxxc");      # 95
294
295 # Negative overloading:
296
297 $na = eval { ~$a };
298 test($@ =~ /no method found/);  # 96
299
300 # Check AUTOLOADING:
301
302 *Oscalar::AUTOLOAD = 
303   sub { *{"Oscalar::$AUTOLOAD"} = sub {"_!_" . shift() . "_!_"} ;
304         goto &{"Oscalar::$AUTOLOAD"}};
305
306 eval "package Oscalar; sub comple; use overload '~' => 'comple'";
307
308 $na = eval { ~$a };             # Hash was not updated
309 test($@ =~ /no method found/);  # 97
310
311 bless \$x, Oscalar;
312
313 $na = eval { ~$a };             # Hash updated
314 warn "`$na', $@" if $@;
315 test !$@;                       # 98
316 test($na eq '_!_xx_!_');        # 99
317
318 $na = 0;
319
320 $na = eval { ~$aI };            # Hash was not updated
321 test($@ =~ /no method found/);  # 100
322
323 bless \$x, OscalarI;
324
325 $na = eval { ~$aI };
326 print $@;
327
328 test !$@;                       # 101
329 test($na eq '_!_xx_!_');        # 102
330
331 eval "package Oscalar; sub rshft; use overload '>>' => 'rshft'";
332
333 $na = eval { $aI >> 1 };        # Hash was not updated
334 test($@ =~ /no method found/);  # 103
335
336 bless \$x, OscalarI;
337
338 $na = 0;
339
340 $na = eval { $aI >> 1 };
341 print $@;
342
343 test !$@;                       # 104
344 test($na eq '_!_xx_!_');        # 105
345
346 # warn overload::Method($a, '0+'), "\n";
347 test (overload::Method($a, '0+') eq \&Oscalar::numify); # 106
348 test (overload::Method($aI,'0+') eq \&Oscalar::numify); # 107
349 test (overload::Overloaded($aI)); # 108
350 test (!overload::Overloaded('overload')); # 109
351
352 test (! defined overload::Method($aI, '<<')); # 110
353 test (! defined overload::Method($a, '<')); # 111
354
355 test (overload::StrVal($aI) =~ /^OscalarI=SCALAR\(0x[\da-fA-F]+\)$/); # 112
356 test (overload::StrVal(\$aI) eq "@{[\$aI]}"); # 113
357
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;
368 bless $aII, 'OscalarII';
369 bless \$fake, 'OscalarI';               # update the hash
370 test(($aI | 3) eq '_<<_xx_<<_');        # 114
371 # warn $aII << 3;
372 test(($aII << 3) eq '_<<_087_<<_');     # 115
373
374 {
375   BEGIN { $int = 7; overload::constant 'integer' => sub {$int++; shift}; }
376   $out = 2**10;
377 }
378 test($int, 9);          # 116
379 test($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
393 test($out, 'foo');              # 118
394 test($out, $foo);               # 119
395 test($out1, 'f\'o\\o');         # 120
396 test($out1, $foo1);             # 121
397 test($out2, "a\afoo,\,");       # 122
398 test("@q", "foo q f'o\\\\o q a\\a qq ,\\, qq"); # 123
399 test($q, 11);                   # 124
400 test("@qr", "b\\b qq .\\. qq"); # 125
401 test($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;
412 oups
413 EOF
414   $b = <<'EOF';
415 oups1
416 EOF
417   $c = bareword;
418   m'try it';
419   s'first part'second part';
420   s/yet another/tail here/;
421   tr/A-Z/a-z/;
422 }
423
424 test($out, '_<foo>_');          # 117
425 test($out1, '_<f\'o\\o>_');             # 128
426 test($out2, "_<a\a>_foo_<,\,>_");       # 129
427 test("@q1", "foo q f'o\\\\o q a\\a qq ,\\, qq oups
428  qq oups1
429  q second part q tail here s A-Z tr a-z tr");   # 130
430 test("@qr1", "b\\b qq .\\. qq try it q first part q yet another qq");   # 131
431 test($res, 1);                  # 132
432 test($a, "_<oups
433 >_");   # 133
434 test($b, "_<oups1
435 >_");   # 134
436 test($c, "bareword");   # 135
437
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->[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->[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 }
697
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 }
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 }
716
717 # XXX iterator overload not intended to work with CORE::GLOBAL?
718 if (defined &CORE::GLOBAL::glob) {
719   test '1', '1';        # 175
720   test '1', '1';        # 176
721   test '1', '1';        # 177
722 }
723 else {
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;
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   }
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
794   # Code
795   @sorted = sort $srt 11, 2, 5, 1, 22;
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
845 my $bar = new two_refs 3,4,5,6;
846 $bar->[2] = 11;
847 test $bar->{two}, 11;           # 199
848 $bar->{three} = 13;
849 test $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;
858 test $bar->{two}, 11;           # 201
859 $bar->{three} = 13;
860 test $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;
900 test $bar->{two}, 11;           # 203
901 $bar->{three} = 13;
902 test $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;
911 test $bar->{two}, 11;           # 205
912 $bar->{three} = 13;
913 test $bar->[3], 13;             # 206
914
915 {
916   package B;
917   use overload bool => sub { ${+shift} };
918 }
919
920 my $aaa;
921 { my $bbbb = 0; $aaa = bless \$bbbb, B }
922
923 test !$aaa, 1;                  # 207
924
925 unless ($aaa) {
926   test 'ok', 'ok';              # 208
927 } else {
928   test 'is not', 'ok';          # 208
929 }
930
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 };
938
939 # Test module-specific warning
940 {
941     # check the Odd number of arguments for overload::constant warning
942     my $a = "" ;
943     local $SIG{__WARN__} = sub {$a = $_[0]} ;
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 = "" ;
954     local $SIG{__WARN__} = sub {$a = $_[0]} ;
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 = "" ;
965     local $SIG{__WARN__} = sub {$a = $_[0]} ;
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
973 {
974   my $c = 0;
975   package ov_int1;
976   use overload '""'    => sub { 3+shift->[0] },
977                '0+'    => sub { 10+shift->[0] },
978                'int'   => sub { 100+shift->[0] };
979   sub new {my $p = shift; bless [shift], $p}
980
981   package ov_int2;
982   use overload '""'    => sub { 5+shift->[0] },
983                '0+'    => sub { 30+shift->[0] },
984                'int'   => sub { 'ov_int1'->new(1000+shift->[0]) };
985   sub new {my $p = shift; bless [shift], $p}
986
987   package noov_int;
988   use overload '""'    => sub { 2+shift->[0] },
989                '0+'    => sub { 9+shift->[0] };
990   sub new {my $p = shift; bless [shift], $p}
991
992   package main;
993
994   my $x = new noov_int 11;
995   my $int_x = int $x;
996   main::test("$int_x" eq 20);                   # 216
997   $x = new ov_int1 31;
998   $int_x = int $x;
999   main::test("$int_x" eq 131);                  # 217
1000   $x = new ov_int2 51;
1001   $int_x = int $x;
1002   main::test("$int_x" eq 1054);                 # 218
1003 }
1004
1005 # make sure that we don't inifinitely recurse
1006 {
1007   my $c = 0;
1008   package Recurse;
1009   use overload '""'    => sub { shift },
1010                '0+'    => sub { shift },
1011                'bool'  => sub { shift },
1012                fallback => 1;
1013   my $x = bless([]);
1014   main::test("$x" =~ /Recurse=ARRAY/);          # 219
1015   main::test($x);                               # 220
1016   main::test($x+0 =~ /Recurse=ARRAY/);          # 221
1017 }
1018
1019 # BugID 20010422.003
1020 package Foo;
1021
1022 use overload
1023   'bool' => sub { return !$_[0]->is_zero() || undef; }
1024 ;
1025  
1026 sub is_zero
1027   {
1028   my $self = shift;
1029   return $self->{var} == 0;
1030   }
1031
1032 sub new
1033   {
1034   my $class = shift;
1035   my $self =  {};
1036   $self->{var} = shift;
1037   bless $self,$class;
1038   }
1039
1040 package main;
1041
1042 use strict;
1043
1044 my $r = Foo->new(8);
1045 $r = Foo->new(0);
1046
1047 test(($r || 0) == 0); # 222
1048
1049 package utf8_o;
1050
1051 use overload 
1052   '""'  =>  sub { return $_[0]->{var}; }
1053   ;
1054   
1055 sub new
1056   {
1057     my $class = shift;
1058     my $self =  {};
1059     $self->{var} = shift;
1060     bless $self,$class;
1061   }
1062
1063 package main;
1064
1065
1066 my $utfvar = new utf8_o 200.2.1;
1067 test("$utfvar" eq 200.2.1); # 223 - stringify
1068 test("a$utfvar" eq "a".200.2.1); # 224 - overload via sv_2pv_flags
1069
1070 # 225..227 -- more %{} tests.  Hangs in 5.6.0, okay in later releases.
1071 # Basically this example implements strong encapsulation: if Hderef::import()
1072 # were to eval the overload code in the caller's namespace, the privatisation
1073 # would be quite transparent.
1074 package Hderef;
1075 use overload '%{}' => sub { (caller(0))[0] eq 'Foo' ? $_[0] : die "zap" };
1076 package Foo;
1077 @Foo::ISA = 'Hderef';
1078 sub new { bless {}, shift }
1079 sub xet { @_ == 2 ? $_[0]->{$_[1]} :
1080           @_ == 3 ? ($_[0]->{$_[1]} = $_[2]) : undef }
1081 package main;
1082 my $a = Foo->new;
1083 $a->xet('b', 42);
1084 print $a->xet('b') == 42 ? "ok 225\n" : "not ok 225\n";
1085 print defined eval { $a->{b} } ? "not ok 226\n" : "ok 226\n";
1086 print $@ =~ /zap/ ? "ok 227\n" : "not ok 227\n";
1087
1088 # Last test is:
1089 sub last {227}