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