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