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