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