From 74cfb115ac810480c0000dc742b20383c1578bac Mon Sep 17 00:00:00 2001 From: "Todd C. Miller" Date: Sun, 27 Oct 2002 22:15:15 +0000 Subject: stock perl 5.8.0 from CPAN --- gnu/usr.bin/perl/ext/Data/Dumper/t/dumper.t | 1355 +++++++++++++++++++++++++ gnu/usr.bin/perl/ext/Data/Dumper/t/overload.t | 35 + 2 files changed, 1390 insertions(+) create mode 100644 gnu/usr.bin/perl/ext/Data/Dumper/t/dumper.t create mode 100644 gnu/usr.bin/perl/ext/Data/Dumper/t/overload.t (limited to 'gnu/usr.bin/perl/ext/Data') diff --git a/gnu/usr.bin/perl/ext/Data/Dumper/t/dumper.t b/gnu/usr.bin/perl/ext/Data/Dumper/t/dumper.t new file mode 100644 index 00000000000..9c7f0a68705 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Data/Dumper/t/dumper.t @@ -0,0 +1,1355 @@ +#!./perl -w +# +# testsuite for Data::Dumper +# + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { + print "1..0 # Skip: Data::Dumper was not built\n"; + exit 0; + } +} + +use Data::Dumper; +use Config; +my $Is_ebcdic = defined($Config{'ebcdic'}) && $Config{'ebcdic'} eq 'define'; + +$Data::Dumper::Pad = "#"; +my $TMAX; +my $XS; +my $TNUM = 0; +my $WANT = ''; + +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; + } + $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"); + + ++$TNUM; + eval "$t"; + print $@ ? "not ok $TNUM\n# \$@ says: $@\n" : "ok $TNUM\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"); +} + +# 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 = 357; $XS = 1; +} +else { + print "### XS extensions not loaded, will NOT run XS tests\n"; + $TMAX = 180; $XS = 0; +} + +print "1..$TMAX\n"; + +#XXXif (0) { +############# +############# + +@c = ('c'); +$c = \@c; +$b = {}; +$a = [1, $b, $c]; +$b->{a} = $a; +$b->{b} = $a->[1]; +$b->{c} = $a->[2]; + +############# 1 +## +$WANT = <<'EOT'; +#$a = [ +# 1, +# { +# 'c' => [ +# 'c' +# ], +# 'a' => $a, +# 'b' => $a->[1] +# }, +# $a->[1]{'c'} +# ]; +#$b = $a->[1]; +#$c = $a->[1]{'c'}; +EOT + +TEST q(Data::Dumper->Dump([$a,$b,$c], [qw(a b c)])); +TEST q(Data::Dumper->Dumpxs([$a,$b,$c], [qw(a b c)])) if $XS; + + +############# 7 +## +$WANT = <<'EOT'; +#@a = ( +# 1, +# { +# 'c' => [ +# 'c' +# ], +# 'a' => [], +# 'b' => {} +# }, +# [] +# ); +#$a[1]{'a'} = \@a; +#$a[1]{'b'} = $a[1]; +#$a[2] = $a[1]{'c'}; +#$b = $a[1]; +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; + +############# 13 +## +$WANT = <<'EOT'; +#%b = ( +# 'c' => [ +# 'c' +# ], +# 'a' => [ +# 1, +# {}, +# [] +# ], +# 'b' => {} +# ); +#$b{'a'}[1] = \%b; +#$b{'a'}[2] = $b{'c'}; +#$b{'b'} = \%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; + +############# 19 +## +$WANT = <<'EOT'; +#$a = [ +# 1, +# { +# 'c' => [], +# 'a' => [], +# 'b' => {} +# }, +# [] +#]; +#$a->[1]{'c'} = \@c; +#$a->[1]{'a'} = $a; +#$a->[1]{'b'} = $a->[1]; +#$a->[2] = \@c; +#$b = $a->[1]; +EOT + +$Data::Dumper::Indent = 1; +TEST q( + $d = Data::Dumper->new([$a,$b], [qw(a b)]); + $d->Seen({'*c' => $c}); + $d->Dump; + ); +if ($XS) { + TEST q( + $d = Data::Dumper->new([$a,$b], [qw(a b)]); + $d->Seen({'*c' => $c}); + $d->Dumpxs; + ); +} + + +############# 25 +## +$WANT = <<'EOT'; +#$a = [ +# #0 +# 1, +# #1 +# { +# c => [ +# #0 +# 'c' +# ], +# a => $a, +# b => $a->[1] +# }, +# #2 +# $a->[1]{c} +# ]; +#$b = $a->[1]; +EOT + +$d->Indent(3); +$d->Purity(0)->Quotekeys(0); +TEST q( $d->Reset; $d->Dump ); + +TEST q( $d->Reset; $d->Dumpxs ) if $XS; + +############# 31 +## +$WANT = <<'EOT'; +#$VAR1 = [ +# 1, +# { +# 'c' => [ +# 'c' +# ], +# 'a' => [], +# 'b' => {} +# }, +# [] +#]; +#$VAR1->[1]{'a'} = $VAR1; +#$VAR1->[1]{'b'} = $VAR1->[1]; +#$VAR1->[2] = $VAR1->[1]{'c'}; +EOT + +TEST q(Dumper($a)); +TEST q(Data::Dumper::DumperX($a)) if $XS; + +############# 37 +## +$WANT = <<'EOT'; +#[ +# 1, +# { +# c => [ +# 'c' +# ], +# a => $VAR1, +# b => $VAR1->[1] +# }, +# $VAR1->[1]{c} +#] +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; +} + + +############# 43 +## +$WANT = <<'EOT'; +#$VAR1 = { +# "reftest" => \\1, +# "abc\0'\efg" => "mno\0" +#}; +EOT + +$foo = { "abc\000\'\efg" => "mno\000", + "reftest" => \\1, + }; +{ + local $Data::Dumper::Useqq = 1; + TEST q(Dumper($foo)); +} + + $WANT = <<"EOT"; +#\$VAR1 = { +# 'reftest' => \\\\1, +# 'abc\0\\'\efg' => 'mno\0' +#}; +EOT + + { + local $Data::Dumper::Useqq = 1; + TEST q(Data::Dumper::DumperX($foo)) if $XS; # cheat + } + + + +############# +############# + +{ + package main; + use Data::Dumper; + $foo = 5; + @foo = (-10,\*foo); + %foo = (a=>1,b=>\$foo,c=>\@foo); + $foo{d} = \%foo; + $foo[2] = \%foo; + +############# 49 +## + $WANT = <<'EOT'; +#$foo = \*::foo; +#*::foo = \5; +#*::foo = [ +# #0 +# -10, +# #1 +# do{my $o}, +# #2 +# { +# 'c' => [], +# 'a' => 1, +# 'b' => do{my $o}, +# 'd' => {} +# } +# ]; +#*::foo{ARRAY}->[1] = $foo; +#*::foo{ARRAY}->[2]{'c'} = *::foo{ARRAY}; +#*::foo{ARRAY}->[2]{'b'} = *::foo{SCALAR}; +#*::foo{ARRAY}->[2]{'d'} = *::foo{ARRAY}->[2]; +#*::foo = *::foo{ARRAY}->[2]; +#@bar = @{*::foo{ARRAY}}; +#%baz = %{*::foo{ARRAY}->[2]}; +EOT + + $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; + +############# 55 +## + $WANT = <<'EOT'; +#$foo = \*::foo; +#*::foo = \5; +#*::foo = [ +# -10, +# do{my $o}, +# { +# 'c' => [], +# 'a' => 1, +# 'b' => do{my $o}, +# 'd' => {} +# } +#]; +#*::foo{ARRAY}->[1] = $foo; +#*::foo{ARRAY}->[2]{'c'} = *::foo{ARRAY}; +#*::foo{ARRAY}->[2]{'b'} = *::foo{SCALAR}; +#*::foo{ARRAY}->[2]{'d'} = *::foo{ARRAY}->[2]; +#*::foo = *::foo{ARRAY}->[2]; +#$bar = *::foo{ARRAY}; +#$baz = *::foo{ARRAY}->[2]; +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; + +############# 61 +## + $WANT = <<'EOT'; +#@bar = ( +# -10, +# \*::foo, +# {} +#); +#*::foo = \5; +#*::foo = \@bar; +#*::foo = { +# 'c' => [], +# 'a' => 1, +# 'b' => do{my $o}, +# 'd' => {} +#}; +#*::foo{HASH}->{'c'} = \@bar; +#*::foo{HASH}->{'b'} = *::foo{SCALAR}; +#*::foo{HASH}->{'d'} = *::foo{HASH}; +#$bar[2] = *::foo{HASH}; +#%baz = %{*::foo{HASH}}; +#$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; + +############# 67 +## + $WANT = <<'EOT'; +#$bar = [ +# -10, +# \*::foo, +# {} +#]; +#*::foo = \5; +#*::foo = $bar; +#*::foo = { +# 'c' => [], +# 'a' => 1, +# 'b' => do{my $o}, +# 'd' => {} +#}; +#*::foo{HASH}->{'c'} = $bar; +#*::foo{HASH}->{'b'} = *::foo{SCALAR}; +#*::foo{HASH}->{'d'} = *::foo{HASH}; +#$bar->[2] = *::foo{HASH}; +#$baz = *::foo{HASH}; +#$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; + +############# 73 +## + $WANT = <<'EOT'; +#$foo = \*::foo; +#@bar = ( +# -10, +# $foo, +# { +# c => \@bar, +# a => 1, +# b => \5, +# d => $bar[2] +# } +#); +#%baz = %{$bar[2]}; +EOT + + $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; + +############# 79 +## + $WANT = <<'EOT'; +#$foo = \*::foo; +#$bar = [ +# -10, +# $foo, +# { +# c => $bar, +# a => 1, +# b => \5, +# d => $bar->[2] +# } +#]; +#$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; + +} + +############# +############# +{ + package main; + @dogs = ( 'Fido', 'Wags' ); + %kennel = ( + First => \$dogs[0], + Second => \$dogs[1], + ); + $dogs[2] = \%kennel; + $mutts = \%kennel; + $mutts = $mutts; # avoid warning + +############# 85 +## + $WANT = <<'EOT'; +#%kennels = ( +# Second => \'Wags', +# First => \'Fido' +#); +#@dogs = ( +# ${$kennels{First}}, +# ${$kennels{Second}}, +# \%kennels +#); +#%mutts = %kennels; +EOT + + TEST q( + $d = Data::Dumper->new([\\%kennel, \\@dogs, $mutts], + [qw(*kennels *dogs *mutts)] ); + $d->Dump; + ); + if ($XS) { + TEST q( + $d = Data::Dumper->new([\\%kennel, \\@dogs, $mutts], + [qw(*kennels *dogs *mutts)] ); + $d->Dumpxs; + ); + } + +############# 91 +## + $WANT = <<'EOT'; +#%kennels = %kennels; +#@dogs = @dogs; +#%mutts = %kennels; +EOT + + TEST q($d->Dump); + TEST q($d->Dumpxs) if $XS; + +############# 97 +## + $WANT = <<'EOT'; +#%kennels = ( +# Second => \'Wags', +# First => \'Fido' +#); +#@dogs = ( +# ${$kennels{First}}, +# ${$kennels{Second}}, +# \%kennels +#); +#%mutts = %kennels; +EOT + + + TEST q($d->Reset; $d->Dump); + if ($XS) { + TEST q($d->Reset; $d->Dumpxs); + } + +############# 103 +## + $WANT = <<'EOT'; +#@dogs = ( +# 'Fido', +# 'Wags', +# { +# Second => \$dogs[1], +# First => \$dogs[0] +# } +#); +#%kennels = %{$dogs[2]}; +#%mutts = %{$dogs[2]}; +EOT + + TEST q( + $d = Data::Dumper->new([\\@dogs, \\%kennel, $mutts], + [qw(*dogs *kennels *mutts)] ); + $d->Dump; + ); + if ($XS) { + TEST q( + $d = Data::Dumper->new([\\@dogs, \\%kennel, $mutts], + [qw(*dogs *kennels *mutts)] ); + $d->Dumpxs; + ); + } + +############# 109 +## + TEST q($d->Reset->Dump); + if ($XS) { + TEST q($d->Reset->Dumpxs); + } + +############# 115 +## + $WANT = <<'EOT'; +#@dogs = ( +# 'Fido', +# 'Wags', +# { +# Second => \'Wags', +# First => \'Fido' +# } +#); +#%kennels = ( +# Second => \'Wags', +# First => \'Fido' +#); +EOT + + TEST q( + $d = Data::Dumper->new( [\@dogs, \%kennel], [qw(*dogs *kennels)] ); + $d->Deepcopy(1)->Dump; + ); + if ($XS) { + TEST q($d->Reset->Dumpxs); + } + +} + +{ + +sub z { print "foo\n" } +$c = [ \&z ]; + +############# 121 +## + $WANT = <<'EOT'; +#$a = $b; +#$c = [ +# $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;) + if $XS; + +############# 127 +## + $WANT = <<'EOT'; +#$a = \&b; +#$c = [ +# \&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;) + if $XS; + +############# 133 +## + $WANT = <<'EOT'; +#*a = \&b; +#@c = ( +# \&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;) + if $XS; + +} + +{ + $a = []; + $a->[1] = \$a->[0]; + +############# 139 +## + $WANT = <<'EOT'; +#@a = ( +# undef, +# do{my $o} +#); +#$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;) + 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;) + if $XS; +} + +{ + $a = [{ a => \$b }, { b => undef }]; + $b = [{ c => \$b }, { d => \$a }]; + +############# 151 +## + $WANT = <<'EOT'; +#$a = [ +# { +# a => \[ +# { +# c => do{my $o} +# }, +# { +# d => \[] +# } +# ] +# }, +# { +# b => undef +# } +#]; +#${$a->[0]{a}}->[0]->{c} = $a->[0]{a}; +#${${$a->[0]{a}}->[1]->{d}} = $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;) + if $XS; +} + +{ + $a = [[[[\\\\\'foo']]]]; + $b = $a->[0][0]; + $c = $${$b->[0][0]}; + +############# 157 +## + $WANT = <<'EOT'; +#$a = [ +# [ +# [ +# [ +# \\\\\'foo' +# ] +# ] +# ] +#]; +#$b = $a->[0][0]; +#$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;) + if $XS; +} + +{ + $f = "pearl"; + $e = [ $f ]; + $d = { 'e' => $e }; + $c = [ $d ]; + $b = { 'c' => $c }; + $a = { 'b' => $b }; + +############# 163 +## + $WANT = <<'EOT'; +#$a = { +# b => { +# c => [ +# { +# e => 'ARRAY(0xdeadbeef)' +# } +# ] +# } +#}; +#$b = $a->{b}; +#$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;) + if $XS; + +############# 169 +## + $WANT = <<'EOT'; +#$a = { +# b => 'HASH(0xdeadbeef)' +#}; +#$b = $a->{b}; +#$c = [ +# 'HASH(0xdeadbeef)' +#]; +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;) + if $XS; +} + +{ + $a = \$a; + $b = [$a]; + +############# 175 +## + $WANT = <<'EOT'; +#$b = [ +# \$b->[0] +#]; +EOT + +TEST q(Data::Dumper->new([$b],['b'])->Purity(0)->Dump;); +TEST q(Data::Dumper->new([$b],['b'])->Purity(0)->Dumpxs;) + if $XS; + +############# 181 +## + $WANT = <<'EOT'; +#$b = [ +# \do{my $o} +#]; +#${$b->[0]} = $b->[0]; +EOT + + +TEST q(Data::Dumper->new([$b],['b'])->Purity(1)->Dump;); +TEST q(Data::Dumper->new([$b],['b'])->Purity(1)->Dumpxs;) + if $XS; +} + +{ + $a = "\x{09c10}"; +############# 187 +## XS code was adding an extra \0 + $WANT = <<'EOT'; +#$a = "\x{9c10}"; +EOT + + TEST q(Data::Dumper->Dump([$a], ['a'])), "\\x{9c10}"; + TEST q(Data::Dumper->Dumpxs([$a], ['a'])), "XS \\x{9c10}" + if $XS; + +} + +{ + $i = 0; + $a = { map { ("$_$_$_", ++$i) } 'I'..'Q' }; + local $Data::Dumper::Sortkeys = 1; + +############# 193 +## + $WANT = <<'EOT'; +#$VAR1 = { +# III => 1, +# JJJ => 2, +# KKK => 3, +# LLL => 4, +# MMM => 5, +# NNN => 6, +# OOO => 7, +# PPP => 8, +# QQQ => 9 +#}; +EOT + +TEST q(Data::Dumper->new([$a])->Dump;); +TEST q(Data::Dumper->new([$a])->Dumpxs;) + if $XS; +} + +{ + $i = 5; + $c = { map { (++$i, "$_$_$_") } 'I'..'Q' }; + local $Data::Dumper::Sortkeys = \&sort199; + sub sort199 { + my $hash = shift; + return [ sort { $b <=> $a } keys %$hash ]; + } + +############# 199 +## + $WANT = <<'EOT'; +#$VAR1 = { +# 14 => 'QQQ', +# 13 => 'PPP', +# 12 => 'OOO', +# 11 => 'NNN', +# 10 => 'MMM', +# 9 => 'LLL', +# 8 => 'KKK', +# 7 => 'JJJ', +# 6 => 'III' +#}; +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;) + if $XS; +} + +{ + $i = 5; + $c = { map { (++$i, "$_$_$_") } 'I'..'Q' }; + $d = { reverse %$c }; + local $Data::Dumper::Sortkeys = \&sort205; + sub sort205 { + my $hash = shift; + return [ + $hash eq $c ? (sort { $a <=> $b } keys %$hash) + : (reverse sort keys %$hash) + ]; + } + +############# 205 +## + $WANT = <<'EOT'; +#$VAR1 = [ +# { +# 6 => 'III', +# 7 => 'JJJ', +# 8 => 'KKK', +# 9 => 'LLL', +# 10 => 'MMM', +# 11 => 'NNN', +# 12 => 'OOO', +# 13 => 'PPP', +# 14 => 'QQQ' +# }, +# { +# QQQ => 14, +# PPP => 13, +# OOO => 12, +# NNN => 11, +# MMM => 10, +# LLL => 9, +# KKK => 8, +# JJJ => 7, +# III => 6 +# } +#]; +EOT + +TEST q(Data::Dumper->new([[$c, $d]])->Dump;); +$WANT =~ s/ (\d+)/ '$1'/gs; +TEST q(Data::Dumper->new([[$c, $d]])->Dumpxs;) + if $XS; +} + +{ + local $Data::Dumper::Deparse = 1; + local $Data::Dumper::Indent = 2; + +############# 211 +## + $WANT = <<'EOT'; +#$VAR1 = { +# foo => sub { +# print 'foo'; +# } +# }; +EOT + + TEST q(Data::Dumper->new([{ foo => sub { print "foo"; } }])->Dump); +} + +############# 214 +## + +# This is messy. +# The controls (bare numbers) are stored either as integers or floating point. +# [depending on whether the tokeniser sees things like ".". +# The peephole optimiser only runs for constant folding, not single constants, +# so I already have some NVs, some IVs +# The string versions are not. They are all PV + +# This is arguably all far too chummy with the implementation, but I really +# want to ensure that we don't go wrong when flags on scalars get as side +# effects of reading them. + +# These tests are actually testing the precise output of the current +# implementation, so will most likely fail if the implementation changes, +# even if the new implementation produces different but correct results. +# It would be nice to test for wrong answers, but I can't see how to do that, +# so instead I'm checking for unexpected answers. (ie -2 becoming "-2" is not +# wrong, but I can't see an easy, reliable way to code that knowledge) + +# Numbers (seen by the tokeniser as numbers, stored as numbers. + @numbers = + ( + 0, +1, -2, 3.0, +4.0, -5.0, 6.5, +7.5, -8.5, + 9, +10, -11, 12.0, +13.0, -14.0, 15.5, +16.25, -17.75, + ); +# Strings + @strings = + ( + "0", "+1", "-2", "3.0", "+4.0", "-5.0", "6.5", "+7.5", "-8.5", " 9", + " +10", " -11", " 12.0", " +13.0", " -14.0", " 15.5", " +16.25", " -17.75", + ); + +# The perl code always does things the same way for numbers. + $WANT_PL_N = <<'EOT'; +#$VAR1 = 0; +#$VAR2 = 1; +#$VAR3 = -2; +#$VAR4 = 3; +#$VAR5 = 4; +#$VAR6 = -5; +#$VAR7 = '6.5'; +#$VAR8 = '7.5'; +#$VAR9 = '-8.5'; +#$VAR10 = 9; +#$VAR11 = 10; +#$VAR12 = -11; +#$VAR13 = 12; +#$VAR14 = 13; +#$VAR15 = -14; +#$VAR16 = '15.5'; +#$VAR17 = '16.25'; +#$VAR18 = '-17.75'; +EOT +# The perl code knows that 0 and -2 stringify exactly back to the strings, +# so it dumps them as numbers, not strings. + $WANT_PL_S = <<'EOT'; +#$VAR1 = 0; +#$VAR2 = '+1'; +#$VAR3 = -2; +#$VAR4 = '3.0'; +#$VAR5 = '+4.0'; +#$VAR6 = '-5.0'; +#$VAR7 = '6.5'; +#$VAR8 = '+7.5'; +#$VAR9 = '-8.5'; +#$VAR10 = ' 9'; +#$VAR11 = ' +10'; +#$VAR12 = ' -11'; +#$VAR13 = ' 12.0'; +#$VAR14 = ' +13.0'; +#$VAR15 = ' -14.0'; +#$VAR16 = ' 15.5'; +#$VAR17 = ' +16.25'; +#$VAR18 = ' -17.75'; +EOT + +# The XS code differs. +# These are the numbers as seen by the tokeniser. Constants aren't folded +# (which makes IVs where possible) so values the tokeniser thought were +# floating point are stored as NVs. The XS code outputs these as strings, +# but as it has converted them from NVs, leading + signs will not be there. + $WANT_XS_N = <<'EOT'; +#$VAR1 = 0; +#$VAR2 = 1; +#$VAR3 = -2; +#$VAR4 = '3'; +#$VAR5 = '4'; +#$VAR6 = '-5'; +#$VAR7 = '6.5'; +#$VAR8 = '7.5'; +#$VAR9 = '-8.5'; +#$VAR10 = 9; +#$VAR11 = 10; +#$VAR12 = -11; +#$VAR13 = '12'; +#$VAR14 = '13'; +#$VAR15 = '-14'; +#$VAR16 = '15.5'; +#$VAR17 = '16.25'; +#$VAR18 = '-17.75'; +EOT + +# These are the strings as seen by the tokeniser. The XS code will output +# these for all cases except where the scalar has been used in integer context + $WANT_XS_S = <<'EOT'; +#$VAR1 = '0'; +#$VAR2 = '+1'; +#$VAR3 = '-2'; +#$VAR4 = '3.0'; +#$VAR5 = '+4.0'; +#$VAR6 = '-5.0'; +#$VAR7 = '6.5'; +#$VAR8 = '+7.5'; +#$VAR9 = '-8.5'; +#$VAR10 = ' 9'; +#$VAR11 = ' +10'; +#$VAR12 = ' -11'; +#$VAR13 = ' 12.0'; +#$VAR14 = ' +13.0'; +#$VAR15 = ' -14.0'; +#$VAR16 = ' 15.5'; +#$VAR17 = ' +16.25'; +#$VAR18 = ' -17.75'; +EOT + +# These are the numbers as IV-ized by & +# These will differ from WANT_XS_N because now IV flags will be set on all +# values that were actually integer, and the XS code will then output these +# as numbers not strings. + $WANT_XS_I = <<'EOT'; +#$VAR1 = 0; +#$VAR2 = 1; +#$VAR3 = -2; +#$VAR4 = 3; +#$VAR5 = 4; +#$VAR6 = -5; +#$VAR7 = '6.5'; +#$VAR8 = '7.5'; +#$VAR9 = '-8.5'; +#$VAR10 = 9; +#$VAR11 = 10; +#$VAR12 = -11; +#$VAR13 = 12; +#$VAR14 = 13; +#$VAR15 = -14; +#$VAR16 = '15.5'; +#$VAR17 = '16.25'; +#$VAR18 = '-17.75'; +EOT + +# Some of these tests will be redundant. +@numbers_s = @numbers_i = @numbers_is = @numbers_n = @numbers_ns = @numbers_ni + = @numbers_nis = @numbers; +@strings_s = @strings_i = @strings_is = @strings_n = @strings_ns = @strings_ni + = @strings_nis = @strings; +# Use them in an integer context +foreach (@numbers_i, @numbers_ni, @numbers_nis, @numbers_is, + @strings_i, @strings_ni, @strings_nis, @strings_is) { + my $b = sprintf "%d", $_; +} +# Use them in a floating point context +foreach (@numbers_n, @numbers_ni, @numbers_nis, @numbers_ns, + @strings_n, @strings_ni, @strings_nis, @strings_ns) { + my $b = sprintf "%e", $_; +} +# Use them in a string context +foreach (@numbers_s, @numbers_is, @numbers_nis, @numbers_ns, + @strings_s, @strings_is, @strings_nis, @strings_ns) { + my $b = sprintf "%s", $_; +} + +# use Devel::Peek; Dump ($_) foreach @vanilla_c; + +$WANT=$WANT_PL_N; +TEST q(Data::Dumper->new(\@numbers)->Dump), 'Numbers'; +TEST q(Data::Dumper->new(\@numbers_s)->Dump), 'Numbers PV'; +TEST q(Data::Dumper->new(\@numbers_i)->Dump), 'Numbers IV'; +TEST q(Data::Dumper->new(\@numbers_is)->Dump), 'Numbers IV,PV'; +TEST q(Data::Dumper->new(\@numbers_n)->Dump), 'Numbers NV'; +TEST q(Data::Dumper->new(\@numbers_ns)->Dump), 'Numbers NV,PV'; +TEST q(Data::Dumper->new(\@numbers_ni)->Dump), 'Numbers NV,IV'; +TEST q(Data::Dumper->new(\@numbers_nis)->Dump), 'Numbers NV,IV,PV'; +$WANT=$WANT_PL_S; +TEST q(Data::Dumper->new(\@strings)->Dump), 'Strings'; +TEST q(Data::Dumper->new(\@strings_s)->Dump), 'Strings PV'; +TEST q(Data::Dumper->new(\@strings_i)->Dump), 'Strings IV'; +TEST q(Data::Dumper->new(\@strings_is)->Dump), 'Strings IV,PV'; +TEST q(Data::Dumper->new(\@strings_n)->Dump), 'Strings NV'; +TEST q(Data::Dumper->new(\@strings_ns)->Dump), 'Strings NV,PV'; +TEST q(Data::Dumper->new(\@strings_ni)->Dump), 'Strings NV,IV'; +TEST q(Data::Dumper->new(\@strings_nis)->Dump), 'Strings NV,IV,PV'; +if ($XS) { + $WANT=$WANT_XS_N; + TEST q(Data::Dumper->new(\@numbers)->Dumpxs), 'XS Numbers'; + TEST q(Data::Dumper->new(\@numbers_s)->Dumpxs), 'XS Numbers PV'; + $WANT=$WANT_XS_I; + TEST q(Data::Dumper->new(\@numbers_i)->Dumpxs), 'XS Numbers IV'; + TEST q(Data::Dumper->new(\@numbers_is)->Dumpxs), 'XS Numbers IV,PV'; + $WANT=$WANT_XS_N; + TEST q(Data::Dumper->new(\@numbers_n)->Dumpxs), 'XS Numbers NV'; + TEST q(Data::Dumper->new(\@numbers_ns)->Dumpxs), 'XS Numbers NV,PV'; + $WANT=$WANT_XS_I; + TEST q(Data::Dumper->new(\@numbers_ni)->Dumpxs), 'XS Numbers NV,IV'; + TEST q(Data::Dumper->new(\@numbers_nis)->Dumpxs), 'XS Numbers NV,IV,PV'; + + $WANT=$WANT_XS_S; + TEST q(Data::Dumper->new(\@strings)->Dumpxs), 'XS Strings'; + TEST q(Data::Dumper->new(\@strings_s)->Dumpxs), 'XS Strings PV'; + # This one used to really mess up. New code actually emulates the .pm code + $WANT=$WANT_PL_S; + TEST q(Data::Dumper->new(\@strings_i)->Dumpxs), 'XS Strings IV'; + TEST q(Data::Dumper->new(\@strings_is)->Dumpxs), 'XS Strings IV,PV'; + $WANT=$WANT_XS_S; + TEST q(Data::Dumper->new(\@strings_n)->Dumpxs), 'XS Strings NV'; + TEST q(Data::Dumper->new(\@strings_ns)->Dumpxs), 'XS Strings NV,PV'; + # This one used to really mess up. New code actually emulates the .pm code + $WANT=$WANT_PL_S; + TEST q(Data::Dumper->new(\@strings_ni)->Dumpxs), 'XS Strings NV,IV'; + TEST q(Data::Dumper->new(\@strings_nis)->Dumpxs), 'XS Strings NV,IV,PV'; +} + +{ + $a = "1\n"; +############# 310 +## Perl code was using /...$/ and hence missing the \n. + $WANT = <<'EOT'; +my $VAR1 = '42 +'; +EOT + + # Can't pad with # as the output has an embedded newline. + local $Data::Dumper::Pad = "my "; + TEST q(Data::Dumper->Dump(["42\n"])), "number with trailing newline"; + TEST q(Data::Dumper->Dumpxs(["42\n"])), "XS number with trailing newline" + if $XS; +} + +{ + @a = ( + 999999999, + 1000000000, + 9999999999, + 10000000000, + -999999999, + -1000000000, + -9999999999, + -10000000000, + 4294967295, + 4294967296, + -2147483648, + -2147483649, + ); +############# 316 +## Perl code flips over at 10 digits. + $WANT = <<'EOT'; +#$VAR1 = 999999999; +#$VAR2 = '1000000000'; +#$VAR3 = '9999999999'; +#$VAR4 = '10000000000'; +#$VAR5 = -999999999; +#$VAR6 = '-1000000000'; +#$VAR7 = '-9999999999'; +#$VAR8 = '-10000000000'; +#$VAR9 = '4294967295'; +#$VAR10 = '4294967296'; +#$VAR11 = '-2147483648'; +#$VAR12 = '-2147483649'; +EOT + + TEST q(Data::Dumper->Dump(\@a)), "long integers"; + + if ($XS) { +## XS code flips over at 11 characters ("-" is a char) or larger than int. + if (~0 == 0xFFFFFFFF) { + # 32 bit system + $WANT = <<'EOT'; +#$VAR1 = 999999999; +#$VAR2 = 1000000000; +#$VAR3 = '9999999999'; +#$VAR4 = '10000000000'; +#$VAR5 = -999999999; +#$VAR6 = '-1000000000'; +#$VAR7 = '-9999999999'; +#$VAR8 = '-10000000000'; +#$VAR9 = 4294967295; +#$VAR10 = '4294967296'; +#$VAR11 = '-2147483648'; +#$VAR12 = '-2147483649'; +EOT + } else { + $WANT = <<'EOT'; +#$VAR1 = 999999999; +#$VAR2 = 1000000000; +#$VAR3 = 9999999999; +#$VAR4 = '10000000000'; +#$VAR5 = -999999999; +#$VAR6 = '-1000000000'; +#$VAR7 = '-9999999999'; +#$VAR8 = '-10000000000'; +#$VAR9 = 4294967295; +#$VAR10 = 4294967296; +#$VAR11 = '-2147483648'; +#$VAR12 = '-2147483649'; +EOT + } + TEST q(Data::Dumper->Dumpxs(\@a)), "XS long integers"; + } +} + +#XXX} +{ + $b = "Bad. XS didn't escape dollar sign"; +############# 322 + $WANT = <<"EOT"; # Careful. This is '' string written inside '' here doc +#\$VAR1 = '\$b\"\@\\\\\xA3'; +EOT + + $a = "\$b\"\@\\\xA3\x{100}"; + chop $a; + TEST q(Data::Dumper->Dump([$a])), "utf8 flag with \" and \$"; + if ($XS) { + $WANT = <<'EOT'; # While this is "" string written inside "" here doc +#$VAR1 = "\$b\"\@\\\x{a3}"; +EOT + TEST q(Data::Dumper->Dumpxs([$a])), "XS utf8 flag with \" and \$"; + } + # XS used to produce "$b\"' which is 4 chars, not 3. [ie wrongly qq(\$b\\\")] +############# 328 + $WANT = <<'EOT'; +#$VAR1 = '$b"'; +EOT + + $a = "\$b\"\x{100}"; + chop $a; + TEST q(Data::Dumper->Dump([$a])), "utf8 flag with \" and \$"; + if ($XS) { + TEST q(Data::Dumper->Dumpxs([$a])), "XS utf8 flag with \" and \$"; + } + + + # 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 + + $a = "D'oh!\x{100}"; + chop $a; + TEST q(Data::Dumper->Dump([$a])), "utf8 flag with '"; + if ($XS) { + TEST q(Data::Dumper->Dumpxs([$a])), "XS utf8 flag with '"; + } +} + +# Jarkko found that -Mutf8 caused some tests to fail. Turns out that there +# was an otherwise untested code path in the XS for utf8 hash keys with purity +# 1 + +{ + $WANT = <<'EOT'; +#$ping = \*::ping; +#*::ping = \5; +#*::ping = { +# "\x{decaf}\x{decaf}\x{decaf}\x{decaf}" => do{my $o} +#}; +#*::ping{HASH}->{"\x{decaf}\x{decaf}\x{decaf}\x{decaf}"} = *::ping{SCALAR}; +#%pong = %{*::ping{HASH}}; +EOT + local $Data::Dumper::Purity = 1; + local $Data::Dumper::Sortkeys; + $ping = 5; + %ping = (chr (0xDECAF) x 4 =>\$ping); + for $Data::Dumper::Sortkeys (0, 1) { + TEST q(Data::Dumper->Dump([\\*ping, \\%ping], ['*ping', '*pong'])); + TEST q(Data::Dumper->Dumpxs([\\*ping, \\%ping], ['*ping', '*pong'])) if $XS; + } +} + +# XS for quotekeys==0 was not being defensive enough against utf8 flagged +# scalars + +{ + $WANT = <<'EOT'; +#$VAR1 = { +# perl => 'rocks' +#}; +EOT + local $Data::Dumper::Quotekeys = 0; + my $k = 'perl' . chr 256; + chop $k; + %foo = ($k => 'rocks'); + + TEST q(Data::Dumper->Dump([\\%foo])), "quotekeys == 0 for utf8 flagged ASCII"; + TEST q(Data::Dumper->Dumpxs([\\%foo])), + "XS quotekeys == 0 for utf8 flagged ASCII" if $XS; +} diff --git a/gnu/usr.bin/perl/ext/Data/Dumper/t/overload.t b/gnu/usr.bin/perl/ext/Data/Dumper/t/overload.t new file mode 100644 index 00000000000..d4b3a924ae4 --- /dev/null +++ b/gnu/usr.bin/perl/ext/Data/Dumper/t/overload.t @@ -0,0 +1,35 @@ +#!./perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require Config; import Config; + if ($Config{'extensions'} !~ /\bData\/Dumper\b/) { + print "1..0 # Skip: Data::Dumper was not built\n"; + exit 0; + } +} + +use Data::Dumper; + +print "1..1\n"; + +package Foo; +use overload '""' => 'as_string'; + +sub new { bless { foo => "bar" }, shift } +sub as_string { "%%%%" } + +package main; + +my $f = Foo->new; + +print "#\$f=$f\n"; + +$_ = Dumper($f); +s/^/#/mg; +print $_; + +print "not " unless /bar/ && /Foo/; +print "ok 1\n"; + -- cgit v1.2.3