1#!./perl -w 2# 3# testsuite for Data::Dumper 4# 5 6BEGIN { 7 require Config; import Config; 8 if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { 9 print "1..0 # Skip: Data::Dumper was not built\n"; 10 exit 0; 11 } 12} 13 14# Since Perl 5.8.1 because otherwise hash ordering is really random. 15local $Data::Dumper::Sortkeys = 1; 16 17use Data::Dumper; 18use Config; 19 20$Data::Dumper::Pad = "#"; 21my $TMAX; 22my $XS; 23my $TNUM = 0; 24my $WANT = ''; 25 26# Perl 5.16 was the first version that correctly handled Unicode in typeglob 27# names. Tests for how globs are dumped must revise their expectations 28# downwards when run on earlier Perls. 29sub change_glob_expectation { 30 my ($input) = @_; 31 if ($] < 5.016) { 32 $input =~ s<\\x\{([0-9a-f]+)\}>{ 33 my $s = chr hex $1; 34 utf8::encode($s); 35 join '', map sprintf('\\%o', ord), split //, $s; 36 }ge; 37 } 38 return $input; 39} 40 41sub convert_to_native($) { 42 my $input = shift; 43 44 # unicode_to_native() not available before this release; hence won't work 45 # on EBCDIC platforms for earlier. 46 return $input if $] lt 5.007_003; 47 48 my @output; 49 50 # The input should always be one of the following constructs 51 while ($input =~ m/ ( \\ [0-7]+ ) 52 | ( \\ x \{ [[:xdigit:]]+ } ) 53 | ( \\ . ) 54 | ( . ) /gx) 55 { 56 #print STDERR __LINE__, ": ", $&, "\n"; 57 my $index; 58 my $replacement; 59 if (defined $4) { # Literal 60 $index = ord $4; 61 $replacement = $4; 62 } 63 elsif (defined $3) { # backslash escape 64 $index = ord eval "\"$3\""; 65 $replacement = $3; 66 } 67 elsif (defined $2) { # Hex 68 $index = utf8::unicode_to_native(ord eval "\"$2\""); 69 70 # But low hex numbers are always in octal. These are all 71 # controls. 72 my $format = ($index < ord(" ")) 73 ? "\\%o" 74 : "\\x{%x}"; 75 $replacement = sprintf($format, $index); 76 } 77 elsif (defined $1) { # Octal 78 $index = utf8::unicode_to_native(ord eval "\"$1\""); 79 $replacement = sprintf("\\%o", $index); 80 } 81 else { 82 die "Unexpected match in convert_to_native()"; 83 } 84 85 if (defined $output[$index]) { 86 print STDERR "ordinal $index already has '$output[$index]'; skipping '$replacement'\n"; 87 next; 88 } 89 90 $output[$index] = $replacement; 91 } 92 93 return join "", grep { defined } @output; 94} 95 96sub TEST { 97 my $string = shift; 98 my $name = shift; 99 my $t = eval $string; 100 ++$TNUM; 101 $t =~ s/([A-Z]+)\(0x[0-9a-f]+\)/$1(0xdeadbeef)/g 102 if ($WANT =~ /deadbeef/); 103 $name = $name ? " - $name" : ''; 104 print( ($t eq $WANT and not $@) ? "ok $TNUM$name\n" 105 : "not ok $TNUM$name\n--Expected--\n$WANT\n--Got--\n$@$t\n"); 106 107 ++$TNUM; 108 eval "$t"; 109 print $@ ? "not ok $TNUM\n# \$@ says: $@\n" : "ok $TNUM - no eval error\n"; 110 111 $t = eval $string; 112 ++$TNUM; 113 $t =~ s/([A-Z]+)\(0x[0-9a-f]+\)/$1(0xdeadbeef)/g 114 if ($WANT =~ /deadbeef/); 115 print( ($t eq $WANT and not $@) ? "ok $TNUM - works a 2nd time after intervening eval\n" 116 : "not ok $TNUM - re-evaled version \n--Expected--\n$WANT\n--Got--\n$@$t\n"); 117} 118 119sub SKIP_TEST { 120 my $reason = shift; 121 ++$TNUM; print "ok $TNUM # skip $reason\n"; 122 ++$TNUM; print "ok $TNUM # skip $reason\n"; 123 ++$TNUM; print "ok $TNUM # skip $reason\n"; 124} 125 126$TMAX = 468; 127 128# Force Data::Dumper::Dump to use perl. We test Dumpxs explicitly by calling 129# it direct. Out here it lets us knobble the next if to test that the perl 130# only tests do work (and count correctly) 131$Data::Dumper::Useperl = 1; 132if (defined &Data::Dumper::Dumpxs) { 133 print "### XS extension loaded, will run XS tests\n"; 134 $XS = 1; 135} 136else { 137 print "### XS extensions not loaded, will NOT run XS tests\n"; 138 $TMAX /= 2; 139 $XS = 0; 140} 141 142print "1..$TMAX\n"; 143 144#XXXif (0) { 145############# 146############# 147 148@c = ('c'); 149$c = \@c; 150$b = {}; 151$a = [1, $b, $c]; 152$b->{a} = $a; 153$b->{b} = $a->[1]; 154$b->{c} = $a->[2]; 155 156############# 157## 158$WANT = <<'EOT'; 159#$a = [ 160# 1, 161# { 162# 'a' => $a, 163# 'b' => $a->[1], 164# 'c' => [ 165# 'c' 166# ] 167# }, 168# $a->[1]{'c'} 169# ]; 170#$b = $a->[1]; 171#$6 = $a->[1]{'c'}; 172EOT 173 174TEST (q(Data::Dumper->Dump([$a,$b,$c], [qw(a b), 6])), 175 'basic test with names: Dump()'); 176TEST (q(Data::Dumper->Dumpxs([$a,$b,$c], [qw(a b), 6])), 177 'basic test with names: Dumpxs()') 178 if $XS; 179 180SCOPE: { 181 local $Data::Dumper::Sparseseen = 1; 182 TEST (q(Data::Dumper->Dump([$a,$b,$c], [qw(a b), 6])), 183 'Sparseseen with names: Dump()'); 184 TEST (q(Data::Dumper->Dumpxs([$a,$b,$c], [qw(a b), 6])), 185 'Sparseseen with names: Dumpxs()') 186 if $XS; 187} 188 189 190############# 191## 192$WANT = <<'EOT'; 193#@a = ( 194# 1, 195# { 196# 'a' => [], 197# 'b' => {}, 198# 'c' => [ 199# 'c' 200# ] 201# }, 202# [] 203# ); 204#$a[1]{'a'} = \@a; 205#$a[1]{'b'} = $a[1]; 206#$a[2] = $a[1]{'c'}; 207#$b = $a[1]; 208EOT 209 210$Data::Dumper::Purity = 1; # fill in the holes for eval 211TEST (q(Data::Dumper->Dump([$a, $b], [qw(*a b)])), 212 'Purity: basic test with dereferenced array: Dump()'); # print as @a 213TEST (q(Data::Dumper->Dumpxs([$a, $b], [qw(*a b)])), 214 'Purity: basic test with dereferenced array: Dumpxs()') 215 if $XS; 216 217SCOPE: { 218 local $Data::Dumper::Sparseseen = 1; 219 TEST (q(Data::Dumper->Dump([$a, $b], [qw(*a b)])), 220 'Purity: Sparseseen with dereferenced array: Dump()'); # print as @a 221 TEST (q(Data::Dumper->Dumpxs([$a, $b], [qw(*a b)])), 222 'Purity: Sparseseen with dereferenced array: Dumpxs()') 223 if $XS; 224} 225 226############# 227## 228$WANT = <<'EOT'; 229#%b = ( 230# 'a' => [ 231# 1, 232# {}, 233# [ 234# 'c' 235# ] 236# ], 237# 'b' => {}, 238# 'c' => [] 239# ); 240#$b{'a'}[1] = \%b; 241#$b{'b'} = \%b; 242#$b{'c'} = $b{'a'}[2]; 243#$a = $b{'a'}; 244EOT 245 246TEST (q(Data::Dumper->Dump([$b, $a], [qw(*b a)])), 247 'basic test with dereferenced hash: Dump()'); # print as %b 248TEST (q(Data::Dumper->Dumpxs([$b, $a], [qw(*b a)])), 249 'basic test with dereferenced hash: Dumpxs()') 250 if $XS; 251 252############# 253## 254$WANT = <<'EOT'; 255#$a = [ 256# 1, 257# { 258# 'a' => [], 259# 'b' => {}, 260# 'c' => [] 261# }, 262# [] 263#]; 264#$a->[1]{'a'} = $a; 265#$a->[1]{'b'} = $a->[1]; 266#$a->[1]{'c'} = \@c; 267#$a->[2] = \@c; 268#$b = $a->[1]; 269EOT 270 271$Data::Dumper::Indent = 1; 272TEST (q( 273 $d = Data::Dumper->new([$a,$b], [qw(a b)]); 274 $d->Seen({'*c' => $c}); 275 $d->Dump; 276 ), 277 'Indent: Seen: Dump()'); 278if ($XS) { 279 TEST (q( 280 $d = Data::Dumper->new([$a,$b], [qw(a b)]); 281 $d->Seen({'*c' => $c}); 282 $d->Dumpxs; 283 ), 284 'Indent: Seen: Dumpxs()'); 285} 286 287 288############# 289## 290$WANT = <<'EOT'; 291#$a = [ 292# #0 293# 1, 294# #1 295# { 296# a => $a, 297# b => $a->[1], 298# c => [ 299# #0 300# 'c' 301# ] 302# }, 303# #2 304# $a->[1]{c} 305# ]; 306#$b = $a->[1]; 307EOT 308 309$d->Indent(3); 310$d->Purity(0)->Quotekeys(0); 311TEST (q( $d->Reset; $d->Dump ), 312 'Indent(3): Purity(0)->Quotekeys(0): Dump()'); 313 314TEST (q( $d->Reset; $d->Dumpxs ), 315 'Indent(3): Purity(0)->Quotekeys(0): Dumpxs()') 316 if $XS; 317 318############# 319## 320$WANT = <<'EOT'; 321#$VAR1 = [ 322# 1, 323# { 324# 'a' => [], 325# 'b' => {}, 326# 'c' => [ 327# 'c' 328# ] 329# }, 330# [] 331#]; 332#$VAR1->[1]{'a'} = $VAR1; 333#$VAR1->[1]{'b'} = $VAR1->[1]; 334#$VAR1->[2] = $VAR1->[1]{'c'}; 335EOT 336 337TEST (q(Dumper($a)), 'Dumper'); 338TEST (q(Data::Dumper::DumperX($a)), 'DumperX') if $XS; 339 340############# 341## 342$WANT = <<'EOT'; 343#[ 344# 1, 345# { 346# a => $VAR1, 347# b => $VAR1->[1], 348# c => [ 349# 'c' 350# ] 351# }, 352# $VAR1->[1]{c} 353#] 354EOT 355 356{ 357 local $Data::Dumper::Purity = 0; 358 local $Data::Dumper::Quotekeys = 0; 359 local $Data::Dumper::Terse = 1; 360 TEST (q(Dumper($a)), 361 'Purity 0: Quotekeys 0: Terse 1: Dumper'); 362 TEST (q(Data::Dumper::DumperX($a)), 363 'Purity 0: Quotekeys 0: Terse 1: DumperX') 364 if $XS; 365} 366 367 368############# 369## 370$WANT = <<'EOT'; 371#$VAR1 = { 372# "abc\0'\efg" => "mno\0", 373# "reftest" => \\1 374#}; 375EOT 376 377$foo = { "abc\000\'\efg" => "mno\000", 378 "reftest" => \\1, 379 }; 380{ 381 local $Data::Dumper::Useqq = 1; 382 TEST (q(Dumper($foo)), 'Useqq: Dumper'); 383 TEST (q(Data::Dumper::DumperX($foo)), 'Useqq: DumperX') if $XS; 384} 385 386 387 388############# 389############# 390 391{ 392 package main; 393 use Data::Dumper; 394 $foo = 5; 395 @foo = (-10,\*foo); 396 %foo = (a=>1,b=>\$foo,c=>\@foo); 397 $foo{d} = \%foo; 398 $foo[2] = \%foo; 399 400############# 401## 402 $WANT = <<'EOT'; 403#$foo = \*::foo; 404#*::foo = \5; 405#*::foo = [ 406# #0 407# -10, 408# #1 409# do{my $o}, 410# #2 411# { 412# 'a' => 1, 413# 'b' => do{my $o}, 414# 'c' => [], 415# 'd' => {} 416# } 417# ]; 418#*::foo{ARRAY}->[1] = $foo; 419#*::foo{ARRAY}->[2]{'b'} = *::foo{SCALAR}; 420#*::foo{ARRAY}->[2]{'c'} = *::foo{ARRAY}; 421#*::foo{ARRAY}->[2]{'d'} = *::foo{ARRAY}->[2]; 422#*::foo = *::foo{ARRAY}->[2]; 423#@bar = @{*::foo{ARRAY}}; 424#%baz = %{*::foo{ARRAY}->[2]}; 425EOT 426 427 $Data::Dumper::Purity = 1; 428 $Data::Dumper::Indent = 3; 429 TEST (q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])), 430 'Purity 1: Indent 3: Dump()'); 431 TEST (q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])), 432 'Purity 1: Indent 3: Dumpxs()') 433 if $XS; 434 435############# 436## 437 $WANT = <<'EOT'; 438#$foo = \*::foo; 439#*::foo = \5; 440#*::foo = [ 441# -10, 442# do{my $o}, 443# { 444# 'a' => 1, 445# 'b' => do{my $o}, 446# 'c' => [], 447# 'd' => {} 448# } 449#]; 450#*::foo{ARRAY}->[1] = $foo; 451#*::foo{ARRAY}->[2]{'b'} = *::foo{SCALAR}; 452#*::foo{ARRAY}->[2]{'c'} = *::foo{ARRAY}; 453#*::foo{ARRAY}->[2]{'d'} = *::foo{ARRAY}->[2]; 454#*::foo = *::foo{ARRAY}->[2]; 455#$bar = *::foo{ARRAY}; 456#$baz = *::foo{ARRAY}->[2]; 457EOT 458 459 $Data::Dumper::Indent = 1; 460 TEST (q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])), 461 'Purity 1: Indent 1: Dump()'); 462 TEST (q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])), 463 'Purity 1: Indent 1: Dumpxs()') 464 if $XS; 465 466############# 467## 468 $WANT = <<'EOT'; 469#@bar = ( 470# -10, 471# \*::foo, 472# {} 473#); 474#*::foo = \5; 475#*::foo = \@bar; 476#*::foo = { 477# 'a' => 1, 478# 'b' => do{my $o}, 479# 'c' => [], 480# 'd' => {} 481#}; 482#*::foo{HASH}->{'b'} = *::foo{SCALAR}; 483#*::foo{HASH}->{'c'} = \@bar; 484#*::foo{HASH}->{'d'} = *::foo{HASH}; 485#$bar[2] = *::foo{HASH}; 486#%baz = %{*::foo{HASH}}; 487#$foo = $bar[1]; 488EOT 489 490 TEST (q(Data::Dumper->Dump([\\@foo, \\%foo, \\*foo], ['*bar', '*baz', '*foo'])), 491 'array|hash|glob dereferenced: Dump()'); 492 TEST (q(Data::Dumper->Dumpxs([\\@foo, \\%foo, \\*foo], ['*bar', '*baz', '*foo'])), 493 'array|hash|glob dereferenced: Dumpxs()') 494 if $XS; 495 496############# 497## 498 $WANT = <<'EOT'; 499#$bar = [ 500# -10, 501# \*::foo, 502# {} 503#]; 504#*::foo = \5; 505#*::foo = $bar; 506#*::foo = { 507# 'a' => 1, 508# 'b' => do{my $o}, 509# 'c' => [], 510# 'd' => {} 511#}; 512#*::foo{HASH}->{'b'} = *::foo{SCALAR}; 513#*::foo{HASH}->{'c'} = $bar; 514#*::foo{HASH}->{'d'} = *::foo{HASH}; 515#$bar->[2] = *::foo{HASH}; 516#$baz = *::foo{HASH}; 517#$foo = $bar->[1]; 518EOT 519 520 TEST (q(Data::Dumper->Dump([\\@foo, \\%foo, \\*foo], ['bar', 'baz', 'foo'])), 521 'array|hash|glob: not dereferenced: Dump()'); 522 TEST (q(Data::Dumper->Dumpxs([\\@foo, \\%foo, \\*foo], ['bar', 'baz', 'foo'])), 523 'array|hash|glob: not dereferenced: Dumpxs()') 524 if $XS; 525 526############# 527## 528 $WANT = <<'EOT'; 529#$foo = \*::foo; 530#@bar = ( 531# -10, 532# $foo, 533# { 534# a => 1, 535# b => \5, 536# c => \@bar, 537# d => $bar[2] 538# } 539#); 540#%baz = %{$bar[2]}; 541EOT 542 543 $Data::Dumper::Purity = 0; 544 $Data::Dumper::Quotekeys = 0; 545 TEST (q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])), 546 'Purity 0: Quotekeys 0: dereferenced: Dump()'); 547 TEST (q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])), 548 'Purity 0: Quotekeys 0: dereferenced: Dumpxs') 549 if $XS; 550 551############# 552## 553 $WANT = <<'EOT'; 554#$foo = \*::foo; 555#$bar = [ 556# -10, 557# $foo, 558# { 559# a => 1, 560# b => \5, 561# c => $bar, 562# d => $bar->[2] 563# } 564#]; 565#$baz = $bar->[2]; 566EOT 567 568 TEST (q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])), 569 'Purity 0: Quotekeys 0: not dereferenced: Dump()'); 570 TEST (q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])), 571 'Purity 0: Quotekeys 0: not dereferenced: Dumpxs()') 572 if $XS; 573 574} 575 576############# 577############# 578{ 579 package main; 580 @dogs = ( 'Fido', 'Wags' ); 581 %kennel = ( 582 First => \$dogs[0], 583 Second => \$dogs[1], 584 ); 585 $dogs[2] = \%kennel; 586 $mutts = \%kennel; 587 $mutts = $mutts; # avoid warning 588 589############# 590## 591 $WANT = <<'EOT'; 592#%kennels = ( 593# First => \'Fido', 594# Second => \'Wags' 595#); 596#@dogs = ( 597# ${$kennels{First}}, 598# ${$kennels{Second}}, 599# \%kennels 600#); 601#%mutts = %kennels; 602EOT 603 604 TEST (q( 605 $d = Data::Dumper->new([\\%kennel, \\@dogs, $mutts], 606 [qw(*kennels *dogs *mutts)] ); 607 $d->Dump; 608 ), 609 'constructor: hash|array|scalar: Dump()'); 610 if ($XS) { 611 TEST (q( 612 $d = Data::Dumper->new([\\%kennel, \\@dogs, $mutts], 613 [qw(*kennels *dogs *mutts)] ); 614 $d->Dumpxs; 615 ), 616 'constructor: hash|array|scalar: Dumpxs()'); 617 } 618 619############# 620## 621 $WANT = <<'EOT'; 622#%kennels = %kennels; 623#@dogs = @dogs; 624#%mutts = %kennels; 625EOT 626 627 TEST q($d->Dump), 'object call: Dump'; 628 TEST q($d->Dumpxs), 'object call: Dumpxs' if $XS; 629 630############# 631## 632 $WANT = <<'EOT'; 633#%kennels = ( 634# First => \'Fido', 635# Second => \'Wags' 636#); 637#@dogs = ( 638# ${$kennels{First}}, 639# ${$kennels{Second}}, 640# \%kennels 641#); 642#%mutts = %kennels; 643EOT 644 645 TEST q($d->Reset; $d->Dump), 'Reset and Dump separate calls'; 646 if ($XS) { 647 TEST (q($d->Reset; $d->Dumpxs), 'Reset and Dumpxs separate calls'); 648 } 649 650############# 651## 652 $WANT = <<'EOT'; 653#@dogs = ( 654# 'Fido', 655# 'Wags', 656# { 657# First => \$dogs[0], 658# Second => \$dogs[1] 659# } 660#); 661#%kennels = %{$dogs[2]}; 662#%mutts = %{$dogs[2]}; 663EOT 664 665 TEST (q( 666 $d = Data::Dumper->new([\\@dogs, \\%kennel, $mutts], 667 [qw(*dogs *kennels *mutts)] ); 668 $d->Dump; 669 ), 670 'constructor: array|hash|scalar: Dump()'); 671 if ($XS) { 672 TEST (q( 673 $d = Data::Dumper->new([\\@dogs, \\%kennel, $mutts], 674 [qw(*dogs *kennels *mutts)] ); 675 $d->Dumpxs; 676 ), 677 'constructor: array|hash|scalar: Dumpxs()'); 678 } 679 680############# 681## 682 TEST q($d->Reset->Dump), 'Reset Dump chained'; 683 if ($XS) { 684 TEST q($d->Reset->Dumpxs), 'Reset Dumpxs chained'; 685 } 686 687############# 688## 689 $WANT = <<'EOT'; 690#@dogs = ( 691# 'Fido', 692# 'Wags', 693# { 694# First => \'Fido', 695# Second => \'Wags' 696# } 697#); 698#%kennels = ( 699# First => \'Fido', 700# Second => \'Wags' 701#); 702EOT 703 704 TEST (q( 705 $d = Data::Dumper->new( [\@dogs, \%kennel], [qw(*dogs *kennels)] ); 706 $d->Deepcopy(1)->Dump; 707 ), 708 'Deepcopy(1): Dump'); 709 if ($XS) { 710# TEST 'q($d->Reset->Dumpxs); 711 TEST (q( 712 $d = Data::Dumper->new( [\@dogs, \%kennel], [qw(*dogs *kennels)] ); 713 $d->Deepcopy(1)->Dumpxs; 714 ), 715 'Deepcopy(1): Dumpxs'); 716 } 717 718} 719 720{ 721 722sub z { print "foo\n" } 723$c = [ \&z ]; 724 725############# 726## 727 $WANT = <<'EOT'; 728#$a = $b; 729#$c = [ 730# $b 731#]; 732EOT 733 734TEST (q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'b' => \&z})->Dump;), 735 'Seen: scalar: Dump'); 736TEST (q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'b' => \&z})->Dumpxs;), 737 'Seen: scalar: Dumpxs') 738 if $XS; 739 740############# 741## 742 $WANT = <<'EOT'; 743#$a = \&b; 744#$c = [ 745# \&b 746#]; 747EOT 748 749TEST (q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'*b' => \&z})->Dump;), 750 'Seen: glob: Dump'); 751TEST (q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'*b' => \&z})->Dumpxs;), 752 'Seen: glob: Dumpxs') 753 if $XS; 754 755############# 756## 757 $WANT = <<'EOT'; 758#*a = \&b; 759#@c = ( 760# \&b 761#); 762EOT 763 764TEST (q(Data::Dumper->new([\&z,$c],['*a','*c'])->Seen({'*b' => \&z})->Dump;), 765 'Seen: glob: dereference: Dump'); 766TEST (q(Data::Dumper->new([\&z,$c],['*a','*c'])->Seen({'*b' => 767\&z})->Dumpxs;), 768 'Seen: glob: derference: Dumpxs') 769 if $XS; 770 771} 772 773{ 774 $a = []; 775 $a->[1] = \$a->[0]; 776 777############# 778## 779 $WANT = <<'EOT'; 780#@a = ( 781# undef, 782# do{my $o} 783#); 784#$a[1] = \$a[0]; 785EOT 786 787TEST (q(Data::Dumper->new([$a],['*a'])->Purity(1)->Dump;), 788 'Purity(1): dereference: Dump'); 789TEST (q(Data::Dumper->new([$a],['*a'])->Purity(1)->Dumpxs;), 790 'Purity(1): dereference: Dumpxs') 791 if $XS; 792} 793 794{ 795 $a = \\\\\'foo'; 796 $b = $$$a; 797 798############# 799## 800 $WANT = <<'EOT'; 801#$a = \\\\\'foo'; 802#$b = ${${$a}}; 803EOT 804 805TEST (q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dump;), 806 'Purity(1): not dereferenced: Dump'); 807TEST (q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dumpxs;), 808 'Purity(1): not dereferenced: Dumpxs') 809 if $XS; 810} 811 812{ 813 $a = [{ a => \$b }, { b => undef }]; 814 $b = [{ c => \$b }, { d => \$a }]; 815 816############# 817## 818 $WANT = <<'EOT'; 819#$a = [ 820# { 821# a => \[ 822# { 823# c => do{my $o} 824# }, 825# { 826# d => \[] 827# } 828# ] 829# }, 830# { 831# b => undef 832# } 833#]; 834#${$a->[0]{a}}->[0]->{c} = $a->[0]{a}; 835#${${$a->[0]{a}}->[1]->{d}} = $a; 836#$b = ${$a->[0]{a}}; 837EOT 838 839TEST (q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dump;), 840 'Purity(1): Dump again'); 841TEST (q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dumpxs;), 842 'Purity(1); Dumpxs again') 843 if $XS; 844} 845 846{ 847 $a = [[[[\\\\\'foo']]]]; 848 $b = $a->[0][0]; 849 $c = $${$b->[0][0]}; 850 851############# 852## 853 $WANT = <<'EOT'; 854#$a = [ 855# [ 856# [ 857# [ 858# \\\\\'foo' 859# ] 860# ] 861# ] 862#]; 863#$b = $a->[0][0]; 864#$c = ${${$a->[0][0][0][0]}}; 865EOT 866 867TEST (q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Purity(1)->Dump;), 868 'Purity(1): Dump: 3 elements'); 869TEST (q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Purity(1)->Dumpxs;), 870 'Purity(1): Dumpxs: 3 elements') 871 if $XS; 872} 873 874{ 875 $f = "pearl"; 876 $e = [ $f ]; 877 $d = { 'e' => $e }; 878 $c = [ $d ]; 879 $b = { 'c' => $c }; 880 $a = { 'b' => $b }; 881 882############# 883## 884 $WANT = <<'EOT'; 885#$a = { 886# b => { 887# c => [ 888# { 889# e => 'ARRAY(0xdeadbeef)' 890# } 891# ] 892# } 893#}; 894#$b = $a->{b}; 895#$c = $a->{b}{c}; 896EOT 897 898TEST (q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(4)->Dump;), 899 'Maxdepth(4): Dump()'); 900TEST (q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(4)->Dumpxs;), 901 'Maxdepth(4): Dumpxs()') 902 if $XS; 903 904############# 905## 906 $WANT = <<'EOT'; 907#$a = { 908# b => 'HASH(0xdeadbeef)' 909#}; 910#$b = $a->{b}; 911#$c = [ 912# 'HASH(0xdeadbeef)' 913#]; 914EOT 915 916TEST (q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(1)->Dump;), 917 'Maxdepth(1): Dump()'); 918TEST (q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(1)->Dumpxs;), 919 'Maxdepth(1): Dumpxs()') 920 if $XS; 921} 922 923{ 924 $a = \$a; 925 $b = [$a]; 926 927############# 928## 929 $WANT = <<'EOT'; 930#$b = [ 931# \$b->[0] 932#]; 933EOT 934 935TEST (q(Data::Dumper->new([$b],['b'])->Purity(0)->Dump;), 936 'Purity(0): Dump()'); 937TEST (q(Data::Dumper->new([$b],['b'])->Purity(0)->Dumpxs;), 938 'Purity(0): Dumpxs()') 939 if $XS; 940 941############# 942## 943 $WANT = <<'EOT'; 944#$b = [ 945# \do{my $o} 946#]; 947#${$b->[0]} = $b->[0]; 948EOT 949 950 951TEST (q(Data::Dumper->new([$b],['b'])->Purity(1)->Dump;), 952 'Purity(1): Dump()'); 953TEST (q(Data::Dumper->new([$b],['b'])->Purity(1)->Dumpxs;), 954 'Purity(1): Dumpxs') 955 if $XS; 956} 957 958{ 959 $a = "\x{09c10}"; 960############# 961## XS code was adding an extra \0 962 $WANT = <<'EOT'; 963#$a = "\x{9c10}"; 964EOT 965 966 if($] >= 5.007) { 967 TEST q(Data::Dumper->Dump([$a], ['a'])), "\\x{9c10}"; 968 } else { 969 SKIP_TEST "Incomplete support for UTF-8 in old perls"; 970 } 971 TEST q(Data::Dumper->Dumpxs([$a], ['a'])), "XS \\x{9c10}" 972 if $XS; 973} 974 975{ 976 $i = 0; 977 $a = { map { ("$_$_$_", ++$i) } 'I'..'Q' }; 978 979############# 980## 981 $WANT = <<'EOT'; 982#$VAR1 = { 983# III => 1, 984# JJJ => 2, 985# KKK => 3, 986# LLL => 4, 987# MMM => 5, 988# NNN => 6, 989# OOO => 7, 990# PPP => 8, 991# QQQ => 9 992#}; 993EOT 994 995TEST (q(Data::Dumper->new([$a])->Dump;), 996 'basic test without names: Dump()'); 997TEST (q(Data::Dumper->new([$a])->Dumpxs;), 998 'basic test without names: Dumpxs()') 999 if $XS; 1000} 1001 1002{ 1003 $i = 5; 1004 $c = { map { (++$i, "$_$_$_") } 'I'..'Q' }; 1005 local $Data::Dumper::Sortkeys = \&sort199; 1006 sub sort199 { 1007 my $hash = shift; 1008 return [ sort { $b <=> $a } keys %$hash ]; 1009 } 1010 1011############# 1012## 1013 $WANT = <<'EOT'; 1014#$VAR1 = { 1015# 14 => 'QQQ', 1016# 13 => 'PPP', 1017# 12 => 'OOO', 1018# 11 => 'NNN', 1019# 10 => 'MMM', 1020# 9 => 'LLL', 1021# 8 => 'KKK', 1022# 7 => 'JJJ', 1023# 6 => 'III' 1024#}; 1025EOT 1026 1027TEST q(Data::Dumper->new([$c])->Dump;), "sortkeys sub"; 1028TEST q(Data::Dumper->new([$c])->Dumpxs;), "sortkeys sub (XS)" 1029 if $XS; 1030} 1031 1032{ 1033 $i = 5; 1034 $c = { map { (++$i, "$_$_$_") } 'I'..'Q' }; 1035 $d = { reverse %$c }; 1036 local $Data::Dumper::Sortkeys = \&sort205; 1037 sub sort205 { 1038 my $hash = shift; 1039 return [ 1040 $hash eq $c ? (sort { $a <=> $b } keys %$hash) 1041 : (reverse sort keys %$hash) 1042 ]; 1043 } 1044 1045############# 1046## 1047 $WANT = <<'EOT'; 1048#$VAR1 = [ 1049# { 1050# 6 => 'III', 1051# 7 => 'JJJ', 1052# 8 => 'KKK', 1053# 9 => 'LLL', 1054# 10 => 'MMM', 1055# 11 => 'NNN', 1056# 12 => 'OOO', 1057# 13 => 'PPP', 1058# 14 => 'QQQ' 1059# }, 1060# { 1061# QQQ => 14, 1062# PPP => 13, 1063# OOO => 12, 1064# NNN => 11, 1065# MMM => 10, 1066# LLL => 9, 1067# KKK => 8, 1068# JJJ => 7, 1069# III => 6 1070# } 1071#]; 1072EOT 1073 1074TEST q(Data::Dumper->new([[$c, $d]])->Dump;), "more sortkeys sub"; 1075# the XS code does number values as strings 1076$WANT =~ s/ (\d+)(,?)$/ '$1'$2/gm; 1077TEST q(Data::Dumper->new([[$c, $d]])->Dumpxs;), "more sortkeys sub (XS)" 1078 if $XS; 1079} 1080 1081{ 1082 local $Data::Dumper::Deparse = 1; 1083 local $Data::Dumper::Indent = 2; 1084 1085############# 1086## 1087 $WANT = <<'EOT'; 1088#$VAR1 = { 1089# foo => sub { 1090# print 'foo'; 1091# } 1092# }; 1093EOT 1094 1095 if(" $Config{'extensions'} " !~ m[ B ]) { 1096 SKIP_TEST "Perl configured without B module"; 1097 } else { 1098 TEST (q(Data::Dumper->new([{ foo => sub { print "foo"; } }])->Dump), 1099 'Deparse 1: Indent 2; Dump()'); 1100 } 1101} 1102 1103############# 1104## 1105 1106# This is messy. 1107# The controls (bare numbers) are stored either as integers or floating point. 1108# [depending on whether the tokeniser sees things like ".". 1109# The peephole optimiser only runs for constant folding, not single constants, 1110# so I already have some NVs, some IVs 1111# The string versions are not. They are all PV 1112 1113# This is arguably all far too chummy with the implementation, but I really 1114# want to ensure that we don't go wrong when flags on scalars get as side 1115# effects of reading them. 1116 1117# These tests are actually testing the precise output of the current 1118# implementation, so will most likely fail if the implementation changes, 1119# even if the new implementation produces different but correct results. 1120# It would be nice to test for wrong answers, but I can't see how to do that, 1121# so instead I'm checking for unexpected answers. (ie -2 becoming "-2" is not 1122# wrong, but I can't see an easy, reliable way to code that knowledge) 1123 1124# Numbers (seen by the tokeniser as numbers, stored as numbers. 1125 @numbers = 1126 ( 1127 0, +1, -2, 3.0, +4.0, -5.0, 6.5, +7.5, -8.5, 1128 9, +10, -11, 12.0, +13.0, -14.0, 15.5, +16.25, -17.75, 1129 ); 1130# Strings 1131 @strings = 1132 ( 1133 "0", "+1", "-2", "3.0", "+4.0", "-5.0", "6.5", "+7.5", "-8.5", " 9", 1134 " +10", " -11", " 12.0", " +13.0", " -14.0", " 15.5", " +16.25", " -17.75", 1135 ); 1136 1137# The perl code always does things the same way for numbers. 1138 $WANT_PL_N = <<'EOT'; 1139#$VAR1 = 0; 1140#$VAR2 = 1; 1141#$VAR3 = -2; 1142#$VAR4 = 3; 1143#$VAR5 = 4; 1144#$VAR6 = -5; 1145#$VAR7 = '6.5'; 1146#$VAR8 = '7.5'; 1147#$VAR9 = '-8.5'; 1148#$VAR10 = 9; 1149#$VAR11 = 10; 1150#$VAR12 = -11; 1151#$VAR13 = 12; 1152#$VAR14 = 13; 1153#$VAR15 = -14; 1154#$VAR16 = '15.5'; 1155#$VAR17 = '16.25'; 1156#$VAR18 = '-17.75'; 1157EOT 1158# The perl code knows that 0 and -2 stringify exactly back to the strings, 1159# so it dumps them as numbers, not strings. 1160 $WANT_PL_S = <<'EOT'; 1161#$VAR1 = 0; 1162#$VAR2 = '+1'; 1163#$VAR3 = -2; 1164#$VAR4 = '3.0'; 1165#$VAR5 = '+4.0'; 1166#$VAR6 = '-5.0'; 1167#$VAR7 = '6.5'; 1168#$VAR8 = '+7.5'; 1169#$VAR9 = '-8.5'; 1170#$VAR10 = ' 9'; 1171#$VAR11 = ' +10'; 1172#$VAR12 = ' -11'; 1173#$VAR13 = ' 12.0'; 1174#$VAR14 = ' +13.0'; 1175#$VAR15 = ' -14.0'; 1176#$VAR16 = ' 15.5'; 1177#$VAR17 = ' +16.25'; 1178#$VAR18 = ' -17.75'; 1179EOT 1180 1181# The XS code differs. 1182# These are the numbers as seen by the tokeniser. Constants aren't folded 1183# (which makes IVs where possible) so values the tokeniser thought were 1184# floating point are stored as NVs. The XS code outputs these as strings, 1185# but as it has converted them from NVs, leading + signs will not be there. 1186 $WANT_XS_N = <<'EOT'; 1187#$VAR1 = 0; 1188#$VAR2 = 1; 1189#$VAR3 = -2; 1190#$VAR4 = '3'; 1191#$VAR5 = '4'; 1192#$VAR6 = '-5'; 1193#$VAR7 = '6.5'; 1194#$VAR8 = '7.5'; 1195#$VAR9 = '-8.5'; 1196#$VAR10 = 9; 1197#$VAR11 = 10; 1198#$VAR12 = -11; 1199#$VAR13 = '12'; 1200#$VAR14 = '13'; 1201#$VAR15 = '-14'; 1202#$VAR16 = '15.5'; 1203#$VAR17 = '16.25'; 1204#$VAR18 = '-17.75'; 1205EOT 1206 1207# These are the strings as seen by the tokeniser. The XS code will output 1208# these for all cases except where the scalar has been used in integer context 1209 $WANT_XS_S = <<'EOT'; 1210#$VAR1 = '0'; 1211#$VAR2 = '+1'; 1212#$VAR3 = '-2'; 1213#$VAR4 = '3.0'; 1214#$VAR5 = '+4.0'; 1215#$VAR6 = '-5.0'; 1216#$VAR7 = '6.5'; 1217#$VAR8 = '+7.5'; 1218#$VAR9 = '-8.5'; 1219#$VAR10 = ' 9'; 1220#$VAR11 = ' +10'; 1221#$VAR12 = ' -11'; 1222#$VAR13 = ' 12.0'; 1223#$VAR14 = ' +13.0'; 1224#$VAR15 = ' -14.0'; 1225#$VAR16 = ' 15.5'; 1226#$VAR17 = ' +16.25'; 1227#$VAR18 = ' -17.75'; 1228EOT 1229 1230# These are the numbers as IV-ized by & 1231# These will differ from WANT_XS_N because now IV flags will be set on all 1232# values that were actually integer, and the XS code will then output these 1233# as numbers not strings. 1234 $WANT_XS_I = <<'EOT'; 1235#$VAR1 = 0; 1236#$VAR2 = 1; 1237#$VAR3 = -2; 1238#$VAR4 = 3; 1239#$VAR5 = 4; 1240#$VAR6 = -5; 1241#$VAR7 = '6.5'; 1242#$VAR8 = '7.5'; 1243#$VAR9 = '-8.5'; 1244#$VAR10 = 9; 1245#$VAR11 = 10; 1246#$VAR12 = -11; 1247#$VAR13 = 12; 1248#$VAR14 = 13; 1249#$VAR15 = -14; 1250#$VAR16 = '15.5'; 1251#$VAR17 = '16.25'; 1252#$VAR18 = '-17.75'; 1253EOT 1254 1255# Some of these tests will be redundant. 1256@numbers_s = @numbers_i = @numbers_is = @numbers_n = @numbers_ns = @numbers_ni 1257 = @numbers_nis = @numbers; 1258@strings_s = @strings_i = @strings_is = @strings_n = @strings_ns = @strings_ni 1259 = @strings_nis = @strings; 1260# Use them in an integer context 1261foreach (@numbers_i, @numbers_ni, @numbers_nis, @numbers_is, 1262 @strings_i, @strings_ni, @strings_nis, @strings_is) { 1263 my $b = sprintf "%d", $_; 1264} 1265# Use them in a floating point context 1266foreach (@numbers_n, @numbers_ni, @numbers_nis, @numbers_ns, 1267 @strings_n, @strings_ni, @strings_nis, @strings_ns) { 1268 my $b = sprintf "%e", $_; 1269} 1270# Use them in a string context 1271foreach (@numbers_s, @numbers_is, @numbers_nis, @numbers_ns, 1272 @strings_s, @strings_is, @strings_nis, @strings_ns) { 1273 my $b = sprintf "%s", $_; 1274} 1275 1276# use Devel::Peek; Dump ($_) foreach @vanilla_c; 1277 1278$WANT=$WANT_PL_N; 1279TEST q(Data::Dumper->new(\@numbers)->Dump), 'Numbers'; 1280TEST q(Data::Dumper->new(\@numbers_s)->Dump), 'Numbers PV'; 1281TEST q(Data::Dumper->new(\@numbers_i)->Dump), 'Numbers IV'; 1282TEST q(Data::Dumper->new(\@numbers_is)->Dump), 'Numbers IV,PV'; 1283TEST q(Data::Dumper->new(\@numbers_n)->Dump), 'Numbers NV'; 1284TEST q(Data::Dumper->new(\@numbers_ns)->Dump), 'Numbers NV,PV'; 1285TEST q(Data::Dumper->new(\@numbers_ni)->Dump), 'Numbers NV,IV'; 1286TEST q(Data::Dumper->new(\@numbers_nis)->Dump), 'Numbers NV,IV,PV'; 1287$WANT=$WANT_PL_S; 1288TEST q(Data::Dumper->new(\@strings)->Dump), 'Strings'; 1289TEST q(Data::Dumper->new(\@strings_s)->Dump), 'Strings PV'; 1290TEST q(Data::Dumper->new(\@strings_i)->Dump), 'Strings IV'; 1291TEST q(Data::Dumper->new(\@strings_is)->Dump), 'Strings IV,PV'; 1292TEST q(Data::Dumper->new(\@strings_n)->Dump), 'Strings NV'; 1293TEST q(Data::Dumper->new(\@strings_ns)->Dump), 'Strings NV,PV'; 1294TEST q(Data::Dumper->new(\@strings_ni)->Dump), 'Strings NV,IV'; 1295TEST q(Data::Dumper->new(\@strings_nis)->Dump), 'Strings NV,IV,PV'; 1296if ($XS) { 1297 my $nv_preserves_uv = defined $Config{d_nv_preserves_uv}; 1298 my $nv_preserves_uv_4bits = exists($Config{nv_preserves_uv_bits}) && $Config{nv_preserves_uv_bits} >= 4; 1299 $WANT=$WANT_XS_N; 1300 TEST q(Data::Dumper->new(\@numbers)->Dumpxs), 'XS Numbers'; 1301 TEST q(Data::Dumper->new(\@numbers_s)->Dumpxs), 'XS Numbers PV'; 1302 if ($nv_preserves_uv || $nv_preserves_uv_4bits) { 1303 $WANT=$WANT_XS_I; 1304 TEST q(Data::Dumper->new(\@numbers_i)->Dumpxs), 'XS Numbers IV'; 1305 TEST q(Data::Dumper->new(\@numbers_is)->Dumpxs), 'XS Numbers IV,PV'; 1306 } else { 1307 SKIP_TEST "NV does not preserve 4bits"; 1308 SKIP_TEST "NV does not preserve 4bits"; 1309 } 1310 $WANT=$WANT_XS_N; 1311 TEST q(Data::Dumper->new(\@numbers_n)->Dumpxs), 'XS Numbers NV'; 1312 TEST q(Data::Dumper->new(\@numbers_ns)->Dumpxs), 'XS Numbers NV,PV'; 1313 if ($nv_preserves_uv || $nv_preserves_uv_4bits) { 1314 $WANT=$WANT_XS_I; 1315 TEST q(Data::Dumper->new(\@numbers_ni)->Dumpxs), 'XS Numbers NV,IV'; 1316 TEST q(Data::Dumper->new(\@numbers_nis)->Dumpxs), 'XS Numbers NV,IV,PV'; 1317 } else { 1318 SKIP_TEST "NV does not preserve 4bits"; 1319 SKIP_TEST "NV does not preserve 4bits"; 1320 } 1321 1322 $WANT=$WANT_XS_S; 1323 TEST q(Data::Dumper->new(\@strings)->Dumpxs), 'XS Strings'; 1324 TEST q(Data::Dumper->new(\@strings_s)->Dumpxs), 'XS Strings PV'; 1325 # This one used to really mess up. New code actually emulates the .pm code 1326 $WANT=$WANT_PL_S; 1327 TEST q(Data::Dumper->new(\@strings_i)->Dumpxs), 'XS Strings IV'; 1328 TEST q(Data::Dumper->new(\@strings_is)->Dumpxs), 'XS Strings IV,PV'; 1329 if ($nv_preserves_uv || $nv_preserves_uv_4bits) { 1330 $WANT=$WANT_XS_S; 1331 TEST q(Data::Dumper->new(\@strings_n)->Dumpxs), 'XS Strings NV'; 1332 TEST q(Data::Dumper->new(\@strings_ns)->Dumpxs), 'XS Strings NV,PV'; 1333 } else { 1334 SKIP_TEST "NV does not preserve 4bits"; 1335 SKIP_TEST "NV does not preserve 4bits"; 1336 } 1337 # This one used to really mess up. New code actually emulates the .pm code 1338 $WANT=$WANT_PL_S; 1339 TEST q(Data::Dumper->new(\@strings_ni)->Dumpxs), 'XS Strings NV,IV'; 1340 TEST q(Data::Dumper->new(\@strings_nis)->Dumpxs), 'XS Strings NV,IV,PV'; 1341} 1342 1343{ 1344 $a = "1\n"; 1345############# 1346## Perl code was using /...$/ and hence missing the \n. 1347 $WANT = <<'EOT'; 1348my $VAR1 = '42 1349'; 1350EOT 1351 1352 # Can't pad with # as the output has an embedded newline. 1353 local $Data::Dumper::Pad = "my "; 1354 TEST q(Data::Dumper->Dump(["42\n"])), "number with trailing newline"; 1355 TEST q(Data::Dumper->Dumpxs(["42\n"])), "XS number with trailing newline" 1356 if $XS; 1357} 1358 1359{ 1360 @a = ( 1361 999999999, 1362 1000000000, 1363 9999999999, 1364 10000000000, 1365 -999999999, 1366 -1000000000, 1367 -9999999999, 1368 -10000000000, 1369 4294967295, 1370 4294967296, 1371 -2147483648, 1372 -2147483649, 1373 ); 1374############# 1375## Perl code flips over at 10 digits. 1376 $WANT = <<'EOT'; 1377#$VAR1 = 999999999; 1378#$VAR2 = '1000000000'; 1379#$VAR3 = '9999999999'; 1380#$VAR4 = '10000000000'; 1381#$VAR5 = -999999999; 1382#$VAR6 = '-1000000000'; 1383#$VAR7 = '-9999999999'; 1384#$VAR8 = '-10000000000'; 1385#$VAR9 = '4294967295'; 1386#$VAR10 = '4294967296'; 1387#$VAR11 = '-2147483648'; 1388#$VAR12 = '-2147483649'; 1389EOT 1390 1391 TEST q(Data::Dumper->Dump(\@a)), "long integers"; 1392 1393 if ($XS) { 1394## XS code flips over at 11 characters ("-" is a char) or larger than int. 1395 if (~0 == 0xFFFFFFFF) { 1396 # 32 bit system 1397 $WANT = <<'EOT'; 1398#$VAR1 = 999999999; 1399#$VAR2 = 1000000000; 1400#$VAR3 = '9999999999'; 1401#$VAR4 = '10000000000'; 1402#$VAR5 = -999999999; 1403#$VAR6 = '-1000000000'; 1404#$VAR7 = '-9999999999'; 1405#$VAR8 = '-10000000000'; 1406#$VAR9 = 4294967295; 1407#$VAR10 = '4294967296'; 1408#$VAR11 = '-2147483648'; 1409#$VAR12 = '-2147483649'; 1410EOT 1411 } else { 1412 $WANT = <<'EOT'; 1413#$VAR1 = 999999999; 1414#$VAR2 = 1000000000; 1415#$VAR3 = 9999999999; 1416#$VAR4 = '10000000000'; 1417#$VAR5 = -999999999; 1418#$VAR6 = '-1000000000'; 1419#$VAR7 = '-9999999999'; 1420#$VAR8 = '-10000000000'; 1421#$VAR9 = 4294967295; 1422#$VAR10 = 4294967296; 1423#$VAR11 = '-2147483648'; 1424#$VAR12 = '-2147483649'; 1425EOT 1426 } 1427 TEST q(Data::Dumper->Dumpxs(\@a)), "XS long integers"; 1428 } 1429} 1430 1431{ 1432 $b = "Bad. XS didn't escape dollar sign"; 1433############# 1434 # B6 is chosen because it is UTF-8 variant on ASCII and all 3 EBCDIC 1435 # platforms that Perl currently purports to work on. It also is the only 1436 # such code point that has the same meaning on all 4, the paragraph sign. 1437 $WANT = <<"EOT"; # Careful. This is '' string written inside "" here doc 1438#\$VAR1 = '\$b\"\@\\\\\xB6'; 1439EOT 1440 1441 $a = "\$b\"\@\\\xB6\x{100}"; 1442 chop $a; 1443 TEST q(Data::Dumper->Dump([$a])), "utf8 flag with \" and \$"; 1444 if ($XS) { 1445 $WANT = <<'EOT'; # While this is "" string written inside "" here doc 1446#$VAR1 = "\$b\"\@\\\x{b6}"; 1447EOT 1448 TEST q(Data::Dumper->Dumpxs([$a])), "XS utf8 flag with \" and \$"; 1449 } 1450 # XS used to produce "$b\"' which is 4 chars, not 3. [ie wrongly qq(\$b\\\")] 1451############# 1452 $WANT = <<'EOT'; 1453#$VAR1 = '$b"'; 1454EOT 1455 1456 $a = "\$b\"\x{100}"; 1457 chop $a; 1458 TEST q(Data::Dumper->Dump([$a])), "utf8 flag with \" and \$"; 1459 if ($XS) { 1460 TEST q(Data::Dumper->Dumpxs([$a])), "XS utf8 flag with \" and \$"; 1461 } 1462 1463 1464 # XS used to produce 'D'oh!' which is well, D'oh! 1465 # Andreas found this one, which in turn discovered the previous two. 1466############# 1467 $WANT = <<'EOT'; 1468#$VAR1 = 'D\'oh!'; 1469EOT 1470 1471 $a = "D'oh!\x{100}"; 1472 chop $a; 1473 TEST q(Data::Dumper->Dump([$a])), "utf8 flag with '"; 1474 if ($XS) { 1475 TEST q(Data::Dumper->Dumpxs([$a])), "XS utf8 flag with '"; 1476 } 1477} 1478 1479# Jarkko found that -Mutf8 caused some tests to fail. Turns out that there 1480# was an otherwise untested code path in the XS for utf8 hash keys with purity 1481# 1 1482 1483{ 1484 $WANT = <<'EOT'; 1485#$ping = \*::ping; 1486#*::ping = \5; 1487#*::ping = { 1488# "\x{decaf}\x{decaf}\x{decaf}\x{decaf}" => do{my $o} 1489#}; 1490#*::ping{HASH}->{"\x{decaf}\x{decaf}\x{decaf}\x{decaf}"} = *::ping{SCALAR}; 1491#%pong = %{*::ping{HASH}}; 1492EOT 1493 local $Data::Dumper::Purity = 1; 1494 local $Data::Dumper::Sortkeys; 1495 $ping = 5; 1496 %ping = (chr (0xDECAF) x 4 =>\$ping); 1497 for $Data::Dumper::Sortkeys (0, 1) { 1498 if($] >= 5.007) { 1499 TEST (q(Data::Dumper->Dump([\\*ping, \\%ping], ['*ping', '*pong'])), 1500 "utf8: Purity 1: Sortkeys: Dump()"); 1501 TEST (q(Data::Dumper->Dumpxs([\\*ping, \\%ping], ['*ping', '*pong'])), 1502 "utf8: Purity 1: Sortkeys: Dumpxs()") 1503 if $XS; 1504 } else { 1505 SKIP_TEST "Incomplete support for UTF-8 in old perls"; 1506 SKIP_TEST "Incomplete support for UTF-8 in old perls"; 1507 } 1508 } 1509} 1510 1511# XS for quotekeys==0 was not being defensive enough against utf8 flagged 1512# scalars 1513 1514{ 1515 $WANT = <<'EOT'; 1516#$VAR1 = { 1517# perl => 'rocks' 1518#}; 1519EOT 1520 local $Data::Dumper::Quotekeys = 0; 1521 my $k = 'perl' . chr 256; 1522 chop $k; 1523 %foo = ($k => 'rocks'); 1524 1525 TEST q(Data::Dumper->Dump([\\%foo])), "quotekeys == 0 for utf8 flagged ASCII"; 1526 TEST q(Data::Dumper->Dumpxs([\\%foo])), 1527 "XS quotekeys == 0 for utf8 flagged ASCII" if $XS; 1528} 1529############# 1530{ 1531 $WANT = <<'EOT'; 1532#$VAR1 = [ 1533# undef, 1534# undef, 1535# 1 1536#]; 1537EOT 1538 @foo = (); 1539 $foo[2] = 1; 1540 TEST q(Data::Dumper->Dump([\@foo])), 'Richard Clamp, Message-Id: <20030104005247.GA27685@mirth.demon.co.uk>: Dump()'; 1541 TEST q(Data::Dumper->Dumpxs([\@foo])), 'Richard Clamp, Message-Id: <20030104005247.GA27685@mirth.demon.co.uk>: Dumpxs()'if $XS; 1542} 1543 1544############# 1545# Make sure $obj->Dumpxs returns the right thing in list context. This was 1546# broken by the initial attempt to fix [perl #74170]. 1547$WANT = <<'EOT'; 1548#$VAR1 = []; 1549EOT 1550TEST q(join " ", new Data::Dumper [[]],[] =>->Dumpxs), 1551 '$obj->Dumpxs in list context' 1552 if $XS; 1553 1554############# 1555{ 1556 $WANT = '\0\1\2\3\4\5\6\a\b\t\n\13\f\r\16\17\20\21\22\23\24\25\26\27\30\31\32\e\34\35\36\37 !\"#\$%&\'()*+,-./0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\177\200\201\202\203\204\205\206\207\210\211\212\213\214\215\216\217\220\221\222\223\224\225\226\227\230\231\232\233\234\235\236\237\240\241\242\243\244\245\246\247\250\251\252\253\254\255\256\257\260\261\262\263\264\265\266\267\270\271\272\273\274\275\276\277\300\301\302\303\304\305\306\307\310\311\312\313\314\315\316\317\320\321\322\323\324\325\326\327\330\331\332\333\334\335\336\337\340\341\342\343\344\345\346\347\350\351\352\353\354\355\356\357\360\361\362\363\364\365\366\367\370\371\372\373\374\375\376\377'; 1557 $WANT = convert_to_native($WANT); 1558 $WANT = <<EOT; 1559#\$VAR1 = [ 1560# "$WANT" 1561#]; 1562EOT 1563 1564 $foo = [ join "", map chr, 0..255 ]; 1565 local $Data::Dumper::Useqq = 1; 1566 TEST (q(Dumper($foo)), 'All latin1 characters: Dumper'); 1567 TEST (q(Data::Dumper::DumperX($foo)), 'All latin1 characters: DumperX') if $XS; 1568} 1569 1570############# 1571{ 1572 $WANT = '\0\1\2\3\4\5\6\a\b\t\n\13\f\r\16\17\20\21\22\23\24\25\26\27\30\31\32\e\34\35\36\37 !\"#\$%&\'()*+,-./0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\177\x{80}\x{81}\x{82}\x{83}\x{84}\x{85}\x{86}\x{87}\x{88}\x{89}\x{8a}\x{8b}\x{8c}\x{8d}\x{8e}\x{8f}\x{90}\x{91}\x{92}\x{93}\x{94}\x{95}\x{96}\x{97}\x{98}\x{99}\x{9a}\x{9b}\x{9c}\x{9d}\x{9e}\x{9f}\x{a0}\x{a1}\x{a2}\x{a3}\x{a4}\x{a5}\x{a6}\x{a7}\x{a8}\x{a9}\x{aa}\x{ab}\x{ac}\x{ad}\x{ae}\x{af}\x{b0}\x{b1}\x{b2}\x{b3}\x{b4}\x{b5}\x{b6}\x{b7}\x{b8}\x{b9}\x{ba}\x{bb}\x{bc}\x{bd}\x{be}\x{bf}\x{c0}\x{c1}\x{c2}\x{c3}\x{c4}\x{c5}\x{c6}\x{c7}\x{c8}\x{c9}\x{ca}\x{cb}\x{cc}\x{cd}\x{ce}\x{cf}\x{d0}\x{d1}\x{d2}\x{d3}\x{d4}\x{d5}\x{d6}\x{d7}\x{d8}\x{d9}\x{da}\x{db}\x{dc}\x{dd}\x{de}\x{df}\x{e0}\x{e1}\x{e2}\x{e3}\x{e4}\x{e5}\x{e6}\x{e7}\x{e8}\x{e9}\x{ea}\x{eb}\x{ec}\x{ed}\x{ee}\x{ef}\x{f0}\x{f1}\x{f2}\x{f3}\x{f4}\x{f5}\x{f6}\x{f7}\x{f8}\x{f9}\x{fa}\x{fb}\x{fc}\x{fd}\x{fe}\x{ff}\x{20ac}'; 1573 $WANT = convert_to_native($WANT); 1574 $WANT = <<EOT; 1575#\$VAR1 = [ 1576# "$WANT" 1577#]; 1578EOT 1579 1580 $foo = [ join "", map chr, 0..255, 0x20ac ]; 1581 local $Data::Dumper::Useqq = 1; 1582 if ($] < 5.007) { 1583 print "not ok " . (++$TNUM) . " # TODO - fails under 5.6\n" for 1..3; 1584 } 1585 else { 1586 TEST q(Dumper($foo)), 1587 'All latin1 characters with utf8 flag including a wide character: Dumper'; 1588 } 1589 TEST (q(Data::Dumper::DumperX($foo)), 1590 'All latin1 characters with utf8 flag including a wide character: DumperX') 1591 if $XS; 1592} 1593 1594############# 1595{ 1596 # If XS cannot load, the pure-Perl version cannot deparse vstrings with 1597 # underscores properly. In 5.8.0, vstrings are just strings. 1598 my $no_vstrings = <<'NOVSTRINGS'; 1599#$a = \'ABC'; 1600#$b = \'ABC'; 1601#$c = \'ABC'; 1602#$d = \'ABC'; 1603NOVSTRINGS 1604my $ABC_native = chr(65) . chr(66) . chr(67); 1605 my $vstrings_corr = <<VSTRINGS_CORRECT; 1606#\$a = \\v65.66.67; 1607#\$b = \\v65.66.067; 1608#\$c = \\v65.66.6_7; 1609#\$d = \\'$ABC_native'; 1610VSTRINGS_CORRECT 1611 $WANT = $] <= 5.0080001 1612 ? $no_vstrings 1613 : $vstrings_corr; 1614 1615 @::_v = ( 1616 \v65.66.67, 1617 \($] < 5.007 ? v65.66.67 : eval 'v65.66.067'), 1618 \v65.66.6_7, 1619 \~v190.189.188 1620 ); 1621 if ($] >= 5.010) { 1622 TEST q(Data::Dumper->Dump(\@::_v, [qw(a b c d)])), 'vstrings'; 1623 TEST q(Data::Dumper->Dumpxs(\@::_v, [qw(a b c d)])), 'xs vstrings' 1624 if $XS; 1625 } 1626 else { # Skip tests before 5.10. vstrings considered funny before 1627 SKIP_TEST "vstrings considered funny before 5.10.0"; 1628 SKIP_TEST "vstrings considered funny before 5.10.0 (XS)" 1629 if $XS; 1630 } 1631} 1632 1633############# 1634{ 1635 # [perl #107372] blessed overloaded globs 1636 $WANT = <<'EOW'; 1637#$VAR1 = bless( \*::finkle, 'overtest' ); 1638EOW 1639 { 1640 package overtest; 1641 use overload fallback=>1, q\""\=>sub{"oaoaa"}; 1642 } 1643 TEST q(Data::Dumper->Dump([bless \*finkle, "overtest"])), 1644 'blessed overloaded globs'; 1645 TEST q(Data::Dumper->Dumpxs([\*finkle])), 'blessed overloaded globs (xs)' 1646 if $XS; 1647} 1648############# 1649{ 1650 # [perl #74798] uncovered behaviour 1651 $WANT = <<'EOW'; 1652#$VAR1 = "\0000"; 1653EOW 1654 local $Data::Dumper::Useqq = 1; 1655 TEST q(Data::Dumper->Dump(["\x000"])), 1656 "\\ octal followed by digit"; 1657 TEST q(Data::Dumper->Dumpxs(["\x000"])), '\\ octal followed by digit (xs)' 1658 if $XS; 1659 1660 $WANT = <<'EOW'; 1661#$VAR1 = "\x{100}\0000"; 1662EOW 1663 local $Data::Dumper::Useqq = 1; 1664 TEST q(Data::Dumper->Dump(["\x{100}\x000"])), 1665 "\\ octal followed by digit unicode"; 1666 TEST q(Data::Dumper->Dumpxs(["\x{100}\x000"])), '\\ octal followed by digit unicode (xs)' 1667 if $XS; 1668 1669 1670 $WANT = <<'EOW'; 1671#$VAR1 = "\0\x{660}"; 1672EOW 1673 TEST q(Data::Dumper->Dump(["\\x00\\x{0660}"])), 1674 "\\ octal followed by unicode digit"; 1675 TEST q(Data::Dumper->Dumpxs(["\\x00\\x{0660}"])), '\\ octal followed by unicode digit (xs)' 1676 if $XS; 1677 1678 # [perl #118933 - handling of digits 1679$WANT = <<'EOW'; 1680#$VAR1 = 0; 1681#$VAR2 = 1; 1682#$VAR3 = 90; 1683#$VAR4 = -10; 1684#$VAR5 = "010"; 1685#$VAR6 = 112345678; 1686#$VAR7 = "1234567890"; 1687EOW 1688 TEST q(Data::Dumper->Dump([0, 1, 90, -10, "010", "112345678", "1234567890" ])), 1689 "numbers and number-like scalars"; 1690 1691 TEST q(Data::Dumper->Dumpxs([0, 1, 90, -10, "010", "112345678", "1234567890" ])), 1692 "numbers and number-like scalars" 1693 if $XS; 1694} 1695############# 1696{ 1697 # [perl #82948] 1698 # re::regexp_pattern was moved to universal.c in v5.10.0-252-g192c1e2 1699 # and apparently backported to maint-5.10 1700 $WANT = $] > 5.010 ? <<'NEW' : <<'OLD'; 1701#$VAR1 = qr/abc/; 1702#$VAR2 = qr/abc/i; 1703NEW 1704#$VAR1 = qr/(?-xism:abc)/; 1705#$VAR2 = qr/(?i-xsm:abc)/; 1706OLD 1707 TEST q(Data::Dumper->Dump([ qr/abc/, qr/abc/i ])), "qr//"; 1708 TEST q(Data::Dumper->Dumpxs([ qr/abc/, qr/abc/i ])), "qr// xs" 1709 if $XS; 1710} 1711############# 1712 1713{ 1714 sub foo {} 1715 $WANT = <<'EOW'; 1716#*a = sub { "DUMMY" }; 1717#$b = \&a; 1718EOW 1719 1720 TEST q(Data::Dumper->new([ \&foo, \\&foo ], [ "*a", "b" ])->Dump), "name of code in *foo"; 1721 TEST q(Data::Dumper->new([ \&foo, \\&foo ], [ "*a", "b" ])->Dumpxs), "name of code in *foo xs" 1722 if $XS; 1723} 1724############# 1725 1726{ 1727 if($] lt 5.007_003) { 1728 SKIP_TEST "Test is only problematic for EBCDIC, which only works for >= 5.8"; 1729 SKIP_TEST "Test is only problematic for EBCDIC, which only works for >= 5.8"; 1730 } 1731 else { 1732 # There is special code to handle the single control that in EBCDIC is 1733 # not in the block with all the other controls, when it is UTF-8 and 1734 # there are no variants in it (All controls in EBCDIC are invariant.) 1735 # This tests that. There is no harm in testing this works on ASCII, 1736 # and is better to not have split code paths. 1737 my $outlier = chr utf8::unicode_to_native(0x9F); 1738 my $outlier_hex = sprintf "%x", ord $outlier; 1739 $WANT = <<EOT; 1740#\$VAR1 = \"\\x{$outlier_hex}\"; 1741EOT 1742 $foo = "$outlier\x{100}"; 1743 chop $foo; 1744 local $Data::Dumper::Useqq = 1; 1745 TEST (q(Dumper($foo)), 'EBCDIC outlier control'); 1746 TEST (q(Data::Dumper::DumperX($foo)), 'EBCDIC outlier control: DumperX') if $XS; 1747 } 1748} 1749############# [perl #124091] 1750{ 1751 $WANT = <<'EOT'; 1752#$VAR1 = "\n"; 1753EOT 1754 local $Data::Dumper::Useqq = 1; 1755 TEST (qq(Dumper("\n")), '\n alone'); 1756 TEST (qq(Data::Dumper::DumperX("\n")), '\n alone') if $XS; 1757} 1758############# 1759our @globs = map { $_, \$_ } map { *$_ } map { $_, "s::$_" } 1760 "foo", "\1bar", "L\x{e9}on", "m\x{100}cron", "snow\x{2603}"; 1761$WANT = change_glob_expectation(<<'EOT'); 1762#$globs = [ 1763# *::foo, 1764# \*::foo, 1765# *s::foo, 1766# \*s::foo, 1767# *{"::\1bar"}, 1768# \*{"::\1bar"}, 1769# *{"s::\1bar"}, 1770# \*{"s::\1bar"}, 1771# *{"::L\351on"}, 1772# \*{"::L\351on"}, 1773# *{"s::L\351on"}, 1774# \*{"s::L\351on"}, 1775# *{"::m\x{100}cron"}, 1776# \*{"::m\x{100}cron"}, 1777# *{"s::m\x{100}cron"}, 1778# \*{"s::m\x{100}cron"}, 1779# *{"::snow\x{2603}"}, 1780# \*{"::snow\x{2603}"}, 1781# *{"s::snow\x{2603}"}, 1782# \*{"s::snow\x{2603}"} 1783#]; 1784EOT 1785{ 1786 local $Data::Dumper::Useqq = 1; 1787 if (ord("A") == 65) { 1788 TEST (q(Data::Dumper->Dump([\@globs], ["globs"])), 'globs: Dump()'); 1789 TEST (q(Data::Dumper->Dumpxs([\@globs], ["globs"])), 'globs: Dumpxs()') 1790 if $XS; 1791 } 1792 else { 1793 SKIP_TEST "ASCII-dependent test"; 1794 SKIP_TEST "ASCII-dependent test"; 1795 } 1796} 1797############# 1798$WANT = change_glob_expectation(<<'EOT'); 1799#$v = { 1800# a => \*::ppp, 1801# b => \*{'::a/b'}, 1802# c => \*{"::a\x{2603}b"} 1803#}; 1804#*::ppp = { 1805# a => 1 1806#}; 1807#*{'::a/b'} = { 1808# b => 3 1809#}; 1810#*{"::a\x{2603}b"} = { 1811# c => 5 1812#}; 1813EOT 1814{ 1815 *ppp = { a => 1 }; 1816 *{"a/b"} = { b => 3 }; 1817 *{"a\x{2603}b"} = { c => 5 }; 1818 our $v = { a => \*ppp, b => \*{"a/b"}, c => \*{"a\x{2603}b"} }; 1819 local $Data::Dumper::Purity = 1; 1820 TEST (q(Data::Dumper->Dump([$v], ["v"])), 'glob purity: Dump()'); 1821 TEST (q(Data::Dumper->Dumpxs([$v], ["v"])), 'glob purity: Dumpxs()') if $XS; 1822 $WANT =~ tr/'/"/; 1823 local $Data::Dumper::Useqq = 1; 1824 TEST (q(Data::Dumper->Dump([$v], ["v"])), 'glob purity, useqq: Dump()'); 1825 TEST (q(Data::Dumper->Dumpxs([$v], ["v"])), 'glob purity, useqq: Dumpxs()') if $XS; 1826} 1827