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_catpvs(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_catpvs(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_catpvs(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_catpvs(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_catpvs(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_catpvs(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_catpvs(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_catpvs(t, ":"); 422 } 423 else if (SvREFCNT(sv) == 0) { 424 sv_catpvs(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_catpvs(t, "\\"); 449 if (SvCUR(t) + unref > 10) { 450 SvCUR_set(t, unref + 3); 451 *SvEND(t) = '\0'; 452 sv_catpvs(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_catpvs(t, "FREED"); 473 goto finish; 474 } 475 476 if (SvPOKp(sv)) { 477 if (!SvPVX_const(sv)) 478 sv_catpvs(t, "(null)"); 479 else { 480 SV * const tmp = newSVpvs(""); 481 sv_catpvs(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_catpvs(t, "()"); 509 510 finish: 511 while (unref--) 512 sv_catpvs(t, ")"); 513 if (TAINTING_get && sv && SvTAINTED(sv)) 514 sv_catpvs(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_catpvs(desc, ",ONCE"); 879 #ifdef USE_ITHREADS 880 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset])) 881 sv_catpvs(desc, ":USED"); 882 #else 883 if (pmflags & PMf_USED) 884 sv_catpvs(desc, ":USED"); 885 #endif 886 887 if (regex) { 888 if (RX_ISTAINTED(regex)) 889 sv_catpvs(desc, ",TAINTED"); 890 if (RX_CHECK_SUBSTR(regex)) { 891 if (!(RX_INTFLAGS(regex) & PREGf_NOSCAN)) 892 sv_catpvs(desc, ",SCANFIRST"); 893 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL) 894 sv_catpvs(desc, ",ALL"); 895 } 896 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE) 897 sv_catpvs(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_catpvs(tmpsv, ",VOID"); 1017 break; 1018 case OPf_WANT_SCALAR: 1019 sv_catpvs(tmpsv, ",SCALAR"); 1020 break; 1021 case OPf_WANT_LIST: 1022 sv_catpvs(tmpsv, ",LIST"); 1023 break; 1024 default: 1025 sv_catpvs(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_catpvs(tmpsv, ","); 1090 if (label != -1) { 1091 sv_catpv(tmpsv, &PL_op_private_labels[label]); 1092 sv_catpvs(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_catpvs(tmpsv, ","); 1108 sv_catpv(tmpsv, &PL_op_private_labels[ix]); 1109 } 1110 } 1111 } 1112 if (oppriv) { 1113 sv_catpvs(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 dVAR; 1703 SV *d; 1704 const char *s; 1705 U32 flags; 1706 U32 type; 1707 1708 PERL_ARGS_ASSERT_DO_SV_DUMP; 1709 1710 if (!sv) { 1711 Perl_dump_indent(aTHX_ level, file, "SV = 0\n"); 1712 return; 1713 } 1714 1715 flags = SvFLAGS(sv); 1716 type = SvTYPE(sv); 1717 1718 /* process general SV flags */ 1719 1720 d = Perl_newSVpvf(aTHX_ 1721 "(0x%" UVxf ") at 0x%" UVxf "\n%*s REFCNT = %" IVdf "\n%*s FLAGS = (", 1722 PTR2UV(SvANY(sv)), PTR2UV(sv), 1723 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv), 1724 (int)(PL_dumpindent*level), ""); 1725 1726 if ((flags & SVs_PADSTALE)) 1727 sv_catpvs(d, "PADSTALE,"); 1728 if ((flags & SVs_PADTMP)) 1729 sv_catpvs(d, "PADTMP,"); 1730 append_flags(d, flags, first_sv_flags_names); 1731 if (flags & SVf_ROK) { 1732 sv_catpvs(d, "ROK,"); 1733 if (SvWEAKREF(sv)) sv_catpvs(d, "WEAKREF,"); 1734 } 1735 if (flags & SVf_IsCOW && type != SVt_PVHV) sv_catpvs(d, "IsCOW,"); 1736 append_flags(d, flags, second_sv_flags_names); 1737 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv) 1738 && type != SVt_PVAV) { 1739 if (SvPCS_IMPORTED(sv)) 1740 sv_catpvs(d, "PCS_IMPORTED,"); 1741 else 1742 sv_catpvs(d, "SCREAM,"); 1743 } 1744 1745 /* process type-specific SV flags */ 1746 1747 switch (type) { 1748 case SVt_PVCV: 1749 case SVt_PVFM: 1750 append_flags(d, CvFLAGS(sv), cv_flags_names); 1751 break; 1752 case SVt_PVHV: 1753 append_flags(d, flags, hv_flags_names); 1754 break; 1755 case SVt_PVGV: 1756 case SVt_PVLV: 1757 if (isGV_with_GP(sv)) { 1758 append_flags(d, GvFLAGS(sv), gp_flags_names); 1759 } 1760 if (isGV_with_GP(sv) && GvIMPORTED(sv)) { 1761 sv_catpvs(d, "IMPORT"); 1762 if (GvIMPORTED(sv) == GVf_IMPORTED) 1763 sv_catpvs(d, "ALL,"); 1764 else { 1765 sv_catpvs(d, "("); 1766 append_flags(d, GvFLAGS(sv), gp_flags_imported_names); 1767 sv_catpvs(d, " ),"); 1768 } 1769 } 1770 /* FALLTHROUGH */ 1771 case SVt_PVMG: 1772 default: 1773 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpvs(d, "IsUV,"); 1774 break; 1775 1776 case SVt_PVAV: 1777 break; 1778 } 1779 /* SVphv_SHAREKEYS is also 0x20000000 */ 1780 if ((type != SVt_PVHV) && SvUTF8(sv)) 1781 sv_catpvs(d, "UTF8"); 1782 1783 if (*(SvEND(d) - 1) == ',') { 1784 SvCUR_set(d, SvCUR(d) - 1); 1785 SvPVX(d)[SvCUR(d)] = '\0'; 1786 } 1787 sv_catpvs(d, ")"); 1788 s = SvPVX_const(d); 1789 1790 /* dump initial SV details */ 1791 1792 #ifdef DEBUG_LEAKING_SCALARS 1793 Perl_dump_indent(aTHX_ level, file, 1794 "ALLOCATED at %s:%d %s %s (parent 0x%" UVxf "); serial %" UVuf "\n", 1795 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)", 1796 sv->sv_debug_line, 1797 sv->sv_debug_inpad ? "for" : "by", 1798 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)", 1799 PTR2UV(sv->sv_debug_parent), 1800 sv->sv_debug_serial 1801 ); 1802 #endif 1803 Perl_dump_indent(aTHX_ level, file, "SV = "); 1804 1805 /* Dump SV type */ 1806 1807 if (type < SVt_LAST) { 1808 PerlIO_printf(file, "%s%s\n", svtypenames[type], s); 1809 1810 if (type == SVt_NULL) { 1811 SvREFCNT_dec_NN(d); 1812 return; 1813 } 1814 } else { 1815 PerlIO_printf(file, "UNKNOWN(0x%" UVxf ") %s\n", (UV)type, s); 1816 SvREFCNT_dec_NN(d); 1817 return; 1818 } 1819 1820 /* Dump general SV fields */ 1821 1822 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV 1823 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_PVIO 1824 && type != SVt_REGEXP && !isGV_with_GP(sv) && !SvVALID(sv)) 1825 || (type == SVt_IV && !SvROK(sv))) { 1826 if (SvIsUV(sv) 1827 ) 1828 Perl_dump_indent(aTHX_ level, file, " UV = %" UVuf, (UV)SvUVX(sv)); 1829 else 1830 Perl_dump_indent(aTHX_ level, file, " IV = %" IVdf, (IV)SvIVX(sv)); 1831 (void)PerlIO_putc(file, '\n'); 1832 } 1833 1834 if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV 1835 && type != SVt_PVCV && type != SVt_PVFM && type != SVt_REGEXP 1836 && type != SVt_PVIO && !isGV_with_GP(sv) && !SvVALID(sv)) 1837 || type == SVt_NV) { 1838 DECLARATION_FOR_LC_NUMERIC_MANIPULATION; 1839 STORE_LC_NUMERIC_SET_STANDARD(); 1840 Perl_dump_indent(aTHX_ level, file, " NV = %.*" NVgf "\n", NV_DIG, SvNVX(sv)); 1841 RESTORE_LC_NUMERIC(); 1842 } 1843 1844 if (SvROK(sv)) { 1845 Perl_dump_indent(aTHX_ level, file, " RV = 0x%" UVxf "\n", 1846 PTR2UV(SvRV(sv))); 1847 if (nest < maxnest) 1848 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim); 1849 } 1850 1851 if (type < SVt_PV) { 1852 SvREFCNT_dec_NN(d); 1853 return; 1854 } 1855 1856 if ((type <= SVt_PVLV && !isGV_with_GP(sv)) 1857 || (type == SVt_PVIO && IoFLAGS(sv) & IOf_FAKE_DIRP)) { 1858 const bool re = isREGEXP(sv); 1859 const char * const ptr = 1860 re ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv); 1861 if (ptr) { 1862 STRLEN delta; 1863 if (SvOOK(sv)) { 1864 SvOOK_offset(sv, delta); 1865 Perl_dump_indent(aTHX_ level, file," OFFSET = %" UVuf "\n", 1866 (UV) delta); 1867 } else { 1868 delta = 0; 1869 } 1870 Perl_dump_indent(aTHX_ level, file," PV = 0x%" UVxf " ", 1871 PTR2UV(ptr)); 1872 if (SvOOK(sv)) { 1873 PerlIO_printf(file, "( %s . ) ", 1874 pv_display(d, ptr - delta, delta, 0, 1875 pvlim)); 1876 } 1877 if (type == SVt_INVLIST) { 1878 PerlIO_printf(file, "\n"); 1879 /* 4 blanks indents 2 beyond the PV, etc */ 1880 _invlist_dump(file, level, " ", sv); 1881 } 1882 else { 1883 PerlIO_printf(file, "%s", pv_display(d, ptr, SvCUR(sv), 1884 re ? 0 : SvLEN(sv), 1885 pvlim)); 1886 if (SvUTF8(sv)) /* the 6? \x{....} */ 1887 PerlIO_printf(file, " [UTF8 \"%s\"]", 1888 sv_uni_display(d, sv, 6 * SvCUR(sv), 1889 UNI_DISPLAY_QQ)); 1890 PerlIO_printf(file, "\n"); 1891 } 1892 Perl_dump_indent(aTHX_ level, file, " CUR = %" IVdf "\n", (IV)SvCUR(sv)); 1893 if (re && type == SVt_PVLV) 1894 /* LV-as-REGEXP usurps len field to store pointer to 1895 * regexp struct */ 1896 Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%" UVxf "\n", 1897 PTR2UV(((XPV*)SvANY(sv))->xpv_len_u.xpvlenu_rx)); 1898 else 1899 Perl_dump_indent(aTHX_ level, file, " LEN = %" IVdf "\n", 1900 (IV)SvLEN(sv)); 1901 #ifdef PERL_COPY_ON_WRITE 1902 if (SvIsCOW(sv) && SvLEN(sv)) 1903 Perl_dump_indent(aTHX_ level, file, " COW_REFCNT = %d\n", 1904 CowREFCNT(sv)); 1905 #endif 1906 } 1907 else 1908 Perl_dump_indent(aTHX_ level, file, " PV = 0\n"); 1909 } 1910 1911 if (type >= SVt_PVMG) { 1912 if (SvMAGIC(sv)) 1913 do_magic_dump(level, file, SvMAGIC(sv), nest+1, maxnest, dumpops, pvlim); 1914 if (SvSTASH(sv)) 1915 do_hv_dump(level, file, " STASH", SvSTASH(sv)); 1916 1917 if ((type == SVt_PVMG || type == SVt_PVLV) && SvVALID(sv)) { 1918 Perl_dump_indent(aTHX_ level, file, " USEFUL = %" IVdf "\n", 1919 (IV)BmUSEFUL(sv)); 1920 } 1921 } 1922 1923 /* Dump type-specific SV fields */ 1924 1925 switch (type) { 1926 case SVt_PVAV: 1927 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf, 1928 PTR2UV(AvARRAY(sv))); 1929 if (AvARRAY(sv) != AvALLOC(sv)) { 1930 PerlIO_printf(file, " (offset=%" IVdf ")\n", 1931 (IV)(AvARRAY(sv) - AvALLOC(sv))); 1932 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%" UVxf "\n", 1933 PTR2UV(AvALLOC(sv))); 1934 } 1935 else 1936 (void)PerlIO_putc(file, '\n'); 1937 Perl_dump_indent(aTHX_ level, file, " FILL = %" IVdf "\n", 1938 (IV)AvFILLp(sv)); 1939 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n", 1940 (IV)AvMAX(sv)); 1941 SvPVCLEAR(d); 1942 if (AvREAL(sv)) sv_catpvs(d, ",REAL"); 1943 if (AvREIFY(sv)) sv_catpvs(d, ",REIFY"); 1944 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n", 1945 SvCUR(d) ? SvPVX_const(d) + 1 : ""); 1946 if (nest < maxnest && AvARRAY(MUTABLE_AV(sv))) { 1947 SSize_t count; 1948 SV **svp = AvARRAY(MUTABLE_AV(sv)); 1949 for (count = 0; 1950 count <= AvFILLp(MUTABLE_AV(sv)) && count < maxnest; 1951 count++, svp++) 1952 { 1953 SV* const elt = *svp; 1954 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %" IVdf "\n", 1955 (IV)count); 1956 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim); 1957 } 1958 } 1959 break; 1960 case SVt_PVHV: { 1961 U32 usedkeys; 1962 if (SvOOK(sv)) { 1963 struct xpvhv_aux *const aux = HvAUX(sv); 1964 Perl_dump_indent(aTHX_ level, file, " AUX_FLAGS = %" UVuf "\n", 1965 (UV)aux->xhv_aux_flags); 1966 } 1967 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%" UVxf, PTR2UV(HvARRAY(sv))); 1968 usedkeys = HvUSEDKEYS(MUTABLE_HV(sv)); 1969 if (HvARRAY(sv) && usedkeys) { 1970 /* Show distribution of HEs in the ARRAY */ 1971 int freq[200]; 1972 #define FREQ_MAX ((int)(C_ARRAY_LENGTH(freq) - 1)) 1973 int i; 1974 int max = 0; 1975 U32 pow2 = 2, keys = usedkeys; 1976 NV theoret, sum = 0; 1977 1978 PerlIO_printf(file, " ("); 1979 Zero(freq, FREQ_MAX + 1, int); 1980 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) { 1981 HE* h; 1982 int count = 0; 1983 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h)) 1984 count++; 1985 if (count > FREQ_MAX) 1986 count = FREQ_MAX; 1987 freq[count]++; 1988 if (max < count) 1989 max = count; 1990 } 1991 for (i = 0; i <= max; i++) { 1992 if (freq[i]) { 1993 PerlIO_printf(file, "%d%s:%d", i, 1994 (i == FREQ_MAX) ? "+" : "", 1995 freq[i]); 1996 if (i != max) 1997 PerlIO_printf(file, ", "); 1998 } 1999 } 2000 (void)PerlIO_putc(file, ')'); 2001 /* The "quality" of a hash is defined as the total number of 2002 comparisons needed to access every element once, relative 2003 to the expected number needed for a random hash. 2004 2005 The total number of comparisons is equal to the sum of 2006 the squares of the number of entries in each bucket. 2007 For a random hash of n keys into k buckets, the expected 2008 value is 2009 n + n(n-1)/2k 2010 */ 2011 2012 for (i = max; i > 0; i--) { /* Precision: count down. */ 2013 sum += freq[i] * i * i; 2014 } 2015 while ((keys = keys >> 1)) 2016 pow2 = pow2 << 1; 2017 theoret = usedkeys; 2018 theoret += theoret * (theoret-1)/pow2; 2019 (void)PerlIO_putc(file, '\n'); 2020 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1" 2021 NVff "%%", theoret/sum*100); 2022 } 2023 (void)PerlIO_putc(file, '\n'); 2024 Perl_dump_indent(aTHX_ level, file, " KEYS = %" IVdf "\n", 2025 (IV)usedkeys); 2026 { 2027 STRLEN count = 0; 2028 HE **ents = HvARRAY(sv); 2029 2030 if (ents) { 2031 HE *const *const last = ents + HvMAX(sv); 2032 count = last + 1 - ents; 2033 2034 do { 2035 if (!*ents) 2036 --count; 2037 } while (++ents <= last); 2038 } 2039 2040 Perl_dump_indent(aTHX_ level, file, " FILL = %" UVuf "\n", 2041 (UV)count); 2042 } 2043 Perl_dump_indent(aTHX_ level, file, " MAX = %" IVdf "\n", 2044 (IV)HvMAX(sv)); 2045 if (SvOOK(sv)) { 2046 Perl_dump_indent(aTHX_ level, file, " RITER = %" IVdf "\n", 2047 (IV)HvRITER_get(sv)); 2048 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%" UVxf "\n", 2049 PTR2UV(HvEITER_get(sv))); 2050 #ifdef PERL_HASH_RANDOMIZE_KEYS 2051 Perl_dump_indent(aTHX_ level, file, " RAND = 0x%" UVxf, 2052 (UV)HvRAND_get(sv)); 2053 if (HvRAND_get(sv) != HvLASTRAND_get(sv) && HvRITER_get(sv) != -1 ) { 2054 PerlIO_printf(file, " (LAST = 0x%" UVxf ")", 2055 (UV)HvLASTRAND_get(sv)); 2056 } 2057 #endif 2058 (void)PerlIO_putc(file, '\n'); 2059 } 2060 { 2061 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab); 2062 if (mg && mg->mg_obj) { 2063 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%" UVxf "\n", PTR2UV(mg->mg_obj)); 2064 } 2065 } 2066 { 2067 const char * const hvname = HvNAME_get(sv); 2068 if (hvname) { 2069 SV* tmpsv = newSVpvs_flags("", SVs_TEMP); 2070 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", 2071 generic_pv_escape( tmpsv, hvname, 2072 HvNAMELEN(sv), HvNAMEUTF8(sv))); 2073 } 2074 } 2075 if (SvOOK(sv)) { 2076 AV * const backrefs 2077 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv)); 2078 struct mro_meta * const meta = HvAUX(sv)->xhv_mro_meta; 2079 if (HvAUX(sv)->xhv_name_count) 2080 Perl_dump_indent(aTHX_ 2081 level, file, " NAMECOUNT = %" IVdf "\n", 2082 (IV)HvAUX(sv)->xhv_name_count 2083 ); 2084 if (HvAUX(sv)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(sv)) { 2085 const I32 count = HvAUX(sv)->xhv_name_count; 2086 if (count) { 2087 SV * const names = newSVpvs_flags("", SVs_TEMP); 2088 /* The starting point is the first element if count is 2089 positive and the second element if count is negative. */ 2090 HEK *const *hekp = HvAUX(sv)->xhv_name_u.xhvnameu_names 2091 + (count < 0 ? 1 : 0); 2092 HEK *const *const endp = HvAUX(sv)->xhv_name_u.xhvnameu_names 2093 + (count < 0 ? -count : count); 2094 while (hekp < endp) { 2095 if (*hekp) { 2096 SV *tmp = newSVpvs_flags("", SVs_TEMP); 2097 Perl_sv_catpvf(aTHX_ names, ", \"%s\"", 2098 generic_pv_escape(tmp, HEK_KEY(*hekp), HEK_LEN(*hekp), HEK_UTF8(*hekp))); 2099 } else { 2100 /* This should never happen. */ 2101 sv_catpvs(names, ", (null)"); 2102 } 2103 ++hekp; 2104 } 2105 Perl_dump_indent(aTHX_ 2106 level, file, " ENAME = %s\n", SvPV_nolen(names)+2 2107 ); 2108 } 2109 else { 2110 SV * const tmp = newSVpvs_flags("", SVs_TEMP); 2111 const char *const hvename = HvENAME_get(sv); 2112 Perl_dump_indent(aTHX_ 2113 level, file, " ENAME = \"%s\"\n", 2114 generic_pv_escape(tmp, hvename, 2115 HvENAMELEN_get(sv), HvENAMEUTF8(sv))); 2116 } 2117 } 2118 if (backrefs) { 2119 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%" UVxf "\n", 2120 PTR2UV(backrefs)); 2121 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest, 2122 dumpops, pvlim); 2123 } 2124 if (meta) { 2125 SV* tmpsv = newSVpvs_flags("", SVs_TEMP); 2126 Perl_dump_indent(aTHX_ level, file, " MRO_WHICH = \"%s\" (0x%" 2127 UVxf ")\n", 2128 generic_pv_escape( tmpsv, meta->mro_which->name, 2129 meta->mro_which->length, 2130 (meta->mro_which->kflags & HVhek_UTF8)), 2131 PTR2UV(meta->mro_which)); 2132 Perl_dump_indent(aTHX_ level, file, " CACHE_GEN = 0x%" 2133 UVxf "\n", 2134 (UV)meta->cache_gen); 2135 Perl_dump_indent(aTHX_ level, file, " PKG_GEN = 0x%" UVxf "\n", 2136 (UV)meta->pkg_gen); 2137 if (meta->mro_linear_all) { 2138 Perl_dump_indent(aTHX_ level, file, " MRO_LINEAR_ALL = 0x%" 2139 UVxf "\n", 2140 PTR2UV(meta->mro_linear_all)); 2141 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_all), nest+1, maxnest, 2142 dumpops, pvlim); 2143 } 2144 if (meta->mro_linear_current) { 2145 Perl_dump_indent(aTHX_ level, file, 2146 " MRO_LINEAR_CURRENT = 0x%" UVxf "\n", 2147 PTR2UV(meta->mro_linear_current)); 2148 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_linear_current), nest+1, maxnest, 2149 dumpops, pvlim); 2150 } 2151 if (meta->mro_nextmethod) { 2152 Perl_dump_indent(aTHX_ level, file, 2153 " MRO_NEXTMETHOD = 0x%" UVxf "\n", 2154 PTR2UV(meta->mro_nextmethod)); 2155 do_sv_dump(level+1, file, MUTABLE_SV(meta->mro_nextmethod), nest+1, maxnest, 2156 dumpops, pvlim); 2157 } 2158 if (meta->isa) { 2159 Perl_dump_indent(aTHX_ level, file, " ISA = 0x%" UVxf "\n", 2160 PTR2UV(meta->isa)); 2161 do_sv_dump(level+1, file, MUTABLE_SV(meta->isa), nest+1, maxnest, 2162 dumpops, pvlim); 2163 } 2164 } 2165 } 2166 if (nest < maxnest) { 2167 HV * const hv = MUTABLE_HV(sv); 2168 STRLEN i; 2169 HE *he; 2170 2171 if (HvARRAY(hv)) { 2172 int count = maxnest - nest; 2173 for (i=0; i <= HvMAX(hv); i++) { 2174 for (he = HvARRAY(hv)[i]; he; he = HeNEXT(he)) { 2175 U32 hash; 2176 SV * keysv; 2177 const char * keypv; 2178 SV * elt; 2179 STRLEN len; 2180 2181 if (count-- <= 0) goto DONEHV; 2182 2183 hash = HeHASH(he); 2184 keysv = hv_iterkeysv(he); 2185 keypv = SvPV_const(keysv, len); 2186 elt = HeVAL(he); 2187 2188 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim)); 2189 if (SvUTF8(keysv)) 2190 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ)); 2191 if (HvEITER_get(hv) == he) 2192 PerlIO_printf(file, "[CURRENT] "); 2193 PerlIO_printf(file, "HASH = 0x%" UVxf "\n", (UV) hash); 2194 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim); 2195 } 2196 } 2197 DONEHV:; 2198 } 2199 } 2200 break; 2201 } /* case SVt_PVHV */ 2202 2203 case SVt_PVCV: 2204 if (CvAUTOLOAD(sv)) { 2205 SV* tmpsv = newSVpvs_flags("", SVs_TEMP); 2206 STRLEN len; 2207 const char *const name = SvPV_const(sv, len); 2208 Perl_dump_indent(aTHX_ level, file, " AUTOLOAD = \"%s\"\n", 2209 generic_pv_escape(tmpsv, name, len, SvUTF8(sv))); 2210 } 2211 if (SvPOK(sv)) { 2212 SV* tmpsv = newSVpvs_flags("", SVs_TEMP); 2213 const char *const proto = CvPROTO(sv); 2214 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n", 2215 generic_pv_escape(tmpsv, proto, CvPROTOLEN(sv), 2216 SvUTF8(sv))); 2217 } 2218 /* FALLTHROUGH */ 2219 case SVt_PVFM: 2220 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv)); 2221 if (!CvISXSUB(sv)) { 2222 if (CvSTART(sv)) { 2223 if (CvSLABBED(sv)) 2224 Perl_dump_indent(aTHX_ level, file, 2225 " SLAB = 0x%" UVxf "\n", 2226 PTR2UV(CvSTART(sv))); 2227 else 2228 Perl_dump_indent(aTHX_ level, file, 2229 " START = 0x%" UVxf " ===> %" IVdf "\n", 2230 PTR2UV(CvSTART(sv)), 2231 (IV)sequence_num(CvSTART(sv))); 2232 } 2233 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%" UVxf "\n", 2234 PTR2UV(CvROOT(sv))); 2235 if (CvROOT(sv) && dumpops) { 2236 do_op_dump(level+1, file, CvROOT(sv)); 2237 } 2238 } else { 2239 SV * const constant = cv_const_sv((const CV *)sv); 2240 2241 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%" UVxf "\n", PTR2UV(CvXSUB(sv))); 2242 2243 if (constant) { 2244 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%" UVxf 2245 " (CONST SV)\n", 2246 PTR2UV(CvXSUBANY(sv).any_ptr)); 2247 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops, 2248 pvlim); 2249 } else { 2250 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %" IVdf "\n", 2251 (IV)CvXSUBANY(sv).any_i32); 2252 } 2253 } 2254 if (CvNAMED(sv)) 2255 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", 2256 HEK_KEY(CvNAME_HEK((CV *)sv))); 2257 else do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv)); 2258 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv)); 2259 Perl_dump_indent(aTHX_ level, file, " DEPTH = %" 2260 IVdf "\n", (IV)CvDEPTH(sv)); 2261 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", 2262 (UV)CvFLAGS(sv)); 2263 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %" UVuf "\n", (UV)CvOUTSIDE_SEQ(sv)); 2264 if (!CvISXSUB(sv)) { 2265 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%" UVxf "\n", PTR2UV(CvPADLIST(sv))); 2266 if (nest < maxnest) { 2267 do_dump_pad(level+1, file, CvPADLIST(sv), 0); 2268 } 2269 } 2270 else 2271 Perl_dump_indent(aTHX_ level, file, " HSCXT = 0x%p\n", CvHSCXT(sv)); 2272 { 2273 const CV * const outside = CvOUTSIDE(sv); 2274 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%" UVxf " (%s)\n", 2275 PTR2UV(outside), 2276 (!outside ? "null" 2277 : CvANON(outside) ? "ANON" 2278 : (outside == PL_main_cv) ? "MAIN" 2279 : CvUNIQUE(outside) ? "UNIQUE" 2280 : CvGV(outside) ? 2281 generic_pv_escape( 2282 newSVpvs_flags("", SVs_TEMP), 2283 GvNAME(CvGV(outside)), 2284 GvNAMELEN(CvGV(outside)), 2285 GvNAMEUTF8(CvGV(outside))) 2286 : "UNDEFINED")); 2287 } 2288 if (CvOUTSIDE(sv) 2289 && (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))) 2290 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim); 2291 break; 2292 2293 case SVt_PVGV: 2294 case SVt_PVLV: 2295 if (type == SVt_PVLV) { 2296 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv)); 2297 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %" IVdf "\n", (IV)LvTARGOFF(sv)); 2298 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %" IVdf "\n", (IV)LvTARGLEN(sv)); 2299 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%" UVxf "\n", PTR2UV(LvTARG(sv))); 2300 Perl_dump_indent(aTHX_ level, file, " FLAGS = %" IVdf "\n", (IV)LvFLAGS(sv)); 2301 if (isALPHA_FOLD_NE(LvTYPE(sv), 't')) 2302 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest, 2303 dumpops, pvlim); 2304 } 2305 if (isREGEXP(sv)) goto dumpregexp; 2306 if (!isGV_with_GP(sv)) 2307 break; 2308 { 2309 SV* tmpsv = newSVpvs_flags("", SVs_TEMP); 2310 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", 2311 generic_pv_escape(tmpsv, GvNAME(sv), 2312 GvNAMELEN(sv), 2313 GvNAMEUTF8(sv))); 2314 } 2315 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %" IVdf "\n", (IV)GvNAMELEN(sv)); 2316 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv)); 2317 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)GvFLAGS(sv)); 2318 Perl_dump_indent(aTHX_ level, file, " GP = 0x%" UVxf "\n", PTR2UV(GvGP(sv))); 2319 if (!GvGP(sv)) 2320 break; 2321 Perl_dump_indent(aTHX_ level, file, " SV = 0x%" UVxf "\n", PTR2UV(GvSV(sv))); 2322 Perl_dump_indent(aTHX_ level, file, " REFCNT = %" IVdf "\n", (IV)GvREFCNT(sv)); 2323 Perl_dump_indent(aTHX_ level, file, " IO = 0x%" UVxf "\n", PTR2UV(GvIOp(sv))); 2324 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%" UVxf " \n", PTR2UV(GvFORM(sv))); 2325 Perl_dump_indent(aTHX_ level, file, " AV = 0x%" UVxf "\n", PTR2UV(GvAV(sv))); 2326 Perl_dump_indent(aTHX_ level, file, " HV = 0x%" UVxf "\n", PTR2UV(GvHV(sv))); 2327 Perl_dump_indent(aTHX_ level, file, " CV = 0x%" UVxf "\n", PTR2UV(GvCV(sv))); 2328 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%" UVxf "\n", (UV)GvCVGEN(sv)); 2329 Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%" UVxf 2330 " (%s)\n", 2331 (UV)GvGPFLAGS(sv), 2332 ""); 2333 Perl_dump_indent(aTHX_ level, file, " LINE = %" IVdf "\n", (IV)GvLINE(sv)); 2334 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv)); 2335 do_gv_dump (level, file, " EGV", GvEGV(sv)); 2336 break; 2337 case SVt_PVIO: 2338 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%" UVxf "\n", PTR2UV(IoIFP(sv))); 2339 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%" UVxf "\n", PTR2UV(IoOFP(sv))); 2340 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%" UVxf "\n", PTR2UV(IoDIRP(sv))); 2341 Perl_dump_indent(aTHX_ level, file, " LINES = %" IVdf "\n", (IV)IoLINES(sv)); 2342 Perl_dump_indent(aTHX_ level, file, " PAGE = %" IVdf "\n", (IV)IoPAGE(sv)); 2343 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %" IVdf "\n", (IV)IoPAGE_LEN(sv)); 2344 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %" IVdf "\n", (IV)IoLINES_LEFT(sv)); 2345 if (IoTOP_NAME(sv)) 2346 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv)); 2347 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV) 2348 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv)); 2349 else { 2350 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%" UVxf "\n", 2351 PTR2UV(IoTOP_GV(sv))); 2352 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1, 2353 maxnest, dumpops, pvlim); 2354 } 2355 /* Source filters hide things that are not GVs in these three, so let's 2356 be careful out there. */ 2357 if (IoFMT_NAME(sv)) 2358 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv)); 2359 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV) 2360 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv)); 2361 else { 2362 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%" UVxf "\n", 2363 PTR2UV(IoFMT_GV(sv))); 2364 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1, 2365 maxnest, dumpops, pvlim); 2366 } 2367 if (IoBOTTOM_NAME(sv)) 2368 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv)); 2369 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV) 2370 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv)); 2371 else { 2372 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%" UVxf "\n", 2373 PTR2UV(IoBOTTOM_GV(sv))); 2374 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1, 2375 maxnest, dumpops, pvlim); 2376 } 2377 if (isPRINT(IoTYPE(sv))) 2378 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv)); 2379 else 2380 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv)); 2381 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%" UVxf "\n", (UV)IoFLAGS(sv)); 2382 break; 2383 case SVt_REGEXP: 2384 dumpregexp: 2385 { 2386 struct regexp * const r = ReANY((REGEXP*)sv); 2387 2388 #define SV_SET_STRINGIFY_REGEXP_FLAGS(d,flags,names) STMT_START { \ 2389 sv_setpv(d,""); \ 2390 append_flags(d, flags, names); \ 2391 if (SvCUR(d) > 0 && *(SvEND(d) - 1) == ',') { \ 2392 SvCUR_set(d, SvCUR(d) - 1); \ 2393 SvPVX(d)[SvCUR(d)] = '\0'; \ 2394 } \ 2395 } STMT_END 2396 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->compflags,regexp_extflags_names); 2397 Perl_dump_indent(aTHX_ level, file, " COMPFLAGS = 0x%" UVxf " (%s)\n", 2398 (UV)(r->compflags), SvPVX_const(d)); 2399 2400 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->extflags,regexp_extflags_names); 2401 Perl_dump_indent(aTHX_ level, file, " EXTFLAGS = 0x%" UVxf " (%s)\n", 2402 (UV)(r->extflags), SvPVX_const(d)); 2403 2404 Perl_dump_indent(aTHX_ level, file, " ENGINE = 0x%" UVxf " (%s)\n", 2405 PTR2UV(r->engine), (r->engine == &PL_core_reg_engine) ? "STANDARD" : "PLUG-IN" ); 2406 if (r->engine == &PL_core_reg_engine) { 2407 SV_SET_STRINGIFY_REGEXP_FLAGS(d,r->intflags,regexp_core_intflags_names); 2408 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf " (%s)\n", 2409 (UV)(r->intflags), SvPVX_const(d)); 2410 } else { 2411 Perl_dump_indent(aTHX_ level, file, " INTFLAGS = 0x%" UVxf "\n", 2412 (UV)(r->intflags)); 2413 } 2414 #undef SV_SET_STRINGIFY_REGEXP_FLAGS 2415 Perl_dump_indent(aTHX_ level, file, " NPARENS = %" UVuf "\n", 2416 (UV)(r->nparens)); 2417 Perl_dump_indent(aTHX_ level, file, " LASTPAREN = %" UVuf "\n", 2418 (UV)(r->lastparen)); 2419 Perl_dump_indent(aTHX_ level, file, " LASTCLOSEPAREN = %" UVuf "\n", 2420 (UV)(r->lastcloseparen)); 2421 Perl_dump_indent(aTHX_ level, file, " MINLEN = %" IVdf "\n", 2422 (IV)(r->minlen)); 2423 Perl_dump_indent(aTHX_ level, file, " MINLENRET = %" IVdf "\n", 2424 (IV)(r->minlenret)); 2425 Perl_dump_indent(aTHX_ level, file, " GOFS = %" UVuf "\n", 2426 (UV)(r->gofs)); 2427 Perl_dump_indent(aTHX_ level, file, " PRE_PREFIX = %" UVuf "\n", 2428 (UV)(r->pre_prefix)); 2429 Perl_dump_indent(aTHX_ level, file, " SUBLEN = %" IVdf "\n", 2430 (IV)(r->sublen)); 2431 Perl_dump_indent(aTHX_ level, file, " SUBOFFSET = %" IVdf "\n", 2432 (IV)(r->suboffset)); 2433 Perl_dump_indent(aTHX_ level, file, " SUBCOFFSET = %" IVdf "\n", 2434 (IV)(r->subcoffset)); 2435 if (r->subbeg) 2436 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x%" UVxf " %s\n", 2437 PTR2UV(r->subbeg), 2438 pv_display(d, r->subbeg, r->sublen, 50, pvlim)); 2439 else 2440 Perl_dump_indent(aTHX_ level, file, " SUBBEG = 0x0\n"); 2441 Perl_dump_indent(aTHX_ level, file, " MOTHER_RE = 0x%" UVxf "\n", 2442 PTR2UV(r->mother_re)); 2443 if (nest < maxnest && r->mother_re) 2444 do_sv_dump(level+1, file, (SV *)r->mother_re, nest+1, 2445 maxnest, dumpops, pvlim); 2446 Perl_dump_indent(aTHX_ level, file, " PAREN_NAMES = 0x%" UVxf "\n", 2447 PTR2UV(r->paren_names)); 2448 Perl_dump_indent(aTHX_ level, file, " SUBSTRS = 0x%" UVxf "\n", 2449 PTR2UV(r->substrs)); 2450 Perl_dump_indent(aTHX_ level, file, " PPRIVATE = 0x%" UVxf "\n", 2451 PTR2UV(r->pprivate)); 2452 Perl_dump_indent(aTHX_ level, file, " OFFS = 0x%" UVxf "\n", 2453 PTR2UV(r->offs)); 2454 Perl_dump_indent(aTHX_ level, file, " QR_ANONCV = 0x%" UVxf "\n", 2455 PTR2UV(r->qr_anoncv)); 2456 #ifdef PERL_ANY_COW 2457 Perl_dump_indent(aTHX_ level, file, " SAVED_COPY = 0x%" UVxf "\n", 2458 PTR2UV(r->saved_copy)); 2459 #endif 2460 } 2461 break; 2462 } 2463 SvREFCNT_dec_NN(d); 2464 } 2465 2466 /* 2467 =for apidoc sv_dump 2468 2469 Dumps the contents of an SV to the C<STDERR> filehandle. 2470 2471 For an example of its output, see L<Devel::Peek>. 2472 2473 =cut 2474 */ 2475 2476 void 2477 Perl_sv_dump(pTHX_ SV *sv) 2478 { 2479 if (sv && SvROK(sv)) 2480 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0); 2481 else 2482 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0); 2483 } 2484 2485 int 2486 Perl_runops_debug(pTHX) 2487 { 2488 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY 2489 SSize_t orig_stack_hwm = PL_curstackinfo->si_stack_hwm; 2490 2491 PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base; 2492 #endif 2493 2494 if (!PL_op) { 2495 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN"); 2496 return 0; 2497 } 2498 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n")); 2499 do { 2500 #ifdef PERL_TRACE_OPS 2501 ++PL_op_exec_cnt[PL_op->op_type]; 2502 #endif 2503 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY 2504 if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base) 2505 Perl_croak_nocontext( 2506 "panic: previous op failed to extend arg stack: " 2507 "base=%p, sp=%p, hwm=%p\n", 2508 PL_stack_base, PL_stack_sp, 2509 PL_stack_base + PL_curstackinfo->si_stack_hwm); 2510 PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base; 2511 #endif 2512 if (PL_debug) { 2513 ENTER; 2514 SAVETMPS; 2515 if (PL_watchaddr && (*PL_watchaddr != PL_watchok)) 2516 PerlIO_printf(Perl_debug_log, 2517 "WARNING: %" UVxf " changed from %" UVxf " to %" UVxf "\n", 2518 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok), 2519 PTR2UV(*PL_watchaddr)); 2520 if (DEBUG_s_TEST_) { 2521 if (DEBUG_v_TEST_) { 2522 PerlIO_printf(Perl_debug_log, "\n"); 2523 deb_stack_all(); 2524 } 2525 else 2526 debstack(); 2527 } 2528 2529 2530 if (DEBUG_t_TEST_) debop(PL_op); 2531 if (DEBUG_P_TEST_) debprof(PL_op); 2532 FREETMPS; 2533 LEAVE; 2534 } 2535 2536 PERL_DTRACE_PROBE_OP(PL_op); 2537 } while ((PL_op = PL_op->op_ppaddr(aTHX))); 2538 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n")); 2539 PERL_ASYNC_CHECK(); 2540 2541 #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY 2542 if (PL_curstackinfo->si_stack_hwm < orig_stack_hwm) 2543 PL_curstackinfo->si_stack_hwm = orig_stack_hwm; 2544 #endif 2545 TAINT_NOT; 2546 return 0; 2547 } 2548 2549 2550 /* print the names of the n lexical vars starting at pad offset off */ 2551 2552 STATIC void 2553 S_deb_padvar(pTHX_ PADOFFSET off, int n, bool paren) 2554 { 2555 PADNAME *sv; 2556 CV * const cv = deb_curcv(cxstack_ix); 2557 PADNAMELIST *comppad = NULL; 2558 int i; 2559 2560 if (cv) { 2561 PADLIST * const padlist = CvPADLIST(cv); 2562 comppad = PadlistNAMES(padlist); 2563 } 2564 if (paren) 2565 PerlIO_printf(Perl_debug_log, "("); 2566 for (i = 0; i < n; i++) { 2567 if (comppad && (sv = padnamelist_fetch(comppad, off + i))) 2568 PerlIO_printf(Perl_debug_log, "%" PNf, PNfARG(sv)); 2569 else 2570 PerlIO_printf(Perl_debug_log, "[%" UVuf "]", 2571 (UV)(off+i)); 2572 if (i < n - 1) 2573 PerlIO_printf(Perl_debug_log, ","); 2574 } 2575 if (paren) 2576 PerlIO_printf(Perl_debug_log, ")"); 2577 } 2578 2579 2580 /* append to the out SV, the name of the lexical at offset off in the CV 2581 * cv */ 2582 2583 static void 2584 S_append_padvar(pTHX_ PADOFFSET off, CV *cv, SV *out, int n, 2585 bool paren, bool is_scalar) 2586 { 2587 PADNAME *sv; 2588 PADNAMELIST *namepad = NULL; 2589 int i; 2590 2591 if (cv) { 2592 PADLIST * const padlist = CvPADLIST(cv); 2593 namepad = PadlistNAMES(padlist); 2594 } 2595 2596 if (paren) 2597 sv_catpvs_nomg(out, "("); 2598 for (i = 0; i < n; i++) { 2599 if (namepad && (sv = padnamelist_fetch(namepad, off + i))) 2600 { 2601 STRLEN cur = SvCUR(out); 2602 Perl_sv_catpvf(aTHX_ out, "[%" UTF8f, 2603 UTF8fARG(1, PadnameLEN(sv) - 1, 2604 PadnamePV(sv) + 1)); 2605 if (is_scalar) 2606 SvPVX(out)[cur] = '$'; 2607 } 2608 else 2609 Perl_sv_catpvf(aTHX_ out, "[%" UVuf "]", (UV)(off+i)); 2610 if (i < n - 1) 2611 sv_catpvs_nomg(out, ","); 2612 } 2613 if (paren) 2614 sv_catpvs_nomg(out, "("); 2615 } 2616 2617 2618 static void 2619 S_append_gv_name(pTHX_ GV *gv, SV *out) 2620 { 2621 SV *sv; 2622 if (!gv) { 2623 sv_catpvs_nomg(out, "<NULLGV>"); 2624 return; 2625 } 2626 sv = newSV(0); 2627 gv_fullname4(sv, gv, NULL, FALSE); 2628 Perl_sv_catpvf(aTHX_ out, "$%" SVf, SVfARG(sv)); 2629 SvREFCNT_dec_NN(sv); 2630 } 2631 2632 #ifdef USE_ITHREADS 2633 # define ITEM_SV(item) (comppad ? \ 2634 *av_fetch(comppad, (item)->pad_offset, FALSE) : NULL); 2635 #else 2636 # define ITEM_SV(item) UNOP_AUX_item_sv(item) 2637 #endif 2638 2639 2640 /* return a temporary SV containing a stringified representation of 2641 * the op_aux field of a MULTIDEREF op, associated with CV cv 2642 */ 2643 2644 SV* 2645 Perl_multideref_stringify(pTHX_ const OP *o, CV *cv) 2646 { 2647 UNOP_AUX_item *items = cUNOP_AUXo->op_aux; 2648 UV actions = items->uv; 2649 SV *sv; 2650 bool last = 0; 2651 bool is_hash = FALSE; 2652 int derefs = 0; 2653 SV *out = newSVpvn_flags("",0,SVs_TEMP); 2654 #ifdef USE_ITHREADS 2655 PAD *comppad; 2656 2657 if (cv) { 2658 PADLIST *padlist = CvPADLIST(cv); 2659 comppad = PadlistARRAY(padlist)[1]; 2660 } 2661 else 2662 comppad = NULL; 2663 #endif 2664 2665 PERL_ARGS_ASSERT_MULTIDEREF_STRINGIFY; 2666 2667 while (!last) { 2668 switch (actions & MDEREF_ACTION_MASK) { 2669 2670 case MDEREF_reload: 2671 actions = (++items)->uv; 2672 continue; 2673 NOT_REACHED; /* NOTREACHED */ 2674 2675 case MDEREF_HV_padhv_helem: 2676 is_hash = TRUE; 2677 /* FALLTHROUGH */ 2678 case MDEREF_AV_padav_aelem: 2679 derefs = 1; 2680 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1); 2681 goto do_elem; 2682 NOT_REACHED; /* NOTREACHED */ 2683 2684 case MDEREF_HV_gvhv_helem: 2685 is_hash = TRUE; 2686 /* FALLTHROUGH */ 2687 case MDEREF_AV_gvav_aelem: 2688 derefs = 1; 2689 items++; 2690 sv = ITEM_SV(items); 2691 S_append_gv_name(aTHX_ (GV*)sv, out); 2692 goto do_elem; 2693 NOT_REACHED; /* NOTREACHED */ 2694 2695 case MDEREF_HV_gvsv_vivify_rv2hv_helem: 2696 is_hash = TRUE; 2697 /* FALLTHROUGH */ 2698 case MDEREF_AV_gvsv_vivify_rv2av_aelem: 2699 items++; 2700 sv = ITEM_SV(items); 2701 S_append_gv_name(aTHX_ (GV*)sv, out); 2702 goto do_vivify_rv2xv_elem; 2703 NOT_REACHED; /* NOTREACHED */ 2704 2705 case MDEREF_HV_padsv_vivify_rv2hv_helem: 2706 is_hash = TRUE; 2707 /* FALLTHROUGH */ 2708 case MDEREF_AV_padsv_vivify_rv2av_aelem: 2709 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1); 2710 goto do_vivify_rv2xv_elem; 2711 NOT_REACHED; /* NOTREACHED */ 2712 2713 case MDEREF_HV_pop_rv2hv_helem: 2714 case MDEREF_HV_vivify_rv2hv_helem: 2715 is_hash = TRUE; 2716 /* FALLTHROUGH */ 2717 do_vivify_rv2xv_elem: 2718 case MDEREF_AV_pop_rv2av_aelem: 2719 case MDEREF_AV_vivify_rv2av_aelem: 2720 if (!derefs++) 2721 sv_catpvs_nomg(out, "->"); 2722 do_elem: 2723 if ((actions & MDEREF_INDEX_MASK)== MDEREF_INDEX_none) { 2724 sv_catpvs_nomg(out, "->"); 2725 last = 1; 2726 break; 2727 } 2728 2729 sv_catpvn_nomg(out, (is_hash ? "{" : "["), 1); 2730 switch (actions & MDEREF_INDEX_MASK) { 2731 case MDEREF_INDEX_const: 2732 if (is_hash) { 2733 items++; 2734 sv = ITEM_SV(items); 2735 if (!sv) 2736 sv_catpvs_nomg(out, "???"); 2737 else { 2738 STRLEN cur; 2739 char *s; 2740 s = SvPV(sv, cur); 2741 pv_pretty(out, s, cur, 30, 2742 NULL, NULL, 2743 (PERL_PV_PRETTY_NOCLEAR 2744 |PERL_PV_PRETTY_QUOTE 2745 |PERL_PV_PRETTY_ELLIPSES)); 2746 } 2747 } 2748 else 2749 Perl_sv_catpvf(aTHX_ out, "%" IVdf, (++items)->iv); 2750 break; 2751 case MDEREF_INDEX_padsv: 2752 S_append_padvar(aTHX_ (++items)->pad_offset, cv, out, 1, 0, 1); 2753 break; 2754 case MDEREF_INDEX_gvsv: 2755 items++; 2756 sv = ITEM_SV(items); 2757 S_append_gv_name(aTHX_ (GV*)sv, out); 2758 break; 2759 } 2760 sv_catpvn_nomg(out, (is_hash ? "}" : "]"), 1); 2761 2762 if (actions & MDEREF_FLAG_last) 2763 last = 1; 2764 is_hash = FALSE; 2765 2766 break; 2767 2768 default: 2769 PerlIO_printf(Perl_debug_log, "UNKNOWN(%d)", 2770 (int)(actions & MDEREF_ACTION_MASK)); 2771 last = 1; 2772 break; 2773 2774 } /* switch */ 2775 2776 actions >>= MDEREF_SHIFT; 2777 } /* while */ 2778 return out; 2779 } 2780 2781 2782 /* Return a temporary SV containing a stringified representation of 2783 * the op_aux field of a MULTICONCAT op. Note that if the aux contains 2784 * both plain and utf8 versions of the const string and indices, only 2785 * the first is displayed. 2786 */ 2787 2788 SV* 2789 Perl_multiconcat_stringify(pTHX_ const OP *o) 2790 { 2791 UNOP_AUX_item *aux = cUNOP_AUXo->op_aux; 2792 UNOP_AUX_item *lens; 2793 STRLEN len; 2794 SSize_t nargs; 2795 char *s; 2796 SV *out = newSVpvn_flags("", 0, SVs_TEMP); 2797 2798 PERL_ARGS_ASSERT_MULTICONCAT_STRINGIFY; 2799 2800 nargs = aux[PERL_MULTICONCAT_IX_NARGS].ssize; 2801 s = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv; 2802 len = aux[PERL_MULTICONCAT_IX_PLAIN_LEN].ssize; 2803 if (!s) { 2804 s = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv; 2805 len = aux[PERL_MULTICONCAT_IX_UTF8_LEN].ssize; 2806 sv_catpvs(out, "UTF8 "); 2807 } 2808 pv_pretty(out, s, len, 50, 2809 NULL, NULL, 2810 (PERL_PV_PRETTY_NOCLEAR 2811 |PERL_PV_PRETTY_QUOTE 2812 |PERL_PV_PRETTY_ELLIPSES)); 2813 2814 lens = aux + PERL_MULTICONCAT_IX_LENGTHS; 2815 while (nargs-- >= 0) { 2816 Perl_sv_catpvf(aTHX_ out, ",%" IVdf, (IV)lens->ssize); 2817 lens++; 2818 } 2819 return out; 2820 } 2821 2822 2823 I32 2824 Perl_debop(pTHX_ const OP *o) 2825 { 2826 PERL_ARGS_ASSERT_DEBOP; 2827 2828 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_) 2829 return 0; 2830 2831 Perl_deb(aTHX_ "%s", OP_NAME(o)); 2832 switch (o->op_type) { 2833 case OP_CONST: 2834 case OP_HINTSEVAL: 2835 /* With ITHREADS, consts are stored in the pad, and the right pad 2836 * may not be active here, so check. 2837 * Looks like only during compiling the pads are illegal. 2838 */ 2839 #ifdef USE_ITHREADS 2840 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME) 2841 #endif 2842 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv)); 2843 break; 2844 case OP_GVSV: 2845 case OP_GV: 2846 PerlIO_printf(Perl_debug_log, "(%" SVf ")", 2847 SVfARG(S_gv_display(aTHX_ cGVOPo_gv))); 2848 break; 2849 2850 case OP_PADSV: 2851 case OP_PADAV: 2852 case OP_PADHV: 2853 case OP_ARGELEM: 2854 S_deb_padvar(aTHX_ o->op_targ, 1, 1); 2855 break; 2856 2857 case OP_PADRANGE: 2858 S_deb_padvar(aTHX_ o->op_targ, 2859 o->op_private & OPpPADRANGE_COUNTMASK, 1); 2860 break; 2861 2862 case OP_MULTIDEREF: 2863 PerlIO_printf(Perl_debug_log, "(%" SVf ")", 2864 SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix)))); 2865 break; 2866 2867 case OP_MULTICONCAT: 2868 PerlIO_printf(Perl_debug_log, "(%" SVf ")", 2869 SVfARG(multiconcat_stringify(o))); 2870 break; 2871 2872 default: 2873 break; 2874 } 2875 PerlIO_printf(Perl_debug_log, "\n"); 2876 return 0; 2877 } 2878 2879 2880 /* 2881 =for apidoc op_class 2882 2883 Given an op, determine what type of struct it has been allocated as. 2884 Returns one of the OPclass enums, such as OPclass_LISTOP. 2885 2886 =cut 2887 */ 2888 2889 2890 OPclass 2891 Perl_op_class(pTHX_ const OP *o) 2892 { 2893 bool custom = 0; 2894 2895 if (!o) 2896 return OPclass_NULL; 2897 2898 if (o->op_type == 0) { 2899 if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE) 2900 return OPclass_COP; 2901 return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP; 2902 } 2903 2904 if (o->op_type == OP_SASSIGN) 2905 return ((o->op_private & OPpASSIGN_BACKWARDS) ? OPclass_UNOP : OPclass_BINOP); 2906 2907 if (o->op_type == OP_AELEMFAST) { 2908 #ifdef USE_ITHREADS 2909 return OPclass_PADOP; 2910 #else 2911 return OPclass_SVOP; 2912 #endif 2913 } 2914 2915 #ifdef USE_ITHREADS 2916 if (o->op_type == OP_GV || o->op_type == OP_GVSV || 2917 o->op_type == OP_RCATLINE) 2918 return OPclass_PADOP; 2919 #endif 2920 2921 if (o->op_type == OP_CUSTOM) 2922 custom = 1; 2923 2924 switch (OP_CLASS(o)) { 2925 case OA_BASEOP: 2926 return OPclass_BASEOP; 2927 2928 case OA_UNOP: 2929 return OPclass_UNOP; 2930 2931 case OA_BINOP: 2932 return OPclass_BINOP; 2933 2934 case OA_LOGOP: 2935 return OPclass_LOGOP; 2936 2937 case OA_LISTOP: 2938 return OPclass_LISTOP; 2939 2940 case OA_PMOP: 2941 return OPclass_PMOP; 2942 2943 case OA_SVOP: 2944 return OPclass_SVOP; 2945 2946 case OA_PADOP: 2947 return OPclass_PADOP; 2948 2949 case OA_PVOP_OR_SVOP: 2950 /* 2951 * Character translations (tr///) are usually a PVOP, keeping a 2952 * pointer to a table of shorts used to look up translations. 2953 * Under utf8, however, a simple table isn't practical; instead, 2954 * the OP is an SVOP (or, under threads, a PADOP), 2955 * and the SV is a reference to a swash 2956 * (i.e., an RV pointing to an HV). 2957 */ 2958 return (!custom && 2959 (o->op_private & (OPpTRANS_TO_UTF|OPpTRANS_FROM_UTF)) 2960 ) 2961 #if defined(USE_ITHREADS) 2962 ? OPclass_PADOP : OPclass_PVOP; 2963 #else 2964 ? OPclass_SVOP : OPclass_PVOP; 2965 #endif 2966 2967 case OA_LOOP: 2968 return OPclass_LOOP; 2969 2970 case OA_COP: 2971 return OPclass_COP; 2972 2973 case OA_BASEOP_OR_UNOP: 2974 /* 2975 * UNI(OP_foo) in toke.c returns token UNI or FUNC1 depending on 2976 * whether parens were seen. perly.y uses OPf_SPECIAL to 2977 * signal whether a BASEOP had empty parens or none. 2978 * Some other UNOPs are created later, though, so the best 2979 * test is OPf_KIDS, which is set in newUNOP. 2980 */ 2981 return (o->op_flags & OPf_KIDS) ? OPclass_UNOP : OPclass_BASEOP; 2982 2983 case OA_FILESTATOP: 2984 /* 2985 * The file stat OPs are created via UNI(OP_foo) in toke.c but use 2986 * the OPf_REF flag to distinguish between OP types instead of the 2987 * usual OPf_SPECIAL flag. As usual, if OPf_KIDS is set, then we 2988 * return OPclass_UNOP so that walkoptree can find our children. If 2989 * OPf_KIDS is not set then we check OPf_REF. Without OPf_REF set 2990 * (no argument to the operator) it's an OP; with OPf_REF set it's 2991 * an SVOP (and op_sv is the GV for the filehandle argument). 2992 */ 2993 return ((o->op_flags & OPf_KIDS) ? OPclass_UNOP : 2994 #ifdef USE_ITHREADS 2995 (o->op_flags & OPf_REF) ? OPclass_PADOP : OPclass_BASEOP); 2996 #else 2997 (o->op_flags & OPf_REF) ? OPclass_SVOP : OPclass_BASEOP); 2998 #endif 2999 case OA_LOOPEXOP: 3000 /* 3001 * next, last, redo, dump and goto use OPf_SPECIAL to indicate that a 3002 * label was omitted (in which case it's a BASEOP) or else a term was 3003 * seen. In this last case, all except goto are definitely PVOP but 3004 * goto is either a PVOP (with an ordinary constant label), an UNOP 3005 * with OPf_STACKED (with a non-constant non-sub) or an UNOP for 3006 * OP_REFGEN (with goto &sub) in which case OPf_STACKED also seems to 3007 * get set. 3008 */ 3009 if (o->op_flags & OPf_STACKED) 3010 return OPclass_UNOP; 3011 else if (o->op_flags & OPf_SPECIAL) 3012 return OPclass_BASEOP; 3013 else 3014 return OPclass_PVOP; 3015 case OA_METHOP: 3016 return OPclass_METHOP; 3017 case OA_UNOP_AUX: 3018 return OPclass_UNOP_AUX; 3019 } 3020 Perl_warn(aTHX_ "Can't determine class of operator %s, assuming BASEOP\n", 3021 OP_NAME(o)); 3022 return OPclass_BASEOP; 3023 } 3024 3025 3026 3027 STATIC CV* 3028 S_deb_curcv(pTHX_ I32 ix) 3029 { 3030 PERL_SI *si = PL_curstackinfo; 3031 for (; ix >=0; ix--) { 3032 const PERL_CONTEXT * const cx = &(si->si_cxstack)[ix]; 3033 3034 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) 3035 return cx->blk_sub.cv; 3036 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx)) 3037 return cx->blk_eval.cv; 3038 else if (ix == 0 && si->si_type == PERLSI_MAIN) 3039 return PL_main_cv; 3040 else if (ix == 0 && CxTYPE(cx) == CXt_NULL 3041 && si->si_type == PERLSI_SORT) 3042 { 3043 /* fake sort sub; use CV of caller */ 3044 si = si->si_prev; 3045 ix = si->si_cxix + 1; 3046 } 3047 } 3048 return NULL; 3049 } 3050 3051 void 3052 Perl_watch(pTHX_ char **addr) 3053 { 3054 PERL_ARGS_ASSERT_WATCH; 3055 3056 PL_watchaddr = addr; 3057 PL_watchok = *addr; 3058 PerlIO_printf(Perl_debug_log, "WATCHING, %" UVxf " is currently %" UVxf "\n", 3059 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok)); 3060 } 3061 3062 STATIC void 3063 S_debprof(pTHX_ const OP *o) 3064 { 3065 PERL_ARGS_ASSERT_DEBPROF; 3066 3067 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash)) 3068 return; 3069 if (!PL_profiledata) 3070 Newxz(PL_profiledata, MAXO, U32); 3071 ++PL_profiledata[o->op_type]; 3072 } 3073 3074 void 3075 Perl_debprofdump(pTHX) 3076 { 3077 unsigned i; 3078 if (!PL_profiledata) 3079 return; 3080 for (i = 0; i < MAXO; i++) { 3081 if (PL_profiledata[i]) 3082 PerlIO_printf(Perl_debug_log, 3083 "%5lu %s\n", (unsigned long)PL_profiledata[i], 3084 PL_op_name[i]); 3085 } 3086 } 3087 3088 3089 /* 3090 * ex: set ts=8 sts=4 sw=4 et: 3091 */ 3092