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_my_sprintf
8 # define NEED_sv_2pv_flags
9 # define NEED_utf8_to_uvchr_buf
10 # include "ppport.h"
11 #endif
12
13 #ifndef strlcpy
14 # ifdef my_strlcpy
15 # define strlcpy(d,s,l) my_strlcpy(d,s,l)
16 # else
17 # define strlcpy(d,s,l) strcpy(d,s)
18 # endif
19 #endif
20
21 /* These definitions are ASCII only. But the pure-perl .pm avoids
22 * calling this .xs file for releases where they aren't defined */
23
24 #ifndef ESC_NATIVE /* \e */
25 # define ESC_NATIVE LATIN1_TO_NATIVE(27)
26 #endif
27
28 /* SvPVCLEAR only from perl 5.25.6 */
29 #ifndef SvPVCLEAR
30 # define SvPVCLEAR(sv) sv_setpvs((sv), "")
31 #endif
32
33 #ifndef memBEGINs
34 # define memBEGINs(s1, l, s2) \
35 ( (l) >= sizeof(s2) - 1 \
36 && memEQ(s1, "" s2 "", sizeof(s2)-1))
37 #endif
38
39 /* This struct contains almost all the user's desired configuration, and it
40 * is treated as mostly constant (except for maxrecursed) by the recursive
41 * function. This arrangement has the advantage of needing less memory
42 * than passing all of them on the stack all the time (as was the case in
43 * an earlier implementation). */
44 typedef struct {
45 SV *pad;
46 SV *xpad;
47 SV *sep;
48 SV *pair;
49 SV *sortkeys;
50 SV *freezer;
51 SV *toaster;
52 SV *bless;
53 IV maxrecurse;
54 bool maxrecursed; /* at some point we exceeded the maximum recursion level */
55 I32 indent;
56 I32 purity;
57 I32 deepcopy;
58 I32 quotekeys;
59 I32 maxdepth;
60 I32 useqq;
61 int use_sparse_seen_hash;
62 int trailingcomma;
63 int deparse;
64 } Style;
65
66 static STRLEN num_q (const char *s, STRLEN slen);
67 static STRLEN esc_q (char *dest, const char *src, STRLEN slen);
68 static STRLEN esc_q_utf8 (pTHX_ SV *sv, const char *src, STRLEN slen, I32 do_utf8, I32 useqq);
69 static bool globname_needs_quote(const char *s, STRLEN len);
70 #ifndef GvNAMEUTF8
71 static bool globname_supra_ascii(const char *s, STRLEN len);
72 #endif
73 static bool key_needs_quote(const char *s, STRLEN len);
74 static bool safe_decimal_number(const char *p, STRLEN len);
75 static SV *sv_x (pTHX_ SV *sv, const char *str, STRLEN len, I32 n);
76 static I32 DD_dump (pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval,
77 HV *seenhv, AV *postav, const I32 level, SV *apad,
78 Style *style);
79
80 #define DD_is_integer(sv) SvIOK(sv)
81
82 /* does a glob name need to be protected? */
83 static bool
globname_needs_quote(const char * ss,STRLEN len)84 globname_needs_quote(const char *ss, STRLEN len)
85 {
86 const U8 *s = (const U8 *) ss;
87 const U8 *send = s+len;
88 TOP:
89 if (s[0] == ':') {
90 if (++s<send) {
91 if (*s++ != ':')
92 return TRUE;
93 }
94 else
95 return TRUE;
96 }
97 if (isIDFIRST(*s)) {
98 while (++s<send)
99 if (!isWORDCHAR(*s)) {
100 if (*s == ':')
101 goto TOP;
102 else
103 return TRUE;
104 }
105 }
106 else
107 return TRUE;
108
109 return FALSE;
110 }
111
112 #ifndef GvNAMEUTF8
113 /* does a glob name contain supra-ASCII characters? */
114 static bool
globname_supra_ascii(const char * ss,STRLEN len)115 globname_supra_ascii(const char *ss, STRLEN len)
116 {
117 const U8 *s = (const U8 *) ss;
118 const U8 *send = s+len;
119 while (s < send) {
120 if (!isASCII(*s))
121 return TRUE;
122 s++;
123 }
124 return FALSE;
125 }
126 #endif
127
128 /* does a hash key need to be quoted (to the left of => ).
129 Previously this used (globname_)needs_quote() which accepted strings
130 like '::foo', but these aren't safe as unquoted keys under strict.
131 */
132 static bool
key_needs_quote(const char * s,STRLEN len)133 key_needs_quote(const char *s, STRLEN len) {
134 const char *send = s+len;
135
136 if (safe_decimal_number(s, len)) {
137 return FALSE;
138 }
139 else if (isIDFIRST(*s)) {
140 while (++s<send)
141 if (!isWORDCHAR(*s))
142 return TRUE;
143 }
144 else
145 return TRUE;
146
147 return FALSE;
148 }
149
150 /* Check that the SV can be represented as a simple decimal integer.
151 *
152 * The perl code does this by matching against /^(?:0|-?[1-9]\d{0,8})\z/
153 */
154 static bool
safe_decimal_number(const char * p,STRLEN len)155 safe_decimal_number(const char *p, STRLEN len) {
156 if (len == 1 && *p == '0')
157 return TRUE;
158
159 if (len && *p == '-') {
160 ++p;
161 --len;
162 }
163
164 if (len == 0 || *p < '1' || *p > '9')
165 return FALSE;
166
167 ++p;
168 --len;
169
170 if (len > 8)
171 return FALSE;
172
173 while (len > 0) {
174 /* the perl code checks /\d/ but we don't want unicode digits here */
175 if (*p < '0' || *p > '9')
176 return FALSE;
177 ++p;
178 --len;
179 }
180 return TRUE;
181 }
182
183 /* count the number of "'"s and "\"s in string */
184 static STRLEN
num_q(const char * s,STRLEN slen)185 num_q(const char *s, STRLEN slen)
186 {
187 STRLEN ret = 0;
188
189 while (slen > 0) {
190 if (*s == '\'' || *s == '\\')
191 ++ret;
192 ++s;
193 --slen;
194 }
195 return ret;
196 }
197
198
199 /* returns number of chars added to escape "'"s and "\"s in s */
200 /* slen number of characters in s will be escaped */
201 /* destination must be long enough for additional chars */
202 static STRLEN
esc_q(char * d,const char * s,STRLEN slen)203 esc_q(char *d, const char *s, STRLEN slen)
204 {
205 STRLEN ret = 0;
206
207 while (slen > 0) {
208 switch (*s) {
209 case '\'':
210 case '\\':
211 *d = '\\';
212 ++d; ++ret;
213 /* FALLTHROUGH */
214 default:
215 *d = *s;
216 ++d; ++s; --slen;
217 break;
218 }
219 }
220 return ret;
221 }
222
223 /* this function is also misused for implementing $Useqq */
224 static STRLEN
esc_q_utf8(pTHX_ SV * sv,const char * src,STRLEN slen,I32 do_utf8,I32 useqq)225 esc_q_utf8(pTHX_ SV* sv, const char *src, STRLEN slen, I32 do_utf8, I32 useqq)
226 {
227 char *r, *rstart;
228 const char *s = src;
229 const char * const send = src + slen;
230 STRLEN j, cur = SvCUR(sv);
231 /* Could count 128-255 and 256+ in two variables, if we want to
232 be like &qquote and make a distinction. */
233 STRLEN grow = 0; /* bytes needed to represent chars 128+ */
234 /* STRLEN topbit_grow = 0; bytes needed to represent chars 128-255 */
235 STRLEN backslashes = 0;
236 STRLEN single_quotes = 0;
237 STRLEN qq_escapables = 0; /* " $ @ will need a \ in "" strings. */
238 STRLEN normal = 0;
239 int increment;
240
241 for (s = src; s < send; s += increment) { /* Sizing pass */
242 UV k = *(U8*)s;
243
244 increment = 1; /* Will override if necessary for utf-8 */
245
246 if (isPRINT(k)) {
247 if (k == '\\') {
248 backslashes++;
249 } else if (k == '\'') {
250 single_quotes++;
251 } else if (k == '"' || k == '$' || k == '@') {
252 qq_escapables++;
253 } else {
254 normal++;
255 }
256 }
257 else if (! UTF8_IS_INVARIANT(k)) {
258 /* We treat as low ordinal any code point whose representation is
259 * the same under UTF-8 as not. Thus, this is a high ordinal code
260 * point.
261 *
262 * If UTF-8, output as hex, regardless of useqq. This means there
263 * is an overhead of 4 chars '\x{}'. Then count the number of hex
264 * digits. */
265 if (do_utf8) {
266 k = utf8_to_uvchr_buf((U8*)s, (U8*) send, NULL);
267
268 /* treat invalid utf8 byte by byte. This loop iteration gets the
269 * first byte */
270 increment = (k == 0 && *s != '\0') ? 1 : UTF8SKIP(s);
271
272 grow += 6; /* Smallest we do is "\x{FF}" */
273 k >>= 4;
274 while ((k >>= 4) != 0) { /* Add space for each nibble */
275 grow++;
276 }
277 }
278 else if (useqq) { /* Not utf8, must be <= 0xFF, hence 2 hex
279 * digits. */
280 grow += 4 + 2;
281 }
282 else { /* Non-qq generates 3 octal digits plus backslash */
283 grow += 4;
284 }
285 } /* End of high-ordinal non-printable */
286 else if (! useqq) { /* Low ordinal, non-printable, non-qq just
287 * outputs the raw char */
288 normal++;
289 }
290 else { /* Is qq, low ordinal, non-printable. Output escape
291 * sequences */
292 if ( k == '\a' || k == '\b' || k == '\t' || k == '\n' || k == '\r'
293 || k == '\f' || k == ESC_NATIVE)
294 {
295 grow += 2; /* 1 char plus backslash */
296 }
297 else /* The other low ordinals are output as an octal escape
298 * sequence */
299 if (s + 1 >= send || isDIGIT(*(s+1))) {
300 /* When the following character is a digit, use 3 octal digits
301 * plus backslash, as using fewer digits would concatenate the
302 * following char into this one */
303 grow += 4;
304 }
305 else if (k <= 7) {
306 grow += 2; /* 1 octal digit, plus backslash */
307 }
308 else if (k <= 077) {
309 grow += 3; /* 2 octal digits plus backslash */
310 }
311 else {
312 grow += 4; /* 3 octal digits plus backslash */
313 }
314 }
315 } /* End of size-calculating loop */
316
317 if (grow || useqq) {
318 /* We have something needing hex. 3 is ""\0 */
319 sv_grow(sv, cur + 3 + grow + 2*backslashes + single_quotes
320 + 2*qq_escapables + normal);
321 rstart = r = SvPVX(sv) + cur;
322
323 *r++ = '"';
324
325 for (s = src; s < send; s += increment) {
326 U8 c0 = *(U8 *)s;
327 UV k;
328
329 if (do_utf8 && ! UTF8_IS_INVARIANT(c0)) {
330
331 /* In UTF-8, we output as \x{} all chars that require more than
332 * a single byte in UTF-8 to represent. */
333 k = utf8_to_uvchr_buf((U8*)s, (U8*) send, NULL);
334
335 /* treat invalid utf8 byte by byte. This loop iteration gets the
336 * first byte */
337 increment = (k == 0 && *s != '\0') ? 1 : UTF8SKIP(s);
338
339 r = r + my_sprintf(r, "\\x{%" UVxf "}", k);
340 continue;
341 }
342
343 /* Here 1) isn't UTF-8; or
344 * 2) the current character is ASCII; or
345 * 3) it is an EBCDIC platform and is a low ordinal
346 * non-ASCII control.
347 * In each case the character occupies just one byte */
348 k = *(U8*)s;
349 increment = 1;
350
351 if (isPRINT(k)) {
352 /* These need a backslash escape */
353 if (k == '"' || k == '\\' || k == '$' || k == '@') {
354 *r++ = '\\';
355 }
356
357 *r++ = (char)k;
358 }
359 else if (! useqq) { /* non-qq, non-printable, low-ordinal is
360 * output raw */
361 *r++ = (char)k;
362 }
363 else { /* Is qq means use escape sequences */
364 bool next_is_digit;
365
366 *r++ = '\\';
367 switch (k) {
368 case '\a': *r++ = 'a'; break;
369 case '\b': *r++ = 'b'; break;
370 case '\t': *r++ = 't'; break;
371 case '\n': *r++ = 'n'; break;
372 case '\f': *r++ = 'f'; break;
373 case '\r': *r++ = 'r'; break;
374 case ESC_NATIVE: *r++ = 'e'; break;
375 default:
376
377 /* only ASCII digits matter here, which are invariant,
378 * since we only encode characters \377 and under, or
379 * \x177 and under for a unicode string
380 */
381 next_is_digit = (s + 1 < send && isDIGIT(*(s+1)));
382
383 /* faster than
384 * r = r + my_sprintf(r, "%o", k);
385 */
386 if (k <= 7 && !next_is_digit) {
387 *r++ = (char)k + '0';
388 } else if (k <= 63 && !next_is_digit) {
389 *r++ = (char)(k>>3) + '0';
390 *r++ = (char)(k&7) + '0';
391 } else {
392 *r++ = (char)(k>>6) + '0';
393 *r++ = (char)((k&63)>>3) + '0';
394 *r++ = (char)(k&7) + '0';
395 }
396 }
397 }
398 }
399 *r++ = '"';
400 } else {
401 /* Single quotes. */
402 sv_grow(sv, cur + 3 + 2*backslashes + 2*single_quotes
403 + qq_escapables + normal);
404 rstart = r = SvPVX(sv) + cur;
405 *r++ = '\'';
406 for (s = src; s < send; s ++) {
407 const char k = *s;
408 if (k == '\'' || k == '\\')
409 *r++ = '\\';
410 *r++ = k;
411 }
412 *r++ = '\'';
413 }
414 *r = '\0';
415 j = r - rstart;
416 SvCUR_set(sv, cur + j);
417
418 return j;
419 }
420
421 /* append a repeated string to an SV */
422 static SV *
sv_x(pTHX_ SV * sv,const char * str,STRLEN len,I32 n)423 sv_x(pTHX_ SV *sv, const char *str, STRLEN len, I32 n)
424 {
425 if (!sv)
426 sv = newSVpvs("");
427 #ifdef DEBUGGING
428 else
429 assert(SvTYPE(sv) >= SVt_PV);
430 #endif
431
432 if (n > 0) {
433 SvGROW(sv, len*n + SvCUR(sv) + 1);
434 if (len == 1) {
435 char * const start = SvPVX(sv) + SvCUR(sv);
436 SvCUR_set(sv, SvCUR(sv) + n);
437 start[n] = '\0';
438 while (n > 0)
439 start[--n] = str[0];
440 }
441 else
442 while (n > 0) {
443 sv_catpvn(sv, str, len);
444 --n;
445 }
446 }
447 return sv;
448 }
449
450 static SV *
deparsed_output(pTHX_ SV * val)451 deparsed_output(pTHX_ SV *val)
452 {
453 SV *text;
454 int n;
455 dSP;
456
457 /* This is passed to load_module(), which decrements its ref count and
458 * modifies it (so we also can't reuse it below) */
459 SV *pkg = newSVpvs("B::Deparse");
460
461 /* Commit ebdc88085efa6fca8a1b0afaa388f0491bdccd5a (first released as part
462 * of 5.19.7) changed core S_process_special_blocks() to use a new stack
463 * for anything using a BEGIN block, on the grounds that doing so "avoids
464 * the stack moving underneath anything that directly or indirectly calls
465 * Perl_load_module()". If we're in an older Perl, we can't rely on that
466 * stack, and must create a fresh sacrificial stack of our own. */
467 #if PERL_VERSION_LT(5,20,0)
468 PUSHSTACKi(PERLSI_REQUIRE);
469 #endif
470
471 load_module(PERL_LOADMOD_NOIMPORT, pkg, 0);
472
473 #if PERL_VERSION_LT(5,20,0)
474 POPSTACK;
475 SPAGAIN;
476 #endif
477
478 SAVETMPS;
479
480 PUSHMARK(SP);
481 mXPUSHs(newSVpvs("B::Deparse"));
482 PUTBACK;
483
484 n = call_method("new", G_SCALAR);
485 SPAGAIN;
486
487 if (n != 1) {
488 croak("B::Deparse->new returned %d items, but expected exactly 1", n);
489 }
490
491 PUSHMARK(SP - n);
492 XPUSHs(val);
493 PUTBACK;
494
495 n = call_method("coderef2text", G_SCALAR);
496 SPAGAIN;
497
498 if (n != 1) {
499 croak("$b_deparse->coderef2text returned %d items, but expected exactly 1", n);
500 }
501
502 text = POPs;
503 SvREFCNT_inc(text); /* the caller will mortalise this */
504
505 FREETMPS;
506
507 PUTBACK;
508
509 return text;
510 }
511
512 static void
dump_regexp(pTHX_ SV * retval,SV * val)513 dump_regexp(pTHX_ SV *retval, SV *val)
514 {
515 STRLEN rlen;
516 SV *sv_pattern = NULL;
517 SV *sv_flags = NULL;
518 const char *rval;
519 const U8 *rend;
520 U8 *p;
521 CV *re_pattern_cv = get_cv("re::regexp_pattern", 0);
522 int do_utf8;
523
524 if (!re_pattern_cv) {
525 sv_pattern = val;
526 }
527 else {
528 dSP;
529 I32 count;
530 ENTER;
531 SAVETMPS;
532 PUSHMARK(SP);
533 XPUSHs(val);
534 PUTBACK;
535 count = call_sv((SV*)re_pattern_cv, G_ARRAY);
536 SPAGAIN;
537 if (count >= 2) {
538 sv_flags = POPs;
539 sv_pattern = POPs;
540 SvREFCNT_inc(sv_flags);
541 SvREFCNT_inc(sv_pattern);
542 }
543 PUTBACK;
544 FREETMPS;
545 LEAVE;
546 if (sv_pattern) {
547 sv_2mortal(sv_pattern);
548 sv_2mortal(sv_flags);
549 }
550 }
551
552 assert(sv_pattern);
553
554 sv_catpvs(retval, "qr/");
555
556 /* The strategy here is from commit 7894fbab1e479c2c (in June 1999) with a
557 * bug fix in Feb 2012 (commit de5ef703c7d8db65).
558 * We need to ensure that / is escaped as \/
559 * To be efficient, we want to avoid copying byte-for-byte, so we scan the
560 * string looking for "things we need to escape", and each time we find
561 * something, we copy over the verbatim section, before writing out the
562 * escaped part. At the end, if there's some verbatim section left, we copy
563 * that over to finish.
564 * The complication (perl #58608) is that we must not convert \/ to \\/
565 * (as that would be a syntax error), so we need to walk the string looking
566 * for either
567 * \ and the character immediately after (together)
568 * a character
569 * and only for the latter, do we need to escape /
570 *
571 * Of course, to add to the fun, we also need to escape Unicode characters
572 * to \x{...} notation (whether they are "escaped" by \ or stand alone).
573 *
574 * which means we need to output qr// notation
575 * even if the input was expressed as q'' (eg q'$foo')
576 *
577 * We can do all this in one pass if we are careful...
578 */
579
580 rval = SvPV(sv_pattern, rlen);
581 p = (U8 *)rval;
582 rend = p + rlen;
583 do_utf8 = DO_UTF8(sv_pattern);
584
585 while (p < rend) {
586 UV k = *p;
587 int saw_backslash = k == '\\';
588
589 if (saw_backslash) {
590 if (++p == rend) {
591 /* Oh my, \ at the end. Is this possible? */
592 break;
593 }
594 /* Otherwise we look at the next octet */
595 k = *p;
596 }
597
598 if (/* / that was not backslashed */
599 (k == '/' && !saw_backslash)
600 /* $ that was not backslashed, unless it is at the end of the regex
601 or it is followed by | or it is followed by ) */
602 || (k == '$' && !saw_backslash
603 && (p + 1 != rend && p[1] != '|' && p[1] != ')'))
604 /* or need to use \x{} notation. */
605 || (do_utf8 && ! UTF8_IS_INVARIANT(k)))
606 {
607 STRLEN to_copy = p - (U8 *) rval;
608 if (to_copy) {
609 /* If saw_backslash is true, this will copy the \ for us too. */
610 sv_catpvn(retval, rval, to_copy);
611 }
612 if (k == '/') {
613 sv_catpvs(retval, "\\/");
614 ++p;
615 }
616 else if (k == '$') {
617 /* this approach suggested by Eirik Berg Hanssen: */
618 sv_catpvs(retval, "${\\q($)}");
619 ++p;
620 }
621 else {
622 /* If there was a \, we have copied it already, so all that is
623 * left to do here is the \x{...} escaping.
624 *
625 * Since this is a pattern, presumably created by perl, we can
626 * assume it is well-formed */
627 k = utf8_to_uvchr_buf(p, rend, NULL);
628 sv_catpvf(retval, "\\x{%" UVxf "}", k);
629 p += UTF8SKIP(p);
630 }
631 rval = (const char *) p;
632 }
633 else {
634 ++p;
635 }
636 }
637
638 rlen = rend - (U8 *) rval;
639 if (rlen) {
640 sv_catpvn(retval, rval, rlen);
641 }
642 sv_catpvs(retval, "/");
643
644 if (sv_flags)
645 sv_catsv(retval, sv_flags);
646 }
647
648 /*
649 * This ought to be split into smaller functions. (it is one long function since
650 * it exactly parallels the perl version, which was one long thing for
651 * efficiency raisins.) Ugggh!
652 */
653 static I32
DD_dump(pTHX_ SV * val,const char * name,STRLEN namelen,SV * retval,HV * seenhv,AV * postav,const I32 level,SV * apad,Style * style)654 DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
655 AV *postav, const I32 level, SV *apad, Style *style)
656 {
657 char tmpbuf[128];
658 Size_t i;
659 char *c, *r, *realpack;
660 UV id_buffer;
661 char *const id = (char *)&id_buffer;
662 SV **svp;
663 SV *sv, *ipad, *ival;
664 SV *blesspad = Nullsv;
665 AV *seenentry = NULL;
666 char *iname;
667 STRLEN inamelen, idlen = 0;
668 U32 realtype;
669 bool no_bless = 0; /* when a qr// is blessed into Regexp we dont want to bless it.
670 in later perls we should actually check the classname of the
671 engine. this gets tricky as it involves lexical issues that arent so
672 easy to resolve */
673 bool is_regex = 0; /* we are dumping a regex, we need to know this before we bless */
674
675 if (!val)
676 return 0;
677
678 if (style->maxrecursed)
679 return 0;
680
681 /* If the output buffer has less than some arbitrary amount of space
682 remaining, then enlarge it. For the test case (25M of output),
683 *1.1 was slower, *2.0 was the same, so the first guess of 1.5 is
684 deemed to be good enough. */
685 if (SvTYPE(retval) >= SVt_PV && (SvLEN(retval) - SvCUR(retval)) < 42) {
686 sv_grow(retval, SvCUR(retval) * 3 / 2);
687 }
688
689 realtype = SvTYPE(val);
690
691 if (SvGMAGICAL(val))
692 mg_get(val);
693 if (SvROK(val)) {
694
695 /* If a freeze method is provided and the object has it, call
696 it. Warn on errors. */
697 if (SvOBJECT(SvRV(val)) && style->freezer &&
698 SvPOK(style->freezer) && SvCUR(style->freezer) &&
699 gv_fetchmeth(SvSTASH(SvRV(val)), SvPVX_const(style->freezer),
700 SvCUR(style->freezer), -1) != NULL)
701 {
702 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
703 XPUSHs(val); PUTBACK;
704 i = perl_call_method(SvPVX_const(style->freezer), G_EVAL|G_VOID|G_DISCARD);
705 SPAGAIN;
706 if (SvTRUE(ERRSV))
707 warn("WARNING(Freezer method call failed): %" SVf, ERRSV);
708 PUTBACK; FREETMPS; LEAVE;
709 }
710
711 ival = SvRV(val);
712 realtype = SvTYPE(ival);
713 id_buffer = PTR2UV(ival);
714 idlen = sizeof(id_buffer);
715 if (SvOBJECT(ival))
716 realpack = HvNAME_get(SvSTASH(ival));
717 else
718 realpack = NULL;
719
720 /* if it has a name, we need to either look it up, or keep a tab
721 * on it so we know when we hit it later
722 */
723 if (namelen) {
724 if ((svp = hv_fetch(seenhv, id, idlen, FALSE))
725 && (sv = *svp) && SvROK(sv) && (seenentry = (AV*)SvRV(sv)))
726 {
727 SV *othername;
728 if ((svp = av_fetch(seenentry, 0, FALSE))
729 && (othername = *svp))
730 {
731 if (style->purity && level > 0) {
732 SV *postentry;
733
734 if (realtype == SVt_PVHV)
735 sv_catpvs(retval, "{}");
736 else if (realtype == SVt_PVAV)
737 sv_catpvs(retval, "[]");
738 else
739 sv_catpvs(retval, "do{my $o}");
740 postentry = newSVpvn(name, namelen);
741 sv_catpvs(postentry, " = ");
742 sv_catsv(postentry, othername);
743 av_push(postav, postentry);
744 }
745 else {
746 if (name[0] == '@' || name[0] == '%') {
747 if ((SvPVX_const(othername))[0] == '\\' &&
748 (SvPVX_const(othername))[1] == name[0]) {
749 sv_catpvn(retval, SvPVX_const(othername)+1,
750 SvCUR(othername)-1);
751 }
752 else {
753 sv_catpvn(retval, name, 1);
754 sv_catpvs(retval, "{");
755 sv_catsv(retval, othername);
756 sv_catpvs(retval, "}");
757 }
758 }
759 else
760 sv_catsv(retval, othername);
761 }
762 return 1;
763 }
764 else {
765 warn("ref name not found for 0x%" UVxf, PTR2UV(ival));
766 return 0;
767 }
768 }
769 else { /* store our name and continue */
770 SV *namesv;
771 if (name[0] == '@' || name[0] == '%') {
772 namesv = newSVpvs("\\");
773 sv_catpvn(namesv, name, namelen);
774 }
775 else if (realtype == SVt_PVCV && name[0] == '*') {
776 namesv = newSVpvs("\\");
777 sv_catpvn(namesv, name, namelen);
778 (SvPVX(namesv))[1] = '&';
779 }
780 else
781 namesv = newSVpvn(name, namelen);
782 seenentry = newAV();
783 av_push(seenentry, namesv);
784 (void)SvREFCNT_inc(val);
785 av_push(seenentry, val);
786 (void)hv_store(seenhv, id, idlen,
787 newRV_inc((SV*)seenentry), 0);
788 SvREFCNT_dec(seenentry);
789 }
790 }
791 /* regexps dont have to be blessed into package "Regexp"
792 * they can be blessed into any package.
793 */
794 #if PERL_VERSION_LT(5,11,0)
795 if (realpack && realtype == SVt_PVMG && mg_find(ival, PERL_MAGIC_qr))
796 #else
797 if (realpack && realtype == SVt_REGEXP)
798 #endif
799 {
800 is_regex = 1;
801 if (strEQ(realpack, "Regexp"))
802 no_bless = 1;
803 else
804 no_bless = 0;
805 }
806
807 /* If purity is not set and maxdepth is set, then check depth:
808 * if we have reached maximum depth, return the string
809 * representation of the thing we are currently examining
810 * at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)').
811 */
812 if (!style->purity && style->maxdepth > 0 && level >= style->maxdepth) {
813 STRLEN vallen;
814 const char * const valstr = SvPV(val,vallen);
815 sv_catpvs(retval, "'");
816 sv_catpvn(retval, valstr, vallen);
817 sv_catpvs(retval, "'");
818 return 1;
819 }
820
821 if (style->maxrecurse > 0 && level >= style->maxrecurse) {
822 style->maxrecursed = TRUE;
823 }
824
825 if (realpack && !no_bless) { /* we have a blessed ref */
826 STRLEN blesslen;
827 const char * const blessstr = SvPV(style->bless, blesslen);
828 sv_catpvn(retval, blessstr, blesslen);
829 sv_catpvs(retval, "( ");
830 if (style->indent >= 2) {
831 blesspad = apad;
832 apad = sv_2mortal(newSVsv(apad));
833 sv_x(aTHX_ apad, " ", 1, blesslen+2);
834 }
835 }
836
837 ipad = sv_x(aTHX_ Nullsv, SvPVX_const(style->xpad), SvCUR(style->xpad), level+1);
838 sv_2mortal(ipad);
839
840 if (is_regex) {
841 dump_regexp(aTHX_ retval, val);
842 }
843 else if (
844 #if PERL_VERSION_LT(5,9,0)
845 realtype <= SVt_PVBM
846 #else
847 realtype <= SVt_PVMG
848 #endif
849 ) { /* scalar ref */
850 SV * const namesv = sv_2mortal(newSVpvs("${"));
851 sv_catpvn(namesv, name, namelen);
852 sv_catpvs(namesv, "}");
853 if (realpack) { /* blessed */
854 sv_catpvs(retval, "do{\\(my $o = ");
855 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
856 postav, level+1, apad, style);
857 sv_catpvs(retval, ")}");
858 } /* plain */
859 else {
860 sv_catpvs(retval, "\\");
861 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
862 postav, level+1, apad, style);
863 }
864 }
865 else if (realtype == SVt_PVGV) { /* glob ref */
866 SV * const namesv = newSVpvs("*{");
867 sv_catpvn(namesv, name, namelen);
868 sv_catpvs(namesv, "}");
869 sv_catpvs(retval, "\\");
870 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
871 postav, level+1, apad, style);
872 SvREFCNT_dec(namesv);
873 }
874 else if (realtype == SVt_PVAV) {
875 SV *totpad;
876 SSize_t ix = 0;
877 const SSize_t ixmax = av_len((AV *)ival);
878
879 SV * const ixsv = sv_2mortal(newSViv(0));
880 /* allowing for a 24 char wide array index */
881 New(0, iname, namelen+28, char);
882 SAVEFREEPV(iname);
883 (void) strlcpy(iname, name, namelen+28);
884 inamelen = namelen;
885 if (name[0] == '@') {
886 sv_catpvs(retval, "(");
887 iname[0] = '$';
888 }
889 else {
890 sv_catpvs(retval, "[");
891 /* omit "->" in $foo{bar}->[0], but not in ${$foo}->[0] */
892 /*if (namelen > 0
893 && name[namelen-1] != ']' && name[namelen-1] != '}'
894 && (namelen < 4 || (name[1] != '{' && name[2] != '{')))*/
895 if ((namelen > 0
896 && name[namelen-1] != ']' && name[namelen-1] != '}')
897 || (namelen > 4
898 && (name[1] == '{'
899 || (name[0] == '\\' && name[2] == '{'))))
900 {
901 iname[inamelen++] = '-'; iname[inamelen++] = '>';
902 iname[inamelen] = '\0';
903 }
904 }
905 if (iname[0] == '*' && iname[inamelen-1] == '}' && inamelen >= 8 &&
906 (instr(iname+inamelen-8, "{SCALAR}") ||
907 instr(iname+inamelen-7, "{ARRAY}") ||
908 instr(iname+inamelen-6, "{HASH}"))) {
909 iname[inamelen++] = '-'; iname[inamelen++] = '>';
910 }
911 iname[inamelen++] = '['; iname[inamelen] = '\0';
912 totpad = sv_2mortal(newSVsv(style->sep));
913 sv_catsv(totpad, style->pad);
914 sv_catsv(totpad, apad);
915
916 for (ix = 0; ix <= ixmax; ++ix) {
917 STRLEN ilen;
918 SV *elem;
919 svp = av_fetch((AV*)ival, ix, FALSE);
920 if (svp)
921 elem = *svp;
922 else
923 elem = &PL_sv_undef;
924
925 ilen = inamelen;
926 sv_setiv(ixsv, ix);
927 ilen = ilen + my_sprintf(iname+ilen, "%" IVdf, (IV)ix);
928 iname[ilen++] = ']'; iname[ilen] = '\0';
929 if (style->indent >= 3) {
930 sv_catsv(retval, totpad);
931 sv_catsv(retval, ipad);
932 sv_catpvs(retval, "#");
933 sv_catsv(retval, ixsv);
934 }
935 sv_catsv(retval, totpad);
936 sv_catsv(retval, ipad);
937 ENTER;
938 SAVETMPS;
939 DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav,
940 level+1, apad, style);
941 FREETMPS;
942 LEAVE;
943 if (ix < ixmax || (style->trailingcomma && style->indent >= 1))
944 sv_catpvs(retval, ",");
945 }
946 if (ixmax >= 0) {
947 SV * const opad = sv_x(aTHX_ Nullsv, SvPVX_const(style->xpad), SvCUR(style->xpad), level);
948 sv_catsv(retval, totpad);
949 sv_catsv(retval, opad);
950 SvREFCNT_dec(opad);
951 }
952 if (name[0] == '@')
953 sv_catpvs(retval, ")");
954 else
955 sv_catpvs(retval, "]");
956 }
957 else if (realtype == SVt_PVHV) {
958 SV *totpad, *newapad;
959 SV *sname;
960 HE *entry = NULL;
961 char *key;
962 SV *hval;
963 AV *keys = NULL;
964
965 SV * const iname = newSVpvn_flags(name, namelen, SVs_TEMP);
966 if (name[0] == '%') {
967 sv_catpvs(retval, "(");
968 (SvPVX(iname))[0] = '$';
969 }
970 else {
971 sv_catpvs(retval, "{");
972 /* omit "->" in $foo[0]->{bar}, but not in ${$foo}->{bar} */
973 if ((namelen > 0
974 && name[namelen-1] != ']' && name[namelen-1] != '}')
975 || (namelen > 4
976 && (name[1] == '{'
977 || (name[0] == '\\' && name[2] == '{'))))
978 {
979 sv_catpvs(iname, "->");
980 }
981 }
982 if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 &&
983 (instr(name+namelen-8, "{SCALAR}") ||
984 instr(name+namelen-7, "{ARRAY}") ||
985 instr(name+namelen-6, "{HASH}"))) {
986 sv_catpvs(iname, "->");
987 }
988 sv_catpvs(iname, "{");
989 totpad = sv_2mortal(newSVsv(style->sep));
990 sv_catsv(totpad, style->pad);
991 sv_catsv(totpad, apad);
992
993 /* If requested, get a sorted/filtered array of hash keys */
994 if (style->sortkeys) {
995 if (style->sortkeys == &PL_sv_yes) {
996 keys = newAV();
997 (void)hv_iterinit((HV*)ival);
998 while ((entry = hv_iternext((HV*)ival))) {
999 sv = hv_iterkeysv(entry);
1000 (void)SvREFCNT_inc(sv);
1001 av_push(keys, sv);
1002 }
1003 #ifdef USE_LOCALE_COLLATE
1004 # ifdef IN_LC /* Use this if available */
1005 if (IN_LC(LC_COLLATE))
1006 # else
1007 if (IN_LOCALE)
1008 # endif
1009 {
1010 sortsv(AvARRAY(keys),
1011 av_len(keys)+1,
1012 Perl_sv_cmp_locale);
1013 }
1014 else
1015 #endif
1016 {
1017 sortsv(AvARRAY(keys),
1018 av_len(keys)+1,
1019 Perl_sv_cmp);
1020 }
1021 }
1022 else
1023 {
1024 dSP; ENTER; SAVETMPS; PUSHMARK(sp);
1025 XPUSHs(sv_2mortal(newRV_inc(ival))); PUTBACK;
1026 i = perl_call_sv(style->sortkeys, G_SCALAR | G_EVAL);
1027 SPAGAIN;
1028 if (i) {
1029 sv = POPs;
1030 if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVAV))
1031 keys = (AV*)SvREFCNT_inc(SvRV(sv));
1032 }
1033 if (! keys)
1034 warn("Sortkeys subroutine did not return ARRAYREF\n");
1035 PUTBACK; FREETMPS; LEAVE;
1036 }
1037 if (keys)
1038 sv_2mortal((SV*)keys);
1039 }
1040 else
1041 (void)hv_iterinit((HV*)ival);
1042
1043 /* foreach (keys %hash) */
1044 for (i = 0; 1; i++) {
1045 char *nkey;
1046 char *nkey_buffer = NULL;
1047 STRLEN nticks = 0;
1048 SV* keysv;
1049 STRLEN klen;
1050 STRLEN keylen;
1051 STRLEN nlen;
1052 bool do_utf8 = FALSE;
1053
1054 if (style->sortkeys) {
1055 if (!(keys && (SSize_t)i <= av_len(keys))) break;
1056 } else {
1057 if (!(entry = hv_iternext((HV *)ival))) break;
1058 }
1059
1060 if (i)
1061 sv_catpvs(retval, ",");
1062
1063 if (style->sortkeys) {
1064 char *key;
1065 svp = av_fetch(keys, i, FALSE);
1066 keysv = svp ? *svp : sv_newmortal();
1067 key = SvPV(keysv, keylen);
1068 svp = hv_fetch((HV*)ival, key,
1069 SvUTF8(keysv) ? -(I32)keylen : (I32)keylen, 0);
1070 hval = svp ? *svp : sv_newmortal();
1071 }
1072 else {
1073 keysv = hv_iterkeysv(entry);
1074 hval = hv_iterval((HV*)ival, entry);
1075 }
1076
1077 key = SvPV(keysv, keylen);
1078 do_utf8 = DO_UTF8(keysv);
1079 klen = keylen;
1080
1081 sv_catsv(retval, totpad);
1082 sv_catsv(retval, ipad);
1083
1084 ENTER;
1085 SAVETMPS;
1086
1087 /* The (very)
1088 old logic was first to check utf8 flag, and if utf8 always
1089 call esc_q_utf8. This caused test to break under -Mutf8,
1090 because there even strings like 'c' have utf8 flag on.
1091 Hence with quotekeys == 0 the XS code would still '' quote
1092 them based on flags, whereas the perl code would not,
1093 based on regexps.
1094
1095 The old logic checked that the string was a valid
1096 perl glob name (foo::bar), which isn't safe under
1097 strict, and differs from the perl code which only
1098 accepts simple identifiers.
1099
1100 With the fix for [perl #120384] I chose to make
1101 their handling of key quoting compatible between XS
1102 and perl.
1103 */
1104 if (style->quotekeys || key_needs_quote(key,keylen)) {
1105 if (do_utf8 || style->useqq) {
1106 STRLEN ocur = SvCUR(retval);
1107 klen = nlen = esc_q_utf8(aTHX_ retval, key, klen, do_utf8, style->useqq);
1108 nkey = SvPVX(retval) + ocur;
1109 }
1110 else {
1111 nticks = num_q(key, klen);
1112 New(0, nkey_buffer, klen+nticks+3, char);
1113 SAVEFREEPV(nkey_buffer);
1114 nkey = nkey_buffer;
1115 nkey[0] = '\'';
1116 if (nticks)
1117 klen += esc_q(nkey+1, key, klen);
1118 else
1119 (void)Copy(key, nkey+1, klen, char);
1120 nkey[++klen] = '\'';
1121 nkey[++klen] = '\0';
1122 nlen = klen;
1123 sv_catpvn(retval, nkey, klen);
1124 }
1125 }
1126 else {
1127 nkey = key;
1128 nlen = klen;
1129 sv_catpvn(retval, nkey, klen);
1130 }
1131
1132 sname = sv_2mortal(newSVsv(iname));
1133 sv_catpvn(sname, nkey, nlen);
1134 sv_catpvs(sname, "}");
1135
1136 sv_catsv(retval, style->pair);
1137 if (style->indent >= 2) {
1138 char *extra;
1139 STRLEN elen = 0;
1140 newapad = sv_2mortal(newSVsv(apad));
1141 New(0, extra, klen+4+1, char);
1142 while (elen < (klen+4))
1143 extra[elen++] = ' ';
1144 extra[elen] = '\0';
1145 sv_catpvn(newapad, extra, elen);
1146 Safefree(extra);
1147 }
1148 else
1149 newapad = apad;
1150
1151 DD_dump(aTHX_ hval, SvPVX_const(sname), SvCUR(sname), retval, seenhv,
1152 postav, level+1, newapad, style);
1153
1154 FREETMPS;
1155 LEAVE;
1156 }
1157 if (i) {
1158 SV *opad = sv_x(aTHX_ Nullsv, SvPVX_const(style->xpad),
1159 SvCUR(style->xpad), level);
1160 if (style->trailingcomma && style->indent >= 1)
1161 sv_catpvs(retval, ",");
1162 sv_catsv(retval, totpad);
1163 sv_catsv(retval, opad);
1164 SvREFCNT_dec(opad);
1165 }
1166 if (name[0] == '%')
1167 sv_catpvs(retval, ")");
1168 else
1169 sv_catpvs(retval, "}");
1170 }
1171 else if (realtype == SVt_PVCV) {
1172 if (style->deparse) {
1173 SV *deparsed = sv_2mortal(deparsed_output(aTHX_ val));
1174 SV *fullpad = sv_2mortal(newSVsv(style->sep));
1175 const char *p;
1176 STRLEN plen;
1177 I32 i;
1178
1179 sv_catsv(fullpad, style->pad);
1180 sv_catsv(fullpad, apad);
1181 for (i = 0; i < level; i++) {
1182 sv_catsv(fullpad, style->xpad);
1183 }
1184
1185 sv_catpvs(retval, "sub ");
1186 p = SvPV(deparsed, plen);
1187 while (plen > 0) {
1188 const char *nl = (const char *) memchr(p, '\n', plen);
1189 if (!nl) {
1190 sv_catpvn(retval, p, plen);
1191 break;
1192 }
1193 else {
1194 size_t n = nl - p;
1195 sv_catpvn(retval, p, n);
1196 sv_catsv(retval, fullpad);
1197 p += n + 1;
1198 plen -= n + 1;
1199 }
1200 }
1201 }
1202 else {
1203 sv_catpvs(retval, "sub { \"DUMMY\" }");
1204 if (style->purity)
1205 warn("Encountered CODE ref, using dummy placeholder");
1206 }
1207 }
1208 else {
1209 warn("cannot handle ref type %d", (int)realtype);
1210 }
1211
1212 if (realpack && !no_bless) { /* free blessed allocs */
1213 STRLEN plen, pticks;
1214
1215 if (style->indent >= 2) {
1216 apad = blesspad;
1217 }
1218 sv_catpvs(retval, ", '");
1219
1220 plen = strlen(realpack);
1221 pticks = num_q(realpack, plen);
1222 if (pticks) { /* needs escaping */
1223 char *npack;
1224 char *npack_buffer = NULL;
1225
1226 New(0, npack_buffer, plen+pticks+1, char);
1227 npack = npack_buffer;
1228 plen += esc_q(npack, realpack, plen);
1229 npack[plen] = '\0';
1230
1231 sv_catpvn(retval, npack, plen);
1232 Safefree(npack_buffer);
1233 }
1234 else {
1235 sv_catpvn(retval, realpack, strlen(realpack));
1236 }
1237 sv_catpvs(retval, "' )");
1238 if (style->toaster && SvPOK(style->toaster) && SvCUR(style->toaster)) {
1239 sv_catpvs(retval, "->");
1240 sv_catsv(retval, style->toaster);
1241 sv_catpvs(retval, "()");
1242 }
1243 }
1244 }
1245 else {
1246 STRLEN i;
1247 const MAGIC *mg;
1248
1249 if (namelen) {
1250 id_buffer = PTR2UV(val);
1251 idlen = sizeof(id_buffer);
1252 if ((svp = hv_fetch(seenhv, id, idlen, FALSE)) &&
1253 (sv = *svp) && SvROK(sv) &&
1254 (seenentry = (AV*)SvRV(sv)))
1255 {
1256 SV *othername;
1257 if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)
1258 && (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0)
1259 {
1260 sv_catpvs(retval, "${");
1261 sv_catsv(retval, othername);
1262 sv_catpvs(retval, "}");
1263 return 1;
1264 }
1265 }
1266 /* If we're allowed to keep only a sparse "seen" hash
1267 * (IOW, the user does not expect it to contain everything
1268 * after the dump, then only store in seen hash if the SV
1269 * ref count is larger than 1. If it's 1, then we know that
1270 * there is no other reference, duh. This is an optimization.
1271 * Note that we'd have to check for weak-refs, too, but this is
1272 * already the branch for non-refs only. */
1273 else if (val != &PL_sv_undef && (!style->use_sparse_seen_hash || SvREFCNT(val) > 1)) {
1274 SV * const namesv = newSVpvs("\\");
1275 sv_catpvn(namesv, name, namelen);
1276 seenentry = newAV();
1277 av_push(seenentry, namesv);
1278 av_push(seenentry, newRV_inc(val));
1279 (void)hv_store(seenhv, id, idlen, newRV_inc((SV*)seenentry), 0);
1280 SvREFCNT_dec(seenentry);
1281 }
1282 }
1283
1284 if (DD_is_integer(val)) {
1285 STRLEN len;
1286 if (SvIsUV(val))
1287 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%" UVuf, SvUV(val));
1288 else
1289 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%" IVdf, SvIV(val));
1290 if (SvPOK(val)) {
1291 /* Need to check to see if this is a string such as " 0".
1292 I'm assuming from sprintf isn't going to clash with utf8. */
1293 STRLEN pvlen;
1294 const char * const pv = SvPV(val, pvlen);
1295 if (pvlen != len || memNE(pv, tmpbuf, len))
1296 goto integer_came_from_string;
1297 }
1298 if (len > 10) {
1299 /* Looks like we're on a 64 bit system. Make it a string so that
1300 if a 32 bit system reads the number it will cope better. */
1301 sv_catpvf(retval, "'%s'", tmpbuf);
1302 } else
1303 sv_catpvn(retval, tmpbuf, len);
1304 }
1305 else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */
1306 c = SvPV(val, i);
1307 if(i) ++c, --i; /* just get the name */
1308 if (memBEGINs(c, i, "main::")) {
1309 c += 4;
1310 if (i == 6)
1311 i = 0; else i -= 4;
1312 }
1313 if (globname_needs_quote(c,i)) {
1314 sv_grow(retval, SvCUR(retval)+3);
1315 r = SvPVX(retval)+SvCUR(retval);
1316 r[0] = '*'; r[1] = '{'; r[2] = 0;
1317 SvCUR_set(retval, SvCUR(retval)+2);
1318 i = 3 + esc_q_utf8(aTHX_ retval, c, i,
1319 #ifdef GvNAMEUTF8
1320 !!GvNAMEUTF8(val), style->useqq
1321 #else
1322 0, style->useqq || globname_supra_ascii(c, i)
1323 #endif
1324 );
1325 sv_grow(retval, SvCUR(retval)+2);
1326 r = SvPVX(retval)+SvCUR(retval);
1327 r[0] = '}'; r[1] = '\0';
1328 SvCUR_set(retval, SvCUR(retval)+1);
1329 r = r+1 - i;
1330 }
1331 else {
1332 sv_grow(retval, SvCUR(retval)+i+2);
1333 r = SvPVX(retval)+SvCUR(retval);
1334 r[0] = '*'; strlcpy(r+1, c, SvLEN(retval));
1335 i++;
1336 SvCUR_set(retval, SvCUR(retval)+i);
1337 }
1338
1339 if (style->purity) {
1340 static const char* const entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" };
1341 static const STRLEN sizes[] = { 8, 7, 6 };
1342 SV *e;
1343 SV * const nname = newSVpvs("");
1344 SV * const newapad = newSVpvs("");
1345 GV * const gv = (GV*)val;
1346 I32 j;
1347
1348 for (j=0; j<3; j++) {
1349 e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv));
1350 if (!e)
1351 continue;
1352 if (j == 0 && !SvOK(e))
1353 continue;
1354
1355 {
1356 SV *postentry = newSVpvn(r,i);
1357
1358 sv_setsv(nname, postentry);
1359 sv_catpvn(nname, entries[j], sizes[j]);
1360 sv_catpvs(postentry, " = ");
1361 av_push(postav, postentry);
1362 e = newRV_inc(e);
1363
1364 SvCUR_set(newapad, 0);
1365 if (style->indent >= 2)
1366 (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry));
1367
1368 DD_dump(aTHX_ e, SvPVX_const(nname), SvCUR(nname), postentry,
1369 seenhv, postav, 0, newapad, style);
1370 SvREFCNT_dec(e);
1371 }
1372 }
1373
1374 SvREFCNT_dec(newapad);
1375 SvREFCNT_dec(nname);
1376 }
1377 }
1378 else if (val == &PL_sv_undef || !SvOK(val)) {
1379 sv_catpvs(retval, "undef");
1380 }
1381 #ifdef SvVOK
1382 else if (SvMAGICAL(val) && (mg = mg_find(val, 'V'))) {
1383 # if !defined(PL_vtbl_vstring) && PERL_VERSION_LT(5,17,0)
1384 SV * const vecsv = sv_newmortal();
1385 # if PERL_VERSION_LT(5,10,0)
1386 scan_vstring(mg->mg_ptr, vecsv);
1387 # else
1388 scan_vstring(mg->mg_ptr, mg->mg_ptr + mg->mg_len, vecsv);
1389 # endif
1390 if (!sv_eq(vecsv, val)) goto integer_came_from_string;
1391 # endif
1392 sv_catpvn(retval, (const char *)mg->mg_ptr, mg->mg_len);
1393 }
1394 #endif
1395
1396 else {
1397 integer_came_from_string:
1398 c = SvPV(val, i);
1399 /* the pure perl and XS non-qq outputs have historically been
1400 * different in this case, but for useqq, let's try to match
1401 * the pure perl code.
1402 * see [perl #74798]
1403 */
1404 if (style->useqq && safe_decimal_number(c, i)) {
1405 sv_catsv(retval, val);
1406 }
1407 else if (DO_UTF8(val) || style->useqq)
1408 i += esc_q_utf8(aTHX_ retval, c, i, DO_UTF8(val), style->useqq);
1409 else {
1410 sv_grow(retval, SvCUR(retval)+3+2*i); /* 3: ""\0 */
1411 r = SvPVX(retval) + SvCUR(retval);
1412 r[0] = '\'';
1413 i += esc_q(r+1, c, i);
1414 ++i;
1415 r[i++] = '\'';
1416 r[i] = '\0';
1417 SvCUR_set(retval, SvCUR(retval)+i);
1418 }
1419 }
1420 }
1421
1422 if (idlen) {
1423 if (style->deepcopy)
1424 (void)hv_delete(seenhv, id, idlen, G_DISCARD);
1425 else if (namelen && seenentry) {
1426 SV *mark = *av_fetch(seenentry, 2, TRUE);
1427 sv_setiv(mark,1);
1428 }
1429 }
1430 return 1;
1431 }
1432
1433
1434 MODULE = Data::Dumper PACKAGE = Data::Dumper PREFIX = Data_Dumper_
1435
1436 #
1437 # This is the exact equivalent of Dump. Well, almost. The things that are
1438 # different as of now (due to Laziness):
1439 # * doesn't do deparse yet.'
1440 #
1441
1442 void
1443 Data_Dumper_Dumpxs(href, ...)
1444 SV *href;
1445 PROTOTYPE: $;$$
1446 PPCODE:
1447 {
1448 HV *hv;
1449 SV *retval, *valstr;
1450 HV *seenhv = NULL;
1451 AV *postav, *todumpav, *namesav;
1452 I32 terse = 0;
1453 SSize_t i, imax, postlen;
1454 SV **svp;
1455 SV *apad = &PL_sv_undef;
1456 Style style;
1457
1458 SV *name_sv, *val = &PL_sv_undef, *varname = &PL_sv_undef;
1459 I32 gimme = GIMME_V;
1460
1461 if (!SvROK(href)) { /* call new to get an object first */
1462 if (items < 2)
1463 croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, [NAME_ARY_REF])");
1464
1465 ENTER;
1466 SAVETMPS;
1467
1468 PUSHMARK(sp);
1469 EXTEND(SP, 3); /* 3 == max of all branches below */
1470 PUSHs(href);
1471 PUSHs(sv_2mortal(newSVsv(ST(1))));
1472 if (items >= 3)
1473 PUSHs(sv_2mortal(newSVsv(ST(2))));
1474 PUTBACK;
1475 i = perl_call_method("new", G_SCALAR);
1476 SPAGAIN;
1477 if (i)
1478 href = newSVsv(POPs);
1479
1480 PUTBACK;
1481 FREETMPS;
1482 LEAVE;
1483 if (i)
1484 (void)sv_2mortal(href);
1485 }
1486
1487 todumpav = namesav = NULL;
1488 style.indent = 2;
1489 style.quotekeys = 1;
1490 style.maxrecurse = 1000;
1491 style.maxrecursed = FALSE;
1492 style.purity = style.deepcopy = style.useqq = style.maxdepth
1493 = style.use_sparse_seen_hash = style.trailingcomma = 0;
1494 style.pad = style.xpad = style.sep = style.pair = style.sortkeys
1495 = style.freezer = style.toaster = style.bless = &PL_sv_undef;
1496 seenhv = NULL;
1497 name_sv = sv_newmortal();
1498
1499 retval = newSVpvs_flags("", SVs_TEMP);
1500 if (SvROK(href)
1501 && (hv = (HV*)SvRV((SV*)href))
1502 && SvTYPE(hv) == SVt_PVHV) {
1503
1504 if ((svp = hv_fetchs(hv, "seen", FALSE)) && SvROK(*svp))
1505 seenhv = (HV*)SvRV(*svp);
1506 else
1507 style.use_sparse_seen_hash = 1;
1508 if ((svp = hv_fetchs(hv, "noseen", FALSE)))
1509 style.use_sparse_seen_hash = (SvOK(*svp) && SvIV(*svp) != 0);
1510 if ((svp = hv_fetchs(hv, "todump", FALSE)) && SvROK(*svp))
1511 todumpav = (AV*)SvRV(*svp);
1512 if ((svp = hv_fetchs(hv, "names", FALSE)) && SvROK(*svp))
1513 namesav = (AV*)SvRV(*svp);
1514 if ((svp = hv_fetchs(hv, "indent", FALSE)))
1515 style.indent = SvIV(*svp);
1516 if ((svp = hv_fetchs(hv, "purity", FALSE)))
1517 style.purity = SvIV(*svp);
1518 if ((svp = hv_fetchs(hv, "terse", FALSE)))
1519 terse = SvTRUE(*svp);
1520 if ((svp = hv_fetchs(hv, "useqq", FALSE)))
1521 style.useqq = SvTRUE(*svp);
1522 if ((svp = hv_fetchs(hv, "pad", FALSE)))
1523 style.pad = *svp;
1524 if ((svp = hv_fetchs(hv, "xpad", FALSE)))
1525 style.xpad = *svp;
1526 if ((svp = hv_fetchs(hv, "apad", FALSE)))
1527 apad = *svp;
1528 if ((svp = hv_fetchs(hv, "sep", FALSE)))
1529 style.sep = *svp;
1530 if ((svp = hv_fetchs(hv, "pair", FALSE)))
1531 style.pair = *svp;
1532 if ((svp = hv_fetchs(hv, "varname", FALSE)))
1533 varname = *svp;
1534 if ((svp = hv_fetchs(hv, "freezer", FALSE)))
1535 style.freezer = *svp;
1536 if ((svp = hv_fetchs(hv, "toaster", FALSE)))
1537 style.toaster = *svp;
1538 if ((svp = hv_fetchs(hv, "deepcopy", FALSE)))
1539 style.deepcopy = SvTRUE(*svp);
1540 if ((svp = hv_fetchs(hv, "quotekeys", FALSE)))
1541 style.quotekeys = SvTRUE(*svp);
1542 if ((svp = hv_fetchs(hv, "trailingcomma", FALSE)))
1543 style.trailingcomma = SvTRUE(*svp);
1544 if ((svp = hv_fetchs(hv, "deparse", FALSE)))
1545 style.deparse = SvTRUE(*svp);
1546 if ((svp = hv_fetchs(hv, "bless", FALSE)))
1547 style.bless = *svp;
1548 if ((svp = hv_fetchs(hv, "maxdepth", FALSE)))
1549 style.maxdepth = SvIV(*svp);
1550 if ((svp = hv_fetchs(hv, "maxrecurse", FALSE)))
1551 style.maxrecurse = SvIV(*svp);
1552 if ((svp = hv_fetchs(hv, "sortkeys", FALSE))) {
1553 SV *sv = *svp;
1554 if (! SvTRUE(sv))
1555 style.sortkeys = NULL;
1556 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV)
1557 style.sortkeys = sv;
1558 else
1559 /* flag to use sortsv() for sorting hash keys */
1560 style.sortkeys = &PL_sv_yes;
1561 }
1562 postav = newAV();
1563 sv_2mortal((SV*)postav);
1564
1565 if (todumpav)
1566 imax = av_len(todumpav);
1567 else
1568 imax = -1;
1569 valstr = newSVpvs_flags("", SVs_TEMP);
1570 for (i = 0; i <= imax; ++i) {
1571 SV *newapad;
1572 char *name;
1573 STRLEN name_len;
1574
1575 av_clear(postav);
1576 if ((svp = av_fetch(todumpav, i, FALSE)))
1577 val = *svp;
1578 else
1579 val = &PL_sv_undef;
1580 if ((svp = av_fetch(namesav, i, TRUE))) {
1581 if (SvOK(*svp)) {
1582 sv_setsv(name_sv, *svp);
1583 name = SvPV(name_sv, name_len);
1584 }
1585 else {
1586 name = NULL;
1587 }
1588 }
1589 else {
1590 name = NULL;
1591 }
1592
1593 if (name) {
1594 if (*name == '*') {
1595 if (SvROK(val)) {
1596 switch (SvTYPE(SvRV(val))) {
1597 case SVt_PVAV:
1598 *name = '@';
1599 break;
1600 case SVt_PVHV:
1601 *name = '%';
1602 break;
1603 case SVt_PVCV:
1604 *name = '*';
1605 break;
1606 default:
1607 *name = '$';
1608 break;
1609 }
1610 }
1611 else
1612 *name = '$';
1613 }
1614 else if (*name != '$') {
1615 sv_insert(name_sv, 0, 0, "$", 1);
1616 name = SvPV(name_sv, name_len);
1617 }
1618 }
1619 else {
1620 sv_setpvf(name_sv, "$%" SVf "%" IVdf, SVfARG(varname), (IV)(i+1));
1621 name = SvPV(name_sv, name_len);
1622 }
1623
1624 if (style.indent >= 2 && !terse) {
1625 SV * const tmpsv = sv_x(aTHX_ NULL, " ", 1, name_len + 3);
1626 newapad = sv_2mortal(newSVsv(apad));
1627 sv_catsv(newapad, tmpsv);
1628 SvREFCNT_dec(tmpsv);
1629 }
1630 else
1631 newapad = apad;
1632
1633 ENTER;
1634 SAVETMPS;
1635 PUTBACK;
1636 DD_dump(aTHX_ val, name, name_len, valstr, seenhv,
1637 postav, 0, newapad, &style);
1638 SPAGAIN;
1639 FREETMPS;
1640 LEAVE;
1641
1642 postlen = av_len(postav);
1643 if (postlen >= 0 || !terse) {
1644 sv_insert(valstr, 0, 0, " = ", 3);
1645 sv_insert(valstr, 0, 0, name, name_len);
1646 sv_catpvs(valstr, ";");
1647 }
1648 sv_catsv(retval, style.pad);
1649 sv_catsv(retval, valstr);
1650 sv_catsv(retval, style.sep);
1651 if (postlen >= 0) {
1652 SSize_t i;
1653 sv_catsv(retval, style.pad);
1654 for (i = 0; i <= postlen; ++i) {
1655 SV *elem;
1656 svp = av_fetch(postav, i, FALSE);
1657 if (svp && (elem = *svp)) {
1658 sv_catsv(retval, elem);
1659 if (i < postlen) {
1660 sv_catpvs(retval, ";");
1661 sv_catsv(retval, style.sep);
1662 sv_catsv(retval, style.pad);
1663 }
1664 }
1665 }
1666 sv_catpvs(retval, ";");
1667 sv_catsv(retval, style.sep);
1668 }
1669 SvPVCLEAR(valstr);
1670 if (gimme == G_ARRAY) {
1671 XPUSHs(retval);
1672 if (i < imax) /* not the last time thro ? */
1673 retval = newSVpvs_flags("", SVs_TEMP);
1674 }
1675 }
1676
1677 /* we defer croaking until here so that temporary SVs and
1678 * buffers won't be leaked */
1679 if (style.maxrecursed)
1680 croak("Recursion limit of %" IVdf " exceeded",
1681 style.maxrecurse);
1682
1683 }
1684 else
1685 croak("Call to new() method failed to return HASH ref");
1686 if (gimme != G_ARRAY)
1687 XPUSHs(retval);
1688 }
1689
1690 SV *
Data_Dumper__vstring(sv)1691 Data_Dumper__vstring(sv)
1692 SV *sv;
1693 PROTOTYPE: $
1694 CODE:
1695 {
1696 #ifdef SvVOK
1697 const MAGIC *mg;
1698 RETVAL =
1699 SvMAGICAL(sv) && (mg = mg_find(sv, 'V'))
1700 ? newSVpvn((const char *)mg->mg_ptr, mg->mg_len)
1701 : &PL_sv_undef;
1702 #else
1703 RETVAL = &PL_sv_undef;
1704 #endif
1705 }
1706 OUTPUT: RETVAL
1707