This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Fix C pre-processor expression in Dumper.xs
[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
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,
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);
de5ef703
FC		 466 const char * const rend = rval+rlen;
467 const char *slash = rval;
4ab99479 468 sv_catpvn(retval, "qr/", 3);
de5ef703
FC		 469 for (;slash < rend; slash++) {
470 if (*slash == '\\') { ++slash; continue; }
471 if (*slash == '/') {
4ab99479
YO		 472 sv_catpvn(retval, rval, slash-rval);
473 sv_catpvn(retval, "\\/", 2);
474 rlen -= slash-rval+1;
475 rval = slash+1;
de5ef703 476 }
4ab99479
YO		 477 }
478 sv_catpvn(retval, rval, rlen);
479 sv_catpvn(retval, "/", 1);
480 }
481 else if (
d1dd14d1
JH		 482#if PERL_VERSION < 9
483 realtype <= SVt_PVBM
484#else
485 realtype <= SVt_PVMG
486#endif
487 ) { /* scalar ref */
9061c4b9 488 SV * const namesv = newSVpvn("${", 2);
7820172a
GS		 489 sv_catpvn(namesv, name, namelen);
490 sv_catpvn(namesv, "}", 1);
6cde4e94 491 if (realpack) { /* blessed */
823edd99 492 sv_catpvn(retval, "do{\\(my $o = ", 13);
aa07b2f6 493 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
30b4f386 494 postav, levelp, indent, pad, xpad, apad, sep, pair,
a2126434 495 freezer, toaster, purity, deepcopy, quotekeys, bless,
e9105f86 496 maxdepth, sortkeys);
823edd99 497 sv_catpvn(retval, ")}", 2);
7820172a 498 } /* plain */
823edd99
GS		 499 else {
500 sv_catpvn(retval, "\\", 1);
aa07b2f6 501 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
30b4f386 502 postav, levelp, indent, pad, xpad, apad, sep, pair,
a2126434 503 freezer, toaster, purity, deepcopy, quotekeys, bless,
e9105f86 504 maxdepth, sortkeys);
823edd99 505 }
7820172a
GS		 506 SvREFCNT_dec(namesv);
507 }
508 else if (realtype == SVt_PVGV) { /* glob ref */
9061c4b9 509 SV * const namesv = newSVpvn("*{", 2);
7820172a
GS		 510 sv_catpvn(namesv, name, namelen);
511 sv_catpvn(namesv, "}", 1);
512 sv_catpvn(retval, "\\", 1);
aa07b2f6 513 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
30b4f386 514 postav, levelp, indent, pad, xpad, apad, sep, pair,
a2126434 515 freezer, toaster, purity, deepcopy, quotekeys, bless,
e9105f86 516 maxdepth, sortkeys);
7820172a 517 SvREFCNT_dec(namesv);
823edd99
GS		 518 }
519 else if (realtype == SVt_PVAV) {
520 SV *totpad;
521 I32 ix = 0;
9061c4b9 522 const I32 ixmax = av_len((AV *)ival);
6cde4e94 523
9061c4b9 524 SV * const ixsv = newSViv(0);
823edd99
GS		 525 /* allowing for a 24 char wide array index */
526 New(0, iname, namelen+28, char);
527 (void)strcpy(iname, name);
528 inamelen = namelen;
529 if (name[0] == '@') {
530 sv_catpvn(retval, "(", 1);
531 iname[0] = '$';
532 }
533 else {
534 sv_catpvn(retval, "[", 1);
7820172a
GS		 535 /* omit "->" in $foo{bar}->[0], but not in ${$foo}->[0] */
536 /*if (namelen > 0
537 && name[namelen-1] != ']' && name[namelen-1] != '}'
538 && (namelen < 4 || (name[1] != '{' && name[2] != '{')))*/
539 if ((namelen > 0
540 && name[namelen-1] != ']' && name[namelen-1] != '}')
541 || (namelen > 4
542 && (name[1] == '{'
543 || (name[0] == '\\' && name[2] == '{'))))
544 {
823edd99
GS		 545 iname[inamelen++] = '-'; iname[inamelen++] = '>';
546 iname[inamelen] = '\0';
547 }
548 }
549 if (iname[0] == '*' && iname[inamelen-1] == '}' && inamelen >= 8 &&
550 (instr(iname+inamelen-8, "{SCALAR}") ||
551 instr(iname+inamelen-7, "{ARRAY}") ||
552 instr(iname+inamelen-6, "{HASH}"))) {
553 iname[inamelen++] = '-'; iname[inamelen++] = '>';
554 }
555 iname[inamelen++] = '['; iname[inamelen] = '\0';
556 totpad = newSVsv(sep);
557 sv_catsv(totpad, pad);
558 sv_catsv(totpad, apad);
559
560 for (ix = 0; ix <= ixmax; ++ix) {
561 STRLEN ilen;
562 SV *elem;
563 svp = av_fetch((AV*)ival, ix, FALSE);
564 if (svp)
565 elem = *svp;
566 else
3280af22 567 elem = &PL_sv_undef;
823edd99
GS		 568
569 ilen = inamelen;
570 sv_setiv(ixsv, ix);
02c14053
AC		 571#if PERL_VERSION < 10
572 (void) sprintf(iname+ilen, "%"IVdf, (IV)ix);
573 ilen = strlen(iname);
574#else
f5def3a2 575 ilen = ilen + my_sprintf(iname+ilen, "%"IVdf, (IV)ix);
02c14053 576#endif
823edd99
GS		 577 iname[ilen++] = ']'; iname[ilen] = '\0';
578 if (indent >= 3) {
579 sv_catsv(retval, totpad);
580 sv_catsv(retval, ipad);
581 sv_catpvn(retval, "#", 1);
582 sv_catsv(retval, ixsv);
583 }
584 sv_catsv(retval, totpad);
585 sv_catsv(retval, ipad);
cea2e8a9 586 DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav,
30b4f386 587 levelp, indent, pad, xpad, apad, sep, pair,
a2126434 588 freezer, toaster, purity, deepcopy, quotekeys, bless,
e9105f86 589 maxdepth, sortkeys);
823edd99
GS		 590 if (ix < ixmax)
591 sv_catpvn(retval, ",", 1);
592 }
593 if (ixmax >= 0) {
9061c4b9 594 SV * const opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), (*levelp)-1);
823edd99
GS		 595 sv_catsv(retval, totpad);
596 sv_catsv(retval, opad);
597 SvREFCNT_dec(opad);
598 }
599 if (name[0] == '@')
600 sv_catpvn(retval, ")", 1);
601 else
602 sv_catpvn(retval, "]", 1);
603 SvREFCNT_dec(ixsv);
604 SvREFCNT_dec(totpad);
605 Safefree(iname);
606 }
607 else if (realtype == SVt_PVHV) {
608 SV *totpad, *newapad;
9061c4b9 609 SV *sname;
823edd99
GS		 610 HE *entry;
611 char *key;
612 I32 klen;
613 SV *hval;
7d49f689 614 AV *keys = NULL;
6cde4e94 615
9061c4b9 616 SV * const iname = newSVpvn(name, namelen);
823edd99
GS		 617 if (name[0] == '%') {
618 sv_catpvn(retval, "(", 1);
619 (SvPVX(iname))[0] = '$';
620 }
621 else {
622 sv_catpvn(retval, "{", 1);
7820172a
GS		 623 /* omit "->" in $foo[0]->{bar}, but not in ${$foo}->{bar} */
624 if ((namelen > 0
625 && name[namelen-1] != ']' && name[namelen-1] != '}')
626 || (namelen > 4
627 && (name[1] == '{'
628 || (name[0] == '\\' && name[2] == '{'))))
629 {
823edd99
GS		 630 sv_catpvn(iname, "->", 2);
631 }
632 }
633 if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 &&
634 (instr(name+namelen-8, "{SCALAR}") ||
635 instr(name+namelen-7, "{ARRAY}") ||
636 instr(name+namelen-6, "{HASH}"))) {
637 sv_catpvn(iname, "->", 2);
638 }
639 sv_catpvn(iname, "{", 1);
640 totpad = newSVsv(sep);
641 sv_catsv(totpad, pad);
642 sv_catsv(totpad, apad);
6cde4e94 643
e9105f86
IN		 644 /* If requested, get a sorted/filtered array of hash keys */
645 if (sortkeys) {
646 if (sortkeys == &PL_sv_yes) {
fec5e1eb
IM		 647#if PERL_VERSION < 8
648 sortkeys = sv_2mortal(newSVpvn("Data::Dumper::_sortkeys", 23));
649#else
e9105f86
IN		 650 keys = newAV();
651 (void)hv_iterinit((HV*)ival);
20d72259 652 while ((entry = hv_iternext((HV*)ival))) {
e9105f86 653 sv = hv_iterkeysv(entry);
63c7889e 654 (void)SvREFCNT_inc(sv);
e9105f86
IN		 655 av_push(keys, sv);
656 }
fec5e1eb 657# ifdef USE_LOCALE_NUMERIC
e9105f86
IN		 658 sortsv(AvARRAY(keys),
659 av_len(keys)+1,
3c253d0e 660 IN_LOCALE ? Perl_sv_cmp_locale : Perl_sv_cmp);
fec5e1eb 661# else
503ec68f
JH		 662 sortsv(AvARRAY(keys),
663 av_len(keys)+1,
664 Perl_sv_cmp);
fec5e1eb 665# endif
02a99678 666#endif
e9105f86 667 }
fec5e1eb 668 if (sortkeys != &PL_sv_yes) {
e9105f86
IN		 669 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
670 XPUSHs(sv_2mortal(newRV_inc(ival))); PUTBACK;
671 i = perl_call_sv(sortkeys, G_SCALAR | G_EVAL);
672 SPAGAIN;
673 if (i) {
674 sv = POPs;
675 if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVAV))
676 keys = (AV*)SvREFCNT_inc(SvRV(sv));
677 }
678 if (! keys)
679 warn("Sortkeys subroutine did not return ARRAYREF\n");
680 PUTBACK; FREETMPS; LEAVE;
681 }
682 if (keys)
683 sv_2mortal((SV*)keys);
684 }
685 else
686 (void)hv_iterinit((HV*)ival);
ecfc8647
AMS		 687
688 /* foreach (keys %hash) */
689 for (i = 0; 1; i++) {
fdce9ba9
NC		 690 char *nkey;
691 char *nkey_buffer = NULL;
823edd99 692 I32 nticks = 0;
dc71dc59
JH		 693 SV* keysv;
694 STRLEN keylen;
fdce9ba9 695 I32 nlen;
dc71dc59 696 bool do_utf8 = FALSE;
ecfc8647 697
27688d77
YST		 698 if (sortkeys) {
699 if (!(keys && (I32)i <= av_len(keys))) break;
700 } else {
701 if (!(entry = hv_iternext((HV *)ival))) break;
702 }
ecfc8647 703
823edd99
GS		 704 if (i)
705 sv_catpvn(retval, ",", 1);
e9105f86
IN		 706
707 if (sortkeys) {
708 char *key;
709 svp = av_fetch(keys, i, FALSE);
4bbdbd51 710 keysv = svp ? *svp : sv_newmortal();
e9105f86 711 key = SvPV(keysv, keylen);
d075f8ed 712 svp = hv_fetch((HV*)ival, key,
c33e8be1 713 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen, 0);
4bbdbd51 714 hval = svp ? *svp : sv_newmortal();
e9105f86
IN		 715 }
716 else {
717 keysv = hv_iterkeysv(entry);
718 hval = hv_iterval((HV*)ival, entry);
719 }
720
dc71dc59 721 key = SvPV(keysv, keylen);
8738e0c0 722 do_utf8 = DO_UTF8(keysv);
dc71dc59
JH		 723 klen = keylen;
724
fdce9ba9
NC		 725 sv_catsv(retval, totpad);
726 sv_catsv(retval, ipad);
727 /* old logic was first to check utf8 flag, and if utf8 always
728 call esc_q_utf8. This caused test to break under -Mutf8,
729 because there even strings like 'c' have utf8 flag on.
730 Hence with quotekeys == 0 the XS code would still '' quote
731 them based on flags, whereas the perl code would not,
732 based on regexps.
733 The perl code is correct.
734 needs_quote() decides that anything that isn't a valid
735 perl identifier needs to be quoted, hence only correctly
736 formed strings with no characters outside [A-Za-z0-9_:]
737 won't need quoting. None of those characters are used in
738 the byte encoding of utf8, so anything with utf8
739 encoded characters in will need quoting. Hence strings
740 with utf8 encoded characters in will end up inside do_utf8
741 just like before, but now strings with utf8 flag set but
742 only ascii characters will end up in the unquoted section.
743
744 There should also be less tests for the (probably currently)
745 more common doesn't need quoting case.
746 The code is also smaller (22044 vs 22260) because I've been
30b4f386 747 able to pull the common logic out to both sides. */
95869c09 748 if (quotekeys || needs_quote(key,keylen)) {
fdce9ba9
NC		 749 if (do_utf8) {
750 STRLEN ocur = SvCUR(retval);
751 nlen = esc_q_utf8(aTHX_ retval, key, klen);
752 nkey = SvPVX(retval) + ocur;
753 }
754 else {
dc71dc59 755 nticks = num_q(key, klen);
fdce9ba9
NC		 756 New(0, nkey_buffer, klen+nticks+3, char);
757 nkey = nkey_buffer;
dc71dc59
JH		 758 nkey[0] = '\'';
759 if (nticks)
760 klen += esc_q(nkey+1, key, klen);
761 else
762 (void)Copy(key, nkey+1, klen, char);
763 nkey[++klen] = '\'';
764 nkey[++klen] = '\0';
fdce9ba9
NC		 765 nlen = klen;
766 sv_catpvn(retval, nkey, klen);
dc71dc59 767 }
fdce9ba9
NC		 768 }
769 else {
770 nkey = key;
771 nlen = klen;
772 sv_catpvn(retval, nkey, klen);
dc71dc59 773 }
fdce9ba9
NC		 774 sname = newSVsv(iname);
775 sv_catpvn(sname, nkey, nlen);
776 sv_catpvn(sname, "}", 1);
777
30b4f386 778 sv_catsv(retval, pair);
823edd99
GS		 779 if (indent >= 2) {
780 char *extra;
781 I32 elen = 0;
782 newapad = newSVsv(apad);
783 New(0, extra, klen+4+1, char);
784 while (elen < (klen+4))
785 extra[elen++] = ' ';
786 extra[elen] = '\0';
787 sv_catpvn(newapad, extra, elen);
788 Safefree(extra);
789 }
790 else
791 newapad = apad;
792
aa07b2f6 793 DD_dump(aTHX_ hval, SvPVX_const(sname), SvCUR(sname), retval, seenhv,
30b4f386 794 postav, levelp, indent, pad, xpad, newapad, sep, pair,
a2126434 795 freezer, toaster, purity, deepcopy, quotekeys, bless,
e9105f86 796 maxdepth, sortkeys);
823edd99 797 SvREFCNT_dec(sname);
fdce9ba9 798 Safefree(nkey_buffer);
823edd99
GS		 799 if (indent >= 2)
800 SvREFCNT_dec(newapad);
801 }
802 if (i) {
aa07b2f6 803 SV *opad = sv_x(aTHX_ Nullsv, SvPVX_const(xpad), SvCUR(xpad), *levelp-1);
823edd99
GS		 804 sv_catsv(retval, totpad);
805 sv_catsv(retval, opad);
806 SvREFCNT_dec(opad);
807 }
808 if (name[0] == '%')
809 sv_catpvn(retval, ")", 1);
810 else
811 sv_catpvn(retval, "}", 1);
812 SvREFCNT_dec(iname);
813 SvREFCNT_dec(totpad);
814 }
815 else if (realtype == SVt_PVCV) {
816 sv_catpvn(retval, "sub { \"DUMMY\" }", 15);
817 if (purity)
818 warn("Encountered CODE ref, using dummy placeholder");
819 }
820 else {
4f12661d 821 warn("cannot handle ref type %d", (int)realtype);
823edd99
GS		 822 }
823
4ab99479 824 if (realpack && !no_bless) { /* free blessed allocs */
d0c214fd
AF		 825 I32 plen;
826 I32 pticks;
827
823edd99
GS		 828 if (indent >= 2) {
829 SvREFCNT_dec(apad);
830 apad = blesspad;
831 }
832 sv_catpvn(retval, ", '", 3);
d0c214fd
AF		 833
834 plen = strlen(realpack);
835 pticks = num_q(realpack, plen);
34baf60a 836 if (pticks) { /* needs escaping */
d0c214fd
AF		 837 char *npack;
838 char *npack_buffer = NULL;
839
840 New(0, npack_buffer, plen+pticks+1, char);
841 npack = npack_buffer;
842 plen += esc_q(npack, realpack, plen);
843 npack[plen] = '\0';
844
845 sv_catpvn(retval, npack, plen);
846 Safefree(npack_buffer);
847 }
848 else {
849 sv_catpvn(retval, realpack, strlen(realpack));
850 }
823edd99
GS		 851 sv_catpvn(retval, "' )", 3);
852 if (toaster && SvPOK(toaster) && SvCUR(toaster)) {
853 sv_catpvn(retval, "->", 2);
854 sv_catsv(retval, toaster);
855 sv_catpvn(retval, "()", 2);
856 }
857 }
858 SvREFCNT_dec(ipad);
859 (*levelp)--;
860 }
861 else {
862 STRLEN i;
d036e907 863 const MAGIC *mg;
823edd99
GS		 864
865 if (namelen) {
e52c0e5a 866#ifdef DD_USE_OLD_ID_FORMAT
f5def3a2 867 idlen = my_snprintf(id, sizeof(id), "0x%"UVxf, PTR2UV(val));
e52c0e5a
NC		 868#else
869 id_buffer = PTR2UV(val);
870 idlen = sizeof(id_buffer);
871#endif
f5def3a2 872 if ((svp = hv_fetch(seenhv, id, idlen, FALSE)) &&
823edd99 873 (sv = *svp) && SvROK(sv) &&
7820172a
GS		 874 (seenentry = (AV*)SvRV(sv)))
875 {
823edd99 876 SV *othername;
7820172a
GS		 877 if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)
878 && (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0)
879 {
880 sv_catpvn(retval, "${", 2);
823edd99 881 sv_catsv(retval, othername);
7820172a 882 sv_catpvn(retval, "}", 1);
823edd99
GS		 883 return 1;
884 }
885 }
3bef8b4a 886 else if (val != &PL_sv_undef) {
9061c4b9 887 SV * const namesv = newSVpvn("\\", 1);
823edd99
GS		 888 sv_catpvn(namesv, name, namelen);
889 seenentry = newAV();
890 av_push(seenentry, namesv);
fec5e1eb 891 av_push(seenentry, newRV_inc(val));
383d9087 892 (void)hv_store(seenhv, id, idlen, newRV_inc((SV*)seenentry), 0);
823edd99
GS		 893 SvREFCNT_dec(seenentry);
894 }
895 }
7820172a 896
fec5e1eb 897 if (DD_is_integer(val)) {
823edd99 898 STRLEN len;
0e8b3009 899 if (SvIsUV(val))
f5def3a2 900 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"UVuf, SvUV(val));
0e8b3009 901 else
f5def3a2 902 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"IVdf, SvIV(val));
c4cce848
NC		 903 if (SvPOK(val)) {
904 /* Need to check to see if this is a string such as " 0".
905 I'm assuming from sprintf isn't going to clash with utf8.
906 Is this valid on EBCDIC? */
907 STRLEN pvlen;
9061c4b9 908 const char * const pv = SvPV(val, pvlen);
c4cce848
NC		 909 if (pvlen != len || memNE(pv, tmpbuf, len))
910 goto integer_came_from_string;
911 }
912 if (len > 10) {
913 /* Looks like we're on a 64 bit system. Make it a string so that
914 if a 32 bit system reads the number it will cope better. */
915 sv_catpvf(retval, "'%s'", tmpbuf);
916 } else
917 sv_catpvn(retval, tmpbuf, len);
823edd99
GS		 918 }
919 else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */
920 c = SvPV(val, i);
ecf0432f 921 if(i) ++c, --i; /* just get the name */
823edd99
GS		 922 if (i >= 6 && strncmp(c, "main::", 6) == 0) {
923 c += 4;
ad08c923
FC		 924#if PERL_VERSION < 7
925 if (i == 6 || (i == 7 && c[6] == '\0'))
926#else
927 if (i == 6)
928#endif
929 i = 0; else i -= 4;
823edd99 930 }
95869c09
FC		 931 if (needs_quote(c,i)) {
932#ifdef GvNAMEUTF8
933 if (GvNAMEUTF8(val)) {
934 sv_grow(retval, SvCUR(retval)+2);
935 r = SvPVX(retval)+SvCUR(retval);
936 r[0] = '*'; r[1] = '{';
937 SvCUR_set(retval, SvCUR(retval)+2);
938 esc_q_utf8(aTHX_ retval, c, i);
939 sv_grow(retval, SvCUR(retval)+2);
940 r = SvPVX(retval)+SvCUR(retval);
941 r[0] = '}'; r[1] = '\0';
942 i = 1;
943 }
944 else
945#endif
946 {
823edd99
GS		 947 sv_grow(retval, SvCUR(retval)+6+2*i);
948 r = SvPVX(retval)+SvCUR(retval);
949 r[0] = '*'; r[1] = '{'; r[2] = '\'';
950 i += esc_q(r+3, c, i);
951 i += 3;
952 r[i++] = '\''; r[i++] = '}';
953 r[i] = '\0';
95869c09 954 }
823edd99
GS		 955 }
956 else {
957 sv_grow(retval, SvCUR(retval)+i+2);
958 r = SvPVX(retval)+SvCUR(retval);
959 r[0] = '*'; strcpy(r+1, c);
960 i++;
961 }
7820172a 962 SvCUR_set(retval, SvCUR(retval)+i);
823edd99
GS		 963
964 if (purity) {
27da23d5
JH		 965 static const char* const entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" };
966 static const STRLEN sizes[] = { 8, 7, 6 };
823edd99 967 SV *e;
9061c4b9
AL		 968 SV * const nname = newSVpvn("", 0);
969 SV * const newapad = newSVpvn("", 0);
970 GV * const gv = (GV*)val;
823edd99
GS		 971 I32 j;
972
973 for (j=0; j<3; j++) {
974 e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv));
7820172a
GS		 975 if (!e)
976 continue;
977 if (j == 0 && !SvOK(e))
978 continue;
979
980 {
823edd99 981 I32 nlevel = 0;
7820172a 982 SV *postentry = newSVpvn(r,i);
823edd99
GS		 983
984 sv_setsv(nname, postentry);
985 sv_catpvn(nname, entries[j], sizes[j]);
986 sv_catpvn(postentry, " = ", 3);
987 av_push(postav, postentry);
fec5e1eb 988 e = newRV_inc(e);
823edd99 989
b162af07 990 SvCUR_set(newapad, 0);
823edd99 991 if (indent >= 2)
cea2e8a9 992 (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry));
823edd99 993
aa07b2f6 994 DD_dump(aTHX_ e, SvPVX_const(nname), SvCUR(nname), postentry,
823edd99 995 seenhv, postav, &nlevel, indent, pad, xpad,
30b4f386 996 newapad, sep, pair, freezer, toaster, purity,
e9105f86
IN		 997 deepcopy, quotekeys, bless, maxdepth,
998 sortkeys);
823edd99
GS		 999 SvREFCNT_dec(e);
1000 }
1001 }
1002
1003 SvREFCNT_dec(newapad);
1004 SvREFCNT_dec(nname);
1005 }
1006 }
7820172a
GS		 1007 else if (val == &PL_sv_undef || !SvOK(val)) {
1008 sv_catpvn(retval, "undef", 5);
1009 }
d036e907
FC		 1010#ifdef SvVOK
1011 else if (SvMAGICAL(val) && (mg = mg_find(val, 'V'))) {
5fde9fa4 1012# if !defined(PL_vtbl_vstring) && PERL_VERSION < 17
d036e907
FC		 1013 SV * const vecsv = sv_newmortal();
1014# if PERL_VERSION < 10
1015 scan_vstring(mg->mg_ptr, vecsv);
1016# else
1017 scan_vstring(mg->mg_ptr, mg->mg_ptr + mg->mg_len, vecsv);
1018# endif
1019 if (!sv_eq(vecsv, val)) goto integer_came_from_string;
1020# endif
1021 sv_catpvn(retval, (const char *)mg->mg_ptr, mg->mg_len);
1022 }
1023#endif
823edd99 1024 else {
c4cce848 1025 integer_came_from_string:
823edd99 1026 c = SvPV(val, i);
dc71dc59 1027 if (DO_UTF8(val))
6cde4e94 1028 i += esc_q_utf8(aTHX_ retval, c, i);
dc71dc59
JH		 1029 else {
1030 sv_grow(retval, SvCUR(retval)+3+2*i); /* 3: ""\0 */
1031 r = SvPVX(retval) + SvCUR(retval);
1032 r[0] = '\'';
1033 i += esc_q(r+1, c, i);
1034 ++i;
1035 r[i++] = '\'';
1036 r[i] = '\0';
1037 SvCUR_set(retval, SvCUR(retval)+i);
1038 }
823edd99 1039 }
823edd99
GS		 1040 }
1041
7820172a
GS		 1042 if (idlen) {
1043 if (deepcopy)
1044 (void)hv_delete(seenhv, id, idlen, G_DISCARD);
1045 else if (namelen && seenentry) {
1046 SV *mark = *av_fetch(seenentry, 2, TRUE);
1047 sv_setiv(mark,1);
1048 }
1049 }
823edd99
GS		 1050 return 1;
1051}
1052
1053
1054MODULE = Data::Dumper PACKAGE = Data::Dumper PREFIX = Data_Dumper_
1055
1056#
1057# This is the exact equivalent of Dump. Well, almost. The things that are
1058# different as of now (due to Laziness):
c4a6f826 1059# * doesn't do double-quotes yet.
823edd99
GS		 1060#
1061
1062void
1063Data_Dumper_Dumpxs(href, ...)
1064 SV *href;
1065 PROTOTYPE: $;$$
1066 PPCODE:
1067 {
1068 HV *hv;
1069 SV *retval, *valstr;
5c284bb0 1070 HV *seenhv = NULL;
823edd99
GS		 1071 AV *postav, *todumpav, *namesav;
1072 I32 level = 0;
497b47a8 1073 I32 indent, terse, i, imax, postlen;
823edd99 1074 SV **svp;
30b4f386 1075 SV *val, *name, *pad, *xpad, *apad, *sep, *pair, *varname;
e9105f86 1076 SV *freezer, *toaster, *bless, *sortkeys;
7b0972df 1077 I32 purity, deepcopy, quotekeys, maxdepth = 0;
823edd99
GS		 1078 char tmpbuf[1024];
1079 I32 gimme = GIMME;
1080
1081 if (!SvROK(href)) { /* call new to get an object first */
0f1923bd
GS		 1082 if (items < 2)
1083 croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, [NAME_ARY_REF])");
823edd99
GS		 1084
1085 ENTER;
1086 SAVETMPS;
1087
1088 PUSHMARK(sp);
1089 XPUSHs(href);
0f1923bd
GS		 1090 XPUSHs(sv_2mortal(newSVsv(ST(1))));
1091 if (items >= 3)
1092 XPUSHs(sv_2mortal(newSVsv(ST(2))));
823edd99
GS		 1093 PUTBACK;
1094 i = perl_call_method("new", G_SCALAR);
1095 SPAGAIN;
1096 if (i)
1097 href = newSVsv(POPs);
1098
1099 PUTBACK;
1100 FREETMPS;
1101 LEAVE;
1102 if (i)
1103 (void)sv_2mortal(href);
1104 }
1105
7d49f689 1106 todumpav = namesav = NULL;
5c284bb0 1107 seenhv = NULL;
30b4f386 1108 val = pad = xpad = apad = sep = pair = varname
65e66c80 1109 = freezer = toaster = bless = sortkeys = &PL_sv_undef;
823edd99
GS		 1110 name = sv_newmortal();
1111 indent = 2;
497b47a8 1112 terse = purity = deepcopy = 0;
823edd99 1113 quotekeys = 1;
6cde4e94 1114
7820172a 1115 retval = newSVpvn("", 0);
823edd99
GS		 1116 if (SvROK(href)
1117 && (hv = (HV*)SvRV((SV*)href))
1118 && SvTYPE(hv) == SVt_PVHV) {
1119
1120 if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp))
1121 seenhv = (HV*)SvRV(*svp);
1122 if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp))
1123 todumpav = (AV*)SvRV(*svp);
1124 if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp))
1125 namesav = (AV*)SvRV(*svp);
1126 if ((svp = hv_fetch(hv, "indent", 6, FALSE)))
1127 indent = SvIV(*svp);
1128 if ((svp = hv_fetch(hv, "purity", 6, FALSE)))
1129 purity = SvIV(*svp);
1130 if ((svp = hv_fetch(hv, "terse", 5, FALSE)))
1131 terse = SvTRUE(*svp);
497b47a8 1132#if 0 /* useqq currently unused */
823edd99
GS		 1133 if ((svp = hv_fetch(hv, "useqq", 5, FALSE)))
1134 useqq = SvTRUE(*svp);
497b47a8 1135#endif
823edd99
GS		 1136 if ((svp = hv_fetch(hv, "pad", 3, FALSE)))
1137 pad = *svp;
1138 if ((svp = hv_fetch(hv, "xpad", 4, FALSE)))
1139 xpad = *svp;
1140 if ((svp = hv_fetch(hv, "apad", 4, FALSE)))
1141 apad = *svp;
1142 if ((svp = hv_fetch(hv, "sep", 3, FALSE)))
1143 sep = *svp;
30b4f386 1144 if ((svp = hv_fetch(hv, "pair", 4, FALSE)))
1145 pair = *svp;
823edd99
GS		 1146 if ((svp = hv_fetch(hv, "varname", 7, FALSE)))
1147 varname = *svp;
1148 if ((svp = hv_fetch(hv, "freezer", 7, FALSE)))
1149 freezer = *svp;
1150 if ((svp = hv_fetch(hv, "toaster", 7, FALSE)))
1151 toaster = *svp;
1152 if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE)))
1153 deepcopy = SvTRUE(*svp);
1154 if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE)))
1155 quotekeys = SvTRUE(*svp);
1156 if ((svp = hv_fetch(hv, "bless", 5, FALSE)))
1157 bless = *svp;
a2126434
JN		 1158 if ((svp = hv_fetch(hv, "maxdepth", 8, FALSE)))
1159 maxdepth = SvIV(*svp);
e9105f86
IN		 1160 if ((svp = hv_fetch(hv, "sortkeys", 8, FALSE))) {
1161 sortkeys = *svp;
1162 if (! SvTRUE(sortkeys))
1163 sortkeys = NULL;
1164 else if (! (SvROK(sortkeys) &&
1165 SvTYPE(SvRV(sortkeys)) == SVt_PVCV) )
1166 {
1167 /* flag to use qsortsv() for sorting hash keys */
1168 sortkeys = &PL_sv_yes;
1169 }
1170 }
823edd99
GS		 1171 postav = newAV();
1172
1173 if (todumpav)
1174 imax = av_len(todumpav);
1175 else
1176 imax = -1;
7820172a 1177 valstr = newSVpvn("",0);
823edd99
GS		 1178 for (i = 0; i <= imax; ++i) {
1179 SV *newapad;
6cde4e94 1180
823edd99
GS		 1181 av_clear(postav);
1182 if ((svp = av_fetch(todumpav, i, FALSE)))
1183 val = *svp;
1184 else
3280af22 1185 val = &PL_sv_undef;
d20128b8 1186 if ((svp = av_fetch(namesav, i, TRUE))) {
823edd99 1187 sv_setsv(name, *svp);
d20128b8
RGS		 1188 if (SvOK(*svp) && !SvPOK(*svp))
1189 (void)SvPV_nolen_const(name);
1190 }
823edd99 1191 else
8063af02 1192 (void)SvOK_off(name);
6cde4e94 1193
d20128b8 1194 if (SvPOK(name)) {
aa07b2f6 1195 if ((SvPVX_const(name))[0] == '*') {
823edd99
GS		 1196 if (SvROK(val)) {
1197 switch (SvTYPE(SvRV(val))) {
1198 case SVt_PVAV:
1199 (SvPVX(name))[0] = '@';
1200 break;
1201 case SVt_PVHV:
1202 (SvPVX(name))[0] = '%';
1203 break;
1204 case SVt_PVCV:
1205 (SvPVX(name))[0] = '*';
1206 break;
1207 default:
1208 (SvPVX(name))[0] = '$';
1209 break;
1210 }
1211 }
1212 else
1213 (SvPVX(name))[0] = '$';
1214 }
aa07b2f6 1215 else if ((SvPVX_const(name))[0] != '$')
823edd99
GS		 1216 sv_insert(name, 0, 0, "$", 1);
1217 }
1218 else {
9061c4b9 1219 STRLEN nchars;
823edd99
GS		 1220 sv_setpvn(name, "$", 1);
1221 sv_catsv(name, varname);
f5def3a2 1222 nchars = my_snprintf(tmpbuf, sizeof(tmpbuf), "%"IVdf, (IV)(i+1));
823edd99
GS		 1223 sv_catpvn(name, tmpbuf, nchars);
1224 }
6cde4e94 1225
d34e9bd9 1226 if (indent >= 2 && !terse) {
9061c4b9 1227 SV * const tmpsv = sv_x(aTHX_ NULL, " ", 1, SvCUR(name)+3);
823edd99
GS		 1228 newapad = newSVsv(apad);
1229 sv_catsv(newapad, tmpsv);
1230 SvREFCNT_dec(tmpsv);
1231 }
1232 else
1233 newapad = apad;
6cde4e94 1234
e3ec2293 1235 PUTBACK;
aa07b2f6 1236 DD_dump(aTHX_ val, SvPVX_const(name), SvCUR(name), valstr, seenhv,
30b4f386 1237 postav, &level, indent, pad, xpad, newapad, sep, pair,
823edd99 1238 freezer, toaster, purity, deepcopy, quotekeys,
e9105f86 1239 bless, maxdepth, sortkeys);
e3ec2293 1240 SPAGAIN;
6cde4e94 1241
d34e9bd9 1242 if (indent >= 2 && !terse)
823edd99
GS		 1243 SvREFCNT_dec(newapad);
1244
1245 postlen = av_len(postav);
1246 if (postlen >= 0 || !terse) {
1247 sv_insert(valstr, 0, 0, " = ", 3);
aa07b2f6 1248 sv_insert(valstr, 0, 0, SvPVX_const(name), SvCUR(name));
823edd99
GS		 1249 sv_catpvn(valstr, ";", 1);
1250 }
1251 sv_catsv(retval, pad);
1252 sv_catsv(retval, valstr);
1253 sv_catsv(retval, sep);
1254 if (postlen >= 0) {
1255 I32 i;
1256 sv_catsv(retval, pad);
1257 for (i = 0; i <= postlen; ++i) {
1258 SV *elem;
1259 svp = av_fetch(postav, i, FALSE);
1260 if (svp && (elem = *svp)) {
1261 sv_catsv(retval, elem);
1262 if (i < postlen) {
1263 sv_catpvn(retval, ";", 1);
1264 sv_catsv(retval, sep);
1265 sv_catsv(retval, pad);
1266 }
1267 }
1268 }
1269 sv_catpvn(retval, ";", 1);
1270 sv_catsv(retval, sep);
1271 }
1272 sv_setpvn(valstr, "", 0);
1273 if (gimme == G_ARRAY) {
1274 XPUSHs(sv_2mortal(retval));
1275 if (i < imax) /* not the last time thro ? */
7820172a 1276 retval = newSVpvn("",0);
823edd99
GS		 1277 }
1278 }
1279 SvREFCNT_dec(postav);
1280 SvREFCNT_dec(valstr);
1281 }
1282 else
1283 croak("Call to new() method failed to return HASH ref");
1284 if (gimme == G_SCALAR)
1285 XPUSHs(sv_2mortal(retval));
1286 }
d036e907
FC		 1287
1288SV *
1289Data_Dumper__vstring(sv)
1290 SV *sv;
1291 PROTOTYPE: $
1292 CODE:
1293 {
1294#ifdef SvVOK
1295 const MAGIC *mg;
1296 RETVAL =
1297 SvMAGICAL(sv) && (mg = mg_find(sv, 'V'))
1298 ? newSVpvn((const char *)mg->mg_ptr, mg->mg_len)
1299 : &PL_sv_undef;
1300#else
1301 RETVAL = &PL_sv_undef;
1302#endif
1303 }
1304 OUTPUT: RETVAL
Unnamed repository; edit this file 'description' to name the repository.