1 /* dump.c 2 * 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others 5 * 6 * You may distribute under the terms of either the GNU General Public 7 * License or the Artistic License, as specified in the README file. 8 * 9 */ 10 11 /* 12 * 'You have talked long in your sleep, Frodo,' said Gandalf gently, 'and 13 * it has not been hard for me to read your mind and memory.' 14 * 15 * [p.220 of _The Lord of the Rings_, II/i: "Many Meetings"] 16 */ 17 18 /* This file contains utility routines to dump the contents of SV and OP 19 * structures, as used by command-line options like -Dt and -Dx, and 20 * by Devel::Peek. 21 * 22 * It also holds the debugging version of the runops function. 23 24 =head1 Display and Dump functions 25 */ 26 27 #include "EXTERN.h" 28 #define PERL_IN_DUMP_C 29 #include "perl.h" 30 #include "regcomp.h" 31 32 static const char* const svtypenames[SVt_LAST] = { 33 "NULL", 34 "IV", 35 "NV", 36 "PV", 37 "INVLIST", 38 "PVIV", 39 "PVNV", 40 "PVMG", 41 "REGEXP", 42 "PVGV", 43 "PVLV", 44 "PVAV", 45 "PVHV", 46 "PVCV", 47 "PVFM", 48 "PVIO" 49 }; 50 51 52 static const char* const svshorttypenames[SVt_LAST] = { 53 "UNDEF", 54 "IV", 55 "NV", 56 "PV", 57 "INVLST", 58 "PVIV", 59 "PVNV", 60 "PVMG", 61 "REGEXP", 62 "GV", 63 "PVLV", 64 "AV", 65 "HV", 66 "CV", 67 "FM", 68 "IO" 69 }; 70 71 struct flag_to_name { 72 U32 flag; 73 const char *name; 74 }; 75 76 static void 77 S_append_flags(pTHX_ SV *sv, U32 flags, const struct flag_to_name *start, 78 const struct flag_to_name *const end) 79 { 80 do { 81 if (flags & start->flag) 82 sv_catpv(sv, start->name); 83 } while (++start < end); 84 } 85 86 #define append_flags(sv, f, flags) \ 87 S_append_flags(aTHX_ (sv), (f), (flags), C_ARRAY_END(flags)) 88 89 #define generic_pv_escape(sv,s,len,utf8) pv_escape( (sv), (s), (len), \ 90 (len) * (4+UTF8_MAXBYTES) + 1, NULL, \ 91 PERL_PV_ESCAPE_NONASCII | PERL_PV_ESCAPE_DWIM \ 92 | ((utf8) ? PERL_PV_ESCAPE_UNI : 0) ) 93 94 /* 95 =for apidoc pv_escape 96 97 Escapes at most the first C<count> chars of C<pv> and puts the results into 98 C<dsv> such that the size of the escaped string will not exceed C<max> chars 99 and will not contain any incomplete escape sequences. The number of bytes 100 escaped will be returned in the C<STRLEN *escaped> parameter if it is not null. 101 When the C<dsv> parameter is null no escaping actually occurs, but the number 102 of bytes that would be escaped were it not null will be calculated. 103 104 If flags contains C<PERL_PV_ESCAPE_QUOTE> then any double quotes in the string 105 will also be escaped. 106 107 Normally the SV will be cleared before the escaped string is prepared, 108 but when C<PERL_PV_ESCAPE_NOCLEAR> is set this will not occur. 109 110 If C<PERL_PV_ESCAPE_UNI> is set then the input string is treated as UTF-8 111 if C<PERL_PV_ESCAPE_UNI_DETECT> is set then the input string is scanned 112 using C<is_utf8_string()> to determine if it is UTF-8. 113 114 If C<PERL_PV_ESCAPE_ALL> is set then all input chars will be output 115 using C<\x01F1> style escapes, otherwise if C<PERL_PV_ESCAPE_NONASCII> is set, only 116 non-ASCII chars will be escaped using this style; otherwise, only chars above 117 255 will be so escaped; other non printable chars will use octal or 118 common escaped patterns like C<\n>. 119 Otherwise, if C<PERL_PV_ESCAPE_NOBACKSLASH> 120 then all chars below 255 will be treated as printable and 121 will be output as literals. 122 123 If C<PERL_PV_ESCAPE_FIRSTCHAR> is set then only the first char of the 124 string will be escaped, regardless of max. If the output is to be in hex, 125 then it will be returned as a plain hex 126 sequence. Thus the output will either be a single char, 127 an octal escape sequence, a special escape like C<\n> or a hex value. 128 129 If C<PERL_PV_ESCAPE_RE> is set then the escape char used will be a C<"%"> and 130 not a C<"\\">. This is because regexes very often contain backslashed 131 sequences, whereas C<"%"> is not a particularly common character in patterns. 132 133 Returns a pointer to the escaped text as held by C<dsv>. 134 135 =cut 136 */ 137 #define PV_ESCAPE_OCTBUFSIZE 32 138 139 char * 140 Perl_pv_escape( pTHX_ SV *dsv, char const * const str, 141 const STRLEN count, const STRLEN max, 142 STRLEN * const escaped, const U32 flags ) 143 { 144 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\'; 145 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc; 146 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF"; 147 STRLEN wrote = 0; /* chars written so far */ 148 STRLEN chsize = 0; /* size of data to be written */ 149 STRLEN readsize = 1; /* size of data just read */ 150 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this UTF-8 */ 151 const char *pv = str; 152 const char * const end = pv + count; /* end of string */ 153 octbuf[0] = esc; 154 155 PERL_ARGS_ASSERT_PV_ESCAPE; 156 157 if (dsv && !(flags & PERL_PV_ESCAPE_NOCLEAR)) { 158 /* This won't alter the UTF-8 flag */ 159 sv_setpvs(dsv, ""); 160 } 161 162 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count)) 163 isuni = 1; 164 165 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) { 166 const UV u= (isuni) ? utf8_to_uvchr_buf((U8*)pv, (U8*) end, &readsize) : (U8)*pv; 167 const U8 c = (U8)u & 0xFF; 168 169 if ( ( u > 255 ) 170 || (flags & PERL_PV_ESCAPE_ALL) 171 || (( ! isASCII(u) ) && (flags & (PERL_PV_ESCAPE_NONASCII|PERL_PV_ESCAPE_DWIM)))) 172 { 173 if (flags & PERL_PV_ESCAPE_FIRSTCHAR) 174 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, 175 "%"UVxf, u); 176 else 177 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, 178 ((flags & PERL_PV_ESCAPE_DWIM) && !isuni) 179 ? "%cx%02"UVxf 180 : "%cx{%02"UVxf"}", esc, u); 181 182 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) { 183 chsize = 1; 184 } else { 185 if ( (c == dq) || (c == esc) || !isPRINT(c) ) { 186 chsize = 2; 187 switch (c) { 188 189 case '\\' : /* FALLTHROUGH */ 190 case '%' : if ( c == esc ) { 191 octbuf[1] = esc; 192 } else { 193 chsize = 1; 194 } 195 break; 196 case '\v' : octbuf[1] = 'v'; break; 197 case '\t' : octbuf[1] = 't'; break; 198 case '\r' : octbuf[1] = 'r'; break; 199 case '\n' : octbuf[1] = 'n'; break; 200 case '\f' : octbuf[1] = 'f'; break; 201 case '"' : 202 if ( dq == '"' ) 203 octbuf[1] = '"'; 204 else 205 chsize = 1; 206 break; 207 default: 208 if ( (flags & PERL_PV_ESCAPE_DWIM) && c != '\0' ) { 209 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, 210 isuni ? "%cx{%02"UVxf"}" : "%cx%02"UVxf, 211 esc, u); 212 } 213 else if ( (pv+readsize < end) && isDIGIT((U8)*(pv+readsize)) ) 214 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, 215 "%c%03o", esc, c); 216 else 217 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, 218 "%c%o", esc, c); 219 } 220 } else { 221 chsize = 1; 222 } 223 } 224 if ( max && (wrote + chsize > max) ) { 225 break; 226 } else if (chsize > 1) { 227 if (dsv) 228 sv_catpvn(dsv, octbuf, chsize); 229 wrote += chsize; 230 } else { 231 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then non-ASCII bytes 232 can be appended raw to the dsv. If dsv happens to be 233 UTF-8 then we need catpvf to upgrade them for us. 234 Or add a new API call sv_catpvc(). Think about that name, and 235 how to keep it clear that it's unlike the s of catpvs, which is 236 really an array of octets, not a string. */ 237 if (dsv) 238 Perl_sv_catpvf( aTHX_ dsv, "%c", c); 239 wrote++; 240 } 241 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR ) 242 break; 243 } 244 if (escaped != NULL) 245 *escaped= pv - str; 246 return dsv ? SvPVX(dsv) : NULL; 247 } 248 /* 249 =for apidoc pv_pretty 250 251 Converts a string into something presentable, handling escaping via 252 C<pv_escape()> and supporting quoting and ellipses. 253 254 If the C<PERL_PV_PRETTY_QUOTE> flag is set then the result will be 255 double quoted with any double quotes in the string escaped. Otherwise 256 if the C<PERL_PV_PRETTY_LTGT> flag is set then the result be wrapped in 257 angle brackets. 258 259 If the C<PERL_PV_PRETTY_ELLIPSES> flag is set and not all characters in 260 string were output then an ellipsis C<...> will be appended to the 261 string. Note that this happens AFTER it has been quoted. 262 263 If C<start_color> is non-null then it will be inserted after the opening 264 quote (if there is one) but before the escaped text. If C<end_color> 265 is non-null then it will be inserted after the escaped text but before 266 any quotes or ellipses. 267 268 Returns a pointer to the prettified text as held by C<dsv>. 269 270 =cut 271 */ 272 273 char * 274 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count, 275 const STRLEN max, char const * const start_color, char const * const end_color, 276 const U32 flags ) 277 { 278 const U8 *quotes = (U8*)((flags & PERL_PV_PRETTY_QUOTE) ? "\"\"" : 279 (flags & PERL_PV_PRETTY_LTGT) ? "<>" : NULL); 280 STRLEN escaped; 281 STRLEN max_adjust= 0; 282 STRLEN orig_cur; 283 284 PERL_ARGS_ASSERT_PV_PRETTY; 285 286 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) { 287 /* This won't alter the UTF-8 flag */ 288 sv_setpvs(dsv, ""); 289 } 290 orig_cur= SvCUR(dsv); 291 292 if ( quotes ) 293 Perl_sv_catpvf(aTHX_ dsv, "%c", quotes[0]); 294 295 if ( start_color != NULL ) 296 sv_catpv(dsv, start_color); 297 298 if ((flags & PERL_PV_PRETTY_EXACTSIZE)) { 299 if (quotes) 300 max_adjust += 2; 301 assert(max > max_adjust); 302 pv_escape( NULL, str, count, max - max_adjust, &escaped, flags ); 303 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) ) 304 max_adjust += 3; 305 assert(max > max_adjust); 306 } 307 308 pv_escape( dsv, str, count, max - max_adjust, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR ); 309 310 if ( end_color != NULL ) 311 sv_catpv(dsv, end_color); 312 313 if ( quotes ) 314 Perl_sv_catpvf(aTHX_ dsv, "%c", quotes[1]); 315 316 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) ) 317 sv_catpvs(dsv, "..."); 318 319 if ((flags & PERL_PV_PRETTY_EXACTSIZE)) { 320 while( SvCUR(dsv) - orig_cur < max ) 321 sv_catpvs(dsv," "); 322 } 323 324 return SvPVX(dsv); 325 } 326 327 /* 328 =for apidoc pv_display 329 330 Similar to 331 332 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE); 333 334 except that an additional "\0" will be appended to the string when 335 len > cur and pv[cur] is "\0". 336 337 Note that the final string may be up to 7 chars longer than pvlim. 338 339 =cut 340 */ 341 342 char * 343 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim) 344 { 345 PERL_ARGS_ASSERT_PV_DISPLAY; 346 347 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP); 348 if (len > cur && pv[cur] == '\0') 349 sv_catpvs( dsv, "\\0"); 350 return SvPVX(dsv); 351 } 352 353 char * 354 Perl_sv_peek(pTHX_ SV *sv) 355 { 356 dVAR; 357 SV * const t = sv_newmortal(); 358 int unref = 0; 359 U32 type; 360 361 sv_setpvs(t, ""); 362 retry: 363 if (!sv) { 364 sv_catpv(t, "VOID"); 365 goto finish; 366 } 367 else if (sv == (const SV *)0x55555555 || ((char)SvTYPE(sv)) == 'U') { 368 /* detect data corruption under memory poisoning */ 369 sv_catpv(t, "WILD"); 370 goto finish; 371 } 372 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) { 373 if (sv == &PL_sv_undef) { 374 sv_catpv(t, "SV_UNDEF"); 375 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT| 376 SVs_GMG|SVs_SMG|SVs_RMG)) && 377 SvREADONLY(sv)) 378 goto finish; 379 } 380 else if (sv == &PL_sv_no) { 381 sv_catpv(t, "SV_NO"); 382 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| 383 SVs_GMG|SVs_SMG|SVs_RMG)) && 384 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| 385 SVp_POK|SVp_NOK)) && 386 SvCUR(sv) == 0 && 387 SvNVX(sv) == 0.0) 388 goto finish; 389 } 390 else if (sv == &PL_sv_yes) { 391 sv_catpv(t, "SV_YES"); 392 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| 393 SVs_GMG|SVs_SMG|SVs_RMG)) && 394 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| 395 SVp_POK|SVp_NOK)) && 396 SvCUR(sv) == 1 && 397 SvPVX_const(sv) && *SvPVX_const(sv) == '1' && 398 SvNVX(sv) == 1.0) 399 goto finish; 400 } 401 else { 402 sv_catpv(t, "SV_PLACEHOLDER"); 403 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT| 404 SVs_GMG|SVs_SMG|SVs_RMG)) && 405 SvREADONLY(sv)) 406 goto finish; 407 } 408 sv_catpv(t, ":"); 409 } 410 else if (SvREFCNT(sv) == 0) { 411 sv_catpv(t, "("); 412 unref++; 413 } 414 else if (DEBUG_R_TEST_) { 415 int is_tmp = 0; 416 SSize_t ix; 417 /* is this SV on the tmps stack? */ 418 for (ix=PL_tmps_ix; ix>=0; ix--) { 419 if (PL_tmps_stack[ix] == sv) { 420 is_tmp = 1; 421 break; 422 } 423 } 424 if (SvREFCNT(sv) > 1) 425 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv), 426 is_tmp ? "T" : ""); 427 else if (is_tmp) 428 sv_catpv(t, "<T>"); 429 } 430 431 if (SvROK(sv)) { 432 sv_catpv(t, "\\"); 433 if (SvCUR(t) + unref > 10) { 434 SvCUR_set(t, unref + 3); 435 *SvEND(t) = '\0'; 436 sv_catpv(t, "..."); 437 goto finish; 438 } 439 sv = SvRV(sv); 440 goto retry; 441 } 442 type = SvTYPE(sv); 443 if (type == SVt_PVCV) { 444 SV * const tmp = newSVpvs_flags("", SVs_TEMP); 445 GV* gvcv = CvGV(sv); 446 Perl_sv_catpvf(aTHX_ t, "CV(%s)", gvcv 447 ? generic_pv_escape( tmp, GvNAME(gvcv), GvNAMELEN(gvcv), GvNAMEUTF8(gvcv)) 448 : ""); 449 goto finish; 450 } else if (type < SVt_LAST) { 451 sv_catpv(t, svshorttypenames[type]); 452 453 if (type == SVt_NULL) 454 goto finish; 455 } else { 456 sv_catpv(t, "FREED"); 457 goto finish; 458 } 459 460 if (SvPOKp(sv)) { 461 if (!SvPVX_const(sv)) 462 sv_catpv(t, "(null)"); 463 else { 464 SV * const tmp = newSVpvs(""); 465 sv_catpv(t, "("); 466 if (SvOOK(sv)) { 467 STRLEN delta; 468 SvOOK_offset(sv, delta); 469 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127)); 470 } 471 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127)); 472 if (SvUTF8(sv)) 473 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]", 474 sv_uni_display(tmp, sv, 6 * SvCUR(sv), 475 UNI_DISPLAY_QQ)); 476 SvREFCNT_dec_NN(tmp); 477 } 478 } 479 else if (SvNOKp(sv)) { 480 STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD(); 481 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv)); 482 RESTORE_LC_NUMERIC_UNDERLYING(); 483 } 484 else if (SvIOKp(sv)) { 485 if (SvIsUV(sv)) 486 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv)); 487 else 488 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv)); 489 } 490 else 491 sv_catpv(t, "()"); 492 493 finish: 494 while (unref--) 495 sv_catpv(t, ")"); 496 if (TAINTING_get && sv && SvTAINTED(sv)) 497 sv_catpv(t, " [tainted]"); 498 return SvPV_nolen(t); 499 } 500 501 /* 502 =head1 Debugging Utilities 503 */ 504 505 void 506 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...) 507 { 508 va_list args; 509 PERL_ARGS_ASSERT_DUMP_INDENT; 510 va_start(args, pat); 511 dump_vindent(level, file, pat, &args); 512 va_end(args); 513 } 514 515 void 516 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args) 517 { 518 PERL_ARGS_ASSERT_DUMP_VINDENT; 519 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), ""); 520 PerlIO_vprintf(file, pat, *args); 521 } 522 523 /* 524 =for apidoc dump_all 525 526 Dumps the entire optree of the current program starting at C<PL_main_root> to 527 C<STDERR>. Also dumps the optrees for all visible subroutines in 528 C<PL_defstash>. 529 530 =cut 531 */ 532 533 void 534 Perl_dump_all(pTHX) 535 { 536 dump_all_perl(FALSE); 537 } 538 539 void 540 Perl_dump_all_perl(pTHX_ bool justperl) 541 { 542 PerlIO_setlinebuf(Perl_debug_log); 543 if (PL_main_root) 544 op_dump(PL_main_root); 545 dump_packsubs_perl(PL_defstash, justperl); 546 } 547 548 /* 549 =for apidoc dump_packsubs 550 551 Dumps the optrees for all visible subroutines in C<stash>. 552 553 =cut 554 */ 555 556 void 557 Perl_dump_packsubs(pTHX_ const HV *stash) 558 { 559 PERL_ARGS_ASSERT_DUMP_PACKSUBS; 560 dump_packsubs_perl(stash, FALSE); 561 } 562 563 void 564 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl) 565 { 566 I32 i; 567 568 PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL; 569 570 if (!HvARRAY(stash)) 571 return; 572 for (i = 0; i <= (I32) HvMAX(stash); i++) { 573 const HE *entry; 574 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { 575 GV * gv = (GV *)HeVAL(entry); 576 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) 577 /* unfake a fake GV */ 578 (void)CvGV(SvRV(gv)); 579 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv)) 580 continue; 581 if (GvCVu(gv)) 582 dump_sub_perl(gv, justperl); 583 if (GvFORM(gv)) 584 dump_form(gv); 585 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') { 586 const HV * const hv = GvHV(gv); 587 if (hv && (hv != PL_defstash)) 588 dump_packsubs_perl(hv, justperl); /* nested package */ 589 } 590 } 591 } 592 } 593 594 void 595 Perl_dump_sub(pTHX_ const GV *gv) 596 { 597 PERL_ARGS_ASSERT_DUMP_SUB; 598 dump_sub_perl(gv, FALSE); 599 } 600 601 void 602 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl) 603 { 604 STRLEN len; 605 SV * const sv = newSVpvs_flags("", SVs_TEMP); 606 SV *tmpsv; 607 const char * name; 608 609 PERL_ARGS_ASSERT_DUMP_SUB_PERL; 610 611 if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv)))) 612 return; 613 614 tmpsv = newSVpvs_flags("", SVs_TEMP); 615 gv_fullname3(sv, gv, NULL); 616 name = SvPV_const(sv, len); 617 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", 618 generic_pv_escape(tmpsv, name, len, SvUTF8(sv))); 619 if (CvISXSUB(GvCV(gv))) 620 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n", 621 PTR2UV(CvXSUB(GvCV(gv))), 622 (int)CvXSUBANY(GvCV(gv)).any_i32); 623 else if (CvROOT(GvCV(gv))) 624 op_dump(CvROOT(GvCV(gv))); 625 else 626 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n"); 627 } 628 629 void 630 Perl_dump_form(pTHX_ const GV *gv) 631 { 632 SV * const sv = sv_newmortal(); 633 634 PERL_ARGS_ASSERT_DUMP_FORM; 635 636 gv_fullname3(sv, gv, NULL); 637 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv)); 638 if (CvROOT(GvFORM(gv))) 639 op_dump(CvROOT(GvFORM(gv))); 640 else 641 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n"); 642 } 643 644 void 645 Perl_dump_eval(pTHX) 646 { 647 op_dump(PL_eval_root); 648 } 649 650 void 651 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm) 652 { 653 char ch; 654 655 PERL_ARGS_ASSERT_DO_PMOP_DUMP; 656 657 if (!pm) { 658 Perl_dump_indent(aTHX_ level, file, "{}\n"); 659 return; 660 } 661 Perl_dump_indent(aTHX_ level, file, "{\n"); 662 level++; 663 if (pm->op_pmflags & PMf_ONCE) 664 ch = '?'; 665 else 666 ch = '/'; 667 if (PM_GETRE(pm)) 668 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%.*s%c%s\n", 669 ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch, 670 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : ""); 671 else 672 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n"); 673 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) { 674 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = "); 675 op_dump(pm->op_pmreplrootu.op_pmreplroot); 676 } 677 if (pm->op_code_list) { 678 if (pm->op_pmflags & PMf_CODELIST_PRIVATE) { 679 Perl_dump_indent(aTHX_ level, file, "CODE_LIST =\n"); 680 do_op_dump(level, file, pm->op_code_list); 681 } 682 else 683 Perl_dump_indent(aTHX_ level, file, "CODE_LIST = 0x%"UVxf"\n", 684 PTR2UV(pm->op_code_list)); 685 } 686 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) { 687 SV * const tmpsv = pm_description(pm); 688 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : ""); 689 SvREFCNT_dec_NN(tmpsv); 690 } 691 692 Perl_dump_indent(aTHX_ level-1, file, "}\n"); 693 } 694 695 const struct flag_to_name pmflags_flags_names[] = { 696 {PMf_CONST, ",CONST"}, 697 {PMf_KEEP, ",KEEP"}, 698 {PMf_GLOBAL, ",GLOBAL"}, 699 {PMf_CONTINUE, ",CONTINUE"}, 700 {PMf_RETAINT, ",RETAINT"}, 701 {PMf_EVAL, ",EVAL"}, 702 {PMf_NONDESTRUCT, ",NONDESTRUCT"}, 703 {PMf_HAS_CV, ",HAS_CV"}, 704 {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"}, 705 {PMf_IS_QR, ",IS_QR"} 706 }; 707 708 static SV * 709 S_pm_description(pTHX_ const PMOP *pm) 710 { 711 SV * const desc = newSVpvs(""); 712 const REGEXP * const regex = PM_GETRE(pm); 713 const U32 pmflags = pm->op_pmflags; 714 715 PERL_ARGS_ASSERT_PM_DESCRIPTION; 716 717 if (pmflags & PMf_ONCE) 718 sv_catpv(desc, ",ONCE"); 719 #ifdef USE_ITHREADS 720 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset])) 721 sv_catpv(desc, ":USED"); 722 #else 723 if (pmflags & PMf_USED) 724 sv_catpv(desc, ":USED"); 725 #endif 726 727 if (regex) { 728 if (RX_ISTAINTED(regex)) 729 sv_catpv(desc, ",TAINTED"); 730 if (RX_CHECK_SUBSTR(regex)) { 731 if (!(RX_INTFLAGS(regex) & PREGf_NOSCAN)) 732 sv_catpv(desc, ",SCANFIRST"); 733 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL) 734 sv_catpv(desc, ",ALL"); 735 } 736 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE) 737 sv_catpv(desc, ",SKIPWHITE"); 738 } 739 740 append_flags(desc, pmflags, pmflags_flags_names); 741 return desc; 742 } 743 744 void 745 Perl_pmop_dump(pTHX_ PMOP *pm) 746 { 747 do_pmop_dump(0, Perl_debug_log, pm); 748 } 749 750 /* Return a unique integer to represent the address of op o. 751 * If it already exists in PL_op_sequence, just return it; 752 * otherwise add it. 753 * *** Note that this isn't thread-safe */ 754 755 STATIC UV 756 S_sequence_num(pTHX_ const OP *o) 757 { 758 dVAR; 759 SV *op, 760 **seq; 761 const char *key; 762 STRLEN len; 763 if (!o) 764 return 0; 765 op = newSVuv(PTR2UV(o)); 766 sv_2mortal(op); 767 key = SvPV_const(op, len); 768 if (!PL_op_sequence) 769 PL_op_sequence = newHV(); 770 seq = hv_fetch(PL_op_sequence, key, len, 0); 771 if (seq) 772 return SvUV(*seq); 773 (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0); 774 return PL_op_seq; 775 } 776 777 778 779 780 781 const struct flag_to_name op_flags_names[] = { 782 {OPf_KIDS, ",KIDS"}, 783 {OPf_PARENS, ",PARENS"}, 784 {OPf_REF, ",REF"}, 785 {OPf_MOD, ",MOD"}, 786 {OPf_STACKED, ",STACKED"}, 787 {OPf_SPECIAL, ",SPECIAL"} 788 }; 789 790 791 void 792 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) 793 { 794 UV seq; 795 const OPCODE optype = o->op_type; 796 797 PERL_ARGS_ASSERT_DO_OP_DUMP; 798 799 Perl_dump_indent(aTHX_ level, file, "{\n"); 800 level++; 801 seq = sequence_num(o); 802 if (seq) 803 PerlIO_printf(file, "%-4"UVuf, seq); 804 else 805 PerlIO_printf(file, "????"); 806 PerlIO_printf(file, 807 "%*sTYPE = %s ===> ", 808 (int)(PL_dumpindent*level-4), "", OP_NAME(o)); 809 if (o->op_next) 810 PerlIO_printf(file, 811 o->op_type == OP_NULL ? "(%"UVuf")\n" : "%"UVuf"\n", 812 sequence_num(o->op_next)); 813 else 814 PerlIO_printf(file, "NULL\n"); 815 if (o->op_targ) { 816 if (optype == OP_NULL) { 817 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]); 818 } 819 else 820 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ); 821 } 822 #ifdef DUMPADDR 823 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next); 824 #endif 825 826 if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) { 827 SV * const tmpsv = newSVpvs(""); 828 switch (o->op_flags & OPf_WANT) { 829 case OPf_WANT_VOID: 830 sv_catpv(tmpsv, ",VOID"); 831 break; 832 case OPf_WANT_SCALAR: 833 sv_catpv(tmpsv, ",SCALAR"); 834 break; 835 case OPf_WANT_LIST: 836 sv_catpv(tmpsv, ",LIST"); 837 break; 838 default: 839 sv_catpv(tmpsv, ",UNKNOWN"); 840 break; 841 } 842 append_flags(tmpsv, o->op_flags, op_flags_names); 843 if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED"); 844 if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE"); 845 if (o->op_static) sv_catpvs(tmpsv, ",STATIC"); 846 if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED"); 847 if (o->op_moresib) sv_catpvs(tmpsv, ",MORESIB"); 848 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", 849 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : ""); 850 } 851 852 if (o->op_private) { 853 U16 oppriv = o->op_private; 854 I16 op_ix = PL_op_private_bitdef_ix[o->op_type]; 855 SV * tmpsv = NULL; 856 857 if (op_ix != -1) { 858 U16 stop = 0; 859 tmpsv = newSVpvs(""); 860 for (; !stop; op_ix++) { 861 U16 entry = PL_op_private_bitdefs[op_ix]; 862 U16 bit = (entry >> 2) & 7; 863 U16 ix = entry >> 5; 864 865 stop = (entry & 1); 866 867 if (entry & 2) { 868 /* bitfield */ 869 I16 const *p = &PL_op_private_bitfields[ix]; 870 U16 bitmin = (U16) *p++; 871 I16 label = *p++; 872 I16 enum_label; 873 U16 mask = 0; 874 U16 i; 875 U16 val; 876 877 for (i = bitmin; i<= bit; i++) 878 mask |= (1<<i); 879 bit = bitmin; 880 val = (oppriv & mask); 881 882 if ( label != -1 883 && PL_op_private_labels[label] == '-' 884 && PL_op_private_labels[label+1] == '\0' 885 ) 886 /* display as raw number */ 887 continue; 888 889 oppriv -= val; 890 val >>= bit; 891 enum_label = -1; 892 while (*p != -1) { 893 if (val == *p++) { 894 enum_label = *p; 895 break; 896 } 897 p++; 898 } 899 if (val == 0 && enum_label == -1) 900 /* don't display anonymous zero values */ 901 continue; 902 903 sv_catpv(tmpsv, ","); 904 if (label != -1) { 905 sv_catpv(tmpsv, &PL_op_private_labels[label]); 906 sv_catpv(tmpsv, "="); 907 } 908 if (enum_label == -1) 909 Perl_sv_catpvf(aTHX_ tmpsv, "0x%"UVxf, (UV)val); 910 else 911 sv_catpv(tmpsv, &PL_op_private_labels[enum_label]); 912 913 } 914 else { 915 /* bit flag */ 916 if ( oppriv & (1<<bit) 917 && !(PL_op_private_labels[ix] == '-' 918 && PL_op_private_labels[ix+1] == '\0')) 919 { 920 oppriv -= (1<<bit); 921 sv_catpv(tmpsv, ","); 922 sv_catpv(tmpsv, &PL_op_private_labels[ix]); 923 } 924 } 925 } 926 if (oppriv) { 927 sv_catpv(tmpsv, ","); 928 Perl_sv_catpvf(aTHX_ tmpsv, "0x%"UVxf, (UV)oppriv); 929 } 930 } 931 if (tmpsv && SvCUR(tmpsv)) { 932 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1); 933 } else 934 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (0x%"UVxf")\n", 935 (UV)oppriv); 936 } 937 938 switch (optype) { 939 case OP_AELEMFAST: 940 case OP_GVSV: 941 case OP_GV: 942 #ifdef USE_ITHREADS 943 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix); 944 #else 945 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */ 946 if (cSVOPo->op_sv) { 947 STRLEN len; 948 const char * name; 949 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP); 950 SV * const tmpsv2 = newSVpvs_flags("", SVs_TEMP); 951 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL); 952 name = SvPV_const(tmpsv, len); 953 Perl_dump_indent(aTHX_ level, file, "GV = %s\n", 954 generic_pv_escape( tmpsv2, name, len, SvUTF8(tmpsv))); 955 } 956 else 957 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n"); 958 } 959 #endif 960 break; 961 962 case OP_MULTIDEREF: 963 { 964 UNOP_AUX_item *items = cUNOP_AUXo->op_aux; 965 UV i, count = items[-1].uv; 966 967 Perl_dump_indent(aTHX_ level, file, "ARGS = \n"); 968 for (i=0; i < count; i++) 969 Perl_dump_indent(aTHX_ level+1, file, "%"UVuf" => 0x%"UVxf"\n", 970 i, items[i].uv); 971 break; 972 } 973 974 case OP_CONST: 975 case OP_HINTSEVAL: 976 case OP_METHOD_NAMED: 977 case OP_METHOD_SUPER: 978 case OP_METHOD_REDIR: 979 case OP_METHOD_REDIR_SUPER: 980 #ifndef USE_ITHREADS 981 /* with ITHREADS, consts are stored in the pad, and the right pad 982 * may not be active here, so skip */ 983 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cMETHOPx_meth(o))); 984 #endif 985 break; 986 case OP_NULL: 987 if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE) 988 break; 989 /* FALLTHROUGH */ 990 case OP_NEXTSTATE: 991 case OP_DBSTATE: 992 if (CopLINE(cCOPo)) 993 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n", 994 (UV)CopLINE(cCOPo)); 995 if (CopSTASHPV(cCOPo)) { 996 SV* tmpsv = newSVpvs_flags("", SVs_TEMP); 997 HV *stash = CopSTASH(cCOPo); 998 const char * const hvname = HvNAME_get(stash); 999 1000 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n", 1001 generic_pv_escape(tmpsv, hvname, 1002 HvNAMELEN(stash), HvNAMEUTF8(stash))); 1003 } 1004 if (CopLABEL(cCOPo)) { 1005 SV* tmpsv = newSVpvs_flags("", SVs_TEMP); 1006 STRLEN label_len; 1007 U32 label_flags; 1008 const char *label = CopLABEL_len_flags(cCOPo, 1009 &label_len, &label_flags); 1010 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n", 1011 generic_pv_escape( tmpsv, label, label_len, 1012 (label_flags & SVf_UTF8))); 1013 } 1014 Perl_dump_indent(aTHX_ level, file, "SEQ = %u\n", 1015 (unsigned int)cCOPo->cop_seq); 1016 break; 1017 case OP_ENTERLOOP: 1018 Perl_dump_indent(aTHX_ level, file, "REDO ===> "); 1019 if (cLOOPo->op_redoop) 1020 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop)); 1021 else 1022 PerlIO_printf(file, "DONE\n"); 1023 Perl_dump_indent(aTHX_ level, file, "NEXT ===> "); 1024 if (cLOOPo->op_nextop) 1025 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop)); 1026 else 1027 PerlIO_printf(file, "DONE\n"); 1028 Perl_dump_indent(aTHX_ level, file, "LAST ===> "); 1029 if (cLOOPo->op_lastop) 1030 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop)); 1031 else 1032 PerlIO_printf(file, "DONE\n"); 1033 break; 1034 case OP_COND_EXPR: 1035 case OP_RANGE: 1036 case OP_MAPWHILE: 1037 case OP_GREPWHILE: 1038 case OP_OR: 1039 case OP_AND: 1040 Perl_dump_indent(aTHX_ level, file, "OTHER ===> "); 1041 if (cLOGOPo->op_other) 1042 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other)); 1043 else 1044 PerlIO_printf(file, "DONE\n"); 1045 break; 1046 case OP_PUSHRE: 1047 case OP_MATCH: 1048 case OP_QR: 1049 case OP_SUBST: 1050 do_pmop_dump(level, file, cPMOPo); 1051 break; 1052 case OP_LEAVE: 1053 case OP_LEAVEEVAL: 1054 case OP_LEAVESUB: 1055 case OP_LEAVESUBLV: 1056 case OP_LEAVEWRITE: 1057 case OP_SCOPE: 1058 if (o->op_private & OPpREFCOUNTED) 1059 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ); 1060 break; 1061 default: 1062 break; 1063 } 1064 if (o->op_flags & OPf_KIDS) { 1065 OP *kid; 1066 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) 1067 do_op_dump(level, file, kid); 1068 } 1069 Perl_dump_indent(aTHX_ level-1, file, "}\n"); 1070 } 1071 1072 /* 1073 =for apidoc op_dump 1074 1075 Dumps the optree starting at OP C<o> to C<STDERR>. 1076 1077 =cut 1078 */ 1079 1080 void 1081 Perl_op_dump(pTHX_ const OP *o) 1082 { 1083 PERL_ARGS_ASSERT_OP_DUMP; 1084 do_op_dump(0, Perl_debug_log, o); 1085 } 1086 1087 void 1088 Perl_gv_dump(pTHX_ GV *gv) 1089 { 1090 STRLEN len; 1091 const char* name; 1092 SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP); 1093 1094 if (!gv) { 1095 PerlIO_printf(Perl_debug_log, "{}\n"); 1096 return; 1097 } 1098 sv = sv_newmortal(); 1099 PerlIO_printf(Perl_debug_log, "{\n"); 1100 gv_fullname3(sv, gv, NULL); 1101 name = SvPV_const(sv, len); 1102 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", 1103 generic_pv_escape( tmp, name, len, SvUTF8(sv) )); 1104 if (gv != GvEGV(gv)) { 1105 gv_efullname3(sv, GvEGV(gv), NULL); 1106 name = SvPV_const(sv, len); 1107 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", 1108 generic_pv_escape( tmp, name, len, SvUTF8(sv) )); 1109 } 1110 (void)PerlIO_putc(Perl_debug_log, '\n'); 1111 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n"); 1112 } 1113 1114 1115 /* map magic types to the symbolic names 1116 * (with the PERL_MAGIC_ prefixed stripped) 1117 */ 1118 1119 static const struct { const char type; const char *name; } magic_names[] = { 1120 #include "mg_names.inc" 1121 /* this null string terminates the list */ 1122 { 0, NULL }, 1123 }; 1124 1125 void 1126 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim) 1127 { 1128 PERL_ARGS_ASSERT_DO_MAGIC_DUMP; 1129 1130 for (; mg; mg = mg->mg_moremagic) { 1131 Perl_dump_indent(aTHX_ level, file, 1132 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg)); 1133 if (mg->mg_virtual) { 1134 const MGVTBL * const v = mg->mg_virtual; 1135 if (v >= PL_magic_vtables 1136 && v < PL_magic_vtables + magic_vtable_max) { 1137 const U32 i = v - PL_magic_vtables; 1138 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]); 1139 } 1140 else 1141 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v)); 1142 } 1143 else 1144 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n"); 1145 1146 if (mg->mg_private) 1147 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private); 1148 1149 { 1150 int n; 1151 const char *name = NULL; 1152 for (n = 0; magic_names[n].name; n++) { 1153 if (mg->mg_type == magic_names[n].type) { 1154 name = magic_names[n].name; 1155 break; 1156 } 1157 } 1158 if (name) 1159 Perl_dump_indent(aTHX_ level, file, 1160 " MG_TYPE = PERL_MAGIC_%s\n", name); 1161 else 1162 Perl_dump_indent(aTHX_ level, file, 1163 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type); 1164 } 1165 1166 if (mg->mg_flags) { 1167 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags); 1168 if (mg->mg_type == PERL_MAGIC_envelem && 1169 mg->mg_flags & MGf_TAINTEDDIR) 1170 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n"); 1171 if (mg->mg_type == PERL_MAGIC_regex_global && 1172 mg->mg_flags & MGf_MINMATCH) 1173 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n"); 1174 if (mg->mg_flags & MGf_REFCOUNTED) 1175 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n"); 1176 if (mg->mg_flags & MGf_GSKIP) 1177 Perl_dump_indent(aTHX_ level, file, " GSKIP\n"); 1178 if (mg->mg_flags & MGf_COPY) 1179 Perl_dump_indent(aTHX_ level, file, " COPY\n"); 1180 if (mg->mg_flags & MGf_DUP) 1181 Perl_dump_indent(aTHX_ level, file, " DUP\n"); 1182 if (mg->mg_flags & MGf_LOCAL) 1183 Perl_dump_indent(aTHX_ level, file, " LOCAL\n"); 1184 if (mg->mg_type == PERL_MAGIC_regex_global && 1185 mg->mg_flags & MGf_BYTES) 1186 Perl_dump_indent(aTHX_ level, file, " BYTES\n"); 1187 } 1188 if (mg->mg_obj) { 1189 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n", 1190 PTR2UV(mg->mg_obj)); 1191 if (mg->mg_type == PERL_MAGIC_qr) { 1192 REGEXP* const re = (REGEXP *)mg->mg_obj; 1193 SV * const dsv = sv_newmortal(); 1194 const char * const s 1195 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re), 1196 60, NULL, NULL, 1197 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES | 1198 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0)) 1199 ); 1200 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s); 1201 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n", 1202 (IV)RX_REFCNT(re)); 1203 } 1204 if (mg->mg_flags & MGf_REFCOUNTED) 1205 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */ 1206 } 1207 if (mg->mg_len) 1208 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len); 1209 if (mg->mg_ptr) { 1210 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr)); 1211 if (mg->mg_len >= 0) { 1212 if (mg->mg_type != PERL_MAGIC_utf8) { 1213 SV * const sv = newSVpvs(""); 1214 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim)); 1215 SvREFCNT_dec_NN(sv); 1216 } 1217 } 1218 else if (mg->mg_len == HEf_SVKEY) { 1219 PerlIO_puts(file, " => HEf_SVKEY\n"); 1220 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1, 1221 maxnest, dumpops, pvlim); /* MG is already +1 */ 1222 continue; 1223 } 1224 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8); 1225 else 1226 PerlIO_puts( 1227 file, 1228 " ???? - " __FILE__ 1229 " does not know how to handle this MG_LEN" 1230 ); 1231 (void)PerlIO_putc(file, '\n'); 1232 } 1233 if (mg->mg_type == PERL_MAGIC_utf8) { 1234 const STRLEN * const cache = (STRLEN *) mg->mg_ptr; 1235 if (cache) { 1236 IV i; 1237 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++) 1238 Perl_dump_indent(aTHX_ level, file, 1239 " %2"IVdf": %"UVuf" -> %"UVuf"\n", 1240 i, 1241 (UV)cache[i * 2], 1242 (UV)cache[i * 2 + 1]); 1243 } 1244 } 1245 } 1246 } 1247 1248 void 1249 Perl_magic_dump(pTHX_ const MAGIC *mg) 1250 { 1251 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0); 1252 } 1253 1254 void 1255 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv) 1256 { 1257 const char *hvname; 1258 1259 PERL_ARGS_ASSERT_DO_HV_DUMP; 1260 1261 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv)); 1262 if (sv && (hvname = HvNAME_get(sv))) 1263 { 1264 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package 1265 name which quite legally could contain insane things like tabs, newlines, nulls or 1266 other scary crap - this should produce sane results - except maybe for unicode package 1267 names - but we will wait for someone to file a bug on that - demerphq */ 1268 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP); 1269 PerlIO_printf(file, "\t\"%s\"\n", 1270 generic_pv_escape( tmpsv, hvname, 1271 HvNAMELEN(sv), HvNAMEUTF8(sv))); 1272 } 1273 else 1274 (void)PerlIO_putc(file, '\n'); 1275 } 1276 1277 void 1278 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv) 1279 { 1280 PERL_ARGS_ASSERT_DO_GV_DUMP; 1281 1282 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv)); 1283 if (sv && GvNAME(sv)) { 1284 SV * const tmpsv = newSVpvs(""); 1285 PerlIO_printf(file, "\t\"%s\"\n", 1286 generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) )); 1287 } 1288 else 1289 (void)PerlIO_putc(file, '\n'); 1290 } 1291 1292 void 1293 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv) 1294 { 1295 PERL_ARGS_ASSERT_DO_GVGV_DUMP; 1296 1297 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv)); 1298 if (sv && GvNAME(sv)) { 1299 SV *tmp = newSVpvs_flags("", SVs_TEMP); 1300 const char *hvname; 1301 HV * const stash = GvSTASH(sv); 1302 PerlIO_printf(file, "\t"); 1303 /* TODO might have an extra \" here */ 1304 if (stash && (hvname = HvNAME_get(stash))) { 1305 PerlIO_printf(file, "\"%s\" :: \"", 1306 generic_pv_escape(tmp, hvname, 1307 HvNAMELEN(stash), HvNAMEUTF8(stash))); 1308 } 1309 PerlIO_printf(file, "%s\"\n", 1310 generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv))); 1311 } 1312 else 1313 (void)PerlIO_putc(file, '\n'); 1314 } 1315 1316 const struct flag_to_name first_sv_flags_names[] = { 1317 {SVs_TEMP, "TEMP,"}, 1318 {SVs_OBJECT, "OBJECT,"}, 1319 {SVs_GMG, "GMG,"}, 1320 {SVs_SMG, "SMG,"}, 1321 {SVs_RMG, "RMG,"}, 1322 {SVf_IOK, "IOK,"}, 1323 {SVf_NOK, "NOK,"}, 1324 {SVf_POK, "POK,"} 1325 }; 1326 1327 const struct flag_to_name second_sv_flags_names[] = { 1328 {SVf_OOK, "OOK,"}, 1329 {SVf_FAKE, "FAKE,"}, 1330 {SVf_READONLY, "READONLY,"}, 1331 {SVf_PROTECT, "PROTECT,"}, 1332 {SVf_BREAK, "BREAK,"}, 1333 {SVp_IOK, "pIOK,"}, 1334 {SVp_NOK, "pNOK,"}, 1335 {SVp_POK, "pPOK,"} 1336 }; 1337 1338 const struct flag_to_name cv_flags_names[] = { 1339 {CVf_ANON, "ANON,"}, 1340 {CVf_UNIQUE, "UNIQUE,"}, 1341 {CVf_CLONE, "CLONE,"}, 1342 {CVf_CLONED, "CLONED,"}, 1343 {CVf_CONST, "CONST,"}, 1344 {CVf_NODEBUG, "NODEBUG,"}, 1345 {CVf_LVALUE, "LVALUE,"}, 1346 {CVf_METHOD, "METHOD,"}, 1347 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"}, 1348 {CVf_CVGV_RC, "CVGV_RC,"}, 1349 {CVf_DYNFILE, "DYNFILE,"}, 1350 {CVf_AUTOLOAD, "AUTOLOAD,"}, 1351 {CVf_HASEVAL, "HASEVAL,"}, 1352 {CVf_SLABBED, "SLABBED,"}, 1353 {CVf_NAMED, "NAMED,"}, 1354 {CVf_LEXICAL, "LEXICAL,"}, 1355 {CVf_ISXSUB, "ISXSUB,"} 1356 }; 1357 1358 const struct flag_to_name hv_flags_names[] = { 1359 {SVphv_SHAREKEYS, "SHAREKEYS,"}, 1360 {SVphv_LAZYDEL, "LAZYDEL,"}, 1361 {SVphv_HASKFLAGS, "HASKFLAGS,"}, 1362 {SVf_AMAGIC, "OVERLOAD,"}, 1363 {SVphv_CLONEABLE, "CLONEABLE,"} 1364 }; 1365 1366 const struct flag_to_name gp_flags_names[] = { 1367 {GVf_INTRO, "INTRO,"}, 1368 {GVf_MULTI, "MULTI,"}, 1369 {GVf_ASSUMECV, "ASSUMECV,"}, 1370 }; 1371 1372 const struct flag_to_name gp_flags_imported_names[] = { 1373 {GVf_IMPORTED_SV, " SV"}, 1374 {GVf_IMPORTED_AV, " AV"}, 1375 {GVf_IMPORTED_HV, " HV"}, 1376 {GVf_IMPORTED_CV, " CV"}, 1377 }; 1378 1379 /* NOTE: this structure is mostly duplicative of one generated by 1380 * 'make regen' in regnodes.h - perhaps we should somehow integrate 1381 * the two. - Yves */ 1382 const struct flag_to_name regexp_extflags_names[] = { 1383 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"}, 1384 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"}, 1385 {RXf_PMf_FOLD, "PMf_FOLD,"}, 1386 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"}, 1387 {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"}, 1388 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"}, 1389 {RXf_PMf_NOCAPTURE, "PMf_NOCAPURE,"}, 1390 {RXf_IS_ANCHORED, "IS_ANCHORED,"}, 1391 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"}, 1392 {RXf_EVAL_SEEN, "EVAL_SEEN,"}, 1393 {RXf_CHECK_ALL, "CHECK_ALL,"}, 1394 {RXf_MATCH_UTF8, "MATCH_UTF8,"}, 1395 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"}, 1396 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"}, 1397 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"}, 1398 {RXf_SPLIT, "SPLIT,"}, 1399 {RXf_COPY_DONE, "COPY_DONE,"}, 1400 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"}, 1401 {RXf_TAINTED, "TAINTED,"}, 1402 {RXf_START_ONLY, "START_ONLY,"}, 1403 {RXf_SKIPWHITE, "SKIPWHITE,"}, 1404 {RXf_WHITE, "WHITE,"}, 1405 {RXf_NULL, "NULL,"}, 1406 }; 1407 1408 /* NOTE: this structure is mostly duplicative of one generated by 1409 * 'make regen' in regnodes.h - perhaps we should somehow integrate 1410 * the two. - Yves */ 1411 const struct flag_to_name regexp_core_intflags_names[] = { 1412 {PREGf_SKIP, "SKIP,"}, 1413 {PREGf_IMPLICIT, "IMPLICIT,"}, 1414 {PREGf_NAUGHTY, "NAUGHTY,"}, 1415 {PREGf_VERBARG_SEEN, "VERBARG_SEEN,"}, 1416 {PREGf_CUTGROUP_SEEN, "CUTGROUP_SEEN,"}, 1417 {PREGf_USE_RE_EVAL, "USE_RE_EVAL,"}, 1418 {PREGf_NOSCAN, "NOSCAN,"}, 1419 {PREGf_GPOS_SEEN, "GPOS_SEEN,"}, 1420 {PREGf_GPOS_FLOAT, "GPOS_FLOAT,"}, 1421 {PREGf_ANCH_MBOL, "ANCH_MBOL,"}, 1422 {PREGf_ANCH_SBOL, "ANCH_SBOL,"}, 1423 {PREGf_ANCH_GPOS, "ANCH_GPOS,"}, 1424 }; 1425 1426 /* Perl_do_sv_dump(): 1427 * 1428 * level: amount to indent the output 1429 * sv: the object to dump 1430 * nest: the current level of recursion 1431 * maxnest: the maximum allowed level of recursion 1432 * dumpops: if true, also dump the ops associated with a CV 1433 * pvlim: limit on the length of any strings that are output 1434 * */ 1435 1436 void 1437 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim) 1438 { 1439 SV *d; 1440 const char *s; 1441 U32 flags; 1442 U32 type; 1443 1444 PERL_ARGS_ASSERT_DO_SV_DUMP; 1445 1446 if (!sv) { 1447 Perl_dump_indent(aTHX_ level, file, "SV = 0\n"); 1448 return; 1449 } 1450 1451 flags = SvFLAGS(sv); 1452 type = SvTYPE(sv); 1453 1454 /* process general SV flags */ 1455 1456 d = Perl_newSVpvf(aTHX_ 1457 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (", 1458 PTR2UV(SvANY(sv)), PTR2UV(sv), 1459 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv), 1460 (int)(PL_dumpindent*level), ""); 1461 1462 if ((flags & SVs_PADSTALE)) 1463 sv_catpv(d, "PADSTALE,"); 1464 if ((flags & SVs_PADTMP)) 1465 sv_catpv(d, "PADTMP,"); 1466 append_flags(d, flags, first_sv_flags_names); 1467 if (flags & SVf_ROK) { 1468 sv_catpv(d, "ROK,"); 1469 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,"); 1470 } 1471 if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,"); 1472 append_flags(d, flags, second_sv_flags_names); 1473 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv) 1474 && type != SVt_PVAV) { 1475 if (SvPCS_IMPORTED(sv)) 1476 sv_catpv(d, "PCS_IMPORTED,"); 1477 else 1478 sv_catpv(d, "SCREAM,"); 1479 } 1480 1481 /* process type-specific SV flags */ 1482 1483 switch (type) { 1484 case SVt_PVCV: 1485 case SVt_PVFM: 1486 append_flags(d, CvFLAGS(sv), cv_flags_names); 1487 break; 1488 case SVt_PVHV: 1489 append_flags(d, flags, hv_flags_names); 1490 break; 1491 case SVt_PVGV: 1492 case SVt_PVLV: 1493 if (isGV_with_GP(sv)) { 1494 append_flags(d, GvFLAGS(sv), gp_flags_names); 1495 } 1496 if (isGV_with_GP(sv) && GvIMPORTED(sv)) { 1497 sv_catpv(d, "IMPORT"); 1498 if (GvIMPORTED(sv) == GVf_IMPORTED) 1499 sv_catpv(d, "ALL,"); 1500 else { 1501 sv_catpv(d, "("); 1502 append_flags(d, GvFLAGS(sv), gp_flags_imported_names); 1503 sv_catpv(d, " ),"); 1504 } 1505 } 1506 /* FALLTHROUGH */ 1507 default: 1508 evaled_or_uv: 1509 if (SvEVALED(sv)) sv_catpv(d, "EVALED,"); 1510 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,"); 1511 break; 1512 case SVt_PVMG: 1513 if (SvTAIL(sv)) sv_catpv(d, "TAIL,"); 1514 if (SvVALID(sv)) sv_catpv(d, "VALID,"); 1515 /* FALLTHROUGH */ 1516 goto evaled_or_uv; 1517 case SVt_PVAV: 1518 break; 1519 } 1520 /* SVphv_SHAREKEYS is also 0x20000000 */ 1521 if ((type != SVt_PVHV) && SvUTF8(sv)) 1522 sv_catpv(d, "UTF8"); 1523 1524 if (*(SvEND(d) - 1) == ',') { 1525 SvCUR_set(d, SvCUR(d) - 1); 1526 SvPVX(d)[SvCUR(d)] = '\0'; 1527 } 1528 sv_catpv(d, ")"); 1529 s = SvPVX_const(d); 1530 1531 /* dump initial SV details */ 1532 1533 #ifdef DEBUG_LEAKING_SCALARS 1534 Perl_dump_indent(aTHX_ level, file, 1535 "ALLOCATED at %s:%d %s %s (parent 0x%"UVxf"); serial %"UVuf"\n", 1536 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)", 1537 sv->sv_debug_line, 1538 sv->sv_debug_inpad ? "for" : "by", 1539 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)", 1540 PTR2UV(sv->sv_debug_parent), 1541 sv->sv_debug_serial 1542 ); 1543 #endif 1544 Perl_dump_indent(aTHX_ level, file, "SV = "); 1545 1546 /* Dump SV type */ 1547 1548 if (type < SVt_LAST) { 1549 PerlIO_printf(file, "%s%s\n", svtypenames[type], s); 1550 1551 if (type == SVt_NULL) { 1552 SvREFCNT_dec_NN(d); 1553 return; 1554 } 1555 } else { 1556 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s); 1557 SvREFCNT_dec_NN(d); 1558 return; 1559 } 1560 1561 /* Dump general SV fields */ 1562 1563 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV 1564 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO 1565 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv)) 1566 || (type == SVt_IV && !SvROK(sv))) { 1567 if (SvIsUV(sv) 1568 ) 1569 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv)); 1570 else 1571 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv)); 1572 (void)PerlIO_putc(file, '\n'); 1573 } 1574 1575 if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV 1576 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP 1577 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv)) 1578 || type == SVt_NV) { 1579 STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD(); 1580 Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv)); 1581 RESTORE_LC_NUMERIC_UNDERLYING(); 1582 } 1583 1584 if (SvROK(sv)) { 1585 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv))); 1586 if (nest < maxnest) 1587 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim); 1588 } 1589 1590 if (type < SVt_PV) { 1591 SvREFCNT_dec_NN(d); 1592 return; 1593 } 1594 1595 if ((type <= SVt_PVLV && !isGV_with_GP(sv)) 1596 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) { 1597 const bool re = isREGEXP(sv); 1598 const char * const ptr = 1599 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv); 1600 if (ptr) { 1601 STRLEN delta; 1602 if (SvOOK(sv)) { 1603 SvOOK_offset(sv, delta); 1604 Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n", 1605 (UV) delta); 1606 } else { 1607 delta = 0; 1608 } 1609 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(ptr)); 1610 if (SvOOK(sv)) { 1611 PerlIO_printf(file, "( %s . ) ", 1612 pv_display(d, ptr - delta, delta, 0, 1613 pvlim)); 1614 } 1615 if (type == SVt_INVLIST) { 1616 PerlIO_printf(file, "\n"); 1617 /* 4 blanks indents 2 beyond the PV, etc */ 1618 _invlist_dump(file, level, " ", sv); 1619 } 1620 else { 1621 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv), 1622 re ? 0 : SvLEN(sv), 1623 pvlim)); 1624 if (SvUTF8(sv)) /* the 6? \x{....} */ 1625 PerlIO_printf(file, " [UTF8 \"%s\"]", 1626 sv_uni_display(d, sv, 6 * SvCUR(sv), 1627 UNI_DISPLAY_QQ)); 1628 PerlIO_printf(file, "\n"); 1629 } 1630 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv)); 1631 if (!re) 1632 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", 1633 (IV)SvLEN(sv)); 1634 #ifdef PERL_COPY_ON_WRITE 1635 if (SvIsCOW(sv) && SvLEN(sv)) 1636 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n", 1637 CowREFCNT(sv)); 1638 #endif 1639 } 1640 else 1641 Perl_dump_indent(aTHX_ level, file, " PV = 0\n"); 1642 } 1643 1644 if (type >= SVt_PVMG) { 1645 if (SvMAGIC(sv)) 1646 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim); 1647 if (SvSTASH(sv)) 1648 do_hv_dump(level, file, " STASH", SvSTASH(sv)); 1649 1650 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) { 1651 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv)); 1652 } 1653 } 1654 1655 /* Dump type-specific SV fields */ 1656 1657 switch (type) { 1658 case SVt_PVAV: 1659 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv))); 1660 if (AvARRAY(sv) != AvALLOC(sv)) { 1661 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv))); 1662 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv))); 1663 } 1664 else 1665 (void)PerlIO_putc(file, '\n'); 1666 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv)); 1667 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv)); 1668 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", 1669 SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0); 1670 sv_setpvs(d, ""); 1671 if (AvREAL(sv)) sv_catpv(d, ",REAL"); 1672 if (AvREIFY(sv)) sv_catpv(d, ",REIFY"); 1673 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n", 1674 SvCUR(d) ? SvPVX_const(d) + 1 : ""); 1675 if (nest < maxnest && av_tindex(MUTABLE_AV(sv)) >= 0) { 1676 SSize_t count; 1677 for (count = 0; count <= av_tindex(MUTABLE_AV(sv)) && count < maxnest; count++) { 1678 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0); 1679 1680 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count); 1681 if (elt) 1682 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim); 1683 } 1684 } 1685 break; 1686 case SVt_PVHV: { 1687 U32 usedkeys; 1688 if (SvOOK(sv)) { 1689 struct xpvhv_aux *const aux = HvAUX(sv); 1690 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %"UVuf"\n", 1691 (UV)aux->xhv_aux_flags); 1692 } 1693 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv))); 1694 usedkeys = HvUSEDKEYS(sv); 1695 if (HvARRAY(sv) && usedkeys) { 1696 /* Show distribution of HEs in the ARRAY */ 1697 int freq[200]; 1698 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1)) 1699 int i; 1700 int max = 0; 1701 U32 pow2 = 2, keys = usedkeys; 1702 NV theoret, sum = 0; 1703 1704 PerlIO_printf(file, " ("); 1705 Zero(freq, FREQ_MAX + 1, int); 1706 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) { 1707 HE* h; 1708 int count = 0; 1709 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h)) 1710 count++; 1711 if (count > FREQ_MAX) 1712 count = FREQ_MAX; 1713 freq[count]++; 1714 if (max < count) 1715 max = count; 1716 } 1717 for (i = 0; i <= max; i++) { 1718 if (freq[i]) { 1719 PerlIO_printf(file, "%d%s:%d", i, 1720 (i == FREQ_MAX) ? "+" : "", 1721 freq[i]); 1722 if (i != max) 1723 PerlIO_printf(file, ", "); 1724 } 1725 } 1726 (void)PerlIO_putc(file, ')'); 1727 /* The "quality" of a hash is defined as the total number of 1728 comparisons needed to access every element once, relative 1729 to the expected number needed for a random hash. 1730 1731 The total number of comparisons is equal to the sum of 1732 the squares of the number of entries in each bucket. 1733 For a random hash of n keys into k buckets, the expected 1734 value is 1735 n + n(n-1)/2k 1736 */ 1737 1738 for (i = max; i > 0; i--) { /* Precision: count down. */ 1739 sum += freq[i] * i * i; 1740 } 1741 while ((keys = keys >> 1)) 1742 pow2 = pow2 << 1; 1743 theoret = usedkeys; 1744 theoret += theoret * (theoret-1)/pow2; 1745 (void)PerlIO_putc(file, '\n'); 1746 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100); 1747 } 1748 (void)PerlIO_putc(file, '\n'); 1749 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)usedkeys); 1750 { 1751 STRLEN count = 0; 1752 HE **ents = HvARRAY(sv); 1753 1754 if (ents) { 1755 HE *const *const last = ents + HvMAX(sv); 1756 count = last + 1 - ents; 1757 1758 do { 1759 if (!*ents) 1760 --count; 1761 } while (++ents <= last); 1762 } 1763 1764 if (SvOOK(sv)) { 1765 struct xpvhv_aux *const aux = HvAUX(sv); 1766 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf 1767 " (cached = %"UVuf")\n", 1768 (UV)count, (UV)aux->xhv_fill_lazy); 1769 } else { 1770 Perl_dump_indent(aTHX_ level, file, " FILL = %"UVuf"\n", 1771 (UV)count); 1772 } 1773 } 1774 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv)); 1775 if (SvOOK(sv)) { 1776 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv)); 1777 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv))); 1778 #ifdef PERL_HASH_RANDOMIZE_KEYS 1779 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%"UVxf, (UV)HvRAND_get(sv)); 1780 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) { 1781 PerlIO_printf(file, " (LAST = 0x%"UVxf")", (UV)HvLASTRAND_get(sv)); 1782 } 1783 #endif 1784 (void)PerlIO_putc(file, '\n'); 1785 } 1786 { 1787 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab); 1788 if (mg && mg->mg_obj) { 1789 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj)); 1790 } 1791 } 1792 { 1793 const char * const hvname = HvNAME_get(sv); 1794 if (hvname) { 1795 SV* tmpsv = newSVpvs_flags("", SVs_TEMP); 1796 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", 1797 generic_pv_escape( tmpsv, hvname, 1798 HvNAMELEN(sv), HvNAMEUTF8(sv))); 1799 } 1800 } 1801 if (SvOOK(sv)) { 1802 AV * const backrefs 1803 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv)); 1804 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta; 1805 if (HvAUX(sv)->xhv_name_count) 1806 Perl_dump_indent(aTHX_ 1807 level, file, " NAMECOUNT = %"IVdf"\n", 1808 (IV)HvAUX(sv)->xhv_name_count 1809 ); 1810 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) { 1811 const I32 count = HvAUX(sv)->xhv_name_count; 1812 if (count) { 1813 SV * const names = newSVpvs_flags("", SVs_TEMP); 1814 /* The starting point is the first element if count is 1815 positive and the second element if count is negative. */ 1816 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names 1817 + (count < 0 ? 1 : 0); 1818 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names 1819 + (count < 0 ? -count : count); 1820 while (hekp < endp) { 1821 if (HEK_LEN(*hekp)) { 1822 SV *tmp = newSVpvs_flags("", SVs_TEMP); 1823 Perl_sv_catpvf(aTHX_ names, ", \"%s\"", 1824 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp))); 1825 } else { 1826 /* This should never happen. */ 1827 sv_catpvs(names, ", (null)"); 1828 } 1829 ++hekp; 1830 } 1831 Perl_dump_indent(aTHX_ 1832 level, file, " ENAME = %s\n", SvPV_nolen(names)+2 1833 ); 1834 } 1835 else { 1836 SV * const tmp = newSVpvs_flags("", SVs_TEMP); 1837 const char *const hvename = HvENAME_get(sv); 1838 Perl_dump_indent(aTHX_ 1839 level, file, " ENAME = \"%s\"\n", 1840 generic_pv_escape(tmp, hvename, 1841 HvENAMELEN_get(sv), HvENAMEUTF8(sv))); 1842 } 1843 } 1844 if (backrefs) { 1845 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n", 1846 PTR2UV(backrefs)); 1847 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest, 1848 dumpops, pvlim); 1849 } 1850 if (meta) { 1851 SV* tmpsv = newSVpvs_flags("", SVs_TEMP); 1852 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%"UVxf")\n", 1853 generic_pv_escape( tmpsv, meta->mro_which->name, 1854 meta->mro_which->length, 1855 (meta->mro_which->kflags & HVhek_UTF8)), 1856 PTR2UV(meta->mro_which)); 1857 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%"UVxf"\n", 1858 (UV)meta->cache_gen); 1859 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%"UVxf"\n", 1860 (UV)meta->pkg_gen); 1861 if (meta->mro_linear_all) { 1862 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%"UVxf"\n", 1863 PTR2UV(meta->mro_linear_all)); 1864 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest, 1865 dumpops, pvlim); 1866 } 1867 if (meta->mro_linear_current) { 1868 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_CURRENT = 0x%"UVxf"\n", 1869 PTR2UV(meta->mro_linear_current)); 1870 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest, 1871 dumpops, pvlim); 1872 } 1873 if (meta->mro_nextmethod) { 1874 Perl_dump_indent(aTHX_ level, file, " MRO_NEXTMETHOD = 0x%"UVxf"\n", 1875 PTR2UV(meta->mro_nextmethod)); 1876 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest, 1877 dumpops, pvlim); 1878 } 1879 if (meta->isa) { 1880 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%"UVxf"\n", 1881 PTR2UV(meta->isa)); 1882 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest, 1883 dumpops, pvlim); 1884 } 1885 } 1886 } 1887 if (nest < maxnest) { 1888 HV * const hv = MUTABLE_HV(sv); 1889 STRLEN i; 1890 HE *he; 1891 1892 if (HvARRAY(hv)) { 1893 int count = maxnest - nest; 1894 for (i=0; i <= HvMAX(hv); i++) { 1895 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) { 1896 U32 hash; 1897 SV * keysv; 1898 const char * keypv; 1899 SV * elt; 1900 STRLEN len; 1901 1902 if (count-- <= 0) goto DONEHV; 1903 1904 hash = HeHASH(he); 1905 keysv = hv_iterkeysv(he); 1906 keypv = SvPV_const(keysv, len); 1907 elt = HeVAL(he); 1908 1909 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim)); 1910 if (SvUTF8(keysv)) 1911 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ)); 1912 if (HvEITER_get(hv) == he) 1913 PerlIO_printf(file, "[CURRENT] "); 1914 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV) hash); 1915 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim); 1916 } 1917 } 1918 DONEHV:; 1919 } 1920 } 1921 break; 1922 } /* case SVt_PVHV */ 1923 1924 case SVt_PVCV: 1925 if (CvAUTOLOAD(sv)) { 1926 SV* tmpsv = newSVpvs_flags("", SVs_TEMP); 1927 STRLEN len; 1928 const char *const name = SvPV_const(sv, len); 1929 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n", 1930 generic_pv_escape(tmpsv, name, len, SvUTF8(sv))); 1931 } 1932 if (SvPOK(sv)) { 1933 SV* tmpsv = newSVpvs_flags("", SVs_TEMP); 1934 const char *const proto = CvPROTO(sv); 1935 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n", 1936 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv), 1937 SvUTF8(sv))); 1938 } 1939 /* FALLTHROUGH */ 1940 case SVt_PVFM: 1941 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv)); 1942 if (!CvISXSUB(sv)) { 1943 if (CvSTART(sv)) { 1944 Perl_dump_indent(aTHX_ level, file, 1945 " START = 0x%"UVxf" ===> %"IVdf"\n", 1946 PTR2UV(CvSTART(sv)), 1947 (IV)sequence_num(CvSTART(sv))); 1948 } 1949 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n", 1950 PTR2UV(CvROOT(sv))); 1951 if (CvROOT(sv) && dumpops) { 1952 do_op_dump(level+1, file, CvROOT(sv)); 1953 } 1954 } else { 1955 SV * const constant = cv_const_sv((const CV *)sv); 1956 1957 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv))); 1958 1959 if (constant) { 1960 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf 1961 " (CONST SV)\n", 1962 PTR2UV(CvXSUBANY(sv).any_ptr)); 1963 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops, 1964 pvlim); 1965 } else { 1966 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n", 1967 (IV)CvXSUBANY(sv).any_i32); 1968 } 1969 } 1970 if (CvNAMED(sv)) 1971 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", 1972 HEK_KEY(CvNAME_HEK((CV *)sv))); 1973 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv)); 1974 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv)); 1975 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv)); 1976 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv)); 1977 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv)); 1978 if (!CvISXSUB(sv)) { 1979 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv))); 1980 if (nest < maxnest) { 1981 do_dump_pad(level+1, file, CvPADLIST(sv), 0); 1982 } 1983 } 1984 else 1985 Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv)); 1986 { 1987 const CV * const outside = CvOUTSIDE(sv); 1988 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n", 1989 PTR2UV(outside), 1990 (!outside ? "null" 1991 : CvANON(outside) ? "ANON" 1992 : (outside == PL_main_cv) ? "MAIN" 1993 : CvUNIQUE(outside) ? "UNIQUE" 1994 : CvGV(outside) ? 1995 generic_pv_escape( 1996 newSVpvs_flags("", SVs_TEMP), 1997 GvNAME(CvGV(outside)), 1998 GvNAMELEN(CvGV(outside)), 1999 GvNAMEUTF8(CvGV(outside))) 2000 : "UNDEFINED")); 2001 } 2002 if (CvOUTSIDE(sv) 2003 && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))) 2004 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim); 2005 break; 2006 2007 case SVt_PVGV: 2008 case SVt_PVLV: 2009 if (type == SVt_PVLV) { 2010 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv)); 2011 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv)); 2012 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv)); 2013 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv))); 2014 Perl_dump_indent(aTHX_ level, file, " FLAGS = %"IVdf"\n", (IV)LvFLAGS(sv)); 2015 if (isALPHA_FOLD_NE(LvTYPE(sv), 't')) 2016 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest, 2017 dumpops, pvlim); 2018 } 2019 if (isREGEXP(sv)) goto dumpregexp; 2020 if (!isGV_with_GP(sv)) 2021 break; 2022 { 2023 SV* tmpsv = newSVpvs_flags("", SVs_TEMP); 2024 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", 2025 generic_pv_escape(tmpsv, GvNAME(sv), 2026 GvNAMELEN(sv), 2027 GvNAMEUTF8(sv))); 2028 } 2029 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv)); 2030 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv)); 2031 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv)); 2032 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv))); 2033 if (!GvGP(sv)) 2034 break; 2035 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv))); 2036 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv)); 2037 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv))); 2038 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv))); 2039 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv))); 2040 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv))); 2041 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv))); 2042 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv)); 2043 Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%"UVxf 2044 " (%s)\n", 2045 (UV)GvGPFLAGS(sv), 2046 ""); 2047 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv)); 2048 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv)); 2049 do_gv_dump (level, file, " EGV", GvEGV(sv)); 2050 break; 2051 case SVt_PVIO: 2052 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv))); 2053 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv))); 2054 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv))); 2055 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv)); 2056 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv)); 2057 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv)); 2058 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv)); 2059 if (IoTOP_NAME(sv)) 2060 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv)); 2061 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV) 2062 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv)); 2063 else { 2064 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n", 2065 PTR2UV(IoTOP_GV(sv))); 2066 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1, 2067 maxnest, dumpops, pvlim); 2068 } 2069 /* Source filters hide things that are not GVs in these three, so let's 2070 be careful out there. */ 2071 if (IoFMT_NAME(sv)) 2072 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv)); 2073 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV) 2074 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv)); 2075 else { 2076 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n", 2077 PTR2UV(IoFMT_GV(sv))); 2078 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1, 2079 maxnest, dumpops, pvlim); 2080 } 2081 if (IoBOTTOM_NAME(sv)) 2082 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv)); 2083 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV) 2084 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv)); 2085 else { 2086 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n", 2087 PTR2UV(IoBOTTOM_GV(sv))); 2088 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1, 2089 maxnest, dumpops, pvlim); 2090 } 2091 if (isPRINT(IoTYPE(sv))) 2092 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv)); 2093 else 2094 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv)); 2095 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv)); 2096 break; 2097 case SVt_REGEXP: 2098 dumpregexp: 2099 { 2100 struct regexp * const r = ReANY((REGEXP*)sv); 2101 2102 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \ 2103 sv_setpv(d,""); \ 2104 append_flags(d, flags, names); \ 2105 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \ 2106 SvCUR_set(d, SvCUR(d) - 1); \ 2107 SvPVX(d)[SvCUR(d)] = '\0'; \ 2108 } \ 2109 } STMT_END 2110 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names); 2111 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%"UVxf" (%s)\n", 2112 (UV)(r->compflags), SvPVX_const(d)); 2113 2114 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names); 2115 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%"UVxf" (%s)\n", 2116 (UV)(r->extflags), SvPVX_const(d)); 2117 2118 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%"UVxf" (%s)\n", 2119 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" ); 2120 if (r->engine == &PL_core_reg_engine) { 2121 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names); 2122 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf" (%s)\n", 2123 (UV)(r->intflags), SvPVX_const(d)); 2124 } else { 2125 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%"UVxf"\n", 2126 (UV)(r->intflags)); 2127 } 2128 #undef SV_SET_STRINGIFY_REGEXP_FLAGS 2129 Perl_dump_indent(aTHX_ level, file, " NPARENS = %"UVuf"\n", 2130 (UV)(r->nparens)); 2131 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %"UVuf"\n", 2132 (UV)(r->lastparen)); 2133 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %"UVuf"\n", 2134 (UV)(r->lastcloseparen)); 2135 Perl_dump_indent(aTHX_ level, file, " MINLEN = %"IVdf"\n", 2136 (IV)(r->minlen)); 2137 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %"IVdf"\n", 2138 (IV)(r->minlenret)); 2139 Perl_dump_indent(aTHX_ level, file, " GOFS = %"UVuf"\n", 2140 (UV)(r->gofs)); 2141 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %"UVuf"\n", 2142 (UV)(r->pre_prefix)); 2143 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %"IVdf"\n", 2144 (IV)(r->sublen)); 2145 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %"IVdf"\n", 2146 (IV)(r->suboffset)); 2147 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %"IVdf"\n", 2148 (IV)(r->subcoffset)); 2149 if (r->subbeg) 2150 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%"UVxf" %s\n", 2151 PTR2UV(r->subbeg), 2152 pv_display(d, r->subbeg, r->sublen, 50, pvlim)); 2153 else 2154 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n"); 2155 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%"UVxf"\n", 2156 PTR2UV(r->mother_re)); 2157 if (nest < maxnest && r->mother_re) 2158 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1, 2159 maxnest, dumpops, pvlim); 2160 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%"UVxf"\n", 2161 PTR2UV(r->paren_names)); 2162 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%"UVxf"\n", 2163 PTR2UV(r->substrs)); 2164 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%"UVxf"\n", 2165 PTR2UV(r->pprivate)); 2166 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%"UVxf"\n", 2167 PTR2UV(r->offs)); 2168 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%"UVxf"\n", 2169 PTR2UV(r->qr_anoncv)); 2170 #ifdef PERL_ANY_COW 2171 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%"UVxf"\n", 2172 PTR2UV(r->saved_copy)); 2173 #endif 2174 } 2175 break; 2176 } 2177 SvREFCNT_dec_NN(d); 2178 } 2179 2180 /* 2181 =for apidoc sv_dump 2182 2183 Dumps the contents of an SV to the C<STDERR> filehandle. 2184 2185 For an example of its output, see L<Devel::Peek>. 2186 2187 =cut 2188 */ 2189 2190 void 2191 Perl_sv_dump(pTHX_ SV *sv) 2192 { 2193 PERL_ARGS_ASSERT_SV_DUMP; 2194 2195 if (SvROK(sv)) 2196 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0); 2197 else 2198 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0); 2199 } 2200 2201 int 2202 Perl_runops_debug(pTHX) 2203 { 2204 if (!PL_op) { 2205 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN"); 2206 return 0; 2207 } 2208 2209 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n")); 2210 do { 2211 #ifdef PERL_TRACE_OPS 2212 ++PL_op_exec_cnt[PL_op->op_type]; 2213 #endif 2214 if (PL_debug) { 2215 ENTER; 2216 SAVETMPS; 2217 if (PL_watchaddr && (*PL_watchaddr != PL_watchok)) 2218 PerlIO_printf(Perl_debug_log, 2219 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n", 2220 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok), 2221 PTR2UV(*PL_watchaddr)); 2222 if (DEBUG_s_TEST_) { 2223 if (DEBUG_v_TEST_) { 2224 PerlIO_printf(Perl_debug_log, "\n"); 2225 deb_stack_all(); 2226 } 2227 else 2228 debstack(); 2229 } 2230 2231 2232 if (DEBUG_t_TEST_) debop(PL_op); 2233 if (DEBUG_P_TEST_) debprof(PL_op); 2234 FREETMPS; 2235 LEAVE; 2236 } 2237 2238 PERL_DTRACE_PROBE_OP(PL_op); 2239 } while ((PL_op = PL_op->op_ppaddr(aTHX))); 2240 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n")); 2241 PERL_ASYNC_CHECK(); 2242 2243 TAINT_NOT; 2244 return 0; 2245 } 2246 2247 2248 /* print the names of the n lexical vars starting at pad offset off */ 2249 2250 STATIC void 2251 S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren) 2252 { 2253 PADNAME *sv; 2254 CV * const cv = deb_curcv(cxstack_ix); 2255 PADNAMELIST *comppad = NULL; 2256 int i; 2257 2258 if (cv) { 2259 PADLIST * const padlist = CvPADLIST(cv); 2260 comppad = PadlistNAMES(padlist); 2261 } 2262 if (paren) 2263 PerlIO_printf(Perl_debug_log, "("); 2264 for (i = 0; i < n; i++) { 2265 if (comppad && (sv = padnamelist_fetch(comppad, off + i))) 2266 PerlIO_printf(Perl_debug_log, "%"PNf, PNfARG(sv)); 2267 else 2268 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", 2269 (UV)(off+i)); 2270 if (i < n - 1) 2271 PerlIO_printf(Perl_debug_log, ","); 2272 } 2273 if (paren) 2274 PerlIO_printf(Perl_debug_log, ")"); 2275 } 2276 2277 2278 /* append to the out SV, the name of the lexical at offset off in the CV 2279 * cv */ 2280 2281 static void 2282 S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n, 2283 bool paren, bool is_scalar) 2284 { 2285 PADNAME *sv; 2286 PADNAMELIST *namepad = NULL; 2287 int i; 2288 2289 if (cv) { 2290 PADLIST * const padlist = CvPADLIST(cv); 2291 namepad = PadlistNAMES(padlist); 2292 } 2293 2294 if (paren) 2295 sv_catpvs_nomg(out, "("); 2296 for (i = 0; i < n; i++) { 2297 if (namepad && (sv = padnamelist_fetch(namepad, off + i))) 2298 { 2299 STRLEN cur = SvCUR(out); 2300 Perl_sv_catpvf(aTHX_ out, "[%"UTF8f, 2301 UTF8fARG(1, PadnameLEN(sv) - 1, 2302 PadnamePV(sv) + 1)); 2303 if (is_scalar) 2304 SvPVX(out)[cur] = '$'; 2305 } 2306 else 2307 Perl_sv_catpvf(aTHX_ out, "[%"UVuf"]", (UV)(off+i)); 2308 if (i < n - 1) 2309 sv_catpvs_nomg(out, ","); 2310 } 2311 if (paren) 2312 sv_catpvs_nomg(out, "("); 2313 } 2314 2315 2316 static void 2317 S_append_gv_name(pTHX_ GV *gv, SV *out) 2318 { 2319 SV *sv; 2320 if (!gv) { 2321 sv_catpvs_nomg(out, "<NULLGV>"); 2322 return; 2323 } 2324 sv = newSV(0); 2325 gv_fullname4(sv, gv, NULL, FALSE); 2326 Perl_sv_catpvf(aTHX_ out, "$%"SVf, SVfARG(sv)); 2327 SvREFCNT_dec_NN(sv); 2328 } 2329 2330 #ifdef USE_ITHREADS 2331 # define ITEM_SV(item) (comppad ? \ 2332 *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL); 2333 #else 2334 # define ITEM_SV(item) UNOP_AUX_item_sv(item) 2335 #endif 2336 2337 2338 /* return a temporary SV containing a stringified representation of 2339 * the op_aux field of a MULTIDEREF op, associated with CV cv 2340 */ 2341 2342 SV* 2343 Perl_multideref_stringify(pTHX_ const OP *o, CV *cv) 2344 { 2345 UNOP_AUX_item *items = cUNOP_AUXo->op_aux; 2346 UV actions = items->uv; 2347 SV *sv; 2348 bool last = 0; 2349 bool is_hash = FALSE; 2350 int derefs = 0; 2351 SV *out = newSVpvn_flags("",0,SVs_TEMP); 2352 #ifdef USE_ITHREADS 2353 PAD *comppad; 2354 2355 if (cv) { 2356 PADLIST *padlist = CvPADLIST(cv); 2357 comppad = PadlistARRAY(padlist)[1]; 2358 } 2359 else 2360 comppad = NULL; 2361 #endif 2362 2363 PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY; 2364 2365 while (!last) { 2366 switch (actions & MDEREF_ACTION_MASK) { 2367 2368 case MDEREF_reload: 2369 actions = (++items)->uv; 2370 continue; 2371 NOT_REACHED; /* NOTREACHED */ 2372 2373 case MDEREF_HV_padhv_helem: 2374 is_hash = TRUE; 2375 /* FALLTHROUGH */ 2376 case MDEREF_AV_padav_aelem: 2377 derefs = 1; 2378 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1); 2379 goto do_elem; 2380 NOT_REACHED; /* NOTREACHED */ 2381 2382 case MDEREF_HV_gvhv_helem: 2383 is_hash = TRUE; 2384 /* FALLTHROUGH */ 2385 case MDEREF_AV_gvav_aelem: 2386 derefs = 1; 2387 items++; 2388 sv = ITEM_SV(items); 2389 S_append_gv_name(aTHX_ (GV*)sv, out); 2390 goto do_elem; 2391 NOT_REACHED; /* NOTREACHED */ 2392 2393 case MDEREF_HV_gvsv_vivify_rv2hv_helem: 2394 is_hash = TRUE; 2395 /* FALLTHROUGH */ 2396 case MDEREF_AV_gvsv_vivify_rv2av_aelem: 2397 items++; 2398 sv = ITEM_SV(items); 2399 S_append_gv_name(aTHX_ (GV*)sv, out); 2400 goto do_vivify_rv2xv_elem; 2401 NOT_REACHED; /* NOTREACHED */ 2402 2403 case MDEREF_HV_padsv_vivify_rv2hv_helem: 2404 is_hash = TRUE; 2405 /* FALLTHROUGH */ 2406 case MDEREF_AV_padsv_vivify_rv2av_aelem: 2407 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1); 2408 goto do_vivify_rv2xv_elem; 2409 NOT_REACHED; /* NOTREACHED */ 2410 2411 case MDEREF_HV_pop_rv2hv_helem: 2412 case MDEREF_HV_vivify_rv2hv_helem: 2413 is_hash = TRUE; 2414 /* FALLTHROUGH */ 2415 do_vivify_rv2xv_elem: 2416 case MDEREF_AV_pop_rv2av_aelem: 2417 case MDEREF_AV_vivify_rv2av_aelem: 2418 if (!derefs++) 2419 sv_catpvs_nomg(out, "->"); 2420 do_elem: 2421 if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) { 2422 sv_catpvs_nomg(out, "->"); 2423 last = 1; 2424 break; 2425 } 2426 2427 sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1); 2428 switch (actions & MDEREF_INDEX_MASK) { 2429 case MDEREF_INDEX_const: 2430 if (is_hash) { 2431 items++; 2432 sv = ITEM_SV(items); 2433 if (!sv) 2434 sv_catpvs_nomg(out, "???"); 2435 else { 2436 STRLEN cur; 2437 char *s; 2438 s = SvPV(sv, cur); 2439 pv_pretty(out, s, cur, 30, 2440 NULL, NULL, 2441 (PERL_PV_PRETTY_NOCLEAR 2442 |PERL_PV_PRETTY_QUOTE 2443 |PERL_PV_PRETTY_ELLIPSES)); 2444 } 2445 } 2446 else 2447 Perl_sv_catpvf(aTHX_ out, "%"IVdf, (++items)->iv); 2448 break; 2449 case MDEREF_INDEX_padsv: 2450 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1); 2451 break; 2452 case MDEREF_INDEX_gvsv: 2453 items++; 2454 sv = ITEM_SV(items); 2455 S_append_gv_name(aTHX_ (GV*)sv, out); 2456 break; 2457 } 2458 sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1); 2459 2460 if (actions & MDEREF_FLAG_last) 2461 last = 1; 2462 is_hash = FALSE; 2463 2464 break; 2465 2466 default: 2467 PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)", 2468 (int)(actions & MDEREF_ACTION_MASK)); 2469 last = 1; 2470 break; 2471 2472 } /* switch */ 2473 2474 actions >>= MDEREF_SHIFT; 2475 } /* while */ 2476 return out; 2477 } 2478 2479 2480 I32 2481 Perl_debop(pTHX_ const OP *o) 2482 { 2483 PERL_ARGS_ASSERT_DEBOP; 2484 2485 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_) 2486 return 0; 2487 2488 Perl_deb(aTHX_ "%s", OP_NAME(o)); 2489 switch (o->op_type) { 2490 case OP_CONST: 2491 case OP_HINTSEVAL: 2492 /* With ITHREADS, consts are stored in the pad, and the right pad 2493 * may not be active here, so check. 2494 * Looks like only during compiling the pads are illegal. 2495 */ 2496 #ifdef USE_ITHREADS 2497 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME) 2498 #endif 2499 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv)); 2500 break; 2501 case OP_GVSV: 2502 case OP_GV: 2503 if (cGVOPo_gv && isGV(cGVOPo_gv)) { 2504 SV * const sv = newSV(0); 2505 gv_fullname3(sv, cGVOPo_gv, NULL); 2506 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv)); 2507 SvREFCNT_dec_NN(sv); 2508 } 2509 else if (cGVOPo_gv) { 2510 SV * const sv = newSV(0); 2511 assert(SvROK(cGVOPo_gv)); 2512 assert(SvTYPE(SvRV(cGVOPo_gv)) == SVt_PVCV); 2513 PerlIO_printf(Perl_debug_log, "(cv ref: %s)", 2514 SvPV_nolen_const(cv_name((CV *)SvRV(cGVOPo_gv),sv,0))); 2515 SvREFCNT_dec_NN(sv); 2516 } 2517 else 2518 PerlIO_printf(Perl_debug_log, "(NULL)"); 2519 break; 2520 2521 case OP_PADSV: 2522 case OP_PADAV: 2523 case OP_PADHV: 2524 S_deb_padvar(aTHX_ o->op_targ, 1, 1); 2525 break; 2526 2527 case OP_PADRANGE: 2528 S_deb_padvar(aTHX_ o->op_targ, 2529 o->op_private & OPpPADRANGE_COUNTMASK, 1); 2530 break; 2531 2532 case OP_MULTIDEREF: 2533 PerlIO_printf(Perl_debug_log, "(%"SVf")", 2534 SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix)))); 2535 break; 2536 2537 default: 2538 break; 2539 } 2540 PerlIO_printf(Perl_debug_log, "\n"); 2541 return 0; 2542 } 2543 2544 STATIC CV* 2545 S_deb_curcv(pTHX_ I32 ix) 2546 { 2547 PERL_SI *si = PL_curstackinfo; 2548 for (; ix >=0; ix--) { 2549 const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix]; 2550 2551 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) 2552 return cx->blk_sub.cv; 2553 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx)) 2554 return cx->blk_eval.cv; 2555 else if (ix == 0 && si->si_type == PERLSI_MAIN) 2556 return PL_main_cv; 2557 else if (ix == 0 && CxTYPE(cx) == CXt_NULL 2558 && si->si_type == PERLSI_SORT) 2559 { 2560 /* fake sort sub; use CV of caller */ 2561 si = si->si_prev; 2562 ix = si->si_cxix + 1; 2563 } 2564 } 2565 return NULL; 2566 } 2567 2568 void 2569 Perl_watch(pTHX_ char **addr) 2570 { 2571 PERL_ARGS_ASSERT_WATCH; 2572 2573 PL_watchaddr = addr; 2574 PL_watchok = *addr; 2575 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n", 2576 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok)); 2577 } 2578 2579 STATIC void 2580 S_debprof(pTHX_ const OP *o) 2581 { 2582 PERL_ARGS_ASSERT_DEBPROF; 2583 2584 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash)) 2585 return; 2586 if (!PL_profiledata) 2587 Newxz(PL_profiledata, MAXO, U32); 2588 ++PL_profiledata[o->op_type]; 2589 } 2590 2591 void 2592 Perl_debprofdump(pTHX) 2593 { 2594 unsigned i; 2595 if (!PL_profiledata) 2596 return; 2597 for (i = 0; i < MAXO; i++) { 2598 if (PL_profiledata[i]) 2599 PerlIO_printf(Perl_debug_log, 2600 "%5lu %s\n", (unsigned long)PL_profiledata[i], 2601 PL_op_name[i]); 2602 } 2603 } 2604 2605 2606 /* 2607 * ex: set ts=8 sts=4 sw=4 et: 2608 */ 2609