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