+#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
-static SV *freezer;
-static SV *toaster;
+#ifndef PERL_VERSION
+#include "patchlevel.h"
+#define PERL_VERSION PATCHLEVEL
+#endif
-static I32 num_q _((char *s, STRLEN slen));
-static I32 esc_q _((char *dest, char *src, STRLEN slen));
-static SV *sv_x _((SV *sv, char *str, STRLEN len, I32 n));
-static I32 DD_dump _((SV *val, char *name, STRLEN namelen, SV *retval,
- HV *seenhv, AV *postav, I32 *levelp, I32 indent,
- SV *pad, SV *xpad, SV *apad, SV *sep,
- SV *freezer, SV *toaster,
- I32 purity, I32 deepcopy, I32 quotekeys, SV *bless));
+#if PERL_VERSION < 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);
+static I32 esc_q_utf8 (pTHX_ SV *sv, char *src, STRLEN slen);
+static SV *sv_x (pTHX_ SV *sv, char *str, STRLEN len, I32 n);
+static I32 DD_dump (pTHX_ SV *val, char *name, STRLEN namelen, SV *retval,
+ HV *seenhv, AV *postav, I32 *levelp, I32 indent,
+ SV *pad, SV *xpad, SV *apad, SV *sep,
+ SV *freezer, SV *toaster,
+ I32 purity, I32 deepcopy, I32 quotekeys, SV *bless,
+ I32 maxdepth, SV *sortkeys);
/* does a string need to be protected? */
static I32
}
if (isIDFIRST(*s)) {
while (*++s)
- if (!isALNUM(*s))
+ if (!isALNUM(*s)) {
if (*s == ':')
goto TOP;
else
return 1;
+ }
}
- else
+ else
return 1;
return 0;
}
esc_q(register char *d, register char *s, register STRLEN slen)
{
register I32 ret = 0;
-
+
while (slen > 0) {
switch (*s) {
case '\'':
return ret;
}
+static I32
+esc_q_utf8(pTHX_ SV* sv, register char *src, register STRLEN slen)
+{
+ char *s, *send, *r;
+ STRLEN grow = 0, j = 1, l;
+ bool dquote = FALSE;
+
+ /* this will need EBCDICification */
+ for (s = src, send = src + slen; s < send; s += UTF8SKIP(s)) {
+ UV k = utf8_to_uvchr((U8*)s, &l);
+
+ grow +=
+ (*s == '"' || *s == '\\') ? 2 :
+ (k < 0x80 ? 1 : UNISKIP(k) + 1 + 4); /* 4: \x{} */
+ }
+ sv_grow(sv, SvCUR(sv)+3+grow); /* 3: ""\0 */
+ r = SvPVX(sv) + SvCUR(sv);
+
+ for (s = src; s < send; s += UTF8SKIP(s)) {
+ UV k = utf8_to_uvchr((U8*)s, &l);
+
+ if (*s == '"' || *s == '\\') {
+ r[j++] = '\\';
+ r[j++] = *s;
+ }
+ else if (k < 0x80)
+ r[j++] = k;
+ else {
+ r[j++] = '\\';
+ r[j++] = 'x';
+ r[j++] = '{';
+ j += sprintf(r + j, "%"UVxf, k);
+ r[j++] = '}';
+ dquote = TRUE;
+ }
+ }
+ if (dquote)
+ r[0] = r[j++] = '"';
+ else
+ r[0] = r[j++] = '\'';
+ r[j] = '\0';
+ SvCUR_set(sv, SvCUR(sv) + j);
+
+ return j;
+}
+
/* append a repeated string to an SV */
static SV *
-sv_x(SV *sv, register char *str, STRLEN len, I32 n)
+sv_x(pTHX_ SV *sv, register char *str, STRLEN len, I32 n)
{
if (sv == Nullsv)
- sv = newSVpv("", 0);
+ sv = newSVpvn("", 0);
else
assert(SvTYPE(sv) >= SVt_PV);
* efficiency raisins.) Ugggh!
*/
static I32
-DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
+DD_dump(pTHX_ SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad,
SV *apad, SV *sep, SV *freezer, SV *toaster, I32 purity,
- I32 deepcopy, I32 quotekeys, SV *bless)
+ I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth, SV *sortkeys)
{
char tmpbuf[128];
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;
U32 realtype;
if (!val)
return 0;
- flags = SvFLAGS(val);
realtype = SvTYPE(val);
-
+
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;
}
ival = SvRV(val);
- flags = SvFLAGS(ival);
realtype = SvTYPE(ival);
(void) sprintf(id, "0x%lx", (unsigned long)ival);
idlen = strlen(id);
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, "do{my $o}", 9);
+ 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 = 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 { /* 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] = '&';
+
+ if (realpack && *realpack == 'R' && strEQ(realpack, "Regexp")) {
+ STRLEN rlen;
+ char *rval = SvPV(val, rlen);
+ char *slash = strchr(rval, '/');
+ sv_catpvn(retval, "qr/", 3);
+ while (slash) {
+ sv_catpvn(retval, rval, slash-rval);
+ sv_catpvn(retval, "\\/", 2);
+ rlen -= slash-rval+1;
+ rval = slash+1;
+ slash = strchr(rval, '/');
}
- 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);
+ sv_catpvn(retval, rval, rlen);
+ sv_catpvn(retval, "/", 1);
+ return 1;
}
-
- (*levelp)++;
- ipad = sv_x(Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp);
- if (realpack) { /* we have a blessed ref */
+ /* If purity is not set and maxdepth is set, then check depth:
+ * if we have reached maximum depth, return the string
+ * representation of the thing we are currently examining
+ * at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)').
+ */
+ if (!purity && maxdepth > 0 && *levelp >= maxdepth) {
+ STRLEN vallen;
+ char *valstr = SvPV(val,vallen);
+ sv_catpvn(retval, "'", 1);
+ sv_catpvn(retval, valstr, vallen);
+ sv_catpvn(retval, "'", 1);
+ return 1;
+ }
+
+ if (realpack) { /* we have a blessed ref */
STRLEN blesslen;
char *blessstr = SvPV(bless, blesslen);
sv_catpvn(retval, blessstr, blesslen);
if (indent >= 2) {
blesspad = apad;
apad = newSVsv(apad);
- sv_x(apad, " ", 1, blesslen+2);
+ sv_x(aTHX_ apad, " ", 1, blesslen+2);
}
}
- if (realtype <= SVt_PVBM || realtype == SVt_PVGV) { /* scalars */
- if (realpack && realtype != SVt_PVGV) { /* blessed */
+ (*levelp)++;
+ ipad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp);
+
+ 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,
- freezer, toaster, purity, deepcopy, quotekeys, bless);
+ DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
+ postav, levelp, indent, pad, xpad, apad, sep,
+ freezer, toaster, purity, deepcopy, quotekeys, bless,
+ maxdepth, sortkeys);
sv_catpvn(retval, ")}", 2);
- }
+ } /* plain */
else {
sv_catpvn(retval, "\\", 1);
- DD_dump(ival, "", 0, retval, seenhv, postav,
- levelp, indent, pad, xpad, apad, sep,
- freezer, toaster, purity, deepcopy, quotekeys, bless);
+ DD_dump(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
+ postav, levelp, indent, pad, xpad, apad, sep,
+ freezer, toaster, purity, deepcopy, quotekeys, bless,
+ maxdepth, sortkeys);
}
+ 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(aTHX_ ival, SvPVX(namesv), SvCUR(namesv), retval, seenhv,
+ postav, levelp, indent, pad, xpad, apad, sep,
+ freezer, toaster, purity, deepcopy, quotekeys, bless,
+ maxdepth, sortkeys);
+ SvREFCNT_dec(namesv);
}
else if (realtype == SVt_PVAV) {
SV *totpad;
I32 ix = 0;
I32 ixmax = av_len((AV *)ival);
-
+
SV *ixsv = newSViv(0);
/* allowing for a 24 char wide array index */
New(0, iname, namelen+28, char);
}
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';
}
ilen = inamelen;
sv_setiv(ixsv, ix);
- (void) sprintf(iname+ilen, "%ld", ix);
+ (void) sprintf(iname+ilen, "%"IVdf, (IV)ix);
ilen = strlen(iname);
iname[ilen++] = ']'; iname[ilen] = '\0';
if (indent >= 3) {
}
sv_catsv(retval, totpad);
sv_catsv(retval, ipad);
- DD_dump(elem, iname, ilen, retval, seenhv, postav,
+ DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav,
levelp, indent, pad, xpad, apad, sep,
- freezer, toaster, purity, deepcopy, quotekeys, bless);
+ freezer, toaster, purity, deepcopy, quotekeys, bless,
+ maxdepth, sortkeys);
if (ix < ixmax)
sv_catpvn(retval, ",", 1);
}
if (ixmax >= 0) {
- SV *opad = sv_x(Nullsv, SvPVX(xpad), SvCUR(xpad), (*levelp)-1);
+ SV *opad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), (*levelp)-1);
sv_catsv(retval, totpad);
sv_catsv(retval, opad);
SvREFCNT_dec(opad);
char *key;
I32 klen;
SV *hval;
-
- iname = newSVpv(name, namelen);
+ AV *keys = Nullav;
+
+ 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);
}
}
totpad = newSVsv(sep);
sv_catsv(totpad, pad);
sv_catsv(totpad, apad);
-
- (void)hv_iterinit((HV*)ival);
+
+ /* If requested, get a sorted/filtered array of hash keys */
+ if (sortkeys) {
+ if (sortkeys == &PL_sv_yes) {
+ keys = newAV();
+ (void)hv_iterinit((HV*)ival);
+ while (entry = hv_iternext((HV*)ival)) {
+ sv = hv_iterkeysv(entry);
+ SvREFCNT_inc(sv);
+ av_push(keys, sv);
+ }
+ sortsv(AvARRAY(keys),
+ av_len(keys)+1,
+ Perl_sv_cmp_locale);
+ }
+ else {
+ dSP; ENTER; SAVETMPS; PUSHMARK(sp);
+ XPUSHs(sv_2mortal(newRV_inc(ival))); PUTBACK;
+ i = perl_call_sv(sortkeys, G_SCALAR | G_EVAL);
+ SPAGAIN;
+ if (i) {
+ sv = POPs;
+ if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVAV))
+ keys = (AV*)SvREFCNT_inc(SvRV(sv));
+ }
+ if (! keys)
+ warn("Sortkeys subroutine did not return ARRAYREF\n");
+ PUTBACK; FREETMPS; LEAVE;
+ }
+ if (keys)
+ sv_2mortal((SV*)keys);
+ }
+ else
+ (void)hv_iterinit((HV*)ival);
i = 0;
- while ((entry = hv_iternext((HV*)ival))) {
- char *nkey;
+ while (sortkeys ? (void*)(keys && (i <= av_len(keys))) :
+ (void*)((entry = hv_iternext((HV*)ival))) ) {
+ char *nkey = NULL;
I32 nticks = 0;
+ SV* keysv;
+ STRLEN keylen;
+ bool do_utf8 = FALSE;
if (i)
sv_catpvn(retval, ",", 1);
- i++;
- key = hv_iterkey(entry, &klen);
- hval = hv_iterval((HV*)ival, entry);
-
- if (quotekeys || needs_quote(key)) {
- nticks = num_q(key, klen);
- New(0, nkey, klen+nticks+3, char);
- nkey[0] = '\'';
- if (nticks)
- klen += esc_q(nkey+1, key, klen);
- else
- (void)Copy(key, nkey+1, klen, char);
- nkey[++klen] = '\'';
- nkey[++klen] = '\0';
+
+ if (sortkeys) {
+ char *key;
+ svp = av_fetch(keys, i, FALSE);
+ keysv = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
+ key = SvPV(keysv, keylen);
+ svp = hv_fetch((HV*)ival, key, keylen, 0);
+ hval = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
}
else {
- New(0, nkey, klen, char);
- (void)Copy(key, nkey, klen, char);
+ keysv = hv_iterkeysv(entry);
+ hval = hv_iterval((HV*)ival, entry);
}
-
- sname = newSVsv(iname);
- sv_catpvn(sname, nkey, klen);
- sv_catpvn(sname, "}", 1);
- sv_catsv(retval, totpad);
- sv_catsv(retval, ipad);
- sv_catpvn(retval, nkey, klen);
+ i++;
+
+ do_utf8 = DO_UTF8(keysv);
+ key = SvPV(keysv, keylen);
+ klen = keylen;
+
+ if (do_utf8) {
+ char *okey = SvPVX(retval) + SvCUR(retval);
+ I32 nlen;
+
+ sv_catsv(retval, totpad);
+ sv_catsv(retval, ipad);
+ nlen = esc_q_utf8(aTHX_ retval, key, klen);
+
+ sname = newSVsv(iname);
+ sv_catpvn(sname, okey, nlen);
+ sv_catpvn(sname, "}", 1);
+ }
+ else {
+ if (quotekeys || needs_quote(key)) {
+ nticks = num_q(key, klen);
+ New(0, nkey, klen+nticks+3, char);
+ nkey[0] = '\'';
+ if (nticks)
+ klen += esc_q(nkey+1, key, klen);
+ else
+ (void)Copy(key, nkey+1, klen, char);
+ nkey[++klen] = '\'';
+ nkey[++klen] = '\0';
+ }
+ else {
+ New(0, nkey, klen, char);
+ (void)Copy(key, nkey, klen, char);
+ }
+
+ sname = newSVsv(iname);
+ sv_catpvn(sname, nkey, klen);
+ sv_catpvn(sname, "}", 1);
+
+ sv_catsv(retval, totpad);
+ sv_catsv(retval, ipad);
+ sv_catpvn(retval, nkey, klen);
+ }
sv_catpvn(retval, " => ", 4);
if (indent >= 2) {
char *extra;
else
newapad = apad;
- DD_dump(hval, SvPVX(sname), SvCUR(sname), retval, seenhv,
+ DD_dump(aTHX_ hval, SvPVX(sname), SvCUR(sname), retval, seenhv,
postav, levelp, indent, pad, xpad, newapad, sep,
- freezer, toaster, purity, deepcopy, quotekeys, bless);
+ freezer, toaster, purity, deepcopy, quotekeys, bless,
+ maxdepth, sortkeys);
SvREFCNT_dec(sname);
Safefree(nkey);
if (indent >= 2)
SvREFCNT_dec(newapad);
}
if (i) {
- SV *opad = sv_x(Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp-1);
+ SV *opad = sv_x(aTHX_ Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp-1);
sv_catsv(retval, totpad);
sv_catsv(retval, opad);
SvREFCNT_dec(opad);
(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);
+ if (SvIsUV(val))
+ (void) sprintf(tmpbuf, "%"UVuf, SvUV(val));
+ else
+ (void) sprintf(tmpbuf, "%"IVdf, SvIV(val));
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]);
SvCUR(newapad) = 0;
if (indent >= 2)
- (void)sv_x(newapad, " ", 1, SvCUR(postentry));
+ (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry));
- DD_dump(e, SvPVX(nname), SvCUR(nname), postentry,
+ DD_dump(aTHX_ e, SvPVX(nname), SvCUR(nname), postentry,
seenhv, postav, &nlevel, indent, pad, xpad,
newapad, sep, freezer, toaster, purity,
- deepcopy, quotekeys, bless);
+ deepcopy, quotekeys, bless, maxdepth,
+ sortkeys);
SvREFCNT_dec(e);
}
}
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);
- r = SvPVX(retval)+SvCUR(retval);
- r[0] = '\'';
- i += esc_q(r+1, c, i);
- ++i;
- r[i++] = '\'';
- r[i] = '\0';
+ if (DO_UTF8(val))
+ i += esc_q_utf8(aTHX_ retval, c, i);
+ else {
+ sv_grow(retval, SvCUR(retval)+3+2*i); /* 3: ""\0 */
+ r = SvPVX(retval) + SvCUR(retval);
+ r[0] = '\'';
+ i += esc_q(r+1, c, 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;
}
HV *seenhv = Nullhv;
AV *postav, *todumpav, *namesav;
I32 level = 0;
- I32 indent, terse, useqq, i, imax, postlen;
+ I32 indent, terse, i, imax, postlen;
SV **svp;
- SV *val, *name, *pad, *xpad, *apad, *sep, *tmp, *varname;
- SV *freezer, *toaster, *bless;
- I32 purity, deepcopy, quotekeys;
+ SV *val, *name, *pad, *xpad, *apad, *sep, *varname;
+ SV *freezer, *toaster, *bless, *sortkeys;
+ I32 purity, deepcopy, quotekeys, maxdepth = 0;
char tmpbuf[1024];
I32 gimme = GIMME;
if (!SvROK(href)) { /* call new to get an object first */
- SV *valarray;
- SV *namearray;
-
- if (items == 3) {
- valarray = ST(1);
- namearray = ST(2);
- }
- else
- croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, NAME_ARY_REF)");
+ if (items < 2)
+ croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, [NAME_ARY_REF])");
ENTER;
SAVETMPS;
PUSHMARK(sp);
XPUSHs(href);
- XPUSHs(sv_2mortal(newSVsv(valarray)));
- XPUSHs(sv_2mortal(newSVsv(namearray)));
+ XPUSHs(sv_2mortal(newSVsv(ST(1))));
+ if (items >= 3)
+ XPUSHs(sv_2mortal(newSVsv(ST(2))));
PUTBACK;
i = perl_call_method("new", G_SCALAR);
SPAGAIN;
todumpav = namesav = Nullav;
seenhv = Nullhv;
- val = pad = xpad = apad = sep = tmp = varname
+ val = pad = xpad = apad = sep = varname
= freezer = toaster = bless = &PL_sv_undef;
name = sv_newmortal();
indent = 2;
- terse = useqq = purity = deepcopy = 0;
+ terse = purity = deepcopy = 0;
quotekeys = 1;
-
- retval = newSVpv("", 0);
+
+ retval = newSVpvn("", 0);
if (SvROK(href)
&& (hv = (HV*)SvRV((SV*)href))
&& SvTYPE(hv) == SVt_PVHV) {
purity = SvIV(*svp);
if ((svp = hv_fetch(hv, "terse", 5, FALSE)))
terse = SvTRUE(*svp);
+#if 0 /* useqq currently unused */
if ((svp = hv_fetch(hv, "useqq", 5, FALSE)))
useqq = SvTRUE(*svp);
+#endif
if ((svp = hv_fetch(hv, "pad", 3, FALSE)))
pad = *svp;
if ((svp = hv_fetch(hv, "xpad", 4, FALSE)))
quotekeys = SvTRUE(*svp);
if ((svp = hv_fetch(hv, "bless", 5, FALSE)))
bless = *svp;
+ if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE)))
+ maxdepth = SvIV(*svp);
+ if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) {
+ sortkeys = *svp;
+ if (! SvTRUE(sortkeys))
+ sortkeys = NULL;
+ else if (! (SvROK(sortkeys) &&
+ SvTYPE(SvRV(sortkeys)) == SVt_PVCV) )
+ {
+ /* flag to use qsortsv() for sorting hash keys */
+ sortkeys = &PL_sv_yes;
+ }
+ }
postav = newAV();
if (todumpav)
imax = av_len(todumpav);
else
imax = -1;
- valstr = newSVpv("",0);
+ valstr = newSVpvn("",0);
for (i = 0; i <= imax; ++i) {
SV *newapad;
-
+
av_clear(postav);
if ((svp = av_fetch(todumpav, i, FALSE)))
val = *svp;
if ((svp = av_fetch(namesav, i, TRUE)))
sv_setsv(name, *svp);
else
- SvOK_off(name);
-
+ (void)SvOK_off(name);
+
if (SvOK(name)) {
if ((SvPVX(name))[0] == '*') {
if (SvROK(val)) {
STRLEN nchars = 0;
sv_setpvn(name, "$", 1);
sv_catsv(name, varname);
- (void) sprintf(tmpbuf, "%ld", i+1);
+ (void) sprintf(tmpbuf, "%"IVdf, (IV)(i+1));
nchars = strlen(tmpbuf);
sv_catpvn(name, tmpbuf, nchars);
}
-
+
if (indent >= 2) {
- SV *tmpsv = sv_x(Nullsv, " ", 1, SvCUR(name)+3);
+ SV *tmpsv = sv_x(aTHX_ Nullsv, " ", 1, SvCUR(name)+3);
newapad = newSVsv(apad);
sv_catsv(newapad, tmpsv);
SvREFCNT_dec(tmpsv);
}
else
newapad = apad;
-
- DD_dump(val, SvPVX(name), SvCUR(name), valstr, seenhv,
+
+ DD_dump(aTHX_ val, SvPVX(name), SvCUR(name), valstr, seenhv,
postav, &level, indent, pad, xpad, newapad, sep,
freezer, toaster, purity, deepcopy, quotekeys,
- bless);
-
+ bless, maxdepth, sortkeys);
+
if (indent >= 2)
SvREFCNT_dec(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 / blobdiff