This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Increase $Data::Dumper::VERSION to 2.135_02
[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,
e9105f86 25 I32 maxdepth, SV *sortkeys);
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
40Perl_utf8_to_uvchr(pTHX_ U8 *s, STRLEN *retlen)
41{
9061c4b9 42 const UV uv = utf8_to_uv(s, UTF8_MAXLEN, 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)
48# define utf8_to_uvchr Perl_utf8_to_uvchr
49# else
50# define utf8_to_uvchr(a,b) Perl_utf8_to_uvchr(aTHX_ a,b)
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) {
9061c4b9 150 const UV k = utf8_to_uvchr((U8*)s, 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)) {
9061c4b9 187 const UV k = utf8_to_uvchr((U8*)s, 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,
e9105f86 270 I32 deepcopy, I32 quotekeys, SV *bless, I32 maxdepth, SV *sortkeys)
823edd99
GS
271{
272 char tmpbuf[128];
273 U32 i;
e52c0e5a
NC
274 char *c, *r, *realpack;
275#ifdef DD_USE_OLD_ID_FORMAT
276 char id[128];
277#else
278 UV id_buffer;
279 char *const id = (char *)&id_buffer;
280#endif
823edd99 281 SV **svp;
7820172a 282 SV *sv, *ipad, *ival;
823edd99 283 SV *blesspad = Nullsv;
7d49f689 284 AV *seenentry = NULL;
823edd99
GS
285 char *iname;
286 STRLEN inamelen, idlen = 0;
823edd99 287 U32 realtype;
4ab99479
YO
288 bool no_bless = 0; /* when a qr// is blessed into Regexp we dont want to bless it.
289 in later perls we should actually check the classname of the
290 engine. this gets tricky as it involves lexical issues that arent so
291 easy to resolve */
292 bool is_regex = 0; /* we are dumping a regex, we need to know this before we bless */
823edd99
GS
293
294 if (!val)
295 return 0;
296
c4a6f826 297 /* If the ouput buffer has less than some arbitrary amount of space
a4e0d239
NC
298 remaining, then enlarge it. For the test case (25M of output),
299 *1.1 was slower, *2.0 was the same, so the first guess of 1.5 is
300 deemed to be good enough. */
301 if (SvTYPE(retval) >= SVt_PV && (SvLEN(retval) - SvCUR(retval)) < 42) {
97c52c3c 302 sv_grow(retval, SvCUR(retval) * 3 / 2);
9fa5cce2 303 }
a4e0d239 304
823edd99 305 realtype = SvTYPE(val);
6cde4e94 306
823edd99
GS
307 if (SvGMAGICAL(val))
308 mg_get(val);
823edd99
GS
309 if (SvROK(val)) {
310
c5f7c514
ST
311 /* If a freeze method is provided and the object has it, call
312 it. Warn on errors. */
823edd99 313 if (SvOBJECT(SvRV(val)) && freezer &&
c5f7c514 314 SvPOK(freezer) && SvCUR(freezer) &&
aa07b2f6 315 gv_fetchmeth(SvSTASH(SvRV(val)), SvPVX_const(freezer),
c5f7c514 316 SvCUR(freezer), -1) != NULL)
823edd99
GS
317 {
318 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
319 XPUSHs(val); PUTBACK;
aa07b2f6 320 i = perl_call_method(SvPVX_const(freezer), G_EVAL|G_VOID);
823edd99 321 SPAGAIN;
7820172a 322 if (SvTRUE(ERRSV))
35c1215d 323 warn("WARNING(Freezer method call failed): %"SVf"", ERRSV);
823edd99 324 PUTBACK; FREETMPS; LEAVE;
823edd99
GS
325 }
326
327 ival = SvRV(val);
823edd99 328 realtype = SvTYPE(ival);
e52c0e5a 329#ifdef DD_USE_OLD_ID_FORMAT
f5def3a2 330 idlen = my_snprintf(id, sizeof(id), "0x%"UVxf, PTR2UV(ival));
e52c0e5a
NC
331#else
332 id_buffer = PTR2UV(ival);
333 idlen = sizeof(id_buffer);
334#endif
823edd99 335 if (SvOBJECT(ival))
bfcb3514 336 realpack = HvNAME_get(SvSTASH(ival));
823edd99 337 else
9849c14c 338 realpack = NULL;
7820172a
GS
339
340 /* if it has a name, we need to either look it up, or keep a tab
341 * on it so we know when we hit it later
342 */
343 if (namelen) {
344 if ((svp = hv_fetch(seenhv, id, idlen, FALSE))
345 && (sv = *svp) && SvROK(sv) && (seenentry = (AV*)SvRV(sv)))
346 {
347 SV *othername;
348 if ((svp = av_fetch(seenentry, 0, FALSE))
349 && (othername = *svp))
350 {
351 if (purity && *levelp > 0) {
352 SV *postentry;
353
354 if (realtype == SVt_PVHV)
355 sv_catpvn(retval, "{}", 2);
356 else if (realtype == SVt_PVAV)
357 sv_catpvn(retval, "[]", 2);
358 else
5df59fb6 359 sv_catpvn(retval, "do{my $o}", 9);
7820172a
GS
360 postentry = newSVpvn(name, namelen);
361 sv_catpvn(postentry, " = ", 3);
362 sv_catsv(postentry, othername);
363 av_push(postav, postentry);
364 }
365 else {
366 if (name[0] == '@' || name[0] == '%') {
aa07b2f6
SP
367 if ((SvPVX_const(othername))[0] == '\\' &&
368 (SvPVX_const(othername))[1] == name[0]) {
369 sv_catpvn(retval, SvPVX_const(othername)+1,
7820172a
GS
370 SvCUR(othername)-1);
371 }
372 else {
373 sv_catpvn(retval, name, 1);
374 sv_catpvn(retval, "{", 1);
375 sv_catsv(retval, othername);
376 sv_catpvn(retval, "}", 1);
377 }
823edd99 378 }
7820172a 379 else
823edd99 380 sv_catsv(retval, othername);
823edd99 381 }
7820172a
GS
382 return 1;
383 }
384 else {
e52c0e5a 385#ifdef DD_USE_OLD_ID_FORMAT
7820172a 386 warn("ref name not found for %s", id);
e52c0e5a
NC
387#else
388 warn("ref name not found for 0x%"UVxf, PTR2UV(ival));
389#endif
7820172a 390 return 0;
823edd99 391 }
823edd99 392 }
7820172a
GS
393 else { /* store our name and continue */
394 SV *namesv;
395 if (name[0] == '@' || name[0] == '%') {
396 namesv = newSVpvn("\\", 1);
397 sv_catpvn(namesv, name, namelen);
398 }
399 else if (realtype == SVt_PVCV && name[0] == '*') {
400 namesv = newSVpvn("\\", 2);
401 sv_catpvn(namesv, name, namelen);
402 (SvPVX(namesv))[1] = '&';
403 }
404 else
405 namesv = newSVpvn(name, namelen);
406 seenentry = newAV();
407 av_push(seenentry, namesv);
408 (void)SvREFCNT_inc(val);
409 av_push(seenentry, val);
383d9087 410 (void)hv_store(seenhv, id, idlen,
fec5e1eb 411 newRV_inc((SV*)seenentry), 0);
7820172a 412 SvREFCNT_dec(seenentry);
823edd99 413 }
823edd99 414 }
4ab99479
YO
415 /* regexps dont have to be blessed into package "Regexp"
416 * they can be blessed into any package.
417 */
418#if PERL_VERSION < 8
419 if (realpack && *realpack == 'R' && strEQ(realpack, "Regexp"))
420#elif PERL_VERSION < 11
bd2db5df 421 if (realpack && realtype == SVt_PVMG && mg_find(ival, PERL_MAGIC_qr))
4ab99479
YO
422#else
423 if (realpack && realtype == SVt_REGEXP)
424#endif
425 {
426 is_regex = 1;
427 if (strEQ(realpack, "Regexp"))
428 no_bless = 1;
429 else
430 no_bless = 0;
431 }
a2126434
JN
432
433 /* If purity is not set and maxdepth is set, then check depth:
434 * if we have reached maximum depth, return the string
435 * representation of the thing we are currently examining
6cde4e94 436 * at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)').
a2126434
JN
437 */
438 if (!purity && maxdepth > 0 && *levelp >= maxdepth) {
439 STRLEN vallen;
9061c4b9 440 const char * const valstr = SvPV(val,vallen);
a2126434
JN
441 sv_catpvn(retval, "'", 1);
442 sv_catpvn(retval, valstr, vallen);
443 sv_catpvn(retval, "'", 1);
444 return 1;
445 }
446
4ab99479 447 if (realpack && !no_bless) { /* we have a blessed ref */
a2126434 448 STRLEN blesslen;
9061c4b9 449 const char * const blessstr = SvPV(bless, blesslen);
a2126434
JN
450 sv_catpvn(retval, blessstr, blesslen);
451 sv_catpvn(retval, "( ", 2);
452 if (indent >= 2) {
453 blesspad = apad;
454 apad = newSVsv(apad);
455 sv_x(aTHX_ apad, " ", 1, blesslen+2);
823edd99
GS
456 }
457 }
458
7894fbab 459 (*levelp)++;
aa07b2f6 460 ipad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp);
7894fbab 461
4ab99479
YO
462 if (is_regex)
463 {
464 STRLEN rlen;
465 const char *rval = SvPV(val, rlen);
466 const char *slash = strchr(rval, '/');
467 sv_catpvn(retval, "qr/", 3);
468 while (slash) {
469 sv_catpvn(retval, rval, slash-rval);
470 sv_catpvn(retval, "\\/", 2);
471 rlen -= slash-rval+1;
472 rval = slash+1;
473 slash = strchr(rval, '/');
474 }
475 sv_catpvn(retval, rval, rlen);
476 sv_catpvn(retval, "/", 1);
477 }
478 else if (
d1dd14d1
JH
479#if PERL_VERSION < 9
480 realtype <= SVt_PVBM
481#else
482 realtype <= SVt_PVMG
483#endif
484 ) { /* scalar ref */
9061c4b9 485 SV * const namesv = newSVpvn("${", 2);
7820172a
GS
486 sv_catpvn(namesv, name, namelen);
487 sv_catpvn(namesv, "}", 1);
6cde4e94 488 if (realpack) { /* blessed */
823edd99 489 sv_catpvn(retval, "do{\\(my $o = ", 13);
aa07b2f6 490 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
30b4f386 491 postav, levelp, indent, pad, xpad, apad, sep, pair,
a2126434 492 freezer, toaster, purity, deepcopy, quotekeys, bless,
e9105f86 493 maxdepth, sortkeys);
823edd99 494 sv_catpvn(retval, ")}", 2);
7820172a 495 } /* plain */
823edd99
GS
496 else {
497 sv_catpvn(retval, "\\", 1);
aa07b2f6 498 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
30b4f386 499 postav, levelp, indent, pad, xpad, apad, sep, pair,
a2126434 500 freezer, toaster, purity, deepcopy, quotekeys, bless,
e9105f86 501 maxdepth, sortkeys);
823edd99 502 }
7820172a
GS
503 SvREFCNT_dec(namesv);
504 }
505 else if (realtype == SVt_PVGV) { /* glob ref */
9061c4b9 506 SV * const namesv = newSVpvn("*{", 2);
7820172a
GS
507 sv_catpvn(namesv, name, namelen);
508 sv_catpvn(namesv, "}", 1);
509 sv_catpvn(retval, "\\", 1);
aa07b2f6 510 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
30b4f386 511 postav, levelp, indent, pad, xpad, apad, sep, pair,
a2126434 512 freezer, toaster, purity, deepcopy, quotekeys, bless,
e9105f86 513 maxdepth, sortkeys);
7820172a 514 SvREFCNT_dec(namesv);
823edd99
GS
515 }
516 else if (realtype == SVt_PVAV) {
517 SV *totpad;
518 I32 ix = 0;
9061c4b9 519 const I32 ixmax = av_len((AV *)ival);
6cde4e94 520
9061c4b9 521 SV * const ixsv = newSViv(0);
823edd99
GS
522 /* allowing for a 24 char wide array index */
523 New(0, iname, namelen+28, char);
524 (void)strcpy(iname, name);
525 inamelen = namelen;
526 if (name[0] == '@') {
527 sv_catpvn(retval, "(", 1);
528 iname[0] = '$';
529 }
530 else {
531 sv_catpvn(retval, "[", 1);
7820172a
GS
532 /* omit "->" in $foo{bar}->[0], but not in ${$foo}->[0] */
533 /*if (namelen > 0
534 && name[namelen-1] != ']' && name[namelen-1] != '}'
535 && (namelen < 4 || (name[1] != '{' && name[2] != '{')))*/
536 if ((namelen > 0
537 && name[namelen-1] != ']' && name[namelen-1] != '}')
538 || (namelen > 4
539 && (name[1] == '{'
540 || (name[0] == '\\' && name[2] == '{'))))
541 {
823edd99
GS
542 iname[inamelen++] = '-'; iname[inamelen++] = '>';
543 iname[inamelen] = '\0';
544 }
545 }
546 if (iname[0] == '*' && iname[inamelen-1] == '}' && inamelen >= 8 &&
547 (instr(iname+inamelen-8, "{SCALAR}") ||
548 instr(iname+inamelen-7, "{ARRAY}") ||
549 instr(iname+inamelen-6, "{HASH}"))) {
550 iname[inamelen++] = '-'; iname[inamelen++] = '>';
551 }
552 iname[inamelen++] = '['; iname[inamelen] = '\0';
553 totpad = newSVsv(sep);
554 sv_catsv(totpad, pad);
555 sv_catsv(totpad, apad);
556
557 for (ix = 0; ix <= ixmax; ++ix) {
558 STRLEN ilen;
559 SV *elem;
560 svp = av_fetch((AV*)ival, ix, FALSE);
561 if (svp)
562 elem = *svp;
563 else
3280af22 564 elem = &PL_sv_undef;
823edd99
GS
565
566 ilen = inamelen;
567 sv_setiv(ixsv, ix);
02c14053
AC
568#if PERL_VERSION < 10
569 (void) sprintf(iname+ilen, "%"IVdf, (IV)ix);
570 ilen = strlen(iname);
571#else
f5def3a2 572 ilen = ilen + my_sprintf(iname+ilen, "%"IVdf, (IV)ix);
02c14053 573#endif
823edd99
GS
574 iname[ilen++] = ']'; iname[ilen] = '\0';
575 if (indent >= 3) {
576 sv_catsv(retval, totpad);
577 sv_catsv(retval, ipad);
578 sv_catpvn(retval, "#", 1);
579 sv_catsv(retval, ixsv);
580 }
581 sv_catsv(retval, totpad);
582 sv_catsv(retval, ipad);
cea2e8a9 583 DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav,
30b4f386 584 levelp, indent, pad, xpad, apad, sep, pair,
a2126434 585 freezer, toaster, purity, deepcopy, quotekeys, bless,
e9105f86 586 maxdepth, sortkeys);
823edd99
GS
587 if (ix < ixmax)
588 sv_catpvn(retval, ",", 1);
589 }
590 if (ixmax >= 0) {
9061c4b9 591 SV * const opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), (*levelp)-1);
823edd99
GS
592 sv_catsv(retval, totpad);
593 sv_catsv(retval, opad);
594 SvREFCNT_dec(opad);
595 }
596 if (name[0] == '@')
597 sv_catpvn(retval, ")", 1);
598 else
599 sv_catpvn(retval, "]", 1);
600 SvREFCNT_dec(ixsv);
601 SvREFCNT_dec(totpad);
602 Safefree(iname);
603 }
604 else if (realtype == SVt_PVHV) {
605 SV *totpad, *newapad;
9061c4b9 606 SV *sname;
823edd99
GS
607 HE *entry;
608 char *key;
609 I32 klen;
610 SV *hval;
7d49f689 611 AV *keys = NULL;
6cde4e94 612
9061c4b9 613 SV * const iname = newSVpvn(name, namelen);
823edd99
GS
614 if (name[0] == '%') {
615 sv_catpvn(retval, "(", 1);
616 (SvPVX(iname))[0] = '$';
617 }
618 else {
619 sv_catpvn(retval, "{", 1);
7820172a
GS
620 /* omit "->" in $foo[0]->{bar}, but not in ${$foo}->{bar} */
621 if ((namelen > 0
622 && name[namelen-1] != ']' && name[namelen-1] != '}')
623 || (namelen > 4
624 && (name[1] == '{'
625 || (name[0] == '\\' && name[2] == '{'))))
626 {
823edd99
GS
627 sv_catpvn(iname, "->", 2);
628 }
629 }
630 if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 &&
631 (instr(name+namelen-8, "{SCALAR}") ||
632 instr(name+namelen-7, "{ARRAY}") ||
633 instr(name+namelen-6, "{HASH}"))) {
634 sv_catpvn(iname, "->", 2);
635 }
636 sv_catpvn(iname, "{", 1);
637 totpad = newSVsv(sep);
638 sv_catsv(totpad, pad);
639 sv_catsv(totpad, apad);
6cde4e94 640
e9105f86
BI
641 /* If requested, get a sorted/filtered array of hash keys */
642 if (sortkeys) {
643 if (sortkeys == &PL_sv_yes) {
fec5e1eb
IM
644#if PERL_VERSION < 8
645 sortkeys = sv_2mortal(newSVpvn("Data::Dumper::_sortkeys", 23));
646#else
e9105f86
BI
647 keys = newAV();
648 (void)hv_iterinit((HV*)ival);
20d72259 649 while ((entry = hv_iternext((HV*)ival))) {
e9105f86
BI
650 sv = hv_iterkeysv(entry);
651 SvREFCNT_inc(sv);
652 av_push(keys, sv);
653 }
fec5e1eb 654# ifdef USE_LOCALE_NUMERIC
e9105f86
BI
655 sortsv(AvARRAY(keys),
656 av_len(keys)+1,
3c253d0e 657 IN_LOCALE ? Perl_sv_cmp_locale : Perl_sv_cmp);
fec5e1eb 658# else
503ec68f
JH
659 sortsv(AvARRAY(keys),
660 av_len(keys)+1,
661 Perl_sv_cmp);
fec5e1eb 662# endif
02a99678 663#endif
e9105f86 664 }
fec5e1eb 665 if (sortkeys != &PL_sv_yes) {
e9105f86
BI
666 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
667 XPUSHs(sv_2mortal(newRV_inc(ival))); PUTBACK;
668 i = perl_call_sv(sortkeys, G_SCALAR | G_EVAL);
669 SPAGAIN;
670 if (i) {
671 sv = POPs;
672 if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVAV))
673 keys = (AV*)SvREFCNT_inc(SvRV(sv));
674 }
675 if (! keys)
676 warn("Sortkeys subroutine did not return ARRAYREF\n");
677 PUTBACK; FREETMPS; LEAVE;
678 }
679 if (keys)
680 sv_2mortal((SV*)keys);
681 }
682 else
683 (void)hv_iterinit((HV*)ival);
ecfc8647
AMS
684
685 /* foreach (keys %hash) */
686 for (i = 0; 1; i++) {
fdce9ba9
NC
687 char *nkey;
688 char *nkey_buffer = NULL;
823edd99 689 I32 nticks = 0;
dc71dc59
JH
690 SV* keysv;
691 STRLEN keylen;
fdce9ba9 692 I32 nlen;
dc71dc59 693 bool do_utf8 = FALSE;
ecfc8647 694
27688d77
YST
695 if (sortkeys) {
696 if (!(keys && (I32)i <= av_len(keys))) break;
697 } else {
698 if (!(entry = hv_iternext((HV *)ival))) break;
699 }
ecfc8647 700
823edd99
GS
701 if (i)
702 sv_catpvn(retval, ",", 1);
e9105f86
BI
703
704 if (sortkeys) {
705 char *key;
706 svp = av_fetch(keys, i, FALSE);
4bbdbd51 707 keysv = svp ? *svp : sv_newmortal();
e9105f86 708 key = SvPV(keysv, keylen);
d075f8ed 709 svp = hv_fetch((HV*)ival, key,
c33e8be1 710 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen, 0);
4bbdbd51 711 hval = svp ? *svp : sv_newmortal();
e9105f86
BI
712 }
713 else {
714 keysv = hv_iterkeysv(entry);
715 hval = hv_iterval((HV*)ival, entry);
716 }
717
dc71dc59 718 key = SvPV(keysv, keylen);
8738e0c0 719 do_utf8 = DO_UTF8(keysv);
dc71dc59
JH
720 klen = keylen;
721
fdce9ba9
NC
722 sv_catsv(retval, totpad);
723 sv_catsv(retval, ipad);
724 /* old logic was first to check utf8 flag, and if utf8 always
725 call esc_q_utf8. This caused test to break under -Mutf8,
726 because there even strings like 'c' have utf8 flag on.
727 Hence with quotekeys == 0 the XS code would still '' quote
728 them based on flags, whereas the perl code would not,
729 based on regexps.
730 The perl code is correct.
731 needs_quote() decides that anything that isn't a valid
732 perl identifier needs to be quoted, hence only correctly
733 formed strings with no characters outside [A-Za-z0-9_:]
734 won't need quoting. None of those characters are used in
735 the byte encoding of utf8, so anything with utf8
736 encoded characters in will need quoting. Hence strings
737 with utf8 encoded characters in will end up inside do_utf8
738 just like before, but now strings with utf8 flag set but
739 only ascii characters will end up in the unquoted section.
740
741 There should also be less tests for the (probably currently)
742 more common doesn't need quoting case.
743 The code is also smaller (22044 vs 22260) because I've been
30b4f386 744 able to pull the common logic out to both sides. */
95869c09 745 if (quotekeys || needs_quote(key,keylen)) {
fdce9ba9
NC
746 if (do_utf8) {
747 STRLEN ocur = SvCUR(retval);
748 nlen = esc_q_utf8(aTHX_ retval, key, klen);
749 nkey = SvPVX(retval) + ocur;
750 }
751 else {
dc71dc59 752 nticks = num_q(key, klen);
fdce9ba9
NC
753 New(0, nkey_buffer, klen+nticks+3, char);
754 nkey = nkey_buffer;
dc71dc59
JH
755 nkey[0] = '\'';
756 if (nticks)
757 klen += esc_q(nkey+1, key, klen);
758 else
759 (void)Copy(key, nkey+1, klen, char);
760 nkey[++klen] = '\'';
761 nkey[++klen] = '\0';
fdce9ba9
NC
762 nlen = klen;
763 sv_catpvn(retval, nkey, klen);
dc71dc59 764 }
fdce9ba9
NC
765 }
766 else {
767 nkey = key;
768 nlen = klen;
769 sv_catpvn(retval, nkey, klen);
dc71dc59 770 }
fdce9ba9
NC
771 sname = newSVsv(iname);
772 sv_catpvn(sname, nkey, nlen);
773 sv_catpvn(sname, "}", 1);
774
30b4f386 775 sv_catsv(retval, pair);
823edd99
GS
776 if (indent >= 2) {
777 char *extra;
778 I32 elen = 0;
779 newapad = newSVsv(apad);
780 New(0, extra, klen+4+1, char);
781 while (elen < (klen+4))
782 extra[elen++] = ' ';
783 extra[elen] = '\0';
784 sv_catpvn(newapad, extra, elen);
785 Safefree(extra);
786 }
787 else
788 newapad = apad;
789
aa07b2f6 790 DD_dump(aTHX_ hval, SvPVX_const(sname), SvCUR(sname), retval, seenhv,
30b4f386 791 postav, levelp, indent, pad, xpad, newapad, sep, pair,
a2126434 792 freezer, toaster, purity, deepcopy, quotekeys, bless,
e9105f86 793 maxdepth, sortkeys);
823edd99 794 SvREFCNT_dec(sname);
fdce9ba9 795 Safefree(nkey_buffer);
823edd99
GS
796 if (indent >= 2)
797 SvREFCNT_dec(newapad);
798 }
799 if (i) {
aa07b2f6 800 SV *opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp-1);
823edd99
GS
801 sv_catsv(retval, totpad);
802 sv_catsv(retval, opad);
803 SvREFCNT_dec(opad);
804 }
805 if (name[0] == '%')
806 sv_catpvn(retval, ")", 1);
807 else
808 sv_catpvn(retval, "}", 1);
809 SvREFCNT_dec(iname);
810 SvREFCNT_dec(totpad);
811 }
812 else if (realtype == SVt_PVCV) {
813 sv_catpvn(retval, "sub { \"DUMMY\" }", 15);
814 if (purity)
815 warn("Encountered CODE ref, using dummy placeholder");
816 }
817 else {
4f12661d 818 warn("cannot handle ref type %d", (int)realtype);
823edd99
GS
819 }
820
4ab99479 821 if (realpack && !no_bless) { /* free blessed allocs */
d0c214fd
AF
822 I32 plen;
823 I32 pticks;
824
823edd99
GS
825 if (indent >= 2) {
826 SvREFCNT_dec(apad);
827 apad = blesspad;
828 }
829 sv_catpvn(retval, ", '", 3);
d0c214fd
AF
830
831 plen = strlen(realpack);
832 pticks = num_q(realpack, plen);
34baf60a 833 if (pticks) { /* needs escaping */
d0c214fd
AF
834 char *npack;
835 char *npack_buffer = NULL;
836
837 New(0, npack_buffer, plen+pticks+1, char);
838 npack = npack_buffer;
839 plen += esc_q(npack, realpack, plen);
840 npack[plen] = '\0';
841
842 sv_catpvn(retval, npack, plen);
843 Safefree(npack_buffer);
844 }
845 else {
846 sv_catpvn(retval, realpack, strlen(realpack));
847 }
823edd99
GS
848 sv_catpvn(retval, "' )", 3);
849 if (toaster && SvPOK(toaster) && SvCUR(toaster)) {
850 sv_catpvn(retval, "->", 2);
851 sv_catsv(retval, toaster);
852 sv_catpvn(retval, "()", 2);
853 }
854 }
855 SvREFCNT_dec(ipad);
856 (*levelp)--;
857 }
858 else {
859 STRLEN i;
860
861 if (namelen) {
e52c0e5a 862#ifdef DD_USE_OLD_ID_FORMAT
f5def3a2 863 idlen = my_snprintf(id, sizeof(id), "0x%"UVxf, PTR2UV(val));
e52c0e5a
NC
864#else
865 id_buffer = PTR2UV(val);
866 idlen = sizeof(id_buffer);
867#endif
f5def3a2 868 if ((svp = hv_fetch(seenhv, id, idlen, FALSE)) &&
823edd99 869 (sv = *svp) && SvROK(sv) &&
7820172a
GS
870 (seenentry = (AV*)SvRV(sv)))
871 {
823edd99 872 SV *othername;
7820172a
GS
873 if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)
874 && (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0)
875 {
876 sv_catpvn(retval, "${", 2);
823edd99 877 sv_catsv(retval, othername);
7820172a 878 sv_catpvn(retval, "}", 1);
823edd99
GS
879 return 1;
880 }
881 }
3bef8b4a 882 else if (val != &PL_sv_undef) {
9061c4b9 883 SV * const namesv = newSVpvn("\\", 1);
823edd99
GS
884 sv_catpvn(namesv, name, namelen);
885 seenentry = newAV();
886 av_push(seenentry, namesv);
fec5e1eb 887 av_push(seenentry, newRV_inc(val));
383d9087 888 (void)hv_store(seenhv, id, idlen, newRV_inc((SV*)seenentry), 0);
823edd99
GS
889 SvREFCNT_dec(seenentry);
890 }
891 }
7820172a 892
fec5e1eb 893 if (DD_is_integer(val)) {
823edd99 894 STRLEN len;
0e8b3009 895 if (SvIsUV(val))
f5def3a2 896 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"UVuf, SvUV(val));
0e8b3009 897 else
f5def3a2 898 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"IVdf, SvIV(val));
c4cce848
NC
899 if (SvPOK(val)) {
900 /* Need to check to see if this is a string such as " 0".
901 I'm assuming from sprintf isn't going to clash with utf8.
902 Is this valid on EBCDIC? */
903 STRLEN pvlen;
9061c4b9 904 const char * const pv = SvPV(val, pvlen);
c4cce848
NC
905 if (pvlen != len || memNE(pv, tmpbuf, len))
906 goto integer_came_from_string;
907 }
908 if (len > 10) {
909 /* Looks like we're on a 64 bit system. Make it a string so that
910 if a 32 bit system reads the number it will cope better. */
911 sv_catpvf(retval, "'%s'", tmpbuf);
912 } else
913 sv_catpvn(retval, tmpbuf, len);
823edd99
GS
914 }
915 else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */
916 c = SvPV(val, i);
ecf0432f 917 if(i) ++c, --i; /* just get the name */
823edd99
GS
918 if (i >= 6 && strncmp(c, "main::", 6) == 0) {
919 c += 4;
920 i -= 4;
921 }
95869c09
FC
922 if (needs_quote(c,i)) {
923#ifdef GvNAMEUTF8
924 if (GvNAMEUTF8(val)) {
925 sv_grow(retval, SvCUR(retval)+2);
926 r = SvPVX(retval)+SvCUR(retval);
927 r[0] = '*'; r[1] = '{';
928 SvCUR_set(retval, SvCUR(retval)+2);
929 esc_q_utf8(aTHX_ retval, c, i);
930 sv_grow(retval, SvCUR(retval)+2);
931 r = SvPVX(retval)+SvCUR(retval);
932 r[0] = '}'; r[1] = '\0';
933 i = 1;
934 }
935 else
936#endif
937 {
823edd99
GS
938 sv_grow(retval, SvCUR(retval)+6+2*i);
939 r = SvPVX(retval)+SvCUR(retval);
940 r[0] = '*'; r[1] = '{'; r[2] = '\'';
941 i += esc_q(r+3, c, i);
942 i += 3;
943 r[i++] = '\''; r[i++] = '}';
944 r[i] = '\0';
95869c09 945 }
823edd99
GS
946 }
947 else {
948 sv_grow(retval, SvCUR(retval)+i+2);
949 r = SvPVX(retval)+SvCUR(retval);
950 r[0] = '*'; strcpy(r+1, c);
951 i++;
952 }
7820172a 953 SvCUR_set(retval, SvCUR(retval)+i);
823edd99
GS
954
955 if (purity) {
27da23d5
JH
956 static const char* const entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" };
957 static const STRLEN sizes[] = { 8, 7, 6 };
823edd99 958 SV *e;
9061c4b9
AL
959 SV * const nname = newSVpvn("", 0);
960 SV * const newapad = newSVpvn("", 0);
961 GV * const gv = (GV*)val;
823edd99
GS
962 I32 j;
963
964 for (j=0; j<3; j++) {
965 e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv));
7820172a
GS
966 if (!e)
967 continue;
968 if (j == 0 && !SvOK(e))
969 continue;
970
971 {
823edd99 972 I32 nlevel = 0;
7820172a 973 SV *postentry = newSVpvn(r,i);
823edd99
GS
974
975 sv_setsv(nname, postentry);
976 sv_catpvn(nname, entries[j], sizes[j]);
977 sv_catpvn(postentry, " = ", 3);
978 av_push(postav, postentry);
fec5e1eb 979 e = newRV_inc(e);
823edd99 980
b162af07 981 SvCUR_set(newapad, 0);
823edd99 982 if (indent >= 2)
cea2e8a9 983 (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry));
823edd99 984
aa07b2f6 985 DD_dump(aTHX_ e, SvPVX_const(nname), SvCUR(nname), postentry,
823edd99 986 seenhv, postav, &nlevel, indent, pad, xpad,
30b4f386 987 newapad, sep, pair, freezer, toaster, purity,
e9105f86
BI
988 deepcopy, quotekeys, bless, maxdepth,
989 sortkeys);
823edd99
GS
990 SvREFCNT_dec(e);
991 }
992 }
993
994 SvREFCNT_dec(newapad);
995 SvREFCNT_dec(nname);
996 }
997 }
7820172a
GS
998 else if (val == &PL_sv_undef || !SvOK(val)) {
999 sv_catpvn(retval, "undef", 5);
1000 }
823edd99 1001 else {
c4cce848 1002 integer_came_from_string:
823edd99 1003 c = SvPV(val, i);
dc71dc59 1004 if (DO_UTF8(val))
6cde4e94 1005 i += esc_q_utf8(aTHX_ retval, c, i);
dc71dc59
JH
1006 else {
1007 sv_grow(retval, SvCUR(retval)+3+2*i); /* 3: ""\0 */
1008 r = SvPVX(retval) + SvCUR(retval);
1009 r[0] = '\'';
1010 i += esc_q(r+1, c, i);
1011 ++i;
1012 r[i++] = '\'';
1013 r[i] = '\0';
1014 SvCUR_set(retval, SvCUR(retval)+i);
1015 }
823edd99 1016 }
823edd99
GS
1017 }
1018
7820172a
GS
1019 if (idlen) {
1020 if (deepcopy)
1021 (void)hv_delete(seenhv, id, idlen, G_DISCARD);
1022 else if (namelen && seenentry) {
1023 SV *mark = *av_fetch(seenentry, 2, TRUE);
1024 sv_setiv(mark,1);
1025 }
1026 }
823edd99
GS
1027 return 1;
1028}
1029
1030
1031MODULE = Data::Dumper PACKAGE = Data::Dumper PREFIX = Data_Dumper_
1032
1033#
1034# This is the exact equivalent of Dump. Well, almost. The things that are
1035# different as of now (due to Laziness):
c4a6f826 1036# * doesn't do double-quotes yet.
823edd99
GS
1037#
1038
1039void
1040Data_Dumper_Dumpxs(href, ...)
1041 SV *href;
1042 PROTOTYPE: $;$$
1043 PPCODE:
1044 {
1045 HV *hv;
1046 SV *retval, *valstr;
5c284bb0 1047 HV *seenhv = NULL;
823edd99
GS
1048 AV *postav, *todumpav, *namesav;
1049 I32 level = 0;
497b47a8 1050 I32 indent, terse, i, imax, postlen;
823edd99 1051 SV **svp;
30b4f386 1052 SV *val, *name, *pad, *xpad, *apad, *sep, *pair, *varname;
e9105f86 1053 SV *freezer, *toaster, *bless, *sortkeys;
7b0972df 1054 I32 purity, deepcopy, quotekeys, maxdepth = 0;
823edd99
GS
1055 char tmpbuf[1024];
1056 I32 gimme = GIMME;
1057
1058 if (!SvROK(href)) { /* call new to get an object first */
0f1923bd
GS
1059 if (items < 2)
1060 croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, [NAME_ARY_REF])");
823edd99
GS
1061
1062 ENTER;
1063 SAVETMPS;
1064
1065 PUSHMARK(sp);
1066 XPUSHs(href);
0f1923bd
GS
1067 XPUSHs(sv_2mortal(newSVsv(ST(1))));
1068 if (items >= 3)
1069 XPUSHs(sv_2mortal(newSVsv(ST(2))));
823edd99
GS
1070 PUTBACK;
1071 i = perl_call_method("new", G_SCALAR);
1072 SPAGAIN;
1073 if (i)
1074 href = newSVsv(POPs);
1075
1076 PUTBACK;
1077 FREETMPS;
1078 LEAVE;
1079 if (i)
1080 (void)sv_2mortal(href);
1081 }
1082
7d49f689 1083 todumpav = namesav = NULL;
5c284bb0 1084 seenhv = NULL;
30b4f386 1085 val = pad = xpad = apad = sep = pair = varname
65e66c80 1086 = freezer = toaster = bless = sortkeys = &PL_sv_undef;
823edd99
GS
1087 name = sv_newmortal();
1088 indent = 2;
497b47a8 1089 terse = purity = deepcopy = 0;
823edd99 1090 quotekeys = 1;
6cde4e94 1091
7820172a 1092 retval = newSVpvn("", 0);
823edd99
GS
1093 if (SvROK(href)
1094 && (hv = (HV*)SvRV((SV*)href))
1095 && SvTYPE(hv) == SVt_PVHV) {
1096
1097 if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp))
1098 seenhv = (HV*)SvRV(*svp);
1099 if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp))
1100 todumpav = (AV*)SvRV(*svp);
1101 if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp))
1102 namesav = (AV*)SvRV(*svp);
1103 if ((svp = hv_fetch(hv, "indent", 6, FALSE)))
1104 indent = SvIV(*svp);
1105 if ((svp = hv_fetch(hv, "purity", 6, FALSE)))
1106 purity = SvIV(*svp);
1107 if ((svp = hv_fetch(hv, "terse", 5, FALSE)))
1108 terse = SvTRUE(*svp);
497b47a8 1109#if 0 /* useqq currently unused */
823edd99
GS
1110 if ((svp = hv_fetch(hv, "useqq", 5, FALSE)))
1111 useqq = SvTRUE(*svp);
497b47a8 1112#endif
823edd99
GS
1113 if ((svp = hv_fetch(hv, "pad", 3, FALSE)))
1114 pad = *svp;
1115 if ((svp = hv_fetch(hv, "xpad", 4, FALSE)))
1116 xpad = *svp;
1117 if ((svp = hv_fetch(hv, "apad", 4, FALSE)))
1118 apad = *svp;
1119 if ((svp = hv_fetch(hv, "sep", 3, FALSE)))
1120 sep = *svp;
30b4f386 1121 if ((svp = hv_fetch(hv, "pair", 4, FALSE)))
1122 pair = *svp;
823edd99
GS
1123 if ((svp = hv_fetch(hv, "varname", 7, FALSE)))
1124 varname = *svp;
1125 if ((svp = hv_fetch(hv, "freezer", 7, FALSE)))
1126 freezer = *svp;
1127 if ((svp = hv_fetch(hv, "toaster", 7, FALSE)))
1128 toaster = *svp;
1129 if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE)))
1130 deepcopy = SvTRUE(*svp);
1131 if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE)))
1132 quotekeys = SvTRUE(*svp);
1133 if ((svp = hv_fetch(hv, "bless", 5, FALSE)))
1134 bless = *svp;
a2126434
JN
1135 if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE)))
1136 maxdepth = SvIV(*svp);
e9105f86
BI
1137 if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) {
1138 sortkeys = *svp;
1139 if (! SvTRUE(sortkeys))
1140 sortkeys = NULL;
1141 else if (! (SvROK(sortkeys) &&
1142 SvTYPE(SvRV(sortkeys)) == SVt_PVCV) )
1143 {
1144 /* flag to use qsortsv() for sorting hash keys */
1145 sortkeys = &PL_sv_yes;
1146 }
1147 }
823edd99
GS
1148 postav = newAV();
1149
1150 if (todumpav)
1151 imax = av_len(todumpav);
1152 else
1153 imax = -1;
7820172a 1154 valstr = newSVpvn("",0);
823edd99
GS
1155 for (i = 0; i <= imax; ++i) {
1156 SV *newapad;
6cde4e94 1157
823edd99
GS
1158 av_clear(postav);
1159 if ((svp = av_fetch(todumpav, i, FALSE)))
1160 val = *svp;
1161 else
3280af22 1162 val = &PL_sv_undef;
d20128b8 1163 if ((svp = av_fetch(namesav, i, TRUE))) {
823edd99 1164 sv_setsv(name, *svp);
d20128b8
RGS
1165 if (SvOK(*svp) && !SvPOK(*svp))
1166 (void)SvPV_nolen_const(name);
1167 }
823edd99 1168 else
8063af02 1169 (void)SvOK_off(name);
6cde4e94 1170
d20128b8 1171 if (SvPOK(name)) {
aa07b2f6 1172 if ((SvPVX_const(name))[0] == '*') {
823edd99
GS
1173 if (SvROK(val)) {
1174 switch (SvTYPE(SvRV(val))) {
1175 case SVt_PVAV:
1176 (SvPVX(name))[0] = '@';
1177 break;
1178 case SVt_PVHV:
1179 (SvPVX(name))[0] = '%';
1180 break;
1181 case SVt_PVCV:
1182 (SvPVX(name))[0] = '*';
1183 break;
1184 default:
1185 (SvPVX(name))[0] = '$';
1186 break;
1187 }
1188 }
1189 else
1190 (SvPVX(name))[0] = '$';
1191 }
aa07b2f6 1192 else if ((SvPVX_const(name))[0] != '$')
823edd99
GS
1193 sv_insert(name, 0, 0, "$", 1);
1194 }
1195 else {
9061c4b9 1196 STRLEN nchars;
823edd99
GS
1197 sv_setpvn(name, "$", 1);
1198 sv_catsv(name, varname);
f5def3a2 1199 nchars = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"IVdf, (IV)(i+1));
823edd99
GS
1200 sv_catpvn(name, tmpbuf, nchars);
1201 }
6cde4e94 1202
d34e9bd9 1203 if (indent >= 2 && !terse) {
9061c4b9 1204 SV * const tmpsv = sv_x(aTHX_ NULL, " ", 1, SvCUR(name)+3);
823edd99
GS
1205 newapad = newSVsv(apad);
1206 sv_catsv(newapad, tmpsv);
1207 SvREFCNT_dec(tmpsv);
1208 }
1209 else
1210 newapad = apad;
6cde4e94 1211
e3ec2293 1212 PUTBACK;
aa07b2f6 1213 DD_dump(aTHX_ val, SvPVX_const(name), SvCUR(name), valstr, seenhv,
30b4f386 1214 postav, &level, indent, pad, xpad, newapad, sep, pair,
823edd99 1215 freezer, toaster, purity, deepcopy, quotekeys,
e9105f86 1216 bless, maxdepth, sortkeys);
e3ec2293 1217 SPAGAIN;
6cde4e94 1218
d34e9bd9 1219 if (indent >= 2 && !terse)
823edd99
GS
1220 SvREFCNT_dec(newapad);
1221
1222 postlen = av_len(postav);
1223 if (postlen >= 0 || !terse) {
1224 sv_insert(valstr, 0, 0, " = ", 3);
aa07b2f6 1225 sv_insert(valstr, 0, 0, SvPVX_const(name), SvCUR(name));
823edd99
GS
1226 sv_catpvn(valstr, ";", 1);
1227 }
1228 sv_catsv(retval, pad);
1229 sv_catsv(retval, valstr);
1230 sv_catsv(retval, sep);
1231 if (postlen >= 0) {
1232 I32 i;
1233 sv_catsv(retval, pad);
1234 for (i = 0; i <= postlen; ++i) {
1235 SV *elem;
1236 svp = av_fetch(postav, i, FALSE);
1237 if (svp && (elem = *svp)) {
1238 sv_catsv(retval, elem);
1239 if (i < postlen) {
1240 sv_catpvn(retval, ";", 1);
1241 sv_catsv(retval, sep);
1242 sv_catsv(retval, pad);
1243 }
1244 }
1245 }
1246 sv_catpvn(retval, ";", 1);
1247 sv_catsv(retval, sep);
1248 }
1249 sv_setpvn(valstr, "", 0);
1250 if (gimme == G_ARRAY) {
1251 XPUSHs(sv_2mortal(retval));
1252 if (i < imax) /* not the last time thro ? */
7820172a 1253 retval = newSVpvn("",0);
823edd99
GS
1254 }
1255 }
1256 SvREFCNT_dec(postav);
1257 SvREFCNT_dec(valstr);
1258 }
1259 else
1260 croak("Call to new() method failed to return HASH ref");
1261 if (gimme == G_SCALAR)
1262 XPUSHs(sv_2mortal(retval));
1263 }