dist/Data-Dumper/t/dumper.t

   1 #!./perl -w
   2 #
   3 # testsuite for Data::Dumper
   4 #
   5
   6 use strict;
   7 use warnings;
   8
   9 use Data::Dumper;
  10 use Config;
  11 use 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
  17 my $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;
  23 if (defined &Data::Dumper::Dumpxs) {
  24     print "### XS extension loaded, will run XS tests\n";
  25     $XS = 1;
  26 }
  27 else {
  28     print "### XS extensions not loaded, will NOT run XS tests\n";
  29     $XS = 0;
  30 }
  31
  32 our ( @a, $c, $d, $foo, @foo, %foo, @globs, $v, $ping, %ping );
  33 our ( @dogs, %kennel, $mutts );
  34
  35 our ( @numbers, @strings );
  36 our ( @numbers_s, @numbers_i, @numbers_is, @numbers_n, @numbers_ns, @numbers_ni, @numbers_nis );
  37 our ( @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.
  42 sub 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
  54 sub 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
 105 sub 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
 152 sub 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.
 163 sub 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
 193 my @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 ##
 203 my $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'};
 217 EOT
 218
 219 TEST_BOTH(q(Data::Dumper->Dumpxs([$a,$b,$c], [qw(a b), 6])),
 220           'basic test with names: Dumpxs()',
 221           $want);
 222
 223 SCOPE: {
 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];
 248 EOT
 249
 250 $Data::Dumper::Purity = 1;         # fill in the holes for eval
 251 TEST_BOTH(q(Data::Dumper->Dumpxs([$a, $b], [qw(*a b)])),
 252           'Purity: basic test with dereferenced array: Dumpxs()',
 253           $want);
 254
 255 SCOPE: {
 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'};
 280 EOT
 281
 282 TEST_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];
 303 EOT
 304
 305 $Data::Dumper::Indent = 1;
 306 TEST_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];
 332 EOT
 333
 334 $d->Indent(3);
 335 $d->Purity(0)->Quotekeys(0);
 336 TEST_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'};
 357 EOT
 358
 359 TEST_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 #]
 377 EOT
 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 #};
 395 EOT
 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]};
 444 EOT
 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];
 474 EOT
 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];
 503 EOT
 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];
 531 EOT
 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]};
 552 EOT
 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];
 575 EOT
 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;
 609 EOT
 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;
 624 EOT
 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;
 643 EOT
 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]};
 662 EOT
 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 #);
 692 EOT
 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
 703 sub z { print "foo\n" }
 704 $c = [ \&z ];
 705
 706 #############
 707 ##
 708   my $want = <<'EOT';
 709 #$a = $b;
 710 #$c = [
 711 #  $b
 712 #];
 713 EOT
 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 #];
 726 EOT
 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 #);
 739 EOT
 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];
 758 EOT
 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}};
 774 EOT
 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}};
 806 EOT
 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]}};
 832 EOT
 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};
 861 EOT
 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 #];
 877 EOT
 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 #];
 894 EOT
 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];
 907 EOT
 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}";
 920 EOT
 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 #};
 945 EOT
 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 #};
 975 EOT
 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 #];
1022 EOT
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 #        };
1045 EOT
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';
1109 EOT
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';
1131 EOT
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';
1157 EOT
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';
1180 EOT
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';
1205 EOT
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';
1297 my $VAR1 = '42
1298 ';
1299 EOT
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';
1338 EOT
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';
1354 EOT32
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';
1367 EOT64
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';
1382 EOT
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}";
1388 EOT
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"';
1397 EOT
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!';
1411 EOT
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}};
1433 EOT
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 #};
1453 EOT
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 #];
1471 EOT
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 = [];
1485 EOT
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 #];
1499 EOT
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 #];
1516 EOT
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 #];
1536 EOT
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';
1592 VSTRINGS_CORRECT
1593 #\$a = \\v65.66.67;
1594 #\$b = \\v65.66.67;
1595 #\$c = \\v65.66.67;
1596 #\$d = \\'$ABC_native';
1597 NO_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' );
1620 EOW
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";
1634 EOW
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";
1642 EOW
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}";
1650 EOW
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";
1664 EOW
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 #];
1685 EOW
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 #];
1715 EOW
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 #];
1740 EOW
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 #];
1774 EOW
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";
1787 Data::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 ] ]);
1801 EOT
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;
1812 NEW
1813 #$VAR1 = qr/(?-xism:abc)/;
1814 #$VAR2 = qr/(?i-xsm:abc)/;
1815 OLD
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;
1825 EOW
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";
1835 EOT
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 #];
1872 EOT
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 #};
1899 EOT
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 = [];
1922 EOT
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
1939 done_testing();