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 SvPVCLEAR(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 SvPVCLEAR(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 SvPVCLEAR(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 373 || sv == &PL_sv_zero || sv == &PL_sv_placeholder) 374 { 375 if (sv == &PL_sv_undef) { 376 sv_catpv(t, "SV_UNDEF"); 377 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT| 378 SVs_GMG|SVs_SMG|SVs_RMG)) && 379 SvREADONLY(sv)) 380 goto finish; 381 } 382 else if (sv == &PL_sv_no) { 383 sv_catpv(t, "SV_NO"); 384 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| 385 SVs_GMG|SVs_SMG|SVs_RMG)) && 386 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| 387 SVp_POK|SVp_NOK)) && 388 SvCUR(sv) == 0 && 389 SvNVX(sv) == 0.0) 390 goto finish; 391 } 392 else if (sv == &PL_sv_yes) { 393 sv_catpv(t, "SV_YES"); 394 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| 395 SVs_GMG|SVs_SMG|SVs_RMG)) && 396 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| 397 SVp_POK|SVp_NOK)) && 398 SvCUR(sv) == 1 && 399 SvPVX_const(sv) && *SvPVX_const(sv) == '1' && 400 SvNVX(sv) == 1.0) 401 goto finish; 402 } 403 else if (sv == &PL_sv_zero) { 404 sv_catpv(t, "SV_ZERO"); 405 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| 406 SVs_GMG|SVs_SMG|SVs_RMG)) && 407 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| 408 SVp_POK|SVp_NOK)) && 409 SvCUR(sv) == 1 && 410 SvPVX_const(sv) && *SvPVX_const(sv) == '0' && 411 SvNVX(sv) == 0.0) 412 goto finish; 413 } 414 else { 415 sv_catpv(t, "SV_PLACEHOLDER"); 416 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT| 417 SVs_GMG|SVs_SMG|SVs_RMG)) && 418 SvREADONLY(sv)) 419 goto finish; 420 } 421 sv_catpv(t, ":"); 422 } 423 else if (SvREFCNT(sv) == 0) { 424 sv_catpv(t, "("); 425 unref++; 426 } 427 else if (DEBUG_R_TEST_) { 428 int is_tmp = 0; 429 SSize_t ix; 430 /* is this SV on the tmps stack? */ 431 for (ix=PL_tmps_ix; ix>=0; ix--) { 432 if (PL_tmps_stack[ix] == sv) { 433 is_tmp = 1; 434 break; 435 } 436 } 437 if (is_tmp || SvREFCNT(sv) > 1) { 438 Perl_sv_catpvf(aTHX_ t, "<"); 439 if (SvREFCNT(sv) > 1) 440 Perl_sv_catpvf(aTHX_ t, "%" UVuf, (UV)SvREFCNT(sv)); 441 if (is_tmp) 442 Perl_sv_catpvf(aTHX_ t, "%s", SvTEMP(t) ? "T" : "t"); 443 Perl_sv_catpvf(aTHX_ t, ">"); 444 } 445 } 446 447 if (SvROK(sv)) { 448 sv_catpv(t, "\\"); 449 if (SvCUR(t) + unref > 10) { 450 SvCUR_set(t, unref + 3); 451 *SvEND(t) = '\0'; 452 sv_catpv(t, "..."); 453 goto finish; 454 } 455 sv = SvRV(sv); 456 goto retry; 457 } 458 type = SvTYPE(sv); 459 if (type == SVt_PVCV) { 460 SV * const tmp = newSVpvs_flags("", SVs_TEMP); 461 GV* gvcv = CvGV(sv); 462 Perl_sv_catpvf(aTHX_ t, "CV(%s)", gvcv 463 ? generic_pv_escape( tmp, GvNAME(gvcv), GvNAMELEN(gvcv), GvNAMEUTF8(gvcv)) 464 : ""); 465 goto finish; 466 } else if (type < SVt_LAST) { 467 sv_catpv(t, svshorttypenames[type]); 468 469 if (type == SVt_NULL) 470 goto finish; 471 } else { 472 sv_catpv(t, "FREED"); 473 goto finish; 474 } 475 476 if (SvPOKp(sv)) { 477 if (!SvPVX_const(sv)) 478 sv_catpv(t, "(null)"); 479 else { 480 SV * const tmp = newSVpvs(""); 481 sv_catpv(t, "("); 482 if (SvOOK(sv)) { 483 STRLEN delta; 484 SvOOK_offset(sv, delta); 485 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-delta, delta, 0, 127)); 486 } 487 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127)); 488 if (SvUTF8(sv)) 489 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]", 490 sv_uni_display(tmp, sv, 6 * SvCUR(sv), 491 UNI_DISPLAY_QQ)); 492 SvREFCNT_dec_NN(tmp); 493 } 494 } 495 else if (SvNOKp(sv)) { 496 DECLARATION_FOR_LC_NUMERIC_MANIPULATION; 497 STORE_LC_NUMERIC_SET_STANDARD(); 498 Perl_sv_catpvf(aTHX_ t, "(%" NVgf ")",SvNVX(sv)); 499 RESTORE_LC_NUMERIC(); 500 } 501 else if (SvIOKp(sv)) { 502 if (SvIsUV(sv)) 503 Perl_sv_catpvf(aTHX_ t, "(%" UVuf ")", (UV)SvUVX(sv)); 504 else 505 Perl_sv_catpvf(aTHX_ t, "(%" IVdf ")", (IV)SvIVX(sv)); 506 } 507 else 508 sv_catpv(t, "()"); 509 510 finish: 511 while (unref--) 512 sv_catpv(t, ")"); 513 if (TAINTING_get && sv && SvTAINTED(sv)) 514 sv_catpv(t, " [tainted]"); 515 return SvPV_nolen(t); 516 } 517 518 /* 519 =head1 Debugging Utilities 520 */ 521 522 void 523 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...) 524 { 525 va_list args; 526 PERL_ARGS_ASSERT_DUMP_INDENT; 527 va_start(args, pat); 528 dump_vindent(level, file, pat, &args); 529 va_end(args); 530 } 531 532 void 533 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args) 534 { 535 PERL_ARGS_ASSERT_DUMP_VINDENT; 536 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), ""); 537 PerlIO_vprintf(file, pat, *args); 538 } 539 540 541 /* Like Perl_dump_indent(), but specifically for ops: adds a vertical bar 542 * for each indent level as appropriate. 543 * 544 * bar contains bits indicating which indent columns should have a 545 * vertical bar displayed. Bit 0 is the RH-most column. If there are more 546 * levels than bits in bar, then the first few indents are displayed 547 * without a bar. 548 * 549 * The start of a new op is signalled by passing a value for level which 550 * has been negated and offset by 1 (so that level 0 is passed as -1 and 551 * can thus be distinguished from -0); in this case, emit a suitably 552 * indented blank line, then on the next line, display the op's sequence 553 * number, and make the final indent an '+----'. 554 * 555 * e.g. 556 * 557 * | FOO # level = 1, bar = 0b1 558 * | | # level =-2-1, bar = 0b11 559 * 1234 | +---BAR 560 * | BAZ # level = 2, bar = 0b10 561 */ 562 563 static void 564 S_opdump_indent(pTHX_ const OP *o, I32 level, UV bar, PerlIO *file, 565 const char* pat, ...) 566 { 567 va_list args; 568 I32 i; 569 bool newop = (level < 0); 570 571 va_start(args, pat); 572 573 /* start displaying a new op? */ 574 if (newop) { 575 UV seq = sequence_num(o); 576 577 level = -level - 1; 578 579 /* output preceding blank line */ 580 PerlIO_puts(file, " "); 581 for (i = level-1; i >= 0; i--) 582 PerlIO_puts(file, ( i == 0 583 || (i < UVSIZE*8 && (bar & ((UV)1 << i))) 584 ) 585 ? "| " : " "); 586 PerlIO_puts(file, "\n"); 587 588 /* output sequence number */ 589 if (seq) 590 PerlIO_printf(file, "%-4" UVuf " ", seq); 591 else 592 PerlIO_puts(file, "???? "); 593 594 } 595 else 596 PerlIO_printf(file, " "); 597 598 for (i = level-1; i >= 0; i--) 599 PerlIO_puts(file, 600 (i == 0 && newop) ? "+--" 601 : (bar & (1 << i)) ? "| " 602 : " "); 603 PerlIO_vprintf(file, pat, args); 604 va_end(args); 605 } 606 607 608 /* display a link field (e.g. op_next) in the format 609 * ====> sequence_number [opname 0x123456] 610 */ 611 612 static void 613 S_opdump_link(pTHX_ const OP *base, const OP *o, PerlIO *file) 614 { 615 PerlIO_puts(file, " ===> "); 616 if (o == base) 617 PerlIO_puts(file, "[SELF]\n"); 618 else if (o) 619 PerlIO_printf(file, "%" UVuf " [%s 0x%" UVxf "]\n", 620 sequence_num(o), OP_NAME(o), PTR2UV(o)); 621 else 622 PerlIO_puts(file, "[0x0]\n"); 623 } 624 625 /* 626 =for apidoc dump_all 627 628 Dumps the entire optree of the current program starting at C<PL_main_root> to 629 C<STDERR>. Also dumps the optrees for all visible subroutines in 630 C<PL_defstash>. 631 632 =cut 633 */ 634 635 void 636 Perl_dump_all(pTHX) 637 { 638 dump_all_perl(FALSE); 639 } 640 641 void 642 Perl_dump_all_perl(pTHX_ bool justperl) 643 { 644 PerlIO_setlinebuf(Perl_debug_log); 645 if (PL_main_root) 646 op_dump(PL_main_root); 647 dump_packsubs_perl(PL_defstash, justperl); 648 } 649 650 /* 651 =for apidoc dump_packsubs 652 653 Dumps the optrees for all visible subroutines in C<stash>. 654 655 =cut 656 */ 657 658 void 659 Perl_dump_packsubs(pTHX_ const HV *stash) 660 { 661 PERL_ARGS_ASSERT_DUMP_PACKSUBS; 662 dump_packsubs_perl(stash, FALSE); 663 } 664 665 void 666 Perl_dump_packsubs_perl(pTHX_ const HV *stash, bool justperl) 667 { 668 I32 i; 669 670 PERL_ARGS_ASSERT_DUMP_PACKSUBS_PERL; 671 672 if (!HvARRAY(stash)) 673 return; 674 for (i = 0; i <= (I32) HvMAX(stash); i++) { 675 const HE *entry; 676 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { 677 GV * gv = (GV *)HeVAL(entry); 678 if (SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV) 679 /* unfake a fake GV */ 680 (void)CvGV(SvRV(gv)); 681 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv)) 682 continue; 683 if (GvCVu(gv)) 684 dump_sub_perl(gv, justperl); 685 if (GvFORM(gv)) 686 dump_form(gv); 687 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') { 688 const HV * const hv = GvHV(gv); 689 if (hv && (hv != PL_defstash)) 690 dump_packsubs_perl(hv, justperl); /* nested package */ 691 } 692 } 693 } 694 } 695 696 void 697 Perl_dump_sub(pTHX_ const GV *gv) 698 { 699 PERL_ARGS_ASSERT_DUMP_SUB; 700 dump_sub_perl(gv, FALSE); 701 } 702 703 void 704 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl) 705 { 706 CV *cv; 707 708 PERL_ARGS_ASSERT_DUMP_SUB_PERL; 709 710 cv = isGV_with_GP(gv) ? GvCV(gv) : 711 (assert(SvROK((SV*)gv)), (CV*)SvRV((SV*)gv)); 712 if (justperl && (CvISXSUB(cv) || !CvROOT(cv))) 713 return; 714 715 if (isGV_with_GP(gv)) { 716 SV * const namesv = newSVpvs_flags("", SVs_TEMP); 717 SV *escsv = newSVpvs_flags("", SVs_TEMP); 718 const char *namepv; 719 STRLEN namelen; 720 gv_fullname3(namesv, gv, NULL); 721 namepv = SvPV_const(namesv, namelen); 722 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", 723 generic_pv_escape(escsv, namepv, namelen, SvUTF8(namesv))); 724 } else { 725 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB = "); 726 } 727 if (CvISXSUB(cv)) 728 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%" UVxf " %d)\n", 729 PTR2UV(CvXSUB(cv)), 730 (int)CvXSUBANY(cv).any_i32); 731 else if (CvROOT(cv)) 732 op_dump(CvROOT(cv)); 733 else 734 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n"); 735 } 736 737 void 738 Perl_dump_form(pTHX_ const GV *gv) 739 { 740 SV * const sv = sv_newmortal(); 741 742 PERL_ARGS_ASSERT_DUMP_FORM; 743 744 gv_fullname3(sv, gv, NULL); 745 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv)); 746 if (CvROOT(GvFORM(gv))) 747 op_dump(CvROOT(GvFORM(gv))); 748 else 749 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n"); 750 } 751 752 void 753 Perl_dump_eval(pTHX) 754 { 755 op_dump(PL_eval_root); 756 } 757 758 759 /* returns a temp SV displaying the name of a GV. Handles the case where 760 * a GV is in fact a ref to a CV */ 761 762 static SV * 763 S_gv_display(pTHX_ GV *gv) 764 { 765 SV * const name = newSVpvs_flags("", SVs_TEMP); 766 if (gv) { 767 SV * const raw = newSVpvs_flags("", SVs_TEMP); 768 STRLEN len; 769 const char * rawpv; 770 771 if (isGV_with_GP(gv)) 772 gv_fullname3(raw, gv, NULL); 773 else { 774 assert(SvROK(gv)); 775 assert(SvTYPE(SvRV(gv)) == SVt_PVCV); 776 Perl_sv_catpvf(aTHX_ raw, "cv ref: %s", 777 SvPV_nolen_const(cv_name((CV *)SvRV(gv), name, 0))); 778 } 779 rawpv = SvPV_const(raw, len); 780 generic_pv_escape(name, rawpv, len, SvUTF8(raw)); 781 } 782 else 783 sv_catpvs(name, "(NULL)"); 784 785 return name; 786 } 787 788 789 790 /* forward decl */ 791 static void 792 S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o); 793 794 795 static void 796 S_do_pmop_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const PMOP *pm) 797 { 798 UV kidbar; 799 800 if (!pm) 801 return; 802 803 kidbar = ((bar << 1) | cBOOL(pm->op_flags & OPf_KIDS)) << 1; 804 805 if (PM_GETRE(pm)) { 806 char ch = (pm->op_pmflags & PMf_ONCE) ? '?' : '/'; 807 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE %c%.*s%c\n", 808 ch,(int)RX_PRELEN(PM_GETRE(pm)), RX_PRECOMP(PM_GETRE(pm)), ch); 809 } 810 else 811 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_PRE (RUNTIME)\n"); 812 813 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) { 814 SV * const tmpsv = pm_description(pm); 815 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMFLAGS = (%s)\n", 816 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : ""); 817 SvREFCNT_dec_NN(tmpsv); 818 } 819 820 if (pm->op_type == OP_SPLIT) 821 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, 822 "TARGOFF/GV = 0x%" UVxf "\n", 823 PTR2UV(pm->op_pmreplrootu.op_pmtargetgv)); 824 else { 825 if (pm->op_pmreplrootu.op_pmreplroot) { 826 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "PMf_REPL =\n"); 827 S_do_op_dump_bar(aTHX_ level + 2, 828 (kidbar|cBOOL(OpHAS_SIBLING(pm->op_pmreplrootu.op_pmreplroot))), 829 file, pm->op_pmreplrootu.op_pmreplroot); 830 } 831 } 832 833 if (pm->op_code_list) { 834 if (pm->op_pmflags & PMf_CODELIST_PRIVATE) { 835 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, "CODE_LIST =\n"); 836 S_do_op_dump_bar(aTHX_ level + 2, 837 (kidbar | cBOOL(OpHAS_SIBLING(pm->op_code_list))), 838 file, pm->op_code_list); 839 } 840 else 841 S_opdump_indent(aTHX_ (OP*)pm, level, bar, file, 842 "CODE_LIST = 0x%" UVxf "\n", PTR2UV(pm->op_code_list)); 843 } 844 } 845 846 847 void 848 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm) 849 { 850 PERL_ARGS_ASSERT_DO_PMOP_DUMP; 851 S_do_pmop_dump_bar(aTHX_ level, 0, file, pm); 852 } 853 854 855 const struct flag_to_name pmflags_flags_names[] = { 856 {PMf_CONST, ",CONST"}, 857 {PMf_KEEP, ",KEEP"}, 858 {PMf_GLOBAL, ",GLOBAL"}, 859 {PMf_CONTINUE, ",CONTINUE"}, 860 {PMf_RETAINT, ",RETAINT"}, 861 {PMf_EVAL, ",EVAL"}, 862 {PMf_NONDESTRUCT, ",NONDESTRUCT"}, 863 {PMf_HAS_CV, ",HAS_CV"}, 864 {PMf_CODELIST_PRIVATE, ",CODELIST_PRIVATE"}, 865 {PMf_IS_QR, ",IS_QR"} 866 }; 867 868 static SV * 869 S_pm_description(pTHX_ const PMOP *pm) 870 { 871 SV * const desc = newSVpvs(""); 872 const REGEXP * const regex = PM_GETRE(pm); 873 const U32 pmflags = pm->op_pmflags; 874 875 PERL_ARGS_ASSERT_PM_DESCRIPTION; 876 877 if (pmflags & PMf_ONCE) 878 sv_catpv(desc, ",ONCE"); 879 #ifdef USE_ITHREADS 880 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset])) 881 sv_catpv(desc, ":USED"); 882 #else 883 if (pmflags & PMf_USED) 884 sv_catpv(desc, ":USED"); 885 #endif 886 887 if (regex) { 888 if (RX_ISTAINTED(regex)) 889 sv_catpv(desc, ",TAINTED"); 890 if (RX_CHECK_SUBSTR(regex)) { 891 if (!(RX_INTFLAGS(regex) & PREGf_NOSCAN)) 892 sv_catpv(desc, ",SCANFIRST"); 893 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL) 894 sv_catpv(desc, ",ALL"); 895 } 896 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE) 897 sv_catpv(desc, ",SKIPWHITE"); 898 } 899 900 append_flags(desc, pmflags, pmflags_flags_names); 901 return desc; 902 } 903 904 void 905 Perl_pmop_dump(pTHX_ PMOP *pm) 906 { 907 do_pmop_dump(0, Perl_debug_log, pm); 908 } 909 910 /* Return a unique integer to represent the address of op o. 911 * If it already exists in PL_op_sequence, just return it; 912 * otherwise add it. 913 * *** Note that this isn't thread-safe */ 914 915 STATIC UV 916 S_sequence_num(pTHX_ const OP *o) 917 { 918 dVAR; 919 SV *op, 920 **seq; 921 const char *key; 922 STRLEN len; 923 if (!o) 924 return 0; 925 op = newSVuv(PTR2UV(o)); 926 sv_2mortal(op); 927 key = SvPV_const(op, len); 928 if (!PL_op_sequence) 929 PL_op_sequence = newHV(); 930 seq = hv_fetch(PL_op_sequence, key, len, 0); 931 if (seq) 932 return SvUV(*seq); 933 (void)hv_store(PL_op_sequence, key, len, newSVuv(++PL_op_seq), 0); 934 return PL_op_seq; 935 } 936 937 938 939 940 941 const struct flag_to_name op_flags_names[] = { 942 {OPf_KIDS, ",KIDS"}, 943 {OPf_PARENS, ",PARENS"}, 944 {OPf_REF, ",REF"}, 945 {OPf_MOD, ",MOD"}, 946 {OPf_STACKED, ",STACKED"}, 947 {OPf_SPECIAL, ",SPECIAL"} 948 }; 949 950 951 /* indexed by enum OPclass */ 952 const char * const op_class_names[] = { 953 "NULL", 954 "OP", 955 "UNOP", 956 "BINOP", 957 "LOGOP", 958 "LISTOP", 959 "PMOP", 960 "SVOP", 961 "PADOP", 962 "PVOP", 963 "LOOP", 964 "COP", 965 "METHOP", 966 "UNOP_AUX", 967 }; 968 969 970 /* dump an op and any children. level indicates the initial indent. 971 * The bits of bar indicate which indents should receive a vertical bar. 972 * For example if level == 5 and bar == 0b01101, then the indent prefix 973 * emitted will be (not including the <>'s): 974 * 975 * < | | | > 976 * 55554444333322221111 977 * 978 * For heavily nested output, the level may exceed the number of bits 979 * in bar; in this case the first few columns in the output will simply 980 * not have a bar, which is harmless. 981 */ 982 983 static void 984 S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o) 985 { 986 const OPCODE optype = o->op_type; 987 988 PERL_ARGS_ASSERT_DO_OP_DUMP; 989 990 /* print op header line */ 991 992 S_opdump_indent(aTHX_ o, -level-1, bar, file, "%s", OP_NAME(o)); 993 994 if (optype == OP_NULL && o->op_targ) 995 PerlIO_printf(file, " (ex-%s)",PL_op_name[o->op_targ]); 996 997 PerlIO_printf(file, " %s(0x%" UVxf ")", 998 op_class_names[op_class(o)], PTR2UV(o)); 999 S_opdump_link(aTHX_ o, o->op_next, file); 1000 1001 /* print op common fields */ 1002 1003 if (level == 0) { 1004 S_opdump_indent(aTHX_ o, level, bar, file, "PARENT"); 1005 S_opdump_link(aTHX_ o, op_parent((OP*)o), file); 1006 } 1007 1008 if (o->op_targ && optype != OP_NULL) 1009 S_opdump_indent(aTHX_ o, level, bar, file, "TARG = %ld\n", 1010 (long)o->op_targ); 1011 1012 if (o->op_flags || o->op_slabbed || o->op_savefree || o->op_static) { 1013 SV * const tmpsv = newSVpvs(""); 1014 switch (o->op_flags & OPf_WANT) { 1015 case OPf_WANT_VOID: 1016 sv_catpv(tmpsv, ",VOID"); 1017 break; 1018 case OPf_WANT_SCALAR: 1019 sv_catpv(tmpsv, ",SCALAR"); 1020 break; 1021 case OPf_WANT_LIST: 1022 sv_catpv(tmpsv, ",LIST"); 1023 break; 1024 default: 1025 sv_catpv(tmpsv, ",UNKNOWN"); 1026 break; 1027 } 1028 append_flags(tmpsv, o->op_flags, op_flags_names); 1029 if (o->op_slabbed) sv_catpvs(tmpsv, ",SLABBED"); 1030 if (o->op_savefree) sv_catpvs(tmpsv, ",SAVEFREE"); 1031 if (o->op_static) sv_catpvs(tmpsv, ",STATIC"); 1032 if (o->op_folded) sv_catpvs(tmpsv, ",FOLDED"); 1033 if (o->op_moresib) sv_catpvs(tmpsv, ",MORESIB"); 1034 S_opdump_indent(aTHX_ o, level, bar, file, "FLAGS = (%s)\n", 1035 SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : ""); 1036 } 1037 1038 if (o->op_private) { 1039 U16 oppriv = o->op_private; 1040 I16 op_ix = PL_op_private_bitdef_ix[o->op_type]; 1041 SV * tmpsv = NULL; 1042 1043 if (op_ix != -1) { 1044 U16 stop = 0; 1045 tmpsv = newSVpvs(""); 1046 for (; !stop; op_ix++) { 1047 U16 entry = PL_op_private_bitdefs[op_ix]; 1048 U16 bit = (entry >> 2) & 7; 1049 U16 ix = entry >> 5; 1050 1051 stop = (entry & 1); 1052 1053 if (entry & 2) { 1054 /* bitfield */ 1055 I16 const *p = &PL_op_private_bitfields[ix]; 1056 U16 bitmin = (U16) *p++; 1057 I16 label = *p++; 1058 I16 enum_label; 1059 U16 mask = 0; 1060 U16 i; 1061 U16 val; 1062 1063 for (i = bitmin; i<= bit; i++) 1064 mask |= (1<<i); 1065 bit = bitmin; 1066 val = (oppriv & mask); 1067 1068 if ( label != -1 1069 && PL_op_private_labels[label] == '-' 1070 && PL_op_private_labels[label+1] == '\0' 1071 ) 1072 /* display as raw number */ 1073 continue; 1074 1075 oppriv -= val; 1076 val >>= bit; 1077 enum_label = -1; 1078 while (*p != -1) { 1079 if (val == *p++) { 1080 enum_label = *p; 1081 break; 1082 } 1083 p++; 1084 } 1085 if (val == 0 && enum_label == -1) 1086 /* don't display anonymous zero values */ 1087 continue; 1088 1089 sv_catpv(tmpsv, ","); 1090 if (label != -1) { 1091 sv_catpv(tmpsv, &PL_op_private_labels[label]); 1092 sv_catpv(tmpsv, "="); 1093 } 1094 if (enum_label == -1) 1095 Perl_sv_catpvf(aTHX_ tmpsv, "0x%" UVxf, (UV)val); 1096 else 1097 sv_catpv(tmpsv, &PL_op_private_labels[enum_label]); 1098 1099 } 1100 else { 1101 /* bit flag */ 1102 if ( oppriv & (1<<bit) 1103 && !(PL_op_private_labels[ix] == '-' 1104 && PL_op_private_labels[ix+1] == '\0')) 1105 { 1106 oppriv -= (1<<bit); 1107 sv_catpv(tmpsv, ","); 1108 sv_catpv(tmpsv, &PL_op_private_labels[ix]); 1109 } 1110 } 1111 } 1112 if (oppriv) { 1113 sv_catpv(tmpsv, ","); 1114 Perl_sv_catpvf(aTHX_ tmpsv, "0x%" UVxf, (UV)oppriv); 1115 } 1116 } 1117 if (tmpsv && SvCUR(tmpsv)) { 1118 S_opdump_indent(aTHX_ o, level, bar, file, "PRIVATE = (%s)\n", 1119 SvPVX_const(tmpsv) + 1); 1120 } else 1121 S_opdump_indent(aTHX_ o, level, bar, file, 1122 "PRIVATE = (0x%" UVxf ")\n", (UV)oppriv); 1123 } 1124 1125 switch (optype) { 1126 case OP_AELEMFAST: 1127 case OP_GVSV: 1128 case OP_GV: 1129 #ifdef USE_ITHREADS 1130 S_opdump_indent(aTHX_ o, level, bar, file, 1131 "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix); 1132 #else 1133 S_opdump_indent(aTHX_ o, level, bar, file, 1134 "GV = %" SVf " (0x%" UVxf ")\n", 1135 SVfARG(S_gv_display(aTHX_ cGVOPo_gv)), PTR2UV(cGVOPo_gv)); 1136 #endif 1137 break; 1138 1139 case OP_MULTIDEREF: 1140 { 1141 UNOP_AUX_item *items = cUNOP_AUXo->op_aux; 1142 UV i, count = items[-1].uv; 1143 1144 S_opdump_indent(aTHX_ o, level, bar, file, "ARGS = \n"); 1145 for (i=0; i < count; i++) 1146 S_opdump_indent(aTHX_ o, level+1, (bar << 1), file, 1147 "%" UVuf " => 0x%" UVxf "\n", 1148 i, items[i].uv); 1149 break; 1150 } 1151 1152 case OP_MULTICONCAT: 1153 S_opdump_indent(aTHX_ o, level, bar, file, "NARGS = %" IVdf "\n", 1154 (IV)cUNOP_AUXo->op_aux[PERL_MULTICONCAT_IX_NARGS].ssize); 1155 /* XXX really ought to dump each field individually, 1156 * but that's too much like hard work */ 1157 S_opdump_indent(aTHX_ o, level, bar, file, "CONSTS = (%" SVf ")\n", 1158 SVfARG(multiconcat_stringify(o))); 1159 break; 1160 1161 case OP_CONST: 1162 case OP_HINTSEVAL: 1163 case OP_METHOD_NAMED: 1164 case OP_METHOD_SUPER: 1165 case OP_METHOD_REDIR: 1166 case OP_METHOD_REDIR_SUPER: 1167 #ifndef USE_ITHREADS 1168 /* with ITHREADS, consts are stored in the pad, and the right pad 1169 * may not be active here, so skip */ 1170 S_opdump_indent(aTHX_ o, level, bar, file, "SV = %s\n", 1171 SvPEEK(cMETHOPx_meth(o))); 1172 #endif 1173 break; 1174 case OP_NULL: 1175 if (o->op_targ != OP_NEXTSTATE && o->op_targ != OP_DBSTATE) 1176 break; 1177 /* FALLTHROUGH */ 1178 case OP_NEXTSTATE: 1179 case OP_DBSTATE: 1180 if (CopLINE(cCOPo)) 1181 S_opdump_indent(aTHX_ o, level, bar, file, "LINE = %" UVuf "\n", 1182 (UV)CopLINE(cCOPo)); 1183 1184 if (CopSTASHPV(cCOPo)) { 1185 SV* tmpsv = newSVpvs_flags("", SVs_TEMP); 1186 HV *stash = CopSTASH(cCOPo); 1187 const char * const hvname = HvNAME_get(stash); 1188 1189 S_opdump_indent(aTHX_ o, level, bar, file, "PACKAGE = \"%s\"\n", 1190 generic_pv_escape(tmpsv, hvname, 1191 HvNAMELEN(stash), HvNAMEUTF8(stash))); 1192 } 1193 1194 if (CopLABEL(cCOPo)) { 1195 SV* tmpsv = newSVpvs_flags("", SVs_TEMP); 1196 STRLEN label_len; 1197 U32 label_flags; 1198 const char *label = CopLABEL_len_flags(cCOPo, 1199 &label_len, &label_flags); 1200 S_opdump_indent(aTHX_ o, level, bar, file, "LABEL = \"%s\"\n", 1201 generic_pv_escape( tmpsv, label, label_len, 1202 (label_flags & SVf_UTF8))); 1203 } 1204 1205 S_opdump_indent(aTHX_ o, level, bar, file, "SEQ = %u\n", 1206 (unsigned int)cCOPo->cop_seq); 1207 break; 1208 1209 case OP_ENTERITER: 1210 case OP_ENTERLOOP: 1211 S_opdump_indent(aTHX_ o, level, bar, file, "REDO"); 1212 S_opdump_link(aTHX_ o, cLOOPo->op_redoop, file); 1213 S_opdump_indent(aTHX_ o, level, bar, file, "NEXT"); 1214 S_opdump_link(aTHX_ o, cLOOPo->op_nextop, file); 1215 S_opdump_indent(aTHX_ o, level, bar, file, "LAST"); 1216 S_opdump_link(aTHX_ o, cLOOPo->op_lastop, file); 1217 break; 1218 1219 case OP_REGCOMP: 1220 case OP_SUBSTCONT: 1221 case OP_COND_EXPR: 1222 case OP_RANGE: 1223 case OP_MAPWHILE: 1224 case OP_GREPWHILE: 1225 case OP_OR: 1226 case OP_DOR: 1227 case OP_AND: 1228 case OP_ORASSIGN: 1229 case OP_DORASSIGN: 1230 case OP_ANDASSIGN: 1231 case OP_ARGDEFELEM: 1232 case OP_ENTERGIVEN: 1233 case OP_ENTERWHEN: 1234 case OP_ENTERTRY: 1235 case OP_ONCE: 1236 S_opdump_indent(aTHX_ o, level, bar, file, "OTHER"); 1237 S_opdump_link(aTHX_ o, cLOGOPo->op_other, file); 1238 break; 1239 case OP_SPLIT: 1240 case OP_MATCH: 1241 case OP_QR: 1242 case OP_SUBST: 1243 S_do_pmop_dump_bar(aTHX_ level, bar, file, cPMOPo); 1244 break; 1245 case OP_LEAVE: 1246 case OP_LEAVEEVAL: 1247 case OP_LEAVESUB: 1248 case OP_LEAVESUBLV: 1249 case OP_LEAVEWRITE: 1250 case OP_SCOPE: 1251 if (o->op_private & OPpREFCOUNTED) 1252 S_opdump_indent(aTHX_ o, level, bar, file, 1253 "REFCNT = %" UVuf "\n", (UV)o->op_targ); 1254 break; 1255 1256 case OP_DUMP: 1257 case OP_GOTO: 1258 case OP_NEXT: 1259 case OP_LAST: 1260 case OP_REDO: 1261 if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS)) 1262 break; 1263 { 1264 SV * const label = newSVpvs_flags("", SVs_TEMP); 1265 generic_pv_escape(label, cPVOPo->op_pv, strlen(cPVOPo->op_pv), 0); 1266 S_opdump_indent(aTHX_ o, level, bar, file, 1267 "PV = \"%" SVf "\" (0x%" UVxf ")\n", 1268 SVfARG(label), PTR2UV(cPVOPo->op_pv)); 1269 break; 1270 } 1271 1272 case OP_TRANS: 1273 case OP_TRANSR: 1274 if (o->op_private & (OPpTRANS_FROM_UTF | OPpTRANS_TO_UTF)) { 1275 /* utf8: table stored as a swash */ 1276 #ifndef USE_ITHREADS 1277 /* with ITHREADS, swash is stored in the pad, and the right pad 1278 * may not be active here, so skip */ 1279 S_opdump_indent(aTHX_ o, level, bar, file, 1280 "SWASH = 0x%" UVxf "\n", 1281 PTR2UV(MUTABLE_SV(cSVOPo->op_sv))); 1282 #endif 1283 } 1284 else { 1285 const OPtrans_map * const tbl = (OPtrans_map*)cPVOPo->op_pv; 1286 SSize_t i, size = tbl->size; 1287 1288 S_opdump_indent(aTHX_ o, level, bar, file, 1289 "TABLE = 0x%" UVxf "\n", 1290 PTR2UV(tbl)); 1291 S_opdump_indent(aTHX_ o, level, bar, file, 1292 " SIZE: 0x%" UVxf "\n", (UV)size); 1293 1294 /* dump size+1 values, to include the extra slot at the end */ 1295 for (i = 0; i <= size; i++) { 1296 short val = tbl->map[i]; 1297 if ((i & 0xf) == 0) 1298 S_opdump_indent(aTHX_ o, level, bar, file, 1299 " %4" UVxf ":", (UV)i); 1300 if (val < 0) 1301 PerlIO_printf(file, " %2" IVdf, (IV)val); 1302 else 1303 PerlIO_printf(file, " %02" UVxf, (UV)val); 1304 1305 if ( i == size || (i & 0xf) == 0xf) 1306 PerlIO_printf(file, "\n"); 1307 } 1308 } 1309 break; 1310 1311 1312 default: 1313 break; 1314 } 1315 if (o->op_flags & OPf_KIDS) { 1316 OP *kid; 1317 level++; 1318 bar <<= 1; 1319 for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) 1320 S_do_op_dump_bar(aTHX_ level, 1321 (bar | cBOOL(OpHAS_SIBLING(kid))), 1322 file, kid); 1323 } 1324 } 1325 1326 1327 void 1328 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) 1329 { 1330 S_do_op_dump_bar(aTHX_ level, 0, file, o); 1331 } 1332 1333 1334 /* 1335 =for apidoc op_dump 1336 1337 Dumps the optree starting at OP C<o> to C<STDERR>. 1338 1339 =cut 1340 */ 1341 1342 void 1343 Perl_op_dump(pTHX_ const OP *o) 1344 { 1345 PERL_ARGS_ASSERT_OP_DUMP; 1346 do_op_dump(0, Perl_debug_log, o); 1347 } 1348 1349 void 1350 Perl_gv_dump(pTHX_ GV *gv) 1351 { 1352 STRLEN len; 1353 const char* name; 1354 SV *sv, *tmp = newSVpvs_flags("", SVs_TEMP); 1355 1356 if (!gv) { 1357 PerlIO_printf(Perl_debug_log, "{}\n"); 1358 return; 1359 } 1360 sv = sv_newmortal(); 1361 PerlIO_printf(Perl_debug_log, "{\n"); 1362 gv_fullname3(sv, gv, NULL); 1363 name = SvPV_const(sv, len); 1364 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", 1365 generic_pv_escape( tmp, name, len, SvUTF8(sv) )); 1366 if (gv != GvEGV(gv)) { 1367 gv_efullname3(sv, GvEGV(gv), NULL); 1368 name = SvPV_const(sv, len); 1369 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", 1370 generic_pv_escape( tmp, name, len, SvUTF8(sv) )); 1371 } 1372 (void)PerlIO_putc(Perl_debug_log, '\n'); 1373 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n"); 1374 } 1375 1376 1377 /* map magic types to the symbolic names 1378 * (with the PERL_MAGIC_ prefixed stripped) 1379 */ 1380 1381 static const struct { const char type; const char *name; } magic_names[] = { 1382 #include "mg_names.inc" 1383 /* this null string terminates the list */ 1384 { 0, NULL }, 1385 }; 1386 1387 void 1388 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim) 1389 { 1390 PERL_ARGS_ASSERT_DO_MAGIC_DUMP; 1391 1392 for (; mg; mg = mg->mg_moremagic) { 1393 Perl_dump_indent(aTHX_ level, file, 1394 " MAGIC = 0x%" UVxf "\n", PTR2UV(mg)); 1395 if (mg->mg_virtual) { 1396 const MGVTBL * const v = mg->mg_virtual; 1397 if (v >= PL_magic_vtables 1398 && v < PL_magic_vtables + magic_vtable_max) { 1399 const U32 i = v - PL_magic_vtables; 1400 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", PL_magic_vtable_names[i]); 1401 } 1402 else 1403 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%" 1404 UVxf "\n", PTR2UV(v)); 1405 } 1406 else 1407 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n"); 1408 1409 if (mg->mg_private) 1410 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private); 1411 1412 { 1413 int n; 1414 const char *name = NULL; 1415 for (n = 0; magic_names[n].name; n++) { 1416 if (mg->mg_type == magic_names[n].type) { 1417 name = magic_names[n].name; 1418 break; 1419 } 1420 } 1421 if (name) 1422 Perl_dump_indent(aTHX_ level, file, 1423 " MG_TYPE = PERL_MAGIC_%s\n", name); 1424 else 1425 Perl_dump_indent(aTHX_ level, file, 1426 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type); 1427 } 1428 1429 if (mg->mg_flags) { 1430 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags); 1431 if (mg->mg_type == PERL_MAGIC_envelem && 1432 mg->mg_flags & MGf_TAINTEDDIR) 1433 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n"); 1434 if (mg->mg_type == PERL_MAGIC_regex_global && 1435 mg->mg_flags & MGf_MINMATCH) 1436 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n"); 1437 if (mg->mg_flags & MGf_REFCOUNTED) 1438 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n"); 1439 if (mg->mg_flags & MGf_GSKIP) 1440 Perl_dump_indent(aTHX_ level, file, " GSKIP\n"); 1441 if (mg->mg_flags & MGf_COPY) 1442 Perl_dump_indent(aTHX_ level, file, " COPY\n"); 1443 if (mg->mg_flags & MGf_DUP) 1444 Perl_dump_indent(aTHX_ level, file, " DUP\n"); 1445 if (mg->mg_flags & MGf_LOCAL) 1446 Perl_dump_indent(aTHX_ level, file, " LOCAL\n"); 1447 if (mg->mg_type == PERL_MAGIC_regex_global && 1448 mg->mg_flags & MGf_BYTES) 1449 Perl_dump_indent(aTHX_ level, file, " BYTES\n"); 1450 } 1451 if (mg->mg_obj) { 1452 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%" UVxf "\n", 1453 PTR2UV(mg->mg_obj)); 1454 if (mg->mg_type == PERL_MAGIC_qr) { 1455 REGEXP* const re = (REGEXP *)mg->mg_obj; 1456 SV * const dsv = sv_newmortal(); 1457 const char * const s 1458 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re), 1459 60, NULL, NULL, 1460 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES | 1461 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0)) 1462 ); 1463 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s); 1464 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %" IVdf "\n", 1465 (IV)RX_REFCNT(re)); 1466 } 1467 if (mg->mg_flags & MGf_REFCOUNTED) 1468 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */ 1469 } 1470 if (mg->mg_len) 1471 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len); 1472 if (mg->mg_ptr) { 1473 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%" UVxf, PTR2UV(mg->mg_ptr)); 1474 if (mg->mg_len >= 0) { 1475 if (mg->mg_type != PERL_MAGIC_utf8) { 1476 SV * const sv = newSVpvs(""); 1477 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim)); 1478 SvREFCNT_dec_NN(sv); 1479 } 1480 } 1481 else if (mg->mg_len == HEf_SVKEY) { 1482 PerlIO_puts(file, " => HEf_SVKEY\n"); 1483 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1, 1484 maxnest, dumpops, pvlim); /* MG is already +1 */ 1485 continue; 1486 } 1487 else if (mg->mg_len == -1 && mg->mg_type == PERL_MAGIC_utf8); 1488 else 1489 PerlIO_puts( 1490 file, 1491 " ???? - " __FILE__ 1492 " does not know how to handle this MG_LEN" 1493 ); 1494 (void)PerlIO_putc(file, '\n'); 1495 } 1496 if (mg->mg_type == PERL_MAGIC_utf8) { 1497 const STRLEN * const cache = (STRLEN *) mg->mg_ptr; 1498 if (cache) { 1499 IV i; 1500 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++) 1501 Perl_dump_indent(aTHX_ level, file, 1502 " %2" IVdf ": %" UVuf " -> %" UVuf "\n", 1503 i, 1504 (UV)cache[i * 2], 1505 (UV)cache[i * 2 + 1]); 1506 } 1507 } 1508 } 1509 } 1510 1511 void 1512 Perl_magic_dump(pTHX_ const MAGIC *mg) 1513 { 1514 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0); 1515 } 1516 1517 void 1518 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv) 1519 { 1520 const char *hvname; 1521 1522 PERL_ARGS_ASSERT_DO_HV_DUMP; 1523 1524 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv)); 1525 if (sv && (hvname = HvNAME_get(sv))) 1526 { 1527 /* we have to use pv_display and HvNAMELEN_get() so that we display the real package 1528 name which quite legally could contain insane things like tabs, newlines, nulls or 1529 other scary crap - this should produce sane results - except maybe for unicode package 1530 names - but we will wait for someone to file a bug on that - demerphq */ 1531 SV * const tmpsv = newSVpvs_flags("", SVs_TEMP); 1532 PerlIO_printf(file, "\t\"%s\"\n", 1533 generic_pv_escape( tmpsv, hvname, 1534 HvNAMELEN(sv), HvNAMEUTF8(sv))); 1535 } 1536 else 1537 (void)PerlIO_putc(file, '\n'); 1538 } 1539 1540 void 1541 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv) 1542 { 1543 PERL_ARGS_ASSERT_DO_GV_DUMP; 1544 1545 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv)); 1546 if (sv && GvNAME(sv)) { 1547 SV * const tmpsv = newSVpvs(""); 1548 PerlIO_printf(file, "\t\"%s\"\n", 1549 generic_pv_escape( tmpsv, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv) )); 1550 } 1551 else 1552 (void)PerlIO_putc(file, '\n'); 1553 } 1554 1555 void 1556 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv) 1557 { 1558 PERL_ARGS_ASSERT_DO_GVGV_DUMP; 1559 1560 Perl_dump_indent(aTHX_ level, file, "%s = 0x%" UVxf, name, PTR2UV(sv)); 1561 if (sv && GvNAME(sv)) { 1562 SV *tmp = newSVpvs_flags("", SVs_TEMP); 1563 const char *hvname; 1564 HV * const stash = GvSTASH(sv); 1565 PerlIO_printf(file, "\t"); 1566 /* TODO might have an extra \" here */ 1567 if (stash && (hvname = HvNAME_get(stash))) { 1568 PerlIO_printf(file, "\"%s\" :: \"", 1569 generic_pv_escape(tmp, hvname, 1570 HvNAMELEN(stash), HvNAMEUTF8(stash))); 1571 } 1572 PerlIO_printf(file, "%s\"\n", 1573 generic_pv_escape( tmp, GvNAME(sv), GvNAMELEN(sv), GvNAMEUTF8(sv))); 1574 } 1575 else 1576 (void)PerlIO_putc(file, '\n'); 1577 } 1578 1579 const struct flag_to_name first_sv_flags_names[] = { 1580 {SVs_TEMP, "TEMP,"}, 1581 {SVs_OBJECT, "OBJECT,"}, 1582 {SVs_GMG, "GMG,"}, 1583 {SVs_SMG, "SMG,"}, 1584 {SVs_RMG, "RMG,"}, 1585 {SVf_IOK, "IOK,"}, 1586 {SVf_NOK, "NOK,"}, 1587 {SVf_POK, "POK,"} 1588 }; 1589 1590 const struct flag_to_name second_sv_flags_names[] = { 1591 {SVf_OOK, "OOK,"}, 1592 {SVf_FAKE, "FAKE,"}, 1593 {SVf_READONLY, "READONLY,"}, 1594 {SVf_PROTECT, "PROTECT,"}, 1595 {SVf_BREAK, "BREAK,"}, 1596 {SVp_IOK, "pIOK,"}, 1597 {SVp_NOK, "pNOK,"}, 1598 {SVp_POK, "pPOK,"} 1599 }; 1600 1601 const struct flag_to_name cv_flags_names[] = { 1602 {CVf_ANON, "ANON,"}, 1603 {CVf_UNIQUE, "UNIQUE,"}, 1604 {CVf_CLONE, "CLONE,"}, 1605 {CVf_CLONED, "CLONED,"}, 1606 {CVf_CONST, "CONST,"}, 1607 {CVf_NODEBUG, "NODEBUG,"}, 1608 {CVf_LVALUE, "LVALUE,"}, 1609 {CVf_METHOD, "METHOD,"}, 1610 {CVf_WEAKOUTSIDE, "WEAKOUTSIDE,"}, 1611 {CVf_CVGV_RC, "CVGV_RC,"}, 1612 {CVf_DYNFILE, "DYNFILE,"}, 1613 {CVf_AUTOLOAD, "AUTOLOAD,"}, 1614 {CVf_HASEVAL, "HASEVAL,"}, 1615 {CVf_SLABBED, "SLABBED,"}, 1616 {CVf_NAMED, "NAMED,"}, 1617 {CVf_LEXICAL, "LEXICAL,"}, 1618 {CVf_ISXSUB, "ISXSUB,"} 1619 }; 1620 1621 const struct flag_to_name hv_flags_names[] = { 1622 {SVphv_SHAREKEYS, "SHAREKEYS,"}, 1623 {SVphv_LAZYDEL, "LAZYDEL,"}, 1624 {SVphv_HASKFLAGS, "HASKFLAGS,"}, 1625 {SVf_AMAGIC, "OVERLOAD,"}, 1626 {SVphv_CLONEABLE, "CLONEABLE,"} 1627 }; 1628 1629 const struct flag_to_name gp_flags_names[] = { 1630 {GVf_INTRO, "INTRO,"}, 1631 {GVf_MULTI, "MULTI,"}, 1632 {GVf_ASSUMECV, "ASSUMECV,"}, 1633 }; 1634 1635 const struct flag_to_name gp_flags_imported_names[] = { 1636 {GVf_IMPORTED_SV, " SV"}, 1637 {GVf_IMPORTED_AV, " AV"}, 1638 {GVf_IMPORTED_HV, " HV"}, 1639 {GVf_IMPORTED_CV, " CV"}, 1640 }; 1641 1642 /* NOTE: this structure is mostly duplicative of one generated by 1643 * 'make regen' in regnodes.h - perhaps we should somehow integrate 1644 * the two. - Yves */ 1645 const struct flag_to_name regexp_extflags_names[] = { 1646 {RXf_PMf_MULTILINE, "PMf_MULTILINE,"}, 1647 {RXf_PMf_SINGLELINE, "PMf_SINGLELINE,"}, 1648 {RXf_PMf_FOLD, "PMf_FOLD,"}, 1649 {RXf_PMf_EXTENDED, "PMf_EXTENDED,"}, 1650 {RXf_PMf_EXTENDED_MORE, "PMf_EXTENDED_MORE,"}, 1651 {RXf_PMf_KEEPCOPY, "PMf_KEEPCOPY,"}, 1652 {RXf_PMf_NOCAPTURE, "PMf_NOCAPURE,"}, 1653 {RXf_IS_ANCHORED, "IS_ANCHORED,"}, 1654 {RXf_NO_INPLACE_SUBST, "NO_INPLACE_SUBST,"}, 1655 {RXf_EVAL_SEEN, "EVAL_SEEN,"}, 1656 {RXf_CHECK_ALL, "CHECK_ALL,"}, 1657 {RXf_MATCH_UTF8, "MATCH_UTF8,"}, 1658 {RXf_USE_INTUIT_NOML, "USE_INTUIT_NOML,"}, 1659 {RXf_USE_INTUIT_ML, "USE_INTUIT_ML,"}, 1660 {RXf_INTUIT_TAIL, "INTUIT_TAIL,"}, 1661 {RXf_SPLIT, "SPLIT,"}, 1662 {RXf_COPY_DONE, "COPY_DONE,"}, 1663 {RXf_TAINTED_SEEN, "TAINTED_SEEN,"}, 1664 {RXf_TAINTED, "TAINTED,"}, 1665 {RXf_START_ONLY, "START_ONLY,"}, 1666 {RXf_SKIPWHITE, "SKIPWHITE,"}, 1667 {RXf_WHITE, "WHITE,"}, 1668 {RXf_NULL, "NULL,"}, 1669 }; 1670 1671 /* NOTE: this structure is mostly duplicative of one generated by 1672 * 'make regen' in regnodes.h - perhaps we should somehow integrate 1673 * the two. - Yves */ 1674 const struct flag_to_name regexp_core_intflags_names[] = { 1675 {PREGf_SKIP, "SKIP,"}, 1676 {PREGf_IMPLICIT, "IMPLICIT,"}, 1677 {PREGf_NAUGHTY, "NAUGHTY,"}, 1678 {PREGf_VERBARG_SEEN, "VERBARG_SEEN,"}, 1679 {PREGf_CUTGROUP_SEEN, "CUTGROUP_SEEN,"}, 1680 {PREGf_USE_RE_EVAL, "USE_RE_EVAL,"}, 1681 {PREGf_NOSCAN, "NOSCAN,"}, 1682 {PREGf_GPOS_SEEN, "GPOS_SEEN,"}, 1683 {PREGf_GPOS_FLOAT, "GPOS_FLOAT,"}, 1684 {PREGf_ANCH_MBOL, "ANCH_MBOL,"}, 1685 {PREGf_ANCH_SBOL, "ANCH_SBOL,"}, 1686 {PREGf_ANCH_GPOS, "ANCH_GPOS,"}, 1687 }; 1688 1689 /* Perl_do_sv_dump(): 1690 * 1691 * level: amount to indent the output 1692 * sv: the object to dump 1693 * nest: the current level of recursion 1694 * maxnest: the maximum allowed level of recursion 1695 * dumpops: if true, also dump the ops associated with a CV 1696 * pvlim: limit on the length of any strings that are output 1697 * */ 1698 1699 void 1700 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim) 1701 { 1702 SV *d; 1703 const char *s; 1704 U32 flags; 1705 U32 type; 1706 1707 PERL_ARGS_ASSERT_DO_SV_DUMP; 1708 1709 if (!sv) { 1710 Perl_dump_indent(aTHX_ level, file, "SV = 0\n"); 1711 return; 1712 } 1713 1714 flags = SvFLAGS(sv); 1715 type = SvTYPE(sv); 1716 1717 /* process general SV flags */ 1718 1719 d = Perl_newSVpvf(aTHX_ 1720 "(0x%" UVxf ") at 0x%" UVxf "\n%*s REFCNT = %" IVdf "\n%*s FLAGS = (", 1721 PTR2UV(SvANY(sv)), PTR2UV(sv), 1722 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv), 1723 (int)(PL_dumpindent*level), ""); 1724 1725 if ((flags & SVs_PADSTALE)) 1726 sv_catpv(d, "PADSTALE,"); 1727 if ((flags & SVs_PADTMP)) 1728 sv_catpv(d, "PADTMP,"); 1729 append_flags(d, flags, first_sv_flags_names); 1730 if (flags & SVf_ROK) { 1731 sv_catpv(d, "ROK,"); 1732 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,"); 1733 } 1734 if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,"); 1735 append_flags(d, flags, second_sv_flags_names); 1736 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv) 1737 && type != SVt_PVAV) { 1738 if (SvPCS_IMPORTED(sv)) 1739 sv_catpv(d, "PCS_IMPORTED,"); 1740 else 1741 sv_catpv(d, "SCREAM,"); 1742 } 1743 1744 /* process type-specific SV flags */ 1745 1746 switch (type) { 1747 case SVt_PVCV: 1748 case SVt_PVFM: 1749 append_flags(d, CvFLAGS(sv), cv_flags_names); 1750 break; 1751 case SVt_PVHV: 1752 append_flags(d, flags, hv_flags_names); 1753 break; 1754 case SVt_PVGV: 1755 case SVt_PVLV: 1756 if (isGV_with_GP(sv)) { 1757 append_flags(d, GvFLAGS(sv), gp_flags_names); 1758 } 1759 if (isGV_with_GP(sv) && GvIMPORTED(sv)) { 1760 sv_catpv(d, "IMPORT"); 1761 if (GvIMPORTED(sv) == GVf_IMPORTED) 1762 sv_catpv(d, "ALL,"); 1763 else { 1764 sv_catpv(d, "("); 1765 append_flags(d, GvFLAGS(sv), gp_flags_imported_names); 1766 sv_catpv(d, " ),"); 1767 } 1768 } 1769 /* FALLTHROUGH */ 1770 case SVt_PVMG: 1771 default: 1772 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,"); 1773 break; 1774 1775 case SVt_PVAV: 1776 break; 1777 } 1778 /* SVphv_SHAREKEYS is also 0x20000000 */ 1779 if ((type != SVt_PVHV) && SvUTF8(sv)) 1780 sv_catpv(d, "UTF8"); 1781 1782 if (*(SvEND(d) - 1) == ',') { 1783 SvCUR_set(d, SvCUR(d) - 1); 1784 SvPVX(d)[SvCUR(d)] = '\0'; 1785 } 1786 sv_catpv(d, ")"); 1787 s = SvPVX_const(d); 1788 1789 /* dump initial SV details */ 1790 1791 #ifdef DEBUG_LEAKING_SCALARS 1792 Perl_dump_indent(aTHX_ level, file, 1793 "ALLOCATED at %s:%d %s %s (parent 0x%" UVxf "); serial %" UVuf "\n", 1794 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)", 1795 sv->sv_debug_line, 1796 sv->sv_debug_inpad ? "for" : "by", 1797 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)", 1798 PTR2UV(sv->sv_debug_parent), 1799 sv->sv_debug_serial 1800 ); 1801 #endif 1802 Perl_dump_indent(aTHX_ level, file, "SV = "); 1803 1804 /* Dump SV type */ 1805 1806 if (type < SVt_LAST) { 1807 PerlIO_printf(file, "%s%s\n", svtypenames[type], s); 1808 1809 if (type == SVt_NULL) { 1810 SvREFCNT_dec_NN(d); 1811 return; 1812 } 1813 } else { 1814 PerlIO_printf(file, "UNKNOWN(0x%" UVxf ") %s\n", (UV)type, s); 1815 SvREFCNT_dec_NN(d); 1816 return; 1817 } 1818 1819 /* Dump general SV fields */ 1820 1821 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV 1822 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO 1823 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv)) 1824 || (type == SVt_IV && !SvROK(sv))) { 1825 if (SvIsUV(sv) 1826 ) 1827 Perl_dump_indent(aTHX_ level, file, " UV = %" UVuf, (UV)SvUVX(sv)); 1828 else 1829 Perl_dump_indent(aTHX_ level, file, " IV = %" IVdf, (IV)SvIVX(sv)); 1830 (void)PerlIO_putc(file, '\n'); 1831 } 1832 1833 if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV 1834 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP 1835 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv)) 1836 || type == SVt_NV) { 1837 DECLARATION_FOR_LC_NUMERIC_MANIPULATION; 1838 STORE_LC_NUMERIC_SET_STANDARD(); 1839 Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv)); 1840 RESTORE_LC_NUMERIC(); 1841 } 1842 1843 if (SvROK(sv)) { 1844 Perl_dump_indent(aTHX_ level, file, " RV = 0x%" UVxf "\n", 1845 PTR2UV(SvRV(sv))); 1846 if (nest < maxnest) 1847 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim); 1848 } 1849 1850 if (type < SVt_PV) { 1851 SvREFCNT_dec_NN(d); 1852 return; 1853 } 1854 1855 if ((type <= SVt_PVLV && !isGV_with_GP(sv)) 1856 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) { 1857 const bool re = isREGEXP(sv); 1858 const char * const ptr = 1859 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv); 1860 if (ptr) { 1861 STRLEN delta; 1862 if (SvOOK(sv)) { 1863 SvOOK_offset(sv, delta); 1864 Perl_dump_indent(aTHX_ level, file," OFFSET = %" UVuf "\n", 1865 (UV) delta); 1866 } else { 1867 delta = 0; 1868 } 1869 Perl_dump_indent(aTHX_ level, file," PV = 0x%" UVxf " ", 1870 PTR2UV(ptr)); 1871 if (SvOOK(sv)) { 1872 PerlIO_printf(file, "( %s . ) ", 1873 pv_display(d, ptr - delta, delta, 0, 1874 pvlim)); 1875 } 1876 if (type == SVt_INVLIST) { 1877 PerlIO_printf(file, "\n"); 1878 /* 4 blanks indents 2 beyond the PV, etc */ 1879 _invlist_dump(file, level, " ", sv); 1880 } 1881 else { 1882 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv), 1883 re ? 0 : SvLEN(sv), 1884 pvlim)); 1885 if (SvUTF8(sv)) /* the 6? \x{....} */ 1886 PerlIO_printf(file, " [UTF8 \"%s\"]", 1887 sv_uni_display(d, sv, 6 * SvCUR(sv), 1888 UNI_DISPLAY_QQ)); 1889 PerlIO_printf(file, "\n"); 1890 } 1891 Perl_dump_indent(aTHX_ level, file, " CUR = %" IVdf "\n", (IV)SvCUR(sv)); 1892 if (re && type == SVt_PVLV) 1893 /* LV-as-REGEXP usurps len field to store pointer to 1894 * regexp struct */ 1895 Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%" UVxf "\n", 1896 PTR2UV(((XPV*)SvANY(sv))->xpv_len_u.xpvlenu_rx)); 1897 else 1898 Perl_dump_indent(aTHX_ level, file, " LEN = %" IVdf "\n", 1899 (IV)SvLEN(sv)); 1900 #ifdef PERL_COPY_ON_WRITE 1901 if (SvIsCOW(sv) && SvLEN(sv)) 1902 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n", 1903 CowREFCNT(sv)); 1904 #endif 1905 } 1906 else 1907 Perl_dump_indent(aTHX_ level, file, " PV = 0\n"); 1908 } 1909 1910 if (type >= SVt_PVMG) { 1911 if (SvMAGIC(sv)) 1912 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim); 1913 if (SvSTASH(sv)) 1914 do_hv_dump(level, file, " STASH", SvSTASH(sv)); 1915 1916 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) { 1917 Perl_dump_indent(aTHX_ level, file, " USEFUL = %" IVdf "\n", 1918 (IV)BmUSEFUL(sv)); 1919 } 1920 } 1921 1922 /* Dump type-specific SV fields */ 1923 1924 switch (type) { 1925 case SVt_PVAV: 1926 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf, 1927 PTR2UV(AvARRAY(sv))); 1928 if (AvARRAY(sv) != AvALLOC(sv)) { 1929 PerlIO_printf(file, " (offset=%" IVdf ")\n", 1930 (IV)(AvARRAY(sv) - AvALLOC(sv))); 1931 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%" UVxf "\n", 1932 PTR2UV(AvALLOC(sv))); 1933 } 1934 else 1935 (void)PerlIO_putc(file, '\n'); 1936 Perl_dump_indent(aTHX_ level, file, " FILL = %" IVdf "\n", 1937 (IV)AvFILLp(sv)); 1938 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n", 1939 (IV)AvMAX(sv)); 1940 SvPVCLEAR(d); 1941 if (AvREAL(sv)) sv_catpv(d, ",REAL"); 1942 if (AvREIFY(sv)) sv_catpv(d, ",REIFY"); 1943 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n", 1944 SvCUR(d) ? SvPVX_const(d) + 1 : ""); 1945 if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) { 1946 SSize_t count; 1947 SV **svp = AvARRAY(MUTABLE_AV(sv)); 1948 for (count = 0; 1949 count <= AvFILLp(MUTABLE_AV(sv)) && count < maxnest; 1950 count++, svp++) 1951 { 1952 SV* const elt = *svp; 1953 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %" IVdf "\n", 1954 (IV)count); 1955 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim); 1956 } 1957 } 1958 break; 1959 case SVt_PVHV: { 1960 U32 usedkeys; 1961 if (SvOOK(sv)) { 1962 struct xpvhv_aux *const aux = HvAUX(sv); 1963 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %" UVuf "\n", 1964 (UV)aux->xhv_aux_flags); 1965 } 1966 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf, PTR2UV(HvARRAY(sv))); 1967 usedkeys = HvUSEDKEYS(MUTABLE_HV(sv)); 1968 if (HvARRAY(sv) && usedkeys) { 1969 /* Show distribution of HEs in the ARRAY */ 1970 int freq[200]; 1971 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1)) 1972 int i; 1973 int max = 0; 1974 U32 pow2 = 2, keys = usedkeys; 1975 NV theoret, sum = 0; 1976 1977 PerlIO_printf(file, " ("); 1978 Zero(freq, FREQ_MAX + 1, int); 1979 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) { 1980 HE* h; 1981 int count = 0; 1982 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h)) 1983 count++; 1984 if (count > FREQ_MAX) 1985 count = FREQ_MAX; 1986 freq[count]++; 1987 if (max < count) 1988 max = count; 1989 } 1990 for (i = 0; i <= max; i++) { 1991 if (freq[i]) { 1992 PerlIO_printf(file, "%d%s:%d", i, 1993 (i == FREQ_MAX) ? "+" : "", 1994 freq[i]); 1995 if (i != max) 1996 PerlIO_printf(file, ", "); 1997 } 1998 } 1999 (void)PerlIO_putc(file, ')'); 2000 /* The "quality" of a hash is defined as the total number of 2001 comparisons needed to access every element once, relative 2002 to the expected number needed for a random hash. 2003 2004 The total number of comparisons is equal to the sum of 2005 the squares of the number of entries in each bucket. 2006 For a random hash of n keys into k buckets, the expected 2007 value is 2008 n + n(n-1)/2k 2009 */ 2010 2011 for (i = max; i > 0; i--) { /* Precision: count down. */ 2012 sum += freq[i] * i * i; 2013 } 2014 while ((keys = keys >> 1)) 2015 pow2 = pow2 << 1; 2016 theoret = usedkeys; 2017 theoret += theoret * (theoret-1)/pow2; 2018 (void)PerlIO_putc(file, '\n'); 2019 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1" 2020 NVff "%%", theoret/sum*100); 2021 } 2022 (void)PerlIO_putc(file, '\n'); 2023 Perl_dump_indent(aTHX_ level, file, " KEYS = %" IVdf "\n", 2024 (IV)usedkeys); 2025 { 2026 STRLEN count = 0; 2027 HE **ents = HvARRAY(sv); 2028 2029 if (ents) { 2030 HE *const *const last = ents + HvMAX(sv); 2031 count = last + 1 - ents; 2032 2033 do { 2034 if (!*ents) 2035 --count; 2036 } while (++ents <= last); 2037 } 2038 2039 Perl_dump_indent(aTHX_ level, file, " FILL = %" UVuf "\n", 2040 (UV)count); 2041 } 2042 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n", 2043 (IV)HvMAX(sv)); 2044 if (SvOOK(sv)) { 2045 Perl_dump_indent(aTHX_ level, file, " RITER = %" IVdf "\n", 2046 (IV)HvRITER_get(sv)); 2047 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%" UVxf "\n", 2048 PTR2UV(HvEITER_get(sv))); 2049 #ifdef PERL_HASH_RANDOMIZE_KEYS 2050 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%" UVxf, 2051 (UV)HvRAND_get(sv)); 2052 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) { 2053 PerlIO_printf(file, " (LAST = 0x%" UVxf ")", 2054 (UV)HvLASTRAND_get(sv)); 2055 } 2056 #endif 2057 (void)PerlIO_putc(file, '\n'); 2058 } 2059 { 2060 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab); 2061 if (mg && mg->mg_obj) { 2062 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%" UVxf "\n", PTR2UV(mg->mg_obj)); 2063 } 2064 } 2065 { 2066 const char * const hvname = HvNAME_get(sv); 2067 if (hvname) { 2068 SV* tmpsv = newSVpvs_flags("", SVs_TEMP); 2069 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", 2070 generic_pv_escape( tmpsv, hvname, 2071 HvNAMELEN(sv), HvNAMEUTF8(sv))); 2072 } 2073 } 2074 if (SvOOK(sv)) { 2075 AV * const backrefs 2076 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv)); 2077 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta; 2078 if (HvAUX(sv)->xhv_name_count) 2079 Perl_dump_indent(aTHX_ 2080 level, file, " NAMECOUNT = %" IVdf "\n", 2081 (IV)HvAUX(sv)->xhv_name_count 2082 ); 2083 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) { 2084 const I32 count = HvAUX(sv)->xhv_name_count; 2085 if (count) { 2086 SV * const names = newSVpvs_flags("", SVs_TEMP); 2087 /* The starting point is the first element if count is 2088 positive and the second element if count is negative. */ 2089 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names 2090 + (count < 0 ? 1 : 0); 2091 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names 2092 + (count < 0 ? -count : count); 2093 while (hekp < endp) { 2094 if (*hekp) { 2095 SV *tmp = newSVpvs_flags("", SVs_TEMP); 2096 Perl_sv_catpvf(aTHX_ names, ", \"%s\"", 2097 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp))); 2098 } else { 2099 /* This should never happen. */ 2100 sv_catpvs(names, ", (null)"); 2101 } 2102 ++hekp; 2103 } 2104 Perl_dump_indent(aTHX_ 2105 level, file, " ENAME = %s\n", SvPV_nolen(names)+2 2106 ); 2107 } 2108 else { 2109 SV * const tmp = newSVpvs_flags("", SVs_TEMP); 2110 const char *const hvename = HvENAME_get(sv); 2111 Perl_dump_indent(aTHX_ 2112 level, file, " ENAME = \"%s\"\n", 2113 generic_pv_escape(tmp, hvename, 2114 HvENAMELEN_get(sv), HvENAMEUTF8(sv))); 2115 } 2116 } 2117 if (backrefs) { 2118 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%" UVxf "\n", 2119 PTR2UV(backrefs)); 2120 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest, 2121 dumpops, pvlim); 2122 } 2123 if (meta) { 2124 SV* tmpsv = newSVpvs_flags("", SVs_TEMP); 2125 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%" 2126 UVxf ")\n", 2127 generic_pv_escape( tmpsv, meta->mro_which->name, 2128 meta->mro_which->length, 2129 (meta->mro_which->kflags & HVhek_UTF8)), 2130 PTR2UV(meta->mro_which)); 2131 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%" 2132 UVxf "\n", 2133 (UV)meta->cache_gen); 2134 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%" UVxf "\n", 2135 (UV)meta->pkg_gen); 2136 if (meta->mro_linear_all) { 2137 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%" 2138 UVxf "\n", 2139 PTR2UV(meta->mro_linear_all)); 2140 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest, 2141 dumpops, pvlim); 2142 } 2143 if (meta->mro_linear_current) { 2144 Perl_dump_indent(aTHX_ level, file, 2145 " MRO_LINEAR_CURRENT = 0x%" UVxf "\n", 2146 PTR2UV(meta->mro_linear_current)); 2147 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest, 2148 dumpops, pvlim); 2149 } 2150 if (meta->mro_nextmethod) { 2151 Perl_dump_indent(aTHX_ level, file, 2152 " MRO_NEXTMETHOD = 0x%" UVxf "\n", 2153 PTR2UV(meta->mro_nextmethod)); 2154 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest, 2155 dumpops, pvlim); 2156 } 2157 if (meta->isa) { 2158 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%" UVxf "\n", 2159 PTR2UV(meta->isa)); 2160 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest, 2161 dumpops, pvlim); 2162 } 2163 } 2164 } 2165 if (nest < maxnest) { 2166 HV * const hv = MUTABLE_HV(sv); 2167 STRLEN i; 2168 HE *he; 2169 2170 if (HvARRAY(hv)) { 2171 int count = maxnest - nest; 2172 for (i=0; i <= HvMAX(hv); i++) { 2173 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) { 2174 U32 hash; 2175 SV * keysv; 2176 const char * keypv; 2177 SV * elt; 2178 STRLEN len; 2179 2180 if (count-- <= 0) goto DONEHV; 2181 2182 hash = HeHASH(he); 2183 keysv = hv_iterkeysv(he); 2184 keypv = SvPV_const(keysv, len); 2185 elt = HeVAL(he); 2186 2187 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim)); 2188 if (SvUTF8(keysv)) 2189 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ)); 2190 if (HvEITER_get(hv) == he) 2191 PerlIO_printf(file, "[CURRENT] "); 2192 PerlIO_printf(file, "HASH = 0x%" UVxf "\n", (UV) hash); 2193 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim); 2194 } 2195 } 2196 DONEHV:; 2197 } 2198 } 2199 break; 2200 } /* case SVt_PVHV */ 2201 2202 case SVt_PVCV: 2203 if (CvAUTOLOAD(sv)) { 2204 SV* tmpsv = newSVpvs_flags("", SVs_TEMP); 2205 STRLEN len; 2206 const char *const name = SvPV_const(sv, len); 2207 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n", 2208 generic_pv_escape(tmpsv, name, len, SvUTF8(sv))); 2209 } 2210 if (SvPOK(sv)) { 2211 SV* tmpsv = newSVpvs_flags("", SVs_TEMP); 2212 const char *const proto = CvPROTO(sv); 2213 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n", 2214 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv), 2215 SvUTF8(sv))); 2216 } 2217 /* FALLTHROUGH */ 2218 case SVt_PVFM: 2219 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv)); 2220 if (!CvISXSUB(sv)) { 2221 if (CvSTART(sv)) { 2222 if (CvSLABBED(sv)) 2223 Perl_dump_indent(aTHX_ level, file, 2224 " SLAB = 0x%" UVxf "\n", 2225 PTR2UV(CvSTART(sv))); 2226 else 2227 Perl_dump_indent(aTHX_ level, file, 2228 " START = 0x%" UVxf " ===> %" IVdf "\n", 2229 PTR2UV(CvSTART(sv)), 2230 (IV)sequence_num(CvSTART(sv))); 2231 } 2232 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%" UVxf "\n", 2233 PTR2UV(CvROOT(sv))); 2234 if (CvROOT(sv) && dumpops) { 2235 do_op_dump(level+1, file, CvROOT(sv)); 2236 } 2237 } else { 2238 SV * const constant = cv_const_sv((const CV *)sv); 2239 2240 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%" UVxf "\n", PTR2UV(CvXSUB(sv))); 2241 2242 if (constant) { 2243 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%" UVxf 2244 " (CONST SV)\n", 2245 PTR2UV(CvXSUBANY(sv).any_ptr)); 2246 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops, 2247 pvlim); 2248 } else { 2249 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %" IVdf "\n", 2250 (IV)CvXSUBANY(sv).any_i32); 2251 } 2252 } 2253 if (CvNAMED(sv)) 2254 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", 2255 HEK_KEY(CvNAME_HEK((CV *)sv))); 2256 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv)); 2257 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv)); 2258 Perl_dump_indent(aTHX_ level, file, " DEPTH = %" 2259 IVdf "\n", (IV)CvDEPTH(sv)); 2260 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", 2261 (UV)CvFLAGS(sv)); 2262 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %" UVuf "\n", (UV)CvOUTSIDE_SEQ(sv)); 2263 if (!CvISXSUB(sv)) { 2264 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%" UVxf "\n", PTR2UV(CvPADLIST(sv))); 2265 if (nest < maxnest) { 2266 do_dump_pad(level+1, file, CvPADLIST(sv), 0); 2267 } 2268 } 2269 else 2270 Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv)); 2271 { 2272 const CV * const outside = CvOUTSIDE(sv); 2273 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%" UVxf " (%s)\n", 2274 PTR2UV(outside), 2275 (!outside ? "null" 2276 : CvANON(outside) ? "ANON" 2277 : (outside == PL_main_cv) ? "MAIN" 2278 : CvUNIQUE(outside) ? "UNIQUE" 2279 : CvGV(outside) ? 2280 generic_pv_escape( 2281 newSVpvs_flags("", SVs_TEMP), 2282 GvNAME(CvGV(outside)), 2283 GvNAMELEN(CvGV(outside)), 2284 GvNAMEUTF8(CvGV(outside))) 2285 : "UNDEFINED")); 2286 } 2287 if (CvOUTSIDE(sv) 2288 && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))) 2289 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim); 2290 break; 2291 2292 case SVt_PVGV: 2293 case SVt_PVLV: 2294 if (type == SVt_PVLV) { 2295 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv)); 2296 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %" IVdf "\n", (IV)LvTARGOFF(sv)); 2297 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %" IVdf "\n", (IV)LvTARGLEN(sv)); 2298 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%" UVxf "\n", PTR2UV(LvTARG(sv))); 2299 Perl_dump_indent(aTHX_ level, file, " FLAGS = %" IVdf "\n", (IV)LvFLAGS(sv)); 2300 if (isALPHA_FOLD_NE(LvTYPE(sv), 't')) 2301 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest, 2302 dumpops, pvlim); 2303 } 2304 if (isREGEXP(sv)) goto dumpregexp; 2305 if (!isGV_with_GP(sv)) 2306 break; 2307 { 2308 SV* tmpsv = newSVpvs_flags("", SVs_TEMP); 2309 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", 2310 generic_pv_escape(tmpsv, GvNAME(sv), 2311 GvNAMELEN(sv), 2312 GvNAMEUTF8(sv))); 2313 } 2314 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %" IVdf "\n", (IV)GvNAMELEN(sv)); 2315 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv)); 2316 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)GvFLAGS(sv)); 2317 Perl_dump_indent(aTHX_ level, file, " GP = 0x%" UVxf "\n", PTR2UV(GvGP(sv))); 2318 if (!GvGP(sv)) 2319 break; 2320 Perl_dump_indent(aTHX_ level, file, " SV = 0x%" UVxf "\n", PTR2UV(GvSV(sv))); 2321 Perl_dump_indent(aTHX_ level, file, " REFCNT = %" IVdf "\n", (IV)GvREFCNT(sv)); 2322 Perl_dump_indent(aTHX_ level, file, " IO = 0x%" UVxf "\n", PTR2UV(GvIOp(sv))); 2323 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%" UVxf " \n", PTR2UV(GvFORM(sv))); 2324 Perl_dump_indent(aTHX_ level, file, " AV = 0x%" UVxf "\n", PTR2UV(GvAV(sv))); 2325 Perl_dump_indent(aTHX_ level, file, " HV = 0x%" UVxf "\n", PTR2UV(GvHV(sv))); 2326 Perl_dump_indent(aTHX_ level, file, " CV = 0x%" UVxf "\n", PTR2UV(GvCV(sv))); 2327 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%" UVxf "\n", (UV)GvCVGEN(sv)); 2328 Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%" UVxf 2329 " (%s)\n", 2330 (UV)GvGPFLAGS(sv), 2331 ""); 2332 Perl_dump_indent(aTHX_ level, file, " LINE = %" IVdf "\n", (IV)GvLINE(sv)); 2333 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv)); 2334 do_gv_dump (level, file, " EGV", GvEGV(sv)); 2335 break; 2336 case SVt_PVIO: 2337 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%" UVxf "\n", PTR2UV(IoIFP(sv))); 2338 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%" UVxf "\n", PTR2UV(IoOFP(sv))); 2339 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%" UVxf "\n", PTR2UV(IoDIRP(sv))); 2340 Perl_dump_indent(aTHX_ level, file, " LINES = %" IVdf "\n", (IV)IoLINES(sv)); 2341 Perl_dump_indent(aTHX_ level, file, " PAGE = %" IVdf "\n", (IV)IoPAGE(sv)); 2342 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %" IVdf "\n", (IV)IoPAGE_LEN(sv)); 2343 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %" IVdf "\n", (IV)IoLINES_LEFT(sv)); 2344 if (IoTOP_NAME(sv)) 2345 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv)); 2346 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV) 2347 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv)); 2348 else { 2349 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%" UVxf "\n", 2350 PTR2UV(IoTOP_GV(sv))); 2351 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1, 2352 maxnest, dumpops, pvlim); 2353 } 2354 /* Source filters hide things that are not GVs in these three, so let's 2355 be careful out there. */ 2356 if (IoFMT_NAME(sv)) 2357 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv)); 2358 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV) 2359 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv)); 2360 else { 2361 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%" UVxf "\n", 2362 PTR2UV(IoFMT_GV(sv))); 2363 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1, 2364 maxnest, dumpops, pvlim); 2365 } 2366 if (IoBOTTOM_NAME(sv)) 2367 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv)); 2368 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV) 2369 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv)); 2370 else { 2371 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%" UVxf "\n", 2372 PTR2UV(IoBOTTOM_GV(sv))); 2373 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1, 2374 maxnest, dumpops, pvlim); 2375 } 2376 if (isPRINT(IoTYPE(sv))) 2377 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv)); 2378 else 2379 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv)); 2380 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)IoFLAGS(sv)); 2381 break; 2382 case SVt_REGEXP: 2383 dumpregexp: 2384 { 2385 struct regexp * const r = ReANY((REGEXP*)sv); 2386 2387 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \ 2388 sv_setpv(d,""); \ 2389 append_flags(d, flags, names); \ 2390 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \ 2391 SvCUR_set(d, SvCUR(d) - 1); \ 2392 SvPVX(d)[SvCUR(d)] = '\0'; \ 2393 } \ 2394 } STMT_END 2395 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names); 2396 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%" UVxf " (%s)\n", 2397 (UV)(r->compflags), SvPVX_const(d)); 2398 2399 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names); 2400 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%" UVxf " (%s)\n", 2401 (UV)(r->extflags), SvPVX_const(d)); 2402 2403 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%" UVxf " (%s)\n", 2404 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" ); 2405 if (r->engine == &PL_core_reg_engine) { 2406 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names); 2407 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf " (%s)\n", 2408 (UV)(r->intflags), SvPVX_const(d)); 2409 } else { 2410 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf "\n", 2411 (UV)(r->intflags)); 2412 } 2413 #undef SV_SET_STRINGIFY_REGEXP_FLAGS 2414 Perl_dump_indent(aTHX_ level, file, " NPARENS = %" UVuf "\n", 2415 (UV)(r->nparens)); 2416 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %" UVuf "\n", 2417 (UV)(r->lastparen)); 2418 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %" UVuf "\n", 2419 (UV)(r->lastcloseparen)); 2420 Perl_dump_indent(aTHX_ level, file, " MINLEN = %" IVdf "\n", 2421 (IV)(r->minlen)); 2422 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %" IVdf "\n", 2423 (IV)(r->minlenret)); 2424 Perl_dump_indent(aTHX_ level, file, " GOFS = %" UVuf "\n", 2425 (UV)(r->gofs)); 2426 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %" UVuf "\n", 2427 (UV)(r->pre_prefix)); 2428 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %" IVdf "\n", 2429 (IV)(r->sublen)); 2430 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %" IVdf "\n", 2431 (IV)(r->suboffset)); 2432 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %" IVdf "\n", 2433 (IV)(r->subcoffset)); 2434 if (r->subbeg) 2435 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%" UVxf " %s\n", 2436 PTR2UV(r->subbeg), 2437 pv_display(d, r->subbeg, r->sublen, 50, pvlim)); 2438 else 2439 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n"); 2440 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%" UVxf "\n", 2441 PTR2UV(r->mother_re)); 2442 if (nest < maxnest && r->mother_re) 2443 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1, 2444 maxnest, dumpops, pvlim); 2445 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%" UVxf "\n", 2446 PTR2UV(r->paren_names)); 2447 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%" UVxf "\n", 2448 PTR2UV(r->substrs)); 2449 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%" UVxf "\n", 2450 PTR2UV(r->pprivate)); 2451 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%" UVxf "\n", 2452 PTR2UV(r->offs)); 2453 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%" UVxf "\n", 2454 PTR2UV(r->qr_anoncv)); 2455 #ifdef PERL_ANY_COW 2456 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%" UVxf "\n", 2457 PTR2UV(r->saved_copy)); 2458 #endif 2459 } 2460 break; 2461 } 2462 SvREFCNT_dec_NN(d); 2463 } 2464 2465 /* 2466 =for apidoc sv_dump 2467 2468 Dumps the contents of an SV to the C<STDERR> filehandle. 2469 2470 For an example of its output, see L<Devel::Peek>. 2471 2472 =cut 2473 */ 2474 2475 void 2476 Perl_sv_dump(pTHX_ SV *sv) 2477 { 2478 if (sv && SvROK(sv)) 2479 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0); 2480 else 2481 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0); 2482 } 2483 2484 int 2485 Perl_runops_debug(pTHX) 2486 { 2487 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY 2488 SSize_t orig_stack_hwm = PL_curstackinfo->si_stack_hwm; 2489 2490 PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base; 2491 #endif 2492 2493 if (!PL_op) { 2494 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN"); 2495 return 0; 2496 } 2497 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n")); 2498 do { 2499 #ifdef PERL_TRACE_OPS 2500 ++PL_op_exec_cnt[PL_op->op_type]; 2501 #endif 2502 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY 2503 if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base) 2504 Perl_croak_nocontext( 2505 "panic: previous op failed to extend arg stack: " 2506 "base=%p, sp=%p, hwm=%p\n", 2507 PL_stack_base, PL_stack_sp, 2508 PL_stack_base + PL_curstackinfo->si_stack_hwm); 2509 PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base; 2510 #endif 2511 if (PL_debug) { 2512 ENTER; 2513 SAVETMPS; 2514 if (PL_watchaddr && (*PL_watchaddr != PL_watchok)) 2515 PerlIO_printf(Perl_debug_log, 2516 "WARNING: %" UVxf " changed from %" UVxf " to %" UVxf "\n", 2517 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok), 2518 PTR2UV(*PL_watchaddr)); 2519 if (DEBUG_s_TEST_) { 2520 if (DEBUG_v_TEST_) { 2521 PerlIO_printf(Perl_debug_log, "\n"); 2522 deb_stack_all(); 2523 } 2524 else 2525 debstack(); 2526 } 2527 2528 2529 if (DEBUG_t_TEST_) debop(PL_op); 2530 if (DEBUG_P_TEST_) debprof(PL_op); 2531 FREETMPS; 2532 LEAVE; 2533 } 2534 2535 PERL_DTRACE_PROBE_OP(PL_op); 2536 } while ((PL_op = PL_op->op_ppaddr(aTHX))); 2537 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n")); 2538 PERL_ASYNC_CHECK(); 2539 2540 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY 2541 if (PL_curstackinfo->si_stack_hwm < orig_stack_hwm) 2542 PL_curstackinfo->si_stack_hwm = orig_stack_hwm; 2543 #endif 2544 TAINT_NOT; 2545 return 0; 2546 } 2547 2548 2549 /* print the names of the n lexical vars starting at pad offset off */ 2550 2551 STATIC void 2552 S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren) 2553 { 2554 PADNAME *sv; 2555 CV * const cv = deb_curcv(cxstack_ix); 2556 PADNAMELIST *comppad = NULL; 2557 int i; 2558 2559 if (cv) { 2560 PADLIST * const padlist = CvPADLIST(cv); 2561 comppad = PadlistNAMES(padlist); 2562 } 2563 if (paren) 2564 PerlIO_printf(Perl_debug_log, "("); 2565 for (i = 0; i < n; i++) { 2566 if (comppad && (sv = padnamelist_fetch(comppad, off + i))) 2567 PerlIO_printf(Perl_debug_log, "%" PNf, PNfARG(sv)); 2568 else 2569 PerlIO_printf(Perl_debug_log, "[%" UVuf "]", 2570 (UV)(off+i)); 2571 if (i < n - 1) 2572 PerlIO_printf(Perl_debug_log, ","); 2573 } 2574 if (paren) 2575 PerlIO_printf(Perl_debug_log, ")"); 2576 } 2577 2578 2579 /* append to the out SV, the name of the lexical at offset off in the CV 2580 * cv */ 2581 2582 static void 2583 S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n, 2584 bool paren, bool is_scalar) 2585 { 2586 PADNAME *sv; 2587 PADNAMELIST *namepad = NULL; 2588 int i; 2589 2590 if (cv) { 2591 PADLIST * const padlist = CvPADLIST(cv); 2592 namepad = PadlistNAMES(padlist); 2593 } 2594 2595 if (paren) 2596 sv_catpvs_nomg(out, "("); 2597 for (i = 0; i < n; i++) { 2598 if (namepad && (sv = padnamelist_fetch(namepad, off + i))) 2599 { 2600 STRLEN cur = SvCUR(out); 2601 Perl_sv_catpvf(aTHX_ out, "[%" UTF8f, 2602 UTF8fARG(1, PadnameLEN(sv) - 1, 2603 PadnamePV(sv) + 1)); 2604 if (is_scalar) 2605 SvPVX(out)[cur] = '$'; 2606 } 2607 else 2608 Perl_sv_catpvf(aTHX_ out, "[%" UVuf "]", (UV)(off+i)); 2609 if (i < n - 1) 2610 sv_catpvs_nomg(out, ","); 2611 } 2612 if (paren) 2613 sv_catpvs_nomg(out, "("); 2614 } 2615 2616 2617 static void 2618 S_append_gv_name(pTHX_ GV *gv, SV *out) 2619 { 2620 SV *sv; 2621 if (!gv) { 2622 sv_catpvs_nomg(out, "<NULLGV>"); 2623 return; 2624 } 2625 sv = newSV(0); 2626 gv_fullname4(sv, gv, NULL, FALSE); 2627 Perl_sv_catpvf(aTHX_ out, "$%" SVf, SVfARG(sv)); 2628 SvREFCNT_dec_NN(sv); 2629 } 2630 2631 #ifdef USE_ITHREADS 2632 # define ITEM_SV(item) (comppad ? \ 2633 *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL); 2634 #else 2635 # define ITEM_SV(item) UNOP_AUX_item_sv(item) 2636 #endif 2637 2638 2639 /* return a temporary SV containing a stringified representation of 2640 * the op_aux field of a MULTIDEREF op, associated with CV cv 2641 */ 2642 2643 SV* 2644 Perl_multideref_stringify(pTHX_ const OP *o, CV *cv) 2645 { 2646 UNOP_AUX_item *items = cUNOP_AUXo->op_aux; 2647 UV actions = items->uv; 2648 SV *sv; 2649 bool last = 0; 2650 bool is_hash = FALSE; 2651 int derefs = 0; 2652 SV *out = newSVpvn_flags("",0,SVs_TEMP); 2653 #ifdef USE_ITHREADS 2654 PAD *comppad; 2655 2656 if (cv) { 2657 PADLIST *padlist = CvPADLIST(cv); 2658 comppad = PadlistARRAY(padlist)[1]; 2659 } 2660 else 2661 comppad = NULL; 2662 #endif 2663 2664 PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY; 2665 2666 while (!last) { 2667 switch (actions & MDEREF_ACTION_MASK) { 2668 2669 case MDEREF_reload: 2670 actions = (++items)->uv; 2671 continue; 2672 NOT_REACHED; /* NOTREACHED */ 2673 2674 case MDEREF_HV_padhv_helem: 2675 is_hash = TRUE; 2676 /* FALLTHROUGH */ 2677 case MDEREF_AV_padav_aelem: 2678 derefs = 1; 2679 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1); 2680 goto do_elem; 2681 NOT_REACHED; /* NOTREACHED */ 2682 2683 case MDEREF_HV_gvhv_helem: 2684 is_hash = TRUE; 2685 /* FALLTHROUGH */ 2686 case MDEREF_AV_gvav_aelem: 2687 derefs = 1; 2688 items++; 2689 sv = ITEM_SV(items); 2690 S_append_gv_name(aTHX_ (GV*)sv, out); 2691 goto do_elem; 2692 NOT_REACHED; /* NOTREACHED */ 2693 2694 case MDEREF_HV_gvsv_vivify_rv2hv_helem: 2695 is_hash = TRUE; 2696 /* FALLTHROUGH */ 2697 case MDEREF_AV_gvsv_vivify_rv2av_aelem: 2698 items++; 2699 sv = ITEM_SV(items); 2700 S_append_gv_name(aTHX_ (GV*)sv, out); 2701 goto do_vivify_rv2xv_elem; 2702 NOT_REACHED; /* NOTREACHED */ 2703 2704 case MDEREF_HV_padsv_vivify_rv2hv_helem: 2705 is_hash = TRUE; 2706 /* FALLTHROUGH */ 2707 case MDEREF_AV_padsv_vivify_rv2av_aelem: 2708 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1); 2709 goto do_vivify_rv2xv_elem; 2710 NOT_REACHED; /* NOTREACHED */ 2711 2712 case MDEREF_HV_pop_rv2hv_helem: 2713 case MDEREF_HV_vivify_rv2hv_helem: 2714 is_hash = TRUE; 2715 /* FALLTHROUGH */ 2716 do_vivify_rv2xv_elem: 2717 case MDEREF_AV_pop_rv2av_aelem: 2718 case MDEREF_AV_vivify_rv2av_aelem: 2719 if (!derefs++) 2720 sv_catpvs_nomg(out, "->"); 2721 do_elem: 2722 if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) { 2723 sv_catpvs_nomg(out, "->"); 2724 last = 1; 2725 break; 2726 } 2727 2728 sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1); 2729 switch (actions & MDEREF_INDEX_MASK) { 2730 case MDEREF_INDEX_const: 2731 if (is_hash) { 2732 items++; 2733 sv = ITEM_SV(items); 2734 if (!sv) 2735 sv_catpvs_nomg(out, "???"); 2736 else { 2737 STRLEN cur; 2738 char *s; 2739 s = SvPV(sv, cur); 2740 pv_pretty(out, s, cur, 30, 2741 NULL, NULL, 2742 (PERL_PV_PRETTY_NOCLEAR 2743 |PERL_PV_PRETTY_QUOTE 2744 |PERL_PV_PRETTY_ELLIPSES)); 2745 } 2746 } 2747 else 2748 Perl_sv_catpvf(aTHX_ out, "%" IVdf, (++items)->iv); 2749 break; 2750 case MDEREF_INDEX_padsv: 2751 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1); 2752 break; 2753 case MDEREF_INDEX_gvsv: 2754 items++; 2755 sv = ITEM_SV(items); 2756 S_append_gv_name(aTHX_ (GV*)sv, out); 2757 break; 2758 } 2759 sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1); 2760 2761 if (actions & MDEREF_FLAG_last) 2762 last = 1; 2763 is_hash = FALSE; 2764 2765 break; 2766 2767 default: 2768 PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)", 2769 (int)(actions & MDEREF_ACTION_MASK)); 2770 last = 1; 2771 break; 2772 2773 } /* switch */ 2774 2775 actions >>= MDEREF_SHIFT; 2776 } /* while */ 2777 return out; 2778 } 2779 2780 2781 /* Return a temporary SV containing a stringified representation of 2782 * the op_aux field of a MULTICONCAT op. Note that if the aux contains 2783 * both plain and utf8 versions of the const string and indices, only 2784 * the first is displayed. 2785 */ 2786 2787 SV* 2788 Perl_multiconcat_stringify(pTHX_ const OP *o) 2789 { 2790 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux; 2791 UNOP_AUX_item *lens; 2792 STRLEN len; 2793 SSize_t nargs; 2794 char *s; 2795 SV *out = newSVpvn_flags("", 0, SVs_TEMP); 2796 2797 PERL_ARGS_ASSERT_MULTICONCAT_STRINGIFY; 2798 2799 nargs = aux[PERL_MULTICONCAT_IX_NARGS].ssize; 2800 s = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv; 2801 len = aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize; 2802 if (!s) { 2803 s = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv; 2804 len = aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize; 2805 sv_catpvs(out, "UTF8 "); 2806 } 2807 pv_pretty(out, s, len, 50, 2808 NULL, NULL, 2809 (PERL_PV_PRETTY_NOCLEAR 2810 |PERL_PV_PRETTY_QUOTE 2811 |PERL_PV_PRETTY_ELLIPSES)); 2812 2813 lens = aux + PERL_MULTICONCAT_IX_LENGTHS; 2814 while (nargs-- >= 0) { 2815 Perl_sv_catpvf(aTHX_ out, ",%" IVdf, (IV)lens->ssize); 2816 lens++; 2817 } 2818 return out; 2819 } 2820 2821 2822 I32 2823 Perl_debop(pTHX_ const OP *o) 2824 { 2825 PERL_ARGS_ASSERT_DEBOP; 2826 2827 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_) 2828 return 0; 2829 2830 Perl_deb(aTHX_ "%s", OP_NAME(o)); 2831 switch (o->op_type) { 2832 case OP_CONST: 2833 case OP_HINTSEVAL: 2834 /* With ITHREADS, consts are stored in the pad, and the right pad 2835 * may not be active here, so check. 2836 * Looks like only during compiling the pads are illegal. 2837 */ 2838 #ifdef USE_ITHREADS 2839 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME) 2840 #endif 2841 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv)); 2842 break; 2843 case OP_GVSV: 2844 case OP_GV: 2845 PerlIO_printf(Perl_debug_log, "(%" SVf ")", 2846 SVfARG(S_gv_display(aTHX_ cGVOPo_gv))); 2847 break; 2848 2849 case OP_PADSV: 2850 case OP_PADAV: 2851 case OP_PADHV: 2852 case OP_ARGELEM: 2853 S_deb_padvar(aTHX_ o->op_targ, 1, 1); 2854 break; 2855 2856 case OP_PADRANGE: 2857 S_deb_padvar(aTHX_ o->op_targ, 2858 o->op_private & OPpPADRANGE_COUNTMASK, 1); 2859 break; 2860 2861 case OP_MULTIDEREF: 2862 PerlIO_printf(Perl_debug_log, "(%" SVf ")", 2863 SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix)))); 2864 break; 2865 2866 case OP_MULTICONCAT: 2867 PerlIO_printf(Perl_debug_log, "(%" SVf ")", 2868 SVfARG(multiconcat_stringify(o))); 2869 break; 2870 2871 default: 2872 break; 2873 } 2874 PerlIO_printf(Perl_debug_log, "\n"); 2875 return 0; 2876 } 2877 2878 2879 /* 2880 =for apidoc op_class 2881 2882 Given an op, determine what type of struct it has been allocated as. 2883 Returns one of the OPclass enums, such as OPclass_LISTOP. 2884 2885 =cut 2886 */ 2887 2888 2889 OPclass 2890 Perl_op_class(pTHX_ const OP *o) 2891 { 2892 bool custom = 0; 2893 2894 if (!o) 2895 return OPclass_NULL; 2896 2897 if (o->op_type == 0) { 2898 if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE) 2899 return OPclass_COP; 2900 return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP; 2901 } 2902 2903 if (o->op_type == OP_SASSIGN) 2904 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPclass_UNOP : OPclass_BINOP); 2905 2906 if (o->op_type == OP_AELEMFAST) { 2907 #ifdef USE_ITHREADS 2908 return OPclass_PADOP; 2909 #else 2910 return OPclass_SVOP; 2911 #endif 2912 } 2913 2914 #ifdef USE_ITHREADS 2915 if (o->op_type == OP_GV || o->op_type == OP_GVSV || 2916 o->op_type == OP_RCATLINE) 2917 return OPclass_PADOP; 2918 #endif 2919 2920 if (o->op_type == OP_CUSTOM) 2921 custom = 1; 2922 2923 switch (OP_CLASS(o)) { 2924 case OA_BASEOP: 2925 return OPclass_BASEOP; 2926 2927 case OA_UNOP: 2928 return OPclass_UNOP; 2929 2930 case OA_BINOP: 2931 return OPclass_BINOP; 2932 2933 case OA_LOGOP: 2934 return OPclass_LOGOP; 2935 2936 case OA_LISTOP: 2937 return OPclass_LISTOP; 2938 2939 case OA_PMOP: 2940 return OPclass_PMOP; 2941 2942 case OA_SVOP: 2943 return OPclass_SVOP; 2944 2945 case OA_PADOP: 2946 return OPclass_PADOP; 2947 2948 case OA_PVOP_OR_SVOP: 2949 /* 2950 * Character translations (tr///) are usually a PVOP, keeping a 2951 * pointer to a table of shorts used to look up translations. 2952 * Under utf8, however, a simple table isn't practical; instead, 2953 * the OP is an SVOP (or, under threads, a PADOP), 2954 * and the SV is a reference to a swash 2955 * (i.e., an RV pointing to an HV). 2956 */ 2957 return (!custom && 2958 (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF)) 2959 ) 2960 #if defined(USE_ITHREADS) 2961 ? OPclass_PADOP : OPclass_PVOP; 2962 #else 2963 ? OPclass_SVOP : OPclass_PVOP; 2964 #endif 2965 2966 case OA_LOOP: 2967 return OPclass_LOOP; 2968 2969 case OA_COP: 2970 return OPclass_COP; 2971 2972 case OA_BASEOP_OR_UNOP: 2973 /* 2974 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on 2975 * whether parens were seen. perly.y uses OPf_SPECIAL to 2976 * signal whether a BASEOP had empty parens or none. 2977 * Some other UNOPs are created later, though, so the best 2978 * test is OPf_KIDS, which is set in newUNOP. 2979 */ 2980 return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP; 2981 2982 case OA_FILESTATOP: 2983 /* 2984 * The file stat OPs are created via UNI(OP_foo) in toke.c but use 2985 * the OPf_REF flag to distinguish between OP types instead of the 2986 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we 2987 * return OPclass_UNOP so that walkoptree can find our children. If 2988 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set 2989 * (no argument to the operator) it's an OP; with OPf_REF set it's 2990 * an SVOP (and op_sv is the GV for the filehandle argument). 2991 */ 2992 return ((o->op_flags & OPf_KIDS) ? OPclass_UNOP : 2993 #ifdef USE_ITHREADS 2994 (o->op_flags & OPf_REF) ? OPclass_PADOP : OPclass_BASEOP); 2995 #else 2996 (o->op_flags & OPf_REF) ? OPclass_SVOP : OPclass_BASEOP); 2997 #endif 2998 case OA_LOOPEXOP: 2999 /* 3000 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a 3001 * label was omitted (in which case it's a BASEOP) or else a term was 3002 * seen. In this last case, all except goto are definitely PVOP but 3003 * goto is either a PVOP (with an ordinary constant label), an UNOP 3004 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for 3005 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to 3006 * get set. 3007 */ 3008 if (o->op_flags & OPf_STACKED) 3009 return OPclass_UNOP; 3010 else if (o->op_flags & OPf_SPECIAL) 3011 return OPclass_BASEOP; 3012 else 3013 return OPclass_PVOP; 3014 case OA_METHOP: 3015 return OPclass_METHOP; 3016 case OA_UNOP_AUX: 3017 return OPclass_UNOP_AUX; 3018 } 3019 Perl_warn(aTHX_ "Can't determine class of operator %s, assuming BASEOP\n", 3020 OP_NAME(o)); 3021 return OPclass_BASEOP; 3022 } 3023 3024 3025 3026 STATIC CV* 3027 S_deb_curcv(pTHX_ I32 ix) 3028 { 3029 PERL_SI *si = PL_curstackinfo; 3030 for (; ix >=0; ix--) { 3031 const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix]; 3032 3033 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) 3034 return cx->blk_sub.cv; 3035 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx)) 3036 return cx->blk_eval.cv; 3037 else if (ix == 0 && si->si_type == PERLSI_MAIN) 3038 return PL_main_cv; 3039 else if (ix == 0 && CxTYPE(cx) == CXt_NULL 3040 && si->si_type == PERLSI_SORT) 3041 { 3042 /* fake sort sub; use CV of caller */ 3043 si = si->si_prev; 3044 ix = si->si_cxix + 1; 3045 } 3046 } 3047 return NULL; 3048 } 3049 3050 void 3051 Perl_watch(pTHX_ char **addr) 3052 { 3053 PERL_ARGS_ASSERT_WATCH; 3054 3055 PL_watchaddr = addr; 3056 PL_watchok = *addr; 3057 PerlIO_printf(Perl_debug_log, "WATCHING, %" UVxf " is currently %" UVxf "\n", 3058 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok)); 3059 } 3060 3061 STATIC void 3062 S_debprof(pTHX_ const OP *o) 3063 { 3064 PERL_ARGS_ASSERT_DEBPROF; 3065 3066 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash)) 3067 return; 3068 if (!PL_profiledata) 3069 Newxz(PL_profiledata, MAXO, U32); 3070 ++PL_profiledata[o->op_type]; 3071 } 3072 3073 void 3074 Perl_debprofdump(pTHX) 3075 { 3076 unsigned i; 3077 if (!PL_profiledata) 3078 return; 3079 for (i = 0; i < MAXO; i++) { 3080 if (PL_profiledata[i]) 3081 PerlIO_printf(Perl_debug_log, 3082 "%5lu %s\n", (unsigned long)PL_profiledata[i], 3083 PL_op_name[i]); 3084 } 3085 } 3086 3087 3088 /* 3089 * ex: set ts=8 sts=4 sw=4 et: 3090 */ 3091