1 #define PERL_NO_GET_CONTEXT
2 #include "EXTERN.h"
3 #include "perl.h"
4 #include "XSUB.h"
5 
6 static I32 num_q (char *s, STRLEN slen);
7 static I32 esc_q (char *dest, char *src, STRLEN slen);
8 static I32 esc_q_utf8 (pTHX_ SV *sv, char *src, STRLEN slen);
9 static SV *sv_x (pTHX_ SV *sv, const char *str, STRLEN len, I32 n);
10 static I32 DD_dump (pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval,
11 		    HV *seenhv, AV *postav, I32 *levelp, I32 indent,
12 		    SV *pad, SV *xpad, SV *apad, SV *sep, SV *pair,
13 		    SV *freezer, SV *toaster,
14 		    I32 purity, I32 deepcopy, I32 quotekeys, SV *bless,
15 		    I32 maxdepth, SV *sortkeys);
16 
17 #ifndef HvNAME_get
18 #define HvNAME_get HvNAME
19 #endif
20 
21 #if PERL_VERSION <= 6 /* Perl 5.6 and earlier */
22 
23 # ifdef EBCDIC
24 #  define UNI_TO_NATIVE(ch) (((ch) > 255) ? (ch) : ASCII_TO_NATIVE(ch))
25 # else
26 #  define UNI_TO_NATIVE(ch) (ch)
27 # endif
28 
29 UV
Perl_utf8_to_uvchr(pTHX_ U8 * s,STRLEN * retlen)30 Perl_utf8_to_uvchr(pTHX_ U8 *s, STRLEN *retlen)
31 {
32     UV uv = utf8_to_uv(s, UTF8_MAXLEN, retlen,
33                     ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
34     return UNI_TO_NATIVE(uv);
35 }
36 
37 # if !defined(PERL_IMPLICIT_CONTEXT)
38 #  define utf8_to_uvchr	     Perl_utf8_to_uvchr
39 # else
40 #  define utf8_to_uvchr(a,b) Perl_utf8_to_uvchr(aTHX_ a,b)
41 # endif
42 
43 #endif /* PERL_VERSION <= 6 */
44 
45 /* Changes in 5.7 series mean that now IOK is only set if scalar is
46    precisely integer but in 5.6 and earlier we need to do a more
47    complex test  */
48 #if PERL_VERSION <= 6
49 #define DD_is_integer(sv) (SvIOK(sv) && (SvIsUV(val) ? SvUV(sv) == SvNV(sv) : SvIV(sv) == SvNV(sv)))
50 #else
51 #define DD_is_integer(sv) SvIOK(sv)
52 #endif
53 
54 /* does a string need to be protected? */
55 static I32
needs_quote(register char * s)56 needs_quote(register char *s)
57 {
58 TOP:
59     if (s[0] == ':') {
60 	if (*++s) {
61 	    if (*s++ != ':')
62 		return 1;
63 	}
64 	else
65 	    return 1;
66     }
67     if (isIDFIRST(*s)) {
68 	while (*++s)
69 	    if (!isALNUM(*s)) {
70 		if (*s == ':')
71 		    goto TOP;
72 		else
73 		    return 1;
74 	    }
75     }
76     else
77 	return 1;
78     return 0;
79 }
80 
81 /* count the number of "'"s and "\"s in string */
82 static I32
num_q(register char * s,register STRLEN slen)83 num_q(register char *s, register STRLEN slen)
84 {
85     register I32 ret = 0;
86 
87     while (slen > 0) {
88 	if (*s == '\'' || *s == '\\')
89 	    ++ret;
90 	++s;
91 	--slen;
92     }
93     return ret;
94 }
95 
96 
97 /* returns number of chars added to escape "'"s and "\"s in s */
98 /* slen number of characters in s will be escaped */
99 /* destination must be long enough for additional chars */
100 static I32
esc_q(register char * d,register char * s,register STRLEN slen)101 esc_q(register char *d, register char *s, register STRLEN slen)
102 {
103     register I32 ret = 0;
104 
105     while (slen > 0) {
106 	switch (*s) {
107 	case '\'':
108 	case '\\':
109 	    *d = '\\';
110 	    ++d; ++ret;
111 	default:
112 	    *d = *s;
113 	    ++d; ++s; --slen;
114 	    break;
115 	}
116     }
117     return ret;
118 }
119 
120 static I32
esc_q_utf8(pTHX_ SV * sv,register char * src,register STRLEN slen)121 esc_q_utf8(pTHX_ SV* sv, register char *src, register STRLEN slen)
122 {
123     char *s, *send, *r, *rstart;
124     STRLEN j, cur = SvCUR(sv);
125     /* Could count 128-255 and 256+ in two variables, if we want to
126        be like &qquote and make a distinction.  */
127     STRLEN grow = 0;	/* bytes needed to represent chars 128+ */
128     /* STRLEN topbit_grow = 0;	bytes needed to represent chars 128-255 */
129     STRLEN backslashes = 0;
130     STRLEN single_quotes = 0;
131     STRLEN qq_escapables = 0;	/* " $ @ will need a \ in "" strings.  */
132     STRLEN normal = 0;
133 
134     /* this will need EBCDICification */
135     for (s = src, send = src + slen; s < send; s += UTF8SKIP(s)) {
136         UV k = utf8_to_uvchr((U8*)s, NULL);
137 
138         if (k > 127) {
139             /* 4: \x{} then count the number of hex digits.  */
140             grow += 4 + (k <= 0xFF ? 2 : k <= 0xFFF ? 3 : k <= 0xFFFF ? 4 :
141 #if UVSIZE == 4
142                 8 /* We may allocate a bit more than the minimum here.  */
143 #else
144                 k <= 0xFFFFFFFF ? 8 : UVSIZE * 4
145 #endif
146                 );
147         } else if (k == '\\') {
148             backslashes++;
149         } else if (k == '\'') {
150             single_quotes++;
151         } else if (k == '"' || k == '$' || k == '@') {
152             qq_escapables++;
153         } else {
154             normal++;
155         }
156     }
157     if (grow) {
158         /* We have something needing hex. 3 is ""\0 */
159         sv_grow(sv, cur + 3 + grow + 2*backslashes + single_quotes
160 		+ 2*qq_escapables + normal);
161         rstart = r = SvPVX(sv) + cur;
162 
163         *r++ = '"';
164 
165         for (s = src; s < send; s += UTF8SKIP(s)) {
166             UV k = utf8_to_uvchr((U8*)s, NULL);
167 
168             if (k == '"' || k == '\\' || k == '$' || k == '@') {
169                 *r++ = '\\';
170                 *r++ = (char)k;
171             }
172             else if (k < 0x80)
173                 *r++ = (char)k;
174             else {
175 	      /* The return value of sprintf() is unportable.
176 	       * In modern systems it returns (int) the number of characters,
177 	       * but in older systems it might return (char*) the original
178 	       * buffer, or it might even be (void).  The easiest portable
179 	       * thing to do is probably use sprintf() in void context and
180 	       * then strlen(buffer) for the length.  The more proper way
181 	       * would of course be to figure out the prototype of sprintf.
182 	       * --jhi */
183 	        sprintf(r, "\\x{%"UVxf"}", k);
184                 r += strlen(r);
185             }
186         }
187         *r++ = '"';
188     } else {
189         /* Single quotes.  */
190         sv_grow(sv, cur + 3 + 2*backslashes + 2*single_quotes
191 		+ qq_escapables + normal);
192         rstart = r = SvPVX(sv) + cur;
193         *r++ = '\'';
194         for (s = src; s < send; s ++) {
195             char k = *s;
196             if (k == '\'' || k == '\\')
197                 *r++ = '\\';
198             *r++ = k;
199         }
200         *r++ = '\'';
201     }
202     *r = '\0';
203     j = r - rstart;
204     SvCUR_set(sv, cur + j);
205 
206     return j;
207 }
208 
209 /* append a repeated string to an SV */
210 static SV *
sv_x(pTHX_ SV * sv,const char * str,STRLEN len,I32 n)211 sv_x(pTHX_ SV *sv, const char *str, STRLEN len, I32 n)
212 {
213     if (sv == Nullsv)
214 	sv = newSVpvn("", 0);
215     else
216 	assert(SvTYPE(sv) >= SVt_PV);
217 
218     if (n > 0) {
219 	SvGROW(sv, len*n + SvCUR(sv) + 1);
220 	if (len == 1) {
221 	    char *start = SvPVX(sv) + SvCUR(sv);
222 	    SvCUR_set(sv, SvCUR(sv) + n);
223 	    start[n] = '\0';
224 	    while (n > 0)
225 		start[--n] = str[0];
226 	}
227 	else
228 	    while (n > 0) {
229 		sv_catpvn(sv, str, len);
230 		--n;
231 	    }
232     }
233     return sv;
234 }
235 
236 /*
237  * This ought to be split into smaller functions. (it is one long function since
238  * it exactly parallels the perl version, which was one long thing for
239  * efficiency raisins.)  Ugggh!
240  */
241 static I32
DD_dump(pTHX_ SV * val,const char * name,STRLEN namelen,SV * retval,HV * seenhv,AV * postav,I32 * levelp,I32 indent,SV * pad,SV * xpad,SV * apad,SV * sep,SV * pair,SV * freezer,SV * toaster,I32 purity,I32 deepcopy,I32 quotekeys,SV * bless,I32 maxdepth,SV * sortkeys)242 DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
243 	AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad,
244 	SV *apad, SV *sep, SV *pair, SV *freezer, SV *toaster, I32 purity,
245 	I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth, SV *sortkeys)
246 {
247     char tmpbuf[128];
248     U32 i;
249     char *c, *r, *realpack, id[128];
250     SV **svp;
251     SV *sv, *ipad, *ival;
252     SV *blesspad = Nullsv;
253     AV *seenentry = Nullav;
254     char *iname;
255     STRLEN inamelen, idlen = 0;
256     U32 realtype;
257 
258     if (!val)
259 	return 0;
260 
261     realtype = SvTYPE(val);
262 
263     if (SvGMAGICAL(val))
264         mg_get(val);
265     if (SvROK(val)) {
266 
267         /* If a freeze method is provided and the object has it, call
268            it.  Warn on errors. */
269 	if (SvOBJECT(SvRV(val)) && freezer &&
270 	    SvPOK(freezer) && SvCUR(freezer) &&
271             gv_fetchmeth(SvSTASH(SvRV(val)), SvPVX_const(freezer),
272                          SvCUR(freezer), -1) != NULL)
273 	{
274 	    dSP; ENTER; SAVETMPS; PUSHMARK(sp);
275 	    XPUSHs(val); PUTBACK;
276 	    i = perl_call_method(SvPVX_const(freezer), G_EVAL|G_VOID);
277 	    SPAGAIN;
278 	    if (SvTRUE(ERRSV))
279 		warn("WARNING(Freezer method call failed): %"SVf"", ERRSV);
280 	    PUTBACK; FREETMPS; LEAVE;
281 	}
282 
283 	ival = SvRV(val);
284 	realtype = SvTYPE(ival);
285         (void) sprintf(id, "0x%"UVxf, PTR2UV(ival));
286 	idlen = strlen(id);
287 	if (SvOBJECT(ival))
288 	    realpack = HvNAME_get(SvSTASH(ival));
289 	else
290 	    realpack = Nullch;
291 
292 	/* if it has a name, we need to either look it up, or keep a tab
293 	 * on it so we know when we hit it later
294 	 */
295 	if (namelen) {
296 	    if ((svp = hv_fetch(seenhv, id, idlen, FALSE))
297 		&& (sv = *svp) && SvROK(sv) && (seenentry = (AV*)SvRV(sv)))
298 	    {
299 		SV *othername;
300 		if ((svp = av_fetch(seenentry, 0, FALSE))
301 		    && (othername = *svp))
302 		{
303 		    if (purity && *levelp > 0) {
304 			SV *postentry;
305 
306 			if (realtype == SVt_PVHV)
307 			    sv_catpvn(retval, "{}", 2);
308 			else if (realtype == SVt_PVAV)
309 			    sv_catpvn(retval, "[]", 2);
310 			else
311 			    sv_catpvn(retval, "do{my $o}", 9);
312 			postentry = newSVpvn(name, namelen);
313 			sv_catpvn(postentry, " = ", 3);
314 			sv_catsv(postentry, othername);
315 			av_push(postav, postentry);
316 		    }
317 		    else {
318 			if (name[0] == '@' || name[0] == '%') {
319 			    if ((SvPVX_const(othername))[0] == '\\' &&
320 				(SvPVX_const(othername))[1] == name[0]) {
321 				sv_catpvn(retval, SvPVX_const(othername)+1,
322 					  SvCUR(othername)-1);
323 			    }
324 			    else {
325 				sv_catpvn(retval, name, 1);
326 				sv_catpvn(retval, "{", 1);
327 				sv_catsv(retval, othername);
328 				sv_catpvn(retval, "}", 1);
329 			    }
330 			}
331 			else
332 			    sv_catsv(retval, othername);
333 		    }
334 		    return 1;
335 		}
336 		else {
337 		    warn("ref name not found for %s", id);
338 		    return 0;
339 		}
340 	    }
341 	    else {   /* store our name and continue */
342 		SV *namesv;
343 		if (name[0] == '@' || name[0] == '%') {
344 		    namesv = newSVpvn("\\", 1);
345 		    sv_catpvn(namesv, name, namelen);
346 		}
347 		else if (realtype == SVt_PVCV && name[0] == '*') {
348 		    namesv = newSVpvn("\\", 2);
349 		    sv_catpvn(namesv, name, namelen);
350 		    (SvPVX(namesv))[1] = '&';
351 		}
352 		else
353 		    namesv = newSVpvn(name, namelen);
354 		seenentry = newAV();
355 		av_push(seenentry, namesv);
356 		(void)SvREFCNT_inc(val);
357 		av_push(seenentry, val);
358 		(void)hv_store(seenhv, id, strlen(id),
359 			       newRV_inc((SV*)seenentry), 0);
360 		SvREFCNT_dec(seenentry);
361 	    }
362 	}
363 
364 	if (realpack && *realpack == 'R' && strEQ(realpack, "Regexp")) {
365 	    STRLEN rlen;
366 	    char *rval = SvPV(val, rlen);
367 	    char *slash = strchr(rval, '/');
368 	    sv_catpvn(retval, "qr/", 3);
369 	    while (slash) {
370 		sv_catpvn(retval, rval, slash-rval);
371 		sv_catpvn(retval, "\\/", 2);
372 		rlen -= slash-rval+1;
373 		rval = slash+1;
374 		slash = strchr(rval, '/');
375 	    }
376 	    sv_catpvn(retval, rval, rlen);
377 	    sv_catpvn(retval, "/", 1);
378 	    return 1;
379 	}
380 
381 	/* If purity is not set and maxdepth is set, then check depth:
382 	 * if we have reached maximum depth, return the string
383 	 * representation of the thing we are currently examining
384 	 * at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)').
385 	 */
386 	if (!purity && maxdepth > 0 && *levelp >= maxdepth) {
387 	    STRLEN vallen;
388 	    char *valstr = SvPV(val,vallen);
389 	    sv_catpvn(retval, "'", 1);
390 	    sv_catpvn(retval, valstr, vallen);
391 	    sv_catpvn(retval, "'", 1);
392 	    return 1;
393 	}
394 
395 	if (realpack) {				/* we have a blessed ref */
396 	    STRLEN blesslen;
397 	    char *blessstr = SvPV(bless, blesslen);
398 	    sv_catpvn(retval, blessstr, blesslen);
399 	    sv_catpvn(retval, "( ", 2);
400 	    if (indent >= 2) {
401 		blesspad = apad;
402 		apad = newSVsv(apad);
403 		sv_x(aTHX_ apad, " ", 1, blesslen+2);
404 	    }
405 	}
406 
407 	(*levelp)++;
408 	ipad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp);
409 
410 	if (realtype <= SVt_PVBM) {			     /* scalar ref */
411 	    SV *namesv = newSVpvn("${", 2);
412 	    sv_catpvn(namesv, name, namelen);
413 	    sv_catpvn(namesv, "}", 1);
414 	    if (realpack) {				     /* blessed */
415 		sv_catpvn(retval, "do{\\(my $o = ", 13);
416 		DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
417 			postav, levelp,	indent, pad, xpad, apad, sep, pair,
418 			freezer, toaster, purity, deepcopy, quotekeys, bless,
419 			maxdepth, sortkeys);
420 		sv_catpvn(retval, ")}", 2);
421 	    }						     /* plain */
422 	    else {
423 		sv_catpvn(retval, "\\", 1);
424 		DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
425 			postav, levelp,	indent, pad, xpad, apad, sep, pair,
426 			freezer, toaster, purity, deepcopy, quotekeys, bless,
427 			maxdepth, sortkeys);
428 	    }
429 	    SvREFCNT_dec(namesv);
430 	}
431 	else if (realtype == SVt_PVGV) {		     /* glob ref */
432 	    SV *namesv = newSVpvn("*{", 2);
433 	    sv_catpvn(namesv, name, namelen);
434 	    sv_catpvn(namesv, "}", 1);
435 	    sv_catpvn(retval, "\\", 1);
436 	    DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
437 		    postav, levelp,	indent, pad, xpad, apad, sep, pair,
438 		    freezer, toaster, purity, deepcopy, quotekeys, bless,
439 		    maxdepth, sortkeys);
440 	    SvREFCNT_dec(namesv);
441 	}
442 	else if (realtype == SVt_PVAV) {
443 	    SV *totpad;
444 	    I32 ix = 0;
445 	    I32 ixmax = av_len((AV *)ival);
446 
447 	    SV *ixsv = newSViv(0);
448 	    /* allowing for a 24 char wide array index */
449 	    New(0, iname, namelen+28, char);
450 	    (void)strcpy(iname, name);
451 	    inamelen = namelen;
452 	    if (name[0] == '@') {
453 		sv_catpvn(retval, "(", 1);
454 		iname[0] = '$';
455 	    }
456 	    else {
457 		sv_catpvn(retval, "[", 1);
458 		/* omit "->" in $foo{bar}->[0], but not in ${$foo}->[0] */
459 		/*if (namelen > 0
460 		    && name[namelen-1] != ']' && name[namelen-1] != '}'
461 		    && (namelen < 4 || (name[1] != '{' && name[2] != '{')))*/
462 		if ((namelen > 0
463 		     && name[namelen-1] != ']' && name[namelen-1] != '}')
464 		    || (namelen > 4
465 		        && (name[1] == '{'
466 			    || (name[0] == '\\' && name[2] == '{'))))
467 		{
468 		    iname[inamelen++] = '-'; iname[inamelen++] = '>';
469 		    iname[inamelen] = '\0';
470 		}
471 	    }
472 	    if (iname[0] == '*' && iname[inamelen-1] == '}' && inamelen >= 8 &&
473 		(instr(iname+inamelen-8, "{SCALAR}") ||
474 		 instr(iname+inamelen-7, "{ARRAY}") ||
475 		 instr(iname+inamelen-6, "{HASH}"))) {
476 		iname[inamelen++] = '-'; iname[inamelen++] = '>';
477 	    }
478 	    iname[inamelen++] = '['; iname[inamelen] = '\0';
479 	    totpad = newSVsv(sep);
480 	    sv_catsv(totpad, pad);
481 	    sv_catsv(totpad, apad);
482 
483 	    for (ix = 0; ix <= ixmax; ++ix) {
484 		STRLEN ilen;
485 		SV *elem;
486 		svp = av_fetch((AV*)ival, ix, FALSE);
487 		if (svp)
488 		    elem = *svp;
489 		else
490 		    elem = &PL_sv_undef;
491 
492 		ilen = inamelen;
493 		sv_setiv(ixsv, ix);
494                 (void) sprintf(iname+ilen, "%"IVdf, (IV)ix);
495 		ilen = strlen(iname);
496 		iname[ilen++] = ']'; iname[ilen] = '\0';
497 		if (indent >= 3) {
498 		    sv_catsv(retval, totpad);
499 		    sv_catsv(retval, ipad);
500 		    sv_catpvn(retval, "#", 1);
501 		    sv_catsv(retval, ixsv);
502 		}
503 		sv_catsv(retval, totpad);
504 		sv_catsv(retval, ipad);
505 		DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav,
506 			levelp,	indent, pad, xpad, apad, sep, pair,
507 			freezer, toaster, purity, deepcopy, quotekeys, bless,
508 			maxdepth, sortkeys);
509 		if (ix < ixmax)
510 		    sv_catpvn(retval, ",", 1);
511 	    }
512 	    if (ixmax >= 0) {
513 		SV *opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), (*levelp)-1);
514 		sv_catsv(retval, totpad);
515 		sv_catsv(retval, opad);
516 		SvREFCNT_dec(opad);
517 	    }
518 	    if (name[0] == '@')
519 		sv_catpvn(retval, ")", 1);
520 	    else
521 		sv_catpvn(retval, "]", 1);
522 	    SvREFCNT_dec(ixsv);
523 	    SvREFCNT_dec(totpad);
524 	    Safefree(iname);
525 	}
526 	else if (realtype == SVt_PVHV) {
527 	    SV *totpad, *newapad;
528 	    SV *iname, *sname;
529 	    HE *entry;
530 	    char *key;
531 	    I32 klen;
532 	    SV *hval;
533 	    AV *keys = Nullav;
534 
535 	    iname = newSVpvn(name, namelen);
536 	    if (name[0] == '%') {
537 		sv_catpvn(retval, "(", 1);
538 		(SvPVX(iname))[0] = '$';
539 	    }
540 	    else {
541 		sv_catpvn(retval, "{", 1);
542 		/* omit "->" in $foo[0]->{bar}, but not in ${$foo}->{bar} */
543 		if ((namelen > 0
544 		     && name[namelen-1] != ']' && name[namelen-1] != '}')
545 		    || (namelen > 4
546 		        && (name[1] == '{'
547 			    || (name[0] == '\\' && name[2] == '{'))))
548 		{
549 		    sv_catpvn(iname, "->", 2);
550 		}
551 	    }
552 	    if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 &&
553 		(instr(name+namelen-8, "{SCALAR}") ||
554 		 instr(name+namelen-7, "{ARRAY}") ||
555 		 instr(name+namelen-6, "{HASH}"))) {
556 		sv_catpvn(iname, "->", 2);
557 	    }
558 	    sv_catpvn(iname, "{", 1);
559 	    totpad = newSVsv(sep);
560 	    sv_catsv(totpad, pad);
561 	    sv_catsv(totpad, apad);
562 
563 	    /* If requested, get a sorted/filtered array of hash keys */
564 	    if (sortkeys) {
565 		if (sortkeys == &PL_sv_yes) {
566 #if PERL_VERSION < 8
567                     sortkeys = sv_2mortal(newSVpvn("Data::Dumper::_sortkeys", 23));
568 #else
569 		    keys = newAV();
570 		    (void)hv_iterinit((HV*)ival);
571 		    while ((entry = hv_iternext((HV*)ival))) {
572 			sv = hv_iterkeysv(entry);
573 			SvREFCNT_inc(sv);
574 			av_push(keys, sv);
575 		    }
576 # ifdef USE_LOCALE_NUMERIC
577 		    sortsv(AvARRAY(keys),
578 			   av_len(keys)+1,
579 			   IN_LOCALE ? Perl_sv_cmp_locale : Perl_sv_cmp);
580 # else
581 		    sortsv(AvARRAY(keys),
582 			   av_len(keys)+1,
583 			   Perl_sv_cmp);
584 # endif
585 #endif
586 		}
587 		if (sortkeys != &PL_sv_yes) {
588 		    dSP; ENTER; SAVETMPS; PUSHMARK(sp);
589 		    XPUSHs(sv_2mortal(newRV_inc(ival))); PUTBACK;
590 		    i = perl_call_sv(sortkeys, G_SCALAR | G_EVAL);
591 		    SPAGAIN;
592 		    if (i) {
593 			sv = POPs;
594 			if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVAV))
595 			    keys = (AV*)SvREFCNT_inc(SvRV(sv));
596 		    }
597 		    if (! keys)
598 			warn("Sortkeys subroutine did not return ARRAYREF\n");
599 		    PUTBACK; FREETMPS; LEAVE;
600 		}
601 		if (keys)
602 		    sv_2mortal((SV*)keys);
603 	    }
604 	    else
605 		(void)hv_iterinit((HV*)ival);
606 
607             /* foreach (keys %hash) */
608             for (i = 0; 1; i++) {
609 		char *nkey;
610                 char *nkey_buffer = NULL;
611 		I32 nticks = 0;
612 		SV* keysv;
613 		STRLEN keylen;
614                 I32 nlen;
615 		bool do_utf8 = FALSE;
616 
617                if (sortkeys) {
618                    if (!(keys && (I32)i <= av_len(keys))) break;
619                } else {
620                    if (!(entry = hv_iternext((HV *)ival))) break;
621                }
622 
623 		if (i)
624 		    sv_catpvn(retval, ",", 1);
625 
626 		if (sortkeys) {
627 		    char *key;
628 		    svp = av_fetch(keys, i, FALSE);
629 		    keysv = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
630 		    key = SvPV(keysv, keylen);
631 		    svp = hv_fetch((HV*)ival, key,
632                                    SvUTF8(keysv) ? -(I32)keylen : keylen, 0);
633 		    hval = svp ? *svp : sv_mortalcopy(&PL_sv_undef);
634 		}
635 		else {
636 		    keysv = hv_iterkeysv(entry);
637 		    hval = hv_iterval((HV*)ival, entry);
638 		}
639 
640 		do_utf8 = DO_UTF8(keysv);
641 		key = SvPV(keysv, keylen);
642 		klen = keylen;
643 
644                 sv_catsv(retval, totpad);
645                 sv_catsv(retval, ipad);
646                 /* old logic was first to check utf8 flag, and if utf8 always
647                    call esc_q_utf8.  This caused test to break under -Mutf8,
648                    because there even strings like 'c' have utf8 flag on.
649                    Hence with quotekeys == 0 the XS code would still '' quote
650                    them based on flags, whereas the perl code would not,
651                    based on regexps.
652                    The perl code is correct.
653                    needs_quote() decides that anything that isn't a valid
654                    perl identifier needs to be quoted, hence only correctly
655                    formed strings with no characters outside [A-Za-z0-9_:]
656                    won't need quoting.  None of those characters are used in
657                    the byte encoding of utf8, so anything with utf8
658                    encoded characters in will need quoting. Hence strings
659                    with utf8 encoded characters in will end up inside do_utf8
660                    just like before, but now strings with utf8 flag set but
661                    only ascii characters will end up in the unquoted section.
662 
663                    There should also be less tests for the (probably currently)
664                    more common doesn't need quoting case.
665                    The code is also smaller (22044 vs 22260) because I've been
666                    able to pull the common logic out to both sides.  */
667                 if (quotekeys || needs_quote(key)) {
668                     if (do_utf8) {
669                         STRLEN ocur = SvCUR(retval);
670                         nlen = esc_q_utf8(aTHX_ retval, key, klen);
671                         nkey = SvPVX(retval) + ocur;
672                     }
673                     else {
674 		        nticks = num_q(key, klen);
675 			New(0, nkey_buffer, klen+nticks+3, char);
676                         nkey = nkey_buffer;
677 			nkey[0] = '\'';
678 			if (nticks)
679 			    klen += esc_q(nkey+1, key, klen);
680 			else
681 			    (void)Copy(key, nkey+1, klen, char);
682 			nkey[++klen] = '\'';
683 			nkey[++klen] = '\0';
684                         nlen = klen;
685                         sv_catpvn(retval, nkey, klen);
686 		    }
687                 }
688                 else {
689                     nkey = key;
690                     nlen = klen;
691                     sv_catpvn(retval, nkey, klen);
692 		}
693                 sname = newSVsv(iname);
694                 sv_catpvn(sname, nkey, nlen);
695                 sv_catpvn(sname, "}", 1);
696 
697 		sv_catsv(retval, pair);
698 		if (indent >= 2) {
699 		    char *extra;
700 		    I32 elen = 0;
701 		    newapad = newSVsv(apad);
702 		    New(0, extra, klen+4+1, char);
703 		    while (elen < (klen+4))
704 			extra[elen++] = ' ';
705 		    extra[elen] = '\0';
706 		    sv_catpvn(newapad, extra, elen);
707 		    Safefree(extra);
708 		}
709 		else
710 		    newapad = apad;
711 
712 		DD_dump(aTHX_ hval, SvPVX_const(sname), SvCUR(sname), retval, seenhv,
713 			postav, levelp,	indent, pad, xpad, newapad, sep, pair,
714 			freezer, toaster, purity, deepcopy, quotekeys, bless,
715 			maxdepth, sortkeys);
716 		SvREFCNT_dec(sname);
717 		Safefree(nkey_buffer);
718 		if (indent >= 2)
719 		    SvREFCNT_dec(newapad);
720 	    }
721 	    if (i) {
722 		SV *opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp-1);
723 		sv_catsv(retval, totpad);
724 		sv_catsv(retval, opad);
725 		SvREFCNT_dec(opad);
726 	    }
727 	    if (name[0] == '%')
728 		sv_catpvn(retval, ")", 1);
729 	    else
730 		sv_catpvn(retval, "}", 1);
731 	    SvREFCNT_dec(iname);
732 	    SvREFCNT_dec(totpad);
733 	}
734 	else if (realtype == SVt_PVCV) {
735 	    sv_catpvn(retval, "sub { \"DUMMY\" }", 15);
736 	    if (purity)
737 		warn("Encountered CODE ref, using dummy placeholder");
738 	}
739 	else {
740 	    warn("cannot handle ref type %ld", realtype);
741 	}
742 
743 	if (realpack) {  /* free blessed allocs */
744 	    if (indent >= 2) {
745 		SvREFCNT_dec(apad);
746 		apad = blesspad;
747 	    }
748 	    sv_catpvn(retval, ", '", 3);
749 	    sv_catpvn(retval, realpack, strlen(realpack));
750 	    sv_catpvn(retval, "' )", 3);
751 	    if (toaster && SvPOK(toaster) && SvCUR(toaster)) {
752 		sv_catpvn(retval, "->", 2);
753 		sv_catsv(retval, toaster);
754 		sv_catpvn(retval, "()", 2);
755 	    }
756 	}
757 	SvREFCNT_dec(ipad);
758 	(*levelp)--;
759     }
760     else {
761 	STRLEN i;
762 
763 	if (namelen) {
764 	    (void) sprintf(id, "0x%"UVxf, PTR2UV(val));
765 	    if ((svp = hv_fetch(seenhv, id, (idlen = strlen(id)), FALSE)) &&
766 		(sv = *svp) && SvROK(sv) &&
767 		(seenentry = (AV*)SvRV(sv)))
768 	    {
769 		SV *othername;
770 		if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)
771 		    && (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0)
772 		{
773 		    sv_catpvn(retval, "${", 2);
774 		    sv_catsv(retval, othername);
775 		    sv_catpvn(retval, "}", 1);
776 		    return 1;
777 		}
778 	    }
779 	    else if (val != &PL_sv_undef) {
780 		SV *namesv;
781 		namesv = newSVpvn("\\", 1);
782 		sv_catpvn(namesv, name, namelen);
783 		seenentry = newAV();
784 		av_push(seenentry, namesv);
785 		av_push(seenentry, newRV_inc(val));
786 		(void)hv_store(seenhv, id, strlen(id), newRV_inc((SV*)seenentry), 0);
787 		SvREFCNT_dec(seenentry);
788 	    }
789 	}
790 
791         if (DD_is_integer(val)) {
792             STRLEN len;
793 	    if (SvIsUV(val))
794 	      (void) sprintf(tmpbuf, "%"UVuf, SvUV(val));
795 	    else
796 	      (void) sprintf(tmpbuf, "%"IVdf, SvIV(val));
797             len = strlen(tmpbuf);
798             if (SvPOK(val)) {
799               /* Need to check to see if this is a string such as " 0".
800                  I'm assuming from sprintf isn't going to clash with utf8.
801                  Is this valid on EBCDIC?  */
802               STRLEN pvlen;
803               const char *pv = SvPV(val, pvlen);
804               if (pvlen != len || memNE(pv, tmpbuf, len))
805                 goto integer_came_from_string;
806             }
807             if (len > 10) {
808               /* Looks like we're on a 64 bit system.  Make it a string so that
809                  if a 32 bit system reads the number it will cope better.  */
810               sv_catpvf(retval, "'%s'", tmpbuf);
811             } else
812               sv_catpvn(retval, tmpbuf, len);
813 	}
814 	else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */
815 	    c = SvPV(val, i);
816 	    ++c; --i;			/* just get the name */
817 	    if (i >= 6 && strncmp(c, "main::", 6) == 0) {
818 		c += 4;
819 		i -= 4;
820 	    }
821 	    if (needs_quote(c)) {
822 		sv_grow(retval, SvCUR(retval)+6+2*i);
823 		r = SvPVX(retval)+SvCUR(retval);
824 		r[0] = '*'; r[1] = '{';	r[2] = '\'';
825 		i += esc_q(r+3, c, i);
826 		i += 3;
827 		r[i++] = '\''; r[i++] = '}';
828 		r[i] = '\0';
829 	    }
830 	    else {
831 		sv_grow(retval, SvCUR(retval)+i+2);
832 		r = SvPVX(retval)+SvCUR(retval);
833 		r[0] = '*'; strcpy(r+1, c);
834 		i++;
835 	    }
836 	    SvCUR_set(retval, SvCUR(retval)+i);
837 
838 	    if (purity) {
839 		static char *entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" };
840 		static STRLEN sizes[] = { 8, 7, 6 };
841 		SV *e;
842 		SV *nname = newSVpvn("", 0);
843 		SV *newapad = newSVpvn("", 0);
844 		GV *gv = (GV*)val;
845 		I32 j;
846 
847 		for (j=0; j<3; j++) {
848 		    e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv));
849 		    if (!e)
850 			continue;
851 		    if (j == 0 && !SvOK(e))
852 			continue;
853 
854 		    {
855 			I32 nlevel = 0;
856 			SV *postentry = newSVpvn(r,i);
857 
858 			sv_setsv(nname, postentry);
859 			sv_catpvn(nname, entries[j], sizes[j]);
860 			sv_catpvn(postentry, " = ", 3);
861 			av_push(postav, postentry);
862 			e = newRV_inc(e);
863 
864 			SvCUR_set(newapad, 0);
865 			if (indent >= 2)
866 			    (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry));
867 
868 			DD_dump(aTHX_ e, SvPVX_const(nname), SvCUR(nname), postentry,
869 				seenhv, postav, &nlevel, indent, pad, xpad,
870 				newapad, sep, pair, freezer, toaster, purity,
871 				deepcopy, quotekeys, bless, maxdepth,
872 				sortkeys);
873 			SvREFCNT_dec(e);
874 		    }
875 		}
876 
877 		SvREFCNT_dec(newapad);
878 		SvREFCNT_dec(nname);
879 	    }
880 	}
881 	else if (val == &PL_sv_undef || !SvOK(val)) {
882 	    sv_catpvn(retval, "undef", 5);
883 	}
884 	else {
885         integer_came_from_string:
886 	    c = SvPV(val, i);
887 	    if (DO_UTF8(val))
888 	        i += esc_q_utf8(aTHX_ retval, c, i);
889 	    else {
890 		sv_grow(retval, SvCUR(retval)+3+2*i); /* 3: ""\0 */
891 		r = SvPVX(retval) + SvCUR(retval);
892 		r[0] = '\'';
893 		i += esc_q(r+1, c, i);
894 		++i;
895 		r[i++] = '\'';
896 		r[i] = '\0';
897 		SvCUR_set(retval, SvCUR(retval)+i);
898 	    }
899 	}
900     }
901 
902     if (idlen) {
903 	if (deepcopy)
904 	    (void)hv_delete(seenhv, id, idlen, G_DISCARD);
905 	else if (namelen && seenentry) {
906 	    SV *mark = *av_fetch(seenentry, 2, TRUE);
907 	    sv_setiv(mark,1);
908 	}
909     }
910     return 1;
911 }
912 
913 
914 MODULE = Data::Dumper		PACKAGE = Data::Dumper         PREFIX = Data_Dumper_
915 
916 #
917 # This is the exact equivalent of Dump.  Well, almost. The things that are
918 # different as of now (due to Laziness):
919 #   * doesnt do double-quotes yet.
920 #
921 
922 void
923 Data_Dumper_Dumpxs(href, ...)
924 	SV	*href;
925 	PROTOTYPE: $;$$
926 	PPCODE:
927 	{
928 	    HV *hv;
929 	    SV *retval, *valstr;
930 	    HV *seenhv = Nullhv;
931 	    AV *postav, *todumpav, *namesav;
932 	    I32 level = 0;
933 	    I32 indent, terse, i, imax, postlen;
934 	    SV **svp;
935 	    SV *val, *name, *pad, *xpad, *apad, *sep, *pair, *varname;
936 	    SV *freezer, *toaster, *bless, *sortkeys;
937 	    I32 purity, deepcopy, quotekeys, maxdepth = 0;
938 	    char tmpbuf[1024];
939 	    I32 gimme = GIMME;
940 
941 	    if (!SvROK(href)) {		/* call new to get an object first */
942 		if (items < 2)
943 		    croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, [NAME_ARY_REF])");
944 
945 		ENTER;
946 		SAVETMPS;
947 
948 		PUSHMARK(sp);
949 		XPUSHs(href);
950 		XPUSHs(sv_2mortal(newSVsv(ST(1))));
951 		if (items >= 3)
952 		    XPUSHs(sv_2mortal(newSVsv(ST(2))));
953 		PUTBACK;
954 		i = perl_call_method("new", G_SCALAR);
955 		SPAGAIN;
956 		if (i)
957 		    href = newSVsv(POPs);
958 
959 		PUTBACK;
960 		FREETMPS;
961 		LEAVE;
962 		if (i)
963 		    (void)sv_2mortal(href);
964 	    }
965 
966 	    todumpav = namesav = Nullav;
967 	    seenhv = Nullhv;
968 	    val = pad = xpad = apad = sep = pair = varname
969 		= freezer = toaster = bless = &PL_sv_undef;
970 	    name = sv_newmortal();
971 	    indent = 2;
972 	    terse = purity = deepcopy = 0;
973 	    quotekeys = 1;
974 
975 	    retval = newSVpvn("", 0);
976 	    if (SvROK(href)
977 		&& (hv = (HV*)SvRV((SV*)href))
978 		&& SvTYPE(hv) == SVt_PVHV)		{
979 
980 		if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp))
981 		    seenhv = (HV*)SvRV(*svp);
982 		if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp))
983 		    todumpav = (AV*)SvRV(*svp);
984 		if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp))
985 		    namesav = (AV*)SvRV(*svp);
986 		if ((svp = hv_fetch(hv, "indent", 6, FALSE)))
987 		    indent = SvIV(*svp);
988 		if ((svp = hv_fetch(hv, "purity", 6, FALSE)))
989 		    purity = SvIV(*svp);
990 		if ((svp = hv_fetch(hv, "terse", 5, FALSE)))
991 		    terse = SvTRUE(*svp);
992 #if 0 /* useqq currently unused */
993 		if ((svp = hv_fetch(hv, "useqq", 5, FALSE)))
994 		    useqq = SvTRUE(*svp);
995 #endif
996 		if ((svp = hv_fetch(hv, "pad", 3, FALSE)))
997 		    pad = *svp;
998 		if ((svp = hv_fetch(hv, "xpad", 4, FALSE)))
999 		    xpad = *svp;
1000 		if ((svp = hv_fetch(hv, "apad", 4, FALSE)))
1001 		    apad = *svp;
1002 		if ((svp = hv_fetch(hv, "sep", 3, FALSE)))
1003 		    sep = *svp;
1004 		if ((svp = hv_fetch(hv, "pair", 4, FALSE)))
1005 		    pair = *svp;
1006 		if ((svp = hv_fetch(hv, "varname", 7, FALSE)))
1007 		    varname = *svp;
1008 		if ((svp = hv_fetch(hv, "freezer", 7, FALSE)))
1009 		    freezer = *svp;
1010 		if ((svp = hv_fetch(hv, "toaster", 7, FALSE)))
1011 		    toaster = *svp;
1012 		if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE)))
1013 		    deepcopy = SvTRUE(*svp);
1014 		if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE)))
1015 		    quotekeys = SvTRUE(*svp);
1016 		if ((svp = hv_fetch(hv, "bless", 5, FALSE)))
1017 		    bless = *svp;
1018 		if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE)))
1019 		    maxdepth = SvIV(*svp);
1020 		if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) {
1021 		    sortkeys = *svp;
1022 		    if (! SvTRUE(sortkeys))
1023 			sortkeys = NULL;
1024 		    else if (! (SvROK(sortkeys) &&
1025 				SvTYPE(SvRV(sortkeys)) == SVt_PVCV) )
1026 		    {
1027 			/* flag to use qsortsv() for sorting hash keys */
1028 			sortkeys = &PL_sv_yes;
1029 		    }
1030 		}
1031 		postav = newAV();
1032 
1033 		if (todumpav)
1034 		    imax = av_len(todumpav);
1035 		else
1036 		    imax = -1;
1037 		valstr = newSVpvn("",0);
1038 		for (i = 0; i <= imax; ++i) {
1039 		    SV *newapad;
1040 
1041 		    av_clear(postav);
1042 		    if ((svp = av_fetch(todumpav, i, FALSE)))
1043 			val = *svp;
1044 		    else
1045 			val = &PL_sv_undef;
1046 		    if ((svp = av_fetch(namesav, i, TRUE))) {
1047 			sv_setsv(name, *svp);
1048 			if (SvOK(*svp) && !SvPOK(*svp))
1049 			    (void)SvPV_nolen_const(name);
1050 		    }
1051 		    else
1052 			(void)SvOK_off(name);
1053 
1054 		    if (SvPOK(name)) {
1055 			if ((SvPVX_const(name))[0] == '*') {
1056 			    if (SvROK(val)) {
1057 				switch (SvTYPE(SvRV(val))) {
1058 				case SVt_PVAV:
1059 				    (SvPVX(name))[0] = '@';
1060 				    break;
1061 				case SVt_PVHV:
1062 				    (SvPVX(name))[0] = '%';
1063 				    break;
1064 				case SVt_PVCV:
1065 				    (SvPVX(name))[0] = '*';
1066 				    break;
1067 				default:
1068 				    (SvPVX(name))[0] = '$';
1069 				    break;
1070 				}
1071 			    }
1072 			    else
1073 				(SvPVX(name))[0] = '$';
1074 			}
1075 			else if ((SvPVX_const(name))[0] != '$')
1076 			    sv_insert(name, 0, 0, "$", 1);
1077 		    }
1078 		    else {
1079 			STRLEN nchars = 0;
1080 			sv_setpvn(name, "$", 1);
1081 			sv_catsv(name, varname);
1082 			(void) sprintf(tmpbuf, "%"IVdf, (IV)(i+1));
1083 			nchars = strlen(tmpbuf);
1084 			sv_catpvn(name, tmpbuf, nchars);
1085 		    }
1086 
1087 		    if (indent >= 2) {
1088 			SV *tmpsv = sv_x(aTHX_ Nullsv, " ", 1, SvCUR(name)+3);
1089 			newapad = newSVsv(apad);
1090 			sv_catsv(newapad, tmpsv);
1091 			SvREFCNT_dec(tmpsv);
1092 		    }
1093 		    else
1094 			newapad = apad;
1095 
1096 		    DD_dump(aTHX_ val, SvPVX_const(name), SvCUR(name), valstr, seenhv,
1097 			    postav, &level, indent, pad, xpad, newapad, sep, pair,
1098 			    freezer, toaster, purity, deepcopy, quotekeys,
1099 			    bless, maxdepth, sortkeys);
1100 
1101 		    if (indent >= 2)
1102 			SvREFCNT_dec(newapad);
1103 
1104 		    postlen = av_len(postav);
1105 		    if (postlen >= 0 || !terse) {
1106 			sv_insert(valstr, 0, 0, " = ", 3);
1107 			sv_insert(valstr, 0, 0, (char *)SvPVX_const(name), SvCUR(name));
1108 			sv_catpvn(valstr, ";", 1);
1109 		    }
1110 		    sv_catsv(retval, pad);
1111 		    sv_catsv(retval, valstr);
1112 		    sv_catsv(retval, sep);
1113 		    if (postlen >= 0) {
1114 			I32 i;
1115 			sv_catsv(retval, pad);
1116 			for (i = 0; i <= postlen; ++i) {
1117 			    SV *elem;
1118 			    svp = av_fetch(postav, i, FALSE);
1119 			    if (svp && (elem = *svp)) {
1120 				sv_catsv(retval, elem);
1121 				if (i < postlen) {
1122 				    sv_catpvn(retval, ";", 1);
1123 				    sv_catsv(retval, sep);
1124 				    sv_catsv(retval, pad);
1125 				}
1126 			    }
1127 			}
1128 			sv_catpvn(retval, ";", 1);
1129 			    sv_catsv(retval, sep);
1130 		    }
1131 		    sv_setpvn(valstr, "", 0);
1132 		    if (gimme == G_ARRAY) {
1133 			XPUSHs(sv_2mortal(retval));
1134 			if (i < imax)	/* not the last time thro ? */
1135 			    retval = newSVpvn("",0);
1136 		    }
1137 		}
1138 		SvREFCNT_dec(postav);
1139 		SvREFCNT_dec(valstr);
1140 	    }
1141 	    else
1142 		croak("Call to new() method failed to return HASH ref");
1143 	    if (gimme == G_SCALAR)
1144 		XPUSHs(sv_2mortal(retval));
1145 	}
1146