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