package Data::Dumper;
-$VERSION = $VERSION = '2.09';
+$VERSION = $VERSION = '2.10';
#$| = 1;
my($sname);
my($out, $realpack, $realtype, $type, $ipad, $id, $blesspad);
- return "undef" unless defined $val;
-
$type = ref $val;
$out = "";
# 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}++;
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);
$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 . ']';
$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, "");
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
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;
}
}
}
-
- # 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;
}
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;
=head1 VERSION
-Version 2.09 (9 July 1998)
+Version 2.10 (31 Oct 1998)
=head1 SEE ALSO
#include "perl.h"
#include "XSUB.h"
-static SV *freezer;
-static SV *toaster;
+#if PATCHLEVEL < 5
+# ifndef PL_sv_undef
+# define PL_sv_undef sv_undef
+# endif
+# ifndef ERRSV
+# define ERRSV GvSV(errgv)
+# endif
+# ifndef newSVpvn
+# define newSVpvn newSVpv
+# endif
+#endif
static I32 num_q _((char *s, STRLEN slen));
static I32 esc_q _((char *dest, char *src, STRLEN slen));
sv_x(SV *sv, register char *str, STRLEN len, I32 n)
{
if (sv == Nullsv)
- sv = newSVpv("", 0);
+ sv = newSVpvn("", 0);
else
assert(SvTYPE(sv) >= SVt_PV);
U32 i;
char *c, *r, *realpack, id[128];
SV **svp;
- SV *sv;
+ SV *sv, *ipad, *ival;
SV *blesspad = Nullsv;
- SV *ipad;
- SV *ival;
- AV *seenentry;
+ AV *seenentry = Nullav;
char *iname;
STRLEN inamelen, idlen = 0;
U32 flags;
if (SvGMAGICAL(val))
mg_get(val);
- if (val == &PL_sv_undef || !SvOK(val)) {
- sv_catpvn(retval, "undef", 5);
- return 1;
- }
if (SvROK(val)) {
if (SvOBJECT(SvRV(val)) && freezer &&
XPUSHs(val); PUTBACK;
i = perl_call_method(SvPVX(freezer), G_EVAL|G_SCALAR);
SPAGAIN;
- if (SvTRUE(GvSV(PL_errgv)))
+ if (SvTRUE(ERRSV))
warn("WARNING(Freezer method call failed): %s",
- SvPVX(GvSV(PL_errgv)));
+ SvPVX(ERRSV));
else if (i)
val = newSVsv(POPs);
PUTBACK; FREETMPS; LEAVE;
realpack = HvNAME(SvSTASH(ival));
else
realpack = Nullch;
- if ((svp = hv_fetch(seenhv, id, idlen, FALSE)) &&
- (sv = *svp) && SvROK(sv) &&
- (seenentry = (AV*)SvRV(sv))) {
- SV *othername;
- if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)) {
- if (purity && *levelp > 0) {
- SV *postentry;
-
- if (realtype == SVt_PVHV)
- sv_catpvn(retval, "{}", 2);
- else if (realtype == SVt_PVAV)
- sv_catpvn(retval, "[]", 2);
- else
- sv_catpvn(retval, "''", 2);
- postentry = newSVpv(name, namelen);
- sv_catpvn(postentry, " = ", 3);
- sv_catsv(postentry, othername);
- av_push(postav, postentry);
- }
- else {
- if (name[0] == '@' || name[0] == '%') {
- if ((SvPVX(othername))[0] == '\\' &&
- (SvPVX(othername))[1] == name[0]) {
- sv_catpvn(retval, SvPVX(othername)+1, SvCUR(othername)-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 (namelen) {
+ if ((svp = hv_fetch(seenhv, id, idlen, FALSE))
+ && (sv = *svp) && SvROK(sv) && (seenentry = (AV*)SvRV(sv)))
+ {
+ SV *othername;
+ if ((svp = av_fetch(seenentry, 0, FALSE))
+ && (othername = *svp))
+ {
+ if (purity && *levelp > 0) {
+ SV *postentry;
+
+ if (realtype == SVt_PVHV)
+ sv_catpvn(retval, "{}", 2);
+ else if (realtype == SVt_PVAV)
+ sv_catpvn(retval, "[]", 2);
+ else
+ sv_catpvn(retval, "''", 2);
+ postentry = newSVpvn(name, namelen);
+ sv_catpvn(postentry, " = ", 3);
+ sv_catsv(postentry, othername);
+ av_push(postav, postentry);
+ }
+ else {
+ if (name[0] == '@' || name[0] == '%') {
+ if ((SvPVX(othername))[0] == '\\' &&
+ (SvPVX(othername))[1] == name[0]) {
+ sv_catpvn(retval, SvPVX(othername)+1,
+ SvCUR(othername)-1);
+ }
+ else {
+ sv_catpvn(retval, name, 1);
+ sv_catpvn(retval, "{", 1);
+ sv_catsv(retval, othername);
+ sv_catpvn(retval, "}", 1);
+ }
}
- else {
- sv_catpvn(retval, name, 1);
- sv_catpvn(retval, "{", 1);
+ else
sv_catsv(retval, othername);
- sv_catpvn(retval, "}", 1);
- }
}
- else
- sv_catsv(retval, othername);
+ return 1;
+ }
+ else {
+ warn("ref name not found for %s", id);
+ return 0;
}
- return 1;
- }
- else {
- warn("ref name not found for %s", id);
- return 0;
- }
- }
- else { /* store our name and continue */
- SV *namesv;
- if (name[0] == '@' || name[0] == '%') {
- namesv = newSVpv("\\", 1);
- sv_catpvn(namesv, name, namelen);
}
- else if (realtype == SVt_PVCV && name[0] == '*') {
- namesv = newSVpv("\\", 2);
- sv_catpvn(namesv, name, namelen);
- (SvPVX(namesv))[1] = '&';
+ else { /* store our name and continue */
+ SV *namesv;
+ if (name[0] == '@' || name[0] == '%') {
+ namesv = newSVpvn("\\", 1);
+ sv_catpvn(namesv, name, namelen);
+ }
+ else if (realtype == SVt_PVCV && name[0] == '*') {
+ namesv = newSVpvn("\\", 2);
+ sv_catpvn(namesv, name, namelen);
+ (SvPVX(namesv))[1] = '&';
+ }
+ else
+ namesv = newSVpvn(name, namelen);
+ seenentry = newAV();
+ av_push(seenentry, namesv);
+ (void)SvREFCNT_inc(val);
+ av_push(seenentry, val);
+ (void)hv_store(seenhv, id, strlen(id),
+ newRV((SV*)seenentry), 0);
+ SvREFCNT_dec(seenentry);
}
- else
- namesv = newSVpv(name, namelen);
- seenentry = newAV();
- av_push(seenentry, namesv);
- (void)SvREFCNT_inc(val);
- av_push(seenentry, val);
- (void)hv_store(seenhv, id, strlen(id), newRV((SV*)seenentry), 0);
- SvREFCNT_dec(seenentry);
}
(*levelp)++;
}
}
- if (realtype <= SVt_PVBM || realtype == SVt_PVGV) { /* scalars */
- if (realpack && realtype != SVt_PVGV) { /* blessed */
+ if (realtype <= SVt_PVBM) { /* scalar ref */
+ SV *namesv = newSVpvn("${", 2);
+ sv_catpvn(namesv, name, namelen);
+ sv_catpvn(namesv, "}", 1);
+ if (realpack) { /* blessed */
sv_catpvn(retval, "do{\\(my $o = ", 13);
- DD_dump(ival, "", 0, retval, seenhv, postav,
- levelp, indent, pad, xpad, apad, sep,
+ DD_dump(ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
+ postav, levelp, indent, pad, xpad, apad, sep,
freezer, toaster, purity, deepcopy, quotekeys, bless);
sv_catpvn(retval, ")}", 2);
- }
+ } /* plain */
else {
sv_catpvn(retval, "\\", 1);
- DD_dump(ival, "", 0, retval, seenhv, postav,
- levelp, indent, pad, xpad, apad, sep,
+ DD_dump(ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
+ postav, levelp, indent, pad, xpad, apad, sep,
freezer, toaster, purity, deepcopy, quotekeys, bless);
}
+ SvREFCNT_dec(namesv);
+ }
+ else if (realtype == SVt_PVGV) { /* glob ref */
+ SV *namesv = newSVpvn("*{", 2);
+ sv_catpvn(namesv, name, namelen);
+ sv_catpvn(namesv, "}", 1);
+ sv_catpvn(retval, "\\", 1);
+ DD_dump(ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
+ postav, levelp, indent, pad, xpad, apad, sep,
+ freezer, toaster, purity, deepcopy, quotekeys, bless);
+ SvREFCNT_dec(namesv);
}
else if (realtype == SVt_PVAV) {
SV *totpad;
}
else {
sv_catpvn(retval, "[", 1);
- if (namelen > 0 && name[namelen-1] != ']' && name[namelen-1] != '}') {
+ /* omit "->" in $foo{bar}->[0], but not in ${$foo}->[0] */
+ /*if (namelen > 0
+ && name[namelen-1] != ']' && name[namelen-1] != '}'
+ && (namelen < 4 || (name[1] != '{' && name[2] != '{')))*/
+ if ((namelen > 0
+ && name[namelen-1] != ']' && name[namelen-1] != '}')
+ || (namelen > 4
+ && (name[1] == '{'
+ || (name[0] == '\\' && name[2] == '{'))))
+ {
iname[inamelen++] = '-'; iname[inamelen++] = '>';
iname[inamelen] = '\0';
}
I32 klen;
SV *hval;
- iname = newSVpv(name, namelen);
+ iname = newSVpvn(name, namelen);
if (name[0] == '%') {
sv_catpvn(retval, "(", 1);
(SvPVX(iname))[0] = '$';
}
else {
sv_catpvn(retval, "{", 1);
- if (namelen > 0 && name[namelen-1] != ']' && name[namelen-1] != '}') {
+ /* omit "->" in $foo[0]->{bar}, but not in ${$foo}->{bar} */
+ if ((namelen > 0
+ && name[namelen-1] != ']' && name[namelen-1] != '}')
+ || (namelen > 4
+ && (name[1] == '{'
+ || (name[0] == '\\' && name[2] == '{'))))
+ {
sv_catpvn(iname, "->", 2);
}
}
(void) sprintf(id, "0x%lx", (unsigned long)val);
if ((svp = hv_fetch(seenhv, id, (idlen = strlen(id)), FALSE)) &&
(sv = *svp) && SvROK(sv) &&
- (seenentry = (AV*)SvRV(sv))) {
+ (seenentry = (AV*)SvRV(sv)))
+ {
SV *othername;
- if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)) {
+ if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)
+ && (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0)
+ {
+ sv_catpvn(retval, "${", 2);
sv_catsv(retval, othername);
+ sv_catpvn(retval, "}", 1);
return 1;
}
}
else {
SV *namesv;
- namesv = newSVpv("\\", 1);
+ namesv = newSVpvn("\\", 1);
sv_catpvn(namesv, name, namelen);
seenentry = newAV();
av_push(seenentry, namesv);
- (void)SvREFCNT_inc(val);
- av_push(seenentry, val);
+ av_push(seenentry, newRV(val));
(void)hv_store(seenhv, id, strlen(id), newRV((SV*)seenentry), 0);
SvREFCNT_dec(seenentry);
}
}
-
+
if (SvIOK(val)) {
STRLEN len;
i = SvIV(val);
(void) sprintf(tmpbuf, "%d", i);
len = strlen(tmpbuf);
sv_catpvn(retval, tmpbuf, len);
- return 1;
}
else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */
c = SvPV(val, i);
r[0] = '*'; strcpy(r+1, c);
i++;
}
+ SvCUR_set(retval, SvCUR(retval)+i);
if (purity) {
static char *entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" };
static STRLEN sizes[] = { 8, 7, 6 };
SV *e;
- SV *nname = newSVpv("", 0);
- SV *newapad = newSVpv("", 0);
+ SV *nname = newSVpvn("", 0);
+ SV *newapad = newSVpvn("", 0);
GV *gv = (GV*)val;
I32 j;
for (j=0; j<3; j++) {
e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv));
- if (e) {
+ if (!e)
+ continue;
+ if (j == 0 && !SvOK(e))
+ continue;
+
+ {
I32 nlevel = 0;
- SV *postentry = newSVpv(r,i);
+ SV *postentry = newSVpvn(r,i);
sv_setsv(nname, postentry);
sv_catpvn(nname, entries[j], sizes[j]);
SvREFCNT_dec(nname);
}
}
+ else if (val == &PL_sv_undef || !SvOK(val)) {
+ sv_catpvn(retval, "undef", 5);
+ }
else {
c = SvPV(val, i);
sv_grow(retval, SvCUR(retval)+3+2*i);
++i;
r[i++] = '\'';
r[i] = '\0';
+ SvCUR_set(retval, SvCUR(retval)+i);
}
- SvCUR_set(retval, SvCUR(retval)+i);
}
- if (deepcopy && idlen)
- (void)hv_delete(seenhv, id, idlen, G_DISCARD);
-
+ if (idlen) {
+ if (deepcopy)
+ (void)hv_delete(seenhv, id, idlen, G_DISCARD);
+ else if (namelen && seenentry) {
+ SV *mark = *av_fetch(seenentry, 2, TRUE);
+ sv_setiv(mark,1);
+ }
+ }
return 1;
}
terse = useqq = purity = deepcopy = 0;
quotekeys = 1;
- retval = newSVpv("", 0);
+ retval = newSVpvn("", 0);
if (SvROK(href)
&& (hv = (HV*)SvRV((SV*)href))
&& SvTYPE(hv) == SVt_PVHV) {
imax = av_len(todumpav);
else
imax = -1;
- valstr = newSVpv("",0);
+ valstr = newSVpvn("",0);
for (i = 0; i <= imax; ++i) {
SV *newapad;
if (gimme == G_ARRAY) {
XPUSHs(sv_2mortal(retval));
if (i < imax) /* not the last time thro ? */
- retval = newSVpv("",0);
+ retval = newSVpvn("",0);
}
}
SvREFCNT_dec(postav);
projects / p5sagit/p5-mst-13.2.git / commitdiff