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