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