dist/Data-Dumper/t/dumper.t

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