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