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