File Coverage

dist/Data-Dumper/Dumper.xs
Criterion Covered Total %
statement 642 669 96.0
branch n/a
condition n/a
subroutine n/a
total 642 669 96.0


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