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