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