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