1 /* dump.c 2 * 3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 4 * 2000, 2001, 2002, 2003, 2004, 2005, 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 16 /* This file contains utility routines to dump the contents of SV and OP 17 * structures, as used by command-line options like -Dt and -Dx, and 18 * by Devel::Peek. 19 * 20 * It also holds the debugging version of the runops function. 21 */ 22 23 #include "EXTERN.h" 24 #define PERL_IN_DUMP_C 25 #include "perl.h" 26 #include "regcomp.h" 27 28 void 29 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...) 30 { 31 va_list args; 32 va_start(args, pat); 33 dump_vindent(level, file, pat, &args); 34 va_end(args); 35 } 36 37 void 38 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args) 39 { 40 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), ""); 41 PerlIO_vprintf(file, pat, *args); 42 } 43 44 void 45 Perl_dump_all(pTHX) 46 { 47 PerlIO_setlinebuf(Perl_debug_log); 48 if (PL_main_root) 49 op_dump(PL_main_root); 50 dump_packsubs(PL_defstash); 51 } 52 53 void 54 Perl_dump_packsubs(pTHX_ HV *stash) 55 { 56 I32 i; 57 58 if (!HvARRAY(stash)) 59 return; 60 for (i = 0; i <= (I32) HvMAX(stash); i++) { 61 const HE *entry; 62 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { 63 const GV *gv = (GV*)HeVAL(entry); 64 const HV *hv; 65 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv)) 66 continue; 67 if (GvCVu(gv)) 68 dump_sub((GV *)gv); 69 if (GvFORM(gv)) 70 dump_form((GV *)gv); 71 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' 72 && (hv = GvHV(gv)) && hv != PL_defstash) 73 dump_packsubs((HV *) hv); /* nested package */ 74 } 75 } 76 } 77 78 void 79 Perl_dump_sub(pTHX_ GV *gv) 80 { 81 SV * const sv = sv_newmortal(); 82 83 gv_fullname3(sv, gv, Nullch); 84 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv)); 85 if (CvXSUB(GvCV(gv))) 86 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n", 87 PTR2UV(CvXSUB(GvCV(gv))), 88 (int)CvXSUBANY(GvCV(gv)).any_i32); 89 else if (CvROOT(GvCV(gv))) 90 op_dump(CvROOT(GvCV(gv))); 91 else 92 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n"); 93 } 94 95 void 96 Perl_dump_form(pTHX_ GV *gv) 97 { 98 SV * const sv = sv_newmortal(); 99 100 gv_fullname3(sv, gv, Nullch); 101 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv)); 102 if (CvROOT(GvFORM(gv))) 103 op_dump(CvROOT(GvFORM(gv))); 104 else 105 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n"); 106 } 107 108 void 109 Perl_dump_eval(pTHX) 110 { 111 op_dump(PL_eval_root); 112 } 113 114 char * 115 Perl_pv_display(pTHX_ SV *dsv, char *pv, STRLEN cur, STRLEN len, STRLEN pvlim) 116 { 117 const bool nul_terminated = len > cur && pv[cur] == '\0'; 118 bool truncated = 0; 119 120 sv_setpvn(dsv, "\"", 1); 121 for (; cur--; pv++) { 122 if (pvlim && SvCUR(dsv) >= pvlim) { 123 truncated = 1; 124 break; 125 } 126 switch (*pv) { 127 case '\t': sv_catpvn(dsv, "\\t", 2); break; 128 case '\n': sv_catpvn(dsv, "\\n", 2); break; 129 case '\r': sv_catpvn(dsv, "\\r", 2); break; 130 case '\f': sv_catpvn(dsv, "\\f", 2); break; 131 case '"': sv_catpvn(dsv, "\\\"", 2); break; 132 case '\\': sv_catpvn(dsv, "\\\\", 2); break; 133 default: 134 if (isPRINT(*pv)) 135 sv_catpvn(dsv, pv, 1); 136 else if (cur && isDIGIT(*(pv+1))) 137 Perl_sv_catpvf(aTHX_ dsv, "\\%03o", (U8)*pv); 138 else 139 Perl_sv_catpvf(aTHX_ dsv, "\\%o", (U8)*pv); 140 } 141 } 142 sv_catpvn(dsv, "\"", 1); 143 if (truncated) 144 sv_catpvn(dsv, "...", 3); 145 if (nul_terminated) 146 sv_catpvn(dsv, "\\0", 2); 147 148 return SvPVX(dsv); 149 } 150 151 char * 152 Perl_sv_peek(pTHX_ SV *sv) 153 { 154 SV * const t = sv_newmortal(); 155 int unref = 0; 156 157 sv_setpvn(t, "", 0); 158 retry: 159 if (!sv) { 160 sv_catpv(t, "VOID"); 161 goto finish; 162 } 163 else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') { 164 sv_catpv(t, "WILD"); 165 goto finish; 166 } 167 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) { 168 if (sv == &PL_sv_undef) { 169 sv_catpv(t, "SV_UNDEF"); 170 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT| 171 SVs_GMG|SVs_SMG|SVs_RMG)) && 172 SvREADONLY(sv)) 173 goto finish; 174 } 175 else if (sv == &PL_sv_no) { 176 sv_catpv(t, "SV_NO"); 177 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| 178 SVs_GMG|SVs_SMG|SVs_RMG)) && 179 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| 180 SVp_POK|SVp_NOK)) && 181 SvCUR(sv) == 0 && 182 SvNVX(sv) == 0.0) 183 goto finish; 184 } 185 else if (sv == &PL_sv_yes) { 186 sv_catpv(t, "SV_YES"); 187 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| 188 SVs_GMG|SVs_SMG|SVs_RMG)) && 189 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| 190 SVp_POK|SVp_NOK)) && 191 SvCUR(sv) == 1 && 192 SvPVX_const(sv) && *SvPVX_const(sv) == '1' && 193 SvNVX(sv) == 1.0) 194 goto finish; 195 } 196 else { 197 sv_catpv(t, "SV_PLACEHOLDER"); 198 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT| 199 SVs_GMG|SVs_SMG|SVs_RMG)) && 200 SvREADONLY(sv)) 201 goto finish; 202 } 203 sv_catpv(t, ":"); 204 } 205 else if (SvREFCNT(sv) == 0) { 206 sv_catpv(t, "("); 207 unref++; 208 } 209 else if (DEBUG_R_TEST_) { 210 int is_tmp = 0; 211 I32 ix; 212 /* is this SV on the tmps stack? */ 213 for (ix=PL_tmps_ix; ix>=0; ix--) { 214 if (PL_tmps_stack[ix] == sv) { 215 is_tmp = 1; 216 break; 217 } 218 } 219 if (SvREFCNT(sv) > 1) 220 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv), 221 is_tmp ? "T" : ""); 222 else if (is_tmp) 223 sv_catpv(t, "<T>"); 224 } 225 226 if (SvROK(sv)) { 227 sv_catpv(t, "\\"); 228 if (SvCUR(t) + unref > 10) { 229 SvCUR_set(t, unref + 3); 230 *SvEND(t) = '\0'; 231 sv_catpv(t, "..."); 232 goto finish; 233 } 234 sv = (SV*)SvRV(sv); 235 goto retry; 236 } 237 switch (SvTYPE(sv)) { 238 default: 239 sv_catpv(t, "FREED"); 240 goto finish; 241 242 case SVt_NULL: 243 sv_catpv(t, "UNDEF"); 244 goto finish; 245 case SVt_IV: 246 sv_catpv(t, "IV"); 247 break; 248 case SVt_NV: 249 sv_catpv(t, "NV"); 250 break; 251 case SVt_RV: 252 sv_catpv(t, "RV"); 253 break; 254 case SVt_PV: 255 sv_catpv(t, "PV"); 256 break; 257 case SVt_PVIV: 258 sv_catpv(t, "PVIV"); 259 break; 260 case SVt_PVNV: 261 sv_catpv(t, "PVNV"); 262 break; 263 case SVt_PVMG: 264 sv_catpv(t, "PVMG"); 265 break; 266 case SVt_PVLV: 267 sv_catpv(t, "PVLV"); 268 break; 269 case SVt_PVAV: 270 sv_catpv(t, "AV"); 271 break; 272 case SVt_PVHV: 273 sv_catpv(t, "HV"); 274 break; 275 case SVt_PVCV: 276 if (CvGV(sv)) 277 Perl_sv_catpvf(aTHX_ t, "CV(%s)", GvNAME(CvGV(sv))); 278 else 279 sv_catpv(t, "CV()"); 280 goto finish; 281 case SVt_PVGV: 282 sv_catpv(t, "GV"); 283 break; 284 case SVt_PVBM: 285 sv_catpv(t, "BM"); 286 break; 287 case SVt_PVFM: 288 sv_catpv(t, "FM"); 289 break; 290 case SVt_PVIO: 291 sv_catpv(t, "IO"); 292 break; 293 } 294 295 if (SvPOKp(sv)) { 296 if (!SvPVX_const(sv)) 297 sv_catpv(t, "(null)"); 298 else { 299 SV *tmp = newSVpvn("", 0); 300 sv_catpv(t, "("); 301 if (SvOOK(sv)) 302 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, (char *)SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, 127)); 303 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, (char *)SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127)); 304 if (SvUTF8(sv)) 305 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]", 306 sv_uni_display(tmp, sv, 8 * sv_len_utf8(sv), 307 UNI_DISPLAY_QQ)); 308 SvREFCNT_dec(tmp); 309 } 310 } 311 else if (SvNOKp(sv)) { 312 STORE_NUMERIC_LOCAL_SET_STANDARD(); 313 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv)); 314 RESTORE_NUMERIC_LOCAL(); 315 } 316 else if (SvIOKp(sv)) { 317 if (SvIsUV(sv)) 318 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv)); 319 else 320 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv)); 321 } 322 else 323 sv_catpv(t, "()"); 324 325 finish: 326 if (unref) { 327 while (unref--) 328 sv_catpv(t, ")"); 329 } 330 return SvPV_nolen(t); 331 } 332 333 void 334 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, PMOP *pm) 335 { 336 char ch; 337 338 if (!pm) { 339 Perl_dump_indent(aTHX_ level, file, "{}\n"); 340 return; 341 } 342 Perl_dump_indent(aTHX_ level, file, "{\n"); 343 level++; 344 if (pm->op_pmflags & PMf_ONCE) 345 ch = '?'; 346 else 347 ch = '/'; 348 if (PM_GETRE(pm)) 349 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n", 350 ch, PM_GETRE(pm)->precomp, ch, 351 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : ""); 352 else 353 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n"); 354 if (pm->op_type != OP_PUSHRE && pm->op_pmreplroot) { 355 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = "); 356 op_dump(pm->op_pmreplroot); 357 } 358 if (pm->op_pmflags || (PM_GETRE(pm) && PM_GETRE(pm)->check_substr)) { 359 SV *tmpsv = newSVpvn("", 0); 360 if (pm->op_pmdynflags & PMdf_USED) 361 sv_catpv(tmpsv, ",USED"); 362 if (pm->op_pmdynflags & PMdf_TAINTED) 363 sv_catpv(tmpsv, ",TAINTED"); 364 if (pm->op_pmflags & PMf_ONCE) 365 sv_catpv(tmpsv, ",ONCE"); 366 if (PM_GETRE(pm) && PM_GETRE(pm)->check_substr 367 && !(PM_GETRE(pm)->reganch & ROPT_NOSCAN)) 368 sv_catpv(tmpsv, ",SCANFIRST"); 369 if (PM_GETRE(pm) && PM_GETRE(pm)->check_substr 370 && PM_GETRE(pm)->reganch & ROPT_CHECK_ALL) 371 sv_catpv(tmpsv, ",ALL"); 372 if (pm->op_pmflags & PMf_SKIPWHITE) 373 sv_catpv(tmpsv, ",SKIPWHITE"); 374 if (pm->op_pmflags & PMf_CONST) 375 sv_catpv(tmpsv, ",CONST"); 376 if (pm->op_pmflags & PMf_KEEP) 377 sv_catpv(tmpsv, ",KEEP"); 378 if (pm->op_pmflags & PMf_GLOBAL) 379 sv_catpv(tmpsv, ",GLOBAL"); 380 if (pm->op_pmflags & PMf_CONTINUE) 381 sv_catpv(tmpsv, ",CONTINUE"); 382 if (pm->op_pmflags & PMf_RETAINT) 383 sv_catpv(tmpsv, ",RETAINT"); 384 if (pm->op_pmflags & PMf_EVAL) 385 sv_catpv(tmpsv, ",EVAL"); 386 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : ""); 387 SvREFCNT_dec(tmpsv); 388 } 389 390 Perl_dump_indent(aTHX_ level-1, file, "}\n"); 391 } 392 393 void 394 Perl_pmop_dump(pTHX_ PMOP *pm) 395 { 396 do_pmop_dump(0, Perl_debug_log, pm); 397 } 398 399 void 400 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) 401 { 402 Perl_dump_indent(aTHX_ level, file, "{\n"); 403 level++; 404 if (o->op_seq) 405 PerlIO_printf(file, "%-4d", o->op_seq); 406 else 407 PerlIO_printf(file, " "); 408 PerlIO_printf(file, 409 "%*sTYPE = %s ===> ", 410 (int)(PL_dumpindent*level-4), "", OP_NAME(o)); 411 if (o->op_next) { 412 if (o->op_seq) 413 PerlIO_printf(file, "%d\n", o->op_next->op_seq); 414 else 415 PerlIO_printf(file, "(%d)\n", o->op_next->op_seq); 416 } 417 else 418 PerlIO_printf(file, "DONE\n"); 419 if (o->op_targ) { 420 if (o->op_type == OP_NULL) 421 { 422 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]); 423 if (o->op_targ == OP_NEXTSTATE) 424 { 425 if (CopLINE(cCOPo)) 426 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVf"\n", 427 (UV)CopLINE(cCOPo)); 428 if (CopSTASHPV(cCOPo)) 429 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n", 430 CopSTASHPV(cCOPo)); 431 if (cCOPo->cop_label) 432 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n", 433 cCOPo->cop_label); 434 } 435 } 436 else 437 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ); 438 } 439 #ifdef DUMPADDR 440 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next); 441 #endif 442 if (o->op_flags) { 443 SV *tmpsv = newSVpvn("", 0); 444 switch (o->op_flags & OPf_WANT) { 445 case OPf_WANT_VOID: 446 sv_catpv(tmpsv, ",VOID"); 447 break; 448 case OPf_WANT_SCALAR: 449 sv_catpv(tmpsv, ",SCALAR"); 450 break; 451 case OPf_WANT_LIST: 452 sv_catpv(tmpsv, ",LIST"); 453 break; 454 default: 455 sv_catpv(tmpsv, ",UNKNOWN"); 456 break; 457 } 458 if (o->op_flags & OPf_KIDS) 459 sv_catpv(tmpsv, ",KIDS"); 460 if (o->op_flags & OPf_PARENS) 461 sv_catpv(tmpsv, ",PARENS"); 462 if (o->op_flags & OPf_STACKED) 463 sv_catpv(tmpsv, ",STACKED"); 464 if (o->op_flags & OPf_REF) 465 sv_catpv(tmpsv, ",REF"); 466 if (o->op_flags & OPf_MOD) 467 sv_catpv(tmpsv, ",MOD"); 468 if (o->op_flags & OPf_SPECIAL) 469 sv_catpv(tmpsv, ",SPECIAL"); 470 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : ""); 471 SvREFCNT_dec(tmpsv); 472 } 473 if (o->op_private) { 474 SV *tmpsv = newSVpvn("", 0); 475 if (PL_opargs[o->op_type] & OA_TARGLEX) { 476 if (o->op_private & OPpTARGET_MY) 477 sv_catpv(tmpsv, ",TARGET_MY"); 478 } 479 else if (o->op_type == OP_LEAVESUB || 480 o->op_type == OP_LEAVE || 481 o->op_type == OP_LEAVESUBLV || 482 o->op_type == OP_LEAVEWRITE) { 483 if (o->op_private & OPpREFCOUNTED) 484 sv_catpv(tmpsv, ",REFCOUNTED"); 485 } 486 else if (o->op_type == OP_AASSIGN) { 487 if (o->op_private & OPpASSIGN_COMMON) 488 sv_catpv(tmpsv, ",COMMON"); 489 if (o->op_private & OPpASSIGN_HASH) 490 sv_catpv(tmpsv, ",HASH"); 491 } 492 else if (o->op_type == OP_SASSIGN) { 493 if (o->op_private & OPpASSIGN_BACKWARDS) 494 sv_catpv(tmpsv, ",BACKWARDS"); 495 } 496 else if (o->op_type == OP_TRANS) { 497 if (o->op_private & OPpTRANS_SQUASH) 498 sv_catpv(tmpsv, ",SQUASH"); 499 if (o->op_private & OPpTRANS_DELETE) 500 sv_catpv(tmpsv, ",DELETE"); 501 if (o->op_private & OPpTRANS_COMPLEMENT) 502 sv_catpv(tmpsv, ",COMPLEMENT"); 503 if (o->op_private & OPpTRANS_IDENTICAL) 504 sv_catpv(tmpsv, ",IDENTICAL"); 505 if (o->op_private & OPpTRANS_GROWS) 506 sv_catpv(tmpsv, ",GROWS"); 507 } 508 else if (o->op_type == OP_REPEAT) { 509 if (o->op_private & OPpREPEAT_DOLIST) 510 sv_catpv(tmpsv, ",DOLIST"); 511 } 512 else if (o->op_type == OP_ENTERSUB || 513 o->op_type == OP_RV2SV || 514 o->op_type == OP_GVSV || 515 o->op_type == OP_RV2AV || 516 o->op_type == OP_RV2HV || 517 o->op_type == OP_RV2GV || 518 o->op_type == OP_AELEM || 519 o->op_type == OP_HELEM ) 520 { 521 if (o->op_type == OP_ENTERSUB) { 522 if (o->op_private & OPpENTERSUB_AMPER) 523 sv_catpv(tmpsv, ",AMPER"); 524 if (o->op_private & OPpENTERSUB_DB) 525 sv_catpv(tmpsv, ",DB"); 526 if (o->op_private & OPpENTERSUB_HASTARG) 527 sv_catpv(tmpsv, ",HASTARG"); 528 if (o->op_private & OPpENTERSUB_NOPAREN) 529 sv_catpv(tmpsv, ",NOPAREN"); 530 if (o->op_private & OPpENTERSUB_INARGS) 531 sv_catpv(tmpsv, ",INARGS"); 532 if (o->op_private & OPpENTERSUB_NOMOD) 533 sv_catpv(tmpsv, ",NOMOD"); 534 } 535 else { 536 switch (o->op_private & OPpDEREF) { 537 case OPpDEREF_SV: 538 sv_catpv(tmpsv, ",SV"); 539 break; 540 case OPpDEREF_AV: 541 sv_catpv(tmpsv, ",AV"); 542 break; 543 case OPpDEREF_HV: 544 sv_catpv(tmpsv, ",HV"); 545 break; 546 } 547 if (o->op_private & OPpMAYBE_LVSUB) 548 sv_catpv(tmpsv, ",MAYBE_LVSUB"); 549 } 550 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) { 551 if (o->op_private & OPpLVAL_DEFER) 552 sv_catpv(tmpsv, ",LVAL_DEFER"); 553 } 554 else { 555 if (o->op_private & HINT_STRICT_REFS) 556 sv_catpv(tmpsv, ",STRICT_REFS"); 557 if (o->op_private & OPpOUR_INTRO) 558 sv_catpv(tmpsv, ",OUR_INTRO"); 559 } 560 } 561 else if (o->op_type == OP_CONST) { 562 if (o->op_private & OPpCONST_BARE) 563 sv_catpv(tmpsv, ",BARE"); 564 if (o->op_private & OPpCONST_STRICT) 565 sv_catpv(tmpsv, ",STRICT"); 566 if (o->op_private & OPpCONST_ARYBASE) 567 sv_catpv(tmpsv, ",ARYBASE"); 568 if (o->op_private & OPpCONST_WARNING) 569 sv_catpv(tmpsv, ",WARNING"); 570 if (o->op_private & OPpCONST_ENTERED) 571 sv_catpv(tmpsv, ",ENTERED"); 572 } 573 else if (o->op_type == OP_FLIP) { 574 if (o->op_private & OPpFLIP_LINENUM) 575 sv_catpv(tmpsv, ",LINENUM"); 576 } 577 else if (o->op_type == OP_FLOP) { 578 if (o->op_private & OPpFLIP_LINENUM) 579 sv_catpv(tmpsv, ",LINENUM"); 580 } 581 else if (o->op_type == OP_RV2CV) { 582 if (o->op_private & OPpLVAL_INTRO) 583 sv_catpv(tmpsv, ",INTRO"); 584 } 585 else if (o->op_type == OP_GV) { 586 if (o->op_private & OPpEARLY_CV) 587 sv_catpv(tmpsv, ",EARLY_CV"); 588 } 589 else if (o->op_type == OP_LIST) { 590 if (o->op_private & OPpLIST_GUESSED) 591 sv_catpv(tmpsv, ",GUESSED"); 592 } 593 else if (o->op_type == OP_DELETE) { 594 if (o->op_private & OPpSLICE) 595 sv_catpv(tmpsv, ",SLICE"); 596 } 597 else if (o->op_type == OP_EXISTS) { 598 if (o->op_private & OPpEXISTS_SUB) 599 sv_catpv(tmpsv, ",EXISTS_SUB"); 600 } 601 else if (o->op_type == OP_SORT) { 602 if (o->op_private & OPpSORT_NUMERIC) 603 sv_catpv(tmpsv, ",NUMERIC"); 604 if (o->op_private & OPpSORT_INTEGER) 605 sv_catpv(tmpsv, ",INTEGER"); 606 if (o->op_private & OPpSORT_REVERSE) 607 sv_catpv(tmpsv, ",REVERSE"); 608 } 609 else if (o->op_type == OP_THREADSV) { 610 if (o->op_private & OPpDONE_SVREF) 611 sv_catpv(tmpsv, ",SVREF"); 612 } 613 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) { 614 if (o->op_private & OPpOPEN_IN_RAW) 615 sv_catpv(tmpsv, ",IN_RAW"); 616 if (o->op_private & OPpOPEN_IN_CRLF) 617 sv_catpv(tmpsv, ",IN_CRLF"); 618 if (o->op_private & OPpOPEN_OUT_RAW) 619 sv_catpv(tmpsv, ",OUT_RAW"); 620 if (o->op_private & OPpOPEN_OUT_CRLF) 621 sv_catpv(tmpsv, ",OUT_CRLF"); 622 } 623 else if (o->op_type == OP_EXIT) { 624 if (o->op_private & OPpEXIT_VMSISH) 625 sv_catpv(tmpsv, ",EXIT_VMSISH"); 626 if (o->op_private & OPpHUSH_VMSISH) 627 sv_catpv(tmpsv, ",HUSH_VMSISH"); 628 } 629 else if (o->op_type == OP_DIE) { 630 if (o->op_private & OPpHUSH_VMSISH) 631 sv_catpv(tmpsv, ",HUSH_VMSISH"); 632 } 633 else if (OP_IS_FILETEST_ACCESS(o)) { 634 if (o->op_private & OPpFT_ACCESS) 635 sv_catpv(tmpsv, ",FT_ACCESS"); 636 } 637 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO) 638 sv_catpv(tmpsv, ",INTRO"); 639 if (SvCUR(tmpsv)) 640 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1); 641 SvREFCNT_dec(tmpsv); 642 } 643 644 switch (o->op_type) { 645 case OP_AELEMFAST: 646 case OP_GVSV: 647 case OP_GV: 648 #ifdef USE_ITHREADS 649 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix); 650 #else 651 if ( ! PL_op->op_flags & OPf_SPECIAL) { /* not lexical */ 652 if (cSVOPo->op_sv) { 653 SV *tmpsv = NEWSV(0,0); 654 ENTER; 655 SAVEFREESV(tmpsv); 656 gv_fullname3(tmpsv, (GV*)cSVOPo->op_sv, Nullch); 657 Perl_dump_indent(aTHX_ level, file, "GV = %s\n", 658 SvPV_nolen_const(tmpsv)); 659 LEAVE; 660 } 661 else 662 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n"); 663 } 664 #endif 665 break; 666 case OP_CONST: 667 case OP_METHOD_NAMED: 668 #ifndef USE_ITHREADS 669 /* with ITHREADS, consts are stored in the pad, and the right pad 670 * may not be active here, so skip */ 671 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv)); 672 #endif 673 break; 674 case OP_SETSTATE: 675 case OP_NEXTSTATE: 676 case OP_DBSTATE: 677 if (CopLINE(cCOPo)) 678 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVf"\n", 679 (UV)CopLINE(cCOPo)); 680 if (CopSTASHPV(cCOPo)) 681 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n", 682 CopSTASHPV(cCOPo)); 683 if (cCOPo->cop_label) 684 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n", 685 cCOPo->cop_label); 686 break; 687 case OP_ENTERLOOP: 688 Perl_dump_indent(aTHX_ level, file, "REDO ===> "); 689 if (cLOOPo->op_redoop) 690 PerlIO_printf(file, "%d\n", cLOOPo->op_redoop->op_seq); 691 else 692 PerlIO_printf(file, "DONE\n"); 693 Perl_dump_indent(aTHX_ level, file, "NEXT ===> "); 694 if (cLOOPo->op_nextop) 695 PerlIO_printf(file, "%d\n", cLOOPo->op_nextop->op_seq); 696 else 697 PerlIO_printf(file, "DONE\n"); 698 Perl_dump_indent(aTHX_ level, file, "LAST ===> "); 699 if (cLOOPo->op_lastop) 700 PerlIO_printf(file, "%d\n", cLOOPo->op_lastop->op_seq); 701 else 702 PerlIO_printf(file, "DONE\n"); 703 break; 704 case OP_COND_EXPR: 705 case OP_RANGE: 706 case OP_MAPWHILE: 707 case OP_GREPWHILE: 708 case OP_OR: 709 case OP_AND: 710 Perl_dump_indent(aTHX_ level, file, "OTHER ===> "); 711 if (cLOGOPo->op_other) 712 PerlIO_printf(file, "%d\n", cLOGOPo->op_other->op_seq); 713 else 714 PerlIO_printf(file, "DONE\n"); 715 break; 716 case OP_PUSHRE: 717 case OP_MATCH: 718 case OP_QR: 719 case OP_SUBST: 720 do_pmop_dump(level, file, cPMOPo); 721 break; 722 case OP_LEAVE: 723 case OP_LEAVEEVAL: 724 case OP_LEAVESUB: 725 case OP_LEAVESUBLV: 726 case OP_LEAVEWRITE: 727 case OP_SCOPE: 728 if (o->op_private & OPpREFCOUNTED) 729 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ); 730 break; 731 default: 732 break; 733 } 734 if (o->op_flags & OPf_KIDS) { 735 OP *kid; 736 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) 737 do_op_dump(level, file, kid); 738 } 739 Perl_dump_indent(aTHX_ level-1, file, "}\n"); 740 } 741 742 void 743 Perl_op_dump(pTHX_ OP *o) 744 { 745 do_op_dump(0, Perl_debug_log, o); 746 } 747 748 void 749 Perl_gv_dump(pTHX_ GV *gv) 750 { 751 SV *sv; 752 753 if (!gv) { 754 PerlIO_printf(Perl_debug_log, "{}\n"); 755 return; 756 } 757 sv = sv_newmortal(); 758 PerlIO_printf(Perl_debug_log, "{\n"); 759 gv_fullname3(sv, gv, Nullch); 760 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv)); 761 if (gv != GvEGV(gv)) { 762 gv_efullname3(sv, GvEGV(gv), Nullch); 763 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv)); 764 } 765 PerlIO_putc(Perl_debug_log, '\n'); 766 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n"); 767 } 768 769 770 /* map magic types to the symbolic names 771 * (with the PERL_MAGIC_ prefixed stripped) 772 */ 773 774 static const struct { const char type; const char *name; } magic_names[] = { 775 { PERL_MAGIC_sv, "sv(\\0)" }, 776 { PERL_MAGIC_arylen, "arylen(#)" }, 777 { PERL_MAGIC_glob, "glob(*)" }, 778 { PERL_MAGIC_pos, "pos(.)" }, 779 { PERL_MAGIC_backref, "backref(<)" }, 780 { PERL_MAGIC_overload, "overload(A)" }, 781 { PERL_MAGIC_bm, "bm(B)" }, 782 { PERL_MAGIC_regdata, "regdata(D)" }, 783 { PERL_MAGIC_env, "env(E)" }, 784 { PERL_MAGIC_isa, "isa(I)" }, 785 { PERL_MAGIC_dbfile, "dbfile(L)" }, 786 { PERL_MAGIC_shared, "shared(N)" }, 787 { PERL_MAGIC_tied, "tied(P)" }, 788 { PERL_MAGIC_sig, "sig(S)" }, 789 { PERL_MAGIC_uvar, "uvar(U)" }, 790 { PERL_MAGIC_overload_elem, "overload_elem(a)" }, 791 { PERL_MAGIC_overload_table, "overload_table(c)" }, 792 { PERL_MAGIC_regdatum, "regdatum(d)" }, 793 { PERL_MAGIC_envelem, "envelem(e)" }, 794 { PERL_MAGIC_fm, "fm(f)" }, 795 { PERL_MAGIC_regex_global, "regex_global(g)" }, 796 { PERL_MAGIC_isaelem, "isaelem(i)" }, 797 { PERL_MAGIC_nkeys, "nkeys(k)" }, 798 { PERL_MAGIC_dbline, "dbline(l)" }, 799 { PERL_MAGIC_mutex, "mutex(m)" }, 800 { PERL_MAGIC_shared_scalar, "shared_scalar(n)" }, 801 { PERL_MAGIC_collxfrm, "collxfrm(o)" }, 802 { PERL_MAGIC_tiedelem, "tiedelem(p)" }, 803 { PERL_MAGIC_tiedscalar, "tiedscalar(q)" }, 804 { PERL_MAGIC_qr, "qr(r)" }, 805 { PERL_MAGIC_sigelem, "sigelem(s)" }, 806 { PERL_MAGIC_taint, "taint(t)" }, 807 { PERL_MAGIC_uvar_elem, "uvar_elem(v)" }, 808 { PERL_MAGIC_vec, "vec(v)" }, 809 { PERL_MAGIC_vstring, "v-string(V)" }, 810 { PERL_MAGIC_utf8, "utf8(w)" }, 811 { PERL_MAGIC_substr, "substr(x)" }, 812 { PERL_MAGIC_defelem, "defelem(y)" }, 813 { PERL_MAGIC_ext, "ext(~)" }, 814 /* this null string terminates the list */ 815 { 0, 0 }, 816 }; 817 818 void 819 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim) 820 { 821 for (; mg; mg = mg->mg_moremagic) { 822 Perl_dump_indent(aTHX_ level, file, 823 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg)); 824 if (mg->mg_virtual) { 825 const MGVTBL * const v = mg->mg_virtual; 826 const char *s = 0; 827 if (v == &PL_vtbl_sv) s = "sv"; 828 else if (v == &PL_vtbl_env) s = "env"; 829 else if (v == &PL_vtbl_envelem) s = "envelem"; 830 else if (v == &PL_vtbl_sig) s = "sig"; 831 else if (v == &PL_vtbl_sigelem) s = "sigelem"; 832 else if (v == &PL_vtbl_pack) s = "pack"; 833 else if (v == &PL_vtbl_packelem) s = "packelem"; 834 else if (v == &PL_vtbl_dbline) s = "dbline"; 835 else if (v == &PL_vtbl_isa) s = "isa"; 836 else if (v == &PL_vtbl_arylen) s = "arylen"; 837 else if (v == &PL_vtbl_glob) s = "glob"; 838 else if (v == &PL_vtbl_mglob) s = "mglob"; 839 else if (v == &PL_vtbl_nkeys) s = "nkeys"; 840 else if (v == &PL_vtbl_taint) s = "taint"; 841 else if (v == &PL_vtbl_substr) s = "substr"; 842 else if (v == &PL_vtbl_vec) s = "vec"; 843 else if (v == &PL_vtbl_pos) s = "pos"; 844 else if (v == &PL_vtbl_bm) s = "bm"; 845 else if (v == &PL_vtbl_fm) s = "fm"; 846 else if (v == &PL_vtbl_uvar) s = "uvar"; 847 else if (v == &PL_vtbl_defelem) s = "defelem"; 848 #ifdef USE_LOCALE_COLLATE 849 else if (v == &PL_vtbl_collxfrm) s = "collxfrm"; 850 #endif 851 else if (v == &PL_vtbl_amagic) s = "amagic"; 852 else if (v == &PL_vtbl_amagicelem) s = "amagicelem"; 853 else if (v == &PL_vtbl_backref) s = "backref"; 854 else if (v == &PL_vtbl_utf8) s = "utf8"; 855 if (s) 856 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s); 857 else 858 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v)); 859 } 860 else 861 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n"); 862 863 if (mg->mg_private) 864 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private); 865 866 { 867 int n; 868 const char *name = 0; 869 for (n = 0; magic_names[n].name; n++) { 870 if (mg->mg_type == magic_names[n].type) { 871 name = magic_names[n].name; 872 break; 873 } 874 } 875 if (name) 876 Perl_dump_indent(aTHX_ level, file, 877 " MG_TYPE = PERL_MAGIC_%s\n", name); 878 else 879 Perl_dump_indent(aTHX_ level, file, 880 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type); 881 } 882 883 if (mg->mg_flags) { 884 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags); 885 if (mg->mg_type == PERL_MAGIC_envelem && 886 mg->mg_flags & MGf_TAINTEDDIR) 887 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n"); 888 if (mg->mg_flags & MGf_REFCOUNTED) 889 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n"); 890 if (mg->mg_flags & MGf_GSKIP) 891 Perl_dump_indent(aTHX_ level, file, " GSKIP\n"); 892 if (mg->mg_type == PERL_MAGIC_regex_global && 893 mg->mg_flags & MGf_MINMATCH) 894 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n"); 895 } 896 if (mg->mg_obj) { 897 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n", PTR2UV(mg->mg_obj)); 898 if (mg->mg_flags & MGf_REFCOUNTED) 899 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */ 900 } 901 if (mg->mg_len) 902 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len); 903 if (mg->mg_ptr) { 904 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr)); 905 if (mg->mg_len >= 0) { 906 if (mg->mg_type != PERL_MAGIC_utf8) { 907 SV *sv = newSVpvn("", 0); 908 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim)); 909 SvREFCNT_dec(sv); 910 } 911 } 912 else if (mg->mg_len == HEf_SVKEY) { 913 PerlIO_puts(file, " => HEf_SVKEY\n"); 914 do_sv_dump(level+2, file, (SV*)((mg)->mg_ptr), nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */ 915 continue; 916 } 917 else 918 PerlIO_puts(file, " ???? - please notify IZ"); 919 PerlIO_putc(file, '\n'); 920 } 921 if (mg->mg_type == PERL_MAGIC_utf8) { 922 STRLEN *cache = (STRLEN *) mg->mg_ptr; 923 if (cache) { 924 IV i; 925 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++) 926 Perl_dump_indent(aTHX_ level, file, 927 " %2"IVdf": %"UVuf" -> %"UVuf"\n", 928 i, 929 (UV)cache[i * 2], 930 (UV)cache[i * 2 + 1]); 931 } 932 } 933 } 934 } 935 936 void 937 Perl_magic_dump(pTHX_ MAGIC *mg) 938 { 939 do_magic_dump(0, Perl_debug_log, mg, 0, 0, 0, 0); 940 } 941 942 void 943 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, char *name, HV *sv) 944 { 945 const char *hvname; 946 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv)); 947 if (sv && (hvname = HvNAME_get(sv))) 948 PerlIO_printf(file, "\t\"%s\"\n", hvname); 949 else 950 PerlIO_putc(file, '\n'); 951 } 952 953 void 954 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, char *name, GV *sv) 955 { 956 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv)); 957 if (sv && GvNAME(sv)) 958 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv)); 959 else 960 PerlIO_putc(file, '\n'); 961 } 962 963 void 964 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, char *name, GV *sv) 965 { 966 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv)); 967 if (sv && GvNAME(sv)) { 968 const char *hvname; 969 PerlIO_printf(file, "\t\""); 970 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv)))) 971 PerlIO_printf(file, "%s\" :: \"", hvname); 972 PerlIO_printf(file, "%s\"\n", GvNAME(sv)); 973 } 974 else 975 PerlIO_putc(file, '\n'); 976 } 977 978 void 979 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim) 980 { 981 SV *d; 982 const char *s; 983 U32 flags; 984 U32 type; 985 986 if (!sv) { 987 Perl_dump_indent(aTHX_ level, file, "SV = 0\n"); 988 return; 989 } 990 991 flags = SvFLAGS(sv); 992 type = SvTYPE(sv); 993 994 d = Perl_newSVpvf(aTHX_ 995 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (", 996 PTR2UV(SvANY(sv)), PTR2UV(sv), 997 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv), 998 (int)(PL_dumpindent*level), ""); 999 1000 if (flags & SVs_PADBUSY) sv_catpv(d, "PADBUSY,"); 1001 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,"); 1002 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,"); 1003 if (flags & SVs_TEMP) sv_catpv(d, "TEMP,"); 1004 if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,"); 1005 if (flags & SVs_GMG) sv_catpv(d, "GMG,"); 1006 if (flags & SVs_SMG) sv_catpv(d, "SMG,"); 1007 if (flags & SVs_RMG) sv_catpv(d, "RMG,"); 1008 1009 if (flags & SVf_IOK) sv_catpv(d, "IOK,"); 1010 if (flags & SVf_NOK) sv_catpv(d, "NOK,"); 1011 if (flags & SVf_POK) sv_catpv(d, "POK,"); 1012 if (flags & SVf_ROK) { 1013 sv_catpv(d, "ROK,"); 1014 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,"); 1015 } 1016 if (flags & SVf_OOK) sv_catpv(d, "OOK,"); 1017 if (flags & SVf_FAKE) sv_catpv(d, "FAKE,"); 1018 if (flags & SVf_READONLY) sv_catpv(d, "READONLY,"); 1019 1020 if (flags & SVf_AMAGIC && type != SVt_PVHV) 1021 sv_catpv(d, "OVERLOAD,"); 1022 if (flags & SVp_IOK) sv_catpv(d, "pIOK,"); 1023 if (flags & SVp_NOK) sv_catpv(d, "pNOK,"); 1024 if (flags & SVp_POK) sv_catpv(d, "pPOK,"); 1025 if (flags & SVp_SCREAM && type != SVt_PVHV) 1026 sv_catpv(d, "SCREAM,"); 1027 1028 switch (type) { 1029 case SVt_PVCV: 1030 case SVt_PVFM: 1031 if (CvANON(sv)) sv_catpv(d, "ANON,"); 1032 if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,"); 1033 if (CvCLONE(sv)) sv_catpv(d, "CLONE,"); 1034 if (CvCLONED(sv)) sv_catpv(d, "CLONED,"); 1035 if (CvCONST(sv)) sv_catpv(d, "CONST,"); 1036 if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,"); 1037 if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,"); 1038 if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,"); 1039 if (CvMETHOD(sv)) sv_catpv(d, "METHOD,"); 1040 if (CvLOCKED(sv)) sv_catpv(d, "LOCKED,"); 1041 if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,"); 1042 break; 1043 case SVt_PVHV: 1044 if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,"); 1045 if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,"); 1046 if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,"); 1047 if (HvREHASH(sv)) sv_catpv(d, "REHASH,"); 1048 if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,"); 1049 break; 1050 case SVt_PVGV: 1051 if (GvINTRO(sv)) sv_catpv(d, "INTRO,"); 1052 if (GvMULTI(sv)) sv_catpv(d, "MULTI,"); 1053 if (GvUNIQUE(sv)) sv_catpv(d, "UNIQUE,"); 1054 if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,"); 1055 if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,"); 1056 if (flags & SVpad_OUR) sv_catpv(d, "OUR,"); 1057 if (GvIMPORTED(sv)) { 1058 sv_catpv(d, "IMPORT"); 1059 if (GvIMPORTED(sv) == GVf_IMPORTED) 1060 sv_catpv(d, "ALL,"); 1061 else { 1062 sv_catpv(d, "("); 1063 if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV"); 1064 if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV"); 1065 if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV"); 1066 if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV"); 1067 sv_catpv(d, " ),"); 1068 } 1069 } 1070 /* FALL THROUGH */ 1071 default: 1072 if (SvEVALED(sv)) sv_catpv(d, "EVALED,"); 1073 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,"); 1074 break; 1075 case SVt_PVBM: 1076 if (SvTAIL(sv)) sv_catpv(d, "TAIL,"); 1077 if (SvVALID(sv)) sv_catpv(d, "VALID,"); 1078 break; 1079 case SVt_PVMG: 1080 if (flags & SVpad_TYPED) 1081 sv_catpv(d, "TYPED,"); 1082 break; 1083 } 1084 /* SVphv_SHAREKEYS is also 0x20000000 */ 1085 if ((type != SVt_PVHV) && SvUTF8(sv)) 1086 sv_catpv(d, "UTF8"); 1087 1088 if (*(SvEND(d) - 1) == ',') { 1089 SvCUR_set(d, SvCUR(d) - 1); 1090 SvPVX(d)[SvCUR(d)] = '\0'; 1091 } 1092 sv_catpv(d, ")"); 1093 s = SvPVX_const(d); 1094 1095 Perl_dump_indent(aTHX_ level, file, "SV = "); 1096 switch (type) { 1097 case SVt_NULL: 1098 PerlIO_printf(file, "NULL%s\n", s); 1099 SvREFCNT_dec(d); 1100 return; 1101 case SVt_IV: 1102 PerlIO_printf(file, "IV%s\n", s); 1103 break; 1104 case SVt_NV: 1105 PerlIO_printf(file, "NV%s\n", s); 1106 break; 1107 case SVt_RV: 1108 PerlIO_printf(file, "RV%s\n", s); 1109 break; 1110 case SVt_PV: 1111 PerlIO_printf(file, "PV%s\n", s); 1112 break; 1113 case SVt_PVIV: 1114 PerlIO_printf(file, "PVIV%s\n", s); 1115 break; 1116 case SVt_PVNV: 1117 PerlIO_printf(file, "PVNV%s\n", s); 1118 break; 1119 case SVt_PVBM: 1120 PerlIO_printf(file, "PVBM%s\n", s); 1121 break; 1122 case SVt_PVMG: 1123 PerlIO_printf(file, "PVMG%s\n", s); 1124 break; 1125 case SVt_PVLV: 1126 PerlIO_printf(file, "PVLV%s\n", s); 1127 break; 1128 case SVt_PVAV: 1129 PerlIO_printf(file, "PVAV%s\n", s); 1130 break; 1131 case SVt_PVHV: 1132 PerlIO_printf(file, "PVHV%s\n", s); 1133 break; 1134 case SVt_PVCV: 1135 PerlIO_printf(file, "PVCV%s\n", s); 1136 break; 1137 case SVt_PVGV: 1138 PerlIO_printf(file, "PVGV%s\n", s); 1139 break; 1140 case SVt_PVFM: 1141 PerlIO_printf(file, "PVFM%s\n", s); 1142 break; 1143 case SVt_PVIO: 1144 PerlIO_printf(file, "PVIO%s\n", s); 1145 break; 1146 default: 1147 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s); 1148 SvREFCNT_dec(d); 1149 return; 1150 } 1151 if (type >= SVt_PVIV || type == SVt_IV) { 1152 if (SvIsUV(sv)) 1153 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv)); 1154 else 1155 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv)); 1156 if (SvOOK(sv)) 1157 PerlIO_printf(file, " (OFFSET)"); 1158 PerlIO_putc(file, '\n'); 1159 } 1160 if (type >= SVt_PVNV || type == SVt_NV) { 1161 STORE_NUMERIC_LOCAL_SET_STANDARD(); 1162 /* %Vg doesn't work? --jhi */ 1163 #ifdef USE_LONG_DOUBLE 1164 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv)); 1165 #else 1166 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv)); 1167 #endif 1168 RESTORE_NUMERIC_LOCAL(); 1169 } 1170 if (SvROK(sv)) { 1171 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv))); 1172 if (nest < maxnest) 1173 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim); 1174 } 1175 if (type < SVt_PV) { 1176 SvREFCNT_dec(d); 1177 return; 1178 } 1179 if (type <= SVt_PVLV) { 1180 if (SvPVX_const(sv)) { 1181 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv))); 1182 if (SvOOK(sv)) 1183 PerlIO_printf(file, "( %s . ) ", pv_display(d, (char *)SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, pvlim)); 1184 PerlIO_printf(file, "%s", pv_display(d, (char *)SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim)); 1185 if (SvUTF8(sv)) /* the 8? \x{....} */ 1186 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 8 * sv_len_utf8(sv), UNI_DISPLAY_QQ)); 1187 PerlIO_printf(file, "\n"); 1188 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv)); 1189 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv)); 1190 } 1191 else 1192 Perl_dump_indent(aTHX_ level, file, " PV = 0\n"); 1193 } 1194 if (type >= SVt_PVMG) { 1195 if (SvMAGIC(sv)) 1196 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim); 1197 if (SvSTASH(sv)) 1198 do_hv_dump(level, file, " STASH", SvSTASH(sv)); 1199 } 1200 switch (type) { 1201 case SVt_PVLV: 1202 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv)); 1203 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv)); 1204 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv)); 1205 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv))); 1206 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T') 1207 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest, 1208 dumpops, pvlim); 1209 break; 1210 case SVt_PVAV: 1211 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv))); 1212 if (AvARRAY(sv) != AvALLOC(sv)) { 1213 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv))); 1214 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv))); 1215 } 1216 else 1217 PerlIO_putc(file, '\n'); 1218 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv)); 1219 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv)); 1220 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", PTR2UV(AvARYLEN(sv))); 1221 flags = AvFLAGS(sv); 1222 sv_setpvn(d, "", 0); 1223 if (flags & AVf_REAL) sv_catpv(d, ",REAL"); 1224 if (flags & AVf_REIFY) sv_catpv(d, ",REIFY"); 1225 if (flags & AVf_REUSED) sv_catpv(d, ",REUSED"); 1226 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n", 1227 SvCUR(d) ? SvPVX_const(d) + 1 : ""); 1228 if (nest < maxnest && av_len((AV*)sv) >= 0) { 1229 int count; 1230 for (count = 0; count <= av_len((AV*)sv) && count < maxnest; count++) { 1231 SV** elt = av_fetch((AV*)sv,count,0); 1232 1233 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count); 1234 if (elt) 1235 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim); 1236 } 1237 } 1238 break; 1239 case SVt_PVHV: 1240 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv))); 1241 if (HvARRAY(sv) && HvKEYS(sv)) { 1242 /* Show distribution of HEs in the ARRAY */ 1243 int freq[200]; 1244 #define FREQ_MAX (sizeof freq / sizeof freq[0] - 1) 1245 int i; 1246 int max = 0; 1247 U32 pow2 = 2, keys = HvKEYS(sv); 1248 NV theoret, sum = 0; 1249 1250 PerlIO_printf(file, " ("); 1251 Zero(freq, FREQ_MAX + 1, int); 1252 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) { 1253 HE* h; int count = 0; 1254 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h)) 1255 count++; 1256 if (count > FREQ_MAX) 1257 count = FREQ_MAX; 1258 freq[count]++; 1259 if (max < count) 1260 max = count; 1261 } 1262 for (i = 0; i <= max; i++) { 1263 if (freq[i]) { 1264 PerlIO_printf(file, "%d%s:%d", i, 1265 (i == FREQ_MAX) ? "+" : "", 1266 freq[i]); 1267 if (i != max) 1268 PerlIO_printf(file, ", "); 1269 } 1270 } 1271 PerlIO_putc(file, ')'); 1272 /* The "quality" of a hash is defined as the total number of 1273 comparisons needed to access every element once, relative 1274 to the expected number needed for a random hash. 1275 1276 The total number of comparisons is equal to the sum of 1277 the squares of the number of entries in each bucket. 1278 For a random hash of n keys into k buckets, the expected 1279 value is 1280 n + n(n-1)/2k 1281 */ 1282 1283 for (i = max; i > 0; i--) { /* Precision: count down. */ 1284 sum += freq[i] * i * i; 1285 } 1286 while ((keys = keys >> 1)) 1287 pow2 = pow2 << 1; 1288 theoret = HvKEYS(sv); 1289 theoret += theoret * (theoret-1)/pow2; 1290 PerlIO_putc(file, '\n'); 1291 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100); 1292 } 1293 PerlIO_putc(file, '\n'); 1294 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv)); 1295 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv)); 1296 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv)); 1297 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv)); 1298 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv))); 1299 if (HvPMROOT(sv)) 1300 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(HvPMROOT(sv))); 1301 { 1302 const char *hvname = HvNAME_get(sv); 1303 if (hvname) 1304 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname); 1305 } 1306 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */ 1307 HE *he; 1308 HV *hv = (HV*)sv; 1309 int count = maxnest - nest; 1310 1311 hv_iterinit(hv); 1312 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS)) 1313 && count--) { 1314 SV *elt, *keysv; 1315 const char *keypv; 1316 STRLEN len; 1317 U32 hash = HeHASH(he); 1318 1319 keysv = hv_iterkeysv(he); 1320 keypv = SvPV_const(keysv, len); 1321 elt = hv_iterval(hv, he); 1322 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, (char *)keypv, len, 0, pvlim)); 1323 if (SvUTF8(keysv)) 1324 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 8 * sv_len_utf8(keysv), UNI_DISPLAY_QQ)); 1325 if (HeKREHASH(he)) 1326 PerlIO_printf(file, "[REHASH] "); 1327 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash); 1328 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim); 1329 } 1330 hv_iterinit(hv); /* Return to status quo */ 1331 } 1332 break; 1333 case SVt_PVCV: 1334 if (SvPOK(sv)) 1335 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%s\"\n", SvPV_nolen_const(sv)); 1336 /* FALL THROUGH */ 1337 case SVt_PVFM: 1338 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv)); 1339 if (CvSTART(sv)) 1340 Perl_dump_indent(aTHX_ level, file, " START = 0x%"UVxf" ===> %"IVdf"\n", PTR2UV(CvSTART(sv)), (IV)CvSTART(sv)->op_seq); 1341 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n", PTR2UV(CvROOT(sv))); 1342 if (CvROOT(sv) && dumpops) 1343 do_op_dump(level+1, file, CvROOT(sv)); 1344 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv))); 1345 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n", (IV)CvXSUBANY(sv).any_i32); 1346 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv)); 1347 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv)); 1348 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv)); 1349 #ifdef USE_5005THREADS 1350 Perl_dump_indent(aTHX_ level, file, " MUTEXP = 0x%"UVxf"\n", PTR2UV(CvMUTEXP(sv))); 1351 Perl_dump_indent(aTHX_ level, file, " OWNER = 0x%"UVxf"\n", PTR2UV(CvOWNER(sv))); 1352 #endif /* USE_5005THREADS */ 1353 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv)); 1354 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv)); 1355 if (type == SVt_PVFM) 1356 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv)); 1357 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv))); 1358 if (nest < maxnest) { 1359 do_dump_pad(level+1, file, CvPADLIST(sv), 0); 1360 } 1361 { 1362 const CV *outside = CvOUTSIDE(sv); 1363 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n", 1364 PTR2UV(outside), 1365 (!outside ? "null" 1366 : CvANON(outside) ? "ANON" 1367 : (outside == PL_main_cv) ? "MAIN" 1368 : CvUNIQUE(outside) ? "UNIQUE" 1369 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED")); 1370 } 1371 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))) 1372 do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim); 1373 break; 1374 case SVt_PVGV: 1375 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv)); 1376 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv)); 1377 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv)); 1378 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv))); 1379 if (!GvGP(sv)) 1380 break; 1381 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv))); 1382 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv)); 1383 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv))); 1384 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv))); 1385 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv))); 1386 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv))); 1387 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv))); 1388 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv)); 1389 Perl_dump_indent(aTHX_ level, file, " GPFLAGS = 0x%"UVxf"\n", (UV)GvGPFLAGS(sv)); 1390 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv)); 1391 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv)); 1392 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv)); 1393 do_gv_dump (level, file, " EGV", GvEGV(sv)); 1394 break; 1395 case SVt_PVIO: 1396 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv))); 1397 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv))); 1398 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv))); 1399 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv)); 1400 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv)); 1401 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv)); 1402 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv)); 1403 if (IoTOP_NAME(sv)) 1404 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv)); 1405 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv)); 1406 if (IoFMT_NAME(sv)) 1407 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv)); 1408 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv)); 1409 if (IoBOTTOM_NAME(sv)) 1410 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv)); 1411 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv)); 1412 Perl_dump_indent(aTHX_ level, file, " SUBPROCESS = %"IVdf"\n", (IV)IoSUBPROCESS(sv)); 1413 if (isPRINT(IoTYPE(sv))) 1414 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv)); 1415 else 1416 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv)); 1417 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv)); 1418 break; 1419 } 1420 SvREFCNT_dec(d); 1421 } 1422 1423 void 1424 Perl_sv_dump(pTHX_ SV *sv) 1425 { 1426 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0); 1427 } 1428 1429 int 1430 Perl_runops_debug(pTHX) 1431 { 1432 if (!PL_op) { 1433 if (ckWARN_d(WARN_DEBUGGING)) 1434 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN"); 1435 return 0; 1436 } 1437 1438 do { 1439 PERL_ASYNC_CHECK(); 1440 if (PL_debug) { 1441 if (PL_watchaddr != 0 && *PL_watchaddr != PL_watchok) 1442 PerlIO_printf(Perl_debug_log, 1443 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n", 1444 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok), 1445 PTR2UV(*PL_watchaddr)); 1446 if (DEBUG_s_TEST_) { 1447 if (DEBUG_v_TEST_) { 1448 PerlIO_printf(Perl_debug_log, "\n"); 1449 deb_stack_all(); 1450 } 1451 else 1452 debstack(); 1453 } 1454 1455 1456 if (DEBUG_t_TEST_) debop(PL_op); 1457 if (DEBUG_P_TEST_) debprof(PL_op); 1458 } 1459 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX))); 1460 1461 TAINT_NOT; 1462 return 0; 1463 } 1464 1465 I32 1466 Perl_debop(pTHX_ OP *o) 1467 { 1468 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_) 1469 return 0; 1470 1471 Perl_deb(aTHX_ "%s", OP_NAME(o)); 1472 switch (o->op_type) { 1473 case OP_CONST: 1474 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv)); 1475 break; 1476 case OP_GVSV: 1477 case OP_GV: 1478 if (cGVOPo_gv) { 1479 SV *sv = NEWSV(0,0); 1480 gv_fullname3(sv, cGVOPo_gv, Nullch); 1481 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv)); 1482 SvREFCNT_dec(sv); 1483 } 1484 else 1485 PerlIO_printf(Perl_debug_log, "(NULL)"); 1486 break; 1487 case OP_PADSV: 1488 case OP_PADAV: 1489 case OP_PADHV: 1490 { 1491 /* print the lexical's name */ 1492 CV *cv = deb_curcv(cxstack_ix); 1493 SV *sv; 1494 if (cv) { 1495 AV * const padlist = CvPADLIST(cv); 1496 AV * const comppad = (AV*)(*av_fetch(padlist, 0, FALSE)); 1497 sv = *av_fetch(comppad, o->op_targ, FALSE); 1498 } else 1499 sv = Nullsv; 1500 if (sv) 1501 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv)); 1502 else 1503 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ); 1504 } 1505 break; 1506 default: 1507 break; 1508 } 1509 PerlIO_printf(Perl_debug_log, "\n"); 1510 return 0; 1511 } 1512 1513 STATIC CV* 1514 S_deb_curcv(pTHX_ I32 ix) 1515 { 1516 const PERL_CONTEXT *cx = &cxstack[ix]; 1517 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) 1518 return cx->blk_sub.cv; 1519 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx)) 1520 return PL_compcv; 1521 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN) 1522 return PL_main_cv; 1523 else if (ix <= 0) 1524 return Nullcv; 1525 else 1526 return deb_curcv(ix - 1); 1527 } 1528 1529 void 1530 Perl_watch(pTHX_ char **addr) 1531 { 1532 PL_watchaddr = addr; 1533 PL_watchok = *addr; 1534 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n", 1535 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok)); 1536 } 1537 1538 STATIC void 1539 S_debprof(pTHX_ const OP *o) 1540 { 1541 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_) 1542 return; 1543 if (!PL_profiledata) 1544 Newxz(PL_profiledata, MAXO, U32); 1545 ++PL_profiledata[o->op_type]; 1546 } 1547 1548 void 1549 Perl_debprofdump(pTHX) 1550 { 1551 unsigned i; 1552 if (!PL_profiledata) 1553 return; 1554 for (i = 0; i < MAXO; i++) { 1555 if (PL_profiledata[i]) 1556 PerlIO_printf(Perl_debug_log, 1557 "%5lu %s\n", (unsigned long)PL_profiledata[i], 1558 PL_op_name[i]); 1559 } 1560 } 1561 1562 /* 1563 * Local variables: 1564 * c-indentation-style: bsd 1565 * c-basic-offset: 4 1566 * indent-tabs-mode: t 1567 * End: 1568 * 1569 * ex: set ts=8 sts=4 sw=4 noet: 1570 */ 1571