X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=ext%2FData%2FDumper%2FDumper.pm;h=4369664a5aea8521746651016f3d3afb3792a4ab;hb=7820172aeabcfabb96bd74a4753f9acdd5f3e3da;hp=e3c361f3a29991cce9c5f2c913d38c8f00478a4f;hpb=317982ace1c0c548db99fd9a1eb48374c5d480cb;p=p5sagit%2Fp5-mst-13.2.git diff --git a/ext/Data/Dumper/Dumper.pm b/ext/Data/Dumper/Dumper.pm index e3c361f..4369664 100644 --- a/ext/Data/Dumper/Dumper.pm +++ b/ext/Data/Dumper/Dumper.pm @@ -9,7 +9,7 @@ package Data::Dumper; -$VERSION = $VERSION = '2.09'; +$VERSION = $VERSION = '2.10'; #$| = 1; @@ -208,8 +208,6 @@ sub _dump { my($sname); my($out, $realpack, $realtype, $type, $ipad, $id, $blesspad); - return "undef" unless defined $val; - $type = ref $val; $out = ""; @@ -218,47 +216,47 @@ sub _dump { # prep it, if it looks like an object if ($type =~ /[a-z_:]/) { my $freezer = $s->{freezer}; - # UNIVERSAL::can should be used here, when we can require 5.004 - if ($freezer) { - eval { $val->$freezer() }; - carp "WARNING(Freezer method call failed): $@" if $@; - } + $val->$freezer() if $freezer && UNIVERSAL::can($val, $freezer); } ($realpack, $realtype, $id) = (overload::StrVal($val) =~ /^(?:(.*)\=)?([^=]*)\(([^\(]*)\)$/); - # keep a tab on it so that we dont fall into recursive pit - if (exists $s->{seen}{$id}) { -# if ($s->{expdepth} < $s->{level}) { - if ($s->{purity} and $s->{level} > 0) { - $out = ($realtype eq 'HASH') ? '{}' : - ($realtype eq 'ARRAY') ? '[]' : - "''" ; - push @post, $name . " = " . $s->{seen}{$id}[0]; - } - else { - $out = $s->{seen}{$id}[0]; - if ($name =~ /^([\@\%])/) { - my $start = $1; - if ($out =~ /^\\$start/) { - $out = substr($out, 1); + # if it has a name, we need to either look it up, or keep a tab + # on it so we know when we hit it later + if (defined($name) and length($name)) { + # keep a tab on it so that we dont fall into recursive pit + if (exists $s->{seen}{$id}) { +# if ($s->{expdepth} < $s->{level}) { + if ($s->{purity} and $s->{level} > 0) { + $out = ($realtype eq 'HASH') ? '{}' : + ($realtype eq 'ARRAY') ? '[]' : + "''" ; + push @post, $name . " = " . $s->{seen}{$id}[0]; } else { - $out = $start . '{' . $out . '}'; - } - } + $out = $s->{seen}{$id}[0]; + if ($name =~ /^([\@\%])/) { + my $start = $1; + if ($out =~ /^\\$start/) { + $out = substr($out, 1); + } + else { + $out = $start . '{' . $out . '}'; + } + } + } + return $out; +# } + } + else { + # store our name + $s->{seen}{$id} = [ (($name =~ /^[@%]/) ? ('\\' . $name ) : + ($realtype eq 'CODE' and + $name =~ /^[*](.*)$/) ? ('\\&' . $1 ) : + $name ), + $val ]; } - return $out; -# } - } - else { - # store our name - $s->{seen}{$id} = [ (($name =~ /^[@%]/) ? ('\\' . $name ) : - ($realtype eq 'CODE' and - $name =~ /^[*](.*)$/) ? ('\\&' . $1 ) : - $name ), - $val ]; } $s->{level}++; @@ -272,14 +270,14 @@ sub _dump { if ($realtype eq 'SCALAR') { if ($realpack) { - $out .= 'do{\\(my $o = ' . $s->_dump($$val, "") . ')}'; + $out .= 'do{\\(my $o = ' . $s->_dump($$val, "\${$name}") . ')}'; } else { - $out .= '\\' . $s->_dump($$val, ""); + $out .= '\\' . $s->_dump($$val, "\${$name}"); } } elsif ($realtype eq 'GLOB') { - $out .= '\\' . $s->_dump($$val, ""); + $out .= '\\' . $s->_dump($$val, "*{$name}"); } elsif ($realtype eq 'ARRAY') { my($v, $pad, $mname); @@ -287,7 +285,9 @@ sub _dump { $out .= ($name =~ /^\@/) ? '(' : '['; $pad = $s->{sep} . $s->{pad} . $s->{apad}; ($name =~ /^\@(.*)$/) ? ($mname = "\$" . $1) : - ($name =~ /[]}]$/) ? ($mname = $name) : ($mname = $name . '->'); + # omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar} + ($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) : + ($mname = $name . '->'); $mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/; for $v (@$val) { $sname = $mname . '[' . $i . ']'; @@ -303,8 +303,10 @@ sub _dump { $out .= ($name =~ /^\%/) ? '(' : '{'; $pad = $s->{sep} . $s->{pad} . $s->{apad}; $lpad = $s->{apad}; - ($name =~ /^\%(.*)$/) ? ($mname = "\$" . $1) : - ($name =~ /[]}]$/) ? ($mname = $name) : ($mname = $name . '->'); + ($name =~ /^\%(.*)$/) ? ($mname = "\$" . $1) : + # omit -> if $foo->[0]->{bar}, but not ${$foo->[0]}->{bar} + ($name =~ /^\\?[\%\@\*\$][^{].*[]}]$/) ? ($mname = $name) : + ($mname = $name . '->'); $mname .= '->' if $mname =~ /^\*.+\{[A-Z]+\}$/; while (($k, $v) = each %$val) { my $nk = $s->_dump($k, ""); @@ -347,11 +349,15 @@ sub _dump { if ($name ne '') { ($id) = ("$ref" =~ /\(([^\(]*)\)$/); if (exists $s->{seen}{$id}) { - $out = $s->{seen}{$id}[0]; - return $out; + if ($s->{seen}{$id}[2]) { + $out = $s->{seen}{$id}[0]; + #warn "[<$out]\n"; + return "\${$out}"; + } } else { - $s->{seen}{$id} = ["\\$name", $val]; + #warn "[>\\$name]\n"; + $s->{seen}{$id} = ["\\$name", $ref]; } } if (ref($ref) eq 'GLOB' or "$ref" =~ /=GLOB\([^()]+\)$/) { # glob @@ -368,21 +374,28 @@ sub _dump { my $k; local ($s->{level}) = 0; for $k (qw(SCALAR ARRAY HASH)) { + my $gval = *$val{$k}; + next unless defined $gval; + next if $k eq "SCALAR" && ! defined $$gval; # always there + # _dump can push into @post, so we hold our place using $postlen my $postlen = scalar @post; $post[$postlen] = "\*$sname = "; local ($s->{apad}) = " " x length($post[$postlen]) if $s->{indent} >= 2; - $post[$postlen] .= $s->_dump(*{$name}{$k}, "\*$sname\{$k\}"); + $post[$postlen] .= $s->_dump($gval, "\*$sname\{$k\}"); } } $out .= '*' . $sname; } + elsif (!defined($val)) { + $out .= "undef"; + } elsif ($val =~ /^-?[1-9]\d{0,8}$/) { # safe decimal number $out .= $val; } else { # string if ($s->{useqq}) { - $out .= qquote($val); + $out .= qquote($val, $s->{useqq}); } else { $val =~ s/([\\\'])/\\$1/g; @@ -390,10 +403,16 @@ sub _dump { } } } - - # if we made it this far, $id was added to seen list at current - # level, so remove it to get deep copies - delete($s->{seen}{$id}) if $id and $s->{deepcopy}; + if ($id) { + # if we made it this far, $id was added to seen list at current + # level, so remove it to get deep copies + if ($s->{deepcopy}) { + delete($s->{seen}{$id}); + } + elsif ($name) { + $s->{seen}{$id}[2] = 1; + } + } return $out; } @@ -493,22 +512,41 @@ sub Bless { defined($v) ? (($s->{'bless'} = $v), return $s) : $s->{'bless'}; } +# used by qquote below +my %esc = ( + "\a" => "\\a", + "\b" => "\\b", + "\t" => "\\t", + "\n" => "\\n", + "\f" => "\\f", + "\r" => "\\r", + "\e" => "\\e", +); + # put a string value in double quotes sub qquote { local($_) = shift; - s/([\\\"\@\$\%])/\\$1/g; - s/\a/\\a/g; - s/[\b]/\\b/g; - s/\t/\\t/g; - s/\n/\\n/g; - s/\f/\\f/g; - s/\r/\\r/g; - s/\e/\\e/g; - -# this won't work! -# s/([^\a\b\t\n\f\r\e\038-\176])/'\\'.sprintf('%03o',ord($1))/eg; - s/([\000-\006\013\016-\032\034-\037\177\200-\377])/'\\'.sprintf('%03o',ord($1))/eg; - return "\"$_\""; + s/([\\\"\@\$])/\\$1/g; + return qq("$_") unless /[^\040-\176]/; # fast exit + + my $high = shift || ""; + s/([\a\b\t\n\f\r\e])/$esc{$1}/g; + + # no need for 3 digits in escape for these + s/([\0-\037])(?!\d)/'\\'.sprintf('%o',ord($1))/eg; + + s/([\0-\037\177])/'\\'.sprintf('%03o',ord($1))/eg; + if ($high eq "iso8859") { + s/([\200-\240])/'\\'.sprintf('%o',ord($1))/eg; + } elsif ($high eq "utf8") { +# use utf8; +# $str =~ s/([^\040-\176])/sprintf "\\x{%04x}", ord($1)/ge; + } elsif ($high eq "8bit") { + # leave it as it is + } else { + s/([\0-\037\177-\377])/'\\'.sprintf('%03o',ord($1))/eg; + } + return qq("$_"); } 1; @@ -954,7 +992,7 @@ modify it under the same terms as Perl itself. =head1 VERSION -Version 2.09 (9 July 1998) +Version 2.10 (31 Oct 1998) =head1 SEE ALSO