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

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

static SV	*freezer;
static SV	*toaster;

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));

/* 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 STRLEN slen)
{
    register I32 ret = 0;

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