This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
e1de62dd8aafa3a97099a5667d2277a44d652c66
[perl5.git] / ext / Data / Dumper / t / dumper.t
1 #!./perl -w
2 #
3 # testsuite for Data::Dumper
4 #
5
6 BEGIN {
7     chdir 't' if -d 't';
8     @INC = '../lib';
9     require Config; import Config;
10     if ($Config{'extensions'} !~ /\bData\/Dumper\b/) {
11       print "1..0 # Skip: Data::Dumper was not built\n";
12       exit 0;
13     }
14 }
15
16 use Data::Dumper;
17 use Config;
18 my $Is_ebcdic = defined($Config{'ebcdic'}) && $Config{'ebcdic'} eq 'define';
19
20 $Data::Dumper::Pad = "#";
21 my $TMAX;
22 my $XS;
23 my $TNUM = 0;
24 my $WANT = '';
25
26 sub TEST {
27   my $string = shift;
28   my $name = shift;
29   my $t = eval $string;
30   ++$TNUM;
31   $t =~ s/([A-Z]+)\(0x[0-9a-f]+\)/$1(0xdeadbeef)/g
32       if ($WANT =~ /deadbeef/);
33   if ($Is_ebcdic) {
34       # these data need massaging with non ascii character sets
35       # because of hashing order differences
36       $WANT = join("\n",sort(split(/\n/,$WANT)));
37       $WANT =~ s/\,$//mg;
38       $t    = join("\n",sort(split(/\n/,$t)));
39       $t    =~ s/\,$//mg;
40   }
41   $name = $name ? " - $name" : '';
42   print( ($t eq $WANT and not $@) ? "ok $TNUM$name\n"
43         : "not ok $TNUM$name\n--Expected--\n$WANT\n--Got--\n$@$t\n");
44
45   ++$TNUM;
46   eval "$t";
47   print $@ ? "not ok $TNUM\n# \$@ says: $@\n" : "ok $TNUM\n";
48
49   $t = eval $string;
50   ++$TNUM;
51   $t =~ s/([A-Z]+)\(0x[0-9a-f]+\)/$1(0xdeadbeef)/g
52       if ($WANT =~ /deadbeef/);
53   if ($Is_ebcdic) {
54       # here too there are hashing order differences
55       $WANT = join("\n",sort(split(/\n/,$WANT)));
56       $WANT =~ s/\,$//mg;
57       $t    = join("\n",sort(split(/\n/,$t)));
58       $t    =~ s/\,$//mg;
59   }
60   print( ($t eq $WANT and not $@) ? "ok $TNUM\n"
61         : "not ok $TNUM\n--Expected--\n$WANT\n--Got--\n$@$t\n");
62 }
63
64 # Force Data::Dumper::Dump to use perl. We test Dumpxs explicitly by calling
65 # it direct. Out here it lets us knobble the next if to test that the perl
66 # only tests do work (and count correctly)
67 $Data::Dumper::Useperl = 1;
68 if (defined &Data::Dumper::Dumpxs) {
69   print "### XS extension loaded, will run XS tests\n";
70   $TMAX = 363; $XS = 1;
71 }
72 else {
73   print "### XS extensions not loaded, will NOT run XS tests\n";
74   $TMAX = 183; $XS = 0;
75 }
76
77 print "1..$TMAX\n";
78
79 #XXXif (0) {
80 #############
81 #############
82
83 @c = ('c');
84 $c = \@c;
85 $b = {};
86 $a = [1, $b, $c];
87 $b->{a} = $a;
88 $b->{b} = $a->[1];
89 $b->{c} = $a->[2];
90
91 ############# 1
92 ##
93 $WANT = <<'EOT';
94 #$a = [
95 #       1,
96 #       {
97 #         'c' => [
98 #                  'c'
99 #                ],
100 #         'a' => $a,
101 #         'b' => $a->[1]
102 #       },
103 #       $a->[1]{'c'}
104 #     ];
105 #$b = $a->[1];
106 #$c = $a->[1]{'c'};
107 EOT
108
109 TEST q(Data::Dumper->Dump([$a,$b,$c], [qw(a b c)]));
110 TEST q(Data::Dumper->Dumpxs([$a,$b,$c], [qw(a b c)])) if $XS;
111
112
113 ############# 7
114 ##
115 $WANT = <<'EOT';
116 #@a = (
117 #       1,
118 #       {
119 #         'c' => [
120 #                  'c'
121 #                ],
122 #         'a' => [],
123 #         'b' => {}
124 #       },
125 #       []
126 #     );
127 #$a[1]{'a'} = \@a;
128 #$a[1]{'b'} = $a[1];
129 #$a[2] = $a[1]{'c'};
130 #$b = $a[1];
131 EOT
132
133 $Data::Dumper::Purity = 1;         # fill in the holes for eval
134 TEST q(Data::Dumper->Dump([$a, $b], [qw(*a b)])); # print as @a
135 TEST q(Data::Dumper->Dumpxs([$a, $b], [qw(*a b)])) if $XS;
136
137 ############# 13
138 ##
139 $WANT = <<'EOT';
140 #%b = (
141 #       'c' => [
142 #                'c'
143 #              ],
144 #       'a' => [
145 #                1,
146 #                {},
147 #                []
148 #              ],
149 #       'b' => {}
150 #     );
151 #$b{'a'}[1] = \%b;
152 #$b{'a'}[2] = $b{'c'};
153 #$b{'b'} = \%b;
154 #$a = $b{'a'};
155 EOT
156
157 TEST q(Data::Dumper->Dump([$b, $a], [qw(*b a)])); # print as %b
158 TEST q(Data::Dumper->Dumpxs([$b, $a], [qw(*b a)])) if $XS;
159
160 ############# 19
161 ##
162 $WANT = <<'EOT';
163 #$a = [
164 #  1,
165 #  {
166 #    'c' => [],
167 #    'a' => [],
168 #    'b' => {}
169 #  },
170 #  []
171 #];
172 #$a->[1]{'c'} = \@c;
173 #$a->[1]{'a'} = $a;
174 #$a->[1]{'b'} = $a->[1];
175 #$a->[2] = \@c;
176 #$b = $a->[1];
177 EOT
178
179 $Data::Dumper::Indent = 1;
180 TEST q(
181        $d = Data::Dumper->new([$a,$b], [qw(a b)]);
182        $d->Seen({'*c' => $c});
183        $d->Dump;
184       );
185 if ($XS) {
186   TEST q(
187          $d = Data::Dumper->new([$a,$b], [qw(a b)]);
188          $d->Seen({'*c' => $c});
189          $d->Dumpxs;
190         );
191 }
192
193
194 ############# 25
195 ##
196 $WANT = <<'EOT';
197 #$a = [
198 #       #0
199 #       1,
200 #       #1
201 #       {
202 #         c => [
203 #                #0
204 #                'c'
205 #              ],
206 #         a => $a,
207 #         b => $a->[1]
208 #       },
209 #       #2
210 #       $a->[1]{c}
211 #     ];
212 #$b = $a->[1];
213 EOT
214
215 $d->Indent(3);
216 $d->Purity(0)->Quotekeys(0);
217 TEST q( $d->Reset; $d->Dump );
218
219 TEST q( $d->Reset; $d->Dumpxs ) if $XS;
220
221 ############# 31
222 ##
223 $WANT = <<'EOT';
224 #$VAR1 = [
225 #  1,
226 #  {
227 #    'c' => [
228 #      'c'
229 #    ],
230 #    'a' => [],
231 #    'b' => {}
232 #  },
233 #  []
234 #];
235 #$VAR1->[1]{'a'} = $VAR1;
236 #$VAR1->[1]{'b'} = $VAR1->[1];
237 #$VAR1->[2] = $VAR1->[1]{'c'};
238 EOT
239
240 TEST q(Dumper($a));
241 TEST q(Data::Dumper::DumperX($a)) if $XS;
242
243 ############# 37
244 ##
245 $WANT = <<'EOT';
246 #[
247 #  1,
248 #  {
249 #    c => [
250 #      'c'
251 #    ],
252 #    a => $VAR1,
253 #    b => $VAR1->[1]
254 #  },
255 #  $VAR1->[1]{c}
256 #]
257 EOT
258
259 {
260   local $Data::Dumper::Purity = 0;
261   local $Data::Dumper::Quotekeys = 0;
262   local $Data::Dumper::Terse = 1;
263   TEST q(Dumper($a));
264   TEST q(Data::Dumper::DumperX($a)) if $XS;
265 }
266
267
268 ############# 43
269 ##
270 $WANT = <<'EOT';
271 #$VAR1 = {
272 #  "reftest" => \\1,
273 #  "abc\0'\efg" => "mno\0"
274 #};
275 EOT
276
277 $foo = { "abc\000\'\efg" => "mno\000",
278          "reftest" => \\1,
279        };
280 {
281   local $Data::Dumper::Useqq = 1;
282   TEST q(Dumper($foo));
283 }
284
285   $WANT = <<"EOT";
286 #\$VAR1 = {
287 #  'reftest' => \\\\1,
288 #  'abc\0\\'\efg' => 'mno\0'
289 #};
290 EOT
291
292   {
293     local $Data::Dumper::Useqq = 1;
294     TEST q(Data::Dumper::DumperX($foo)) if $XS;   # cheat
295   }
296
297
298
299 #############
300 #############
301
302 {
303   package main;
304   use Data::Dumper;
305   $foo = 5;
306   @foo = (-10,\*foo);
307   %foo = (a=>1,b=>\$foo,c=>\@foo);
308   $foo{d} = \%foo;
309   $foo[2] = \%foo;
310
311 ############# 49
312 ##
313   $WANT = <<'EOT';
314 #$foo = \*::foo;
315 #*::foo = \5;
316 #*::foo = [
317 #           #0
318 #           -10,
319 #           #1
320 #           do{my $o},
321 #           #2
322 #           {
323 #             'c' => [],
324 #             'a' => 1,
325 #             'b' => do{my $o},
326 #             'd' => {}
327 #           }
328 #         ];
329 #*::foo{ARRAY}->[1] = $foo;
330 #*::foo{ARRAY}->[2]{'c'} = *::foo{ARRAY};
331 #*::foo{ARRAY}->[2]{'b'} = *::foo{SCALAR};
332 #*::foo{ARRAY}->[2]{'d'} = *::foo{ARRAY}->[2];
333 #*::foo = *::foo{ARRAY}->[2];
334 #@bar = @{*::foo{ARRAY}};
335 #%baz = %{*::foo{ARRAY}->[2]};
336 EOT
337
338   $Data::Dumper::Purity = 1;
339   $Data::Dumper::Indent = 3;
340   TEST q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz']));
341   TEST q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])) if $XS;
342
343 ############# 55
344 ##
345   $WANT = <<'EOT';
346 #$foo = \*::foo;
347 #*::foo = \5;
348 #*::foo = [
349 #  -10,
350 #  do{my $o},
351 #  {
352 #    'c' => [],
353 #    'a' => 1,
354 #    'b' => do{my $o},
355 #    'd' => {}
356 #  }
357 #];
358 #*::foo{ARRAY}->[1] = $foo;
359 #*::foo{ARRAY}->[2]{'c'} = *::foo{ARRAY};
360 #*::foo{ARRAY}->[2]{'b'} = *::foo{SCALAR};
361 #*::foo{ARRAY}->[2]{'d'} = *::foo{ARRAY}->[2];
362 #*::foo = *::foo{ARRAY}->[2];
363 #$bar = *::foo{ARRAY};
364 #$baz = *::foo{ARRAY}->[2];
365 EOT
366
367   $Data::Dumper::Indent = 1;
368   TEST q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz']));
369   TEST q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])) if $XS;
370
371 ############# 61
372 ##
373   $WANT = <<'EOT';
374 #@bar = (
375 #  -10,
376 #  \*::foo,
377 #  {}
378 #);
379 #*::foo = \5;
380 #*::foo = \@bar;
381 #*::foo = {
382 #  'c' => [],
383 #  'a' => 1,
384 #  'b' => do{my $o},
385 #  'd' => {}
386 #};
387 #*::foo{HASH}->{'c'} = \@bar;
388 #*::foo{HASH}->{'b'} = *::foo{SCALAR};
389 #*::foo{HASH}->{'d'} = *::foo{HASH};
390 #$bar[2] = *::foo{HASH};
391 #%baz = %{*::foo{HASH}};
392 #$foo = $bar[1];
393 EOT
394
395   TEST q(Data::Dumper->Dump([\\@foo, \\%foo, \\*foo], ['*bar', '*baz', '*foo']));
396   TEST q(Data::Dumper->Dumpxs([\\@foo, \\%foo, \\*foo], ['*bar', '*baz', '*foo'])) if $XS;
397
398 ############# 67
399 ##
400   $WANT = <<'EOT';
401 #$bar = [
402 #  -10,
403 #  \*::foo,
404 #  {}
405 #];
406 #*::foo = \5;
407 #*::foo = $bar;
408 #*::foo = {
409 #  'c' => [],
410 #  'a' => 1,
411 #  'b' => do{my $o},
412 #  'd' => {}
413 #};
414 #*::foo{HASH}->{'c'} = $bar;
415 #*::foo{HASH}->{'b'} = *::foo{SCALAR};
416 #*::foo{HASH}->{'d'} = *::foo{HASH};
417 #$bar->[2] = *::foo{HASH};
418 #$baz = *::foo{HASH};
419 #$foo = $bar->[1];
420 EOT
421
422   TEST q(Data::Dumper->Dump([\\@foo, \\%foo, \\*foo], ['bar', 'baz', 'foo']));
423   TEST q(Data::Dumper->Dumpxs([\\@foo, \\%foo, \\*foo], ['bar', 'baz', 'foo'])) if $XS;
424
425 ############# 73
426 ##
427   $WANT = <<'EOT';
428 #$foo = \*::foo;
429 #@bar = (
430 #  -10,
431 #  $foo,
432 #  {
433 #    c => \@bar,
434 #    a => 1,
435 #    b => \5,
436 #    d => $bar[2]
437 #  }
438 #);
439 #%baz = %{$bar[2]};
440 EOT
441
442   $Data::Dumper::Purity = 0;
443   $Data::Dumper::Quotekeys = 0;
444   TEST q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz']));
445   TEST q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])) if $XS;
446
447 ############# 79
448 ##
449   $WANT = <<'EOT';
450 #$foo = \*::foo;
451 #$bar = [
452 #  -10,
453 #  $foo,
454 #  {
455 #    c => $bar,
456 #    a => 1,
457 #    b => \5,
458 #    d => $bar->[2]
459 #  }
460 #];
461 #$baz = $bar->[2];
462 EOT
463
464   TEST q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz']));
465   TEST q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])) if $XS;
466
467 }
468
469 #############
470 #############
471 {
472   package main;
473   @dogs = ( 'Fido', 'Wags' );
474   %kennel = (
475             First => \$dogs[0],
476             Second =>  \$dogs[1],
477            );
478   $dogs[2] = \%kennel;
479   $mutts = \%kennel;
480   $mutts = $mutts;         # avoid warning
481   
482 ############# 85
483 ##
484   $WANT = <<'EOT';
485 #%kennels = (
486 #  Second => \'Wags',
487 #  First => \'Fido'
488 #);
489 #@dogs = (
490 #  ${$kennels{First}},
491 #  ${$kennels{Second}},
492 #  \%kennels
493 #);
494 #%mutts = %kennels;
495 EOT
496
497   TEST q(
498          $d = Data::Dumper->new([\\%kennel, \\@dogs, $mutts],
499                                 [qw(*kennels *dogs *mutts)] );
500          $d->Dump;
501         );
502   if ($XS) {
503     TEST q(
504            $d = Data::Dumper->new([\\%kennel, \\@dogs, $mutts],
505                                   [qw(*kennels *dogs *mutts)] );
506            $d->Dumpxs;
507           );
508   }
509   
510 ############# 91
511 ##
512   $WANT = <<'EOT';
513 #%kennels = %kennels;
514 #@dogs = @dogs;
515 #%mutts = %kennels;
516 EOT
517
518   TEST q($d->Dump);
519   TEST q($d->Dumpxs) if $XS;
520   
521 ############# 97
522 ##
523   $WANT = <<'EOT';
524 #%kennels = (
525 #  Second => \'Wags',
526 #  First => \'Fido'
527 #);
528 #@dogs = (
529 #  ${$kennels{First}},
530 #  ${$kennels{Second}},
531 #  \%kennels
532 #);
533 #%mutts = %kennels;
534 EOT
535
536   
537   TEST q($d->Reset; $d->Dump);
538   if ($XS) {
539     TEST q($d->Reset; $d->Dumpxs);
540   }
541
542 ############# 103
543 ##
544   $WANT = <<'EOT';
545 #@dogs = (
546 #  'Fido',
547 #  'Wags',
548 #  {
549 #    Second => \$dogs[1],
550 #    First => \$dogs[0]
551 #  }
552 #);
553 #%kennels = %{$dogs[2]};
554 #%mutts = %{$dogs[2]};
555 EOT
556
557   TEST q(
558          $d = Data::Dumper->new([\\@dogs, \\%kennel, $mutts],
559                                 [qw(*dogs *kennels *mutts)] );
560          $d->Dump;
561         );
562   if ($XS) {
563     TEST q(
564            $d = Data::Dumper->new([\\@dogs, \\%kennel, $mutts],
565                                   [qw(*dogs *kennels *mutts)] );
566            $d->Dumpxs;
567           );
568   }
569   
570 ############# 109
571 ##
572   TEST q($d->Reset->Dump);
573   if ($XS) {
574     TEST q($d->Reset->Dumpxs);
575   }
576
577 ############# 115
578 ##
579   $WANT = <<'EOT';
580 #@dogs = (
581 #  'Fido',
582 #  'Wags',
583 #  {
584 #    Second => \'Wags',
585 #    First => \'Fido'
586 #  }
587 #);
588 #%kennels = (
589 #  Second => \'Wags',
590 #  First => \'Fido'
591 #);
592 EOT
593
594   TEST q(
595          $d = Data::Dumper->new( [\@dogs, \%kennel], [qw(*dogs *kennels)] );
596          $d->Deepcopy(1)->Dump;
597         );
598   if ($XS) {
599     TEST q($d->Reset->Dumpxs);
600   }
601   
602 }
603
604 {
605
606 sub z { print "foo\n" }
607 $c = [ \&z ];
608
609 ############# 121
610 ##
611   $WANT = <<'EOT';
612 #$a = $b;
613 #$c = [
614 #  $b
615 #];
616 EOT
617
618 TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'b' => \&z})->Dump;);
619 TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'b' => \&z})->Dumpxs;)
620         if $XS;
621
622 ############# 127
623 ##
624   $WANT = <<'EOT';
625 #$a = \&b;
626 #$c = [
627 #  \&b
628 #];
629 EOT
630
631 TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'*b' => \&z})->Dump;);
632 TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'*b' => \&z})->Dumpxs;)
633         if $XS;
634
635 ############# 133
636 ##
637   $WANT = <<'EOT';
638 #*a = \&b;
639 #@c = (
640 #  \&b
641 #);
642 EOT
643
644 TEST q(Data::Dumper->new([\&z,$c],['*a','*c'])->Seen({'*b' => \&z})->Dump;);
645 TEST q(Data::Dumper->new([\&z,$c],['*a','*c'])->Seen({'*b' => \&z})->Dumpxs;)
646         if $XS;
647
648 }
649
650 {
651   $a = [];
652   $a->[1] = \$a->[0];
653
654 ############# 139
655 ##
656   $WANT = <<'EOT';
657 #@a = (
658 #  undef,
659 #  do{my $o}
660 #);
661 #$a[1] = \$a[0];
662 EOT
663
664 TEST q(Data::Dumper->new([$a],['*a'])->Purity(1)->Dump;);
665 TEST q(Data::Dumper->new([$a],['*a'])->Purity(1)->Dumpxs;)
666         if $XS;
667 }
668
669 {
670   $a = \\\\\'foo';
671   $b = $$$a;
672
673 ############# 145
674 ##
675   $WANT = <<'EOT';
676 #$a = \\\\\'foo';
677 #$b = ${${$a}};
678 EOT
679
680 TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dump;);
681 TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dumpxs;)
682         if $XS;
683 }
684
685 {
686   $a = [{ a => \$b }, { b => undef }];
687   $b = [{ c => \$b }, { d => \$a }];
688
689 ############# 151
690 ##
691   $WANT = <<'EOT';
692 #$a = [
693 #  {
694 #    a => \[
695 #        {
696 #          c => do{my $o}
697 #        },
698 #        {
699 #          d => \[]
700 #        }
701 #      ]
702 #  },
703 #  {
704 #    b => undef
705 #  }
706 #];
707 #${$a->[0]{a}}->[0]->{c} = $a->[0]{a};
708 #${${$a->[0]{a}}->[1]->{d}} = $a;
709 #$b = ${$a->[0]{a}};
710 EOT
711
712 TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dump;);
713 TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dumpxs;)
714         if $XS;
715 }
716
717 {
718   $a = [[[[\\\\\'foo']]]];
719   $b = $a->[0][0];
720   $c = $${$b->[0][0]};
721
722 ############# 157
723 ##
724   $WANT = <<'EOT';
725 #$a = [
726 #  [
727 #    [
728 #      [
729 #        \\\\\'foo'
730 #      ]
731 #    ]
732 #  ]
733 #];
734 #$b = $a->[0][0];
735 #$c = ${${$a->[0][0][0][0]}};
736 EOT
737
738 TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Purity(1)->Dump;);
739 TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Purity(1)->Dumpxs;)
740         if $XS;
741 }
742
743 {
744     $f = "pearl";
745     $e = [        $f ];
746     $d = { 'e' => $e };
747     $c = [        $d ];
748     $b = { 'c' => $c };
749     $a = { 'b' => $b };
750
751 ############# 163
752 ##
753   $WANT = <<'EOT';
754 #$a = {
755 #  b => {
756 #    c => [
757 #      {
758 #        e => 'ARRAY(0xdeadbeef)'
759 #      }
760 #    ]
761 #  }
762 #};
763 #$b = $a->{b};
764 #$c = $a->{b}{c};
765 EOT
766
767 TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(4)->Dump;);
768 TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(4)->Dumpxs;)
769         if $XS;
770
771 ############# 169
772 ##
773   $WANT = <<'EOT';
774 #$a = {
775 #  b => 'HASH(0xdeadbeef)'
776 #};
777 #$b = $a->{b};
778 #$c = [
779 #  'HASH(0xdeadbeef)'
780 #];
781 EOT
782
783 TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(1)->Dump;);
784 TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(1)->Dumpxs;)
785         if $XS;
786 }
787
788 {
789     $a = \$a;
790     $b = [$a];
791
792 ############# 175
793 ##
794   $WANT = <<'EOT';
795 #$b = [
796 #  \$b->[0]
797 #];
798 EOT
799
800 TEST q(Data::Dumper->new([$b],['b'])->Purity(0)->Dump;);
801 TEST q(Data::Dumper->new([$b],['b'])->Purity(0)->Dumpxs;)
802         if $XS;
803
804 ############# 181
805 ##
806   $WANT = <<'EOT';
807 #$b = [
808 #  \do{my $o}
809 #];
810 #${$b->[0]} = $b->[0];
811 EOT
812
813
814 TEST q(Data::Dumper->new([$b],['b'])->Purity(1)->Dump;);
815 TEST q(Data::Dumper->new([$b],['b'])->Purity(1)->Dumpxs;)
816         if $XS;
817 }
818
819 {
820   $a = "\x{09c10}";
821 ############# 187
822 ## XS code was adding an extra \0
823   $WANT = <<'EOT';
824 #$a = "\x{9c10}";
825 EOT
826
827   TEST q(Data::Dumper->Dump([$a], ['a'])), "\\x{9c10}";
828   TEST q(Data::Dumper->Dumpxs([$a], ['a'])), "XS \\x{9c10}"
829         if $XS;
830
831 }
832
833 {
834   $i = 0;
835   $a = { map { ("$_$_$_", ++$i) } 'I'..'Q' };
836   local $Data::Dumper::Sortkeys = 1;
837
838 ############# 193
839 ##
840   $WANT = <<'EOT';
841 #$VAR1 = {
842 #  III => 1,
843 #  JJJ => 2,
844 #  KKK => 3,
845 #  LLL => 4,
846 #  MMM => 5,
847 #  NNN => 6,
848 #  OOO => 7,
849 #  PPP => 8,
850 #  QQQ => 9
851 #};
852 EOT
853
854 TEST q(Data::Dumper->new([$a])->Dump;);
855 TEST q(Data::Dumper->new([$a])->Dumpxs;)
856         if $XS;
857 }
858
859 {
860   $i = 5;
861   $c = { map { (++$i, "$_$_$_") } 'I'..'Q' };
862   local $Data::Dumper::Sortkeys = \&sort199;
863   sub sort199 {
864     my $hash = shift;
865     return [ sort { $b <=> $a } keys %$hash ];
866   }
867
868 ############# 199
869 ##
870   $WANT = <<'EOT';
871 #$VAR1 = {
872 #  14 => 'QQQ',
873 #  13 => 'PPP',
874 #  12 => 'OOO',
875 #  11 => 'NNN',
876 #  10 => 'MMM',
877 #  9 => 'LLL',
878 #  8 => 'KKK',
879 #  7 => 'JJJ',
880 #  6 => 'III'
881 #};
882 EOT
883
884 # perl code does keys and values as numbers if possible
885 TEST q(Data::Dumper->new([$c])->Dump;);
886 # XS code always does them as strings
887 $WANT =~ s/ (\d+)/ '$1'/gs;
888 TEST q(Data::Dumper->new([$c])->Dumpxs;)
889         if $XS;
890 }
891
892 {
893   $i = 5;
894   $c = { map { (++$i, "$_$_$_") } 'I'..'Q' };
895   $d = { reverse %$c };
896   local $Data::Dumper::Sortkeys = \&sort205;
897   sub sort205 {
898     my $hash = shift;
899     return [ 
900       $hash eq $c ? (sort { $a <=> $b } keys %$hash)
901                   : (reverse sort keys %$hash)
902     ];
903   }
904
905 ############# 205
906 ##
907   $WANT = <<'EOT';
908 #$VAR1 = [
909 #  {
910 #    6 => 'III',
911 #    7 => 'JJJ',
912 #    8 => 'KKK',
913 #    9 => 'LLL',
914 #    10 => 'MMM',
915 #    11 => 'NNN',
916 #    12 => 'OOO',
917 #    13 => 'PPP',
918 #    14 => 'QQQ'
919 #  },
920 #  {
921 #    QQQ => 14,
922 #    PPP => 13,
923 #    OOO => 12,
924 #    NNN => 11,
925 #    MMM => 10,
926 #    LLL => 9,
927 #    KKK => 8,
928 #    JJJ => 7,
929 #    III => 6
930 #  }
931 #];
932 EOT
933
934 TEST q(Data::Dumper->new([[$c, $d]])->Dump;);
935 $WANT =~ s/ (\d+)/ '$1'/gs;
936 TEST q(Data::Dumper->new([[$c, $d]])->Dumpxs;)
937         if $XS;
938 }
939
940 {
941   local $Data::Dumper::Deparse = 1;
942   local $Data::Dumper::Indent = 2;
943
944 ############# 211
945 ##
946   $WANT = <<'EOT';
947 #$VAR1 = {
948 #          foo => sub {
949 #                         print 'foo';
950 #                     }
951 #        };
952 EOT
953
954   TEST q(Data::Dumper->new([{ foo => sub { print "foo"; } }])->Dump);
955 }
956
957 ############# 214
958 ##
959
960 # This is messy.
961 # The controls (bare numbers) are stored either as integers or floating point.
962 # [depending on whether the tokeniser sees things like ".".
963 # The peephole optimiser only runs for constant folding, not single constants,
964 # so I already have some NVs, some IVs
965 # The string versions are not. They are all PV
966
967 # This is arguably all far too chummy with the implementation, but I really
968 # want to ensure that we don't go wrong when flags on scalars get as side
969 # effects of reading them.
970
971 # These tests are actually testing the precise output of the current
972 # implementation, so will most likely fail if the implementation changes,
973 # even if the new implementation produces different but correct results.
974 # It would be nice to test for wrong answers, but I can't see how to do that,
975 # so instead I'm checking for unexpected answers. (ie -2 becoming "-2" is not
976 # wrong, but I can't see an easy, reliable way to code that knowledge)
977
978 # Numbers (seen by the tokeniser as numbers, stored as numbers.
979   @numbers =
980   (
981    0, +1, -2, 3.0, +4.0, -5.0, 6.5, +7.5, -8.5,
982     9,  +10,  -11,  12.0,  +13.0,  -14.0,  15.5,  +16.25,  -17.75,
983   );
984 # Strings
985   @strings =
986   (
987    "0", "+1", "-2", "3.0", "+4.0", "-5.0", "6.5", "+7.5", "-8.5", " 9",
988    " +10", " -11", " 12.0", " +13.0", " -14.0", " 15.5", " +16.25", " -17.75",
989   );
990
991 # The perl code always does things the same way for numbers.
992   $WANT_PL_N = <<'EOT';
993 #$VAR1 = 0;
994 #$VAR2 = 1;
995 #$VAR3 = -2;
996 #$VAR4 = 3;
997 #$VAR5 = 4;
998 #$VAR6 = -5;
999 #$VAR7 = '6.5';
1000 #$VAR8 = '7.5';
1001 #$VAR9 = '-8.5';
1002 #$VAR10 = 9;
1003 #$VAR11 = 10;
1004 #$VAR12 = -11;
1005 #$VAR13 = 12;
1006 #$VAR14 = 13;
1007 #$VAR15 = -14;
1008 #$VAR16 = '15.5';
1009 #$VAR17 = '16.25';
1010 #$VAR18 = '-17.75';
1011 EOT
1012 # The perl code knows that 0 and -2 stringify exactly back to the strings,
1013 # so it dumps them as numbers, not strings.
1014   $WANT_PL_S = <<'EOT';
1015 #$VAR1 = 0;
1016 #$VAR2 = '+1';
1017 #$VAR3 = -2;
1018 #$VAR4 = '3.0';
1019 #$VAR5 = '+4.0';
1020 #$VAR6 = '-5.0';
1021 #$VAR7 = '6.5';
1022 #$VAR8 = '+7.5';
1023 #$VAR9 = '-8.5';
1024 #$VAR10 = ' 9';
1025 #$VAR11 = ' +10';
1026 #$VAR12 = ' -11';
1027 #$VAR13 = ' 12.0';
1028 #$VAR14 = ' +13.0';
1029 #$VAR15 = ' -14.0';
1030 #$VAR16 = ' 15.5';
1031 #$VAR17 = ' +16.25';
1032 #$VAR18 = ' -17.75';
1033 EOT
1034
1035 # The XS code differs.
1036 # These are the numbers as seen by the tokeniser. Constants aren't folded
1037 # (which makes IVs where possible) so values the tokeniser thought were
1038 # floating point are stored as NVs. The XS code outputs these as strings,
1039 # but as it has converted them from NVs, leading + signs will not be there.
1040   $WANT_XS_N = <<'EOT';
1041 #$VAR1 = 0;
1042 #$VAR2 = 1;
1043 #$VAR3 = -2;
1044 #$VAR4 = '3';
1045 #$VAR5 = '4';
1046 #$VAR6 = '-5';
1047 #$VAR7 = '6.5';
1048 #$VAR8 = '7.5';
1049 #$VAR9 = '-8.5';
1050 #$VAR10 = 9;
1051 #$VAR11 = 10;
1052 #$VAR12 = -11;
1053 #$VAR13 = '12';
1054 #$VAR14 = '13';
1055 #$VAR15 = '-14';
1056 #$VAR16 = '15.5';
1057 #$VAR17 = '16.25';
1058 #$VAR18 = '-17.75';
1059 EOT
1060
1061 # These are the strings as seen by the tokeniser. The XS code will output
1062 # these for all cases except where the scalar has been used in integer context
1063   $WANT_XS_S = <<'EOT';
1064 #$VAR1 = '0';
1065 #$VAR2 = '+1';
1066 #$VAR3 = '-2';
1067 #$VAR4 = '3.0';
1068 #$VAR5 = '+4.0';
1069 #$VAR6 = '-5.0';
1070 #$VAR7 = '6.5';
1071 #$VAR8 = '+7.5';
1072 #$VAR9 = '-8.5';
1073 #$VAR10 = ' 9';
1074 #$VAR11 = ' +10';
1075 #$VAR12 = ' -11';
1076 #$VAR13 = ' 12.0';
1077 #$VAR14 = ' +13.0';
1078 #$VAR15 = ' -14.0';
1079 #$VAR16 = ' 15.5';
1080 #$VAR17 = ' +16.25';
1081 #$VAR18 = ' -17.75';
1082 EOT
1083
1084 # These are the numbers as IV-ized by &
1085 # These will differ from WANT_XS_N because now IV flags will be set on all
1086 # values that were actually integer, and the XS code will then output these
1087 # as numbers not strings.
1088   $WANT_XS_I = <<'EOT';
1089 #$VAR1 = 0;
1090 #$VAR2 = 1;
1091 #$VAR3 = -2;
1092 #$VAR4 = 3;
1093 #$VAR5 = 4;
1094 #$VAR6 = -5;
1095 #$VAR7 = '6.5';
1096 #$VAR8 = '7.5';
1097 #$VAR9 = '-8.5';
1098 #$VAR10 = 9;
1099 #$VAR11 = 10;
1100 #$VAR12 = -11;
1101 #$VAR13 = 12;
1102 #$VAR14 = 13;
1103 #$VAR15 = -14;
1104 #$VAR16 = '15.5';
1105 #$VAR17 = '16.25';
1106 #$VAR18 = '-17.75';
1107 EOT
1108
1109 # Some of these tests will be redundant.
1110 @numbers_s = @numbers_i = @numbers_is = @numbers_n = @numbers_ns = @numbers_ni
1111   = @numbers_nis = @numbers;
1112 @strings_s = @strings_i = @strings_is = @strings_n = @strings_ns = @strings_ni
1113   = @strings_nis = @strings;
1114 # Use them in an integer context
1115 foreach (@numbers_i, @numbers_ni, @numbers_nis, @numbers_is,
1116          @strings_i, @strings_ni, @strings_nis, @strings_is) {
1117   my $b = sprintf "%d", $_;
1118 }
1119 # Use them in a floating point context
1120 foreach (@numbers_n, @numbers_ni, @numbers_nis, @numbers_ns,
1121          @strings_n, @strings_ni, @strings_nis, @strings_ns) {
1122   my $b = sprintf "%e", $_;
1123 }
1124 # Use them in a string context
1125 foreach (@numbers_s, @numbers_is, @numbers_nis, @numbers_ns,
1126          @strings_s, @strings_is, @strings_nis, @strings_ns) {
1127   my $b = sprintf "%s", $_;
1128 }
1129
1130 # use Devel::Peek; Dump ($_) foreach @vanilla_c;
1131
1132 $WANT=$WANT_PL_N;
1133 TEST q(Data::Dumper->new(\@numbers)->Dump), 'Numbers';
1134 TEST q(Data::Dumper->new(\@numbers_s)->Dump), 'Numbers PV';
1135 TEST q(Data::Dumper->new(\@numbers_i)->Dump), 'Numbers IV';
1136 TEST q(Data::Dumper->new(\@numbers_is)->Dump), 'Numbers IV,PV';
1137 TEST q(Data::Dumper->new(\@numbers_n)->Dump), 'Numbers NV';
1138 TEST q(Data::Dumper->new(\@numbers_ns)->Dump), 'Numbers NV,PV';
1139 TEST q(Data::Dumper->new(\@numbers_ni)->Dump), 'Numbers NV,IV';
1140 TEST q(Data::Dumper->new(\@numbers_nis)->Dump), 'Numbers NV,IV,PV';
1141 $WANT=$WANT_PL_S;
1142 TEST q(Data::Dumper->new(\@strings)->Dump), 'Strings';
1143 TEST q(Data::Dumper->new(\@strings_s)->Dump), 'Strings PV';
1144 TEST q(Data::Dumper->new(\@strings_i)->Dump), 'Strings IV';
1145 TEST q(Data::Dumper->new(\@strings_is)->Dump), 'Strings IV,PV';
1146 TEST q(Data::Dumper->new(\@strings_n)->Dump), 'Strings NV';
1147 TEST q(Data::Dumper->new(\@strings_ns)->Dump), 'Strings NV,PV';
1148 TEST q(Data::Dumper->new(\@strings_ni)->Dump), 'Strings NV,IV';
1149 TEST q(Data::Dumper->new(\@strings_nis)->Dump), 'Strings NV,IV,PV';
1150 if ($XS) {
1151   $WANT=$WANT_XS_N;
1152   TEST q(Data::Dumper->new(\@numbers)->Dumpxs), 'XS Numbers';
1153   TEST q(Data::Dumper->new(\@numbers_s)->Dumpxs), 'XS Numbers PV';
1154   $WANT=$WANT_XS_I;
1155   TEST q(Data::Dumper->new(\@numbers_i)->Dumpxs), 'XS Numbers IV';
1156   TEST q(Data::Dumper->new(\@numbers_is)->Dumpxs), 'XS Numbers IV,PV';
1157   $WANT=$WANT_XS_N;
1158   TEST q(Data::Dumper->new(\@numbers_n)->Dumpxs), 'XS Numbers NV';
1159   TEST q(Data::Dumper->new(\@numbers_ns)->Dumpxs), 'XS Numbers NV,PV';
1160   $WANT=$WANT_XS_I;
1161   TEST q(Data::Dumper->new(\@numbers_ni)->Dumpxs), 'XS Numbers NV,IV';
1162   TEST q(Data::Dumper->new(\@numbers_nis)->Dumpxs), 'XS Numbers NV,IV,PV';
1163
1164   $WANT=$WANT_XS_S;
1165   TEST q(Data::Dumper->new(\@strings)->Dumpxs), 'XS Strings';
1166   TEST q(Data::Dumper->new(\@strings_s)->Dumpxs), 'XS Strings PV';
1167   # This one used to really mess up. New code actually emulates the .pm code
1168   $WANT=$WANT_PL_S;
1169   TEST q(Data::Dumper->new(\@strings_i)->Dumpxs), 'XS Strings IV';
1170   TEST q(Data::Dumper->new(\@strings_is)->Dumpxs), 'XS Strings IV,PV';
1171   $WANT=$WANT_XS_S;
1172   TEST q(Data::Dumper->new(\@strings_n)->Dumpxs), 'XS Strings NV';
1173   TEST q(Data::Dumper->new(\@strings_ns)->Dumpxs), 'XS Strings NV,PV';
1174   # This one used to really mess up. New code actually emulates the .pm code
1175   $WANT=$WANT_PL_S;
1176   TEST q(Data::Dumper->new(\@strings_ni)->Dumpxs), 'XS Strings NV,IV';
1177   TEST q(Data::Dumper->new(\@strings_nis)->Dumpxs), 'XS Strings NV,IV,PV';
1178 }
1179
1180 {
1181   $a = "1\n";
1182 ############# 310
1183 ## Perl code was using /...$/ and hence missing the \n.
1184   $WANT = <<'EOT';
1185 my $VAR1 = '42
1186 ';
1187 EOT
1188
1189   # Can't pad with # as the output has an embedded newline.
1190   local $Data::Dumper::Pad = "my ";
1191   TEST q(Data::Dumper->Dump(["42\n"])), "number with trailing newline";
1192   TEST q(Data::Dumper->Dumpxs(["42\n"])), "XS number with trailing newline"
1193         if $XS;
1194 }
1195
1196 {
1197   @a = (
1198         999999999,
1199         1000000000,
1200         9999999999,
1201         10000000000,
1202         -999999999,
1203         -1000000000,
1204         -9999999999,
1205         -10000000000,
1206         4294967295,
1207         4294967296,
1208         -2147483648,
1209         -2147483649,
1210         );
1211 ############# 316
1212 ## Perl code flips over at 10 digits.
1213   $WANT = <<'EOT';
1214 #$VAR1 = 999999999;
1215 #$VAR2 = '1000000000';
1216 #$VAR3 = '9999999999';
1217 #$VAR4 = '10000000000';
1218 #$VAR5 = -999999999;
1219 #$VAR6 = '-1000000000';
1220 #$VAR7 = '-9999999999';
1221 #$VAR8 = '-10000000000';
1222 #$VAR9 = '4294967295';
1223 #$VAR10 = '4294967296';
1224 #$VAR11 = '-2147483648';
1225 #$VAR12 = '-2147483649';
1226 EOT
1227
1228   TEST q(Data::Dumper->Dump(\@a)), "long integers";
1229
1230   if ($XS) {
1231 ## XS code flips over at 11 characters ("-" is a char) or larger than int.
1232     if (~0 == 0xFFFFFFFF) {
1233       # 32 bit system
1234       $WANT = <<'EOT';
1235 #$VAR1 = 999999999;
1236 #$VAR2 = 1000000000;
1237 #$VAR3 = '9999999999';
1238 #$VAR4 = '10000000000';
1239 #$VAR5 = -999999999;
1240 #$VAR6 = '-1000000000';
1241 #$VAR7 = '-9999999999';
1242 #$VAR8 = '-10000000000';
1243 #$VAR9 = 4294967295;
1244 #$VAR10 = '4294967296';
1245 #$VAR11 = '-2147483648';
1246 #$VAR12 = '-2147483649';
1247 EOT
1248     } else {
1249       $WANT = <<'EOT';
1250 #$VAR1 = 999999999;
1251 #$VAR2 = 1000000000;
1252 #$VAR3 = 9999999999;
1253 #$VAR4 = '10000000000';
1254 #$VAR5 = -999999999;
1255 #$VAR6 = '-1000000000';
1256 #$VAR7 = '-9999999999';
1257 #$VAR8 = '-10000000000';
1258 #$VAR9 = 4294967295;
1259 #$VAR10 = 4294967296;
1260 #$VAR11 = '-2147483648';
1261 #$VAR12 = '-2147483649';
1262 EOT
1263     }
1264     TEST q(Data::Dumper->Dumpxs(\@a)), "XS long integers";
1265   }
1266 }
1267
1268 #XXX}
1269 {
1270   $b = "Bad. XS didn't escape dollar sign";
1271 ############# 322
1272   $WANT = <<"EOT"; # Careful. This is '' string written inside '' here doc
1273 #\$VAR1 = '\$b\"\@\\\\\xA3';
1274 EOT
1275
1276   $a = "\$b\"\@\\\xA3\x{100}";
1277   chop $a;
1278   TEST q(Data::Dumper->Dump([$a])), "utf8 flag with \" and \$";
1279   if ($XS) {
1280     $WANT = <<'EOT'; # While this is "" string written inside "" here doc
1281 #$VAR1 = "\$b\"\@\\\x{a3}";
1282 EOT
1283     TEST q(Data::Dumper->Dumpxs([$a])), "XS utf8 flag with \" and \$";
1284   }
1285   # XS used to produce "$b\"' which is 4 chars, not 3. [ie wrongly qq(\$b\\\")]
1286 ############# 328
1287   $WANT = <<'EOT';
1288 #$VAR1 = '$b"';
1289 EOT
1290
1291   $a = "\$b\"\x{100}";
1292   chop $a;
1293   TEST q(Data::Dumper->Dump([$a])), "utf8 flag with \" and \$";
1294   if ($XS) {
1295     TEST q(Data::Dumper->Dumpxs([$a])), "XS utf8 flag with \" and \$";
1296   }
1297
1298
1299   # XS used to produce 'D'oh!' which is well, D'oh!
1300   # Andreas found this one, which in turn discovered the previous two.
1301 ############# 334
1302   $WANT = <<'EOT';
1303 #$VAR1 = 'D\'oh!';
1304 EOT
1305
1306   $a = "D'oh!\x{100}";
1307   chop $a;
1308   TEST q(Data::Dumper->Dump([$a])), "utf8 flag with '";
1309   if ($XS) {
1310     TEST q(Data::Dumper->Dumpxs([$a])), "XS utf8 flag with '";
1311   }
1312 }
1313
1314 # Jarkko found that -Mutf8 caused some tests to fail.  Turns out that there
1315 # was an otherwise untested code path in the XS for utf8 hash keys with purity
1316 # 1
1317
1318 {
1319   $WANT = <<'EOT';
1320 #$ping = \*::ping;
1321 #*::ping = \5;
1322 #*::ping = {
1323 #  "\x{decaf}\x{decaf}\x{decaf}\x{decaf}" => do{my $o}
1324 #};
1325 #*::ping{HASH}->{"\x{decaf}\x{decaf}\x{decaf}\x{decaf}"} = *::ping{SCALAR};
1326 #%pong = %{*::ping{HASH}};
1327 EOT
1328   local $Data::Dumper::Purity = 1;
1329   local $Data::Dumper::Sortkeys;
1330   $ping = 5;
1331   %ping = (chr (0xDECAF) x 4  =>\$ping);
1332   for $Data::Dumper::Sortkeys (0, 1) {
1333     TEST q(Data::Dumper->Dump([\\*ping, \\%ping], ['*ping', '*pong']));
1334     TEST q(Data::Dumper->Dumpxs([\\*ping, \\%ping], ['*ping', '*pong'])) if $XS;
1335   }
1336 }
1337
1338 # XS for quotekeys==0 was not being defensive enough against utf8 flagged
1339 # scalars
1340
1341 {
1342   $WANT = <<'EOT';
1343 #$VAR1 = {
1344 #  perl => 'rocks'
1345 #};
1346 EOT
1347   local $Data::Dumper::Quotekeys = 0;
1348   my $k = 'perl' . chr 256;
1349   chop $k;
1350   %foo = ($k => 'rocks');
1351
1352   TEST q(Data::Dumper->Dump([\\%foo])), "quotekeys == 0 for utf8 flagged ASCII";
1353   TEST q(Data::Dumper->Dumpxs([\\%foo])),
1354     "XS quotekeys == 0 for utf8 flagged ASCII" if $XS;
1355 }
1356 ############# 358
1357 {
1358   $WANT = <<'EOT';
1359 #$VAR1 = [
1360 #  undef,
1361 #  undef,
1362 #  1
1363 #];
1364 EOT
1365     @foo = ();
1366     $foo[2] = 1;
1367     TEST q(Data::Dumper->Dump([\@foo])), 'Richard Clamp, Message-Id: <20030104005247.GA27685@mirth.demon.co.uk>';
1368     TEST q(Data::Dumper->Dumpxs([\@foo])) if $XS;
1369 }
1370
1371