1#!./perl 2 3BEGIN { 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 13package Oscalar; 14use 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 32qw( 33"" stringify 340+ numify) # Order of arguments insignificant 35); 36 37sub new { 38 my $foo = $_[1]; 39 bless \$foo, $_[0]; 40} 41 42sub stringify { "${$_[0]}" } 43sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead 44 # comparing to direct compilation based on 45 # stringify 46 47package main; 48 49$| = 1; 50use Test::More tests => 556; 51 52 53$a = new Oscalar "087"; 54$b= "$a"; 55 56is($b, $a); 57is($b, "087"); 58is(ref $a, "Oscalar"); 59is($a, $a); 60is($a, "087"); 61 62$c = $a + 7; 63 64is(ref $c, "Oscalar"); 65isnt($c, $a); 66is($c, "94"); 67 68$b=$a; 69 70is(ref $a, "Oscalar"); 71 72$b++; 73 74is(ref $b, "Oscalar"); 75is($a, "087"); 76is($b, "88"); 77is(ref $a, "Oscalar"); 78 79$c=$b; 80$c-=$a; 81 82is(ref $c, "Oscalar"); 83is($a, "087"); 84is($c, "1"); 85is(ref $a, "Oscalar"); 86 87$b=1; 88$b+=$a; 89 90is(ref $b, "Oscalar"); 91is($a, "087"); 92is($b, "88"); 93is(ref $a, "Oscalar"); 94 95eval q[ package Oscalar; use overload ('++' => sub { $ {$_[0]}++;$_[0] } ) ]; 96 97$b=$a; 98 99is(ref $a, "Oscalar"); 100 101$b++; 102 103is(ref $b, "Oscalar"); 104is($a, "087"); 105is($b, "88"); 106is(ref $a, "Oscalar"); 107 108package Oscalar; 109$dummy=bless \$dummy; # Now cache of method should be reloaded 110package main; 111 112$b=$a; 113$b++; 114 115is(ref $b, "Oscalar"); 116is($a, "087"); 117is($b, "88"); 118is(ref $a, "Oscalar"); 119 120undef $b; # Destroying updates tables too... 121 122eval q[package Oscalar; use overload ('++' => sub { $ {$_[0]} += 2; $_[0] } ) ]; 123 124$b=$a; 125 126is(ref $a, "Oscalar"); 127 128$b++; 129 130is(ref $b, "Oscalar"); 131is($a, "087"); 132is($b, "88"); 133is(ref $a, "Oscalar"); 134 135package Oscalar; 136$dummy=bless \$dummy; # Now cache of method should be reloaded 137package main; 138 139$b++; 140 141is(ref $b, "Oscalar"); 142is($a, "087"); 143is($b, "90"); 144is(ref $a, "Oscalar"); 145 146$b=$a; 147$b++; 148 149is(ref $b, "Oscalar"); 150is($a, "087"); 151is($b, "89"); 152is(ref $a, "Oscalar"); 153 154 155ok($b? 1:0); 156 157eval 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 164is(ref $b, "Oscalar"); 165is($a, "087"); 166is($b, "087"); 167is(ref $a, "Oscalar"); 168 169$b++; 170 171is(ref $b, "Oscalar"); 172is($a, "087"); 173is($b, "89"); 174is(ref $a, "Oscalar"); 175is($copies, undef); 176 177$b+=1; 178 179is(ref $b, "Oscalar"); 180is($a, "087"); 181is($b, "90"); 182is(ref $a, "Oscalar"); 183is($copies, undef); 184 185$b=$a; 186$b+=1; 187 188is(ref $b, "Oscalar"); 189is($a, "087"); 190is($b, "88"); 191is(ref $a, "Oscalar"); 192is($copies, undef); 193 194$b=$a; 195$b++; 196 197is(ref $b, "Oscalar"); 198is($a, "087"); 199is($b, "89"); 200is(ref $a, "Oscalar"); 201is($copies, 1); 202 203eval 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 210is(ref $b, "Oscalar"); 211is($a, "087"); 212is($b, "90"); 213is(ref $a, "Oscalar"); 214is($copies, 2); 215 216$b+=$b; 217 218is(ref $b, "Oscalar"); 219is($b, "360"); 220is($copies, 2); 221$b=-$b; 222 223is(ref $b, "Oscalar"); 224is($b, "-360"); 225is($copies, 2); 226 227$b=abs($b); 228 229is(ref $b, "Oscalar"); 230is($b, "360"); 231is($copies, 2); 232 233$b=abs($b); 234 235is(ref $b, "Oscalar"); 236is($b, "360"); 237is($copies, 2); 238 239eval 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; 245is($a, "_.yy.__.yy.__.yy._"); 246 247eval q[package Oscalar; 248 use overload ('.' => sub {new Oscalar ( $_[2] ? 249 "_.$_[1].__.$ {$_[0]}._" 250 : "_.$ {$_[0]}.__.$_[1]._")}) ]; 251 252$a=new Oscalar "xx"; 253 254is("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"; 263is(ref $aI, "OscalarI"); 264is("$aI", "xx"); 265is($aI, "xx"); 266is("b${aI}c", "_._.b.__.xx._.__.c._"); 267 268# Here we test blessing to a package updates hash 269 270eval "package Oscalar; no overload '.'"; 271 272is("b${a}", "_.b.__.xx._"); 273$x="1"; 274bless \$x, Oscalar; 275is("b${a}c", "bxxc"); 276new Oscalar 1; 277is("b${a}c", "bxxc"); 278 279# Negative overloading: 280 281$na = eval { ~$a }; 282like($@, qr/no method found/); 283 284# Check AUTOLOADING: 285 286*Oscalar::AUTOLOAD = 287 sub { *{"Oscalar::$AUTOLOAD"} = sub {"_!_" . shift() . "_!_"} ; 288 goto &{"Oscalar::$AUTOLOAD"}}; 289 290eval "package Oscalar; sub comple; use overload '~' => 'comple'"; 291 292$na = eval { ~$a }; # Hash was not updated 293like($@, qr/no method found/); 294 295bless \$x, Oscalar; 296 297$na = eval { ~$a }; # Hash updated 298warn "`$na', $@" if $@; 299ok !$@; 300is($na, '_!_xx_!_'); 301 302$na = 0; 303 304$na = eval { ~$aI }; # Hash was not updated 305like($@, qr/no method found/); 306 307bless \$x, OscalarI; 308 309$na = eval { ~$aI }; 310print $@; 311 312ok(!$@); 313is($na, '_!_xx_!_'); 314 315eval "package Oscalar; sub rshft; use overload '>>' => 'rshft'"; 316 317$na = eval { $aI >> 1 }; # Hash was not updated 318like($@, qr/no method found/); 319 320bless \$x, OscalarI; 321 322$na = 0; 323 324$na = eval { $aI >> 1 }; 325print $@; 326 327ok(!$@); 328is($na, '_!_xx_!_'); 329 330# warn overload::Method($a, '0+'), "\n"; 331is(overload::Method($a, '0+'), \&Oscalar::numify); 332is(overload::Method($aI,'0+'), \&Oscalar::numify); 333ok(overload::Overloaded($aI)); 334ok(!overload::Overloaded('overload')); 335 336ok(! defined overload::Method($aI, '<<')); 337ok(! defined overload::Method($a, '<')); 338 339like (overload::StrVal($aI), qr/^OscalarI=SCALAR\(0x[\da-fA-F]+\)$/); 340is(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; 352bless $aII, 'OscalarII'; 353bless \$fake, 'OscalarI'; # update the hash 354is(($aI | 3), '_<<_xx_<<_'); 355# warn $aII << 3; 356is(($aII << 3), '_<<_087_<<_'); 357 358{ 359 BEGIN { $int = 7; overload::constant 'integer' => sub {$int++; shift}; } 360 $out = 2**10; 361} 362is($int, 9); 363is($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 377is($out, 'foo'); 378is($out, $foo); 379is($out1, 'f\'o\\o'); 380is($out1, $foo1); 381is($out2, "a\afoo,\,"); 382is("@q", "foo q f'o\\\\o q a\\a qq ,\\, qq"); 383is($q, 11); 384is("@qr", "b\\b qq .\\. qq"); 385is($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; 396oups 397EOF 398 $b = <<'EOF'; 399oups1 400EOF 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 408is($out, '_<foo>_'); 409is($out1, '_<f\'o\\o>_'); 410is($out2, "_<a\a>_foo_<,\,>_"); 411is("@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"); 414is("@qr1", "b\\b qq .\\. qq try it q first part q yet another qq"); 415is($res, 1); 416is($a, "_<oups 417>_"); 418is($b, "_<oups1 419>_"); 420is($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' => \∁ 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? 702if (defined &CORE::GLOBAL::glob) { 703 is('1', '1'); 704 is('1', '1'); 705 is('1', '1'); 706} 707else { 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 829my $bar = new two_refs 3,4,5,6; 830$bar->[2] = 11; 831is($bar->{two}, 11); 832$bar->{three} = 13; 833is($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; 842is($bar->{two}, 11); 843$bar->{three} = 13; 844is($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; 884is($bar->{two}, 11); 885$bar->{three} = 13; 886is($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; 895is($bar->{two}, 11); 896$bar->{three} = 13; 897is($bar->[3], 13); 898 899{ 900 package B; 901 use overload bool => sub { ${+shift} }; 902} 903 904my $aaa; 905{ my $bbbb = 0; $aaa = bless \$bbbb, B } 906 907is !$aaa, 1; 908 909unless ($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 infinitely 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 1005package Foo; 1006 1007use overload 1008 'bool' => sub { return !$_[0]->is_zero() || undef; } 1009; 1010 1011sub is_zero 1012 { 1013 my $self = shift; 1014 return $self->{var} == 0; 1015 } 1016 1017sub new 1018 { 1019 my $class = shift; 1020 my $self = {}; 1021 $self->{var} = shift; 1022 bless $self,$class; 1023 } 1024 1025package main; 1026 1027use strict; 1028 1029my $r = Foo->new(8); 1030$r = Foo->new(0); 1031 1032is(($r || 0), 0); 1033 1034package utf8_o; 1035 1036use overload 1037 '""' => sub { return $_[0]->{var}; } 1038 ; 1039 1040sub new 1041 { 1042 my $class = shift; 1043 my $self = {}; 1044 $self->{var} = shift; 1045 bless $self,$class; 1046 } 1047 1048package main; 1049 1050 1051my $utfvar = new utf8_o 200.2.1; 1052is("$utfvar", 200.2.1); # 223 - stringify 1053is("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. 1059package Hderef; 1060use overload '%{}' => sub { (caller(0))[0] eq 'Foo' ? $_[0] : die "zap" }; 1061package Foo; 1062@Foo::ISA = 'Hderef'; 1063sub new { bless {}, shift } 1064sub xet { @_ == 2 ? $_[0]->{$_[1]} : 1065 @_ == 3 ? ($_[0]->{$_[1]} = $_[2]) : undef } 1066package main; 1067my $a = Foo->new; 1068$a->xet('b', 42); 1069is ($a->xet('b'), 42); 1070ok (!defined eval { $a->{b} }); 1071like ($@, 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 addresses 1135# are what is getting tested. 1136my ($two, $one, $un, $deux) = map {new Numify $_} 2, 1, 1, 2; 1137my ($ein, $zwei) = (1, 2); 1138 1139my %map = (one => 1, un => 1, ein => 1, deux => 2, two => 2, zwei => 2); 1140foreach 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 nonexistent 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} 1336 1337{ 1338 # Subtle bug pre 5.10, as a side effect of the overloading flag being 1339 # stored on the reference rather than the referent. Despite the fact that 1340 # objects can only be accessed via references (even internally), the 1341 # referent actually knows that it's blessed, not the references. So taking 1342 # a new, unrelated, reference to it gives an object. However, the 1343 # overloading-or-not flag was on the reference prior to 5.10, and taking 1344 # a new reference didn't (use to) copy it. 1345 1346 package kayo; 1347 1348 use overload '""' => sub {${$_[0]}}; 1349 1350 sub Pie { 1351 return "$_[0], $_[1]"; 1352 } 1353 1354 package main; 1355 1356 my $class = 'kayo'; 1357 my $string = 'bam'; 1358 my $crunch_eth = bless \$string, $class; 1359 1360 is("$crunch_eth", $string); 1361 is ($crunch_eth->Pie("Meat"), "$string, Meat"); 1362 1363 my $wham_eth = \$string; 1364 1365 is("$wham_eth", $string, 1366 'This reference did not have overloading in 5.8.8 and earlier'); 1367 is ($crunch_eth->Pie("Apple"), "$string, Apple"); 1368 1369 my $class = ref $wham_eth; 1370 $class =~ s/=.*//; 1371 1372 # Bless it back into its own class! 1373 bless $wham_eth, $class; 1374 1375 is("$wham_eth", $string); 1376 is ($crunch_eth->Pie("Blackbird"), "$string, Blackbird"); 1377} 1378 1379{ 1380 package numify_int; 1381 use overload "0+" => sub { $_[0][0] += 1; 42 }; 1382 package numify_self; 1383 use overload "0+" => sub { $_[0][0]++; $_[0] }; 1384 package numify_other; 1385 use overload "0+" => sub { $_[0][0]++; $_[0][1] = bless [], 'numify_int' }; 1386 package numify_by_fallback; 1387 use overload fallback => 1; 1388 1389 package main; 1390 my $o = bless [], 'numify_int'; 1391 is(int($o), 42, 'numifies to integer'); 1392 is($o->[0], 1, 'int() numifies only once'); 1393 1394 my $aref = []; 1395 my $num_val = int($aref); 1396 my $r = bless $aref, 'numify_self'; 1397 is(int($r), $num_val, 'numifies to self'); 1398 is($r->[0], 1, 'int() numifies once when returning self'); 1399 1400 my $s = bless [], 'numify_other'; 1401 is(int($s), 42, 'numifies to numification of other object'); 1402 is($s->[0], 1, 'int() numifies once when returning other object'); 1403 is($s->[1][0], 1, 'returned object numifies too'); 1404 1405 my $m = bless $aref, 'numify_by_fallback'; 1406 is(int($m), $num_val, 'numifies to usual reference value'); 1407 is(abs($m), $num_val, 'numifies to usual reference value'); 1408 is(-$m, -$num_val, 'numifies to usual reference value'); 1409 is(0+$m, $num_val, 'numifies to usual reference value'); 1410 is($m+0, $num_val, 'numifies to usual reference value'); 1411 is($m+$m, 2*$num_val, 'numifies to usual reference value'); 1412 is(0-$m, -$num_val, 'numifies to usual reference value'); 1413 is(1*$m, $num_val, 'numifies to usual reference value'); 1414 is($m/1, $num_val, 'numifies to usual reference value'); 1415 is($m%100, $num_val%100, 'numifies to usual reference value'); 1416 is($m**1, $num_val, 'numifies to usual reference value'); 1417 1418 is(abs($aref), $num_val, 'abs() of ref'); 1419 is(-$aref, -$num_val, 'negative of ref'); 1420 is(0+$aref, $num_val, 'ref addition'); 1421 is($aref+0, $num_val, 'ref addition'); 1422 is($aref+$aref, 2*$num_val, 'ref addition'); 1423 is(0-$aref, -$num_val, 'subtraction of ref'); 1424 is(1*$aref, $num_val, 'multiplicaton of ref'); 1425 is($aref/1, $num_val, 'division of ref'); 1426 is($aref%100, $num_val%100, 'modulo of ref'); 1427 is($aref**1, $num_val, 'exponentiation of ref'); 1428} 1429 1430# EOF 1431