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