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