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