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