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