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 use Test::More tests=>498;
  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     my $Test = Test::Builder->new;
 712     $Test->current_test(173);
 713 }
 714 {
 715   package sorting;
 716   use overload 'cmp' => \&comp;
 717   sub new { my ($p, $v) = @_; bless \$v, $p }
 718   sub comp { my ($x,$y) = @_; ($$x * 3 % 10) <=> ($$y * 3 % 10) or $$x cmp $$y }
 719 }
 720 {
 721   my @arr = map sorting->new($_), 0..12;
 722   my @sorted1 = sort @arr;
 723   my @sorted2 = map $$_, @sorted1;
 724   is("@sorted2", '0 10 7 4 1 11 8 5 12 2 9 6 3');
 725 }
 726 {
 727   package iterator;
 728   use overload '<>' => \&iter;
 729   sub new { my ($p, $v) = @_; bless \$v, $p }
 730   sub iter { my ($x) = @_; return undef if $$x < 0; return $$x--; }
 731 }
 732
 733 # XXX iterator overload not intended to work with CORE::GLOBAL?
 734 if (defined &CORE::GLOBAL::glob) {
 735   is('1', '1');
 736   is('1', '1');
 737   is('1', '1');
 738 }
 739 else {
 740   my $iter = iterator->new(5);
 741   my $acc = '';
 742   my $out;
 743   $acc .= " $out" while $out = <${iter}>;
 744   is($acc, ' 5 4 3 2 1 0');
 745   $iter = iterator->new(5);
 746   is(scalar <${iter}>, '5');
 747   $acc = '';
 748   $acc .= " $out" while $out = <$iter>;
 749   is($acc, ' 4 3 2 1 0');
 750 }
 751 {
 752   package deref;
 753   use overload '%{}' => \&hderef, '&{}' => \&cderef,
 754     '*{}' => \&gderef, '${}' => \&sderef, '@{}' => \&aderef;
 755   sub new { my ($p, $v) = @_; bless \$v, $p }
 756   sub deref {
 757     my ($self, $key) = (shift, shift);
 758     my $class = ref $self;
 759     bless $self, 'deref::dummy'; # Disable overloading of %{}
 760     my $out = $self->{$key};
 761     bless $self, $class;        # Restore overloading
 762     $out;
 763   }
 764   sub hderef {shift->deref('h')}
 765   sub aderef {shift->deref('a')}
 766   sub cderef {shift->deref('c')}
 767   sub gderef {shift->deref('g')}
 768   sub sderef {shift->deref('s')}
 769 }
 770 {
 771   my $deref = bless { h => { foo => 5 , fake => 23 },
 772                       c => sub {return shift() + 34},
 773                       's' => \123,
 774                       a => [11..13],
 775                       g => \*srt,
 776                     }, 'deref';
 777   # Hash:
 778   my @cont = sort %$deref;
 779   if ("\t" eq "\011") { # ascii
 780       is("@cont", '23 5 fake foo');
 781   }
 782   else {                # ebcdic alpha-numeric sort order
 783       is("@cont", 'fake foo 23 5');
 784   }
 785   my @keys = sort keys %$deref;
 786   is("@keys", 'fake foo');
 787   my @val = sort values %$deref;
 788   is("@val", '23 5');
 789   is($deref->{foo}, 5);
 790   is(defined $deref->{bar}, '');
 791   my $key;
 792   @keys = ();
 793   push @keys, $key while $key = each %$deref;
 794   @keys = sort @keys;
 795   is("@keys", 'fake foo');
 796   is(exists $deref->{bar}, '');
 797   is(exists $deref->{foo}, 1);
 798   # Code:
 799   is($deref->(5), 39);
 800   is(&$deref(6), 40);
 801   sub xxx_goto { goto &$deref }
 802   is(xxx_goto(7), 41);
 803   my $srt = bless { c => sub {$b <=> $a}
 804                   }, 'deref';
 805   *srt = \&$srt;
 806   my @sorted = sort srt 11, 2, 5, 1, 22;
 807   is("@sorted", '22 11 5 2 1');
 808   # Scalar
 809   is($$deref, 123);
 810   # Code
 811   @sorted = sort $srt 11, 2, 5, 1, 22;
 812   is("@sorted", '22 11 5 2 1');
 813   # Array
 814   is("@$deref", '11 12 13');
 815   is($#$deref, '2');
 816   my $l = @$deref;
 817   is($l, 3);
 818   is($deref->[2], '13');
 819   $l = pop @$deref;
 820   is($l, 13);
 821   $l = 1;
 822   is($deref->[$l], '12');
 823   # Repeated dereference
 824   my $double = bless { h => $deref,
 825                      }, 'deref';
 826   is($double->{foo}, 5);
 827 }
 828
 829 {
 830   package two_refs;
 831   use overload '%{}' => \&gethash, '@{}' => sub { ${shift()} };
 832   sub new {
 833     my $p = shift;
 834     bless \ [@_], $p;
 835   }
 836   sub gethash {
 837     my %h;
 838     my $self = shift;
 839     tie %h, ref $self, $self;
 840     \%h;
 841   }
 842
 843   sub TIEHASH { my $p = shift; bless \ shift, $p }
 844   my %fields;
 845   my $i = 0;
 846   $fields{$_} = $i++ foreach qw{zero one two three};
 847   sub STORE {
 848     my $self = ${shift()};
 849     my $key = $fields{shift()};
 850     defined $key or die "Out of band access";
 851     $$self->[$key] = shift;
 852   }
 853   sub FETCH {
 854     my $self = ${shift()};
 855     my $key = $fields{shift()};
 856     defined $key or die "Out of band access";
 857     $$self->[$key];
 858   }
 859 }
 860
 861 my $bar = new two_refs 3,4,5,6;
 862 $bar->[2] = 11;
 863 is($bar->{two}, 11);
 864 $bar->{three} = 13;
 865 is($bar->[3], 13);
 866
 867 {
 868   package two_refs_o;
 869   @ISA = ('two_refs');
 870 }
 871
 872 $bar = new two_refs_o 3,4,5,6;
 873 $bar->[2] = 11;
 874 is($bar->{two}, 11);
 875 $bar->{three} = 13;
 876 is($bar->[3], 13);
 877
 878 {
 879   package two_refs1;
 880   use overload '%{}' => sub { ${shift()}->[1] },
 881                '@{}' => sub { ${shift()}->[0] };
 882   sub new {
 883     my $p = shift;
 884     my $a = [@_];
 885     my %h;
 886     tie %h, $p, $a;
 887     bless \ [$a, \%h], $p;
 888   }
 889   sub gethash {
 890     my %h;
 891     my $self = shift;
 892     tie %h, ref $self, $self;
 893     \%h;
 894   }
 895
 896   sub TIEHASH { my $p = shift; bless \ shift, $p }
 897   my %fields;
 898   my $i = 0;
 899   $fields{$_} = $i++ foreach qw{zero one two three};
 900   sub STORE {
 901     my $a = ${shift()};
 902     my $key = $fields{shift()};
 903     defined $key or die "Out of band access";
 904     $a->[$key] = shift;
 905   }
 906   sub FETCH {
 907     my $a = ${shift()};
 908     my $key = $fields{shift()};
 909     defined $key or die "Out of band access";
 910     $a->[$key];
 911   }
 912 }
 913
 914 $bar = new two_refs_o 3,4,5,6;
 915 $bar->[2] = 11;
 916 is($bar->{two}, 11);
 917 $bar->{three} = 13;
 918 is($bar->[3], 13);
 919
 920 {
 921   package two_refs1_o;
 922   @ISA = ('two_refs1');
 923 }
 924
 925 $bar = new two_refs1_o 3,4,5,6;
 926 $bar->[2] = 11;
 927 is($bar->{two}, 11);
 928 $bar->{three} = 13;
 929 is($bar->[3], 13);
 930
 931 {
 932   package B;
 933   use overload bool => sub { ${+shift} };
 934 }
 935
 936 my $aaa;
 937 { my $bbbb = 0; $aaa = bless \$bbbb, B }
 938
 939 is !$aaa, 1;
 940
 941 unless ($aaa) {
 942   pass();
 943 } else {
 944   fail();
 945 }
 946
 947 # check that overload isn't done twice by join
 948 { my $c = 0;
 949   package Join;
 950   use overload '""' => sub { $c++ };
 951   my $x = join '', bless([]), 'pq', bless([]);
 952   main::is $x, '0pq1';
 953 };
 954
 955 # Test module-specific warning
 956 {
 957     # check the Odd number of arguments for overload::constant warning
 958     my $a = "" ;
 959     local $SIG{__WARN__} = sub {$a = $_[0]} ;
 960     $x = eval ' overload::constant "integer" ; ' ;
 961     is($a, "");
 962     use warnings 'overload' ;
 963     $x = eval ' overload::constant "integer" ; ' ;
 964     like($a, qr/^Odd number of arguments for overload::constant at/);
 965 }
 966
 967 {
 968     # check the `$_[0]' is not an overloadable type warning
 969     my $a = "" ;
 970     local $SIG{__WARN__} = sub {$a = $_[0]} ;
 971     $x = eval ' overload::constant "fred" => sub {} ; ' ;
 972     is($a, "");
 973     use warnings 'overload' ;
 974     $x = eval ' overload::constant "fred" => sub {} ; ' ;
 975     like($a, qr/^`fred' is not an overloadable type at/);
 976 }
 977
 978 {
 979     # check the `$_[1]' is not a code reference warning
 980     my $a = "" ;
 981     local $SIG{__WARN__} = sub {$a = $_[0]} ;
 982     $x = eval ' overload::constant "integer" => 1; ' ;
 983     is($a, "");
 984     use warnings 'overload' ;
 985     $x = eval ' overload::constant "integer" => 1; ' ;
 986     like($a, qr/^`1' is not a code reference at/);
 987 }
 988
 989 {
 990   my $c = 0;
 991   package ov_int1;
 992   use overload '""'    => sub { 3+shift->[0] },
 993                '0+'    => sub { 10+shift->[0] },
 994                'int'   => sub { 100+shift->[0] };
 995   sub new {my $p = shift; bless [shift], $p}
 996
 997   package ov_int2;
 998   use overload '""'    => sub { 5+shift->[0] },
 999                '0+'    => sub { 30+shift->[0] },
1000                'int'   => sub { 'ov_int1'->new(1000+shift->[0]) };
1001   sub new {my $p = shift; bless [shift], $p}
1002
1003   package noov_int;
1004   use overload '""'    => sub { 2+shift->[0] },
1005                '0+'    => sub { 9+shift->[0] };
1006   sub new {my $p = shift; bless [shift], $p}
1007
1008   package main;
1009
1010   my $x = new noov_int 11;
1011   my $int_x = int $x;
1012   main::is("$int_x", 20);
1013   $x = new ov_int1 31;
1014   $int_x = int $x;
1015   main::is("$int_x", 131);
1016   $x = new ov_int2 51;
1017   $int_x = int $x;
1018   main::is("$int_x", 1054);
1019 }
1020
1021 # make sure that we don't inifinitely recurse
1022 {
1023   my $c = 0;
1024   package Recurse;
1025   use overload '""'    => sub { shift },
1026                '0+'    => sub { shift },
1027                'bool'  => sub { shift },
1028                fallback => 1;
1029   my $x = bless([]);
1030   # For some reason beyond me these have to be oks rather than likes.
1031   main::ok("$x" =~ /Recurse=ARRAY/);
1032   main::ok($x);
1033   main::ok($x+0 =~ qr/Recurse=ARRAY/);
1034 }
1035
1036 # BugID 20010422.003
1037 package Foo;
1038
1039 use overload
1040   'bool' => sub { return !$_[0]->is_zero() || undef; }
1041 ;
1042
1043 sub is_zero
1044   {
1045   my $self = shift;
1046   return $self->{var} == 0;
1047   }
1048
1049 sub new
1050   {
1051   my $class = shift;
1052   my $self =  {};
1053   $self->{var} = shift;
1054   bless $self,$class;
1055   }
1056
1057 package main;
1058
1059 use strict;
1060
1061 my $r = Foo->new(8);
1062 $r = Foo->new(0);
1063
1064 is(($r || 0), 0);
1065
1066 package utf8_o;
1067
1068 use overload
1069   '""'  =>  sub { return $_[0]->{var}; }
1070   ;
1071
1072 sub new
1073   {
1074     my $class = shift;
1075     my $self =  {};
1076     $self->{var} = shift;
1077     bless $self,$class;
1078   }
1079
1080 package main;
1081
1082
1083 my $utfvar = new utf8_o 200.2.1;
1084 is("$utfvar", 200.2.1); # 223 - stringify
1085 is("a$utfvar", "a".200.2.1); # 224 - overload via sv_2pv_flags
1086
1087 # 225..227 -- more %{} tests.  Hangs in 5.6.0, okay in later releases.
1088 # Basically this example implements strong encapsulation: if Hderef::import()
1089 # were to eval the overload code in the caller's namespace, the privatisation
1090 # would be quite transparent.
1091 package Hderef;
1092 use overload '%{}' => sub { (caller(0))[0] eq 'Foo' ? $_[0] : die "zap" };
1093 package Foo;
1094 @Foo::ISA = 'Hderef';
1095 sub new { bless {}, shift }
1096 sub xet { @_ == 2 ? $_[0]->{$_[1]} :
1097           @_ == 3 ? ($_[0]->{$_[1]} = $_[2]) : undef }
1098 package main;
1099 my $a = Foo->new;
1100 $a->xet('b', 42);
1101 is ($a->xet('b'), 42);
1102 ok (!defined eval { $a->{b} });
1103 like ($@, qr/zap/);
1104
1105 {
1106    package t229;
1107    use overload '='  => sub { 42 },
1108                 '++' => sub { my $x = ${$_[0]}; $_[0] };
1109    sub new { my $x = 42; bless \$x }
1110
1111    my $warn;
1112    {
1113      local $SIG{__WARN__} = sub { $warn++ };
1114       my $x = t229->new;
1115       my $y = $x;
1116       eval { $y++ };
1117    }
1118    main::ok (!$warn);
1119 }
1120
1121 {
1122     my ($int, $out1, $out2);
1123     {
1124         BEGIN { $int = 0; overload::constant 'integer' => sub {$int++; 17}; }
1125         $out1 = 0;
1126         $out2 = 1;
1127     }
1128     is($int,  2,  "#24313");    # 230
1129     is($out1, 17, "#24313");    # 231
1130     is($out2, 17, "#24313");    # 232
1131 }
1132
1133 {
1134     package Numify;
1135     use overload (qw(0+ numify fallback 1));
1136
1137     sub new {
1138         my $val = $_[1];
1139         bless \$val, $_[0];
1140     }
1141
1142     sub numify { ${$_[0]} }
1143 }
1144
1145 {
1146     package perl31793;
1147     use overload cmp => sub { 0 };
1148     package perl31793_fb;
1149     use overload cmp => sub { 0 }, fallback => 1;
1150     package main;
1151     my $o  = bless [], 'perl31793';
1152     my $of = bless [], 'perl31793_fb';
1153     my $no = bless [], 'no_overload';
1154     like(overload::StrVal(\"scalar"), qr/^SCALAR\(0x[0-9a-f]+\)$/);
1155     like(overload::StrVal([]),        qr/^ARRAY\(0x[0-9a-f]+\)$/);
1156     like(overload::StrVal({}),        qr/^HASH\(0x[0-9a-f]+\)$/);
1157     like(overload::StrVal(sub{1}),    qr/^CODE\(0x[0-9a-f]+\)$/);
1158     like(overload::StrVal(\*GLOB),    qr/^GLOB\(0x[0-9a-f]+\)$/);
1159     like(overload::StrVal(\$o),       qr/^REF\(0x[0-9a-f]+\)$/);
1160     like(overload::StrVal(qr/a/),     qr/^Regexp=SCALAR\(0x[0-9a-f]+\)$/);
1161     like(overload::StrVal($o),        qr/^perl31793=ARRAY\(0x[0-9a-f]+\)$/);
1162     like(overload::StrVal($of),       qr/^perl31793_fb=ARRAY\(0x[0-9a-f]+\)$/);
1163     like(overload::StrVal($no),       qr/^no_overload=ARRAY\(0x[0-9a-f]+\)$/);
1164 }
1165
1166 # These are all check that overloaded values rather than reference addressess
1167 # are what is getting tested.
1168 my ($two, $one, $un, $deux) = map {new Numify $_} 2, 1, 1, 2;
1169 my ($ein, $zwei) = (1, 2);
1170
1171 my %map = (one => 1, un => 1, ein => 1, deux => 2, two => 2, zwei => 2);
1172 foreach my $op (qw(<=> == != < <= > >=)) {
1173     foreach my $l (keys %map) {
1174         foreach my $r (keys %map) {
1175             my $ocode = "\$$l $op \$$r";
1176             my $rcode = "$map{$l} $op $map{$r}";
1177
1178             my $got = eval $ocode;
1179             die if $@;
1180             my $expect = eval $rcode;
1181             die if $@;
1182             is ($got, $expect, $ocode) or print "# $rcode\n";
1183         }
1184     }
1185 }
1186 {
1187     # check that overloading works in regexes
1188     {
1189         package Foo493;
1190         use overload
1191             '""' => sub { "^$_[0][0]\$" },
1192             '.'  => sub {
1193                     bless [
1194                              $_[2]
1195                             ? (ref $_[1] ? $_[1][0] : $_[1]) . ':' .$_[0][0]
1196                             : $_[0][0] . ':' . (ref $_[1] ? $_[1][0] : $_[1])
1197                     ], 'Foo493'
1198                         };
1199     }
1200
1201     my $a = bless [ "a" ], 'Foo493';
1202     like('a', qr/$a/);
1203     like('x:a', qr/x$a/);
1204     like('x:a:=', qr/x$a=$/);
1205     like('x:a:a:=', qr/x$a$a=$/);
1206
1207 }
1208
1209 {
1210     my $twenty_three = 23;
1211     # Check that constant overloading propagates into evals
1212     BEGIN { overload::constant integer => sub { 23 } }
1213     is(eval "17", $twenty_three);
1214 }