use Data::Dumper;
use Config;
-my $Is_ebcdic = defined($Config{'ebcdic'}) && $Config{'ebcdic'} eq 'define';
$Data::Dumper::Pad = "#";
my $TMAX;
my $TNUM = 0;
my $WANT = '';
+sub convert_to_native($) {
+ my $input = shift;
+
+ # unicode_to_native() not available before this release; hence won't work
+ # on EBCDIC platforms for earlier.
+ return $input if $] lt 5.007_003;
+
+ my @output;
+
+ # The input should always be one of the following constructs
+ while ($input =~ m/ ( \\ [0-7]+ )
+ | ( \\ x \{ [[:xdigit:]]+ } )
+ | ( \\ . )
+ | ( . ) /gx)
+ {
+ #print STDERR __LINE__, ": ", $&, "\n";
+ my $index;
+ my $replacement;
+ if (defined $4) { # Literal
+ $index = ord $4;
+ $replacement = $4;
+ }
+ elsif (defined $3) { # backslash escape
+ $index = ord eval "\"$3\"";
+ $replacement = $3;
+ }
+ elsif (defined $2) { # Hex
+ $index = utf8::unicode_to_native(ord eval "\"$2\"");
+
+ # But low hex numbers are always in octal. These are all
+ # controls.
+ my $format = ($index < ord(" "))
+ ? "\\%o"
+ : "\\x{%x}";
+ $replacement = sprintf($format, $index);
+ }
+ elsif (defined $1) { # Octal
+ $index = utf8::unicode_to_native(ord eval "\"$1\"");
+ $replacement = sprintf("\\%o", $index);
+ }
+ else {
+ die "Unexpected match in convert_to_native()";
+ }
+
+ if (defined $output[$index]) {
+ print STDERR "ordinal $index already has '$output[$index]'; skipping '$replacement'\n";
+ next;
+ }
+
+ $output[$index] = $replacement;
+ }
+
+ return join "", grep { defined } @output;
+}
+
sub TEST {
my $string = shift;
my $name = shift;
my $t = eval $string;
++$TNUM;
$t =~ s/([A-Z]+)\(0x[0-9a-f]+\)/$1(0xdeadbeef)/g
- if ($WANT =~ /deadbeef/);
- if ($Is_ebcdic) {
- # these data need massaging with non ascii character sets
- # because of hashing order differences
- $WANT = join("\n",sort(split(/\n/,$WANT)));
- $WANT =~ s/\,$//mg;
- $t = join("\n",sort(split(/\n/,$t)));
- $t =~ s/\,$//mg;
- }
+ if ($WANT =~ /deadbeef/);
$name = $name ? " - $name" : '';
print( ($t eq $WANT and not $@) ? "ok $TNUM$name\n"
- : "not ok $TNUM$name\n--Expected--\n$WANT\n--Got--\n$@$t\n");
+ : "not ok $TNUM$name\n--Expected--\n$WANT\n--Got--\n$@$t\n");
++$TNUM;
- if ($Is_ebcdic) { # EBCDIC.
- if ($TNUM == 311 || $TNUM == 314) {
- eval $string;
- } else {
- eval $t;
- }
- } else {
- eval "$t";
- }
- print $@ ? "not ok $TNUM\n# \$@ says: $@\n" : "ok $TNUM\n";
+ eval "$t";
+ print $@ ? "not ok $TNUM\n# \$@ says: $@\n" : "ok $TNUM - no eval error\n";
$t = eval $string;
++$TNUM;
$t =~ s/([A-Z]+)\(0x[0-9a-f]+\)/$1(0xdeadbeef)/g
- if ($WANT =~ /deadbeef/);
- if ($Is_ebcdic) {
- # here too there are hashing order differences
- $WANT = join("\n",sort(split(/\n/,$WANT)));
- $WANT =~ s/\,$//mg;
- $t = join("\n",sort(split(/\n/,$t)));
- $t =~ s/\,$//mg;
- }
- print( ($t eq $WANT and not $@) ? "ok $TNUM\n"
- : "not ok $TNUM\n--Expected--\n$WANT\n--Got--\n$@$t\n");
+ if ($WANT =~ /deadbeef/);
+ print( ($t eq $WANT and not $@) ? "ok $TNUM - works a 2nd time after intervening eval\n"
+ : "not ok $TNUM\n--Expected--\n$WANT\n--Got--\n$@$t\n");
}
sub SKIP_TEST {
++$TNUM; print "ok $TNUM # skip $reason\n";
}
+$TMAX = 450;
+
# Force Data::Dumper::Dump to use perl. We test Dumpxs explicitly by calling
# it direct. Out here it lets us knobble the next if to test that the perl
# only tests do work (and count correctly)
$Data::Dumper::Useperl = 1;
if (defined &Data::Dumper::Dumpxs) {
print "### XS extension loaded, will run XS tests\n";
- $TMAX = 384; $XS = 1;
+ $XS = 1;
}
else {
print "### XS extensions not loaded, will NOT run XS tests\n";
- $TMAX = 192; $XS = 0;
+ $TMAX /= 2;
+ $XS = 0;
}
print "1..$TMAX\n";
$b->{b} = $a->[1];
$b->{c} = $a->[2];
-############# 1
+#############
##
$WANT = <<'EOT';
#$a = [
#$6 = $a->[1]{'c'};
EOT
-TEST q(Data::Dumper->Dump([$a,$b,$c], [qw(a b), 6]));
-TEST q(Data::Dumper->Dumpxs([$a,$b,$c], [qw(a b), 6])) if $XS;
+TEST (q(Data::Dumper->Dump([$a,$b,$c], [qw(a b), 6])),
+ 'basic test with names: Dump()');
+TEST (q(Data::Dumper->Dumpxs([$a,$b,$c], [qw(a b), 6])),
+ 'basic test with names: Dumpxs()')
+ if $XS;
+SCOPE: {
+ local $Data::Dumper::Sparseseen = 1;
+ TEST (q(Data::Dumper->Dump([$a,$b,$c], [qw(a b), 6])),
+ 'Sparseseen with names: Dump()');
+ TEST (q(Data::Dumper->Dumpxs([$a,$b,$c], [qw(a b), 6])),
+ 'Sparseseen with names: Dumpxs()')
+ if $XS;
+}
-############# 7
+
+#############
##
$WANT = <<'EOT';
#@a = (
EOT
$Data::Dumper::Purity = 1; # fill in the holes for eval
-TEST q(Data::Dumper->Dump([$a, $b], [qw(*a b)])); # print as @a
-TEST q(Data::Dumper->Dumpxs([$a, $b], [qw(*a b)])) if $XS;
+TEST (q(Data::Dumper->Dump([$a, $b], [qw(*a b)])),
+ 'Purity: basic test with dereferenced array: Dump()'); # print as @a
+TEST (q(Data::Dumper->Dumpxs([$a, $b], [qw(*a b)])),
+ 'Purity: basic test with dereferenced array: Dumpxs()')
+ if $XS;
+
+SCOPE: {
+ local $Data::Dumper::Sparseseen = 1;
+ TEST (q(Data::Dumper->Dump([$a, $b], [qw(*a b)])),
+ 'Purity: Sparseseen with dereferenced array: Dump()'); # print as @a
+ TEST (q(Data::Dumper->Dumpxs([$a, $b], [qw(*a b)])),
+ 'Purity: Sparseseen with dereferenced array: Dumpxs()')
+ if $XS;
+}
-############# 13
+#############
##
$WANT = <<'EOT';
#%b = (
#$a = $b{'a'};
EOT
-TEST q(Data::Dumper->Dump([$b, $a], [qw(*b a)])); # print as %b
-TEST q(Data::Dumper->Dumpxs([$b, $a], [qw(*b a)])) if $XS;
+TEST (q(Data::Dumper->Dump([$b, $a], [qw(*b a)])),
+ 'basic test with dereferenced hash: Dump()'); # print as %b
+TEST (q(Data::Dumper->Dumpxs([$b, $a], [qw(*b a)])),
+ 'basic test with dereferenced hash: Dumpxs()')
+ if $XS;
-############# 19
+#############
##
$WANT = <<'EOT';
#$a = [
EOT
$Data::Dumper::Indent = 1;
-TEST q(
+TEST (q(
$d = Data::Dumper->new([$a,$b], [qw(a b)]);
$d->Seen({'*c' => $c});
$d->Dump;
- );
+ ),
+ 'Indent: Seen: Dump()');
if ($XS) {
- TEST q(
+ TEST (q(
$d = Data::Dumper->new([$a,$b], [qw(a b)]);
$d->Seen({'*c' => $c});
$d->Dumpxs;
- );
+ ),
+ 'Indent: Seen: Dumpxs()');
}
-############# 25
+#############
##
$WANT = <<'EOT';
#$a = [
$d->Indent(3);
$d->Purity(0)->Quotekeys(0);
-TEST q( $d->Reset; $d->Dump );
+TEST (q( $d->Reset; $d->Dump ),
+ 'Indent(3): Purity(0)->Quotekeys(0): Dump()');
-TEST q( $d->Reset; $d->Dumpxs ) if $XS;
+TEST (q( $d->Reset; $d->Dumpxs ),
+ 'Indent(3): Purity(0)->Quotekeys(0): Dumpxs()')
+ if $XS;
-############# 31
+#############
##
$WANT = <<'EOT';
#$VAR1 = [
#$VAR1->[2] = $VAR1->[1]{'c'};
EOT
-TEST q(Dumper($a));
-TEST q(Data::Dumper::DumperX($a)) if $XS;
+TEST (q(Dumper($a)), 'Dumper');
+TEST (q(Data::Dumper::DumperX($a)), 'DumperX') if $XS;
-############# 37
+#############
##
$WANT = <<'EOT';
#[
local $Data::Dumper::Purity = 0;
local $Data::Dumper::Quotekeys = 0;
local $Data::Dumper::Terse = 1;
- TEST q(Dumper($a));
- TEST q(Data::Dumper::DumperX($a)) if $XS;
+ TEST (q(Dumper($a)),
+ 'Purity 0: Quotekeys 0: Terse 1: Dumper');
+ TEST (q(Data::Dumper::DumperX($a)),
+ 'Purity 0: Quotekeys 0: Terse 1: DumperX')
+ if $XS;
}
-############# 43
+#############
##
$WANT = <<'EOT';
#$VAR1 = {
};
{
local $Data::Dumper::Useqq = 1;
- TEST q(Dumper($foo));
+ TEST (q(Dumper($foo)), 'Useqq: Dumper');
+ TEST (q(Data::Dumper::DumperX($foo)), 'Useqq: DumperX') if $XS;
}
- $WANT = <<"EOT";
-#\$VAR1 = {
-# 'abc\0\\'\efg' => 'mno\0',
-# 'reftest' => \\\\1
-#};
-EOT
-
- {
- local $Data::Dumper::Useqq = 1;
- TEST q(Data::Dumper::DumperX($foo)) if $XS; # cheat
- }
-
#############
$foo{d} = \%foo;
$foo[2] = \%foo;
-############# 49
+#############
##
$WANT = <<'EOT';
#$foo = \*::foo;
$Data::Dumper::Purity = 1;
$Data::Dumper::Indent = 3;
- TEST q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz']));
- TEST q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])) if $XS;
+ TEST (q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])),
+ 'Purity 1: Indent 3: Dump()');
+ TEST (q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])),
+ 'Purity 1: Indent 3: Dumpxs()')
+ if $XS;
-############# 55
+#############
##
$WANT = <<'EOT';
#$foo = \*::foo;
EOT
$Data::Dumper::Indent = 1;
- TEST q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz']));
- TEST q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])) if $XS;
+ TEST (q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])),
+ 'Purity 1: Indent 1: Dump()');
+ TEST (q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])),
+ 'Purity 1: Indent 1: Dumpxs()')
+ if $XS;
-############# 61
+#############
##
$WANT = <<'EOT';
#@bar = (
#$foo = $bar[1];
EOT
- TEST q(Data::Dumper->Dump([\\@foo, \\%foo, \\*foo], ['*bar', '*baz', '*foo']));
- TEST q(Data::Dumper->Dumpxs([\\@foo, \\%foo, \\*foo], ['*bar', '*baz', '*foo'])) if $XS;
+ TEST (q(Data::Dumper->Dump([\\@foo, \\%foo, \\*foo], ['*bar', '*baz', '*foo'])),
+ 'array|hash|glob dereferenced: Dump()');
+ TEST (q(Data::Dumper->Dumpxs([\\@foo, \\%foo, \\*foo], ['*bar', '*baz', '*foo'])),
+ 'array|hash|glob dereferenced: Dumpxs()')
+ if $XS;
-############# 67
+#############
##
$WANT = <<'EOT';
#$bar = [
#$foo = $bar->[1];
EOT
- TEST q(Data::Dumper->Dump([\\@foo, \\%foo, \\*foo], ['bar', 'baz', 'foo']));
- TEST q(Data::Dumper->Dumpxs([\\@foo, \\%foo, \\*foo], ['bar', 'baz', 'foo'])) if $XS;
+ TEST (q(Data::Dumper->Dump([\\@foo, \\%foo, \\*foo], ['bar', 'baz', 'foo'])),
+ 'array|hash|glob: not dereferenced: Dump()');
+ TEST (q(Data::Dumper->Dumpxs([\\@foo, \\%foo, \\*foo], ['bar', 'baz', 'foo'])),
+ 'array|hash|glob: not dereferenced: Dumpxs()')
+ if $XS;
-############# 73
+#############
##
$WANT = <<'EOT';
#$foo = \*::foo;
$Data::Dumper::Purity = 0;
$Data::Dumper::Quotekeys = 0;
- TEST q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz']));
- TEST q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])) if $XS;
+ TEST (q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])),
+ 'Purity 0: Quotekeys 0: dereferenced: Dump()');
+ TEST (q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['*foo', '*bar', '*baz'])),
+ 'Purity 0: Quotekeys 0: dereferenced: Dumpxs')
+ if $XS;
-############# 79
+#############
##
$WANT = <<'EOT';
#$foo = \*::foo;
#$baz = $bar->[2];
EOT
- TEST q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz']));
- TEST q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])) if $XS;
+ TEST (q(Data::Dumper->Dump([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])),
+ 'Purity 0: Quotekeys 0: not dereferenced: Dump()');
+ TEST (q(Data::Dumper->Dumpxs([\\*foo, \\@foo, \\%foo], ['foo', 'bar', 'baz'])),
+ 'Purity 0: Quotekeys 0: not dereferenced: Dumpxs()')
+ if $XS;
}
$dogs[2] = \%kennel;
$mutts = \%kennel;
$mutts = $mutts; # avoid warning
-
-############# 85
+
+#############
##
$WANT = <<'EOT';
#%kennels = (
#%mutts = %kennels;
EOT
- TEST q(
+ TEST (q(
$d = Data::Dumper->new([\\%kennel, \\@dogs, $mutts],
[qw(*kennels *dogs *mutts)] );
$d->Dump;
- );
+ ),
+ 'constructor: hash|array|scalar: Dump()');
if ($XS) {
- TEST q(
+ TEST (q(
$d = Data::Dumper->new([\\%kennel, \\@dogs, $mutts],
[qw(*kennels *dogs *mutts)] );
$d->Dumpxs;
- );
+ ),
+ 'constructor: hash|array|scalar: Dumpxs()');
}
-
-############# 91
+
+#############
##
$WANT = <<'EOT';
#%kennels = %kennels;
#%mutts = %kennels;
EOT
- TEST q($d->Dump);
- TEST q($d->Dumpxs) if $XS;
-
-############# 97
+ TEST q($d->Dump), 'object call: Dump';
+ TEST q($d->Dumpxs), 'object call: Dumpxs' if $XS;
+
+#############
##
$WANT = <<'EOT';
#%kennels = (
#%mutts = %kennels;
EOT
-
- TEST q($d->Reset; $d->Dump);
+ TEST q($d->Reset; $d->Dump), 'Reset and Dump separate calls';
if ($XS) {
- TEST q($d->Reset; $d->Dumpxs);
+ TEST (q($d->Reset; $d->Dumpxs), 'Reset and Dumpxs separate calls');
}
-############# 103
+#############
##
$WANT = <<'EOT';
#@dogs = (
#%mutts = %{$dogs[2]};
EOT
- TEST q(
+ TEST (q(
$d = Data::Dumper->new([\\@dogs, \\%kennel, $mutts],
[qw(*dogs *kennels *mutts)] );
$d->Dump;
- );
+ ),
+ 'constructor: array|hash|scalar: Dump()');
if ($XS) {
- TEST q(
+ TEST (q(
$d = Data::Dumper->new([\\@dogs, \\%kennel, $mutts],
[qw(*dogs *kennels *mutts)] );
$d->Dumpxs;
- );
+ ),
+ 'constructor: array|hash|scalar: Dumpxs()');
}
-
-############# 109
+
+#############
##
- TEST q($d->Reset->Dump);
+ TEST q($d->Reset->Dump), 'Reset Dump chained';
if ($XS) {
- TEST q($d->Reset->Dumpxs);
+ TEST q($d->Reset->Dumpxs), 'Reset Dumpxs chained';
}
-############# 115
+#############
##
$WANT = <<'EOT';
#@dogs = (
#);
EOT
- TEST q(
+ TEST (q(
$d = Data::Dumper->new( [\@dogs, \%kennel], [qw(*dogs *kennels)] );
$d->Deepcopy(1)->Dump;
- );
+ ),
+ 'Deepcopy(1): Dump');
if ($XS) {
- TEST q($d->Reset->Dumpxs);
+# TEST 'q($d->Reset->Dumpxs);
+ TEST (q(
+ $d = Data::Dumper->new( [\@dogs, \%kennel], [qw(*dogs *kennels)] );
+ $d->Deepcopy(1)->Dumpxs;
+ ),
+ 'Deepcopy(1): Dumpxs');
}
-
+
}
{
sub z { print "foo\n" }
$c = [ \&z ];
-############# 121
+#############
##
$WANT = <<'EOT';
#$a = $b;
#];
EOT
-TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'b' => \&z})->Dump;);
-TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'b' => \&z})->Dumpxs;)
+TEST (q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'b' => \&z})->Dump;),
+ 'Seen: scalar: Dump');
+TEST (q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'b' => \&z})->Dumpxs;),
+ 'Seen: scalar: Dumpxs')
if $XS;
-############# 127
+#############
##
$WANT = <<'EOT';
#$a = \&b;
#];
EOT
-TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'*b' => \&z})->Dump;);
-TEST q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'*b' => \&z})->Dumpxs;)
+TEST (q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'*b' => \&z})->Dump;),
+ 'Seen: glob: Dump');
+TEST (q(Data::Dumper->new([\&z,$c],['a','c'])->Seen({'*b' => \&z})->Dumpxs;),
+ 'Seen: glob: Dumpxs')
if $XS;
-############# 133
+#############
##
$WANT = <<'EOT';
#*a = \&b;
#);
EOT
-TEST q(Data::Dumper->new([\&z,$c],['*a','*c'])->Seen({'*b' => \&z})->Dump;);
-TEST q(Data::Dumper->new([\&z,$c],['*a','*c'])->Seen({'*b' => \&z})->Dumpxs;)
+TEST (q(Data::Dumper->new([\&z,$c],['*a','*c'])->Seen({'*b' => \&z})->Dump;),
+ 'Seen: glob: dereference: Dump');
+TEST (q(Data::Dumper->new([\&z,$c],['*a','*c'])->Seen({'*b' =>
+\&z})->Dumpxs;),
+ 'Seen: glob: derference: Dumpxs')
if $XS;
}
$a = [];
$a->[1] = \$a->[0];
-############# 139
+#############
##
$WANT = <<'EOT';
#@a = (
#$a[1] = \$a[0];
EOT
-TEST q(Data::Dumper->new([$a],['*a'])->Purity(1)->Dump;);
-TEST q(Data::Dumper->new([$a],['*a'])->Purity(1)->Dumpxs;)
+TEST (q(Data::Dumper->new([$a],['*a'])->Purity(1)->Dump;),
+ 'Purity(1): dereference: Dump');
+TEST (q(Data::Dumper->new([$a],['*a'])->Purity(1)->Dumpxs;),
+ 'Purity(1): dereference: Dumpxs')
if $XS;
}
$a = \\\\\'foo';
$b = $$$a;
-############# 145
+#############
##
$WANT = <<'EOT';
#$a = \\\\\'foo';
#$b = ${${$a}};
EOT
-TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dump;);
-TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dumpxs;)
+TEST (q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dump;),
+ 'Purity(1): not dereferenced: Dump');
+TEST (q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dumpxs;),
+ 'Purity(1): not dereferenced: Dumpxs')
if $XS;
}
$a = [{ a => \$b }, { b => undef }];
$b = [{ c => \$b }, { d => \$a }];
-############# 151
+#############
##
$WANT = <<'EOT';
#$a = [
#$b = ${$a->[0]{a}};
EOT
-TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dump;);
-TEST q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dumpxs;)
+TEST (q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dump;),
+ 'Purity(1): Dump again');
+TEST (q(Data::Dumper->new([$a,$b],['a','b'])->Purity(1)->Dumpxs;),
+ 'Purity(1); Dumpxs again')
if $XS;
}
$b = $a->[0][0];
$c = $${$b->[0][0]};
-############# 157
+#############
##
$WANT = <<'EOT';
#$a = [
#$c = ${${$a->[0][0][0][0]}};
EOT
-TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Purity(1)->Dump;);
-TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Purity(1)->Dumpxs;)
+TEST (q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Purity(1)->Dump;),
+ 'Purity(1): Dump: 3 elements');
+TEST (q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Purity(1)->Dumpxs;),
+ 'Purity(1): Dumpxs: 3 elements')
if $XS;
}
$b = { 'c' => $c };
$a = { 'b' => $b };
-############# 163
+#############
##
$WANT = <<'EOT';
#$a = {
#$c = $a->{b}{c};
EOT
-TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(4)->Dump;);
-TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(4)->Dumpxs;)
+TEST (q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(4)->Dump;),
+ 'Maxdepth(4): Dump()');
+TEST (q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(4)->Dumpxs;),
+ 'Maxdepth(4): Dumpxs()')
if $XS;
-############# 169
+#############
##
$WANT = <<'EOT';
#$a = {
#];
EOT
-TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(1)->Dump;);
-TEST q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(1)->Dumpxs;)
+TEST (q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(1)->Dump;),
+ 'Maxdepth(1): Dump()');
+TEST (q(Data::Dumper->new([$a,$b,$c],['a','b','c'])->Maxdepth(1)->Dumpxs;),
+ 'Maxdepth(1): Dumpxs()')
if $XS;
}
$a = \$a;
$b = [$a];
-############# 175
+#############
##
$WANT = <<'EOT';
#$b = [
#];
EOT
-TEST q(Data::Dumper->new([$b],['b'])->Purity(0)->Dump;);
-TEST q(Data::Dumper->new([$b],['b'])->Purity(0)->Dumpxs;)
+TEST (q(Data::Dumper->new([$b],['b'])->Purity(0)->Dump;),
+ 'Purity(0): Dump()');
+TEST (q(Data::Dumper->new([$b],['b'])->Purity(0)->Dumpxs;),
+ 'Purity(0): Dumpxs()')
if $XS;
-############# 181
+#############
##
$WANT = <<'EOT';
#$b = [
EOT
-TEST q(Data::Dumper->new([$b],['b'])->Purity(1)->Dump;);
-TEST q(Data::Dumper->new([$b],['b'])->Purity(1)->Dumpxs;)
+TEST (q(Data::Dumper->new([$b],['b'])->Purity(1)->Dump;),
+ 'Purity(1): Dump()');
+TEST (q(Data::Dumper->new([$b],['b'])->Purity(1)->Dumpxs;),
+ 'Purity(1): Dumpxs')
if $XS;
}
{
$a = "\x{09c10}";
-############# 187
+#############
## XS code was adding an extra \0
$WANT = <<'EOT';
#$a = "\x{9c10}";
$i = 0;
$a = { map { ("$_$_$_", ++$i) } 'I'..'Q' };
-############# 193
+#############
##
$WANT = <<'EOT';
#$VAR1 = {
#};
EOT
-TEST q(Data::Dumper->new([$a])->Dump;);
-TEST q(Data::Dumper->new([$a])->Dumpxs;)
+TEST (q(Data::Dumper->new([$a])->Dump;),
+ 'basic test without names: Dump()');
+TEST (q(Data::Dumper->new([$a])->Dumpxs;),
+ 'basic test without names: Dumpxs()')
if $XS;
}
return [ sort { $b <=> $a } keys %$hash ];
}
-############# 199
+#############
##
$WANT = <<'EOT';
#$VAR1 = {
#};
EOT
-# perl code does keys and values as numbers if possible
-TEST q(Data::Dumper->new([$c])->Dump;);
-# XS code always does them as strings
-$WANT =~ s/ (\d+)/ '$1'/gs;
-TEST q(Data::Dumper->new([$c])->Dumpxs;)
+TEST q(Data::Dumper->new([$c])->Dump;), "sortkeys sub";
+TEST q(Data::Dumper->new([$c])->Dumpxs;), "sortkeys sub (XS)"
if $XS;
}
local $Data::Dumper::Sortkeys = \&sort205;
sub sort205 {
my $hash = shift;
- return [
+ return [
$hash eq $c ? (sort { $a <=> $b } keys %$hash)
: (reverse sort keys %$hash)
];
}
-############# 205
+#############
##
$WANT = <<'EOT';
#$VAR1 = [
#];
EOT
-TEST q(Data::Dumper->new([[$c, $d]])->Dump;);
-$WANT =~ s/ (\d+)/ '$1'/gs;
-TEST q(Data::Dumper->new([[$c, $d]])->Dumpxs;)
+TEST q(Data::Dumper->new([[$c, $d]])->Dump;), "more sortkeys sub";
+# the XS code does number values as strings
+$WANT =~ s/ (\d+)(,?)$/ '$1'$2/gm;
+TEST q(Data::Dumper->new([[$c, $d]])->Dumpxs;), "more sortkeys sub (XS)"
if $XS;
}
local $Data::Dumper::Deparse = 1;
local $Data::Dumper::Indent = 2;
-############# 211
+#############
##
$WANT = <<'EOT';
#$VAR1 = {
if(" $Config{'extensions'} " !~ m[ B ]) {
SKIP_TEST "Perl configured without B module";
} else {
- TEST q(Data::Dumper->new([{ foo => sub { print "foo"; } }])->Dump);
+ TEST (q(Data::Dumper->new([{ foo => sub { print "foo"; } }])->Dump),
+ 'Deparse 1: Indent 2; Dump()');
}
}
-############# 214
+#############
##
# This is messy.
{
$a = "1\n";
-############# 310
+#############
## Perl code was using /...$/ and hence missing the \n.
$WANT = <<'EOT';
my $VAR1 = '42
-2147483648,
-2147483649,
);
-############# 316
+#############
## Perl code flips over at 10 digits.
$WANT = <<'EOT';
#$VAR1 = 999999999;
if ($Is_ebcdic) {
$b = "Bad. XS didn't escape dollar sign";
############# 322
- $WANT = <<"EOT"; # Careful. This is '' string written inside '' here doc
+ $WANT = <<"EOT"; # Careful. This is '' string written inside "" here doc
#\$VAR1 = '\$b\"\@\\\\\xB1';
EOT
$a = "\$b\"\@\\\xB1\x{100}";
}
} else {
$b = "Bad. XS didn't escape dollar sign";
-############# 322
- $WANT = <<"EOT"; # Careful. This is '' string written inside '' here doc
+#############
+ $WANT = <<"EOT"; # Careful. This is '' string written inside "" here doc
#\$VAR1 = '\$b\"\@\\\\\xA3';
EOT
}
}
# XS used to produce "$b\"' which is 4 chars, not 3. [ie wrongly qq(\$b\\\")]
-############# 328
+#############
$WANT = <<'EOT';
#$VAR1 = '$b"';
EOT
# XS used to produce 'D'oh!' which is well, D'oh!
# Andreas found this one, which in turn discovered the previous two.
-############# 334
+#############
$WANT = <<'EOT';
#$VAR1 = 'D\'oh!';
EOT
%ping = (chr (0xDECAF) x 4 =>\$ping);
for $Data::Dumper::Sortkeys (0, 1) {
if($] >= 5.007) {
- TEST q(Data::Dumper->Dump([\\*ping, \\%ping], ['*ping', '*pong']));
- TEST q(Data::Dumper->Dumpxs([\\*ping, \\%ping], ['*ping', '*pong'])) if $XS;
+ TEST (q(Data::Dumper->Dump([\\*ping, \\%ping], ['*ping', '*pong'])),
+ "utf8: Purity 1: Sortkeys: Dump()");
+ TEST (q(Data::Dumper->Dumpxs([\\*ping, \\%ping], ['*ping', '*pong'])),
+ "utf8: Purity 1: Sortkeys: Dumpxs()")
+ if $XS;
} else {
SKIP_TEST "Incomplete support for UTF-8 in old perls";
SKIP_TEST "Incomplete support for UTF-8 in old perls";
TEST q(Data::Dumper->Dumpxs([\\%foo])),
"XS quotekeys == 0 for utf8 flagged ASCII" if $XS;
}
-############# 358
+#############
{
$WANT = <<'EOT';
#$VAR1 = [
EOT
@foo = ();
$foo[2] = 1;
- TEST q(Data::Dumper->Dump([\@foo])), 'Richard Clamp, Message-Id: <20030104005247.GA27685@mirth.demon.co.uk>';
- TEST q(Data::Dumper->Dumpxs([\@foo])) if $XS;
+ TEST q(Data::Dumper->Dump([\@foo])), 'Richard Clamp, Message-Id: <20030104005247.GA27685@mirth.demon.co.uk>: Dump()';
+ TEST q(Data::Dumper->Dumpxs([\@foo])), 'Richard Clamp, Message-Id: <20030104005247.GA27685@mirth.demon.co.uk>: Dumpxs()'if $XS;
}
-############# 364
+#############
# Make sure $obj->Dumpxs returns the right thing in list context. This was
# broken by the initial attempt to fix [perl #74170].
$WANT = <<'EOT';
'$obj->Dumpxs in list context'
if $XS;
-############# 366
+#############
{
- $WANT = <<'EOT';
-#$VAR1 = [
-# "\0\1\2\3\4\5\6\a\b\t\n\13\f\r\16\17\20\21\22\23\24\25\26\27\30\31\32\e\34\35\36\37 !\"#\$%&'()*+,-./0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\177\200\201\202\203\204\205\206\207\210\211\212\213\214\215\216\217\220\221\222\223\224\225\226\227\230\231\232\233\234\235\236\237\240\241\242\243\244\245\246\247\250\251\252\253\254\255\256\257\260\261\262\263\264\265\266\267\270\271\272\273\274\275\276\277\300\301\302\303\304\305\306\307\310\311\312\313\314\315\316\317\320\321\322\323\324\325\326\327\330\331\332\333\334\335\336\337\340\341\342\343\344\345\346\347\350\351\352\353\354\355\356\357\360\361\362\363\364\365\366\367\370\371\372\373\374\375\376\377"
+ $WANT = '\0\1\2\3\4\5\6\a\b\t\n\13\f\r\16\17\20\21\22\23\24\25\26\27\30\31\32\e\34\35\36\37 !\"#\$%&\'()*+,-./0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\177\200\201\202\203\204\205\206\207\210\211\212\213\214\215\216\217\220\221\222\223\224\225\226\227\230\231\232\233\234\235\236\237\240\241\242\243\244\245\246\247\250\251\252\253\254\255\256\257\260\261\262\263\264\265\266\267\270\271\272\273\274\275\276\277\300\301\302\303\304\305\306\307\310\311\312\313\314\315\316\317\320\321\322\323\324\325\326\327\330\331\332\333\334\335\336\337\340\341\342\343\344\345\346\347\350\351\352\353\354\355\356\357\360\361\362\363\364\365\366\367\370\371\372\373\374\375\376\377';
+ $WANT = convert_to_native($WANT);
+ $WANT = <<EOT;
+#\$VAR1 = [
+# "$WANT"
#];
EOT
$foo = [ join "", map chr, 0..255 ];
local $Data::Dumper::Useqq = 1;
- TEST q(Dumper($foo)), 'All latin1 characters';
- for (1..3) { print "not ok " . (++$TNUM) . " # TODO NYI\n" if $XS } # TEST q(Data::Dumper::DumperX($foo)) if $XS;
+ TEST (q(Dumper($foo)), 'All latin1 characters: Dumper');
+ TEST (q(Data::Dumper::DumperX($foo)), 'All latin1 characters: DumperX') if $XS;
}
-############# 372
+#############
{
- $WANT = <<'EOT';
-#$VAR1 = [
-# "\0\1\2\3\4\5\6\a\b\t\n\13\f\r\16\17\20\21\22\23\24\25\26\27\30\31\32\e\34\35\36\37 !\"#\$%&'()*+,-./0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\177\x{80}\x{81}\x{82}\x{83}\x{84}\x{85}\x{86}\x{87}\x{88}\x{89}\x{8a}\x{8b}\x{8c}\x{8d}\x{8e}\x{8f}\x{90}\x{91}\x{92}\x{93}\x{94}\x{95}\x{96}\x{97}\x{98}\x{99}\x{9a}\x{9b}\x{9c}\x{9d}\x{9e}\x{9f}\x{a0}\x{a1}\x{a2}\x{a3}\x{a4}\x{a5}\x{a6}\x{a7}\x{a8}\x{a9}\x{aa}\x{ab}\x{ac}\x{ad}\x{ae}\x{af}\x{b0}\x{b1}\x{b2}\x{b3}\x{b4}\x{b5}\x{b6}\x{b7}\x{b8}\x{b9}\x{ba}\x{bb}\x{bc}\x{bd}\x{be}\x{bf}\x{c0}\x{c1}\x{c2}\x{c3}\x{c4}\x{c5}\x{c6}\x{c7}\x{c8}\x{c9}\x{ca}\x{cb}\x{cc}\x{cd}\x{ce}\x{cf}\x{d0}\x{d1}\x{d2}\x{d3}\x{d4}\x{d5}\x{d6}\x{d7}\x{d8}\x{d9}\x{da}\x{db}\x{dc}\x{dd}\x{de}\x{df}\x{e0}\x{e1}\x{e2}\x{e3}\x{e4}\x{e5}\x{e6}\x{e7}\x{e8}\x{e9}\x{ea}\x{eb}\x{ec}\x{ed}\x{ee}\x{ef}\x{f0}\x{f1}\x{f2}\x{f3}\x{f4}\x{f5}\x{f6}\x{f7}\x{f8}\x{f9}\x{fa}\x{fb}\x{fc}\x{fd}\x{fe}\x{ff}\x{20ac}"
+ $WANT = '\0\1\2\3\4\5\6\a\b\t\n\13\f\r\16\17\20\21\22\23\24\25\26\27\30\31\32\e\34\35\36\37 !\"#\$%&\'()*+,-./0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\177\x{80}\x{81}\x{82}\x{83}\x{84}\x{85}\x{86}\x{87}\x{88}\x{89}\x{8a}\x{8b}\x{8c}\x{8d}\x{8e}\x{8f}\x{90}\x{91}\x{92}\x{93}\x{94}\x{95}\x{96}\x{97}\x{98}\x{99}\x{9a}\x{9b}\x{9c}\x{9d}\x{9e}\x{9f}\x{a0}\x{a1}\x{a2}\x{a3}\x{a4}\x{a5}\x{a6}\x{a7}\x{a8}\x{a9}\x{aa}\x{ab}\x{ac}\x{ad}\x{ae}\x{af}\x{b0}\x{b1}\x{b2}\x{b3}\x{b4}\x{b5}\x{b6}\x{b7}\x{b8}\x{b9}\x{ba}\x{bb}\x{bc}\x{bd}\x{be}\x{bf}\x{c0}\x{c1}\x{c2}\x{c3}\x{c4}\x{c5}\x{c6}\x{c7}\x{c8}\x{c9}\x{ca}\x{cb}\x{cc}\x{cd}\x{ce}\x{cf}\x{d0}\x{d1}\x{d2}\x{d3}\x{d4}\x{d5}\x{d6}\x{d7}\x{d8}\x{d9}\x{da}\x{db}\x{dc}\x{dd}\x{de}\x{df}\x{e0}\x{e1}\x{e2}\x{e3}\x{e4}\x{e5}\x{e6}\x{e7}\x{e8}\x{e9}\x{ea}\x{eb}\x{ec}\x{ed}\x{ee}\x{ef}\x{f0}\x{f1}\x{f2}\x{f3}\x{f4}\x{f5}\x{f6}\x{f7}\x{f8}\x{f9}\x{fa}\x{fb}\x{fc}\x{fd}\x{fe}\x{ff}\x{20ac}';
+ $WANT = convert_to_native($WANT);
+ $WANT = <<EOT;
+#\$VAR1 = [
+# "$WANT"
#];
EOT
$foo = [ join "", map chr, 0..255, 0x20ac ];
local $Data::Dumper::Useqq = 1;
- TEST q(Dumper($foo)), 'All latin1 characters with utf8 flag including a wide character';
- for (1..3) { print "not ok " . (++$TNUM) . " # TODO NYI\n" if $XS } # TEST q(Data::Dumper::DumperX($foo)) if $XS;
+ if ($] < 5.007) {
+ print "not ok " . (++$TNUM) . " # TODO - fails under 5.6\n" for 1..3;
+ }
+ else {
+ TEST q(Dumper($foo)),
+ 'All latin1 characters with utf8 flag including a wide character: Dumper';
+ }
+ TEST (q(Data::Dumper::DumperX($foo)),
+ 'All latin1 characters with utf8 flag including a wide character: DumperX')
+ if $XS;
}
-############# 378
+#############
{
# If XS cannot load, the pure-Perl version cannot deparse vstrings with
# underscores properly. In 5.8.0, vstrings are just strings.
- $WANT = $] > 5.0080001 ? $XS ? <<'EOT' : <<'EOV' : <<'EOU';
-#$a = \v65.66.67;
-#$b = \v65.66.067;
-#$c = \v65.66.6_7;
-#$d = \'ABC';
-EOT
-#$a = \v65.66.67;
-#$b = \v65.66.67;
-#$c = \v65.66.67;
-#$d = \'ABC';
-EOV
+ my $no_vstrings = <<'NOVSTRINGS';
#$a = \'ABC';
#$b = \'ABC';
#$c = \'ABC';
#$d = \'ABC';
-EOU
- @::_v = (\v65.66.67, \v65.66.067, \v65.66.6_7, \~v190.189.188);
- TEST q(Data::Dumper->Dump(\@::_v, [qw(a b c d)])), 'vstrings';
- TEST q(Data::Dumper->Dumpxs(\@::_v, [qw(a b c d)])), 'xs vstrings'
+NOVSTRINGS
+my $ABC_native = chr(65) . chr(66) . chr(67);
+ my $vstrings_corr = <<VSTRINGS_CORRECT;
+#\$a = \\v65.66.67;
+#\$b = \\v65.66.067;
+#\$c = \\v65.66.6_7;
+#\$d = \\'$ABC_native';
+VSTRINGS_CORRECT
+ $WANT = $] <= 5.0080001
+ ? $no_vstrings
+ : $vstrings_corr;
+
+ @::_v = (
+ \v65.66.67,
+ \($] < 5.007 ? v65.66.67 : eval 'v65.66.067'),
+ \v65.66.6_7,
+ \~v190.189.188
+ );
+ if ($] >= 5.010) {
+ TEST q(Data::Dumper->Dump(\@::_v, [qw(a b c d)])), 'vstrings';
+ TEST q(Data::Dumper->Dumpxs(\@::_v, [qw(a b c d)])), 'xs vstrings'
+ if $XS;
+ }
+ else { # Skip tests before 5.10. vstrings considered funny before
+ SKIP_TEST "vstrings considered funny before 5.10.0";
+ SKIP_TEST "vstrings considered funny before 5.10.0 (XS)"
+ if $XS;
+ }
+}
+
+#############
+{
+ # [perl #107372] blessed overloaded globs
+ $WANT = <<'EOW';
+#$VAR1 = bless( \*::finkle, 'overtest' );
+EOW
+ {
+ package overtest;
+ use overload fallback=>1, q\""\=>sub{"oaoaa"};
+ }
+ TEST q(Data::Dumper->Dump([bless \*finkle, "overtest"])),
+ 'blessed overloaded globs';
+ TEST q(Data::Dumper->Dumpxs([\*finkle])), 'blessed overloaded globs (xs)'
if $XS;
}
+#############
+{
+ # [perl #74798] uncovered behaviour
+ $WANT = <<'EOW';
+#$VAR1 = "\0000";
+EOW
+ local $Data::Dumper::Useqq = 1;
+ TEST q(Data::Dumper->Dump(["\x000"])),
+ "\\ octal followed by digit";
+ TEST q(Data::Dumper->Dumpxs(["\x000"])), '\\ octal followed by digit (xs)'
+ if $XS;
+
+ $WANT = <<'EOW';
+#$VAR1 = "\x{100}\0000";
+EOW
+ local $Data::Dumper::Useqq = 1;
+ TEST q(Data::Dumper->Dump(["\x{100}\x000"])),
+ "\\ octal followed by digit unicode";
+ TEST q(Data::Dumper->Dumpxs(["\x{100}\x000"])), '\\ octal followed by digit unicode (xs)'
+ if $XS;
+
+
+ $WANT = <<'EOW';
+#$VAR1 = "\0\x{660}";
+EOW
+ TEST q(Data::Dumper->Dump(["\\x00\\x{0660}"])),
+ "\\ octal followed by unicode digit";
+ TEST q(Data::Dumper->Dumpxs(["\\x00\\x{0660}"])), '\\ octal followed by unicode digit (xs)'
+ if $XS;
+
+ # [perl #118933 - handling of digits
+$WANT = <<'EOW';
+#$VAR1 = 0;
+#$VAR2 = 1;
+#$VAR3 = 90;
+#$VAR4 = -10;
+#$VAR5 = "010";
+#$VAR6 = 112345678;
+#$VAR7 = "1234567890";
+EOW
+ TEST q(Data::Dumper->Dump([0, 1, 90, -10, "010", "112345678", "1234567890" ])),
+ "numbers and number-like scalars";
+
+ TEST q(Data::Dumper->Dumpxs([0, 1, 90, -10, "010", "112345678", "1234567890" ])),
+ "numbers and number-like scalars"
+ if $XS;
+}
+#############
+{
+ # [perl #82948]
+ # re::regexp_pattern was moved to universal.c in v5.10.0-252-g192c1e2
+ # and apparently backported to maint-5.10
+ $WANT = $] > 5.010 ? <<'NEW' : <<'OLD';
+#$VAR1 = qr/abc/;
+#$VAR2 = qr/abc/i;
+NEW
+#$VAR1 = qr/(?-xism:abc)/;
+#$VAR2 = qr/(?i-xsm:abc)/;
+OLD
+ TEST q(Data::Dumper->Dump([ qr/abc/, qr/abc/i ])), "qr//";
+ TEST q(Data::Dumper->Dumpxs([ qr/abc/, qr/abc/i ])), "qr// xs"
+ if $XS;
+}
+#############
+
+{
+ sub foo {}
+ $WANT = <<'EOW';
+#*a = sub { "DUMMY" };
+#$b = \&a;
+EOW
+
+ TEST q(Data::Dumper->new([ \&foo, \\&foo ], [ "*a", "b" ])->Dump), "name of code in *foo";
+ TEST q(Data::Dumper->new([ \&foo, \\&foo ], [ "*a", "b" ])->Dumpxs), "name of code in *foo xs"
+ if $XS;
+}
+#############
+
+{
+ if($] lt 5.007_003) {
+ SKIP_TEST "Test is only problematic for EBCDIC, which only works for >= 5.8";
+ SKIP_TEST "Test is only problematic for EBCDIC, which only works for >= 5.8";
+ }
+ else {
+ # There is special code to handle the single control that in EBCDIC is
+ # not in the block with all the other controls, when it is UTF-8 and
+ # there are no variants in it (All controls in EBCDIC are invariant.)
+ # This tests that. There is no harm in testing this works on ASCII,
+ # and is better to not have split code paths.
+ my $outlier = chr utf8::unicode_to_native(0x9F);
+ my $outlier_hex = sprintf "%x", ord $outlier;
+ $WANT = <<EOT;
+#\$VAR1 = \"\\x{$outlier_hex}\";
+EOT
+ $foo = "$outlier\x{100}";
+ chop $foo;
+ local $Data::Dumper::Useqq = 1;
+ TEST (q(Dumper($foo)), 'EBCDIC outlier control');
+ TEST (q(Data::Dumper::DumperX($foo)), 'EBCDIC outlier control: DumperX') if $XS;
+ }
+}
+############# [perl #124091]
+{
+ $WANT = <<'EOT';
+#$VAR1 = "\n";
+EOT
+ local $Data::Dumper::Useqq = 1;
+ TEST (qq(Dumper("\n")), '\n alone');
+ TEST (qq(Data::Dumper::DumperX("\n")), '\n alone') if $XS;
+}
https://perl5.git.perl.org / perl5.git / blobdiff