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