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