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