dumper.xs

perl 解释器

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