lib/overload.t

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