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