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