extra code in pp_concat, Take 2
[p5sagit/p5-mst-13.2.git] / lib / overload.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib';
6     require Config;
7     if (($Config::Config{'extensions'} !~ m!\bList/Util\b!) ){
8         print "1..0 # Skip -- Perl configured without List::Util module\n";
9         exit 0;
10     }
11 }
12
13 package Oscalar;
14 use 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
32 qw(
33 ""      stringify
34 0+      numify)                 # Order of arguments unsignificant
35 );
36
37 sub new {
38   my $foo = $_[1];
39   bless \$foo, $_[0];
40 }
41
42 sub stringify { "${$_[0]}" }
43 sub numify { 0 + "${$_[0]}" }   # Not needed, additional overhead
44                                 # comparing to direct compilation based on
45                                 # stringify
46
47 package main;
48
49 our $test = 0;
50 $| = 1;
51 print "1..",&last,"\n";
52
53 sub test {
54   $test++; 
55   if (@_ > 1) {
56     my $comment = "";
57     $comment = " # " . $_ [2] if @_ > 2;
58     if ($_[0] eq $_[1]) {
59       print "ok $test$comment\n";
60       return 1;
61     } else {
62       $comment .= ": '$_[0]' ne '$_[1]'";
63       print "not ok $test$comment\n";
64       return 0;
65     }
66   } else {
67     if (shift) {
68       print "ok $test\n";
69       return 1;
70     } else {
71       print "not ok $test\n";
72       return 0;
73     }
74   }
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:
82 test(1);                        # 1
83
84 test ($b eq $a);                # 2
85 test ($b eq "087");             # 3
86 test (ref $a eq "Oscalar");     # 4
87 test ($a eq $a);                # 5
88 test ($a eq "087");             # 6
89
90 $c = $a + 7;
91
92 test (ref $c eq "Oscalar");     # 7
93 test (!($c eq $a));             # 8
94 test ($c eq "94");              # 9
95
96 $b=$a;
97
98 test (ref $a eq "Oscalar");     # 10
99
100 $b++;
101
102 test (ref $b eq "Oscalar");     # 11
103 test ( $a eq "087");            # 12
104 test ( $b eq "88");             # 13
105 test (ref $a eq "Oscalar");     # 14
106
107 $c=$b;
108 $c-=$a;
109
110 test (ref $c eq "Oscalar");     # 15
111 test ( $a eq "087");            # 16
112 test ( $c eq "1");              # 17
113 test (ref $a eq "Oscalar");     # 18
114
115 $b=1;
116 $b+=$a;
117
118 test (ref $b eq "Oscalar");     # 19
119 test ( $a eq "087");            # 20
120 test ( $b eq "88");             # 21
121 test (ref $a eq "Oscalar");     # 22
122
123 eval q[ package Oscalar; use overload ('++' => sub { $ {$_[0]}++;$_[0] } ) ];
124
125 $b=$a;
126
127 test (ref $a eq "Oscalar");     # 23
128
129 $b++;
130
131 test (ref $b eq "Oscalar");     # 24
132 test ( $a eq "087");            # 25
133 test ( $b eq "88");             # 26
134 test (ref $a eq "Oscalar");     # 27
135
136 package Oscalar;
137 $dummy=bless \$dummy;           # Now cache of method should be reloaded
138 package main;
139
140 $b=$a;
141 $b++;                           
142
143 test (ref $b eq "Oscalar");     # 28
144 test ( $a eq "087");            # 29
145 test ( $b eq "88");             # 30
146 test (ref $a eq "Oscalar");     # 31
147
148 undef $b;                       # Destroying updates tables too...
149
150 eval q[package Oscalar; use overload ('++' => sub { $ {$_[0]} += 2; $_[0] } ) ];
151
152 $b=$a;
153
154 test (ref $a eq "Oscalar");     # 32
155
156 $b++;
157
158 test (ref $b eq "Oscalar");     # 33
159 test ( $a eq "087");            # 34
160 test ( $b eq "88");             # 35
161 test (ref $a eq "Oscalar");     # 36
162
163 package Oscalar;
164 $dummy=bless \$dummy;           # Now cache of method should be reloaded
165 package main;
166
167 $b++;                           
168
169 test (ref $b eq "Oscalar");     # 37
170 test ( $a eq "087");            # 38
171 test ( $b eq "90");             # 39
172 test (ref $a eq "Oscalar");     # 40
173
174 $b=$a;
175 $b++;
176
177 test (ref $b eq "Oscalar");     # 41
178 test ( $a eq "087");            # 42
179 test ( $b eq "89");             # 43
180 test (ref $a eq "Oscalar");     # 44
181
182
183 test ($b? 1:0);                 # 45
184
185 eval 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
192 test (ref $b eq "Oscalar");     # 46
193 test ( $a eq "087");            # 47
194 test ( $b eq "087");            # 48
195 test (ref $a eq "Oscalar");     # 49
196
197 $b++;
198
199 test (ref $b eq "Oscalar");     # 50
200 test ( $a eq "087");            # 51
201 test ( $b eq "89");             # 52
202 test (ref $a eq "Oscalar");     # 53
203 test ($copies == 0);            # 54
204
205 $b+=1;
206
207 test (ref $b eq "Oscalar");     # 55
208 test ( $a eq "087");            # 56
209 test ( $b eq "90");             # 57
210 test (ref $a eq "Oscalar");     # 58
211 test ($copies == 0);            # 59
212
213 $b=$a;
214 $b+=1;
215
216 test (ref $b eq "Oscalar");     # 60
217 test ( $a eq "087");            # 61
218 test ( $b eq "88");             # 62
219 test (ref $a eq "Oscalar");     # 63
220 test ($copies == 0);            # 64
221
222 $b=$a;
223 $b++;
224
225 test (ref $b eq "Oscalar") || print ref $b,"=ref(b)\n"; # 65
226 test ( $a eq "087");            # 66
227 test ( $b eq "89");             # 67
228 test (ref $a eq "Oscalar");     # 68
229 test ($copies == 1);            # 69
230
231 eval 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
238 test (ref $b eq "Oscalar");     # 70
239 test ( $a eq "087");            # 71
240 test ( $b eq "90");             # 72
241 test (ref $a eq "Oscalar");     # 73
242 test ($copies == 2);            # 74
243
244 $b+=$b;
245
246 test (ref $b eq "Oscalar");     # 75
247 test ( $b eq "360");            # 76
248 test ($copies == 2);            # 77
249 $b=-$b;
250
251 test (ref $b eq "Oscalar");     # 78
252 test ( $b eq "-360");           # 79
253 test ($copies == 2);            # 80
254
255 $b=abs($b);
256
257 test (ref $b eq "Oscalar");     # 81
258 test ( $b eq "360");            # 82
259 test ($copies == 2);            # 83
260
261 $b=abs($b);
262
263 test (ref $b eq "Oscalar");     # 84
264 test ( $b eq "360");            # 85
265 test ($copies == 2);            # 86
266
267 eval 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;
273 test ($a eq "_.yy.__.yy.__.yy._"); # 87
274
275 eval q[package Oscalar; 
276        use overload ('.' => sub {new Oscalar ( $_[2] ? 
277                                               "_.$_[1].__.$ {$_[0]}._"
278                                               : "_.$ {$_[0]}.__.$_[1]._")}) ];
279
280 $a=new Oscalar "xx";
281
282 test ("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";
291 test (ref $aI eq "OscalarI");   # 89
292 test ("$aI" eq "xx");           # 90
293 test ($aI eq "xx");             # 91
294 test ("b${aI}c" eq "_._.b.__.xx._.__.c._");             # 92
295
296 # Here we test blessing to a package updates hash
297
298 eval "package Oscalar; no overload '.'";
299
300 test ("b${a}" eq "_.b.__.xx._"); # 93
301 $x="1";
302 bless \$x, Oscalar;
303 test ("b${a}c" eq "bxxc");      # 94
304 new Oscalar 1;
305 test ("b${a}c" eq "bxxc");      # 95
306
307 # Negative overloading:
308
309 $na = eval { ~$a };
310 test($@ =~ /no method found/);  # 96
311
312 # Check AUTOLOADING:
313
314 *Oscalar::AUTOLOAD = 
315   sub { *{"Oscalar::$AUTOLOAD"} = sub {"_!_" . shift() . "_!_"} ;
316         goto &{"Oscalar::$AUTOLOAD"}};
317
318 eval "package Oscalar; sub comple; use overload '~' => 'comple'";
319
320 $na = eval { ~$a };             # Hash was not updated
321 test($@ =~ /no method found/);  # 97
322
323 bless \$x, Oscalar;
324
325 $na = eval { ~$a };             # Hash updated
326 warn "`$na', $@" if $@;
327 test !$@;                       # 98
328 test($na eq '_!_xx_!_');        # 99
329
330 $na = 0;
331
332 $na = eval { ~$aI };            # Hash was not updated
333 test($@ =~ /no method found/);  # 100
334
335 bless \$x, OscalarI;
336
337 $na = eval { ~$aI };
338 print $@;
339
340 test !$@;                       # 101
341 test($na eq '_!_xx_!_');        # 102
342
343 eval "package Oscalar; sub rshft; use overload '>>' => 'rshft'";
344
345 $na = eval { $aI >> 1 };        # Hash was not updated
346 test($@ =~ /no method found/);  # 103
347
348 bless \$x, OscalarI;
349
350 $na = 0;
351
352 $na = eval { $aI >> 1 };
353 print $@;
354
355 test !$@;                       # 104
356 test($na eq '_!_xx_!_');        # 105
357
358 # warn overload::Method($a, '0+'), "\n";
359 test (overload::Method($a, '0+') eq \&Oscalar::numify); # 106
360 test (overload::Method($aI,'0+') eq \&Oscalar::numify); # 107
361 test (overload::Overloaded($aI)); # 108
362 test (!overload::Overloaded('overload')); # 109
363
364 test (! defined overload::Method($aI, '<<')); # 110
365 test (! defined overload::Method($a, '<')); # 111
366
367 test (overload::StrVal($aI) =~ /^OscalarI=SCALAR\(0x[\da-fA-F]+\)$/); # 112
368 test (overload::StrVal(\$aI) eq "@{[\$aI]}"); # 113
369
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;
380 bless $aII, 'OscalarII';
381 bless \$fake, 'OscalarI';               # update the hash
382 test(($aI | 3) eq '_<<_xx_<<_');        # 114
383 # warn $aII << 3;
384 test(($aII << 3) eq '_<<_087_<<_');     # 115
385
386 {
387   BEGIN { $int = 7; overload::constant 'integer' => sub {$int++; shift}; }
388   $out = 2**10;
389 }
390 test($int, 9);          # 116
391 test($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
405 test($out, 'foo');              # 118
406 test($out, $foo);               # 119
407 test($out1, 'f\'o\\o');         # 120
408 test($out1, $foo1);             # 121
409 test($out2, "a\afoo,\,");       # 122
410 test("@q", "foo q f'o\\\\o q a\\a qq ,\\, qq"); # 123
411 test($q, 11);                   # 124
412 test("@qr", "b\\b qq .\\. qq"); # 125
413 test($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;
424 oups
425 EOF
426   $b = <<'EOF';
427 oups1
428 EOF
429   $c = bareword;
430   m'try it';
431   s'first part'second part';
432   s/yet another/tail here/;
433   tr/A-Z/a-z/;
434 }
435
436 test($out, '_<foo>_');          # 117
437 test($out1, '_<f\'o\\o>_');             # 128
438 test($out2, "_<a\a>_foo_<,\,>_");       # 129
439 test("@q1", "foo q f'o\\\\o q a\\a qq ,\\, qq oups
440  qq oups1
441  q second part q tail here s A-Z tr a-z tr");   # 130
442 test("@qr1", "b\\b qq .\\. qq try it q first part q yet another qq");   # 131
443 test($res, 1);                  # 132
444 test($a, "_<oups
445 >_");   # 133
446 test($b, "_<oups1
447 >_");   # 134
448 test($c, "bareword");   # 135
449
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; 
509     $obj->[1] = shift;
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; 
630     $obj->[1] = shift;
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 }
709
710 {
711   package sorting;
712   use overload 'cmp' => \&comp;
713   sub new { my ($p, $v) = @_; bless \$v, $p }
714   sub comp { my ($x,$y) = @_; ($$x * 3 % 10) <=> ($$y * 3 % 10) or $$x cmp $$y }
715 }
716 {
717   my @arr = map sorting->new($_), 0..12;
718   my @sorted1 = sort @arr;
719   my @sorted2 = map $$_, @sorted1;
720   test "@sorted2", '0 10 7 4 1 11 8 5 12 2 9 6 3';
721 }
722 {
723   package iterator;
724   use overload '<>' => \&iter;
725   sub new { my ($p, $v) = @_; bless \$v, $p }
726   sub iter { my ($x) = @_; return undef if $$x < 0; return $$x--; }
727 }
728
729 # XXX iterator overload not intended to work with CORE::GLOBAL?
730 if (defined &CORE::GLOBAL::glob) {
731   test '1', '1';        # 175
732   test '1', '1';        # 176
733   test '1', '1';        # 177
734 }
735 else {
736   my $iter = iterator->new(5);
737   my $acc = '';
738   my $out;
739   $acc .= " $out" while $out = <${iter}>;
740   test $acc, ' 5 4 3 2 1 0';    # 175
741   $iter = iterator->new(5);
742   test scalar <${iter}>, '5';   # 176
743   $acc = '';
744   $acc .= " $out" while $out = <$iter>;
745   test $acc, ' 4 3 2 1 0';      # 177
746 }
747 {
748   package deref;
749   use overload '%{}' => \&hderef, '&{}' => \&cderef, 
750     '*{}' => \&gderef, '${}' => \&sderef, '@{}' => \&aderef;
751   sub new { my ($p, $v) = @_; bless \$v, $p }
752   sub deref {
753     my ($self, $key) = (shift, shift);
754     my $class = ref $self;
755     bless $self, 'deref::dummy'; # Disable overloading of %{} 
756     my $out = $self->{$key};
757     bless $self, $class;        # Restore overloading
758     $out;
759   }
760   sub hderef {shift->deref('h')}
761   sub aderef {shift->deref('a')}
762   sub cderef {shift->deref('c')}
763   sub gderef {shift->deref('g')}
764   sub sderef {shift->deref('s')}
765 }
766 {
767   my $deref = bless { h => { foo => 5 , fake => 23 },
768                       c => sub {return shift() + 34},
769                       's' => \123,
770                       a => [11..13],
771                       g => \*srt,
772                     }, 'deref';
773   # Hash:
774   my @cont = sort %$deref;
775   if ("\t" eq "\011") { # ascii
776       test "@cont", '23 5 fake foo';    # 178
777   } 
778   else {                # ebcdic alpha-numeric sort order
779       test "@cont", 'fake foo 23 5';    # 178
780   }
781   my @keys = sort keys %$deref;
782   test "@keys", 'fake foo';     # 179
783   my @val = sort values %$deref;
784   test "@val", '23 5';          # 180
785   test $deref->{foo}, 5;        # 181
786   test defined $deref->{bar}, ''; # 182
787   my $key;
788   @keys = ();
789   push @keys, $key while $key = each %$deref;
790   @keys = sort @keys;
791   test "@keys", 'fake foo';     # 183  
792   test exists $deref->{bar}, ''; # 184
793   test exists $deref->{foo}, 1; # 185
794   # Code:
795   test $deref->(5), 39;         # 186
796   test &$deref(6), 40;          # 187
797   sub xxx_goto { goto &$deref }
798   test xxx_goto(7), 41;         # 188
799   my $srt = bless { c => sub {$b <=> $a}
800                   }, 'deref';
801   *srt = \&$srt;
802   my @sorted = sort srt 11, 2, 5, 1, 22;
803   test "@sorted", '22 11 5 2 1'; # 189
804   # Scalar
805   test $$deref, 123;            # 190
806   # Code
807   @sorted = sort $srt 11, 2, 5, 1, 22;
808   test "@sorted", '22 11 5 2 1'; # 191
809   # Array
810   test "@$deref", '11 12 13';   # 192
811   test $#$deref, '2';           # 193
812   my $l = @$deref;
813   test $l, 3;                   # 194
814   test $deref->[2], '13';               # 195
815   $l = pop @$deref;
816   test $l, 13;                  # 196
817   $l = 1;
818   test $deref->[$l], '12';      # 197
819   # Repeated dereference
820   my $double = bless { h => $deref,
821                      }, 'deref';
822   test $double->{foo}, 5;       # 198
823 }
824
825 {
826   package two_refs;
827   use overload '%{}' => \&gethash, '@{}' => sub { ${shift()} };
828   sub new { 
829     my $p = shift; 
830     bless \ [@_], $p;
831   }
832   sub gethash {
833     my %h;
834     my $self = shift;
835     tie %h, ref $self, $self;
836     \%h;
837   }
838
839   sub TIEHASH { my $p = shift; bless \ shift, $p }
840   my %fields;
841   my $i = 0;
842   $fields{$_} = $i++ foreach qw{zero one two three};
843   sub STORE { 
844     my $self = ${shift()};
845     my $key = $fields{shift()};
846     defined $key or die "Out of band access";
847     $$self->[$key] = shift;
848   }
849   sub FETCH { 
850     my $self = ${shift()};
851     my $key = $fields{shift()};
852     defined $key or die "Out of band access";
853     $$self->[$key];
854   }
855 }
856
857 my $bar = new two_refs 3,4,5,6;
858 $bar->[2] = 11;
859 test $bar->{two}, 11;           # 199
860 $bar->{three} = 13;
861 test $bar->[3], 13;             # 200
862
863 {
864   package two_refs_o;
865   @ISA = ('two_refs');
866 }
867
868 $bar = new two_refs_o 3,4,5,6;
869 $bar->[2] = 11;
870 test $bar->{two}, 11;           # 201
871 $bar->{three} = 13;
872 test $bar->[3], 13;             # 202
873
874 {
875   package two_refs1;
876   use overload '%{}' => sub { ${shift()}->[1] },
877                '@{}' => sub { ${shift()}->[0] };
878   sub new { 
879     my $p = shift; 
880     my $a = [@_];
881     my %h;
882     tie %h, $p, $a;
883     bless \ [$a, \%h], $p;
884   }
885   sub gethash {
886     my %h;
887     my $self = shift;
888     tie %h, ref $self, $self;
889     \%h;
890   }
891
892   sub TIEHASH { my $p = shift; bless \ shift, $p }
893   my %fields;
894   my $i = 0;
895   $fields{$_} = $i++ foreach qw{zero one two three};
896   sub STORE { 
897     my $a = ${shift()};
898     my $key = $fields{shift()};
899     defined $key or die "Out of band access";
900     $a->[$key] = shift;
901   }
902   sub FETCH { 
903     my $a = ${shift()};
904     my $key = $fields{shift()};
905     defined $key or die "Out of band access";
906     $a->[$key];
907   }
908 }
909
910 $bar = new two_refs_o 3,4,5,6;
911 $bar->[2] = 11;
912 test $bar->{two}, 11;           # 203
913 $bar->{three} = 13;
914 test $bar->[3], 13;             # 204
915
916 {
917   package two_refs1_o;
918   @ISA = ('two_refs1');
919 }
920
921 $bar = new two_refs1_o 3,4,5,6;
922 $bar->[2] = 11;
923 test $bar->{two}, 11;           # 205
924 $bar->{three} = 13;
925 test $bar->[3], 13;             # 206
926
927 {
928   package B;
929   use overload bool => sub { ${+shift} };
930 }
931
932 my $aaa;
933 { my $bbbb = 0; $aaa = bless \$bbbb, B }
934
935 test !$aaa, 1;                  # 207
936
937 unless ($aaa) {
938   test 'ok', 'ok';              # 208
939 } else {
940   test 'is not', 'ok';          # 208
941 }
942
943 # check that overload isn't done twice by join
944 { my $c = 0;
945   package Join;
946   use overload '""' => sub { $c++ };
947   my $x = join '', bless([]), 'pq', bless([]);
948   main::test $x, '0pq1';                # 209
949 };
950
951 # Test module-specific warning
952 {
953     # check the Odd number of arguments for overload::constant warning
954     my $a = "" ;
955     local $SIG{__WARN__} = sub {$a = $_[0]} ;
956     $x = eval ' overload::constant "integer" ; ' ;
957     test($a eq "") ; # 210
958     use warnings 'overload' ;
959     $x = eval ' overload::constant "integer" ; ' ;
960     test($a =~ /^Odd number of arguments for overload::constant at/) ; # 211
961 }
962
963 {
964     # check the `$_[0]' is not an overloadable type warning
965     my $a = "" ;
966     local $SIG{__WARN__} = sub {$a = $_[0]} ;
967     $x = eval ' overload::constant "fred" => sub {} ; ' ;
968     test($a eq "") ; # 212
969     use warnings 'overload' ;
970     $x = eval ' overload::constant "fred" => sub {} ; ' ;
971     test($a =~ /^`fred' is not an overloadable type at/); # 213
972 }
973
974 {
975     # check the `$_[1]' is not a code reference warning
976     my $a = "" ;
977     local $SIG{__WARN__} = sub {$a = $_[0]} ;
978     $x = eval ' overload::constant "integer" => 1; ' ;
979     test($a eq "") ; # 214
980     use warnings 'overload' ;
981     $x = eval ' overload::constant "integer" => 1; ' ;
982     test($a =~ /^`1' is not a code reference at/); # 215
983 }
984
985 {
986   my $c = 0;
987   package ov_int1;
988   use overload '""'    => sub { 3+shift->[0] },
989                '0+'    => sub { 10+shift->[0] },
990                'int'   => sub { 100+shift->[0] };
991   sub new {my $p = shift; bless [shift], $p}
992
993   package ov_int2;
994   use overload '""'    => sub { 5+shift->[0] },
995                '0+'    => sub { 30+shift->[0] },
996                'int'   => sub { 'ov_int1'->new(1000+shift->[0]) };
997   sub new {my $p = shift; bless [shift], $p}
998
999   package noov_int;
1000   use overload '""'    => sub { 2+shift->[0] },
1001                '0+'    => sub { 9+shift->[0] };
1002   sub new {my $p = shift; bless [shift], $p}
1003
1004   package main;
1005
1006   my $x = new noov_int 11;
1007   my $int_x = int $x;
1008   main::test("$int_x" eq 20);                   # 216
1009   $x = new ov_int1 31;
1010   $int_x = int $x;
1011   main::test("$int_x" eq 131);                  # 217
1012   $x = new ov_int2 51;
1013   $int_x = int $x;
1014   main::test("$int_x" eq 1054);                 # 218
1015 }
1016
1017 # make sure that we don't inifinitely recurse
1018 {
1019   my $c = 0;
1020   package Recurse;
1021   use overload '""'    => sub { shift },
1022                '0+'    => sub { shift },
1023                'bool'  => sub { shift },
1024                fallback => 1;
1025   my $x = bless([]);
1026   main::test("$x" =~ /Recurse=ARRAY/);          # 219
1027   main::test($x);                               # 220
1028   main::test($x+0 =~ /Recurse=ARRAY/);          # 221
1029 }
1030
1031 # BugID 20010422.003
1032 package Foo;
1033
1034 use overload
1035   'bool' => sub { return !$_[0]->is_zero() || undef; }
1036 ;
1037  
1038 sub is_zero
1039   {
1040   my $self = shift;
1041   return $self->{var} == 0;
1042   }
1043
1044 sub new
1045   {
1046   my $class = shift;
1047   my $self =  {};
1048   $self->{var} = shift;
1049   bless $self,$class;
1050   }
1051
1052 package main;
1053
1054 use strict;
1055
1056 my $r = Foo->new(8);
1057 $r = Foo->new(0);
1058
1059 test(($r || 0) == 0); # 222
1060
1061 package utf8_o;
1062
1063 use overload 
1064   '""'  =>  sub { return $_[0]->{var}; }
1065   ;
1066   
1067 sub new
1068   {
1069     my $class = shift;
1070     my $self =  {};
1071     $self->{var} = shift;
1072     bless $self,$class;
1073   }
1074
1075 package main;
1076
1077
1078 my $utfvar = new utf8_o 200.2.1;
1079 test("$utfvar" eq 200.2.1); # 223 - stringify
1080 test("a$utfvar" eq "a".200.2.1); # 224 - overload via sv_2pv_flags
1081
1082 # 225..227 -- more %{} tests.  Hangs in 5.6.0, okay in later releases.
1083 # Basically this example implements strong encapsulation: if Hderef::import()
1084 # were to eval the overload code in the caller's namespace, the privatisation
1085 # would be quite transparent.
1086 package Hderef;
1087 use overload '%{}' => sub { (caller(0))[0] eq 'Foo' ? $_[0] : die "zap" };
1088 package Foo;
1089 @Foo::ISA = 'Hderef';
1090 sub new { bless {}, shift }
1091 sub xet { @_ == 2 ? $_[0]->{$_[1]} :
1092           @_ == 3 ? ($_[0]->{$_[1]} = $_[2]) : undef }
1093 package main;
1094 my $a = Foo->new;
1095 $a->xet('b', 42);
1096 test ($a->xet('b'), 42);
1097 test (!defined eval { $a->{b} });
1098 test ($@ =~ /zap/);
1099
1100 {
1101    package t229;
1102    use overload '='  => sub { 42 },
1103                 '++' => sub { my $x = ${$_[0]}; $_[0] };
1104    sub new { my $x = 42; bless \$x }
1105
1106    my $warn;
1107    {  
1108      local $SIG{__WARN__} = sub { $warn++ };
1109       my $x = t229->new;
1110       my $y = $x;
1111       eval { $y++ };
1112    }
1113    main::test (!$warn);
1114 }
1115
1116 {
1117     my ($int, $out1, $out2);
1118     {
1119         BEGIN { $int = 0; overload::constant 'integer' => sub {$int++; 17}; }
1120         $out1 = 0;
1121         $out2 = 1;
1122     }
1123     test($int,  2,  "#24313");  # 230
1124     test($out1, 17, "#24313");  # 231
1125     test($out2, 17, "#24313");  # 232
1126 }
1127
1128 {
1129     package Numify;
1130     use overload (qw(0+ numify fallback 1));
1131
1132     sub new {
1133         my $val = $_[1];
1134         bless \$val, $_[0];
1135     }
1136
1137     sub numify { ${$_[0]} }
1138 }
1139
1140 {
1141     package perl31793;
1142     use overload cmp => sub { 0 };
1143     package perl31793_fb;
1144     use overload cmp => sub { 0 }, fallback => 1;
1145     package main;
1146     my $o  = bless [], 'perl31793';
1147     my $of = bless [], 'perl31793_fb';
1148     my $no = bless [], 'no_overload';
1149     test (overload::StrVal(\"scalar") =~ /^SCALAR\(0x[0-9a-f]+\)$/);
1150     test (overload::StrVal([])        =~ /^ARRAY\(0x[0-9a-f]+\)$/);
1151     test (overload::StrVal({})        =~ /^HASH\(0x[0-9a-f]+\)$/);
1152     test (overload::StrVal(sub{1})    =~ /^CODE\(0x[0-9a-f]+\)$/);
1153     test (overload::StrVal(\*GLOB)    =~ /^GLOB\(0x[0-9a-f]+\)$/);
1154     test (overload::StrVal(\$o)       =~ /^REF\(0x[0-9a-f]+\)$/);
1155     test (overload::StrVal(qr/a/)     =~ /^Regexp=SCALAR\(0x[0-9a-f]+\)$/);
1156     test (overload::StrVal($o)        =~ /^perl31793=ARRAY\(0x[0-9a-f]+\)$/);
1157     test (overload::StrVal($of)       =~ /^perl31793_fb=ARRAY\(0x[0-9a-f]+\)$/);
1158     test (overload::StrVal($no)       =~ /^no_overload=ARRAY\(0x[0-9a-f]+\)$/);
1159 }
1160
1161 # These are all check that overloaded values rather than reference addressess
1162 # are what is getting tested.
1163 my ($two, $one, $un, $deux) = map {new Numify $_} 2, 1, 1, 2;
1164 my ($ein, $zwei) = (1, 2);
1165
1166 my %map = (one => 1, un => 1, ein => 1, deux => 2, two => 2, zwei => 2);
1167 foreach my $op (qw(<=> == != < <= > >=)) {
1168     foreach my $l (keys %map) {
1169         foreach my $r (keys %map) {
1170             my $ocode = "\$$l $op \$$r";
1171             my $rcode = "$map{$l} $op $map{$r}";
1172
1173             my $got = eval $ocode;
1174             die if $@;
1175             my $expect = eval $rcode;
1176             die if $@;
1177             test ($got, $expect, $ocode) or print "# $rcode\n";
1178         }
1179     }
1180 }
1181 {
1182     # check that overloading works in regexes
1183     {
1184         package Foo493;
1185         use overload
1186             '""' => sub { "^$_[0][0]\$" },
1187             '.'  => sub { 
1188                     bless [
1189                              $_[2]
1190                             ? (ref $_[1] ? $_[1][0] : $_[1]) . ':' .$_[0][0] 
1191                             : $_[0][0] . ':' . (ref $_[1] ? $_[1][0] : $_[1])
1192                     ], 'Foo493'
1193                         };
1194     }
1195
1196     my $a = bless [ "a" ], 'Foo493';
1197     test('a' =~ /$a/);
1198     test('x:a' =~ /x$a/);
1199     test('x:a:=' =~ /x$a=$/);
1200     test('x:a:a:=' =~ /x$a$a=$/);
1201
1202 }
1203
1204
1205 # Last test is:
1206 sub last {497}