dist/Data-Dumper/Dumper.xs

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