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