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 => 561; 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); 364is($int, 9); 365{ 366 BEGIN { overload::constant 'integer' => sub {$int++; shift()+1}; } 367 eval q{$out = 42}; 368} 369is($int, 10); 370is($out, 43); 371 372$foo = 'foo'; 373$foo1 = 'f\'o\\o'; 374{ 375 BEGIN { $q = $qr = 7; 376 overload::constant 'q' => sub {$q++; push @q, shift, ($_[1] || 'none'); shift}, 377 'qr' => sub {$qr++; push @qr, shift, ($_[1] || 'none'); shift}; } 378 $out = 'foo'; 379 $out1 = 'f\'o\\o'; 380 $out2 = "a\a$foo,\,"; 381 /b\b$foo.\./; 382} 383 384is($out, 'foo'); 385is($out, $foo); 386is($out1, 'f\'o\\o'); 387is($out1, $foo1); 388is($out2, "a\afoo,\,"); 389is("@q", "foo q f'o\\\\o q a\\a qq ,\\, qq"); 390is($q, 11); 391is("@qr", "b\\b qq .\\. qq"); 392is($qr, 9); 393 394{ 395 $_ = '!<b>!foo!<-.>!'; 396 BEGIN { overload::constant 'q' => sub {push @q1, shift, ($_[1] || 'none'); "_<" . (shift) . ">_"}, 397 'qr' => sub {push @qr1, shift, ($_[1] || 'none'); "!<" . (shift) . ">!"}; } 398 $out = 'foo'; 399 $out1 = 'f\'o\\o'; 400 $out2 = "a\a$foo,\,"; 401 $res = /b\b$foo.\./; 402 $a = <<EOF; 403oups 404EOF 405 $b = <<'EOF'; 406oups1 407EOF 408 $c = bareword; 409 m'try it'; 410 s'first part'second part'; 411 s/yet another/tail here/; 412 tr/A-Z/a-z/; 413} 414 415is($out, '_<foo>_'); 416is($out1, '_<f\'o\\o>_'); 417is($out2, "_<a\a>_foo_<,\,>_"); 418is("@q1", "foo q f'o\\\\o q a\\a qq ,\\, qq oups 419 qq oups1 420 q second part q tail here s A-Z tr a-z tr"); 421is("@qr1", "b\\b qq .\\. qq try it q first part q yet another qq"); 422is($res, 1); 423is($a, "_<oups 424>_"); 425is($b, "_<oups1 426>_"); 427is($c, "bareword"); 428 429{ 430 package symbolic; # Primitive symbolic calculator 431 use overload nomethod => \&wrap, '""' => \&str, '0+' => \&num, 432 '=' => \&cpy, '++' => \&inc, '--' => \&dec; 433 434 sub new { shift; bless ['n', @_] } 435 sub cpy { 436 my $self = shift; 437 bless [@$self], ref $self; 438 } 439 sub inc { $_[0] = bless ['++', $_[0], 1]; } 440 sub dec { $_[0] = bless ['--', $_[0], 1]; } 441 sub wrap { 442 my ($obj, $other, $inv, $meth) = @_; 443 if ($meth eq '++' or $meth eq '--') { 444 @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference 445 return $obj; 446 } 447 ($obj, $other) = ($other, $obj) if $inv; 448 bless [$meth, $obj, $other]; 449 } 450 sub str { 451 my ($meth, $a, $b) = @{+shift}; 452 $a = 'u' unless defined $a; 453 if (defined $b) { 454 "[$meth $a $b]"; 455 } else { 456 "[$meth $a]"; 457 } 458 } 459 my %subr = ( 'n' => sub {$_[0]} ); 460 foreach my $op (split " ", $overload::ops{with_assign}) { 461 $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}"; 462 } 463 my @bins = qw(binary 3way_comparison num_comparison str_comparison); 464 foreach my $op (split " ", "@overload::ops{ @bins }") { 465 $subr{$op} = eval "sub {shift() $op shift()}"; 466 } 467 foreach my $op (split " ", "@overload::ops{qw(unary func)}") { 468 $subr{$op} = eval "sub {$op shift()}"; 469 } 470 $subr{'++'} = $subr{'+'}; 471 $subr{'--'} = $subr{'-'}; 472 473 sub num { 474 my ($meth, $a, $b) = @{+shift}; 475 my $subr = $subr{$meth} 476 or die "Do not know how to ($meth) in symbolic"; 477 $a = $a->num if ref $a eq __PACKAGE__; 478 $b = $b->num if ref $b eq __PACKAGE__; 479 $subr->($a,$b); 480 } 481 sub TIESCALAR { my $pack = shift; $pack->new(@_) } 482 sub FETCH { shift } 483 sub nop { } # Around a bug 484 sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; } 485 sub STORE { 486 my $obj = shift; 487 $#$obj = 1; 488 $obj->[1] = shift; 489 } 490} 491 492{ 493 my $foo = new symbolic 11; 494 my $baz = $foo++; 495 is((sprintf "%d", $foo), '12'); 496 is((sprintf "%d", $baz), '11'); 497 my $bar = $foo; 498 $baz = ++$foo; 499 is((sprintf "%d", $foo), '13'); 500 is((sprintf "%d", $bar), '12'); 501 is((sprintf "%d", $baz), '13'); 502 my $ban = $foo; 503 $baz = ($foo += 1); 504 is((sprintf "%d", $foo), '14'); 505 is((sprintf "%d", $bar), '12'); 506 is((sprintf "%d", $baz), '14'); 507 is((sprintf "%d", $ban), '13'); 508 $baz = 0; 509 $baz = $foo++; 510 is((sprintf "%d", $foo), '15'); 511 is((sprintf "%d", $baz), '14'); 512 is("$foo", '[++ [+= [++ [++ [n 11] 1] 1] 1] 1]'); 513} 514 515{ 516 my $iter = new symbolic 2; 517 my $side = new symbolic 1; 518 my $cnt = $iter; 519 520 while ($cnt) { 521 $cnt = $cnt - 1; # The "simple" way 522 $side = (sqrt(1 + $side**2) - 1)/$side; 523 } 524 my $pi = $side*(2**($iter+2)); 525 is("$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]'); 526 is((sprintf "%f", $pi), '3.182598'); 527} 528 529{ 530 my $iter = new symbolic 2; 531 my $side = new symbolic 1; 532 my $cnt = $iter; 533 534 while ($cnt--) { 535 $side = (sqrt(1 + $side**2) - 1)/$side; 536 } 537 my $pi = $side*(2**($iter+2)); 538 is("$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]'); 539 is((sprintf "%f", $pi), '3.182598'); 540} 541 542{ 543 my ($a, $b); 544 symbolic->vars($a, $b); 545 my $c = sqrt($a**2 + $b**2); 546 $a = 3; $b = 4; 547 is((sprintf "%d", $c), '5'); 548 $a = 12; $b = 5; 549 is((sprintf "%d", $c), '13'); 550} 551 552{ 553 package symbolic1; # Primitive symbolic calculator 554 # Mutator inc/dec 555 use overload nomethod => \&wrap, '""' => \&str, '0+' => \&num, '=' => \&cpy; 556 557 sub new { shift; bless ['n', @_] } 558 sub cpy { 559 my $self = shift; 560 bless [@$self], ref $self; 561 } 562 sub wrap { 563 my ($obj, $other, $inv, $meth) = @_; 564 if ($meth eq '++' or $meth eq '--') { 565 @$obj = ($meth, (bless [@$obj]), 1); # Avoid circular reference 566 return $obj; 567 } 568 ($obj, $other) = ($other, $obj) if $inv; 569 bless [$meth, $obj, $other]; 570 } 571 sub str { 572 my ($meth, $a, $b) = @{+shift}; 573 $a = 'u' unless defined $a; 574 if (defined $b) { 575 "[$meth $a $b]"; 576 } else { 577 "[$meth $a]"; 578 } 579 } 580 my %subr = ( 'n' => sub {$_[0]} ); 581 foreach my $op (split " ", $overload::ops{with_assign}) { 582 $subr{$op} = $subr{"$op="} = eval "sub {shift() $op shift()}"; 583 } 584 my @bins = qw(binary 3way_comparison num_comparison str_comparison); 585 foreach my $op (split " ", "@overload::ops{ @bins }") { 586 $subr{$op} = eval "sub {shift() $op shift()}"; 587 } 588 foreach my $op (split " ", "@overload::ops{qw(unary func)}") { 589 $subr{$op} = eval "sub {$op shift()}"; 590 } 591 $subr{'++'} = $subr{'+'}; 592 $subr{'--'} = $subr{'-'}; 593 594 sub num { 595 my ($meth, $a, $b) = @{+shift}; 596 my $subr = $subr{$meth} 597 or die "Do not know how to ($meth) in symbolic"; 598 $a = $a->num if ref $a eq __PACKAGE__; 599 $b = $b->num if ref $b eq __PACKAGE__; 600 $subr->($a,$b); 601 } 602 sub TIESCALAR { my $pack = shift; $pack->new(@_) } 603 sub FETCH { shift } 604 sub nop { } # Around a bug 605 sub vars { my $p = shift; tie($_, $p), $_->nop foreach @_; } 606 sub STORE { 607 my $obj = shift; 608 $#$obj = 1; 609 $obj->[1] = shift; 610 } 611} 612 613{ 614 my $foo = new symbolic1 11; 615 my $baz = $foo++; 616 is((sprintf "%d", $foo), '12'); 617 is((sprintf "%d", $baz), '11'); 618 my $bar = $foo; 619 $baz = ++$foo; 620 is((sprintf "%d", $foo), '13'); 621 is((sprintf "%d", $bar), '12'); 622 is((sprintf "%d", $baz), '13'); 623 my $ban = $foo; 624 $baz = ($foo += 1); 625 is((sprintf "%d", $foo), '14'); 626 is((sprintf "%d", $bar), '12'); 627 is((sprintf "%d", $baz), '14'); 628 is((sprintf "%d", $ban), '13'); 629 $baz = 0; 630 $baz = $foo++; 631 is((sprintf "%d", $foo), '15'); 632 is((sprintf "%d", $baz), '14'); 633 is("$foo", '[++ [+= [++ [++ [n 11] 1] 1] 1] 1]'); 634} 635 636{ 637 my $iter = new symbolic1 2; 638 my $side = new symbolic1 1; 639 my $cnt = $iter; 640 641 while ($cnt) { 642 $cnt = $cnt - 1; # The "simple" way 643 $side = (sqrt(1 + $side**2) - 1)/$side; 644 } 645 my $pi = $side*(2**($iter+2)); 646 is("$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]'); 647 is((sprintf "%f", $pi), '3.182598'); 648} 649 650{ 651 my $iter = new symbolic1 2; 652 my $side = new symbolic1 1; 653 my $cnt = $iter; 654 655 while ($cnt--) { 656 $side = (sqrt(1 + $side**2) - 1)/$side; 657 } 658 my $pi = $side*(2**($iter+2)); 659 is("$side", '[/ [- [sqrt [+ 1 [** [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]] 2]]] 1] [/ [- [sqrt [+ 1 [** [n 1] 2]]] 1] [n 1]]]'); 660 is((sprintf "%f", $pi), '3.182598'); 661} 662 663{ 664 my ($a, $b); 665 symbolic1->vars($a, $b); 666 my $c = sqrt($a**2 + $b**2); 667 $a = 3; $b = 4; 668 is((sprintf "%d", $c), '5'); 669 $a = 12; $b = 5; 670 is((sprintf "%d", $c), '13'); 671} 672 673{ 674 package two_face; # Scalars with separate string and 675 # numeric values. 676 sub new { my $p = shift; bless [@_], $p } 677 use overload '""' => \&str, '0+' => \&num, fallback => 1; 678 sub num {shift->[1]} 679 sub str {shift->[0]} 680} 681 682{ 683 my $seven = new two_face ("vii", 7); 684 is((sprintf "seven=$seven, seven=%d, eight=%d", $seven, $seven+1), 685 'seven=vii, seven=7, eight=8'); 686 is(scalar ($seven =~ /i/), '1'); 687} 688 689{ 690 package sorting; 691 use overload 'cmp' => \∁ 692 sub new { my ($p, $v) = @_; bless \$v, $p } 693 sub comp { my ($x,$y) = @_; ($$x * 3 % 10) <=> ($$y * 3 % 10) or $$x cmp $$y } 694} 695{ 696 my @arr = map sorting->new($_), 0..12; 697 my @sorted1 = sort @arr; 698 my @sorted2 = map $$_, @sorted1; 699 is("@sorted2", '0 10 7 4 1 11 8 5 12 2 9 6 3'); 700} 701{ 702 package iterator; 703 use overload '<>' => \&iter; 704 sub new { my ($p, $v) = @_; bless \$v, $p } 705 sub iter { my ($x) = @_; return undef if $$x < 0; return $$x--; } 706} 707 708# XXX iterator overload not intended to work with CORE::GLOBAL? 709if (defined &CORE::GLOBAL::glob) { 710 is('1', '1'); 711 is('1', '1'); 712 is('1', '1'); 713} 714else { 715 my $iter = iterator->new(5); 716 my $acc = ''; 717 my $out; 718 $acc .= " $out" while $out = <${iter}>; 719 is($acc, ' 5 4 3 2 1 0'); 720 $iter = iterator->new(5); 721 is(scalar <${iter}>, '5'); 722 $acc = ''; 723 $acc .= " $out" while $out = <$iter>; 724 is($acc, ' 4 3 2 1 0'); 725} 726{ 727 package deref; 728 use overload '%{}' => \&hderef, '&{}' => \&cderef, 729 '*{}' => \&gderef, '${}' => \&sderef, '@{}' => \&aderef; 730 sub new { my ($p, $v) = @_; bless \$v, $p } 731 sub deref { 732 my ($self, $key) = (shift, shift); 733 my $class = ref $self; 734 bless $self, 'deref::dummy'; # Disable overloading of %{} 735 my $out = $self->{$key}; 736 bless $self, $class; # Restore overloading 737 $out; 738 } 739 sub hderef {shift->deref('h')} 740 sub aderef {shift->deref('a')} 741 sub cderef {shift->deref('c')} 742 sub gderef {shift->deref('g')} 743 sub sderef {shift->deref('s')} 744} 745{ 746 my $deref = bless { h => { foo => 5 , fake => 23 }, 747 c => sub {return shift() + 34}, 748 's' => \123, 749 a => [11..13], 750 g => \*srt, 751 }, 'deref'; 752 # Hash: 753 my @cont = sort %$deref; 754 if ("\t" eq "\011") { # ASCII 755 is("@cont", '23 5 fake foo'); 756 } 757 else { # EBCDIC alpha-numeric sort order 758 is("@cont", 'fake foo 23 5'); 759 } 760 my @keys = sort keys %$deref; 761 is("@keys", 'fake foo'); 762 my @val = sort values %$deref; 763 is("@val", '23 5'); 764 is($deref->{foo}, 5); 765 is(defined $deref->{bar}, ''); 766 my $key; 767 @keys = (); 768 push @keys, $key while $key = each %$deref; 769 @keys = sort @keys; 770 is("@keys", 'fake foo'); 771 is(exists $deref->{bar}, ''); 772 is(exists $deref->{foo}, 1); 773 # Code: 774 is($deref->(5), 39); 775 is(&$deref(6), 40); 776 sub xxx_goto { goto &$deref } 777 is(xxx_goto(7), 41); 778 my $srt = bless { c => sub {$b <=> $a} 779 }, 'deref'; 780 *srt = \&$srt; 781 my @sorted = sort srt 11, 2, 5, 1, 22; 782 is("@sorted", '22 11 5 2 1'); 783 # Scalar 784 is($$deref, 123); 785 # Code 786 @sorted = sort $srt 11, 2, 5, 1, 22; 787 is("@sorted", '22 11 5 2 1'); 788 # Array 789 is("@$deref", '11 12 13'); 790 is($#$deref, '2'); 791 my $l = @$deref; 792 is($l, 3); 793 is($deref->[2], '13'); 794 $l = pop @$deref; 795 is($l, 13); 796 $l = 1; 797 is($deref->[$l], '12'); 798 # Repeated dereference 799 my $double = bless { h => $deref, 800 }, 'deref'; 801 is($double->{foo}, 5); 802} 803 804{ 805 package two_refs; 806 use overload '%{}' => \&gethash, '@{}' => sub { ${shift()} }; 807 sub new { 808 my $p = shift; 809 bless \ [@_], $p; 810 } 811 sub gethash { 812 my %h; 813 my $self = shift; 814 tie %h, ref $self, $self; 815 \%h; 816 } 817 818 sub TIEHASH { my $p = shift; bless \ shift, $p } 819 my %fields; 820 my $i = 0; 821 $fields{$_} = $i++ foreach qw{zero one two three}; 822 sub STORE { 823 my $self = ${shift()}; 824 my $key = $fields{shift()}; 825 defined $key or die "Out of band access"; 826 $$self->[$key] = shift; 827 } 828 sub FETCH { 829 my $self = ${shift()}; 830 my $key = $fields{shift()}; 831 defined $key or die "Out of band access"; 832 $$self->[$key]; 833 } 834} 835 836my $bar = new two_refs 3,4,5,6; 837$bar->[2] = 11; 838is($bar->{two}, 11); 839$bar->{three} = 13; 840is($bar->[3], 13); 841 842{ 843 package two_refs_o; 844 @ISA = ('two_refs'); 845} 846 847$bar = new two_refs_o 3,4,5,6; 848$bar->[2] = 11; 849is($bar->{two}, 11); 850$bar->{three} = 13; 851is($bar->[3], 13); 852 853{ 854 package two_refs1; 855 use overload '%{}' => sub { ${shift()}->[1] }, 856 '@{}' => sub { ${shift()}->[0] }; 857 sub new { 858 my $p = shift; 859 my $a = [@_]; 860 my %h; 861 tie %h, $p, $a; 862 bless \ [$a, \%h], $p; 863 } 864 sub gethash { 865 my %h; 866 my $self = shift; 867 tie %h, ref $self, $self; 868 \%h; 869 } 870 871 sub TIEHASH { my $p = shift; bless \ shift, $p } 872 my %fields; 873 my $i = 0; 874 $fields{$_} = $i++ foreach qw{zero one two three}; 875 sub STORE { 876 my $a = ${shift()}; 877 my $key = $fields{shift()}; 878 defined $key or die "Out of band access"; 879 $a->[$key] = shift; 880 } 881 sub FETCH { 882 my $a = ${shift()}; 883 my $key = $fields{shift()}; 884 defined $key or die "Out of band access"; 885 $a->[$key]; 886 } 887} 888 889$bar = new two_refs_o 3,4,5,6; 890$bar->[2] = 11; 891is($bar->{two}, 11); 892$bar->{three} = 13; 893is($bar->[3], 13); 894 895{ 896 package two_refs1_o; 897 @ISA = ('two_refs1'); 898} 899 900$bar = new two_refs1_o 3,4,5,6; 901$bar->[2] = 11; 902is($bar->{two}, 11); 903$bar->{three} = 13; 904is($bar->[3], 13); 905 906{ 907 package B; 908 use overload bool => sub { ${+shift} }; 909} 910 911my $aaa; 912{ my $bbbb = 0; $aaa = bless \$bbbb, B } 913 914is !$aaa, 1; 915 916unless ($aaa) { 917 pass(); 918} else { 919 fail(); 920} 921 922# check that overload isn't done twice by join 923{ my $c = 0; 924 package Join; 925 use overload '""' => sub { $c++ }; 926 my $x = join '', bless([]), 'pq', bless([]); 927 main::is $x, '0pq1'; 928}; 929 930# Test module-specific warning 931{ 932 # check the Odd number of arguments for overload::constant warning 933 my $a = "" ; 934 local $SIG{__WARN__} = sub {$a = $_[0]} ; 935 $x = eval ' overload::constant "integer" ; ' ; 936 is($a, ""); 937 use warnings 'overload' ; 938 $x = eval ' overload::constant "integer" ; ' ; 939 like($a, qr/^Odd number of arguments for overload::constant at/); 940} 941 942{ 943 # check the `$_[0]' is not an overloadable type warning 944 my $a = "" ; 945 local $SIG{__WARN__} = sub {$a = $_[0]} ; 946 $x = eval ' overload::constant "fred" => sub {} ; ' ; 947 is($a, ""); 948 use warnings 'overload' ; 949 $x = eval ' overload::constant "fred" => sub {} ; ' ; 950 like($a, qr/^`fred' is not an overloadable type at/); 951} 952 953{ 954 # check the `$_[1]' is not a code reference warning 955 my $a = "" ; 956 local $SIG{__WARN__} = sub {$a = $_[0]} ; 957 $x = eval ' overload::constant "integer" => 1; ' ; 958 is($a, ""); 959 use warnings 'overload' ; 960 $x = eval ' overload::constant "integer" => 1; ' ; 961 like($a, qr/^`1' is not a code reference at/); 962} 963 964{ 965 my $c = 0; 966 package ov_int1; 967 use overload '""' => sub { 3+shift->[0] }, 968 '0+' => sub { 10+shift->[0] }, 969 'int' => sub { 100+shift->[0] }; 970 sub new {my $p = shift; bless [shift], $p} 971 972 package ov_int2; 973 use overload '""' => sub { 5+shift->[0] }, 974 '0+' => sub { 30+shift->[0] }, 975 'int' => sub { 'ov_int1'->new(1000+shift->[0]) }; 976 sub new {my $p = shift; bless [shift], $p} 977 978 package noov_int; 979 use overload '""' => sub { 2+shift->[0] }, 980 '0+' => sub { 9+shift->[0] }; 981 sub new {my $p = shift; bless [shift], $p} 982 983 package main; 984 985 my $x = new noov_int 11; 986 my $int_x = int $x; 987 main::is("$int_x", 20); 988 $x = new ov_int1 31; 989 $int_x = int $x; 990 main::is("$int_x", 131); 991 $x = new ov_int2 51; 992 $int_x = int $x; 993 main::is("$int_x", 1054); 994} 995 996# make sure that we don't infinitely recurse 997{ 998 my $c = 0; 999 package Recurse; 1000 use overload '""' => sub { shift }, 1001 '0+' => sub { shift }, 1002 'bool' => sub { shift }, 1003 fallback => 1; 1004 my $x = bless([]); 1005 # For some reason beyond me these have to be oks rather than likes. 1006 main::ok("$x" =~ /Recurse=ARRAY/); 1007 main::ok($x); 1008 main::ok($x+0 =~ qr/Recurse=ARRAY/); 1009} 1010 1011# BugID 20010422.003 1012package Foo; 1013 1014use overload 1015 'bool' => sub { return !$_[0]->is_zero() || undef; } 1016; 1017 1018sub is_zero 1019 { 1020 my $self = shift; 1021 return $self->{var} == 0; 1022 } 1023 1024sub new 1025 { 1026 my $class = shift; 1027 my $self = {}; 1028 $self->{var} = shift; 1029 bless $self,$class; 1030 } 1031 1032package main; 1033 1034use strict; 1035 1036my $r = Foo->new(8); 1037$r = Foo->new(0); 1038 1039is(($r || 0), 0); 1040 1041package utf8_o; 1042 1043use overload 1044 '""' => sub { return $_[0]->{var}; } 1045 ; 1046 1047sub new 1048 { 1049 my $class = shift; 1050 my $self = {}; 1051 $self->{var} = shift; 1052 bless $self,$class; 1053 } 1054 1055package main; 1056 1057 1058my $utfvar = new utf8_o 200.2.1; 1059is("$utfvar", 200.2.1); # 223 - stringify 1060is("a$utfvar", "a".200.2.1); # 224 - overload via sv_2pv_flags 1061 1062# 225..227 -- more %{} tests. Hangs in 5.6.0, okay in later releases. 1063# Basically this example implements strong encapsulation: if Hderef::import() 1064# were to eval the overload code in the caller's namespace, the privatisation 1065# would be quite transparent. 1066package Hderef; 1067use overload '%{}' => sub { (caller(0))[0] eq 'Foo' ? $_[0] : die "zap" }; 1068package Foo; 1069@Foo::ISA = 'Hderef'; 1070sub new { bless {}, shift } 1071sub xet { @_ == 2 ? $_[0]->{$_[1]} : 1072 @_ == 3 ? ($_[0]->{$_[1]} = $_[2]) : undef } 1073package main; 1074my $a = Foo->new; 1075$a->xet('b', 42); 1076is ($a->xet('b'), 42); 1077ok (!defined eval { $a->{b} }); 1078like ($@, qr/zap/); 1079 1080{ 1081 package t229; 1082 use overload '=' => sub { 42 }, 1083 '++' => sub { my $x = ${$_[0]}; $_[0] }; 1084 sub new { my $x = 42; bless \$x } 1085 1086 my $warn; 1087 { 1088 local $SIG{__WARN__} = sub { $warn++ }; 1089 my $x = t229->new; 1090 my $y = $x; 1091 eval { $y++ }; 1092 } 1093 main::ok (!$warn); 1094} 1095 1096{ 1097 my ($int, $out1, $out2); 1098 { 1099 BEGIN { $int = 0; overload::constant 'integer' => sub {$int++; 17}; } 1100 $out1 = 0; 1101 $out2 = 1; 1102 } 1103 is($int, 2, "#24313"); # 230 1104 is($out1, 17, "#24313"); # 231 1105 is($out2, 17, "#24313"); # 232 1106} 1107 1108{ 1109 package Numify; 1110 use overload (qw(0+ numify fallback 1)); 1111 1112 sub new { 1113 my $val = $_[1]; 1114 bless \$val, $_[0]; 1115 } 1116 1117 sub numify { ${$_[0]} } 1118} 1119 1120{ 1121 package perl31793; 1122 use overload cmp => sub { 0 }; 1123 package perl31793_fb; 1124 use overload cmp => sub { 0 }, fallback => 1; 1125 package main; 1126 my $o = bless [], 'perl31793'; 1127 my $of = bless [], 'perl31793_fb'; 1128 my $no = bless [], 'no_overload'; 1129 like(overload::StrVal(\"scalar"), qr/^SCALAR\(0x[0-9a-f]+\)$/); 1130 like(overload::StrVal([]), qr/^ARRAY\(0x[0-9a-f]+\)$/); 1131 like(overload::StrVal({}), qr/^HASH\(0x[0-9a-f]+\)$/); 1132 like(overload::StrVal(sub{1}), qr/^CODE\(0x[0-9a-f]+\)$/); 1133 like(overload::StrVal(\*GLOB), qr/^GLOB\(0x[0-9a-f]+\)$/); 1134 like(overload::StrVal(\$o), qr/^REF\(0x[0-9a-f]+\)$/); 1135 like(overload::StrVal(qr/a/), qr/^Regexp=SCALAR\(0x[0-9a-f]+\)$/); 1136 like(overload::StrVal($o), qr/^perl31793=ARRAY\(0x[0-9a-f]+\)$/); 1137 like(overload::StrVal($of), qr/^perl31793_fb=ARRAY\(0x[0-9a-f]+\)$/); 1138 like(overload::StrVal($no), qr/^no_overload=ARRAY\(0x[0-9a-f]+\)$/); 1139} 1140 1141# These are all check that overloaded values rather than reference addresses 1142# are what is getting tested. 1143my ($two, $one, $un, $deux) = map {new Numify $_} 2, 1, 1, 2; 1144my ($ein, $zwei) = (1, 2); 1145 1146my %map = (one => 1, un => 1, ein => 1, deux => 2, two => 2, zwei => 2); 1147foreach my $op (qw(<=> == != < <= > >=)) { 1148 foreach my $l (keys %map) { 1149 foreach my $r (keys %map) { 1150 my $ocode = "\$$l $op \$$r"; 1151 my $rcode = "$map{$l} $op $map{$r}"; 1152 1153 my $got = eval $ocode; 1154 die if $@; 1155 my $expect = eval $rcode; 1156 die if $@; 1157 is ($got, $expect, $ocode) or print "# $rcode\n"; 1158 } 1159 } 1160} 1161{ 1162 # check that overloading works in regexes 1163 { 1164 package Foo493; 1165 use overload 1166 '""' => sub { "^$_[0][0]\$" }, 1167 '.' => sub { 1168 bless [ 1169 $_[2] 1170 ? (ref $_[1] ? $_[1][0] : $_[1]) . ':' .$_[0][0] 1171 : $_[0][0] . ':' . (ref $_[1] ? $_[1][0] : $_[1]) 1172 ], 'Foo493' 1173 }; 1174 } 1175 1176 my $a = bless [ "a" ], 'Foo493'; 1177 like('a', qr/$a/); 1178 like('x:a', qr/x$a/); 1179 like('x:a:=', qr/x$a=$/); 1180 like('x:a:a:=', qr/x$a$a=$/); 1181 1182} 1183 1184{ 1185 my $twenty_three = 23; 1186 # Check that constant overloading propagates into evals 1187 BEGIN { overload::constant integer => sub { 23 } } 1188 is(eval "17", $twenty_three); 1189} 1190 1191{ 1192 package Sklorsh; 1193 use overload 1194 bool => sub { shift->is_cool }; 1195 1196 sub is_cool { 1197 $_[0]->{name} eq 'cool'; 1198 } 1199 1200 sub delete { 1201 undef %{$_[0]}; 1202 bless $_[0], 'Brap'; 1203 return 1; 1204 } 1205 1206 sub delete_with_self { 1207 my $self = shift; 1208 undef %$self; 1209 bless $self, 'Brap'; 1210 return 1; 1211 } 1212 1213 package Brap; 1214 1215 1; 1216 1217 package main; 1218 1219 my $obj; 1220 $obj = bless {name => 'cool'}, 'Sklorsh'; 1221 $obj->delete; 1222 ok(eval {if ($obj) {1}; 1}, $@ || 'reblessed into nonexistent namespace'); 1223 1224 $obj = bless {name => 'cool'}, 'Sklorsh'; 1225 $obj->delete_with_self; 1226 ok (eval {if ($obj) {1}; 1}, $@); 1227 1228 my $a = $b = {name => 'hot'}; 1229 bless $b, 'Sklorsh'; 1230 is(ref $a, 'Sklorsh'); 1231 is(ref $b, 'Sklorsh'); 1232 ok(!$b, "Expect overloaded boolean"); 1233 ok(!$a, "Expect overloaded boolean"); 1234} 1235{ 1236 use Scalar::Util 'weaken'; 1237 1238 package Shklitza; 1239 use overload '""' => sub {"CLiK KLAK"}; 1240 1241 package Ksshfwoom; 1242 1243 package main; 1244 1245 my ($obj, $ref); 1246 $obj = bless do {my $a; \$a}, 'Shklitza'; 1247 $ref = $obj; 1248 1249 is ($obj, "CLiK KLAK"); 1250 is ($ref, "CLiK KLAK"); 1251 1252 weaken $ref; 1253 is ($ref, "CLiK KLAK"); 1254 1255 bless $obj, 'Ksshfwoom'; 1256 1257 like ($obj, qr/^Ksshfwoom=/); 1258 like ($ref, qr/^Ksshfwoom=/); 1259 1260 undef $obj; 1261 is ($ref, undef); 1262} 1263 1264{ 1265 package bit; 1266 # bit operations have overloadable assignment variants too 1267 1268 sub new { bless \$_[1], $_[0] } 1269 1270 use overload 1271 "&=" => sub { bit->new($_[0]->val . ' & ' . $_[1]->val) }, 1272 "^=" => sub { bit->new($_[0]->val . ' ^ ' . $_[1]->val) }, 1273 "|" => sub { bit->new($_[0]->val . ' | ' . $_[1]->val) }, # |= by fallback 1274 ; 1275 1276 sub val { ${$_[0]} } 1277 1278 package main; 1279 1280 my $a = bit->new(my $va = 'a'); 1281 my $b = bit->new(my $vb = 'b'); 1282 1283 $a &= $b; 1284 is($a->val, 'a & b', "overloaded &= works"); 1285 1286 my $c = bit->new(my $vc = 'c'); 1287 1288 $b ^= $c; 1289 is($b->val, 'b ^ c', "overloaded ^= works"); 1290 1291 my $d = bit->new(my $vd = 'd'); 1292 1293 $c |= $d; 1294 is($c->val, 'c | d', "overloaded |= (by fallback) works"); 1295} 1296 1297{ 1298 # comparison operators with nomethod 1299 my $warning = ""; 1300 my $method; 1301 1302 package nomethod_false; 1303 use overload nomethod => sub { $method = 'nomethod'; 0 }; 1304 1305 package nomethod_true; 1306 use overload nomethod => sub { $method= 'nomethod'; 'true' }; 1307 1308 package main; 1309 local $^W = 1; 1310 local $SIG{__WARN__} = sub { $warning = $_[0] }; 1311 1312 my $f = bless [], 'nomethod_false'; 1313 ($warning, $method) = ("", ""); 1314 is($f eq 'whatever', 0, 'nomethod makes eq return 0'); 1315 is($method, 'nomethod'); 1316 1317 my $t = bless [], 'nomethod_true'; 1318 ($warning, $method) = ("", ""); 1319 is($t eq 'whatever', 'true', 'nomethod makes eq return "true"'); 1320 is($method, 'nomethod'); 1321 is($warning, "", 'nomethod eq need not return number'); 1322 1323 eval q{ 1324 package nomethod_false; 1325 use overload cmp => sub { $method = 'cmp'; 0 }; 1326 }; 1327 $f = bless [], 'nomethod_false'; 1328 ($warning, $method) = ("", ""); 1329 ok($f eq 'whatever', 'eq falls back to cmp (nomethod not called)'); 1330 is($method, 'cmp'); 1331 1332 eval q{ 1333 package nomethod_true; 1334 use overload cmp => sub { $method = 'cmp'; 'true' }; 1335 }; 1336 $t = bless [], 'nomethod_true'; 1337 ($warning, $method) = ("", ""); 1338 ok($t eq 'whatever', 'eq falls back to cmp (nomethod not called)'); 1339 is($method, 'cmp'); 1340 like($warning, qr/isn't numeric/, 'cmp should return number'); 1341 1342} 1343 1344{ 1345 # Subtle bug pre 5.10, as a side effect of the overloading flag being 1346 # stored on the reference rather than the referent. Despite the fact that 1347 # objects can only be accessed via references (even internally), the 1348 # referent actually knows that it's blessed, not the references. So taking 1349 # a new, unrelated, reference to it gives an object. However, the 1350 # overloading-or-not flag was on the reference prior to 5.10, and taking 1351 # a new reference didn't (use to) copy it. 1352 1353 package kayo; 1354 1355 use overload '""' => sub {${$_[0]}}; 1356 1357 sub Pie { 1358 return "$_[0], $_[1]"; 1359 } 1360 1361 package main; 1362 1363 my $class = 'kayo'; 1364 my $string = 'bam'; 1365 my $crunch_eth = bless \$string, $class; 1366 1367 is("$crunch_eth", $string); 1368 is ($crunch_eth->Pie("Meat"), "$string, Meat"); 1369 1370 my $wham_eth = \$string; 1371 1372 is("$wham_eth", $string, 1373 'This reference did not have overloading in 5.8.8 and earlier'); 1374 is ($crunch_eth->Pie("Apple"), "$string, Apple"); 1375 1376 my $class = ref $wham_eth; 1377 $class =~ s/=.*//; 1378 1379 # Bless it back into its own class! 1380 bless $wham_eth, $class; 1381 1382 is("$wham_eth", $string); 1383 is ($crunch_eth->Pie("Blackbird"), "$string, Blackbird"); 1384} 1385 1386{ 1387 package numify_int; 1388 use overload "0+" => sub { $_[0][0] += 1; 42 }; 1389 package numify_self; 1390 use overload "0+" => sub { $_[0][0]++; $_[0] }; 1391 package numify_other; 1392 use overload "0+" => sub { $_[0][0]++; $_[0][1] = bless [], 'numify_int' }; 1393 package numify_by_fallback; 1394 use overload fallback => 1; 1395 1396 package main; 1397 my $o = bless [], 'numify_int'; 1398 is(int($o), 42, 'numifies to integer'); 1399 is($o->[0], 1, 'int() numifies only once'); 1400 1401 my $aref = []; 1402 my $num_val = int($aref); 1403 my $r = bless $aref, 'numify_self'; 1404 is(int($r), $num_val, 'numifies to self'); 1405 is($r->[0], 1, 'int() numifies once when returning self'); 1406 1407 my $s = bless [], 'numify_other'; 1408 is(int($s), 42, 'numifies to numification of other object'); 1409 is($s->[0], 1, 'int() numifies once when returning other object'); 1410 is($s->[1][0], 1, 'returned object numifies too'); 1411 1412 my $m = bless $aref, 'numify_by_fallback'; 1413 is(int($m), $num_val, 'numifies to usual reference value'); 1414 is(abs($m), $num_val, 'numifies to usual reference value'); 1415 is(-$m, -$num_val, 'numifies to usual reference value'); 1416 is(0+$m, $num_val, 'numifies to usual reference value'); 1417 is($m+0, $num_val, 'numifies to usual reference value'); 1418 is($m+$m, 2*$num_val, 'numifies to usual reference value'); 1419 is(0-$m, -$num_val, 'numifies to usual reference value'); 1420 is(1*$m, $num_val, 'numifies to usual reference value'); 1421 is($m/1, $num_val, 'numifies to usual reference value'); 1422 is($m%100, $num_val%100, 'numifies to usual reference value'); 1423 is($m**1, $num_val, 'numifies to usual reference value'); 1424 1425 is(abs($aref), $num_val, 'abs() of ref'); 1426 is(-$aref, -$num_val, 'negative of ref'); 1427 is(0+$aref, $num_val, 'ref addition'); 1428 is($aref+0, $num_val, 'ref addition'); 1429 is($aref+$aref, 2*$num_val, 'ref addition'); 1430 is(0-$aref, -$num_val, 'subtraction of ref'); 1431 is(1*$aref, $num_val, 'multiplicaton of ref'); 1432 is($aref/1, $num_val, 'division of ref'); 1433 is($aref%100, $num_val%100, 'modulo of ref'); 1434 is($aref**1, $num_val, 'exponentiation of ref'); 1435} 1436 1437{ 1438 package CopyConstructorFallback; 1439 use overload 1440 '++' => sub { "$_[0]"; $_[0] }, 1441 fallback => 1; 1442 sub new { bless {} => shift } 1443 1444 package main; 1445 1446 my $o = CopyConstructorFallback->new; 1447 my $x = $o++; # would segfault 1448 my $y = ++$o; 1449 is($x, $o, "copy constructor falls back to assignment (postinc)"); 1450 is($y, $o, "copy constructor falls back to assignment (preinc)"); 1451} 1452 1453# EOF 1454