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