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