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