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 $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 # Last test is:
1050 sub last {222}