[perl5.git] / ext / Data / Dumper / Dumper.xs

#ifdef __cplusplus
extern "C" {
#endif
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#ifdef __cplusplus
}
#endif

static SV	*freezer;
static SV	*toaster;

static I32 num_q _((char *s));
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));

/* does a string need to be protected? */
static I32
needs_quote(register char *s)
{
TOP:
    if (s[0] == ':') {
	if (*++s) {
	    if (*s++ != ':')
		return 1;
	}
	else
	    return 1;
    }
    if (isIDFIRST(*s)) {
	while (*++s)
	    if (!isALNUM(*s))
		if (*s == ':')
		    goto TOP;
		else
		    return 1;
    }
    else 
	return 1;
    return 0;
}

/* count the number of "'"s and "\"s in string */
static I32
num_q(register char *s)
{
    register I32 ret = 0;
    
    while (*s) {
	if (*s == '\'' || *s == '\\')
	    ++ret;
	++s;
    }
    return ret;
}


/* returns number of chars added to escape "'"s and "\"s in s */
/* slen number of characters in s will be escaped */
/* destination must be long enough for additional chars */
static I32
esc_q(register char *d, register char *s, register STRLEN slen)
{
    register I32 ret = 0;
    
    while (slen > 0) {
	switch (*s) {
	case '\'':
	case '\\':
	    *d = '\\';
	    ++d; ++ret;
	default:
	    *d = *s;
	    ++d; ++s; --slen;
	    break;
	}
    }
    return ret;
}

/* append a repeated string to an SV */
static SV *
sv_x(SV *sv, register char *str, STRLEN len, I32 n)
{
    if (sv == Nullsv)
	sv = newSVpv("", 0);
    else
	assert(SvTYPE(sv) >= SVt_PV);

    if (n > 0) {
	SvGROW(sv, len*n + SvCUR(sv) + 1);
	if (len == 1) {
	    char *start = SvPVX(sv) + SvCUR(sv);
	    SvCUR(sv) += n;
	    start[n] = '\0';
	    while (n > 0)
		start[--n] = str[0];
	}
	else
	    while (n > 0) {
		sv_catpvn(sv, str, len);
		--n;
	    }
    }
    return sv;
}

/*
 * This ought to be split into smaller functions. (it is one long function since
 * it exactly parallels the perl version, which was one long thing for
 * efficiency raisins.)  Ugggh!
 */
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)
{
    char tmpbuf[128];
    U32 i;
    char *c, *r, *realpack, id[128];
    SV **svp;
    SV *sv;
    SV *blesspad = Nullsv;
    SV *ipad;
    SV *ival;
    AV *seenentry;
    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 == &sv_undef || !SvOK(val)) {
	sv_catpvn(retval, "undef", 5);
	return 1;
    }
    if (SvROK(val)) {

	if (SvOBJECT(SvRV(val)) && freezer &&
	    SvPOK(freezer) && SvCUR(freezer))
	{
	    dSP; ENTER; SAVETMPS; PUSHMARK(sp);
	    XPUSHs(val); PUTBACK;
	    i = perl_call_method(SvPVX(freezer), G_EVAL|G_SCALAR);
	    SPAGAIN;
	    if (SvTRUE(GvSV(errgv)))
		warn("WARNING(Freezer method call failed): %s",
		     SvPVX(GvSV(errgv)));
	    else if (i)
		val = newSVsv(POPs);
	    PUTBACK; FREETMPS; LEAVE;
	    if (i)
		(void)sv_2mortal(val);
	}
	
	ival = SvRV(val);
	flags = SvFLAGS(ival);
	realtype = SvTYPE(ival);
        (void) sprintf(id, "0x%lx", (unsigned long)ival);
	idlen = strlen(id);
	if (SvOBJECT(ival))
	    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);
			}
			else {
			    sv_catpvn(retval, name, 1);
			    sv_catpvn(retval, "{", 1);
			    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;
	    }
	}
	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
		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)++;
	ipad = sv_x(Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp);

	if (realpack) {   /* we have a blessed ref */
	    STRLEN blesslen;
	    char *blessstr = SvPV(bless, blesslen);
	    sv_catpvn(retval, blessstr, blesslen);
	    sv_catpvn(retval, "( ", 2);
	    if (indent >= 2) {
		blesspad = apad;
		apad = newSVsv(apad);
		sv_x(apad, " ", 1, blesslen+2);
	    }
	}

	if (realtype <= SVt_PVBM || realtype == SVt_PVGV) {  /* scalars */
	    if (realpack && realtype != SVt_PVGV) {          /* 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);
		sv_catpvn(retval, ")}", 2);
	    }
	    else {
		sv_catpvn(retval, "\\", 1);
		DD_dump(ival, "", 0, retval, seenhv, postav,
			levelp,	indent, pad, xpad, apad, sep,
			freezer, toaster, purity, deepcopy, quotekeys, bless);
	    }
	}
	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);
	    (void)strcpy(iname, name);
	    inamelen = namelen;
	    if (name[0] == '@') {
		sv_catpvn(retval, "(", 1);
		iname[0] = '$';
	    }
	    else {
		sv_catpvn(retval, "[", 1);
		if (namelen > 0 && name[namelen-1] != ']' && name[namelen-1] != '}') {
		    iname[inamelen++] = '-'; iname[inamelen++] = '>';
		    iname[inamelen] = '\0';
		}
	    }
	    if (iname[0] == '*' && iname[inamelen-1] == '}' && inamelen >= 8 &&
		(instr(iname+inamelen-8, "{SCALAR}") ||
		 instr(iname+inamelen-7, "{ARRAY}") ||
		 instr(iname+inamelen-6, "{HASH}"))) {
		iname[inamelen++] = '-'; iname[inamelen++] = '>';
	    }
	    iname[inamelen++] = '['; iname[inamelen] = '\0';
	    totpad = newSVsv(sep);
	    sv_catsv(totpad, pad);
	    sv_catsv(totpad, apad);

	    for (ix = 0; ix <= ixmax; ++ix) {
		STRLEN ilen;
		SV *elem;
		svp = av_fetch((AV*)ival, ix, FALSE);
		if (svp)
		    elem = *svp;
		else
		    elem = &sv_undef;
		
		ilen = inamelen;
		sv_setiv(ixsv, ix);
                (void) sprintf(iname+ilen, "%ld", ix);
		ilen = strlen(iname);
		iname[ilen++] = ']'; iname[ilen] = '\0';
		if (indent >= 3) {
		    sv_catsv(retval, totpad);
		    sv_catsv(retval, ipad);
		    sv_catpvn(retval, "#", 1);
		    sv_catsv(retval, ixsv);
		}
		sv_catsv(retval, totpad);
		sv_catsv(retval, ipad);
		DD_dump(elem, iname, ilen, retval, seenhv, postav,
			levelp,	indent, pad, xpad, apad, sep,
			freezer, toaster, purity, deepcopy, quotekeys, bless);
		if (ix < ixmax)
		    sv_catpvn(retval, ",", 1);
	    }
	    if (ixmax >= 0) {
		SV *opad = sv_x(Nullsv, SvPVX(xpad), SvCUR(xpad), (*levelp)-1);
		sv_catsv(retval, totpad);
		sv_catsv(retval, opad);
		SvREFCNT_dec(opad);
	    }
	    if (name[0] == '@')
		sv_catpvn(retval, ")", 1);
	    else
		sv_catpvn(retval, "]", 1);
	    SvREFCNT_dec(ixsv);
	    SvREFCNT_dec(totpad);
	    Safefree(iname);
	}
	else if (realtype == SVt_PVHV) {
	    SV *totpad, *newapad;
	    SV *iname, *sname;
	    HE *entry;
	    char *key;
	    I32 klen;
	    SV *hval;
	    
	    iname = newSVpv(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] != '}') {
		    sv_catpvn(iname, "->", 2);
		}
	    }
	    if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 &&
		(instr(name+namelen-8, "{SCALAR}") ||
		 instr(name+namelen-7, "{ARRAY}") ||
		 instr(name+namelen-6, "{HASH}"))) {
		sv_catpvn(iname, "->", 2);
	    }
	    sv_catpvn(iname, "{", 1);
	    totpad = newSVsv(sep);
	    sv_catsv(totpad, pad);
	    sv_catsv(totpad, apad);
	    
	    (void)hv_iterinit((HV*)ival);
	    i = 0;
	    while ((entry = hv_iternext((HV*)ival)))  {
		char *nkey;
		I32 nticks = 0;
		
		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);
		    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;
		    I32 elen = 0;
		    newapad = newSVsv(apad);
		    New(0, extra, klen+4+1, char);
		    while (elen < (klen+4))
			extra[elen++] = ' ';
		    extra[elen] = '\0';
		    sv_catpvn(newapad, extra, elen);
		    Safefree(extra);
		}
		else
		    newapad = apad;

		DD_dump(hval, SvPVX(sname), SvCUR(sname), retval, seenhv,
			postav, levelp,	indent, pad, xpad, newapad, sep,
			freezer, toaster, purity, deepcopy, quotekeys, bless);
		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_catsv(retval, totpad);
		sv_catsv(retval, opad);
		SvREFCNT_dec(opad);
	    }
	    if (name[0] == '%')
		sv_catpvn(retval, ")", 1);
	    else
		sv_catpvn(retval, "}", 1);
	    SvREFCNT_dec(iname);
	    SvREFCNT_dec(totpad);
	}
	else if (realtype == SVt_PVCV) {
	    sv_catpvn(retval, "sub { \"DUMMY\" }", 15);
	    if (purity)
		warn("Encountered CODE ref, using dummy placeholder");
	}
	else {
	    warn("cannot handle ref type %ld", realtype);
	}

	if (realpack) {  /* free blessed allocs */
	    if (indent >= 2) {
		SvREFCNT_dec(apad);
		apad = blesspad;
	    }
	    sv_catpvn(retval, ", '", 3);
	    sv_catpvn(retval, realpack, strlen(realpack));
	    sv_catpvn(retval, "' )", 3);
	    if (toaster && SvPOK(toaster) && SvCUR(toaster)) {
		sv_catpvn(retval, "->", 2);
		sv_catsv(retval, toaster);
		sv_catpvn(retval, "()", 2);
	    }
	}
	SvREFCNT_dec(ipad);
	(*levelp)--;
    }
    else {
	STRLEN i;
	
	if (namelen) {
	    (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))) {
		SV *othername;
		if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)) {
		    sv_catsv(retval, othername);
		    return 1;
		}
	    }
	    else {
		SV *namesv;
		namesv = newSVpv("\\", 1);
		sv_catpvn(namesv, 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);
	    }
	}
	
	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);
	    ++c; --i;			/* just get the name */
	    if (i >= 6 && strncmp(c, "main::", 6) == 0) {
		c += 4;
		i -= 4;
	    }
	    if (needs_quote(c)) {
		sv_grow(retval, SvCUR(retval)+6+2*i);
		r = SvPVX(retval)+SvCUR(retval);
		r[0] = '*'; r[1] = '{';	r[2] = '\'';
		i += esc_q(r+3, c, i);
		i += 3;
		r[i++] = '\''; r[i++] = '}';
		r[i] = '\0';
	    }
	    else {
		sv_grow(retval, SvCUR(retval)+i+2);
		r = SvPVX(retval)+SvCUR(retval);
		r[0] = '*'; strcpy(r+1, c);
		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);
		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) {
			I32 nlevel = 0;
			SV *postentry = newSVpv(r,i);
			
			sv_setsv(nname, postentry);
			sv_catpvn(nname, entries[j], sizes[j]);
			sv_catpvn(postentry, " = ", 3);
			av_push(postav, postentry);
			e = newRV(e);
			
			SvCUR(newapad) = 0;
			if (indent >= 2)
			    (void)sv_x(newapad, " ", 1, SvCUR(postentry));
			
			DD_dump(e, SvPVX(nname), SvCUR(nname), postentry,
				seenhv, postav, &nlevel, indent, pad, xpad,
				newapad, sep, freezer, toaster, purity,
				deepcopy, quotekeys, bless);
			SvREFCNT_dec(e);
		    }
		}
		
		SvREFCNT_dec(newapad);
		SvREFCNT_dec(nname);
	    }
	}
	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';
	}
	SvCUR_set(retval, SvCUR(retval)+i);
    }

    if (deepcopy && idlen)
	(void)hv_delete(seenhv, id, idlen, G_DISCARD);
	
    return 1;
}


MODULE = Data::Dumper		PACKAGE = Data::Dumper         PREFIX = Data_Dumper_

#
# This is the exact equivalent of Dump.  Well, almost. The things that are
# different as of now (due to Laziness):
#   * doesnt do double-quotes yet.
#

void
Data_Dumper_Dumpxs(href, ...)
	SV	*href;
	PROTOTYPE: $;$$
	PPCODE:
	{
	    HV *hv;
	    SV *retval, *valstr;
	    HV *seenhv = Nullhv;
	    AV *postav, *todumpav, *namesav;
	    I32 level = 0;
	    I32 indent, terse, useqq, i, imax, postlen;
	    SV **svp;
	    SV *val, *name, *pad, *xpad, *apad, *sep, *tmp, *varname;
	    SV *freezer, *toaster, *bless;
	    I32 purity, deepcopy, quotekeys;
	    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)");
		
		ENTER;
		SAVETMPS;
		
		PUSHMARK(sp);
		XPUSHs(href);
		XPUSHs(sv_2mortal(newSVsv(valarray)));
		XPUSHs(sv_2mortal(newSVsv(namearray)));
		PUTBACK;
		i = perl_call_method("new", G_SCALAR);
		SPAGAIN;
		if (i)
		    href = newSVsv(POPs);

		PUTBACK;
		FREETMPS;
		LEAVE;
		if (i)
		    (void)sv_2mortal(href);
	    }

	    todumpav = namesav = Nullav;
	    seenhv = Nullhv;
	    val = pad = xpad = apad = sep = tmp = varname
		= freezer = toaster = bless = &sv_undef;
	    name = sv_newmortal();
	    indent = 2;
	    terse = useqq = purity = deepcopy = 0;
	    quotekeys = 1;
	    
	    retval = newSVpv("", 0);
	    if (SvROK(href)
		&& (hv = (HV*)SvRV((SV*)href))
		&& SvTYPE(hv) == SVt_PVHV)		{

		if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp))
		    seenhv = (HV*)SvRV(*svp);
		if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp))
		    todumpav = (AV*)SvRV(*svp);
		if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp))
		    namesav = (AV*)SvRV(*svp);
		if ((svp = hv_fetch(hv, "indent", 6, FALSE)))
		    indent = SvIV(*svp);
		if ((svp = hv_fetch(hv, "purity", 6, FALSE)))
		    purity = SvIV(*svp);
		if ((svp = hv_fetch(hv, "terse", 5, FALSE)))
		    terse = SvTRUE(*svp);
		if ((svp = hv_fetch(hv, "useqq", 5, FALSE)))
		    useqq = SvTRUE(*svp);
		if ((svp = hv_fetch(hv, "pad", 3, FALSE)))
		    pad = *svp;
		if ((svp = hv_fetch(hv, "xpad", 4, FALSE)))
		    xpad = *svp;
		if ((svp = hv_fetch(hv, "apad", 4, FALSE)))
		    apad = *svp;
		if ((svp = hv_fetch(hv, "sep", 3, FALSE)))
		    sep = *svp;
		if ((svp = hv_fetch(hv, "varname", 7, FALSE)))
		    varname = *svp;
		if ((svp = hv_fetch(hv, "freezer", 7, FALSE)))
		    freezer = *svp;
		if ((svp = hv_fetch(hv, "toaster", 7, FALSE)))
		    toaster = *svp;
		if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE)))
		    deepcopy = SvTRUE(*svp);
		if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE)))
		    quotekeys = SvTRUE(*svp);
		if ((svp = hv_fetch(hv, "bless", 5, FALSE)))
		    bless = *svp;
		postav = newAV();

		if (todumpav)
		    imax = av_len(todumpav);
		else
		    imax = -1;
		valstr = newSVpv("",0);
		for (i = 0; i <= imax; ++i) {
		    SV *newapad;
		    
		    av_clear(postav);
		    if ((svp = av_fetch(todumpav, i, FALSE)))
			val = *svp;
		    else
			val = &sv_undef;
		    if ((svp = av_fetch(namesav, i, TRUE)))
			sv_setsv(name, *svp);
		    else
			SvOK_off(name);
		    
		    if (SvOK(name)) {
			if ((SvPVX(name))[0] == '*') {
			    if (SvROK(val)) {
				switch (SvTYPE(SvRV(val))) {
				case SVt_PVAV:
				    (SvPVX(name))[0] = '@';
				    break;
				case SVt_PVHV:
				    (SvPVX(name))[0] = '%';
				    break;
				case SVt_PVCV:
				    (SvPVX(name))[0] = '*';
				    break;
				default:
				    (SvPVX(name))[0] = '$';
				    break;
				}
			    }
			    else
				(SvPVX(name))[0] = '$';
			}
			else if ((SvPVX(name))[0] != '$')
			    sv_insert(name, 0, 0, "$", 1);
		    }
		    else {
			STRLEN nchars = 0;
			sv_setpvn(name, "$", 1);
			sv_catsv(name, varname);
			(void) sprintf(tmpbuf, "%ld", i+1);
			nchars = strlen(tmpbuf);
			sv_catpvn(name, tmpbuf, nchars);
		    }
		    
		    if (indent >= 2) {
			SV *tmpsv = sv_x(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,
			    postav, &level, indent, pad, xpad, newapad, sep,
			    freezer, toaster, purity, deepcopy, quotekeys,
			    bless);
		    
		    if (indent >= 2)
			SvREFCNT_dec(newapad);

		    postlen = av_len(postav);
		    if (postlen >= 0 || !terse) {
			sv_insert(valstr, 0, 0, " = ", 3);
			sv_insert(valstr, 0, 0, SvPVX(name), SvCUR(name));
			sv_catpvn(valstr, ";", 1);
		    }
		    sv_catsv(retval, pad);
		    sv_catsv(retval, valstr);
		    sv_catsv(retval, sep);
		    if (postlen >= 0) {
			I32 i;
			sv_catsv(retval, pad);
			for (i = 0; i <= postlen; ++i) {
			    SV *elem;
			    svp = av_fetch(postav, i, FALSE);
			    if (svp && (elem = *svp)) {
				sv_catsv(retval, elem);
				if (i < postlen) {
				    sv_catpvn(retval, ";", 1);
				    sv_catsv(retval, sep);
				    sv_catsv(retval, pad);
				}
			    }
			}
			sv_catpvn(retval, ";", 1);
			    sv_catsv(retval, sep);
		    }
		    sv_setpvn(valstr, "", 0);
		    if (gimme == G_ARRAY) {
			XPUSHs(sv_2mortal(retval));
			if (i < imax)	/* not the last time thro ? */
			    retval = newSVpv("",0);
		    }
		}
		SvREFCNT_dec(postav);
		SvREFCNT_dec(valstr);
	    }
	    else
		croak("Call to new() method failed to return HASH ref");
	    if (gimme == G_SCALAR)
		XPUSHs(sv_2mortal(retval));
	}
Commit	Line	Data
823edd99 GS	1	#ifdef __cplusplus
	2	extern "C" {
	3	#endif
	4	#include "EXTERN.h"
	5	#include "perl.h"
	6	#include "XSUB.h"
	7	#ifdef __cplusplus
	8	}
	9	#endif
	10
	11	static SV *freezer;
	12	static SV *toaster;
	13
	14	static I32 num_q _((char *s));
	15	static I32 esc_q _((char dest, char src, STRLEN slen));
	16	static SV sv_x _((SV sv, char *str, STRLEN len, I32 n));
	17	static I32 DD_dump _((SV val, char name, STRLEN namelen, SV *retval,
	18	HV seenhv, AV postav, I32 *levelp, I32 indent,
	19	SV pad, SV xpad, SV apad, SV sep,
	20	SV freezer, SV toaster,
	21	I32 purity, I32 deepcopy, I32 quotekeys, SV *bless));
	22
	23	/* does a string need to be protected? */
	24	static I32
	25	needs_quote(register char *s)
	26	{
	27	TOP:
	28	if (s[0] == ':') {
	29	if (*++s) {
	30	if (*s++ != ':')
	31	return 1;
	32	}
	33	else
	34	return 1;
	35	}
	36	if (isIDFIRST(*s)) {
	37	while (*++s)
	38	if (!isALNUM(*s))
	39	if (*s == ':')
	40	goto TOP;
	41	else
	42	return 1;
	43	}
	44	else
	45	return 1;
	46	return 0;
	47	}
	48
	49	/* count the number of "'"s and "\"s in string */
	50	static I32
	51	num_q(register char *s)
	52	{
	53	register I32 ret = 0;
	54
	55	while (*s) {
	56	if (s == '\'' \|\| s == '\\')
	57	++ret;
	58	++s;
	59	}
	60	return ret;
	61	}
	62
	63
	64	/* returns number of chars added to escape "'"s and "\"s in s */
65	/* slen number of characters in s will be escaped */
66	/* destination must be long enough for additional chars */
67	static I32
68	esc_q(register char d, register char s, register STRLEN slen)
69	{
70	register I32 ret = 0;
71
72	while (slen > 0) {
73	switch (*s) {
74	case '\'':
75	case '\\':
76	*d = '\\';
77	++d; ++ret;
78	default:
79	d = s;
80	++d; ++s; --slen;
81	break;
82	}
83	}
84	return ret;
85	}
86
87	/* append a repeated string to an SV */
88	static SV *
89	sv_x(SV sv, register char str, STRLEN len, I32 n)
90	{
91	if (sv == Nullsv)
92	sv = newSVpv("", 0);
93	else
94	assert(SvTYPE(sv) >= SVt_PV);
95
96	if (n > 0) {
97	SvGROW(sv, len*n + SvCUR(sv) + 1);
98	if (len == 1) {
99	char *start = SvPVX(sv) + SvCUR(sv);
100	SvCUR(sv) += n;
101	start[n] = '\0';
102	while (n > 0)
103	start[--n] = str[0];
104	}
105	else
106	while (n > 0) {
107	sv_catpvn(sv, str, len);
108	--n;
109	}
110	}
111	return sv;
112	}
113
114	/*
115	* This ought to be split into smaller functions. (it is one long function since
116	* it exactly parallels the perl version, which was one long thing for
117	* efficiency raisins.) Ugggh!
118	*/
119	static I32
120	DD_dump(SV val, char name, STRLEN namelen, SV retval, HV seenhv,
121	AV postav, I32 levelp, I32 indent, SV pad, SV xpad,
122	SV apad, SV sep, SV freezer, SV toaster, I32 purity,
123	I32 deepcopy, I32 quotekeys, SV *bless)
124	{
125	char tmpbuf[128];
126	U32 i;
127	char c, r, *realpack, id[128];
128	SV **svp;
129	SV *sv;
130	SV *blesspad = Nullsv;
131	SV *ipad;
132	SV *ival;
133	AV *seenentry;
134	char *iname;
135	STRLEN inamelen, idlen = 0;
136	U32 flags;
137	U32 realtype;
138
139	if (!val)
140	return 0;
141
142	flags = SvFLAGS(val);
143	realtype = SvTYPE(val);
144
145	if (SvGMAGICAL(val))
146	mg_get(val);
147	if (val == &sv_undef \|\| !SvOK(val)) {
148	sv_catpvn(retval, "undef", 5);
149	return 1;
150	}
151	if (SvROK(val)) {
152
153	if (SvOBJECT(SvRV(val)) && freezer &&
154	SvPOK(freezer) && SvCUR(freezer))
155	{
156	dSP; ENTER; SAVETMPS; PUSHMARK(sp);
157	XPUSHs(val); PUTBACK;
158	i = perl_call_method(SvPVX(freezer), G_EVAL\|G_SCALAR);
159	SPAGAIN;
160	if (SvTRUE(GvSV(errgv)))
161	warn("WARNING(Freezer method call failed): %s",
162	SvPVX(GvSV(errgv)));
163	else if (i)
164	val = newSVsv(POPs);
165	PUTBACK; FREETMPS; LEAVE;
166	if (i)
167	(void)sv_2mortal(val);
168	}
169
170	ival = SvRV(val);
171	flags = SvFLAGS(ival);
172	realtype = SvTYPE(ival);
173	(void) sprintf(id, "0x%lx", (unsigned long)ival);
174	idlen = strlen(id);
175	if (SvOBJECT(ival))
176	realpack = HvNAME(SvSTASH(ival));
177	else
178	realpack = Nullch;
179	if ((svp = hv_fetch(seenhv, id, idlen, FALSE)) &&
180	(sv = *svp) && SvROK(sv) &&
181	(seenentry = (AV*)SvRV(sv))) {
182	SV *othername;
183	if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)) {
184	if (purity && *levelp > 0) {
185	SV *postentry;
186
187	if (realtype == SVt_PVHV)
188	sv_catpvn(retval, "{}", 2);
189	else if (realtype == SVt_PVAV)
190	sv_catpvn(retval, "[]", 2);
191	else
192	sv_catpvn(retval, "''", 2);
193	postentry = newSVpv(name, namelen);
194	sv_catpvn(postentry, " = ", 3);
195	sv_catsv(postentry, othername);
196	av_push(postav, postentry);
197	}
198	else {
199	if (name[0] == '@' \|\| name[0] == '%') {
200	if ((SvPVX(othername))[0] == '\\' &&
201	(SvPVX(othername))[1] == name[0]) {
202	sv_catpvn(retval, SvPVX(othername)+1, SvCUR(othername)-1);
203	}
204	else {
205	sv_catpvn(retval, name, 1);
206	sv_catpvn(retval, "{", 1);
207	sv_catsv(retval, othername);
208	sv_catpvn(retval, "}", 1);
209	}
210	}
211	else
212	sv_catsv(retval, othername);
213	}
214	return 1;
215	}
216	else {
217	warn("ref name not found for %s", id);
218	return 0;
219	}
220	}
221	else { /* store our name and continue */
222	SV *namesv;
223	if (name[0] == '@' \|\| name[0] == '%') {
224	namesv = newSVpv("\\", 1);
225	sv_catpvn(namesv, name, namelen);
226	}
227	else if (realtype == SVt_PVCV && name[0] == '*') {
228	namesv = newSVpv("\\", 2);
229	sv_catpvn(namesv, name, namelen);
230	(SvPVX(namesv))[1] = '&';
231	}
232	else
233	namesv = newSVpv(name, namelen);
234	seenentry = newAV();
235	av_push(seenentry, namesv);
236	(void)SvREFCNT_inc(val);
237	av_push(seenentry, val);
238	(void)hv_store(seenhv, id, strlen(id), newRV((SV*)seenentry), 0);
239	SvREFCNT_dec(seenentry);
240	}
241
242	(*levelp)++;
243	ipad = sv_x(Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp);
244
245	if (realpack) { /* we have a blessed ref */
246	STRLEN blesslen;
247	char *blessstr = SvPV(bless, blesslen);
248	sv_catpvn(retval, blessstr, blesslen);
249	sv_catpvn(retval, "( ", 2);
250	if (indent >= 2) {
251	blesspad = apad;
252	apad = newSVsv(apad);
253	sv_x(apad, " ", 1, blesslen+2);
254	}
255	}
256
257	if (realtype <= SVt_PVBM \|\| realtype == SVt_PVGV) { /* scalars */
258	if (realpack && realtype != SVt_PVGV) { /* blessed */
259	sv_catpvn(retval, "do{\\(my $o = ", 13);
260	DD_dump(ival, "", 0, retval, seenhv, postav,
261	levelp, indent, pad, xpad, apad, sep,
262	freezer, toaster, purity, deepcopy, quotekeys, bless);
263	sv_catpvn(retval, ")}", 2);
264	}
265	else {
266	sv_catpvn(retval, "\\", 1);
267	DD_dump(ival, "", 0, retval, seenhv, postav,
268	levelp, indent, pad, xpad, apad, sep,
269	freezer, toaster, purity, deepcopy, quotekeys, bless);
270	}
271	}
272	else if (realtype == SVt_PVAV) {
273	SV *totpad;
274	I32 ix = 0;
275	I32 ixmax = av_len((AV *)ival);
276
277	SV *ixsv = newSViv(0);
278	/* allowing for a 24 char wide array index */
279	New(0, iname, namelen+28, char);
280	(void)strcpy(iname, name);
281	inamelen = namelen;
282	if (name[0] == '@') {
283	sv_catpvn(retval, "(", 1);
284	iname[0] = '$';
285	}
286	else {
287	sv_catpvn(retval, "[", 1);
288	if (namelen > 0 && name[namelen-1] != ']' && name[namelen-1] != '}') {
289	iname[inamelen++] = '-'; iname[inamelen++] = '>';
290	iname[inamelen] = '\0';
291	}
292	}
293	if (iname[0] == '*' && iname[inamelen-1] == '}' && inamelen >= 8 &&
294	(instr(iname+inamelen-8, "{SCALAR}") \|\|
295	instr(iname+inamelen-7, "{ARRAY}") \|\|
296	instr(iname+inamelen-6, "{HASH}"))) {
297	iname[inamelen++] = '-'; iname[inamelen++] = '>';
298	}
299	iname[inamelen++] = '['; iname[inamelen] = '\0';
300	totpad = newSVsv(sep);
301	sv_catsv(totpad, pad);
302	sv_catsv(totpad, apad);
303
304	for (ix = 0; ix <= ixmax; ++ix) {
305	STRLEN ilen;
306	SV *elem;
307	svp = av_fetch((AV*)ival, ix, FALSE);
308	if (svp)
309	elem = *svp;
310	else
311	elem = &sv_undef;
312
313	ilen = inamelen;
314	sv_setiv(ixsv, ix);
315	(void) sprintf(iname+ilen, "%ld", ix);
316	ilen = strlen(iname);
317	iname[ilen++] = ']'; iname[ilen] = '\0';
318	if (indent >= 3) {
319	sv_catsv(retval, totpad);
320	sv_catsv(retval, ipad);
321	sv_catpvn(retval, "#", 1);
322	sv_catsv(retval, ixsv);
323	}
324	sv_catsv(retval, totpad);
325	sv_catsv(retval, ipad);
326	DD_dump(elem, iname, ilen, retval, seenhv, postav,
327	levelp, indent, pad, xpad, apad, sep,
328	freezer, toaster, purity, deepcopy, quotekeys, bless);
329	if (ix < ixmax)
330	sv_catpvn(retval, ",", 1);
331	}
332	if (ixmax >= 0) {
333	SV opad = sv_x(Nullsv, SvPVX(xpad), SvCUR(xpad), (levelp)-1);
334	sv_catsv(retval, totpad);
335	sv_catsv(retval, opad);
336	SvREFCNT_dec(opad);
337	}
338	if (name[0] == '@')
339	sv_catpvn(retval, ")", 1);
340	else
341	sv_catpvn(retval, "]", 1);
342	SvREFCNT_dec(ixsv);
343	SvREFCNT_dec(totpad);
344	Safefree(iname);
345	}
346	else if (realtype == SVt_PVHV) {
347	SV totpad, newapad;
348	SV iname, sname;
349	HE *entry;
350	char *key;
351	I32 klen;
352	SV *hval;
353
354	iname = newSVpv(name, namelen);
355	if (name[0] == '%') {
356	sv_catpvn(retval, "(", 1);
357	(SvPVX(iname))[0] = '$';
358	}
359	else {
360	sv_catpvn(retval, "{", 1);
361	if (namelen > 0 && name[namelen-1] != ']' && name[namelen-1] != '}') {
362	sv_catpvn(iname, "->", 2);
363	}
364	}
365	if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 &&
366	(instr(name+namelen-8, "{SCALAR}") \|\|
367	instr(name+namelen-7, "{ARRAY}") \|\|
368	instr(name+namelen-6, "{HASH}"))) {
369	sv_catpvn(iname, "->", 2);
370	}
371	sv_catpvn(iname, "{", 1);
372	totpad = newSVsv(sep);
373	sv_catsv(totpad, pad);
374	sv_catsv(totpad, apad);
375
376	(void)hv_iterinit((HV*)ival);
377	i = 0;
378	while ((entry = hv_iternext((HV*)ival))) {
379	char *nkey;
380	I32 nticks = 0;
381
382	if (i)
383	sv_catpvn(retval, ",", 1);
384	i++;
385	key = hv_iterkey(entry, &klen);
386	hval = hv_iterval((HV*)ival, entry);
387
388	if (quotekeys \|\| needs_quote(key)) {
389	nticks = num_q(key);
390	New(0, nkey, klen+nticks+3, char);
391	nkey[0] = '\'';
392	if (nticks)
393	klen += esc_q(nkey+1, key, klen);
394	else
395	(void)Copy(key, nkey+1, klen, char);
396	nkey[++klen] = '\'';
397	nkey[++klen] = '\0';
398	}
399	else {
400	New(0, nkey, klen, char);
401	(void)Copy(key, nkey, klen, char);
402	}
403
404	sname = newSVsv(iname);
405	sv_catpvn(sname, nkey, klen);
406	sv_catpvn(sname, "}", 1);
407
408	sv_catsv(retval, totpad);
409	sv_catsv(retval, ipad);
410	sv_catpvn(retval, nkey, klen);
411	sv_catpvn(retval, " => ", 4);
412	if (indent >= 2) {
413	char *extra;
414	I32 elen = 0;
415	newapad = newSVsv(apad);
416	New(0, extra, klen+4+1, char);
417	while (elen < (klen+4))
418	extra[elen++] = ' ';
419	extra[elen] = '\0';
420	sv_catpvn(newapad, extra, elen);
421	Safefree(extra);
422	}
423	else
424	newapad = apad;
425
426	DD_dump(hval, SvPVX(sname), SvCUR(sname), retval, seenhv,
427	postav, levelp, indent, pad, xpad, newapad, sep,
428	freezer, toaster, purity, deepcopy, quotekeys, bless);
429	SvREFCNT_dec(sname);
430	Safefree(nkey);
431	if (indent >= 2)
432	SvREFCNT_dec(newapad);
433	}
434	if (i) {
435	SV opad = sv_x(Nullsv, SvPVX(xpad), SvCUR(xpad), levelp-1);
436	sv_catsv(retval, totpad);
437	sv_catsv(retval, opad);
438	SvREFCNT_dec(opad);
439	}
440	if (name[0] == '%')
441	sv_catpvn(retval, ")", 1);
442	else
443	sv_catpvn(retval, "}", 1);
444	SvREFCNT_dec(iname);
445	SvREFCNT_dec(totpad);
446	}
447	else if (realtype == SVt_PVCV) {
448	sv_catpvn(retval, "sub { \"DUMMY\" }", 15);
449	if (purity)
450	warn("Encountered CODE ref, using dummy placeholder");
451	}
452	else {
453	warn("cannot handle ref type %ld", realtype);
454	}
455
456	if (realpack) { /* free blessed allocs */
457	if (indent >= 2) {
458	SvREFCNT_dec(apad);
459	apad = blesspad;
460	}
461	sv_catpvn(retval, ", '", 3);
462	sv_catpvn(retval, realpack, strlen(realpack));
463	sv_catpvn(retval, "' )", 3);
464	if (toaster && SvPOK(toaster) && SvCUR(toaster)) {
465	sv_catpvn(retval, "->", 2);
466	sv_catsv(retval, toaster);
467	sv_catpvn(retval, "()", 2);
468	}
469	}
470	SvREFCNT_dec(ipad);
471	(*levelp)--;
472	}
473	else {
474	STRLEN i;
475
476	if (namelen) {
477	(void) sprintf(id, "0x%lx", (unsigned long)val);
478	if ((svp = hv_fetch(seenhv, id, (idlen = strlen(id)), FALSE)) &&
479	(sv = *svp) && SvROK(sv) &&
480	(seenentry = (AV*)SvRV(sv))) {
481	SV *othername;
482	if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)) {
483	sv_catsv(retval, othername);
484	return 1;
485	}
486	}
487	else {
488	SV *namesv;
489	namesv = newSVpv("\\", 1);
490	sv_catpvn(namesv, name, namelen);
491	seenentry = newAV();
492	av_push(seenentry, namesv);
493	(void)SvREFCNT_inc(val);
494	av_push(seenentry, val);
495	(void)hv_store(seenhv, id, strlen(id), newRV((SV*)seenentry), 0);
496	SvREFCNT_dec(seenentry);
497	}
498	}
499
500	if (SvIOK(val)) {
501	STRLEN len;
502	i = SvIV(val);
503	(void) sprintf(tmpbuf, "%d", i);
504	len = strlen(tmpbuf);
505	sv_catpvn(retval, tmpbuf, len);
506	return 1;
507	}
508	else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */
509	c = SvPV(val, i);
510	++c; --i; /* just get the name */
511	if (i >= 6 && strncmp(c, "main::", 6) == 0) {
512	c += 4;
513	i -= 4;
514	}
515	if (needs_quote(c)) {
516	sv_grow(retval, SvCUR(retval)+6+2*i);
517	r = SvPVX(retval)+SvCUR(retval);
518	r[0] = '*'; r[1] = '{'; r[2] = '\'';
519	i += esc_q(r+3, c, i);
520	i += 3;
521	r[i++] = '\''; r[i++] = '}';
522	r[i] = '\0';
523	}
524	else {
525	sv_grow(retval, SvCUR(retval)+i+2);
526	r = SvPVX(retval)+SvCUR(retval);
527	r[0] = '*'; strcpy(r+1, c);
528	i++;
529	}
530
531	if (purity) {
532	static char *entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" };
533	static STRLEN sizes[] = { 8, 7, 6 };
534	SV *e;
535	SV *nname = newSVpv("", 0);
536	SV *newapad = newSVpv("", 0);
537	GV gv = (GV)val;
538	I32 j;
539
540	for (j=0; j<3; j++) {
541	e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV)GvAV(gv) : (SV)GvHV(gv));
542	if (e) {
543	I32 nlevel = 0;
544	SV *postentry = newSVpv(r,i);
545
546	sv_setsv(nname, postentry);
547	sv_catpvn(nname, entries[j], sizes[j]);
548	sv_catpvn(postentry, " = ", 3);
549	av_push(postav, postentry);
550	e = newRV(e);
551
552	SvCUR(newapad) = 0;
553	if (indent >= 2)
554	(void)sv_x(newapad, " ", 1, SvCUR(postentry));
555
556	DD_dump(e, SvPVX(nname), SvCUR(nname), postentry,
557	seenhv, postav, &nlevel, indent, pad, xpad,
558	newapad, sep, freezer, toaster, purity,
559	deepcopy, quotekeys, bless);
560	SvREFCNT_dec(e);
561	}
562	}
563
564	SvREFCNT_dec(newapad);
565	SvREFCNT_dec(nname);
566	}
567	}
568	else {
569	c = SvPV(val, i);
570	sv_grow(retval, SvCUR(retval)+3+2*i);
571	r = SvPVX(retval)+SvCUR(retval);
572	r[0] = '\'';
573	i += esc_q(r+1, c, i);
574	++i;
575	r[i++] = '\'';
576	r[i] = '\0';
577	}
578	SvCUR_set(retval, SvCUR(retval)+i);
579	}
580
581	if (deepcopy && idlen)
582	(void)hv_delete(seenhv, id, idlen, G_DISCARD);
583
584	return 1;
585	}
586
587
588	MODULE = Data::Dumper PACKAGE = Data::Dumper PREFIX = Data_Dumper_
589
590	#
591	# This is the exact equivalent of Dump. Well, almost. The things that are
592	# different as of now (due to Laziness):
593	# * doesnt do double-quotes yet.
594	#
595
596	void
597	Data_Dumper_Dumpxs(href, ...)
598	SV *href;
599	PROTOTYPE: $;$$
600	PPCODE:
601	{
602	HV *hv;
603	SV retval, valstr;
604	HV *seenhv = Nullhv;
605	AV postav, todumpav, *namesav;
606	I32 level = 0;
607	I32 indent, terse, useqq, i, imax, postlen;
608	SV **svp;
609	SV val, name, pad, xpad, apad, sep, tmp, varname;
610	SV freezer, toaster, *bless;
611	I32 purity, deepcopy, quotekeys;
612	char tmpbuf[1024];
613	I32 gimme = GIMME;
614
615	if (!SvROK(href)) { /* call new to get an object first */
616	SV *valarray;
617	SV *namearray;
618
619	if (items == 3) {
620	valarray = ST(1);
621	namearray = ST(2);
622	}
623	else
624	croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, NAME_ARY_REF)");
625
626	ENTER;
627	SAVETMPS;
628
629	PUSHMARK(sp);
630	XPUSHs(href);
631	XPUSHs(sv_2mortal(newSVsv(valarray)));
632	XPUSHs(sv_2mortal(newSVsv(namearray)));
633	PUTBACK;
634	i = perl_call_method("new", G_SCALAR);
635	SPAGAIN;
636	if (i)
637	href = newSVsv(POPs);
638
639	PUTBACK;
640	FREETMPS;
641	LEAVE;
642	if (i)
643	(void)sv_2mortal(href);
644	}
645
646	todumpav = namesav = Nullav;
647	seenhv = Nullhv;
648	val = pad = xpad = apad = sep = tmp = varname
649	= freezer = toaster = bless = &sv_undef;
650	name = sv_newmortal();
651	indent = 2;
652	terse = useqq = purity = deepcopy = 0;
653	quotekeys = 1;
654
655	retval = newSVpv("", 0);
656	if (SvROK(href)
657	&& (hv = (HV)SvRV((SV)href))
658	&& SvTYPE(hv) == SVt_PVHV) {
659
660	if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp))
661	seenhv = (HV)SvRV(svp);
662	if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp))
663	todumpav = (AV)SvRV(svp);
664	if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp))
665	namesav = (AV)SvRV(svp);
666	if ((svp = hv_fetch(hv, "indent", 6, FALSE)))
667	indent = SvIV(*svp);
668	if ((svp = hv_fetch(hv, "purity", 6, FALSE)))
669	purity = SvIV(*svp);
670	if ((svp = hv_fetch(hv, "terse", 5, FALSE)))
671	terse = SvTRUE(*svp);
672	if ((svp = hv_fetch(hv, "useqq", 5, FALSE)))
673	useqq = SvTRUE(*svp);
674	if ((svp = hv_fetch(hv, "pad", 3, FALSE)))
675	pad = *svp;
676	if ((svp = hv_fetch(hv, "xpad", 4, FALSE)))
677	xpad = *svp;
678	if ((svp = hv_fetch(hv, "apad", 4, FALSE)))
679	apad = *svp;
680	if ((svp = hv_fetch(hv, "sep", 3, FALSE)))
681	sep = *svp;
682	if ((svp = hv_fetch(hv, "varname", 7, FALSE)))
683	varname = *svp;
684	if ((svp = hv_fetch(hv, "freezer", 7, FALSE)))
685	freezer = *svp;
686	if ((svp = hv_fetch(hv, "toaster", 7, FALSE)))
687	toaster = *svp;
688	if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE)))
689	deepcopy = SvTRUE(*svp);
690	if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE)))
691	quotekeys = SvTRUE(*svp);
692	if ((svp = hv_fetch(hv, "bless", 5, FALSE)))
693	bless = *svp;
694	postav = newAV();
695
696	if (todumpav)
697	imax = av_len(todumpav);
698	else
699	imax = -1;
700	valstr = newSVpv("",0);
701	for (i = 0; i <= imax; ++i) {
702	SV *newapad;
703
704	av_clear(postav);
705	if ((svp = av_fetch(todumpav, i, FALSE)))
706	val = *svp;
707	else
708	val = &sv_undef;
709	if ((svp = av_fetch(namesav, i, TRUE)))
710	sv_setsv(name, *svp);
711	else
712	SvOK_off(name);
713
714	if (SvOK(name)) {
715	if ((SvPVX(name))[0] == '*') {
716	if (SvROK(val)) {
717	switch (SvTYPE(SvRV(val))) {
718	case SVt_PVAV:
719	(SvPVX(name))[0] = '@';
720	break;
721	case SVt_PVHV:
722	(SvPVX(name))[0] = '%';
723	break;
724	case SVt_PVCV:
725	(SvPVX(name))[0] = '*';
726	break;
727	default:
728	(SvPVX(name))[0] = '$';
729	break;
730	}
731	}
732	else
733	(SvPVX(name))[0] = '$';
734	}
735	else if ((SvPVX(name))[0] != '$')
736	sv_insert(name, 0, 0, "$", 1);
737	}
738	else {
739	STRLEN nchars = 0;
740	sv_setpvn(name, "$", 1);
741	sv_catsv(name, varname);
742	(void) sprintf(tmpbuf, "%ld", i+1);
743	nchars = strlen(tmpbuf);
744	sv_catpvn(name, tmpbuf, nchars);
745	}
746
747	if (indent >= 2) {
748	SV *tmpsv = sv_x(Nullsv, " ", 1, SvCUR(name)+3);
749	newapad = newSVsv(apad);
750	sv_catsv(newapad, tmpsv);
751	SvREFCNT_dec(tmpsv);
752	}
753	else
754	newapad = apad;
755
756	DD_dump(val, SvPVX(name), SvCUR(name), valstr, seenhv,
757	postav, &level, indent, pad, xpad, newapad, sep,
758	freezer, toaster, purity, deepcopy, quotekeys,
759	bless);
760
761	if (indent >= 2)
762	SvREFCNT_dec(newapad);
763
764	postlen = av_len(postav);
765	if (postlen >= 0 \|\| !terse) {
766	sv_insert(valstr, 0, 0, " = ", 3);
767	sv_insert(valstr, 0, 0, SvPVX(name), SvCUR(name));
768	sv_catpvn(valstr, ";", 1);
769	}
770	sv_catsv(retval, pad);
771	sv_catsv(retval, valstr);
772	sv_catsv(retval, sep);
773	if (postlen >= 0) {
774	I32 i;
775	sv_catsv(retval, pad);
776	for (i = 0; i <= postlen; ++i) {
777	SV *elem;
778	svp = av_fetch(postav, i, FALSE);
779	if (svp && (elem = *svp)) {
780	sv_catsv(retval, elem);
781	if (i < postlen) {
782	sv_catpvn(retval, ";", 1);
783	sv_catsv(retval, sep);
784	sv_catsv(retval, pad);
785	}
786	}
787	}
788	sv_catpvn(retval, ";", 1);
789	sv_catsv(retval, sep);
790	}
791	sv_setpvn(valstr, "", 0);
792	if (gimme == G_ARRAY) {
793	XPUSHs(sv_2mortal(retval));
794	if (i < imax) /* not the last time thro ? */
795	retval = newSVpv("",0);
796	}
797	}
798	SvREFCNT_dec(postav);
799	SvREFCNT_dec(valstr);
800	}
801	else
802	croak("Call to new() method failed to return HASH ref");
803	if (gimme == G_SCALAR)
804	XPUSHs(sv_2mortal(retval));
805	}