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     rval = SvPV(sv_pattern, rlen);
 660     rend = rval+rlen;
 661     slash = rval;
 662     sv_catpvs(retval, "qr/");
 663
 664     for ( ; slash < rend; slash++) {
 665         if (*slash == '\\') {
 666             ++slash;
 667             continue;
 668         }
 669         if (*slash == '/') {
 670             sv_catpvn(retval, rval, slash-rval);
 671             sv_catpvs(retval, "\\/");
 672             rlen -= slash-rval+1;
 673             rval = slash+1;
 674         }
 675     }
 676
 677     sv_catpvn(retval, rval, rlen);
 678     sv_catpvs(retval, "/");
 679
 680     if (sv_flags)
 681         sv_catsv(retval, sv_flags);
 682 }
 683
 684 /*
 685  * This ought to be split into smaller functions. (it is one long function since
 686  * it exactly parallels the perl version, which was one long thing for
 687  * efficiency raisins.)  Ugggh!
 688  */
 689 static I32
 690 DD_dump(pTHX_ SV *val, const char *name, STRLEN namelen, SV *retval, HV *seenhv,
 691         AV *postav, const I32 level, SV *apad, Style *style)
 692 {
 693     char tmpbuf[128];
 694     Size_t i;
 695     char *c, *r, *realpack;
 696 #ifdef DD_USE_OLD_ID_FORMAT
 697     char id[128];
 698 #else
 699     UV id_buffer;
 700     char *const id = (char *)&id_buffer;
 701 #endif
 702     SV **svp;
 703     SV *sv, *ipad, *ival;
 704     SV *blesspad = Nullsv;
 705     AV *seenentry = NULL;
 706     char *iname;
 707     STRLEN inamelen, idlen = 0;
 708     U32 realtype;
 709     bool no_bless = 0; /* when a qr// is blessed into Regexp we dont want to bless it.
 710                           in later perls we should actually check the classname of the
 711                           engine. this gets tricky as it involves lexical issues that arent so
 712                           easy to resolve */
 713     bool is_regex = 0; /* we are dumping a regex, we need to know this before we bless */
 714
 715     if (!val)
 716         return 0;
 717
 718     if (style->maxrecursed)
 719         return 0;
 720
 721     /* If the output buffer has less than some arbitrary amount of space
 722        remaining, then enlarge it. For the test case (25M of output),
 723        *1.1 was slower, *2.0 was the same, so the first guess of 1.5 is
 724         deemed to be good enough.  */
 725     if (SvTYPE(retval) >= SVt_PV && (SvLEN(retval) - SvCUR(retval)) < 42) {
 726         sv_grow(retval, SvCUR(retval) * 3 / 2);
 727     }
 728
 729     realtype = SvTYPE(val);
 730
 731     if (SvGMAGICAL(val))
 732         mg_get(val);
 733     if (SvROK(val)) {
 734
 735         /* If a freeze method is provided and the object has it, call
 736            it.  Warn on errors. */
 737         if (SvOBJECT(SvRV(val)) && style->freezer &&
 738             SvPOK(style->freezer) && SvCUR(style->freezer) &&
 739             gv_fetchmeth(SvSTASH(SvRV(val)), SvPVX_const(style->freezer),
 740                          SvCUR(style->freezer), -1) != NULL)
 741         {
 742             dSP; ENTER; SAVETMPS; PUSHMARK(sp);
 743             XPUSHs(val); PUTBACK;
 744             i = perl_call_method(SvPVX_const(style->freezer), G_EVAL|G_VOID|G_DISCARD);
 745             SPAGAIN;
 746             if (SvTRUE(ERRSV))
 747                 warn("WARNING(Freezer method call failed): %" SVf, ERRSV);
 748             PUTBACK; FREETMPS; LEAVE;
 749         }
 750
 751         ival = SvRV(val);
 752         realtype = SvTYPE(ival);
 753 #ifdef DD_USE_OLD_ID_FORMAT
 754         idlen = my_snprintf(id, sizeof(id), "0x%" UVxf, PTR2UV(ival));
 755 #else
 756         id_buffer = PTR2UV(ival);
 757         idlen = sizeof(id_buffer);
 758 #endif
 759         if (SvOBJECT(ival))
 760             realpack = HvNAME_get(SvSTASH(ival));
 761         else
 762             realpack = NULL;
 763
 764         /* if it has a name, we need to either look it up, or keep a tab
 765          * on it so we know when we hit it later
 766          */
 767         if (namelen) {
 768             if ((svp = hv_fetch(seenhv, id, idlen, FALSE))
 769                 && (sv = *svp) && SvROK(sv) && (seenentry = (AV*)SvRV(sv)))
 770             {
 771                 SV *othername;
 772                 if ((svp = av_fetch(seenentry, 0, FALSE))
 773                     && (othername = *svp))
 774                 {
 775                     if (style->purity && level > 0) {
 776                         SV *postentry;
 777
 778                         if (realtype == SVt_PVHV)
 779                             sv_catpvs(retval, "{}");
 780                         else if (realtype == SVt_PVAV)
 781                             sv_catpvs(retval, "[]");
 782                         else
 783                             sv_catpvs(retval, "do{my $o}");
 784                         postentry = newSVpvn(name, namelen);
 785                         sv_catpvs(postentry, " = ");
 786                         sv_catsv(postentry, othername);
 787                         av_push(postav, postentry);
 788                     }
 789                     else {
 790                         if (name[0] == '@' || name[0] == '%') {
 791                             if ((SvPVX_const(othername))[0] == '\\' &&
 792                                 (SvPVX_const(othername))[1] == name[0]) {
 793                                 sv_catpvn(retval, SvPVX_const(othername)+1,
 794                                           SvCUR(othername)-1);
 795                             }
 796                             else {
 797                                 sv_catpvn(retval, name, 1);
 798                                 sv_catpvs(retval, "{");
 799                                 sv_catsv(retval, othername);
 800                                 sv_catpvs(retval, "}");
 801                             }
 802                         }
 803                         else
 804                             sv_catsv(retval, othername);
 805                     }
 806                     return 1;
 807                 }
 808                 else {
 809 #ifdef DD_USE_OLD_ID_FORMAT
 810                     warn("ref name not found for %s", id);
 811 #else
 812                     warn("ref name not found for 0x%" UVxf, PTR2UV(ival));
 813 #endif
 814                     return 0;
 815                 }
 816             }
 817             else {   /* store our name and continue */
 818                 SV *namesv;
 819                 if (name[0] == '@' || name[0] == '%') {
 820                     namesv = newSVpvs("\\");
 821                     sv_catpvn(namesv, name, namelen);
 822                 }
 823                 else if (realtype == SVt_PVCV && name[0] == '*') {
 824                     namesv = newSVpvs("\\");
 825                     sv_catpvn(namesv, name, namelen);
 826                     (SvPVX(namesv))[1] = '&';
 827                 }
 828                 else
 829                     namesv = newSVpvn(name, namelen);
 830                 seenentry = newAV();
 831                 av_push(seenentry, namesv);
 832                 (void)SvREFCNT_inc(val);
 833                 av_push(seenentry, val);
 834                 (void)hv_store(seenhv, id, idlen,
 835                                newRV_inc((SV*)seenentry), 0);
 836                 SvREFCNT_dec(seenentry);
 837             }
 838         }
 839         /* regexps dont have to be blessed into package "Regexp"
 840          * they can be blessed into any package.
 841          */
 842 #if PERL_VERSION_LT(5,8,0)
 843         if (realpack && *realpack == 'R' && strEQ(realpack, "Regexp"))
 844 #elif PERL_VERSION_LT(5,11,0)
 845         if (realpack && realtype == SVt_PVMG && mg_find(ival, PERL_MAGIC_qr))
 846 #else
 847         if (realpack && realtype == SVt_REGEXP)
 848 #endif
 849         {
 850             is_regex = 1;
 851             if (strEQ(realpack, "Regexp"))
 852                 no_bless = 1;
 853             else
 854                 no_bless = 0;
 855         }
 856
 857         /* If purity is not set and maxdepth is set, then check depth:
 858          * if we have reached maximum depth, return the string
 859          * representation of the thing we are currently examining
 860          * at this depth (i.e., 'Foo=ARRAY(0xdeadbeef)').
 861          */
 862         if (!style->purity && style->maxdepth > 0 && level >= style->maxdepth) {
 863             STRLEN vallen;
 864             const char * const valstr = SvPV(val,vallen);
 865             sv_catpvs(retval, "'");
 866             sv_catpvn(retval, valstr, vallen);
 867             sv_catpvs(retval, "'");
 868             return 1;
 869         }
 870
 871         if (style->maxrecurse > 0 && level >= style->maxrecurse) {
 872             style->maxrecursed = TRUE;
 873         }
 874
 875         if (realpack && !no_bless) {                            /* we have a blessed ref */
 876             STRLEN blesslen;
 877             const char * const blessstr = SvPV(style->bless, blesslen);
 878             sv_catpvn(retval, blessstr, blesslen);
 879             sv_catpvs(retval, "( ");
 880             if (style->indent >= 2) {
 881                 blesspad = apad;
 882                 apad = sv_2mortal(newSVsv(apad));
 883                 sv_x(aTHX_ apad, " ", 1, blesslen+2);
 884             }
 885         }
 886
 887         ipad = sv_x(aTHX_ Nullsv, SvPVX_const(style->xpad), SvCUR(style->xpad), level+1);
 888         sv_2mortal(ipad);
 889
 890         if (is_regex) {
 891             dump_regexp(aTHX_ retval, val);
 892         }
 893         else if (
 894 #if PERL_VERSION_LT(5,9,0)
 895                 realtype <= SVt_PVBM
 896 #else
 897                 realtype <= SVt_PVMG
 898 #endif
 899         ) {                          /* scalar ref */
 900             SV * const namesv = sv_2mortal(newSVpvs("${"));
 901             sv_catpvn(namesv, name, namelen);
 902             sv_catpvs(namesv, "}");
 903             if (realpack) {                                  /* blessed */
 904                 sv_catpvs(retval, "do{\\(my $o = ");
 905                 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
 906                         postav, level+1, apad, style);
 907                 sv_catpvs(retval, ")}");
 908             }                                                /* plain */
 909             else {
 910                 sv_catpvs(retval, "\\");
 911                 DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
 912                         postav, level+1, apad, style);
 913             }
 914         }
 915         else if (realtype == SVt_PVGV) {                     /* glob ref */
 916             SV * const namesv = newSVpvs("*{");
 917             sv_catpvn(namesv, name, namelen);
 918             sv_catpvs(namesv, "}");
 919             sv_catpvs(retval, "\\");
 920             DD_dump(aTHX_ ival, SvPVX_const(namesv), SvCUR(namesv), retval, seenhv,
 921                     postav, level+1, apad, style);
 922             SvREFCNT_dec(namesv);
 923         }
 924         else if (realtype == SVt_PVAV) {
 925             SV *totpad;
 926             SSize_t ix = 0;
 927             const SSize_t ixmax = av_len((AV *)ival);
 928
 929             SV * const ixsv = sv_2mortal(newSViv(0));
 930             /* allowing for a 24 char wide array index */
 931             New(0, iname, namelen+28, char);
 932             SAVEFREEPV(iname);
 933             (void) strlcpy(iname, name, namelen+28);
 934             inamelen = namelen;
 935             if (name[0] == '@') {
 936                 sv_catpvs(retval, "(");
 937                 iname[0] = '$';
 938             }
 939             else {
 940                 sv_catpvs(retval, "[");
 941                 /* omit "->" in $foo{bar}->[0], but not in ${$foo}->[0] */
 942                 /*if (namelen > 0
 943                     && name[namelen-1] != ']' && name[namelen-1] != '}'
 944                     && (namelen < 4 || (name[1] != '{' && name[2] != '{')))*/
 945                 if ((namelen > 0
 946                      && name[namelen-1] != ']' && name[namelen-1] != '}')
 947                     || (namelen > 4
 948                         && (name[1] == '{'
 949                             || (name[0] == '\\' && name[2] == '{'))))
 950                 {
 951                     iname[inamelen++] = '-'; iname[inamelen++] = '>';
 952                     iname[inamelen] = '\0';
 953                 }
 954             }
 955             if (iname[0] == '*' && iname[inamelen-1] == '}' && inamelen >= 8 &&
 956                 (instr(iname+inamelen-8, "{SCALAR}") ||
 957                  instr(iname+inamelen-7, "{ARRAY}") ||
 958                  instr(iname+inamelen-6, "{HASH}"))) {
 959                 iname[inamelen++] = '-'; iname[inamelen++] = '>';
 960             }
 961             iname[inamelen++] = '['; iname[inamelen] = '\0';
 962             totpad = sv_2mortal(newSVsv(style->sep));
 963             sv_catsv(totpad, style->pad);
 964             sv_catsv(totpad, apad);
 965
 966             for (ix = 0; ix <= ixmax; ++ix) {
 967                 STRLEN ilen;
 968                 SV *elem;
 969                 svp = av_fetch((AV*)ival, ix, FALSE);
 970                 if (svp)
 971                     elem = *svp;
 972                 else
 973                     elem = &PL_sv_undef;
 974
 975                 ilen = inamelen;
 976                 sv_setiv(ixsv, ix);
 977 #if PERL_VERSION_LT(5,10,0)
 978                 (void) sprintf(iname+ilen, "%" IVdf, (IV)ix);
 979                 ilen = strlen(iname);
 980 #else
 981                 ilen = ilen + my_sprintf(iname+ilen, "%" IVdf, (IV)ix);
 982 #endif
 983                 iname[ilen++] = ']'; iname[ilen] = '\0';
 984                 if (style->indent >= 3) {
 985                     sv_catsv(retval, totpad);
 986                     sv_catsv(retval, ipad);
 987                     sv_catpvs(retval, "#");
 988                     sv_catsv(retval, ixsv);
 989                 }
 990                 sv_catsv(retval, totpad);
 991                 sv_catsv(retval, ipad);
 992                 ENTER;
 993                 SAVETMPS;
 994                 DD_dump(aTHX_ elem, iname, ilen, retval, seenhv, postav,
 995                         level+1, apad, style);
 996                 FREETMPS;
 997                 LEAVE;
 998                 if (ix < ixmax || (style->trailingcomma && style->indent >= 1))
 999                     sv_catpvs(retval, ",");
1000             }
1001             if (ixmax >= 0) {
1002                 SV * const opad = sv_x(aTHX_ Nullsv, SvPVX_const(style->xpad), SvCUR(style->xpad), level);
1003                 sv_catsv(retval, totpad);
1004                 sv_catsv(retval, opad);
1005                 SvREFCNT_dec(opad);
1006             }
1007             if (name[0] == '@')
1008                 sv_catpvs(retval, ")");
1009             else
1010                 sv_catpvs(retval, "]");
1011         }
1012         else if (realtype == SVt_PVHV) {
1013             SV *totpad, *newapad;
1014             SV *sname;
1015             HE *entry = NULL;
1016             char *key;
1017             SV *hval;
1018             AV *keys = NULL;
1019
1020             SV * const iname = newSVpvn_flags(name, namelen, SVs_TEMP);
1021             if (name[0] == '%') {
1022                 sv_catpvs(retval, "(");
1023                 (SvPVX(iname))[0] = '$';
1024             }
1025             else {
1026                 sv_catpvs(retval, "{");
1027                 /* omit "->" in $foo[0]->{bar}, but not in ${$foo}->{bar} */
1028                 if ((namelen > 0
1029                      && name[namelen-1] != ']' && name[namelen-1] != '}')
1030                     || (namelen > 4
1031                         && (name[1] == '{'
1032                             || (name[0] == '\\' && name[2] == '{'))))
1033                 {
1034                     sv_catpvs(iname, "->");
1035                 }
1036             }
1037             if (name[0] == '*' && name[namelen-1] == '}' && namelen >= 8 &&
1038                 (instr(name+namelen-8, "{SCALAR}") ||
1039                  instr(name+namelen-7, "{ARRAY}") ||
1040                  instr(name+namelen-6, "{HASH}"))) {
1041                 sv_catpvs(iname, "->");
1042             }
1043             sv_catpvs(iname, "{");
1044             totpad = sv_2mortal(newSVsv(style->sep));
1045             sv_catsv(totpad, style->pad);
1046             sv_catsv(totpad, apad);
1047
1048             /* If requested, get a sorted/filtered array of hash keys */
1049             if (style->sortkeys) {
1050 #if PERL_VERSION_GE(5,8,0)
1051                 if (style->sortkeys == &PL_sv_yes) {
1052                     keys = newAV();
1053                     (void)hv_iterinit((HV*)ival);
1054                     while ((entry = hv_iternext((HV*)ival))) {
1055                         sv = hv_iterkeysv(entry);
1056                         (void)SvREFCNT_inc(sv);
1057                         av_push(keys, sv);
1058                     }
1059 # ifdef USE_LOCALE_COLLATE
1060 #       ifdef IN_LC     /* Use this if available */
1061                     if (IN_LC(LC_COLLATE))
1062 #       else
1063                     if (IN_LOCALE)
1064 #       endif
1065                     {
1066                         sortsv(AvARRAY(keys),
1067                            av_len(keys)+1,
1068                            Perl_sv_cmp_locale);
1069                     }
1070                     else
1071 # endif
1072                     {
1073                         sortsv(AvARRAY(keys),
1074                            av_len(keys)+1,
1075                            Perl_sv_cmp);
1076                     }
1077                 }
1078                 else
1079 #endif
1080                 {
1081                     dSP; ENTER; SAVETMPS; PUSHMARK(sp);
1082                     XPUSHs(sv_2mortal(newRV_inc(ival))); PUTBACK;
1083                     i = perl_call_sv(style->sortkeys, G_SCALAR | G_EVAL);
1084                     SPAGAIN;
1085                     if (i) {
1086                         sv = POPs;
1087                         if (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVAV))
1088                             keys = (AV*)SvREFCNT_inc(SvRV(sv));
1089                     }
1090                     if (! keys)
1091                         warn("Sortkeys subroutine did not return ARRAYREF\n");
1092                     PUTBACK; FREETMPS; LEAVE;
1093                 }
1094                 if (keys)
1095                     sv_2mortal((SV*)keys);
1096             }
1097             else
1098                 (void)hv_iterinit((HV*)ival);
1099
1100             /* foreach (keys %hash) */
1101             for (i = 0; 1; i++) {
1102                 char *nkey;
1103                 char *nkey_buffer = NULL;
1104                 STRLEN nticks = 0;
1105                 SV* keysv;
1106                 STRLEN klen;
1107                 STRLEN keylen;
1108                 STRLEN nlen;
1109                 bool do_utf8 = FALSE;
1110
1111                if (style->sortkeys) {
1112                    if (!(keys && (SSize_t)i <= av_len(keys))) break;
1113                } else {
1114                    if (!(entry = hv_iternext((HV *)ival))) break;
1115                }
1116
1117                 if (i)
1118                     sv_catpvs(retval, ",");
1119
1120                 if (style->sortkeys) {
1121                     char *key;
1122                     svp = av_fetch(keys, i, FALSE);
1123                     keysv = svp ? *svp : sv_newmortal();
1124                     key = SvPV(keysv, keylen);
1125                     svp = hv_fetch((HV*)ival, key,
1126                                    SvUTF8(keysv) ? -(I32)keylen : (I32)keylen, 0);
1127                     hval = svp ? *svp : sv_newmortal();
1128                 }
1129                 else {
1130                     keysv = hv_iterkeysv(entry);
1131                     hval = hv_iterval((HV*)ival, entry);
1132                 }
1133
1134                 key = SvPV(keysv, keylen);
1135                 do_utf8 = DO_UTF8(keysv);
1136                 klen = keylen;
1137
1138                 sv_catsv(retval, totpad);
1139                 sv_catsv(retval, ipad);
1140
1141                 ENTER;
1142                 SAVETMPS;
1143
1144                 /* The (very)
1145                    old logic was first to check utf8 flag, and if utf8 always
1146                    call esc_q_utf8.  This caused test to break under -Mutf8,
1147                    because there even strings like 'c' have utf8 flag on.
1148                    Hence with quotekeys == 0 the XS code would still '' quote
1149                    them based on flags, whereas the perl code would not,
1150                    based on regexps.
1151
1152                    The old logic checked that the string was a valid
1153                    perl glob name (foo::bar), which isn't safe under
1154                    strict, and differs from the perl code which only
1155                    accepts simple identifiers.
1156
1157                    With the fix for [perl #120384] I chose to make
1158                    their handling of key quoting compatible between XS
1159                    and perl.
1160                  */
1161                 if (style->quotekeys || key_needs_quote(key,keylen)) {
1162                     if (do_utf8 || style->useqq) {
1163                         STRLEN ocur = SvCUR(retval);
1164                         klen = nlen = esc_q_utf8(aTHX_ retval, key, klen, do_utf8, style->useqq);
1165                         nkey = SvPVX(retval) + ocur;
1166                     }
1167                     else {
1168                         nticks = num_q(key, klen);
1169                         New(0, nkey_buffer, klen+nticks+3, char);
1170                         SAVEFREEPV(nkey_buffer);
1171                         nkey = nkey_buffer;
1172                         nkey[0] = '\'';
1173                         if (nticks)
1174                             klen += esc_q(nkey+1, key, klen);
1175                         else
1176                             (void)Copy(key, nkey+1, klen, char);
1177                         nkey[++klen] = '\'';
1178                         nkey[++klen] = '\0';
1179                         nlen = klen;
1180                         sv_catpvn(retval, nkey, klen);
1181                     }
1182                 }
1183                 else {
1184                     nkey = key;
1185                     nlen = klen;
1186                     sv_catpvn(retval, nkey, klen);
1187                 }
1188
1189                 sname = sv_2mortal(newSVsv(iname));
1190                 sv_catpvn(sname, nkey, nlen);
1191                 sv_catpvs(sname, "}");
1192
1193                 sv_catsv(retval, style->pair);
1194                 if (style->indent >= 2) {
1195                     char *extra;
1196                     STRLEN elen = 0;
1197                     newapad = sv_2mortal(newSVsv(apad));
1198                     New(0, extra, klen+4+1, char);
1199                     while (elen < (klen+4))
1200                         extra[elen++] = ' ';
1201                     extra[elen] = '\0';
1202                     sv_catpvn(newapad, extra, elen);
1203                     Safefree(extra);
1204                 }
1205                 else
1206                     newapad = apad;
1207
1208                 DD_dump(aTHX_ hval, SvPVX_const(sname), SvCUR(sname), retval, seenhv,
1209                         postav, level+1, newapad, style);
1210
1211                 FREETMPS;
1212                 LEAVE;
1213             }
1214             if (i) {
1215                 SV *opad = sv_x(aTHX_ Nullsv, SvPVX_const(style->xpad),
1216                                 SvCUR(style->xpad), level);
1217                 if (style->trailingcomma && style->indent >= 1)
1218                     sv_catpvs(retval, ",");
1219                 sv_catsv(retval, totpad);
1220                 sv_catsv(retval, opad);
1221                 SvREFCNT_dec(opad);
1222             }
1223             if (name[0] == '%')
1224                 sv_catpvs(retval, ")");
1225             else
1226                 sv_catpvs(retval, "}");
1227         }
1228         else if (realtype == SVt_PVCV) {
1229             if (style->deparse) {
1230                 SV *deparsed = sv_2mortal(deparsed_output(aTHX_ val));
1231                 SV *fullpad = sv_2mortal(newSVsv(style->sep));
1232                 const char *p;
1233                 STRLEN plen;
1234                 I32 i;
1235
1236                 sv_catsv(fullpad, style->pad);
1237                 sv_catsv(fullpad, apad);
1238                 for (i = 0; i < level; i++) {
1239                     sv_catsv(fullpad, style->xpad);
1240                 }
1241
1242                 sv_catpvs(retval, "sub ");
1243                 p = SvPV(deparsed, plen);
1244                 while (plen > 0) {
1245                     const char *nl = (const char *) memchr(p, '\n', plen);
1246                     if (!nl) {
1247                         sv_catpvn(retval, p, plen);
1248                         break;
1249                     }
1250                     else {
1251                         size_t n = nl - p;
1252                         sv_catpvn(retval, p, n);
1253                         sv_catsv(retval, fullpad);
1254                         p += n + 1;
1255                         plen -= n + 1;
1256                     }
1257                 }
1258             }
1259             else {
1260                 sv_catpvs(retval, "sub { \"DUMMY\" }");
1261                 if (style->purity)
1262                     warn("Encountered CODE ref, using dummy placeholder");
1263             }
1264         }
1265         else {
1266             warn("cannot handle ref type %d", (int)realtype);
1267         }
1268
1269         if (realpack && !no_bless) {  /* free blessed allocs */
1270             STRLEN plen, pticks;
1271
1272             if (style->indent >= 2) {
1273                 apad = blesspad;
1274             }
1275             sv_catpvs(retval, ", '");
1276
1277             plen = strlen(realpack);
1278             pticks = num_q(realpack, plen);
1279             if (pticks) { /* needs escaping */
1280                 char *npack;
1281                 char *npack_buffer = NULL;
1282
1283                 New(0, npack_buffer, plen+pticks+1, char);
1284                 npack = npack_buffer;
1285                 plen += esc_q(npack, realpack, plen);
1286                 npack[plen] = '\0';
1287
1288                 sv_catpvn(retval, npack, plen);
1289                 Safefree(npack_buffer);
1290             }
1291             else {
1292                 sv_catpvn(retval, realpack, strlen(realpack));
1293             }
1294             sv_catpvs(retval, "' )");
1295             if (style->toaster && SvPOK(style->toaster) && SvCUR(style->toaster)) {
1296                 sv_catpvs(retval, "->");
1297                 sv_catsv(retval, style->toaster);
1298                 sv_catpvs(retval, "()");
1299             }
1300         }
1301     }
1302     else {
1303         STRLEN i;
1304         const MAGIC *mg;
1305
1306         if (namelen) {
1307 #ifdef DD_USE_OLD_ID_FORMAT
1308             idlen = my_snprintf(id, sizeof(id), "0x%" UVxf, PTR2UV(val));
1309 #else
1310             id_buffer = PTR2UV(val);
1311             idlen = sizeof(id_buffer);
1312 #endif
1313             if ((svp = hv_fetch(seenhv, id, idlen, FALSE)) &&
1314                 (sv = *svp) && SvROK(sv) &&
1315                 (seenentry = (AV*)SvRV(sv)))
1316             {
1317                 SV *othername;
1318                 if ((svp = av_fetch(seenentry, 0, FALSE)) && (othername = *svp)
1319                     && (svp = av_fetch(seenentry, 2, FALSE)) && *svp && SvIV(*svp) > 0)
1320                 {
1321                     sv_catpvs(retval, "${");
1322                     sv_catsv(retval, othername);
1323                     sv_catpvs(retval, "}");
1324                     return 1;
1325                 }
1326             }
1327             /* If we're allowed to keep only a sparse "seen" hash
1328              * (IOW, the user does not expect it to contain everything
1329              * after the dump, then only store in seen hash if the SV
1330              * ref count is larger than 1. If it's 1, then we know that
1331              * there is no other reference, duh. This is an optimization.
1332              * Note that we'd have to check for weak-refs, too, but this is
1333              * already the branch for non-refs only. */
1334             else if (val != &PL_sv_undef && (!style->use_sparse_seen_hash || SvREFCNT(val) > 1)) {
1335                 SV * const namesv = newSVpvs("\\");
1336                 sv_catpvn(namesv, name, namelen);
1337                 seenentry = newAV();
1338                 av_push(seenentry, namesv);
1339                 av_push(seenentry, newRV_inc(val));
1340                 (void)hv_store(seenhv, id, idlen, newRV_inc((SV*)seenentry), 0);
1341                 SvREFCNT_dec(seenentry);
1342             }
1343         }
1344
1345         if (DD_is_integer(val)) {
1346             STRLEN len;
1347             if (SvIsUV(val))
1348               len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%" UVuf, SvUV(val));
1349             else
1350               len = my_snprintf(tmpbuf, sizeof(tmpbuf), "%" IVdf, SvIV(val));
1351             if (SvPOK(val)) {
1352               /* Need to check to see if this is a string such as " 0".
1353                  I'm assuming from sprintf isn't going to clash with utf8. */
1354               STRLEN pvlen;
1355               const char * const pv = SvPV(val, pvlen);
1356               if (pvlen != len || memNE(pv, tmpbuf, len))
1357                 goto integer_came_from_string;
1358             }
1359             if (len > 10) {
1360               /* Looks like we're on a 64 bit system.  Make it a string so that
1361                  if a 32 bit system reads the number it will cope better.  */
1362               sv_catpvf(retval, "'%s'", tmpbuf);
1363             } else
1364               sv_catpvn(retval, tmpbuf, len);
1365         }
1366         else if (realtype == SVt_PVGV) {/* GLOBs can end up with scribbly names */
1367             c = SvPV(val, i);
1368             if(i) ++c, --i;                     /* just get the name */
1369             if (memBEGINs(c, i, "main::")) {
1370                 c += 4;
1371 #if PERL_VERSION_LT(5,7,0)
1372                 if (i == 6 || (i == 7 && c[6] == '\0'))
1373 #else
1374                 if (i == 6)
1375 #endif
1376                     i = 0; else i -= 4;
1377             }
1378             if (globname_needs_quote(c,i)) {
1379                 sv_grow(retval, SvCUR(retval)+3);
1380                 r = SvPVX(retval)+SvCUR(retval);
1381                 r[0] = '*'; r[1] = '{'; r[2] = 0;
1382                 SvCUR_set(retval, SvCUR(retval)+2);
1383                 i = 3 + esc_q_utf8(aTHX_ retval, c, i,
1384 #ifdef GvNAMEUTF8
1385                         !!GvNAMEUTF8(val), style->useqq
1386 #else
1387                         0, style->useqq || globname_supra_ascii(c, i)
1388 #endif
1389                         );
1390                 sv_grow(retval, SvCUR(retval)+2);
1391                 r = SvPVX(retval)+SvCUR(retval);
1392                 r[0] = '}'; r[1] = '\0';
1393                 SvCUR_set(retval, SvCUR(retval)+1);
1394                 r = r+1 - i;
1395             }
1396             else {
1397                 sv_grow(retval, SvCUR(retval)+i+2);
1398                 r = SvPVX(retval)+SvCUR(retval);
1399                 r[0] = '*'; strlcpy(r+1, c, SvLEN(retval));
1400                 i++;
1401                 SvCUR_set(retval, SvCUR(retval)+i);
1402             }
1403
1404             if (style->purity) {
1405                 static const char* const entries[] = { "{SCALAR}", "{ARRAY}", "{HASH}" };
1406                 static const STRLEN sizes[] = { 8, 7, 6 };
1407                 SV *e;
1408                 SV * const nname = newSVpvs("");
1409                 SV * const newapad = newSVpvs("");
1410                 GV * const gv = (GV*)val;
1411                 I32 j;
1412
1413                 for (j=0; j<3; j++) {
1414                     e = ((j == 0) ? GvSV(gv) : (j == 1) ? (SV*)GvAV(gv) : (SV*)GvHV(gv));
1415                     if (!e)
1416                         continue;
1417                     if (j == 0 && !SvOK(e))
1418                         continue;
1419
1420                     {
1421                         SV *postentry = newSVpvn(r,i);
1422
1423                         sv_setsv(nname, postentry);
1424                         sv_catpvn(nname, entries[j], sizes[j]);
1425                         sv_catpvs(postentry, " = ");
1426                         av_push(postav, postentry);
1427                         e = newRV_inc(e);
1428
1429                         SvCUR_set(newapad, 0);
1430                         if (style->indent >= 2)
1431                             (void)sv_x(aTHX_ newapad, " ", 1, SvCUR(postentry));
1432
1433                         DD_dump(aTHX_ e, SvPVX_const(nname), SvCUR(nname), postentry,
1434                                 seenhv, postav, 0, newapad, style);
1435                         SvREFCNT_dec(e);
1436                     }
1437                 }
1438
1439                 SvREFCNT_dec(newapad);
1440                 SvREFCNT_dec(nname);
1441             }
1442         }
1443         else if (val == &PL_sv_undef || !SvOK(val)) {
1444             sv_catpvs(retval, "undef");
1445         }
1446 #ifdef SvVOK
1447         else if (SvMAGICAL(val) && (mg = mg_find(val, 'V'))) {
1448 # if !defined(PL_vtbl_vstring) && PERL_VERSION_LT(5,17,0)
1449             SV * const vecsv = sv_newmortal();
1450 #  if PERL_VERSION_LT(5,10,0)
1451             scan_vstring(mg->mg_ptr, vecsv);
1452 #  else
1453             scan_vstring(mg->mg_ptr, mg->mg_ptr + mg->mg_len, vecsv);
1454 #  endif
1455             if (!sv_eq(vecsv, val)) goto integer_came_from_string;
1456 # endif
1457             sv_catpvn(retval, (const char *)mg->mg_ptr, mg->mg_len);
1458         }
1459 #endif
1460
1461         else {
1462         integer_came_from_string:
1463             c = SvPV(val, i);
1464             /* the pure perl and XS non-qq outputs have historically been
1465              * different in this case, but for useqq, let's try to match
1466              * the pure perl code.
1467              * see [perl #74798]
1468              */
1469             if (style->useqq && safe_decimal_number(c, i)) {
1470                 sv_catsv(retval, val);
1471             }
1472             else if (DO_UTF8(val) || style->useqq)
1473                 i += esc_q_utf8(aTHX_ retval, c, i, DO_UTF8(val), style->useqq);
1474             else {
1475                 sv_grow(retval, SvCUR(retval)+3+2*i); /* 3: ""\0 */
1476                 r = SvPVX(retval) + SvCUR(retval);
1477                 r[0] = '\'';
1478                 i += esc_q(r+1, c, i);
1479                 ++i;
1480                 r[i++] = '\'';
1481                 r[i] = '\0';
1482                 SvCUR_set(retval, SvCUR(retval)+i);
1483             }
1484         }
1485     }
1486
1487     if (idlen) {
1488         if (style->deepcopy)
1489             (void)hv_delete(seenhv, id, idlen, G_DISCARD);
1490         else if (namelen && seenentry) {
1491             SV *mark = *av_fetch(seenentry, 2, TRUE);
1492             sv_setiv(mark,1);
1493         }
1494     }
1495     return 1;
1496 }
1497
1498
1499 MODULE = Data::Dumper           PACKAGE = Data::Dumper         PREFIX = Data_Dumper_
1500
1501 #
1502 # This is the exact equivalent of Dump.  Well, almost. The things that are
1503 # different as of now (due to Laziness):
1504 #   * doesn't do deparse yet.'
1505 #
1506
1507 void
1508 Data_Dumper_Dumpxs(href, ...)
1509         SV      *href;
1510         PROTOTYPE: $;$$
1511         PPCODE:
1512         {
1513             HV *hv;
1514             SV *retval, *valstr;
1515             HV *seenhv = NULL;
1516             AV *postav, *todumpav, *namesav;
1517             I32 terse = 0;
1518             SSize_t i, imax, postlen;
1519             SV **svp;
1520             SV *apad = &PL_sv_undef;
1521             Style style;
1522
1523             SV *name, *val = &PL_sv_undef, *varname = &PL_sv_undef;
1524             char tmpbuf[1024];
1525             I32 gimme = GIMME_V;
1526
1527             if (!SvROK(href)) {         /* call new to get an object first */
1528                 if (items < 2)
1529                     croak("Usage: Data::Dumper::Dumpxs(PACKAGE, VAL_ARY_REF, [NAME_ARY_REF])");
1530
1531                 ENTER;
1532                 SAVETMPS;
1533
1534                 PUSHMARK(sp);
1535                 EXTEND(SP, 3); /* 3 == max of all branches below */
1536                 PUSHs(href);
1537                 PUSHs(sv_2mortal(newSVsv(ST(1))));
1538                 if (items >= 3)
1539                     PUSHs(sv_2mortal(newSVsv(ST(2))));
1540                 PUTBACK;
1541                 i = perl_call_method("new", G_SCALAR);
1542                 SPAGAIN;
1543                 if (i)
1544                     href = newSVsv(POPs);
1545
1546                 PUTBACK;
1547                 FREETMPS;
1548                 LEAVE;
1549                 if (i)
1550                     (void)sv_2mortal(href);
1551             }
1552
1553             todumpav = namesav = NULL;
1554             style.indent = 2;
1555             style.quotekeys = 1;
1556             style.maxrecurse = 1000;
1557             style.maxrecursed = FALSE;
1558             style.purity = style.deepcopy = style.useqq = style.maxdepth
1559                 = style.use_sparse_seen_hash = style.trailingcomma = 0;
1560             style.pad = style.xpad = style.sep = style.pair = style.sortkeys
1561                 = style.freezer = style.toaster = style.bless = &PL_sv_undef;
1562             seenhv = NULL;
1563             name = sv_newmortal();
1564
1565             retval = newSVpvs_flags("", SVs_TEMP);
1566             if (SvROK(href)
1567                 && (hv = (HV*)SvRV((SV*)href))
1568                 && SvTYPE(hv) == SVt_PVHV)              {
1569
1570                 if ((svp = hv_fetchs(hv, "seen", FALSE)) && SvROK(*svp))
1571                     seenhv = (HV*)SvRV(*svp);
1572                 else
1573                     style.use_sparse_seen_hash = 1;
1574                 if ((svp = hv_fetchs(hv, "noseen", FALSE)))
1575                     style.use_sparse_seen_hash = (SvOK(*svp) && SvIV(*svp) != 0);
1576                 if ((svp = hv_fetchs(hv, "todump", FALSE)) && SvROK(*svp))
1577                     todumpav = (AV*)SvRV(*svp);
1578                 if ((svp = hv_fetchs(hv, "names", FALSE)) && SvROK(*svp))
1579                     namesav = (AV*)SvRV(*svp);
1580                 if ((svp = hv_fetchs(hv, "indent", FALSE)))
1581                     style.indent = SvIV(*svp);
1582                 if ((svp = hv_fetchs(hv, "purity", FALSE)))
1583                     style.purity = SvIV(*svp);
1584                 if ((svp = hv_fetchs(hv, "terse", FALSE)))
1585                     terse = SvTRUE(*svp);
1586                 if ((svp = hv_fetchs(hv, "useqq", FALSE)))
1587                     style.useqq = SvTRUE(*svp);
1588                 if ((svp = hv_fetchs(hv, "pad", FALSE)))
1589                     style.pad = *svp;
1590                 if ((svp = hv_fetchs(hv, "xpad", FALSE)))
1591                     style.xpad = *svp;
1592                 if ((svp = hv_fetchs(hv, "apad", FALSE)))
1593                     apad = *svp;
1594                 if ((svp = hv_fetchs(hv, "sep", FALSE)))
1595                     style.sep = *svp;
1596                 if ((svp = hv_fetchs(hv, "pair", FALSE)))
1597                     style.pair = *svp;
1598                 if ((svp = hv_fetchs(hv, "varname", FALSE)))
1599                     varname = *svp;
1600                 if ((svp = hv_fetchs(hv, "freezer", FALSE)))
1601                     style.freezer = *svp;
1602                 if ((svp = hv_fetchs(hv, "toaster", FALSE)))
1603                     style.toaster = *svp;
1604                 if ((svp = hv_fetchs(hv, "deepcopy", FALSE)))
1605                     style.deepcopy = SvTRUE(*svp);
1606                 if ((svp = hv_fetchs(hv, "quotekeys", FALSE)))
1607                     style.quotekeys = SvTRUE(*svp);
1608                 if ((svp = hv_fetchs(hv, "trailingcomma", FALSE)))
1609                     style.trailingcomma = SvTRUE(*svp);
1610                 if ((svp = hv_fetchs(hv, "deparse", FALSE)))
1611                     style.deparse = SvTRUE(*svp);
1612                 if ((svp = hv_fetchs(hv, "bless", FALSE)))
1613                     style.bless = *svp;
1614                 if ((svp = hv_fetchs(hv, "maxdepth", FALSE)))
1615                     style.maxdepth = SvIV(*svp);
1616                 if ((svp = hv_fetchs(hv, "maxrecurse", FALSE)))
1617                     style.maxrecurse = SvIV(*svp);
1618                 if ((svp = hv_fetchs(hv, "sortkeys", FALSE))) {
1619                     SV *sv = *svp;
1620                     if (! SvTRUE(sv))
1621                         style.sortkeys = NULL;
1622                     else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV)
1623                         style.sortkeys = sv;
1624                     else
1625 #if PERL_VERSION_LT(5,8,0)
1626                         /* 5.6 doesn't make sortsv() available to XS code,
1627                          * so we must use this helper instead. Note that we
1628                          * always allocate this mortal SV, but it will be
1629                          * used only if at least one hash is encountered
1630                          * while dumping recursively; an older version
1631                          * allocated it lazily as needed. */
1632                         style.sortkeys = sv_2mortal(newSVpvs("Data::Dumper::_sortkeys"));
1633 #else
1634                         /* flag to use sortsv() for sorting hash keys */
1635                         style.sortkeys = &PL_sv_yes;
1636 #endif
1637                 }
1638                 postav = newAV();
1639                 sv_2mortal((SV*)postav);
1640
1641                 if (todumpav)
1642                     imax = av_len(todumpav);
1643                 else
1644                     imax = -1;
1645                 valstr = newSVpvs_flags("", SVs_TEMP);
1646                 for (i = 0; i <= imax; ++i) {
1647                     SV *newapad;
1648
1649                     av_clear(postav);
1650                     if ((svp = av_fetch(todumpav, i, FALSE)))
1651                         val = *svp;
1652                     else
1653                         val = &PL_sv_undef;
1654                     if ((svp = av_fetch(namesav, i, TRUE))) {
1655                         sv_setsv(name, *svp);
1656                         if (SvOK(*svp) && !SvPOK(*svp))
1657                             (void)SvPV_nolen_const(name);
1658                     }
1659                     else
1660                         (void)SvOK_off(name);
1661
1662                     if (SvPOK(name)) {
1663                         if ((SvPVX_const(name))[0] == '*') {
1664                             if (SvROK(val)) {
1665                                 switch (SvTYPE(SvRV(val))) {
1666                                 case SVt_PVAV:
1667                                     (SvPVX(name))[0] = '@';
1668                                     break;
1669                                 case SVt_PVHV:
1670                                     (SvPVX(name))[0] = '%';
1671                                     break;
1672                                 case SVt_PVCV:
1673                                     (SvPVX(name))[0] = '*';
1674                                     break;
1675                                 default:
1676                                     (SvPVX(name))[0] = '$';
1677                                     break;
1678                                 }
1679                             }
1680                             else
1681                                 (SvPVX(name))[0] = '$';
1682                         }
1683                         else if ((SvPVX_const(name))[0] != '$')
1684                             sv_insert(name, 0, 0, "$", 1);
1685                     }
1686                     else {
1687                         STRLEN nchars;
1688                         sv_setpvs(name, "$");
1689                         sv_catsv(name, varname);
1690                         nchars = my_snprintf(tmpbuf, sizeof(tmpbuf), "%" IVdf,
1691                                                                      (IV)(i+1));
1692                         sv_catpvn(name, tmpbuf, nchars);
1693                     }
1694
1695                     if (style.indent >= 2 && !terse) {
1696                         SV * const tmpsv = sv_x(aTHX_ NULL, " ", 1, SvCUR(name)+3);
1697                         newapad = sv_2mortal(newSVsv(apad));
1698                         sv_catsv(newapad, tmpsv);
1699                         SvREFCNT_dec(tmpsv);
1700                     }
1701                     else
1702                         newapad = apad;
1703
1704                     ENTER;
1705                     SAVETMPS;
1706                     PUTBACK;
1707                     DD_dump(aTHX_ val, SvPVX_const(name), SvCUR(name), valstr, seenhv,
1708                             postav, 0, newapad, &style);
1709                     SPAGAIN;
1710                     FREETMPS;
1711                     LEAVE;
1712
1713                     postlen = av_len(postav);
1714                     if (postlen >= 0 || !terse) {
1715                         sv_insert(valstr, 0, 0, " = ", 3);
1716                         sv_insert(valstr, 0, 0, SvPVX_const(name), SvCUR(name));
1717                         sv_catpvs(valstr, ";");
1718                     }
1719                     sv_catsv(retval, style.pad);
1720                     sv_catsv(retval, valstr);
1721                     sv_catsv(retval, style.sep);
1722                     if (postlen >= 0) {
1723                         SSize_t i;
1724                         sv_catsv(retval, style.pad);
1725                         for (i = 0; i <= postlen; ++i) {
1726                             SV *elem;
1727                             svp = av_fetch(postav, i, FALSE);
1728                             if (svp && (elem = *svp)) {
1729                                 sv_catsv(retval, elem);
1730                                 if (i < postlen) {
1731                                     sv_catpvs(retval, ";");
1732                                     sv_catsv(retval, style.sep);
1733                                     sv_catsv(retval, style.pad);
1734                                 }
1735                             }
1736                         }
1737                         sv_catpvs(retval, ";");
1738                         sv_catsv(retval, style.sep);
1739                     }
1740                     SvPVCLEAR(valstr);
1741                     if (gimme == G_ARRAY) {
1742                         XPUSHs(retval);
1743                         if (i < imax)   /* not the last time thro ? */
1744                             retval = newSVpvs_flags("", SVs_TEMP);
1745                     }
1746                 }
1747
1748                 /* we defer croaking until here so that temporary SVs and
1749                  * buffers won't be leaked */
1750                 if (style.maxrecursed)
1751                     croak("Recursion limit of %" IVdf " exceeded",
1752                             style.maxrecurse);
1753
1754             }
1755             else
1756                 croak("Call to new() method failed to return HASH ref");
1757             if (gimme != G_ARRAY)
1758                 XPUSHs(retval);
1759         }
1760
1761 SV *
1762 Data_Dumper__vstring(sv)
1763         SV      *sv;
1764         PROTOTYPE: $
1765         CODE:
1766         {
1767 #ifdef SvVOK
1768             const MAGIC *mg;
1769             RETVAL =
1770                 SvMAGICAL(sv) && (mg = mg_find(sv, 'V'))
1771                  ? newSVpvn((const char *)mg->mg_ptr, mg->mg_len)
1772                  : &PL_sv_undef;
1773 #else
1774             RETVAL = &PL_sv_undef;
1775 #endif
1776         }
1777         OUTPUT: RETVAL