This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
adjust indentation to match other DD code
[perl5.git] / dist / Data-Dumper / Dumper.xs
CommitLineData
c5be433b 1#define PERL_NO_GET_CONTEXT
823edd99
GS
2#include "EXTERN.h"
3#include "perl.h"
4#include "XSUB.h"
171b7b3b 5#ifdef USE_PPPORT_H
02c14053 6# define NEED_my_snprintf
ab4d8678 7# define NEED_sv_2pv_flags
171b7b3b
JH
8# include "ppport.h"
9#endif
823edd99 10
ecf5217a 11#if PERL_VERSION < 8
e52c0e5a
NC
12# define DD_USE_OLD_ID_FORMAT
13#endif
14
d5e7da3f
KW
15#ifndef isWORDCHAR
16# define isWORDCHAR(c) isALNUM(c)
17#endif
18
9061c4b9
AL
19static I32 num_q (const char *s, STRLEN slen);
20static I32 esc_q (char *dest, const char *src, STRLEN slen);
9baac1a3 21static I32 esc_q_utf8 (pTHX_ SV *sv, const char *src, STRLEN slen, I32 do_utf8, I32 useqq);
5aaab254 22static I32 needs_quote(const char *s, STRLEN len);
aa07b2f6
SP
23static SV *sv_x (pTHX_ SV *sv, const char *str, STRLEN len, I32 n);
24static I32 DD_dump (pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval,
20ce7b12 25 HV *seenhv, AV *postav, I32 *levelp, I32 indent,
30b4f386 26 SV *pad, SV *xpad, SV *apad, SV *sep, SV *pair,
20ce7b12 27 SV *freezer, SV *toaster,
a2126434 28 I32 purity, I32 deepcopy, I32 quotekeys, SV *bless,
9baac1a3 29 I32 maxdepth, SV *sortkeys, int use_sparse_seen_hash, I32 useqq);
823edd99 30
bfcb3514
NC
31#ifndef HvNAME_get
32#define HvNAME_get HvNAME
33#endif
34
54161612
KW
35/* Perls 7 through portions of 15 used utf8_to_uvchr() which didn't have a
36 * length parameter. This wrongly allowed reading beyond the end of buffer
37 * given malformed input */
38
fec5e1eb
IM
39#if PERL_VERSION <= 6 /* Perl 5.6 and earlier */
40
41# ifdef EBCDIC
42# define UNI_TO_NATIVE(ch) (((ch) > 255) ? (ch) : ASCII_TO_NATIVE(ch))
43# else
44# define UNI_TO_NATIVE(ch) (ch)
45# endif
46
47UV
4b88fb76 48Perl_utf8_to_uvchr_buf(pTHX_ U8 *s, U8 *send, STRLEN *retlen)
fec5e1eb 49{
4b88fb76 50 const UV uv = utf8_to_uv(s, send - s, retlen,
fec5e1eb
IM
51 ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
52 return UNI_TO_NATIVE(uv);
53}
54
55# if !defined(PERL_IMPLICIT_CONTEXT)
4b88fb76 56# define utf8_to_uvchr_buf Perl_utf8_to_uvchr_buf
fec5e1eb 57# else
54161612 58# define utf8_to_uvchr_buf(a,b,c) Perl_utf8_to_uvchr_buf(aTHX_ a,b,c)
fec5e1eb
IM
59# endif
60
61#endif /* PERL_VERSION <= 6 */
62
54161612
KW
63/* Perl 5.7 through part of 5.15 */
64#if PERL_VERSION > 6 && PERL_VERSION <= 15 && ! defined(utf8_to_uvchr_buf)
65
66UV
67Perl_utf8_to_uvchr_buf(pTHX_ U8 *s, U8 *send, STRLEN *retlen)
68{
69 /* We have to discard <send> for these versions; hence can read off the
70 * end of the buffer if there is a malformation that indicates the
71 * character is longer than the space available */
72
73 const UV uv = utf8_to_uvchr(s, retlen);
74 return UNI_TO_NATIVE(uv);
75}
76
77# if !defined(PERL_IMPLICIT_CONTEXT)
78# define utf8_to_uvchr_buf Perl_utf8_to_uvchr_buf
79# else
80# define utf8_to_uvchr_buf(a,b,c) Perl_utf8_to_uvchr_buf(aTHX_ a,b,c)
81# endif
82
83#endif /* PERL_VERSION > 6 && <= 15 */
84
fec5e1eb
IM
85/* Changes in 5.7 series mean that now IOK is only set if scalar is
86 precisely integer but in 5.6 and earlier we need to do a more
87 complex test */
88#if PERL_VERSION <= 6
89#define DD_is_integer(sv) (SvIOK(sv) && (SvIsUV(val) ? SvUV(sv) == SvNV(sv) : SvIV(sv) == SvNV(sv)))
90#else
91#define DD_is_integer(sv) SvIOK(sv)
92#endif
93
823edd99
GS
94/* does a string need to be protected? */
95static I32
5aaab254 96needs_quote(const char *s, STRLEN len)
823edd99 97{
95869c09 98 const char *send = s+len;
823edd99
GS
99TOP:
100 if (s[0] == ':') {
95869c09 101 if (++s<send) {
823edd99
GS
102 if (*s++ != ':')
103 return 1;
104 }
105 else
106 return 1;
107 }
108 if (isIDFIRST(*s)) {
95869c09 109 while (++s<send)
0eb30aeb 110 if (!isWORDCHAR(*s)) {
823edd99
GS
111 if (*s == ':')
112 goto TOP;
113 else
114 return 1;
7b0972df 115 }
823edd99 116 }
6cde4e94 117 else
823edd99
GS
118 return 1;
119 return 0;
120}
121
122/* count the number of "'"s and "\"s in string */
123static I32
5aaab254 124num_q(const char *s, STRLEN slen)
823edd99 125{
eb578fdb 126 I32 ret = 0;
6c1ab3c2
SR
127
128 while (slen > 0) {
823edd99
GS
129 if (*s == '\'' || *s == '\\')
130 ++ret;
131 ++s;
6c1ab3c2 132 --slen;
823edd99
GS
133 }
134 return ret;
135}
136
137
138/* returns number of chars added to escape "'"s and "\"s in s */
139/* slen number of characters in s will be escaped */
140/* destination must be long enough for additional chars */
141static I32
5aaab254 142esc_q(char *d, const char *s, STRLEN slen)
823edd99 143{
eb578fdb 144 I32 ret = 0;
6cde4e94 145
823edd99
GS
146 while (slen > 0) {
147 switch (*s) {
148 case '\'':
149 case '\\':
150 *d = '\\';
151 ++d; ++ret;
152 default:
153 *d = *s;
154 ++d; ++s; --slen;
155 break;
156 }
157 }
158 return ret;
159}
160
9baac1a3 161/* this function is also misused for implementing $Useqq */
dc71dc59 162static I32
9baac1a3 163esc_q_utf8(pTHX_ SV* sv, const char *src, STRLEN slen, I32 do_utf8, I32 useqq)
dc71dc59 164{
9061c4b9
AL
165 char *r, *rstart;
166 const char *s = src;
167 const char * const send = src + slen;
f052740f
NC
168 STRLEN j, cur = SvCUR(sv);
169 /* Could count 128-255 and 256+ in two variables, if we want to
170 be like &qquote and make a distinction. */
171 STRLEN grow = 0; /* bytes needed to represent chars 128+ */
172 /* STRLEN topbit_grow = 0; bytes needed to represent chars 128-255 */
173 STRLEN backslashes = 0;
174 STRLEN single_quotes = 0;
175 STRLEN qq_escapables = 0; /* " $ @ will need a \ in "" strings. */
176 STRLEN normal = 0;
7d3a730e 177 int increment;
6cde4e94 178
dc71dc59 179 /* this will need EBCDICification */
9baac1a3
SR
180 for (s = src; s < send; do_utf8 ? s += increment : s++) {
181 const UV k = do_utf8 ? utf8_to_uvchr_buf((U8*)s, (U8*) send, NULL) : *(U8*)s;
f052740f 182
7d3a730e
NT
183 /* check for invalid utf8 */
184 increment = (k == 0 && *s != '\0') ? 1 : UTF8SKIP(s);
185
cf0d1c66
JH
186#ifdef EBCDIC
187 if (!isprint(k) || k > 256) {
188#else
189 if (k > 127) {
190#endif
f052740f
NC
191 /* 4: \x{} then count the number of hex digits. */
192 grow += 4 + (k <= 0xFF ? 2 : k <= 0xFFF ? 3 : k <= 0xFFFF ? 4 :
193#if UVSIZE == 4
194 8 /* We may allocate a bit more than the minimum here. */
195#else
196 k <= 0xFFFFFFFF ? 8 : UVSIZE * 4
197#endif
198 );
9baac1a3
SR
199#ifndef EBCDIC
200 } else if (useqq && (k <= 10 || k == 12 || k == 13 || k == 27)) {
201 grow += 2;
202 } else if (useqq && k <= 31) {
203 grow += 3;
204 } else if (useqq && k >= 127) {
205 grow += 4;
206#endif
f052740f
NC
207 } else if (k == '\\') {
208 backslashes++;
209 } else if (k == '\'') {
210 single_quotes++;
211 } else if (k == '"' || k == '$' || k == '@') {
212 qq_escapables++;
213 } else {
214 normal++;
215 }
dc71dc59 216 }
9baac1a3 217 if (grow || useqq) {
f052740f 218 /* We have something needing hex. 3 is ""\0 */
34231210
NC
219 sv_grow(sv, cur + 3 + grow + 2*backslashes + single_quotes
220 + 2*qq_escapables + normal);
f052740f
NC
221 rstart = r = SvPVX(sv) + cur;
222
223 *r++ = '"';
224
9baac1a3
SR
225 for (s = src; s < send; do_utf8 ? s += UTF8SKIP(s) : s++) {
226 const UV k = do_utf8 ? utf8_to_uvchr_buf((U8*)s, (U8*) send, NULL) : *(U8*)s;
227
f052740f
NC
228
229 if (k == '"' || k == '\\' || k == '$' || k == '@') {
230 *r++ = '\\';
7c436af3 231 *r++ = (char)k;
f052740f 232 }
cf0d1c66
JH
233 else
234#ifdef EBCDIC
235 if (isprint(k) && k < 256)
236#else
9baac1a3
SR
237 if (useqq && (k <= 31 || k == 127 || (!do_utf8 && k > 127))) {
238 *r++ = '\\';
239 switch (k) {
f1c45943
TC
240 case 7: *r++ = 'a'; break;
241 case 8: *r++ = 'b'; break;
242 case 9: *r++ = 't'; break;
243 case 10: *r++ = 'n'; break;
244 case 12: *r++ = 'f'; break;
245 case 13: *r++ = 'r'; break;
246 case 27: *r++ = 'e'; break;
247 default:
248 /* faster than
249 * r = r + my_sprintf(r, "%o", k);
250 */
251 if (k <= 7) {
252 *r++ = (char)k + '0';
253 } else if (k <= 63) {
254 *r++ = (char)(k>>3) + '0';
255 *r++ = (char)(k&7) + '0';
256 } else {
257 *r++ = (char)(k>>6) + '0';
258 *r++ = (char)((k&63)>>3) + '0';
259 *r++ = (char)(k&7) + '0';
260 }
9baac1a3 261 }
f1c45943
TC
262 }
263 else if (k < 0x80)
cf0d1c66 264#endif
7c436af3 265 *r++ = (char)k;
f052740f 266 else {
02c14053
AC
267#if PERL_VERSION < 10
268 sprintf(r, "\\x{%"UVxf"}", k);
269 r += strlen(r);
96109fb7 270 /* my_sprintf is not supported by ppport.h */
02c14053 271#else
f5def3a2 272 r = r + my_sprintf(r, "\\x{%"UVxf"}", k);
02c14053 273#endif
f052740f
NC
274 }
275 }
276 *r++ = '"';
277 } else {
278 /* Single quotes. */
34231210
NC
279 sv_grow(sv, cur + 3 + 2*backslashes + 2*single_quotes
280 + qq_escapables + normal);
f052740f
NC
281 rstart = r = SvPVX(sv) + cur;
282 *r++ = '\'';
283 for (s = src; s < send; s ++) {
9061c4b9 284 const char k = *s;
f052740f
NC
285 if (k == '\'' || k == '\\')
286 *r++ = '\\';
287 *r++ = k;
288 }
289 *r++ = '\'';
dc71dc59 290 }
f052740f
NC
291 *r = '\0';
292 j = r - rstart;
293 SvCUR_set(sv, cur + j);
dc71dc59
JH
294
295 return j;
296}
297
823edd99
GS
298/* append a repeated string to an SV */
299static SV *
aa07b2f6 300sv_x(pTHX_ SV *sv, const char *str, STRLEN len, I32 n)
823edd99 301{
9061c4b9 302 if (!sv)
7820172a 303 sv = newSVpvn("", 0);
65e66c80 304#ifdef DEBUGGING
823edd99
GS
305 else
306 assert(SvTYPE(sv) >= SVt_PV);
65e66c80 307#endif
823edd99
GS
308
309 if (n > 0) {
310 SvGROW(sv, len*n + SvCUR(sv) + 1);
311 if (len == 1) {
9061c4b9 312 char * const start = SvPVX(sv) + SvCUR(sv);
b162af07 313 SvCUR_set(sv, SvCUR(sv) + n);
823edd99
GS
314 start[n] = '\0';
315 while (n > 0)
316 start[--n] = str[0];
317 }
318 else
319 while (n > 0) {
320 sv_catpvn(sv, str, len);
321 --n;
322 }
323 }
324 return sv;
325}
326
327/*
328 * This ought to be split into smaller functions. (it is one long function since
329 * it exactly parallels the perl version, which was one long thing for
330 * efficiency raisins.) Ugggh!
331 */
332static I32
aa07b2f6 333DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
823edd99 334 AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad,
30b4f386 335 SV *apad, SV *sep, SV *pair, SV *freezer, SV *toaster, I32 purity,
d424882c 336 I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth, SV *sortkeys,
9baac1a3 337 int use_sparse_seen_hash, I32 useqq)
823edd99
GS
338{
339 char tmpbuf[128];
340 U32 i;
e52c0e5a
NC
341 char *c, *r, *realpack;
342#ifdef DD_USE_OLD_ID_FORMAT
343 char id[128];
344#else
345 UV id_buffer;
346 char *const id = (char *)&id_buffer;
347#endif
823edd99 348 SV **svp;
7820172a 349 SV *sv, *ipad, *ival;
823edd99 350 SV *blesspad = Nullsv;
7d49f689 351 AV *seenentry = NULL;
823edd99
GS
352 char *iname;
353 STRLEN inamelen, idlen = 0;
823edd99 354 U32 realtype;
4ab99479
YO
355 bool no_bless = 0; /* when a qr// is blessed into Regexp we dont want to bless it.
356 in later perls we should actually check the classname of the
357 engine. this gets tricky as it involves lexical issues that arent so
358 easy to resolve */
359 bool is_regex = 0; /* we are dumping a regex, we need to know this before we bless */
823edd99
GS
360
361 if (!val)
362 return 0;
363
c4a6f826 364 /* If the ouput buffer has less than some arbitrary amount of space
a4e0d239
NC
365 remaining, then enlarge it. For the test case (25M of output),
366 *1.1 was slower, *2.0 was the same, so the first guess of 1.5 is
367 deemed to be good enough. */
368 if (SvTYPE(retval) >= SVt_PV && (SvLEN(retval) - SvCUR(retval)) < 42) {
97c52c3c 369 sv_grow(retval, SvCUR(retval) * 3 / 2);
9fa5cce2 370 }
a4e0d239 371
823edd99 372 realtype = SvTYPE(val);
6cde4e94 373
823edd99
GS
374 if (SvGMAGICAL(val))
375 mg_get(val);
823edd99
GS
376 if (SvROK(val)) {
377
c5f7c514
ST
378 /* If a freeze method is provided and the object has it, call
379 it. Warn on errors. */
823edd99 380 if (SvOBJECT(SvRV(val)) && freezer &&
c5f7c514 381 SvPOK(freezer) && SvCUR(freezer) &&
aa07b2f6 382 gv_fetchmeth(SvSTASH(SvRV(val)), SvPVX_const(freezer),
c5f7c514 383 SvCUR(freezer), -1) != NULL)
823edd99
GS
384 {
385 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
386 XPUSHs(val); PUTBACK;
be022d23 387 i = perl_call_method(SvPVX_const(freezer), G_EVAL|G_VOID|G_DISCARD);
823edd99 388 SPAGAIN;
7820172a 389 if (SvTRUE(ERRSV))
35c1215d 390 warn("WARNING(Freezer method call failed): %"SVf"", ERRSV);
823edd99 391 PUTBACK; FREETMPS; LEAVE;
823edd99
GS
392 }
393
394 ival = SvRV(val);
823edd99 395 realtype = SvTYPE(ival);
e52c0e5a 396#ifdef DD_USE_OLD_ID_FORMAT
f5def3a2 397 idlen = my_snprintf(id, sizeof(id), "0x%"UVxf, PTR2UV(ival));
e52c0e5a
NC
398#else
399 id_buffer = PTR2UV(ival);
400 idlen = sizeof(id_buffer);
401#endif
823edd99 402 if (SvOBJECT(ival))
bfcb3514 403 realpack = HvNAME_get(SvSTASH(ival));
823edd99 404 else
9849c14c 405 realpack = NULL;
7820172a
GS
406
407 /* if it has a name, we need to either look it up, or keep a tab
408 * on it so we know when we hit it later
409 */
410 if (namelen) {
411 if ((svp = hv_fetch(seenhv, id, idlen, FALSE))
412 && (sv = *svp) && SvROK(sv) && (seenentry = (AV*)SvRV(sv)))
413 {
414 SV *othername;
415 if ((svp = av_fetch(seenentry, 0, FALSE))
416 && (othername = *svp))
417 {
418 if (purity && *levelp > 0) {
419 SV *postentry;
420
421 if (realtype == SVt_PVHV)
422 sv_catpvn(retval, "{}", 2);
423 else if (realtype == SVt_PVAV)
424 sv_catpvn(retval, "[]", 2);
425 else
5df59fb6 426 sv_catpvn(retval, "do{my $o}", 9);
7820172a
GS
427 postentry = newSVpvn(name, namelen);
428 sv_catpvn(postentry, " = ", 3);
429 sv_catsv(postentry, othername);
430 av_push(postav, postentry);
431 }
432 else {
433 if (name[0] == '@' || name[0] == '%') {
aa07b2f6
SP
434 if ((SvPVX_const(othername))[0] == '\\' &&
435 (SvPVX_const(othername))[1] == name[0]) {
436 sv_catpvn(retval, SvPVX_const(othername)+1,
7820172a
GS
437 SvCUR(othername)-1);
438 }
439 else {
440 sv_catpvn(retval, name, 1);
441 sv_catpvn(retval, "{", 1);
442 sv_catsv(retval, othername);
443 sv_catpvn(retval, "}", 1);
444 }
823edd99 445 }
7820172a 446 else
823edd99 447 sv_catsv(retval, othername);
823edd99 448 }
7820172a
GS
449 return 1;
450 }
451 else {
e52c0e5a 452#ifdef DD_USE_OLD_ID_FORMAT
7820172a 453 warn("ref name not found for %s", id);
e52c0e5a
NC
454#else
455 warn("ref name not found for 0x%"UVxf, PTR2UV(ival));
456#endif
7820172a 457 return 0;
823edd99 458 }
823edd99 459 }
7820172a
GS
460 else { /* store our name and continue */
461 SV *namesv;
462 if (name[0] == '@' || name[0] == '%') {
463 namesv = newSVpvn("\\", 1);
464 sv_catpvn(namesv, name, namelen);
465 }
466 else if (realtype == SVt_PVCV && name[0] == '*') {
467 namesv = newSVpvn("\\", 2);
468 sv_catpvn(namesv, name, namelen);
469 (SvPVX(namesv))[1] = '&';
470 }
471 else
472 namesv = newSVpvn(name, namelen);
473 seenentry = newAV();
474 av_push(seenentry, namesv);
475 (void)SvREFCNT_inc(val);
476 av_push(seenentry, val);
383d9087 477 (void)hv_store(seenhv, id, idlen,
fec5e1eb 478 newRV_inc((SV*)seenentry), 0);
7820172a 479 SvREFCNT_dec(seenentry);
823edd99 480 }
823edd99 481 }
4ab99479
YO
482 /* regexps dont have to be blessed into package "Regexp"
483 * they can be blessed into any package.
484 */
485#if PERL_VERSION < 8
486 if (realpack && *realpack == 'R' && strEQ(realpack, "Regexp"))
487#elif PERL_VERSION < 11
bd2db5df 488 if (realpack && realtype == SVt_PVMG && mg_find(ival, PERL_MAGIC_qr))
4ab99479
YO
489#else
490 if (realpack && realtype == SVt_REGEXP)
491#endif
492 {
493 is_regex = 1;
494 if (strEQ(realpack, "Regexp"))
495 no_bless = 1;
496 else
497 no_bless = 0;
498 }
a2126434
JN
499
500 /* If purity is not set and maxdepth is set, then check depth:
501 * if we have reached maximum depth, return the string
502 * representation of the thing we are currently examining
6cde4e94 503 * at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)').
a2126434
JN
504 */
505 if (!purity && maxdepth > 0 && *levelp >= maxdepth) {
506 STRLEN vallen;
9061c4b9 507 const char * const valstr = SvPV(val,vallen);
a2126434
JN
508 sv_catpvn(retval, "'", 1);
509 sv_catpvn(retval, valstr, vallen);
510 sv_catpvn(retval, "'", 1);
511 return 1;
512 }
513
4ab99479 514 if (realpack && !no_bless) { /* we have a blessed ref */
a2126434 515 STRLEN blesslen;
9061c4b9 516 const char * const blessstr = SvPV(bless, blesslen);
a2126434
JN
517 sv_catpvn(retval, blessstr, blesslen);
518 sv_catpvn(retval, "( ", 2);
519 if (indent >= 2) {
520 blesspad = apad;
521 apad = newSVsv(apad);
522 sv_x(aTHX_ apad, " ", 1, blesslen+2);
823edd99
GS
523 }
524 }
525
7894fbab 526 (*levelp)++;
aa07b2f6 527 ipad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp);
7894fbab 528
4ab99479
YO
529 if (is_regex)
530 {
531 STRLEN rlen;
532 const char *rval = SvPV(val, rlen);
de5ef703
FC
533 const char * const rend = rval+rlen;
534 const char *slash = rval;
4ab99479 535 sv_catpvn(retval, "qr/", 3);
de5ef703
FC
536 for (;slash < rend; slash++) {
537 if (*slash == '\\') { ++slash; continue; }
538 if (*slash == '/') {
4ab99479
YO
539 sv_catpvn(retval, rval, slash-rval);
540 sv_catpvn(retval, "\\/", 2);
541 rlen -= slash-rval+1;
542 rval = slash+1;
de5ef703 543 }
4ab99479
YO
544 }
545 sv_catpvn(retval, rval, rlen);
546 sv_catpvn(retval, "/", 1);
547 }
548 else if (
d1dd14d1
JH
549#if PERL_VERSION < 9
550 realtype <= SVt_PVBM
551#else
552 realtype <= SVt_PVMG
553#endif
554 ) { /* scalar ref */
9061c4b9 555 SV * const namesv = newSVpvn("${", 2);
7820172a
GS
556 sv_catpvn(namesv, name, namelen);
557 sv_catpvn(namesv, "}", 1);
6cde4e94 558 if (realpack) { /* blessed */
823edd99 559 sv_catpvn(retval, "do{\\(my $o = ", 13);
aa07b2f6 560 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
30b4f386 561 postav, levelp, indent, pad, xpad, apad, sep, pair,
a2126434 562 freezer, toaster, purity, deepcopy, quotekeys, bless,
9baac1a3 563 maxdepth, sortkeys, use_sparse_seen_hash, useqq);
823edd99 564 sv_catpvn(retval, ")}", 2);
7820172a 565 } /* plain */
823edd99
GS
566 else {
567 sv_catpvn(retval, "\\", 1);
aa07b2f6 568 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
30b4f386 569 postav, levelp, indent, pad, xpad, apad, sep, pair,
a2126434 570 freezer, toaster, purity, deepcopy, quotekeys, bless,
9baac1a3 571 maxdepth, sortkeys, use_sparse_seen_hash, useqq);
823edd99 572 }
7820172a
GS
573 SvREFCNT_dec(namesv);
574 }
575 else if (realtype == SVt_PVGV) { /* glob ref */
9061c4b9 576 SV * const namesv = newSVpvn("*{", 2);
7820172a
GS
577 sv_catpvn(namesv, name, namelen);
578 sv_catpvn(namesv, "}", 1);
579 sv_catpvn(retval, "\\", 1);
aa07b2f6 580 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
30b4f386 581 postav, levelp, indent, pad, xpad, apad, sep, pair,
a2126434 582 freezer, toaster, purity, deepcopy, quotekeys, bless,
9baac1a3 583 maxdepth, sortkeys, use_sparse_seen_hash, useqq);
7820172a 584 SvREFCNT_dec(namesv);
823edd99
GS
585 }
586 else if (realtype == SVt_PVAV) {
587 SV *totpad;
588 I32 ix = 0;
9061c4b9 589 const I32 ixmax = av_len((AV *)ival);
6cde4e94 590
9061c4b9 591 SV * const ixsv = newSViv(0);
823edd99
GS
592 /* allowing for a 24 char wide array index */
593 New(0, iname, namelen+28, char);
594 (void)strcpy(iname, name);
595 inamelen = namelen;
596 if (name[0] == '@') {
597 sv_catpvn(retval, "(", 1);
598 iname[0] = '$';
599 }
600 else {
601 sv_catpvn(retval, "[", 1);
7820172a
GS
602 /* omit "->" in $foo{bar}->[0], but not in ${$foo}->[0] */
603 /*if (namelen > 0
604 && name[namelen-1] != ']' && name[namelen-1] != '}'
605 && (namelen < 4 || (name[1] != '{' && name[2] != '{')))*/
606 if ((namelen > 0
607 && name[namelen-1] != ']' && name[namelen-1] != '}')
608 || (namelen > 4
609 && (name[1] == '{'
610 || (name[0] == '\\' && name[2] == '{'))))
611 {
823edd99
GS
612 iname[inamelen++] = '-'; iname[inamelen++] = '>';
613 iname[inamelen] = '\0';
614 }
615 }
616 if (iname[0] == '*' && iname[inamelen-1] == '}' && inamelen >= 8 &&
617 (instr(iname+inamelen-8, "{SCALAR}") ||
618 instr(iname+inamelen-7, "{ARRAY}") ||
619 instr(iname+inamelen-6, "{HASH}"))) {
620 iname[inamelen++] = '-'; iname[inamelen++] = '>';
621 }
622 iname[inamelen++] = '['; iname[inamelen] = '\0';
623 totpad = newSVsv(sep);
624 sv_catsv(totpad, pad);
625 sv_catsv(totpad, apad);
626
627 for (ix = 0; ix <= ixmax; ++ix) {
628 STRLEN ilen;
629 SV *elem;
630 svp = av_fetch((AV*)ival, ix, FALSE);
631 if (svp)
632 elem = *svp;
633 else
3280af22 634 elem = &PL_sv_undef;
823edd99
GS
635
636 ilen = inamelen;
637 sv_setiv(ixsv, ix);
02c14053
AC
638#if PERL_VERSION < 10
639 (void) sprintf(iname+ilen, "%"IVdf, (IV)ix);
640 ilen = strlen(iname);
641#else
f5def3a2 642 ilen = ilen + my_sprintf(iname+ilen, "%"IVdf, (IV)ix);
02c14053 643#endif
823edd99
GS
644 iname[ilen++] = ']'; iname[ilen] = '\0';
645 if (indent >= 3) {
646 sv_catsv(retval, totpad);
647 sv_catsv(retval, ipad);
648 sv_catpvn(retval, "#", 1);
649 sv_catsv(retval, ixsv);
650 }
651 sv_catsv(retval, totpad);
652 sv_catsv(retval, ipad);
cea2e8a9 653 DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav,
30b4f386 654 levelp, indent, pad, xpad, apad, sep, pair,
a2126434 655 freezer, toaster, purity, deepcopy, quotekeys, bless,
9baac1a3 656 maxdepth, sortkeys, use_sparse_seen_hash, useqq);
823edd99
GS
657 if (ix < ixmax)
658 sv_catpvn(retval, ",", 1);
659 }
660 if (ixmax >= 0) {
9061c4b9 661 SV * const opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), (*levelp)-1);
823edd99
GS
662 sv_catsv(retval, totpad);
663 sv_catsv(retval, opad);
664 SvREFCNT_dec(opad);
665 }
666 if (name[0] == '@')
667 sv_catpvn(retval, ")", 1);
668 else
669 sv_catpvn(retval, "]", 1);
670 SvREFCNT_dec(ixsv);
671 SvREFCNT_dec(totpad);
672 Safefree(iname);
673 }
674 else if (realtype == SVt_PVHV) {
675 SV *totpad, *newapad;
9061c4b9 676 SV *sname;
823edd99
GS
677 HE *entry;
678 char *key;
679 I32 klen;
680 SV *hval;
7d49f689 681 AV *keys = NULL;
6cde4e94 682
9061c4b9 683 SV * const iname = newSVpvn(name, namelen);
823edd99
GS
684 if (name[0] == '%') {
685 sv_catpvn(retval, "(", 1);
686 (SvPVX(iname))[0] = '$';
687 }
688 else {
689 sv_catpvn(retval, "{", 1);
7820172a
GS
690 /* omit "->" in $foo[0]->{bar}, but not in ${$foo}->{bar} */
691 if ((namelen > 0
692 && name[namelen-1] != ']' && name[namelen-1] != '}')
693 || (namelen > 4
694 && (name[1] == '{'
695 || (name[0] == '\\' && name[2] == '{'))))
696 {
823edd99
GS
697 sv_catpvn(iname, "->", 2);
698 }
699 }
700 if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 &&
701 (instr(name+namelen-8, "{SCALAR}") ||
702 instr(name+namelen-7, "{ARRAY}") ||
703 instr(name+namelen-6, "{HASH}"))) {
704 sv_catpvn(iname, "->", 2);
705 }
706 sv_catpvn(iname, "{", 1);
707 totpad = newSVsv(sep);
708 sv_catsv(totpad, pad);
709 sv_catsv(totpad, apad);
6cde4e94 710
e9105f86
BI
711 /* If requested, get a sorted/filtered array of hash keys */
712 if (sortkeys) {
713 if (sortkeys == &PL_sv_yes) {
fec5e1eb
IM
714#if PERL_VERSION < 8
715 sortkeys = sv_2mortal(newSVpvn("Data::Dumper::_sortkeys", 23));
716#else
e9105f86
BI
717 keys = newAV();
718 (void)hv_iterinit((HV*)ival);
20d72259 719 while ((entry = hv_iternext((HV*)ival))) {
e9105f86 720 sv = hv_iterkeysv(entry);
63c7889e 721 (void)SvREFCNT_inc(sv);
e9105f86
BI
722 av_push(keys, sv);
723 }
fec5e1eb 724# ifdef USE_LOCALE_NUMERIC
e9105f86
BI
725 sortsv(AvARRAY(keys),
726 av_len(keys)+1,
3c253d0e 727 IN_LOCALE ? Perl_sv_cmp_locale : Perl_sv_cmp);
fec5e1eb 728# else
503ec68f
JH
729 sortsv(AvARRAY(keys),
730 av_len(keys)+1,
731 Perl_sv_cmp);
fec5e1eb 732# endif
02a99678 733#endif
e9105f86 734 }
fec5e1eb 735 if (sortkeys != &PL_sv_yes) {
e9105f86
BI
736 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
737 XPUSHs(sv_2mortal(newRV_inc(ival))); PUTBACK;
738 i = perl_call_sv(sortkeys, G_SCALAR | G_EVAL);
739 SPAGAIN;
740 if (i) {
741 sv = POPs;
742 if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVAV))
743 keys = (AV*)SvREFCNT_inc(SvRV(sv));
744 }
745 if (! keys)
746 warn("Sortkeys subroutine did not return ARRAYREF\n");
747 PUTBACK; FREETMPS; LEAVE;
748 }
749 if (keys)
750 sv_2mortal((SV*)keys);
751 }
752 else
753 (void)hv_iterinit((HV*)ival);
ecfc8647
AMS
754
755 /* foreach (keys %hash) */
756 for (i = 0; 1; i++) {
fdce9ba9
NC
757 char *nkey;
758 char *nkey_buffer = NULL;
823edd99 759 I32 nticks = 0;
dc71dc59
JH
760 SV* keysv;
761 STRLEN keylen;
fdce9ba9 762 I32 nlen;
dc71dc59 763 bool do_utf8 = FALSE;
ecfc8647 764
27688d77
YST
765 if (sortkeys) {
766 if (!(keys && (I32)i <= av_len(keys))) break;
767 } else {
768 if (!(entry = hv_iternext((HV *)ival))) break;
769 }
ecfc8647 770
823edd99
GS
771 if (i)
772 sv_catpvn(retval, ",", 1);
e9105f86
BI
773
774 if (sortkeys) {
775 char *key;
776 svp = av_fetch(keys, i, FALSE);
4bbdbd51 777 keysv = svp ? *svp : sv_newmortal();
e9105f86 778 key = SvPV(keysv, keylen);
d075f8ed 779 svp = hv_fetch((HV*)ival, key,
c33e8be1 780 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen, 0);
4bbdbd51 781 hval = svp ? *svp : sv_newmortal();
e9105f86
BI
782 }
783 else {
784 keysv = hv_iterkeysv(entry);
785 hval = hv_iterval((HV*)ival, entry);
786 }
787
dc71dc59 788 key = SvPV(keysv, keylen);
8738e0c0 789 do_utf8 = DO_UTF8(keysv);
dc71dc59
JH
790 klen = keylen;
791
fdce9ba9
NC
792 sv_catsv(retval, totpad);
793 sv_catsv(retval, ipad);
794 /* old logic was first to check utf8 flag, and if utf8 always
795 call esc_q_utf8. This caused test to break under -Mutf8,
796 because there even strings like 'c' have utf8 flag on.
797 Hence with quotekeys == 0 the XS code would still '' quote
798 them based on flags, whereas the perl code would not,
799 based on regexps.
800 The perl code is correct.
801 needs_quote() decides that anything that isn't a valid
802 perl identifier needs to be quoted, hence only correctly
803 formed strings with no characters outside [A-Za-z0-9_:]
804 won't need quoting. None of those characters are used in
805 the byte encoding of utf8, so anything with utf8
806 encoded characters in will need quoting. Hence strings
807 with utf8 encoded characters in will end up inside do_utf8
808 just like before, but now strings with utf8 flag set but
809 only ascii characters will end up in the unquoted section.
810
811 There should also be less tests for the (probably currently)
812 more common doesn't need quoting case.
813 The code is also smaller (22044 vs 22260) because I've been
30b4f386 814 able to pull the common logic out to both sides. */
95869c09 815 if (quotekeys || needs_quote(key,keylen)) {
9baac1a3 816 if (do_utf8 || useqq) {
fdce9ba9 817 STRLEN ocur = SvCUR(retval);
9baac1a3 818 nlen = esc_q_utf8(aTHX_ retval, key, klen, do_utf8, useqq);
fdce9ba9
NC
819 nkey = SvPVX(retval) + ocur;
820 }
821 else {
dc71dc59 822 nticks = num_q(key, klen);
fdce9ba9
NC
823 New(0, nkey_buffer, klen+nticks+3, char);
824 nkey = nkey_buffer;
dc71dc59
JH
825 nkey[0] = '\'';
826 if (nticks)
827 klen += esc_q(nkey+1, key, klen);
828 else
829 (void)Copy(key, nkey+1, klen, char);
830 nkey[++klen] = '\'';
831 nkey[++klen] = '\0';
fdce9ba9
NC
832 nlen = klen;
833 sv_catpvn(retval, nkey, klen);
dc71dc59 834 }
fdce9ba9
NC
835 }
836 else {
837 nkey = key;
838 nlen = klen;
839 sv_catpvn(retval, nkey, klen);
dc71dc59 840 }
fdce9ba9
NC
841 sname = newSVsv(iname);
842 sv_catpvn(sname, nkey, nlen);
843 sv_catpvn(sname, "}", 1);
844
30b4f386 845 sv_catsv(retval, pair);
823edd99
GS
846 if (indent >= 2) {
847 char *extra;
848 I32 elen = 0;
849 newapad = newSVsv(apad);
850 New(0, extra, klen+4+1, char);
851 while (elen < (klen+4))
852 extra[elen++] = ' ';
853 extra[elen] = '\0';
854 sv_catpvn(newapad, extra, elen);
855 Safefree(extra);
856 }
857 else
858 newapad = apad;
859
aa07b2f6 860 DD_dump(aTHX_ hval, SvPVX_const(sname), SvCUR(sname), retval, seenhv,
30b4f386 861 postav, levelp, indent, pad, xpad, newapad, sep, pair,
a2126434 862 freezer, toaster, purity, deepcopy, quotekeys, bless,
9baac1a3 863 maxdepth, sortkeys, use_sparse_seen_hash, useqq);
823edd99 864 SvREFCNT_dec(sname);
fdce9ba9 865 Safefree(nkey_buffer);
823edd99
GS
866 if (indent >= 2)
867 SvREFCNT_dec(newapad);
868 }
869 if (i) {
aa07b2f6 870 SV *opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp-1);
823edd99
GS
871 sv_catsv(retval, totpad);
872 sv_catsv(retval, opad);
873 SvREFCNT_dec(opad);
874 }
875 if (name[0] == '%')
876 sv_catpvn(retval, ")", 1);
877 else
878 sv_catpvn(retval, "}", 1);
879 SvREFCNT_dec(iname);
880 SvREFCNT_dec(totpad);
881 }
882 else if (realtype == SVt_PVCV) {
883 sv_catpvn(retval, "sub { \"DUMMY\" }", 15);
884 if (purity)
885 warn("Encountered CODE ref, using dummy placeholder");
886 }
887 else {
4f12661d 888 warn("cannot handle ref type %d", (int)realtype);
823edd99
GS
889 }
890
4ab99479 891 if (realpack && !no_bless) { /* free blessed allocs */
d0c214fd
AF
892 I32 plen;
893 I32 pticks;
894
823edd99
GS
895 if (indent >= 2) {
896 SvREFCNT_dec(apad);
897 apad = blesspad;
898 }
899 sv_catpvn(retval, ", '", 3);
d0c214fd
AF
900
901 plen = strlen(realpack);
902 pticks = num_q(realpack, plen);
34baf60a 903 if (pticks) { /* needs escaping */
d0c214fd
AF
904 char *npack;
905 char *npack_buffer = NULL;
906
907 New(0, npack_buffer, plen+pticks+1, char);
908 npack = npack_buffer;
909 plen += esc_q(npack, realpack, plen);
910 npack[plen] = '\0';
911
912 sv_catpvn(retval, npack, plen);
913 Safefree(npack_buffer);
914 }
915 else {
916 sv_catpvn(retval, realpack, strlen(realpack));
917 }
823edd99
GS
918 sv_catpvn(retval, "' )", 3);
919 if (toaster && SvPOK(toaster) && SvCUR(toaster)) {
920 sv_catpvn(retval, "->", 2);
921 sv_catsv(retval, toaster);
922 sv_catpvn(retval, "()", 2);
923 }
924 }
925 SvREFCNT_dec(ipad);
926 (*levelp)--;
927 }
928 else {
929 STRLEN i;
d036e907 930 const MAGIC *mg;
823edd99
GS
931
932 if (namelen) {
e52c0e5a 933#ifdef DD_USE_OLD_ID_FORMAT
f5def3a2 934 idlen = my_snprintf(id, sizeof(id), "0x%"UVxf, PTR2UV(val));
e52c0e5a
NC
935#else
936 id_buffer = PTR2UV(val);
937 idlen = sizeof(id_buffer);
938#endif
f5def3a2 939 if ((svp = hv_fetch(seenhv, id, idlen, FALSE)) &&
823edd99 940 (sv = *svp) && SvROK(sv) &&
7820172a
GS
941 (seenentry = (AV*)SvRV(sv)))
942 {
823edd99 943 SV *othername;
7820172a
GS
944 if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)
945 && (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0)
946 {
947 sv_catpvn(retval, "${", 2);
823edd99 948 sv_catsv(retval, othername);
7820172a 949 sv_catpvn(retval, "}", 1);
823edd99
GS
950 return 1;
951 }
952 }
d424882c
SM
953 /* If we're allowed to keep only a sparse "seen" hash
954 * (IOW, the user does not expect it to contain everything
955 * after the dump, then only store in seen hash if the SV
956 * ref count is larger than 1. If it's 1, then we know that
bdf6ae42
SM
957 * there is no other reference, duh. This is an optimization.
958 * Note that we'd have to check for weak-refs, too, but this is
959 * already the branch for non-refs only. */
d424882c 960 else if (val != &PL_sv_undef && (!use_sparse_seen_hash || SvREFCNT(val) > 1)) {
9061c4b9 961 SV * const namesv = newSVpvn("\\", 1);
823edd99
GS
962 sv_catpvn(namesv, name, namelen);
963 seenentry = newAV();
964 av_push(seenentry, namesv);
fec5e1eb 965 av_push(seenentry, newRV_inc(val));
383d9087 966 (void)hv_store(seenhv, id, idlen, newRV_inc((SV*)seenentry), 0);
823edd99
GS
967 SvREFCNT_dec(seenentry);
968 }
969 }
7820172a 970
fec5e1eb 971 if (DD_is_integer(val)) {
823edd99 972 STRLEN len;
0e8b3009 973 if (SvIsUV(val))
f5def3a2 974 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"UVuf, SvUV(val));
0e8b3009 975 else
f5def3a2 976 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"IVdf, SvIV(val));
c4cce848
NC
977 if (SvPOK(val)) {
978 /* Need to check to see if this is a string such as " 0".
979 I'm assuming from sprintf isn't going to clash with utf8.
980 Is this valid on EBCDIC? */
981 STRLEN pvlen;
9061c4b9 982 const char * const pv = SvPV(val, pvlen);
c4cce848
NC
983 if (pvlen != len || memNE(pv, tmpbuf, len))
984 goto integer_came_from_string;
985 }
986 if (len > 10) {
987 /* Looks like we're on a 64 bit system. Make it a string so that
988 if a 32 bit system reads the number it will cope better. */
989 sv_catpvf(retval, "'%s'", tmpbuf);
990 } else
991 sv_catpvn(retval, tmpbuf, len);
823edd99
GS
992 }
993 else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */
994 c = SvPV(val, i);
ecf0432f 995 if(i) ++c, --i; /* just get the name */
823edd99
GS
996 if (i >= 6 && strncmp(c, "main::", 6) == 0) {
997 c += 4;
ad08c923
FC
998#if PERL_VERSION < 7
999 if (i == 6 || (i == 7 && c[6] == '\0'))
1000#else
1001 if (i == 6)
1002#endif
1003 i = 0; else i -= 4;
823edd99 1004 }
95869c09
FC
1005 if (needs_quote(c,i)) {
1006#ifdef GvNAMEUTF8
1007 if (GvNAMEUTF8(val)) {
1008 sv_grow(retval, SvCUR(retval)+2);
1009 r = SvPVX(retval)+SvCUR(retval);
1010 r[0] = '*'; r[1] = '{';
1011 SvCUR_set(retval, SvCUR(retval)+2);
9baac1a3 1012 esc_q_utf8(aTHX_ retval, c, i, 1, useqq);
95869c09
FC
1013 sv_grow(retval, SvCUR(retval)+2);
1014 r = SvPVX(retval)+SvCUR(retval);
1015 r[0] = '}'; r[1] = '\0';
1016 i = 1;
1017 }
1018 else
1019#endif
1020 {
823edd99
GS
1021 sv_grow(retval, SvCUR(retval)+6+2*i);
1022 r = SvPVX(retval)+SvCUR(retval);
1023 r[0] = '*'; r[1] = '{'; r[2] = '\'';
1024 i += esc_q(r+3, c, i);
1025 i += 3;
1026 r[i++] = '\''; r[i++] = '}';
1027 r[i] = '\0';
95869c09 1028 }
823edd99
GS
1029 }
1030 else {
1031 sv_grow(retval, SvCUR(retval)+i+2);
1032 r = SvPVX(retval)+SvCUR(retval);
1033 r[0] = '*'; strcpy(r+1, c);
1034 i++;
1035 }
7820172a 1036 SvCUR_set(retval, SvCUR(retval)+i);
823edd99
GS
1037
1038 if (purity) {
27da23d5
JH
1039 static const char* const entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" };
1040 static const STRLEN sizes[] = { 8, 7, 6 };
823edd99 1041 SV *e;
9061c4b9
AL
1042 SV * const nname = newSVpvn("", 0);
1043 SV * const newapad = newSVpvn("", 0);
1044 GV * const gv = (GV*)val;
823edd99
GS
1045 I32 j;
1046
1047 for (j=0; j<3; j++) {
1048 e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv));
7820172a
GS
1049 if (!e)
1050 continue;
1051 if (j == 0 && !SvOK(e))
1052 continue;
1053
1054 {
823edd99 1055 I32 nlevel = 0;
7820172a 1056 SV *postentry = newSVpvn(r,i);
823edd99
GS
1057
1058 sv_setsv(nname, postentry);
1059 sv_catpvn(nname, entries[j], sizes[j]);
1060 sv_catpvn(postentry, " = ", 3);
1061 av_push(postav, postentry);
fec5e1eb 1062 e = newRV_inc(e);
823edd99 1063
b162af07 1064 SvCUR_set(newapad, 0);
823edd99 1065 if (indent >= 2)
cea2e8a9 1066 (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry));
823edd99 1067
aa07b2f6 1068 DD_dump(aTHX_ e, SvPVX_const(nname), SvCUR(nname), postentry,
823edd99 1069 seenhv, postav, &nlevel, indent, pad, xpad,
30b4f386 1070 newapad, sep, pair, freezer, toaster, purity,
e9105f86 1071 deepcopy, quotekeys, bless, maxdepth,
9baac1a3 1072 sortkeys, use_sparse_seen_hash, useqq);
823edd99
GS
1073 SvREFCNT_dec(e);
1074 }
1075 }
1076
1077 SvREFCNT_dec(newapad);
1078 SvREFCNT_dec(nname);
1079 }
1080 }
7820172a
GS
1081 else if (val == &PL_sv_undef || !SvOK(val)) {
1082 sv_catpvn(retval, "undef", 5);
1083 }
d036e907
FC
1084#ifdef SvVOK
1085 else if (SvMAGICAL(val) && (mg = mg_find(val, 'V'))) {
5fde9fa4 1086# if !defined(PL_vtbl_vstring) && PERL_VERSION < 17
d036e907
FC
1087 SV * const vecsv = sv_newmortal();
1088# if PERL_VERSION < 10
1089 scan_vstring(mg->mg_ptr, vecsv);
1090# else
1091 scan_vstring(mg->mg_ptr, mg->mg_ptr + mg->mg_len, vecsv);
1092# endif
1093 if (!sv_eq(vecsv, val)) goto integer_came_from_string;
1094# endif
1095 sv_catpvn(retval, (const char *)mg->mg_ptr, mg->mg_len);
1096 }
1097#endif
823edd99 1098 else {
c4cce848 1099 integer_came_from_string:
823edd99 1100 c = SvPV(val, i);
9baac1a3
SR
1101 if (DO_UTF8(val) || useqq)
1102 i += esc_q_utf8(aTHX_ retval, c, i, DO_UTF8(val), useqq);
dc71dc59
JH
1103 else {
1104 sv_grow(retval, SvCUR(retval)+3+2*i); /* 3: ""\0 */
1105 r = SvPVX(retval) + SvCUR(retval);
1106 r[0] = '\'';
1107 i += esc_q(r+1, c, i);
1108 ++i;
1109 r[i++] = '\'';
1110 r[i] = '\0';
1111 SvCUR_set(retval, SvCUR(retval)+i);
1112 }
823edd99 1113 }
823edd99
GS
1114 }
1115
7820172a
GS
1116 if (idlen) {
1117 if (deepcopy)
1118 (void)hv_delete(seenhv, id, idlen, G_DISCARD);
1119 else if (namelen && seenentry) {
1120 SV *mark = *av_fetch(seenentry, 2, TRUE);
1121 sv_setiv(mark,1);
1122 }
1123 }
823edd99
GS
1124 return 1;
1125}
1126
1127
1128MODULE = Data::Dumper PACKAGE = Data::Dumper PREFIX = Data_Dumper_
1129
1130#
1131# This is the exact equivalent of Dump. Well, almost. The things that are
1132# different as of now (due to Laziness):
c4a6f826 1133# * doesn't do double-quotes yet.
823edd99
GS
1134#
1135
1136void
1137Data_Dumper_Dumpxs(href, ...)
1138 SV *href;
1139 PROTOTYPE: $;$$
1140 PPCODE:
1141 {
1142 HV *hv;
1143 SV *retval, *valstr;
5c284bb0 1144 HV *seenhv = NULL;
823edd99
GS
1145 AV *postav, *todumpav, *namesav;
1146 I32 level = 0;
9baac1a3 1147 I32 indent, terse, useqq, i, imax, postlen;
823edd99 1148 SV **svp;
30b4f386 1149 SV *val, *name, *pad, *xpad, *apad, *sep, *pair, *varname;
e9105f86 1150 SV *freezer, *toaster, *bless, *sortkeys;
7b0972df 1151 I32 purity, deepcopy, quotekeys, maxdepth = 0;
823edd99
GS
1152 char tmpbuf[1024];
1153 I32 gimme = GIMME;
d424882c 1154 int use_sparse_seen_hash = 0;
823edd99
GS
1155
1156 if (!SvROK(href)) { /* call new to get an object first */
0f1923bd
GS
1157 if (items < 2)
1158 croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, [NAME_ARY_REF])");
823edd99
GS
1159
1160 ENTER;
1161 SAVETMPS;
1162
1163 PUSHMARK(sp);
6a876a42
SM
1164 EXTEND(SP, 3); /* 3 == max of all branches below */
1165 PUSHs(href);
1166 PUSHs(sv_2mortal(newSVsv(ST(1))));
0f1923bd 1167 if (items >= 3)
6a876a42 1168 PUSHs(sv_2mortal(newSVsv(ST(2))));
823edd99
GS
1169 PUTBACK;
1170 i = perl_call_method("new", G_SCALAR);
1171 SPAGAIN;
1172 if (i)
1173 href = newSVsv(POPs);
1174
1175 PUTBACK;
1176 FREETMPS;
1177 LEAVE;
1178 if (i)
1179 (void)sv_2mortal(href);
1180 }
1181
7d49f689 1182 todumpav = namesav = NULL;
5c284bb0 1183 seenhv = NULL;
30b4f386 1184 val = pad = xpad = apad = sep = pair = varname
65e66c80 1185 = freezer = toaster = bless = sortkeys = &PL_sv_undef;
823edd99
GS
1186 name = sv_newmortal();
1187 indent = 2;
9baac1a3 1188 terse = purity = deepcopy = useqq = 0;
823edd99 1189 quotekeys = 1;
6cde4e94 1190
7820172a 1191 retval = newSVpvn("", 0);
823edd99
GS
1192 if (SvROK(href)
1193 && (hv = (HV*)SvRV((SV*)href))
1194 && SvTYPE(hv) == SVt_PVHV) {
1195
1196 if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp))
1197 seenhv = (HV*)SvRV(*svp);
d424882c
SM
1198 else
1199 use_sparse_seen_hash = 1;
1200 if ((svp = hv_fetch(hv, "noseen", 6, FALSE)))
1201 use_sparse_seen_hash = (SvOK(*svp) && SvIV(*svp) != 0);
823edd99
GS
1202 if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp))
1203 todumpav = (AV*)SvRV(*svp);
1204 if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp))
1205 namesav = (AV*)SvRV(*svp);
1206 if ((svp = hv_fetch(hv, "indent", 6, FALSE)))
1207 indent = SvIV(*svp);
1208 if ((svp = hv_fetch(hv, "purity", 6, FALSE)))
1209 purity = SvIV(*svp);
1210 if ((svp = hv_fetch(hv, "terse", 5, FALSE)))
1211 terse = SvTRUE(*svp);
1212 if ((svp = hv_fetch(hv, "useqq", 5, FALSE)))
1213 useqq = SvTRUE(*svp);
1214 if ((svp = hv_fetch(hv, "pad", 3, FALSE)))
1215 pad = *svp;
1216 if ((svp = hv_fetch(hv, "xpad", 4, FALSE)))
1217 xpad = *svp;
1218 if ((svp = hv_fetch(hv, "apad", 4, FALSE)))
1219 apad = *svp;
1220 if ((svp = hv_fetch(hv, "sep", 3, FALSE)))
1221 sep = *svp;
30b4f386 1222 if ((svp = hv_fetch(hv, "pair", 4, FALSE)))
1223 pair = *svp;
823edd99
GS
1224 if ((svp = hv_fetch(hv, "varname", 7, FALSE)))
1225 varname = *svp;
1226 if ((svp = hv_fetch(hv, "freezer", 7, FALSE)))
1227 freezer = *svp;
1228 if ((svp = hv_fetch(hv, "toaster", 7, FALSE)))
1229 toaster = *svp;
1230 if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE)))
1231 deepcopy = SvTRUE(*svp);
1232 if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE)))
1233 quotekeys = SvTRUE(*svp);
1234 if ((svp = hv_fetch(hv, "bless", 5, FALSE)))
1235 bless = *svp;
a2126434
JN
1236 if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE)))
1237 maxdepth = SvIV(*svp);
e9105f86
BI
1238 if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) {
1239 sortkeys = *svp;
1240 if (! SvTRUE(sortkeys))
1241 sortkeys = NULL;
1242 else if (! (SvROK(sortkeys) &&
1243 SvTYPE(SvRV(sortkeys)) == SVt_PVCV) )
1244 {
1245 /* flag to use qsortsv() for sorting hash keys */
1246 sortkeys = &PL_sv_yes;
1247 }
1248 }
823edd99
GS
1249 postav = newAV();
1250
1251 if (todumpav)
1252 imax = av_len(todumpav);
1253 else
1254 imax = -1;
7820172a 1255 valstr = newSVpvn("",0);
823edd99
GS
1256 for (i = 0; i <= imax; ++i) {
1257 SV *newapad;
6cde4e94 1258
823edd99
GS
1259 av_clear(postav);
1260 if ((svp = av_fetch(todumpav, i, FALSE)))
1261 val = *svp;
1262 else
3280af22 1263 val = &PL_sv_undef;
d20128b8 1264 if ((svp = av_fetch(namesav, i, TRUE))) {
823edd99 1265 sv_setsv(name, *svp);
d20128b8
RGS
1266 if (SvOK(*svp) && !SvPOK(*svp))
1267 (void)SvPV_nolen_const(name);
1268 }
823edd99 1269 else
8063af02 1270 (void)SvOK_off(name);
6cde4e94 1271
d20128b8 1272 if (SvPOK(name)) {
aa07b2f6 1273 if ((SvPVX_const(name))[0] == '*') {
823edd99
GS
1274 if (SvROK(val)) {
1275 switch (SvTYPE(SvRV(val))) {
1276 case SVt_PVAV:
1277 (SvPVX(name))[0] = '@';
1278 break;
1279 case SVt_PVHV:
1280 (SvPVX(name))[0] = '%';
1281 break;
1282 case SVt_PVCV:
1283 (SvPVX(name))[0] = '*';
1284 break;
1285 default:
1286 (SvPVX(name))[0] = '$';
1287 break;
1288 }
1289 }
1290 else
1291 (SvPVX(name))[0] = '$';
1292 }
aa07b2f6 1293 else if ((SvPVX_const(name))[0] != '$')
823edd99
GS
1294 sv_insert(name, 0, 0, "$", 1);
1295 }
1296 else {
9061c4b9 1297 STRLEN nchars;
823edd99
GS
1298 sv_setpvn(name, "$", 1);
1299 sv_catsv(name, varname);
f5def3a2 1300 nchars = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"IVdf, (IV)(i+1));
823edd99
GS
1301 sv_catpvn(name, tmpbuf, nchars);
1302 }
6cde4e94 1303
d34e9bd9 1304 if (indent >= 2 && !terse) {
9061c4b9 1305 SV * const tmpsv = sv_x(aTHX_ NULL, " ", 1, SvCUR(name)+3);
823edd99
GS
1306 newapad = newSVsv(apad);
1307 sv_catsv(newapad, tmpsv);
1308 SvREFCNT_dec(tmpsv);
1309 }
1310 else
1311 newapad = apad;
6cde4e94 1312
e3ec2293 1313 PUTBACK;
aa07b2f6 1314 DD_dump(aTHX_ val, SvPVX_const(name), SvCUR(name), valstr, seenhv,
30b4f386 1315 postav, &level, indent, pad, xpad, newapad, sep, pair,
823edd99 1316 freezer, toaster, purity, deepcopy, quotekeys,
9baac1a3 1317 bless, maxdepth, sortkeys, use_sparse_seen_hash, useqq);
e3ec2293 1318 SPAGAIN;
6cde4e94 1319
d34e9bd9 1320 if (indent >= 2 && !terse)
823edd99
GS
1321 SvREFCNT_dec(newapad);
1322
1323 postlen = av_len(postav);
1324 if (postlen >= 0 || !terse) {
1325 sv_insert(valstr, 0, 0, " = ", 3);
aa07b2f6 1326 sv_insert(valstr, 0, 0, SvPVX_const(name), SvCUR(name));
823edd99
GS
1327 sv_catpvn(valstr, ";", 1);
1328 }
1329 sv_catsv(retval, pad);
1330 sv_catsv(retval, valstr);
1331 sv_catsv(retval, sep);
1332 if (postlen >= 0) {
1333 I32 i;
1334 sv_catsv(retval, pad);
1335 for (i = 0; i <= postlen; ++i) {
1336 SV *elem;
1337 svp = av_fetch(postav, i, FALSE);
1338 if (svp && (elem = *svp)) {
1339 sv_catsv(retval, elem);
1340 if (i < postlen) {
1341 sv_catpvn(retval, ";", 1);
1342 sv_catsv(retval, sep);
1343 sv_catsv(retval, pad);
1344 }
1345 }
1346 }
1347 sv_catpvn(retval, ";", 1);
1348 sv_catsv(retval, sep);
1349 }
1350 sv_setpvn(valstr, "", 0);
1351 if (gimme == G_ARRAY) {
1352 XPUSHs(sv_2mortal(retval));
1353 if (i < imax) /* not the last time thro ? */
7820172a 1354 retval = newSVpvn("",0);
823edd99
GS
1355 }
1356 }
1357 SvREFCNT_dec(postav);
1358 SvREFCNT_dec(valstr);
1359 }
1360 else
1361 croak("Call to new() method failed to return HASH ref");
1362 if (gimme == G_SCALAR)
1363 XPUSHs(sv_2mortal(retval));
1364 }
d036e907
FC
1365
1366SV *
1367Data_Dumper__vstring(sv)
1368 SV *sv;
1369 PROTOTYPE: $
1370 CODE:
1371 {
1372#ifdef SvVOK
1373 const MAGIC *mg;
1374 RETVAL =
1375 SvMAGICAL(sv) && (mg = mg_find(sv, 'V'))
1376 ? newSVpvn((const char *)mg->mg_ptr, mg->mg_len)
1377 : &PL_sv_undef;
1378#else
1379 RETVAL = &PL_sv_undef;
1380#endif
1381 }
1382 OUTPUT: RETVAL