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