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