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