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