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