This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
0824871a996b5363bcd824b01b4a0f13eb5e6fee
[perl5.git] / 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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############
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 #############