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