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