projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
add Data-Dumper, up patchlevel to 71, various misc tweaks to
[p5sagit/p5-mst-13.2.git] / ext / Data / Dumper / Dumper.xs
CommitLineData
823edd99 1#ifdef __cplusplus
2extern "C" {
3#endif
4#include "EXTERN.h"
5#include "perl.h"
6#include "XSUB.h"
7#ifdef __cplusplus
8}
9#endif
10
11static SV *freezer;
12static SV *toaster;
13
14static I32 num_q _((char *s));
15static I32 esc_q _((char *dest, char *src, STRLEN slen));
16static SV *sv_x _((SV *sv, char *str, STRLEN len, I32 n));
17static I32 DD_dump _((SV *val, char *name, STRLEN namelen, SV *retval,
18 HV *seenhv, AV *postav, I32 *levelp, I32 indent,
19 SV *pad, SV *xpad, SV *apad, SV *sep,
20 SV *freezer, SV *toaster,
21 I32 purity, I32 deepcopy, I32 quotekeys, SV *bless));
22
23/* does a string need to be protected? */
24static I32
25needs_quote(register char *s)
26{
27TOP:
28 if (s[0] == ':') {
29 if (*++s) {
30 if (*s++ != ':')
31 return 1;
32 }
33 else
34 return 1;
35 }
36 if (isIDFIRST(*s)) {
37 while (*++s)
38 if (!isALNUM(*s))
39 if (*s == ':')
40 goto TOP;
41 else
42 return 1;
43 }
44 else
45 return 1;
46 return 0;
47}
48
49/* count the number of "'"s and "\"s in string */
50static I32
51num_q(register char *s)
52{
53 register I32 ret = 0;
54
55 while (*s) {
56 if (*s == '\'' || *s == '\\')
57 ++ret;
58 ++s;
59 }
60 return ret;
61}
62
63
64/* returns number of chars added to escape "'"s and "\"s in s */
65/* slen number of characters in s will be escaped */
66/* destination must be long enough for additional chars */
67static I32
68esc_q(register char *d, register char *s, register STRLEN slen)
69{
70 register I32 ret = 0;
71
72 while (slen > 0) {
73 switch (*s) {
74 case '\'':
75 case '\\':
76 *d = '\\';
77 ++d; ++ret;
78 default:
79 *d = *s;
80 ++d; ++s; --slen;
81 break;
82 }
83 }
84 return ret;
85}
86
87/* append a repeated string to an SV */
88static SV *
89sv_x(SV *sv, register char *str, STRLEN len, I32 n)
90{
91 if (sv == Nullsv)
92 sv = newSVpv("", 0);
93 else
94 assert(SvTYPE(sv) >= SVt_PV);
95
96 if (n > 0) {
97 SvGROW(sv, len*n + SvCUR(sv) + 1);
98 if (len == 1) {
99 char *start = SvPVX(sv) + SvCUR(sv);
100 SvCUR(sv) += n;
101 start[n] = '\0';
102 while (n > 0)
103 start[--n] = str[0];
104 }
105 else
106 while (n > 0) {
107 sv_catpvn(sv, str, len);
108 --n;
109 }
110 }
111 return sv;
112}
113
114/*
115 * This ought to be split into smaller functions. (it is one long function since
116 * it exactly parallels the perl version, which was one long thing for
117 * efficiency raisins.) Ugggh!
118 */
119static I32
120DD_dump(SV *val, char *name, STRLEN namelen, SV *retval, HV *seenhv,
121 AV *postav, I32 *levelp, I32 indent, SV *pad, SV *xpad,
122 SV *apad, SV *sep, SV *freezer, SV *toaster, I32 purity,
123 I32 deepcopy, I32 quotekeys, SV *bless)
124{
125 char tmpbuf[128];
126 U32 i;
127 char *c, *r, *realpack, id[128];
128 SV **svp;
129 SV *sv;
130 SV *blesspad = Nullsv;
131 SV *ipad;
132 SV *ival;
133 AV *seenentry;
134 char *iname;
135 STRLEN inamelen, idlen = 0;
136 U32 flags;
137 U32 realtype;
138
139 if (!val)
140 return 0;
141
142 flags = SvFLAGS(val);
143 realtype = SvTYPE(val);
144
145 if (SvGMAGICAL(val))
146 mg_get(val);
147 if (val == &sv_undef || !SvOK(val)) {
148 sv_catpvn(retval, "undef", 5);
149 return 1;
150 }
151 if (SvROK(val)) {
152
153 if (SvOBJECT(SvRV(val)) && freezer &&
154 SvPOK(freezer) && SvCUR(freezer))
155 {
156 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
157 XPUSHs(val); PUTBACK;
158 i = perl_call_method(SvPVX(freezer), G_EVAL|G_SCALAR);
159 SPAGAIN;
160 if (SvTRUE(GvSV(errgv)))
161 warn("WARNING(Freezer method call failed): %s",
162 SvPVX(GvSV(errgv)));
163 else if (i)
164 val = newSVsv(POPs);
165 PUTBACK; FREETMPS; LEAVE;
166 if (i)
167 (void)sv_2mortal(val);
168 }
169
170 ival = SvRV(val);
171 flags = SvFLAGS(ival);
172 realtype = SvTYPE(ival);
173 (void) sprintf(id, "0x%lx", (unsigned long)ival);
174 idlen = strlen(id);
175 if (SvOBJECT(ival))
176 realpack = HvNAME(SvSTASH(ival));
177 else
178 realpack = Nullch;
179 if ((svp = hv_fetch(seenhv, id, idlen, FALSE)) &&
180 (sv = *svp) && SvROK(sv) &&
181 (seenentry = (AV*)SvRV(sv))) {
182 SV *othername;
183 if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)) {
184 if (purity && *levelp > 0) {
185 SV *postentry;
186
187 if (realtype == SVt_PVHV)
188 sv_catpvn(retval, "{}", 2);
189 else if (realtype == SVt_PVAV)
190 sv_catpvn(retval, "[]", 2);
191 else
192 sv_catpvn(retval, "''", 2);
193 postentry = newSVpv(name, namelen);
194 sv_catpvn(postentry, " = ", 3);
195 sv_catsv(postentry, othername);
196 av_push(postav, postentry);
197 }
198 else {
199 if (name[0] == '@' || name[0] == '%') {
200 if ((SvPVX(othername))[0] == '\\' &&
201 (SvPVX(othername))[1] == name[0]) {
202 sv_catpvn(retval, SvPVX(othername)+1, SvCUR(othername)-1);
203 }
204 else {
205 sv_catpvn(retval, name, 1);
206 sv_catpvn(retval, "{", 1);
207 sv_catsv(retval, othername);
208 sv_catpvn(retval, "}", 1);
209 }
210 }
211 else
212 sv_catsv(retval, othername);
213 }
214 return 1;
215 }
216 else {
217 warn("ref name not found for %s", id);
218 return 0;
219 }
220 }
221 else { /* store our name and continue */
222 SV *namesv;
223 if (name[0] == '@' || name[0] == '%') {
224 namesv = newSVpv("\\", 1);
225 sv_catpvn(namesv, name, namelen);
226 }
227 else if (realtype == SVt_PVCV && name[0] == '*') {
228 namesv = newSVpv("\\", 2);
229 sv_catpvn(namesv, name, namelen);
230 (SvPVX(namesv))[1] = '&';
231 }
232 else
233 namesv = newSVpv(name, namelen);
234 seenentry = newAV();
235 av_push(seenentry, namesv);
236 (void)SvREFCNT_inc(val);
237 av_push(seenentry, val);
238 (void)hv_store(seenhv, id, strlen(id), newRV((SV*)seenentry), 0);
239 SvREFCNT_dec(seenentry);
240 }
241
242 (*levelp)++;
243 ipad = sv_x(Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp);
244
245 if (realpack) { /* we have a blessed ref */
246 STRLEN blesslen;
247 char *blessstr = SvPV(bless, blesslen);
248 sv_catpvn(retval, blessstr, blesslen);
249 sv_catpvn(retval, "( ", 2);
250 if (indent >= 2) {
251 blesspad = apad;
252 apad = newSVsv(apad);
253 sv_x(apad, " ", 1, blesslen+2);
254 }
255 }
256
257 if (realtype <= SVt_PVBM || realtype == SVt_PVGV) { /* scalars */
258 if (realpack && realtype != SVt_PVGV) { /* blessed */
259 sv_catpvn(retval, "do{\\(my $o = ", 13);
260 DD_dump(ival, "", 0, retval, seenhv, postav,
261 levelp, indent, pad, xpad, apad, sep,
262 freezer, toaster, purity, deepcopy, quotekeys, bless);
263 sv_catpvn(retval, ")}", 2);
264 }
265 else {
266 sv_catpvn(retval, "\\", 1);
267 DD_dump(ival, "", 0, retval, seenhv, postav,
268 levelp, indent, pad, xpad, apad, sep,
269 freezer, toaster, purity, deepcopy, quotekeys, bless);
270 }
271 }
272 else if (realtype == SVt_PVAV) {
273 SV *totpad;
274 I32 ix = 0;
275 I32 ixmax = av_len((AV *)ival);
276
277 SV *ixsv = newSViv(0);
278 /* allowing for a 24 char wide array index */
279 New(0, iname, namelen+28, char);
280 (void)strcpy(iname, name);
281 inamelen = namelen;
282 if (name[0] == '@') {
283 sv_catpvn(retval, "(", 1);
284 iname[0] = '$';
285 }
286 else {
287 sv_catpvn(retval, "[", 1);
288 if (namelen > 0 && name[namelen-1] != ']' && name[namelen-1] != '}') {
289 iname[inamelen++] = '-'; iname[inamelen++] = '>';
290 iname[inamelen] = '\0';
291 }
292 }
293 if (iname[0] == '*' && iname[inamelen-1] == '}' && inamelen >= 8 &&
294 (instr(iname+inamelen-8, "{SCALAR}") ||
295 instr(iname+inamelen-7, "{ARRAY}") ||
296 instr(iname+inamelen-6, "{HASH}"))) {
297 iname[inamelen++] = '-'; iname[inamelen++] = '>';
298 }
299 iname[inamelen++] = '['; iname[inamelen] = '\0';
300 totpad = newSVsv(sep);
301 sv_catsv(totpad, pad);
302 sv_catsv(totpad, apad);
303
304 for (ix = 0; ix <= ixmax; ++ix) {
305 STRLEN ilen;
306 SV *elem;
307 svp = av_fetch((AV*)ival, ix, FALSE);
308 if (svp)
309 elem = *svp;
310 else
311 elem = &sv_undef;
312
313 ilen = inamelen;
314 sv_setiv(ixsv, ix);
315 (void) sprintf(iname+ilen, "%ld", ix);
316 ilen = strlen(iname);
317 iname[ilen++] = ']'; iname[ilen] = '\0';
318 if (indent >= 3) {
319 sv_catsv(retval, totpad);
320 sv_catsv(retval, ipad);
321 sv_catpvn(retval, "#", 1);
322 sv_catsv(retval, ixsv);
323 }
324 sv_catsv(retval, totpad);
325 sv_catsv(retval, ipad);
326 DD_dump(elem, iname, ilen, retval, seenhv, postav,
327 levelp, indent, pad, xpad, apad, sep,
328 freezer, toaster, purity, deepcopy, quotekeys, bless);
329 if (ix < ixmax)
330 sv_catpvn(retval, ",", 1);
331 }
332 if (ixmax >= 0) {
333 SV *opad = sv_x(Nullsv, SvPVX(xpad), SvCUR(xpad), (*levelp)-1);
334 sv_catsv(retval, totpad);
335 sv_catsv(retval, opad);
336 SvREFCNT_dec(opad);
337 }
338 if (name[0] == '@')
339 sv_catpvn(retval, ")", 1);
340 else
341 sv_catpvn(retval, "]", 1);
342 SvREFCNT_dec(ixsv);
343 SvREFCNT_dec(totpad);
344 Safefree(iname);
345 }
346 else if (realtype == SVt_PVHV) {
347 SV *totpad, *newapad;
348 SV *iname, *sname;
349 HE *entry;
350 char *key;
351 I32 klen;
352 SV *hval;
353
354 iname = newSVpv(name, namelen);
355 if (name[0] == '%') {
356 sv_catpvn(retval, "(", 1);
357 (SvPVX(iname))[0] = '$';
358 }
359 else {
360 sv_catpvn(retval, "{", 1);
361 if (namelen > 0 && name[namelen-1] != ']' && name[namelen-1] != '}') {
362 sv_catpvn(iname, "->", 2);
363 }
364 }
365 if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 &&
366 (instr(name+namelen-8, "{SCALAR}") ||
367 instr(name+namelen-7, "{ARRAY}") ||
368 instr(name+namelen-6, "{HASH}"))) {
369 sv_catpvn(iname, "->", 2);
370 }
371 sv_catpvn(iname, "{", 1);
372 totpad = newSVsv(sep);
373 sv_catsv(totpad, pad);
374 sv_catsv(totpad, apad);
375
376 (void)hv_iterinit((HV*)ival);
377 i = 0;
378 while ((entry = hv_iternext((HV*)ival))) {
379 char *nkey;
380 I32 nticks = 0;
381
382 if (i)
383 sv_catpvn(retval, ",", 1);
384 i++;
385 key = hv_iterkey(entry, &klen);
386 hval = hv_iterval((HV*)ival, entry);
387
388 if (quotekeys || needs_quote(key)) {
389 nticks = num_q(key);
390 New(0, nkey, klen+nticks+3, char);
391 nkey[0] = '\'';
392 if (nticks)
393 klen += esc_q(nkey+1, key, klen);
394 else
395 (void)Copy(key, nkey+1, klen, char);
396 nkey[++klen] = '\'';
397 nkey[++klen] = '\0';
398 }
399 else {
400 New(0, nkey, klen, char);
401 (void)Copy(key, nkey, klen, char);
402 }
403
404 sname = newSVsv(iname);
405 sv_catpvn(sname, nkey, klen);
406 sv_catpvn(sname, "}", 1);
407
408 sv_catsv(retval, totpad);
409 sv_catsv(retval, ipad);
410 sv_catpvn(retval, nkey, klen);
411 sv_catpvn(retval, " => ", 4);
412 if (indent >= 2) {
413 char *extra;
414 I32 elen = 0;
415 newapad = newSVsv(apad);
416 New(0, extra, klen+4+1, char);
417 while (elen < (klen+4))
418 extra[elen++] = ' ';
419 extra[elen] = '\0';
420 sv_catpvn(newapad, extra, elen);
421 Safefree(extra);
422 }
423 else
424 newapad = apad;
425
426 DD_dump(hval, SvPVX(sname), SvCUR(sname), retval, seenhv,
427 postav, levelp, indent, pad, xpad, newapad, sep,
428 freezer, toaster, purity, deepcopy, quotekeys, bless);
429 SvREFCNT_dec(sname);
430 Safefree(nkey);
431 if (indent >= 2)
432 SvREFCNT_dec(newapad);
433 }
434 if (i) {
435 SV *opad = sv_x(Nullsv, SvPVX(xpad), SvCUR(xpad), *levelp-1);
436 sv_catsv(retval, totpad);
437 sv_catsv(retval, opad);
438 SvREFCNT_dec(opad);
439 }
440 if (name[0] == '%')
441 sv_catpvn(retval, ")", 1);
442 else
443 sv_catpvn(retval, "}", 1);
444 SvREFCNT_dec(iname);
445 SvREFCNT_dec(totpad);
446 }
447 else if (realtype == SVt_PVCV) {
448 sv_catpvn(retval, "sub { \"DUMMY\" }", 15);
449 if (purity)
450 warn("Encountered CODE ref, using dummy placeholder");
451 }
452 else {
453 warn("cannot handle ref type %ld", realtype);
454 }
455
456 if (realpack) { /* free blessed allocs */
457 if (indent >= 2) {
458 SvREFCNT_dec(apad);
459 apad = blesspad;
460 }
461 sv_catpvn(retval, ", '", 3);
462 sv_catpvn(retval, realpack, strlen(realpack));
463 sv_catpvn(retval, "' )", 3);
464 if (toaster && SvPOK(toaster) && SvCUR(toaster)) {
465 sv_catpvn(retval, "->", 2);
466 sv_catsv(retval, toaster);
467 sv_catpvn(retval, "()", 2);
468 }
469 }
470 SvREFCNT_dec(ipad);
471 (*levelp)--;
472 }
473 else {
474 STRLEN i;
475
476 if (namelen) {
477 (void) sprintf(id, "0x%lx", (unsigned long)val);
478 if ((svp = hv_fetch(seenhv, id, (idlen = strlen(id)), FALSE)) &&
479 (sv = *svp) && SvROK(sv) &&
480 (seenentry = (AV*)SvRV(sv))) {
481 SV *othername;
482 if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)) {
483 sv_catsv(retval, othername);
484 return 1;
485 }
486 }
487 else {
488 SV *namesv;
489 namesv = newSVpv("\\", 1);
490 sv_catpvn(namesv, name, namelen);
491 seenentry = newAV();
492 av_push(seenentry, namesv);
493 (void)SvREFCNT_inc(val);
494 av_push(seenentry, val);
495 (void)hv_store(seenhv, id, strlen(id), newRV((SV*)seenentry), 0);
496 SvREFCNT_dec(seenentry);
497 }
498 }
499
500 if (SvIOK(val)) {
501 STRLEN len;
502 i = SvIV(val);
503 (void) sprintf(tmpbuf, "%d", i);
504 len = strlen(tmpbuf);
505 sv_catpvn(retval, tmpbuf, len);
506 return 1;
507 }
508 else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */
509 c = SvPV(val, i);
510 ++c; --i; /* just get the name */
511 if (i >= 6 && strncmp(c, "main::", 6) == 0) {
512 c += 4;
513 i -= 4;
514 }
515 if (needs_quote(c)) {
516 sv_grow(retval, SvCUR(retval)+6+2*i);
517 r = SvPVX(retval)+SvCUR(retval);
518 r[0] = '*'; r[1] = '{'; r[2] = '\'';
519 i += esc_q(r+3, c, i);
520 i += 3;
521 r[i++] = '\''; r[i++] = '}';
522 r[i] = '\0';
523 }
524 else {
525 sv_grow(retval, SvCUR(retval)+i+2);
526 r = SvPVX(retval)+SvCUR(retval);
527 r[0] = '*'; strcpy(r+1, c);
528 i++;
529 }
530
531 if (purity) {
532 static char *entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" };
533 static STRLEN sizes[] = { 8, 7, 6 };
534 SV *e;
535 SV *nname = newSVpv("", 0);
536 SV *newapad = newSVpv("", 0);
537 GV *gv = (GV*)val;
538 I32 j;
539
540 for (j=0; j<3; j++) {
541 e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv));
542 if (e) {
543 I32 nlevel = 0;
544 SV *postentry = newSVpv(r,i);
545
546 sv_setsv(nname, postentry);
547 sv_catpvn(nname, entries[j], sizes[j]);
548 sv_catpvn(postentry, " = ", 3);
549 av_push(postav, postentry);
550 e = newRV(e);
551
552 SvCUR(newapad) = 0;
553 if (indent >= 2)
554 (void)sv_x(newapad, " ", 1, SvCUR(postentry));
555
556 DD_dump(e, SvPVX(nname), SvCUR(nname), postentry,
557 seenhv, postav, &nlevel, indent, pad, xpad,
558 newapad, sep, freezer, toaster, purity,
559 deepcopy, quotekeys, bless);
560 SvREFCNT_dec(e);
561 }
562 }
563
564 SvREFCNT_dec(newapad);
565 SvREFCNT_dec(nname);
566 }
567 }
568 else {
569 c = SvPV(val, i);
570 sv_grow(retval, SvCUR(retval)+3+2*i);
571 r = SvPVX(retval)+SvCUR(retval);
572 r[0] = '\'';
573 i += esc_q(r+1, c, i);
574 ++i;
575 r[i++] = '\'';
576 r[i] = '\0';
577 }
578 SvCUR_set(retval, SvCUR(retval)+i);
579 }
580
581 if (deepcopy && idlen)
582 (void)hv_delete(seenhv, id, idlen, G_DISCARD);
583
584 return 1;
585}
586
587
588MODULE = Data::Dumper PACKAGE = Data::Dumper PREFIX = Data_Dumper_
589
590#
591# This is the exact equivalent of Dump. Well, almost. The things that are
592# different as of now (due to Laziness):
593# * doesnt do double-quotes yet.
594#
595
596void
597Data_Dumper_Dumpxs(href, ...)
598 SV *href;
599 PROTOTYPE: $;$$
600 PPCODE:
601 {
602 HV *hv;
603 SV *retval, *valstr;
604 HV *seenhv = Nullhv;
605 AV *postav, *todumpav, *namesav;
606 I32 level = 0;
607 I32 indent, terse, useqq, i, imax, postlen;
608 SV **svp;
609 SV *val, *name, *pad, *xpad, *apad, *sep, *tmp, *varname;
610 SV *freezer, *toaster, *bless;
611 I32 purity, deepcopy, quotekeys;
612 char tmpbuf[1024];
613 I32 gimme = GIMME;
614
615 if (!SvROK(href)) { /* call new to get an object first */
616 SV *valarray;
617 SV *namearray;
618
619 if (items == 3) {
620 valarray = ST(1);
621 namearray = ST(2);
622 }
623 else
624 croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, NAME_ARY_REF)");
625
626 ENTER;
627 SAVETMPS;
628
629 PUSHMARK(sp);
630 XPUSHs(href);
631 XPUSHs(sv_2mortal(newSVsv(valarray)));
632 XPUSHs(sv_2mortal(newSVsv(namearray)));
633 PUTBACK;
634 i = perl_call_method("new", G_SCALAR);
635 SPAGAIN;
636 if (i)
637 href = newSVsv(POPs);
638
639 PUTBACK;
640 FREETMPS;
641 LEAVE;
642 if (i)
643 (void)sv_2mortal(href);
644 }
645
646 todumpav = namesav = Nullav;
647 seenhv = Nullhv;
648 val = pad = xpad = apad = sep = tmp = varname
649 = freezer = toaster = bless = &sv_undef;
650 name = sv_newmortal();
651 indent = 2;
652 terse = useqq = purity = deepcopy = 0;
653 quotekeys = 1;
654
655 retval = newSVpv("", 0);
656 if (SvROK(href)
657 && (hv = (HV*)SvRV((SV*)href))
658 && SvTYPE(hv) == SVt_PVHV) {
659
660 if ((svp = hv_fetch(hv, "seen", 4, FALSE)) && SvROK(*svp))
661 seenhv = (HV*)SvRV(*svp);
662 if ((svp = hv_fetch(hv, "todump", 6, FALSE)) && SvROK(*svp))
663 todumpav = (AV*)SvRV(*svp);
664 if ((svp = hv_fetch(hv, "names", 5, FALSE)) && SvROK(*svp))
665 namesav = (AV*)SvRV(*svp);
666 if ((svp = hv_fetch(hv, "indent", 6, FALSE)))
667 indent = SvIV(*svp);
668 if ((svp = hv_fetch(hv, "purity", 6, FALSE)))
669 purity = SvIV(*svp);
670 if ((svp = hv_fetch(hv, "terse", 5, FALSE)))
671 terse = SvTRUE(*svp);
672 if ((svp = hv_fetch(hv, "useqq", 5, FALSE)))
673 useqq = SvTRUE(*svp);
674 if ((svp = hv_fetch(hv, "pad", 3, FALSE)))
675 pad = *svp;
676 if ((svp = hv_fetch(hv, "xpad", 4, FALSE)))
677 xpad = *svp;
678 if ((svp = hv_fetch(hv, "apad", 4, FALSE)))
679 apad = *svp;
680 if ((svp = hv_fetch(hv, "sep", 3, FALSE)))
681 sep = *svp;
682 if ((svp = hv_fetch(hv, "varname", 7, FALSE)))
683 varname = *svp;
684 if ((svp = hv_fetch(hv, "freezer", 7, FALSE)))
685 freezer = *svp;
686 if ((svp = hv_fetch(hv, "toaster", 7, FALSE)))
687 toaster = *svp;
688 if ((svp = hv_fetch(hv, "deepcopy", 8, FALSE)))
689 deepcopy = SvTRUE(*svp);
690 if ((svp = hv_fetch(hv, "quotekeys", 9, FALSE)))
691 quotekeys = SvTRUE(*svp);
692 if ((svp = hv_fetch(hv, "bless", 5, FALSE)))
693 bless = *svp;
694 postav = newAV();
695
696 if (todumpav)
697 imax = av_len(todumpav);
698 else
699 imax = -1;
700 valstr = newSVpv("",0);
701 for (i = 0; i <= imax; ++i) {
702 SV *newapad;
703
704 av_clear(postav);
705 if ((svp = av_fetch(todumpav, i, FALSE)))
706 val = *svp;
707 else
708 val = &sv_undef;
709 if ((svp = av_fetch(namesav, i, TRUE)))
710 sv_setsv(name, *svp);
711 else
712 SvOK_off(name);
713
714 if (SvOK(name)) {
715 if ((SvPVX(name))[0] == '*') {
716 if (SvROK(val)) {
717 switch (SvTYPE(SvRV(val))) {
718 case SVt_PVAV:
719 (SvPVX(name))[0] = '@';
720 break;
721 case SVt_PVHV:
722 (SvPVX(name))[0] = '%';
723 break;
724 case SVt_PVCV:
725 (SvPVX(name))[0] = '*';
726 break;
727 default:
728 (SvPVX(name))[0] = '$';
729 break;
730 }
731 }
732 else
733 (SvPVX(name))[0] = '$';
734 }
735 else if ((SvPVX(name))[0] != '$')
736 sv_insert(name, 0, 0, "$", 1);
737 }
738 else {
739 STRLEN nchars = 0;
740 sv_setpvn(name, "$", 1);
741 sv_catsv(name, varname);
742 (void) sprintf(tmpbuf, "%ld", i+1);
743 nchars = strlen(tmpbuf);
744 sv_catpvn(name, tmpbuf, nchars);
745 }
746
747 if (indent >= 2) {
748 SV *tmpsv = sv_x(Nullsv, " ", 1, SvCUR(name)+3);
749 newapad = newSVsv(apad);
750 sv_catsv(newapad, tmpsv);
751 SvREFCNT_dec(tmpsv);
752 }
753 else
754 newapad = apad;
755
756 DD_dump(val, SvPVX(name), SvCUR(name), valstr, seenhv,
757 postav, &level, indent, pad, xpad, newapad, sep,
758 freezer, toaster, purity, deepcopy, quotekeys,
759 bless);
760
761 if (indent >= 2)
762 SvREFCNT_dec(newapad);
763
764 postlen = av_len(postav);
765 if (postlen >= 0 || !terse) {
766 sv_insert(valstr, 0, 0, " = ", 3);
767 sv_insert(valstr, 0, 0, SvPVX(name), SvCUR(name));
768 sv_catpvn(valstr, ";", 1);
769 }
770 sv_catsv(retval, pad);
771 sv_catsv(retval, valstr);
772 sv_catsv(retval, sep);
773 if (postlen >= 0) {
774 I32 i;
775 sv_catsv(retval, pad);
776 for (i = 0; i <= postlen; ++i) {
777 SV *elem;
778 svp = av_fetch(postav, i, FALSE);
779 if (svp && (elem = *svp)) {
780 sv_catsv(retval, elem);
781 if (i < postlen) {
782 sv_catpvn(retval, ";", 1);
783 sv_catsv(retval, sep);
784 sv_catsv(retval, pad);
785 }
786 }
787 }
788 sv_catpvn(retval, ";", 1);
789 sv_catsv(retval, sep);
790 }
791 sv_setpvn(valstr, "", 0);
792 if (gimme == G_ARRAY) {
793 XPUSHs(sv_2mortal(retval));
794 if (i < imax) /* not the last time thro ? */
795 retval = newSVpv("",0);
796 }
797 }
798 SvREFCNT_dec(postav);
799 SvREFCNT_dec(valstr);
800 }
801 else
802 croak("Call to new() method failed to return HASH ref");
803 if (gimme == G_SCALAR)
804 XPUSHs(sv_2mortal(retval));
805 }
Unnamed repository; edit this file to name it for gitweb.