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 #include "proto.h" 30 31 32 static const char* const svtypenames[SVt_LAST] = { 33 "NULL", 34 "BIND", 35 "IV", 36 "NV", 37 "RV", 38 "PV", 39 "PVIV", 40 "PVNV", 41 "PVMG", 42 "PVGV", 43 "PVLV", 44 "PVAV", 45 "PVHV", 46 "PVCV", 47 "PVFM", 48 "PVIO" 49 }; 50 51 52 static const char* const svshorttypenames[SVt_LAST] = { 53 "UNDEF", 54 "BIND", 55 "IV", 56 "NV", 57 "RV", 58 "PV", 59 "PVIV", 60 "PVNV", 61 "PVMG", 62 "GV", 63 "PVLV", 64 "AV", 65 "HV", 66 "CV", 67 "FM", 68 "IO" 69 }; 70 71 #define Sequence PL_op_sequence 72 73 void 74 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...) 75 { 76 va_list args; 77 PERL_ARGS_ASSERT_DUMP_INDENT; 78 va_start(args, pat); 79 dump_vindent(level, file, pat, &args); 80 va_end(args); 81 } 82 83 void 84 Perl_dump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args) 85 { 86 dVAR; 87 PERL_ARGS_ASSERT_DUMP_VINDENT; 88 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), ""); 89 PerlIO_vprintf(file, pat, *args); 90 } 91 92 void 93 Perl_dump_all(pTHX) 94 { 95 dVAR; 96 PerlIO_setlinebuf(Perl_debug_log); 97 if (PL_main_root) 98 op_dump(PL_main_root); 99 dump_packsubs(PL_defstash); 100 } 101 102 void 103 Perl_dump_packsubs(pTHX_ const HV *stash) 104 { 105 dVAR; 106 I32 i; 107 108 PERL_ARGS_ASSERT_DUMP_PACKSUBS; 109 110 if (!HvARRAY(stash)) 111 return; 112 for (i = 0; i <= (I32) HvMAX(stash); i++) { 113 const HE *entry; 114 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { 115 const GV * const gv = (const GV *)HeVAL(entry); 116 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv)) 117 continue; 118 if (GvCVu(gv)) 119 dump_sub(gv); 120 if (GvFORM(gv)) 121 dump_form(gv); 122 if (HeKEY(entry)[HeKLEN(entry)-1] == ':') { 123 const HV * const hv = GvHV(gv); 124 if (hv && (hv != PL_defstash)) 125 dump_packsubs(hv); /* nested package */ 126 } 127 } 128 } 129 } 130 131 void 132 Perl_dump_sub(pTHX_ const GV *gv) 133 { 134 SV * const sv = sv_newmortal(); 135 136 PERL_ARGS_ASSERT_DUMP_SUB; 137 138 gv_fullname3(sv, gv, NULL); 139 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", SvPVX_const(sv)); 140 if (CvISXSUB(GvCV(gv))) 141 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%"UVxf" %d)\n", 142 PTR2UV(CvXSUB(GvCV(gv))), 143 (int)CvXSUBANY(GvCV(gv)).any_i32); 144 else if (CvROOT(GvCV(gv))) 145 op_dump(CvROOT(GvCV(gv))); 146 else 147 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n"); 148 } 149 150 void 151 Perl_dump_form(pTHX_ const GV *gv) 152 { 153 SV * const sv = sv_newmortal(); 154 155 PERL_ARGS_ASSERT_DUMP_FORM; 156 157 gv_fullname3(sv, gv, NULL); 158 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nFORMAT %s = ", SvPVX_const(sv)); 159 if (CvROOT(GvFORM(gv))) 160 op_dump(CvROOT(GvFORM(gv))); 161 else 162 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n"); 163 } 164 165 void 166 Perl_dump_eval(pTHX) 167 { 168 dVAR; 169 op_dump(PL_eval_root); 170 } 171 172 173 /* 174 =for apidoc pv_escape 175 176 Escapes at most the first "count" chars of pv and puts the results into 177 dsv such that the size of the escaped string will not exceed "max" chars 178 and will not contain any incomplete escape sequences. 179 180 If flags contains PERL_PV_ESCAPE_QUOTE then any double quotes in the string 181 will also be escaped. 182 183 Normally the SV will be cleared before the escaped string is prepared, 184 but when PERL_PV_ESCAPE_NOCLEAR is set this will not occur. 185 186 If PERL_PV_ESCAPE_UNI is set then the input string is treated as Unicode, 187 if PERL_PV_ESCAPE_UNI_DETECT is set then the input string is scanned 188 using C<is_utf8_string()> to determine if it is Unicode. 189 190 If PERL_PV_ESCAPE_ALL is set then all input chars will be output 191 using C<\x01F1> style escapes, otherwise only chars above 255 will be 192 escaped using this style, other non printable chars will use octal or 193 common escaped patterns like C<\n>. If PERL_PV_ESCAPE_NOBACKSLASH 194 then all chars below 255 will be treated as printable and 195 will be output as literals. 196 197 If PERL_PV_ESCAPE_FIRSTCHAR is set then only the first char of the 198 string will be escaped, regardles of max. If the string is utf8 and 199 the chars value is >255 then it will be returned as a plain hex 200 sequence. Thus the output will either be a single char, 201 an octal escape sequence, a special escape like C<\n> or a 3 or 202 more digit hex value. 203 204 If PERL_PV_ESCAPE_RE is set then the escape char used will be a '%' and 205 not a '\\'. This is because regexes very often contain backslashed 206 sequences, whereas '%' is not a particularly common character in patterns. 207 208 Returns a pointer to the escaped text as held by dsv. 209 210 =cut 211 */ 212 #define PV_ESCAPE_OCTBUFSIZE 32 213 214 char * 215 Perl_pv_escape( pTHX_ SV *dsv, char const * const str, 216 const STRLEN count, const STRLEN max, 217 STRLEN * const escaped, const U32 flags ) 218 { 219 const char esc = (flags & PERL_PV_ESCAPE_RE) ? '%' : '\\'; 220 const char dq = (flags & PERL_PV_ESCAPE_QUOTE) ? '"' : esc; 221 char octbuf[PV_ESCAPE_OCTBUFSIZE] = "%123456789ABCDF"; 222 STRLEN wrote = 0; /* chars written so far */ 223 STRLEN chsize = 0; /* size of data to be written */ 224 STRLEN readsize = 1; /* size of data just read */ 225 bool isuni= flags & PERL_PV_ESCAPE_UNI ? 1 : 0; /* is this Unicode */ 226 const char *pv = str; 227 const char * const end = pv + count; /* end of string */ 228 octbuf[0] = esc; 229 230 PERL_ARGS_ASSERT_PV_ESCAPE; 231 232 if (!(flags & PERL_PV_ESCAPE_NOCLEAR)) { 233 /* This won't alter the UTF-8 flag */ 234 sv_setpvs(dsv, ""); 235 } 236 237 if ((flags & PERL_PV_ESCAPE_UNI_DETECT) && is_utf8_string((U8*)pv, count)) 238 isuni = 1; 239 240 for ( ; (pv < end && (!max || (wrote < max))) ; pv += readsize ) { 241 const UV u= (isuni) ? utf8_to_uvchr((U8*)pv, &readsize) : (U8)*pv; 242 const U8 c = (U8)u & 0xFF; 243 244 if ( ( u > 255 ) || (flags & PERL_PV_ESCAPE_ALL)) { 245 if (flags & PERL_PV_ESCAPE_FIRSTCHAR) 246 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, 247 "%"UVxf, u); 248 else 249 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, 250 "%cx{%"UVxf"}", esc, u); 251 } else if (flags & PERL_PV_ESCAPE_NOBACKSLASH) { 252 chsize = 1; 253 } else { 254 if ( (c == dq) || (c == esc) || !isPRINT(c) ) { 255 chsize = 2; 256 switch (c) { 257 258 case '\\' : /* fallthrough */ 259 case '%' : if ( c == esc ) { 260 octbuf[1] = esc; 261 } else { 262 chsize = 1; 263 } 264 break; 265 case '\v' : octbuf[1] = 'v'; break; 266 case '\t' : octbuf[1] = 't'; break; 267 case '\r' : octbuf[1] = 'r'; break; 268 case '\n' : octbuf[1] = 'n'; break; 269 case '\f' : octbuf[1] = 'f'; break; 270 case '"' : 271 if ( dq == '"' ) 272 octbuf[1] = '"'; 273 else 274 chsize = 1; 275 break; 276 default: 277 if ( (pv < end) && isDIGIT((U8)*(pv+readsize)) ) 278 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, 279 "%c%03o", esc, c); 280 else 281 chsize = my_snprintf( octbuf, PV_ESCAPE_OCTBUFSIZE, 282 "%c%o", esc, c); 283 } 284 } else { 285 chsize = 1; 286 } 287 } 288 if ( max && (wrote + chsize > max) ) { 289 break; 290 } else if (chsize > 1) { 291 sv_catpvn(dsv, octbuf, chsize); 292 wrote += chsize; 293 } else { 294 /* If PERL_PV_ESCAPE_NOBACKSLASH is set then bytes in the range 295 128-255 can be appended raw to the dsv. If dsv happens to be 296 UTF-8 then we need catpvf to upgrade them for us. 297 Or add a new API call sv_catpvc(). Think about that name, and 298 how to keep it clear that it's unlike the s of catpvs, which is 299 really an array octets, not a string. */ 300 Perl_sv_catpvf( aTHX_ dsv, "%c", c); 301 wrote++; 302 } 303 if ( flags & PERL_PV_ESCAPE_FIRSTCHAR ) 304 break; 305 } 306 if (escaped != NULL) 307 *escaped= pv - str; 308 return SvPVX(dsv); 309 } 310 /* 311 =for apidoc pv_pretty 312 313 Converts a string into something presentable, handling escaping via 314 pv_escape() and supporting quoting and ellipses. 315 316 If the PERL_PV_PRETTY_QUOTE flag is set then the result will be 317 double quoted with any double quotes in the string escaped. Otherwise 318 if the PERL_PV_PRETTY_LTGT flag is set then the result be wrapped in 319 angle brackets. 320 321 If the PERL_PV_PRETTY_ELLIPSES flag is set and not all characters in 322 string were output then an ellipsis C<...> will be appended to the 323 string. Note that this happens AFTER it has been quoted. 324 325 If start_color is non-null then it will be inserted after the opening 326 quote (if there is one) but before the escaped text. If end_color 327 is non-null then it will be inserted after the escaped text but before 328 any quotes or ellipses. 329 330 Returns a pointer to the prettified text as held by dsv. 331 332 =cut 333 */ 334 335 char * 336 Perl_pv_pretty( pTHX_ SV *dsv, char const * const str, const STRLEN count, 337 const STRLEN max, char const * const start_color, char const * const end_color, 338 const U32 flags ) 339 { 340 const U8 dq = (flags & PERL_PV_PRETTY_QUOTE) ? '"' : '%'; 341 STRLEN escaped; 342 343 PERL_ARGS_ASSERT_PV_PRETTY; 344 345 if (!(flags & PERL_PV_PRETTY_NOCLEAR)) { 346 /* This won't alter the UTF-8 flag */ 347 sv_setpvs(dsv, ""); 348 } 349 350 if ( dq == '"' ) 351 sv_catpvs(dsv, "\""); 352 else if ( flags & PERL_PV_PRETTY_LTGT ) 353 sv_catpvs(dsv, "<"); 354 355 if ( start_color != NULL ) 356 sv_catpv(dsv, start_color); 357 358 pv_escape( dsv, str, count, max, &escaped, flags | PERL_PV_ESCAPE_NOCLEAR ); 359 360 if ( end_color != NULL ) 361 sv_catpv(dsv, end_color); 362 363 if ( dq == '"' ) 364 sv_catpvs( dsv, "\""); 365 else if ( flags & PERL_PV_PRETTY_LTGT ) 366 sv_catpvs(dsv, ">"); 367 368 if ( (flags & PERL_PV_PRETTY_ELLIPSES) && ( escaped < count ) ) 369 sv_catpvs(dsv, "..."); 370 371 return SvPVX(dsv); 372 } 373 374 /* 375 =for apidoc pv_display 376 377 Similar to 378 379 pv_escape(dsv,pv,cur,pvlim,PERL_PV_ESCAPE_QUOTE); 380 381 except that an additional "\0" will be appended to the string when 382 len > cur and pv[cur] is "\0". 383 384 Note that the final string may be up to 7 chars longer than pvlim. 385 386 =cut 387 */ 388 389 char * 390 Perl_pv_display(pTHX_ SV *dsv, const char *pv, STRLEN cur, STRLEN len, STRLEN pvlim) 391 { 392 PERL_ARGS_ASSERT_PV_DISPLAY; 393 394 pv_pretty( dsv, pv, cur, pvlim, NULL, NULL, PERL_PV_PRETTY_DUMP); 395 if (len > cur && pv[cur] == '\0') 396 sv_catpvs( dsv, "\\0"); 397 return SvPVX(dsv); 398 } 399 400 char * 401 Perl_sv_peek(pTHX_ SV *sv) 402 { 403 dVAR; 404 SV * const t = sv_newmortal(); 405 int unref = 0; 406 U32 type; 407 408 sv_setpvs(t, ""); 409 retry: 410 if (!sv) { 411 sv_catpv(t, "VOID"); 412 goto finish; 413 } 414 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') { 415 sv_catpv(t, "WILD"); 416 goto finish; 417 } 418 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) { 419 if (sv == &PL_sv_undef) { 420 sv_catpv(t, "SV_UNDEF"); 421 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT| 422 SVs_GMG|SVs_SMG|SVs_RMG)) && 423 SvREADONLY(sv)) 424 goto finish; 425 } 426 else if (sv == &PL_sv_no) { 427 sv_catpv(t, "SV_NO"); 428 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| 429 SVs_GMG|SVs_SMG|SVs_RMG)) && 430 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| 431 SVp_POK|SVp_NOK)) && 432 SvCUR(sv) == 0 && 433 SvNVX(sv) == 0.0) 434 goto finish; 435 } 436 else if (sv == &PL_sv_yes) { 437 sv_catpv(t, "SV_YES"); 438 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| 439 SVs_GMG|SVs_SMG|SVs_RMG)) && 440 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| 441 SVp_POK|SVp_NOK)) && 442 SvCUR(sv) == 1 && 443 SvPVX_const(sv) && *SvPVX_const(sv) == '1' && 444 SvNVX(sv) == 1.0) 445 goto finish; 446 } 447 else { 448 sv_catpv(t, "SV_PLACEHOLDER"); 449 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT| 450 SVs_GMG|SVs_SMG|SVs_RMG)) && 451 SvREADONLY(sv)) 452 goto finish; 453 } 454 sv_catpv(t, ":"); 455 } 456 else if (SvREFCNT(sv) == 0) { 457 sv_catpv(t, "("); 458 unref++; 459 } 460 else if (DEBUG_R_TEST_) { 461 int is_tmp = 0; 462 I32 ix; 463 /* is this SV on the tmps stack? */ 464 for (ix=PL_tmps_ix; ix>=0; ix--) { 465 if (PL_tmps_stack[ix] == sv) { 466 is_tmp = 1; 467 break; 468 } 469 } 470 if (SvREFCNT(sv) > 1) 471 Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv), 472 is_tmp ? "T" : ""); 473 else if (is_tmp) 474 sv_catpv(t, "<T>"); 475 } 476 477 if (SvROK(sv)) { 478 sv_catpv(t, "\\"); 479 if (SvCUR(t) + unref > 10) { 480 SvCUR_set(t, unref + 3); 481 *SvEND(t) = '\0'; 482 sv_catpv(t, "..."); 483 goto finish; 484 } 485 sv = SvRV(sv); 486 goto retry; 487 } 488 type = SvTYPE(sv); 489 if (type == SVt_PVCV) { 490 Perl_sv_catpvf(aTHX_ t, "CV(%s)", CvGV(sv) ? GvNAME(CvGV(sv)) : ""); 491 goto finish; 492 } else if (type < SVt_LAST) { 493 sv_catpv(t, svshorttypenames[type]); 494 495 if (type == SVt_NULL) 496 goto finish; 497 } else { 498 sv_catpv(t, "FREED"); 499 goto finish; 500 } 501 502 if (SvPOKp(sv)) { 503 if (!SvPVX_const(sv)) 504 sv_catpv(t, "(null)"); 505 else { 506 SV * const tmp = newSVpvs(""); 507 sv_catpv(t, "("); 508 if (SvOOK(sv)) 509 Perl_sv_catpvf(aTHX_ t, "[%s]", pv_display(tmp, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, 127)); 510 Perl_sv_catpvf(aTHX_ t, "%s)", pv_display(tmp, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), 127)); 511 if (SvUTF8(sv)) 512 Perl_sv_catpvf(aTHX_ t, " [UTF8 \"%s\"]", 513 sv_uni_display(tmp, sv, 6 * SvCUR(sv), 514 UNI_DISPLAY_QQ)); 515 SvREFCNT_dec(tmp); 516 } 517 } 518 else if (SvNOKp(sv)) { 519 STORE_NUMERIC_LOCAL_SET_STANDARD(); 520 Perl_sv_catpvf(aTHX_ t, "(%"NVgf")",SvNVX(sv)); 521 RESTORE_NUMERIC_LOCAL(); 522 } 523 else if (SvIOKp(sv)) { 524 if (SvIsUV(sv)) 525 Perl_sv_catpvf(aTHX_ t, "(%"UVuf")", (UV)SvUVX(sv)); 526 else 527 Perl_sv_catpvf(aTHX_ t, "(%"IVdf")", (IV)SvIVX(sv)); 528 } 529 else 530 sv_catpv(t, "()"); 531 532 finish: 533 while (unref--) 534 sv_catpv(t, ")"); 535 if (PL_tainting && SvTAINTED(sv)) 536 sv_catpv(t, " [tainted]"); 537 return SvPV_nolen(t); 538 } 539 540 void 541 Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, const PMOP *pm) 542 { 543 char ch; 544 545 PERL_ARGS_ASSERT_DO_PMOP_DUMP; 546 547 if (!pm) { 548 Perl_dump_indent(aTHX_ level, file, "{}\n"); 549 return; 550 } 551 Perl_dump_indent(aTHX_ level, file, "{\n"); 552 level++; 553 if (pm->op_pmflags & PMf_ONCE) 554 ch = '?'; 555 else 556 ch = '/'; 557 if (PM_GETRE(pm)) 558 Perl_dump_indent(aTHX_ level, file, "PMf_PRE %c%s%c%s\n", 559 ch, RX_PRECOMP(PM_GETRE(pm)), ch, 560 (pm->op_private & OPpRUNTIME) ? " (RUNTIME)" : ""); 561 else 562 Perl_dump_indent(aTHX_ level, file, "PMf_PRE (RUNTIME)\n"); 563 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) { 564 Perl_dump_indent(aTHX_ level, file, "PMf_REPL = "); 565 op_dump(pm->op_pmreplrootu.op_pmreplroot); 566 } 567 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) { 568 SV * const tmpsv = pm_description(pm); 569 Perl_dump_indent(aTHX_ level, file, "PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : ""); 570 SvREFCNT_dec(tmpsv); 571 } 572 573 Perl_dump_indent(aTHX_ level-1, file, "}\n"); 574 } 575 576 static SV * 577 S_pm_description(pTHX_ const PMOP *pm) 578 { 579 SV * const desc = newSVpvs(""); 580 const REGEXP * const regex = PM_GETRE(pm); 581 const U32 pmflags = pm->op_pmflags; 582 583 PERL_ARGS_ASSERT_PM_DESCRIPTION; 584 585 if (pmflags & PMf_ONCE) 586 sv_catpv(desc, ",ONCE"); 587 #ifdef USE_ITHREADS 588 if (SvREADONLY(PL_regex_pad[pm->op_pmoffset])) 589 sv_catpv(desc, ":USED"); 590 #else 591 if (pmflags & PMf_USED) 592 sv_catpv(desc, ":USED"); 593 #endif 594 595 if (regex) { 596 if (RX_EXTFLAGS(regex) & RXf_TAINTED) 597 sv_catpv(desc, ",TAINTED"); 598 if (RX_CHECK_SUBSTR(regex)) { 599 if (!(RX_EXTFLAGS(regex) & RXf_NOSCAN)) 600 sv_catpv(desc, ",SCANFIRST"); 601 if (RX_EXTFLAGS(regex) & RXf_CHECK_ALL) 602 sv_catpv(desc, ",ALL"); 603 } 604 if (RX_EXTFLAGS(regex) & RXf_SKIPWHITE) 605 sv_catpv(desc, ",SKIPWHITE"); 606 } 607 608 if (pmflags & PMf_CONST) 609 sv_catpv(desc, ",CONST"); 610 if (pmflags & PMf_KEEP) 611 sv_catpv(desc, ",KEEP"); 612 if (pmflags & PMf_GLOBAL) 613 sv_catpv(desc, ",GLOBAL"); 614 if (pmflags & PMf_CONTINUE) 615 sv_catpv(desc, ",CONTINUE"); 616 if (pmflags & PMf_RETAINT) 617 sv_catpv(desc, ",RETAINT"); 618 if (pmflags & PMf_EVAL) 619 sv_catpv(desc, ",EVAL"); 620 return desc; 621 } 622 623 void 624 Perl_pmop_dump(pTHX_ PMOP *pm) 625 { 626 do_pmop_dump(0, Perl_debug_log, pm); 627 } 628 629 /* An op sequencer. We visit the ops in the order they're to execute. */ 630 631 STATIC void 632 S_sequence(pTHX_ register const OP *o) 633 { 634 dVAR; 635 const OP *oldop = NULL; 636 637 if (!o) 638 return; 639 640 #ifdef PERL_MAD 641 if (o->op_next == 0) 642 return; 643 #endif 644 645 if (!Sequence) 646 Sequence = newHV(); 647 648 for (; o; o = o->op_next) { 649 STRLEN len; 650 SV * const op = newSVuv(PTR2UV(o)); 651 const char * const key = SvPV_const(op, len); 652 653 if (hv_exists(Sequence, key, len)) 654 break; 655 656 switch (o->op_type) { 657 case OP_STUB: 658 if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) { 659 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); 660 break; 661 } 662 goto nothin; 663 case OP_NULL: 664 #ifdef PERL_MAD 665 if (o == o->op_next) 666 return; 667 #endif 668 if (oldop && o->op_next) 669 continue; 670 break; 671 case OP_SCALAR: 672 case OP_LINESEQ: 673 case OP_SCOPE: 674 nothin: 675 if (oldop && o->op_next) 676 continue; 677 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); 678 break; 679 680 case OP_MAPWHILE: 681 case OP_GREPWHILE: 682 case OP_AND: 683 case OP_OR: 684 case OP_DOR: 685 case OP_ANDASSIGN: 686 case OP_ORASSIGN: 687 case OP_DORASSIGN: 688 case OP_COND_EXPR: 689 case OP_RANGE: 690 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); 691 sequence_tail(cLOGOPo->op_other); 692 break; 693 694 case OP_ENTERLOOP: 695 case OP_ENTERITER: 696 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); 697 sequence_tail(cLOOPo->op_redoop); 698 sequence_tail(cLOOPo->op_nextop); 699 sequence_tail(cLOOPo->op_lastop); 700 break; 701 702 case OP_SUBST: 703 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); 704 sequence_tail(cPMOPo->op_pmstashstartu.op_pmreplstart); 705 break; 706 707 case OP_QR: 708 case OP_MATCH: 709 case OP_HELEM: 710 break; 711 712 default: 713 (void)hv_store(Sequence, key, len, newSVuv(++PL_op_seq), 0); 714 break; 715 } 716 oldop = o; 717 } 718 } 719 720 static void 721 S_sequence_tail(pTHX_ const OP *o) 722 { 723 while (o && (o->op_type == OP_NULL)) 724 o = o->op_next; 725 sequence(o); 726 } 727 728 STATIC UV 729 S_sequence_num(pTHX_ const OP *o) 730 { 731 dVAR; 732 SV *op, 733 **seq; 734 const char *key; 735 STRLEN len; 736 if (!o) return 0; 737 op = newSVuv(PTR2UV(o)); 738 key = SvPV_const(op, len); 739 seq = hv_fetch(Sequence, key, len, 0); 740 return seq ? SvUV(*seq): 0; 741 } 742 743 void 744 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) 745 { 746 dVAR; 747 UV seq; 748 const OPCODE optype = o->op_type; 749 750 PERL_ARGS_ASSERT_DO_OP_DUMP; 751 752 sequence(o); 753 Perl_dump_indent(aTHX_ level, file, "{\n"); 754 level++; 755 seq = sequence_num(o); 756 if (seq) 757 PerlIO_printf(file, "%-4"UVuf, seq); 758 else 759 PerlIO_printf(file, " "); 760 PerlIO_printf(file, 761 "%*sTYPE = %s ===> ", 762 (int)(PL_dumpindent*level-4), "", OP_NAME(o)); 763 if (o->op_next) 764 PerlIO_printf(file, seq ? "%"UVuf"\n" : "(%"UVuf")\n", 765 sequence_num(o->op_next)); 766 else 767 PerlIO_printf(file, "DONE\n"); 768 if (o->op_targ) { 769 if (optype == OP_NULL) { 770 Perl_dump_indent(aTHX_ level, file, " (was %s)\n", PL_op_name[o->op_targ]); 771 if (o->op_targ == OP_NEXTSTATE) { 772 if (CopLINE(cCOPo)) 773 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n", 774 (UV)CopLINE(cCOPo)); 775 if (CopSTASHPV(cCOPo)) 776 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n", 777 CopSTASHPV(cCOPo)); 778 if (CopLABEL(cCOPo)) 779 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n", 780 CopLABEL(cCOPo)); 781 } 782 } 783 else 784 Perl_dump_indent(aTHX_ level, file, "TARG = %ld\n", (long)o->op_targ); 785 } 786 #ifdef DUMPADDR 787 Perl_dump_indent(aTHX_ level, file, "ADDR = 0x%"UVxf" => 0x%"UVxf"\n", (UV)o, (UV)o->op_next); 788 #endif 789 if (o->op_flags || o->op_latefree || o->op_latefreed || o->op_attached) { 790 SV * const tmpsv = newSVpvs(""); 791 switch (o->op_flags & OPf_WANT) { 792 case OPf_WANT_VOID: 793 sv_catpv(tmpsv, ",VOID"); 794 break; 795 case OPf_WANT_SCALAR: 796 sv_catpv(tmpsv, ",SCALAR"); 797 break; 798 case OPf_WANT_LIST: 799 sv_catpv(tmpsv, ",LIST"); 800 break; 801 default: 802 sv_catpv(tmpsv, ",UNKNOWN"); 803 break; 804 } 805 if (o->op_flags & OPf_KIDS) 806 sv_catpv(tmpsv, ",KIDS"); 807 if (o->op_flags & OPf_PARENS) 808 sv_catpv(tmpsv, ",PARENS"); 809 if (o->op_flags & OPf_STACKED) 810 sv_catpv(tmpsv, ",STACKED"); 811 if (o->op_flags & OPf_REF) 812 sv_catpv(tmpsv, ",REF"); 813 if (o->op_flags & OPf_MOD) 814 sv_catpv(tmpsv, ",MOD"); 815 if (o->op_flags & OPf_SPECIAL) 816 sv_catpv(tmpsv, ",SPECIAL"); 817 if (o->op_latefree) 818 sv_catpv(tmpsv, ",LATEFREE"); 819 if (o->op_latefreed) 820 sv_catpv(tmpsv, ",LATEFREED"); 821 if (o->op_attached) 822 sv_catpv(tmpsv, ",ATTACHED"); 823 Perl_dump_indent(aTHX_ level, file, "FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX_const(tmpsv) + 1 : ""); 824 SvREFCNT_dec(tmpsv); 825 } 826 if (o->op_private) { 827 SV * const tmpsv = newSVpvs(""); 828 if (PL_opargs[optype] & OA_TARGLEX) { 829 if (o->op_private & OPpTARGET_MY) 830 sv_catpv(tmpsv, ",TARGET_MY"); 831 } 832 else if (optype == OP_LEAVESUB || 833 optype == OP_LEAVE || 834 optype == OP_LEAVESUBLV || 835 optype == OP_LEAVEWRITE) { 836 if (o->op_private & OPpREFCOUNTED) 837 sv_catpv(tmpsv, ",REFCOUNTED"); 838 } 839 else if (optype == OP_AASSIGN) { 840 if (o->op_private & OPpASSIGN_COMMON) 841 sv_catpv(tmpsv, ",COMMON"); 842 } 843 else if (optype == OP_SASSIGN) { 844 if (o->op_private & OPpASSIGN_BACKWARDS) 845 sv_catpv(tmpsv, ",BACKWARDS"); 846 } 847 else if (optype == OP_TRANS) { 848 if (o->op_private & OPpTRANS_SQUASH) 849 sv_catpv(tmpsv, ",SQUASH"); 850 if (o->op_private & OPpTRANS_DELETE) 851 sv_catpv(tmpsv, ",DELETE"); 852 if (o->op_private & OPpTRANS_COMPLEMENT) 853 sv_catpv(tmpsv, ",COMPLEMENT"); 854 if (o->op_private & OPpTRANS_IDENTICAL) 855 sv_catpv(tmpsv, ",IDENTICAL"); 856 if (o->op_private & OPpTRANS_GROWS) 857 sv_catpv(tmpsv, ",GROWS"); 858 } 859 else if (optype == OP_REPEAT) { 860 if (o->op_private & OPpREPEAT_DOLIST) 861 sv_catpv(tmpsv, ",DOLIST"); 862 } 863 else if (optype == OP_ENTERSUB || 864 optype == OP_RV2SV || 865 optype == OP_GVSV || 866 optype == OP_RV2AV || 867 optype == OP_RV2HV || 868 optype == OP_RV2GV || 869 optype == OP_AELEM || 870 optype == OP_HELEM ) 871 { 872 if (optype == OP_ENTERSUB) { 873 if (o->op_private & OPpENTERSUB_AMPER) 874 sv_catpv(tmpsv, ",AMPER"); 875 if (o->op_private & OPpENTERSUB_DB) 876 sv_catpv(tmpsv, ",DB"); 877 if (o->op_private & OPpENTERSUB_HASTARG) 878 sv_catpv(tmpsv, ",HASTARG"); 879 if (o->op_private & OPpENTERSUB_NOPAREN) 880 sv_catpv(tmpsv, ",NOPAREN"); 881 if (o->op_private & OPpENTERSUB_INARGS) 882 sv_catpv(tmpsv, ",INARGS"); 883 if (o->op_private & OPpENTERSUB_NOMOD) 884 sv_catpv(tmpsv, ",NOMOD"); 885 } 886 else { 887 switch (o->op_private & OPpDEREF) { 888 case OPpDEREF_SV: 889 sv_catpv(tmpsv, ",SV"); 890 break; 891 case OPpDEREF_AV: 892 sv_catpv(tmpsv, ",AV"); 893 break; 894 case OPpDEREF_HV: 895 sv_catpv(tmpsv, ",HV"); 896 break; 897 } 898 if (o->op_private & OPpMAYBE_LVSUB) 899 sv_catpv(tmpsv, ",MAYBE_LVSUB"); 900 } 901 if (optype == OP_AELEM || optype == OP_HELEM) { 902 if (o->op_private & OPpLVAL_DEFER) 903 sv_catpv(tmpsv, ",LVAL_DEFER"); 904 } 905 else { 906 if (o->op_private & HINT_STRICT_REFS) 907 sv_catpv(tmpsv, ",STRICT_REFS"); 908 if (o->op_private & OPpOUR_INTRO) 909 sv_catpv(tmpsv, ",OUR_INTRO"); 910 } 911 } 912 else if (optype == OP_CONST) { 913 if (o->op_private & OPpCONST_BARE) 914 sv_catpv(tmpsv, ",BARE"); 915 if (o->op_private & OPpCONST_STRICT) 916 sv_catpv(tmpsv, ",STRICT"); 917 if (o->op_private & OPpCONST_ARYBASE) 918 sv_catpv(tmpsv, ",ARYBASE"); 919 if (o->op_private & OPpCONST_WARNING) 920 sv_catpv(tmpsv, ",WARNING"); 921 if (o->op_private & OPpCONST_ENTERED) 922 sv_catpv(tmpsv, ",ENTERED"); 923 } 924 else if (optype == OP_FLIP) { 925 if (o->op_private & OPpFLIP_LINENUM) 926 sv_catpv(tmpsv, ",LINENUM"); 927 } 928 else if (optype == OP_FLOP) { 929 if (o->op_private & OPpFLIP_LINENUM) 930 sv_catpv(tmpsv, ",LINENUM"); 931 } 932 else if (optype == OP_RV2CV) { 933 if (o->op_private & OPpLVAL_INTRO) 934 sv_catpv(tmpsv, ",INTRO"); 935 } 936 else if (optype == OP_GV) { 937 if (o->op_private & OPpEARLY_CV) 938 sv_catpv(tmpsv, ",EARLY_CV"); 939 } 940 else if (optype == OP_LIST) { 941 if (o->op_private & OPpLIST_GUESSED) 942 sv_catpv(tmpsv, ",GUESSED"); 943 } 944 else if (optype == OP_DELETE) { 945 if (o->op_private & OPpSLICE) 946 sv_catpv(tmpsv, ",SLICE"); 947 } 948 else if (optype == OP_EXISTS) { 949 if (o->op_private & OPpEXISTS_SUB) 950 sv_catpv(tmpsv, ",EXISTS_SUB"); 951 } 952 else if (optype == OP_SORT) { 953 if (o->op_private & OPpSORT_NUMERIC) 954 sv_catpv(tmpsv, ",NUMERIC"); 955 if (o->op_private & OPpSORT_INTEGER) 956 sv_catpv(tmpsv, ",INTEGER"); 957 if (o->op_private & OPpSORT_REVERSE) 958 sv_catpv(tmpsv, ",REVERSE"); 959 } 960 else if (optype == OP_OPEN || optype == OP_BACKTICK) { 961 if (o->op_private & OPpOPEN_IN_RAW) 962 sv_catpv(tmpsv, ",IN_RAW"); 963 if (o->op_private & OPpOPEN_IN_CRLF) 964 sv_catpv(tmpsv, ",IN_CRLF"); 965 if (o->op_private & OPpOPEN_OUT_RAW) 966 sv_catpv(tmpsv, ",OUT_RAW"); 967 if (o->op_private & OPpOPEN_OUT_CRLF) 968 sv_catpv(tmpsv, ",OUT_CRLF"); 969 } 970 else if (optype == OP_EXIT) { 971 if (o->op_private & OPpEXIT_VMSISH) 972 sv_catpv(tmpsv, ",EXIT_VMSISH"); 973 if (o->op_private & OPpHUSH_VMSISH) 974 sv_catpv(tmpsv, ",HUSH_VMSISH"); 975 } 976 else if (optype == OP_DIE) { 977 if (o->op_private & OPpHUSH_VMSISH) 978 sv_catpv(tmpsv, ",HUSH_VMSISH"); 979 } 980 else if (PL_check[optype] != MEMBER_TO_FPTR(Perl_ck_ftst)) { 981 if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS) 982 sv_catpv(tmpsv, ",FT_ACCESS"); 983 if (o->op_private & OPpFT_STACKED) 984 sv_catpv(tmpsv, ",FT_STACKED"); 985 } 986 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO) 987 sv_catpv(tmpsv, ",INTRO"); 988 if (SvCUR(tmpsv)) 989 Perl_dump_indent(aTHX_ level, file, "PRIVATE = (%s)\n", SvPVX_const(tmpsv) + 1); 990 SvREFCNT_dec(tmpsv); 991 } 992 993 #ifdef PERL_MAD 994 if (PL_madskills && o->op_madprop) { 995 SV * const tmpsv = newSVpvs(""); 996 MADPROP* mp = o->op_madprop; 997 Perl_dump_indent(aTHX_ level, file, "MADPROPS = {\n"); 998 level++; 999 while (mp) { 1000 const char tmp = mp->mad_key; 1001 sv_setpvs(tmpsv,"'"); 1002 if (tmp) 1003 sv_catpvn(tmpsv, &tmp, 1); 1004 sv_catpv(tmpsv, "'="); 1005 switch (mp->mad_type) { 1006 case MAD_NULL: 1007 sv_catpv(tmpsv, "NULL"); 1008 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv)); 1009 break; 1010 case MAD_PV: 1011 sv_catpv(tmpsv, "<"); 1012 sv_catpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen); 1013 sv_catpv(tmpsv, ">"); 1014 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv)); 1015 break; 1016 case MAD_OP: 1017 if ((OP*)mp->mad_val) { 1018 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv)); 1019 do_op_dump(level, file, (OP*)mp->mad_val); 1020 } 1021 break; 1022 default: 1023 sv_catpv(tmpsv, "(UNK)"); 1024 Perl_dump_indent(aTHX_ level, file, "%s\n", SvPVX(tmpsv)); 1025 break; 1026 } 1027 mp = mp->mad_next; 1028 } 1029 level--; 1030 Perl_dump_indent(aTHX_ level, file, "}\n"); 1031 1032 SvREFCNT_dec(tmpsv); 1033 } 1034 #endif 1035 1036 switch (optype) { 1037 case OP_AELEMFAST: 1038 case OP_GVSV: 1039 case OP_GV: 1040 #ifdef USE_ITHREADS 1041 Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix); 1042 #else 1043 if ( ! (o->op_flags & OPf_SPECIAL)) { /* not lexical */ 1044 if (cSVOPo->op_sv) { 1045 SV * const tmpsv = newSV(0); 1046 ENTER; 1047 SAVEFREESV(tmpsv); 1048 #ifdef PERL_MAD 1049 /* FIXME - is this making unwarranted assumptions about the 1050 UTF-8 cleanliness of the dump file handle? */ 1051 SvUTF8_on(tmpsv); 1052 #endif 1053 gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL); 1054 Perl_dump_indent(aTHX_ level, file, "GV = %s\n", 1055 SvPV_nolen_const(tmpsv)); 1056 LEAVE; 1057 } 1058 else 1059 Perl_dump_indent(aTHX_ level, file, "GV = NULL\n"); 1060 } 1061 #endif 1062 break; 1063 case OP_CONST: 1064 case OP_METHOD_NAMED: 1065 #ifndef USE_ITHREADS 1066 /* with ITHREADS, consts are stored in the pad, and the right pad 1067 * may not be active here, so skip */ 1068 Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv)); 1069 #endif 1070 break; 1071 case OP_SETSTATE: 1072 case OP_NEXTSTATE: 1073 case OP_DBSTATE: 1074 if (CopLINE(cCOPo)) 1075 Perl_dump_indent(aTHX_ level, file, "LINE = %"UVuf"\n", 1076 (UV)CopLINE(cCOPo)); 1077 if (CopSTASHPV(cCOPo)) 1078 Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n", 1079 CopSTASHPV(cCOPo)); 1080 if (CopLABEL(cCOPo)) 1081 Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n", 1082 CopLABEL(cCOPo)); 1083 break; 1084 case OP_ENTERLOOP: 1085 Perl_dump_indent(aTHX_ level, file, "REDO ===> "); 1086 if (cLOOPo->op_redoop) 1087 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_redoop)); 1088 else 1089 PerlIO_printf(file, "DONE\n"); 1090 Perl_dump_indent(aTHX_ level, file, "NEXT ===> "); 1091 if (cLOOPo->op_nextop) 1092 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_nextop)); 1093 else 1094 PerlIO_printf(file, "DONE\n"); 1095 Perl_dump_indent(aTHX_ level, file, "LAST ===> "); 1096 if (cLOOPo->op_lastop) 1097 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOOPo->op_lastop)); 1098 else 1099 PerlIO_printf(file, "DONE\n"); 1100 break; 1101 case OP_COND_EXPR: 1102 case OP_RANGE: 1103 case OP_MAPWHILE: 1104 case OP_GREPWHILE: 1105 case OP_OR: 1106 case OP_AND: 1107 Perl_dump_indent(aTHX_ level, file, "OTHER ===> "); 1108 if (cLOGOPo->op_other) 1109 PerlIO_printf(file, "%"UVuf"\n", sequence_num(cLOGOPo->op_other)); 1110 else 1111 PerlIO_printf(file, "DONE\n"); 1112 break; 1113 case OP_PUSHRE: 1114 case OP_MATCH: 1115 case OP_QR: 1116 case OP_SUBST: 1117 do_pmop_dump(level, file, cPMOPo); 1118 break; 1119 case OP_LEAVE: 1120 case OP_LEAVEEVAL: 1121 case OP_LEAVESUB: 1122 case OP_LEAVESUBLV: 1123 case OP_LEAVEWRITE: 1124 case OP_SCOPE: 1125 if (o->op_private & OPpREFCOUNTED) 1126 Perl_dump_indent(aTHX_ level, file, "REFCNT = %"UVuf"\n", (UV)o->op_targ); 1127 break; 1128 default: 1129 break; 1130 } 1131 if (o->op_flags & OPf_KIDS) { 1132 OP *kid; 1133 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) 1134 do_op_dump(level, file, kid); 1135 } 1136 Perl_dump_indent(aTHX_ level-1, file, "}\n"); 1137 } 1138 1139 void 1140 Perl_op_dump(pTHX_ const OP *o) 1141 { 1142 PERL_ARGS_ASSERT_OP_DUMP; 1143 do_op_dump(0, Perl_debug_log, o); 1144 } 1145 1146 void 1147 Perl_gv_dump(pTHX_ GV *gv) 1148 { 1149 SV *sv; 1150 1151 PERL_ARGS_ASSERT_GV_DUMP; 1152 1153 if (!gv) { 1154 PerlIO_printf(Perl_debug_log, "{}\n"); 1155 return; 1156 } 1157 sv = sv_newmortal(); 1158 PerlIO_printf(Perl_debug_log, "{\n"); 1159 gv_fullname3(sv, gv, NULL); 1160 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "GV_NAME = %s", SvPVX_const(sv)); 1161 if (gv != GvEGV(gv)) { 1162 gv_efullname3(sv, GvEGV(gv), NULL); 1163 Perl_dump_indent(aTHX_ 1, Perl_debug_log, "-> %s", SvPVX_const(sv)); 1164 } 1165 PerlIO_putc(Perl_debug_log, '\n'); 1166 Perl_dump_indent(aTHX_ 0, Perl_debug_log, "}\n"); 1167 } 1168 1169 1170 /* map magic types to the symbolic names 1171 * (with the PERL_MAGIC_ prefixed stripped) 1172 */ 1173 1174 static const struct { const char type; const char *name; } magic_names[] = { 1175 { PERL_MAGIC_sv, "sv(\\0)" }, 1176 { PERL_MAGIC_arylen, "arylen(#)" }, 1177 { PERL_MAGIC_rhash, "rhash(%)" }, 1178 { PERL_MAGIC_pos, "pos(.)" }, 1179 { PERL_MAGIC_symtab, "symtab(:)" }, 1180 { PERL_MAGIC_backref, "backref(<)" }, 1181 { PERL_MAGIC_arylen_p, "arylen_p(@)" }, 1182 { PERL_MAGIC_overload, "overload(A)" }, 1183 { PERL_MAGIC_bm, "bm(B)" }, 1184 { PERL_MAGIC_regdata, "regdata(D)" }, 1185 { PERL_MAGIC_env, "env(E)" }, 1186 { PERL_MAGIC_hints, "hints(H)" }, 1187 { PERL_MAGIC_isa, "isa(I)" }, 1188 { PERL_MAGIC_dbfile, "dbfile(L)" }, 1189 { PERL_MAGIC_shared, "shared(N)" }, 1190 { PERL_MAGIC_tied, "tied(P)" }, 1191 { PERL_MAGIC_sig, "sig(S)" }, 1192 { PERL_MAGIC_uvar, "uvar(U)" }, 1193 { PERL_MAGIC_overload_elem, "overload_elem(a)" }, 1194 { PERL_MAGIC_overload_table, "overload_table(c)" }, 1195 { PERL_MAGIC_regdatum, "regdatum(d)" }, 1196 { PERL_MAGIC_envelem, "envelem(e)" }, 1197 { PERL_MAGIC_fm, "fm(f)" }, 1198 { PERL_MAGIC_regex_global, "regex_global(g)" }, 1199 { PERL_MAGIC_hintselem, "hintselem(h)" }, 1200 { PERL_MAGIC_isaelem, "isaelem(i)" }, 1201 { PERL_MAGIC_nkeys, "nkeys(k)" }, 1202 { PERL_MAGIC_dbline, "dbline(l)" }, 1203 { PERL_MAGIC_shared_scalar, "shared_scalar(n)" }, 1204 { PERL_MAGIC_collxfrm, "collxfrm(o)" }, 1205 { PERL_MAGIC_tiedelem, "tiedelem(p)" }, 1206 { PERL_MAGIC_tiedscalar, "tiedscalar(q)" }, 1207 { PERL_MAGIC_qr, "qr(r)" }, 1208 { PERL_MAGIC_sigelem, "sigelem(s)" }, 1209 { PERL_MAGIC_taint, "taint(t)" }, 1210 { PERL_MAGIC_uvar_elem, "uvar_elem(u)" }, 1211 { PERL_MAGIC_vec, "vec(v)" }, 1212 { PERL_MAGIC_vstring, "vstring(V)" }, 1213 { PERL_MAGIC_utf8, "utf8(w)" }, 1214 { PERL_MAGIC_substr, "substr(x)" }, 1215 { PERL_MAGIC_defelem, "defelem(y)" }, 1216 { PERL_MAGIC_ext, "ext(~)" }, 1217 /* this null string terminates the list */ 1218 { 0, NULL }, 1219 }; 1220 1221 void 1222 Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim) 1223 { 1224 PERL_ARGS_ASSERT_DO_MAGIC_DUMP; 1225 1226 for (; mg; mg = mg->mg_moremagic) { 1227 Perl_dump_indent(aTHX_ level, file, 1228 " MAGIC = 0x%"UVxf"\n", PTR2UV(mg)); 1229 if (mg->mg_virtual) { 1230 const MGVTBL * const v = mg->mg_virtual; 1231 const char *s; 1232 if (v == &PL_vtbl_sv) s = "sv"; 1233 else if (v == &PL_vtbl_env) s = "env"; 1234 else if (v == &PL_vtbl_envelem) s = "envelem"; 1235 else if (v == &PL_vtbl_sig) s = "sig"; 1236 else if (v == &PL_vtbl_sigelem) s = "sigelem"; 1237 else if (v == &PL_vtbl_pack) s = "pack"; 1238 else if (v == &PL_vtbl_packelem) s = "packelem"; 1239 else if (v == &PL_vtbl_dbline) s = "dbline"; 1240 else if (v == &PL_vtbl_isa) s = "isa"; 1241 else if (v == &PL_vtbl_arylen) s = "arylen"; 1242 else if (v == &PL_vtbl_mglob) s = "mglob"; 1243 else if (v == &PL_vtbl_nkeys) s = "nkeys"; 1244 else if (v == &PL_vtbl_taint) s = "taint"; 1245 else if (v == &PL_vtbl_substr) s = "substr"; 1246 else if (v == &PL_vtbl_vec) s = "vec"; 1247 else if (v == &PL_vtbl_pos) s = "pos"; 1248 else if (v == &PL_vtbl_bm) s = "bm"; 1249 else if (v == &PL_vtbl_fm) s = "fm"; 1250 else if (v == &PL_vtbl_uvar) s = "uvar"; 1251 else if (v == &PL_vtbl_defelem) s = "defelem"; 1252 #ifdef USE_LOCALE_COLLATE 1253 else if (v == &PL_vtbl_collxfrm) s = "collxfrm"; 1254 #endif 1255 else if (v == &PL_vtbl_amagic) s = "amagic"; 1256 else if (v == &PL_vtbl_amagicelem) s = "amagicelem"; 1257 else if (v == &PL_vtbl_backref) s = "backref"; 1258 else if (v == &PL_vtbl_utf8) s = "utf8"; 1259 else if (v == &PL_vtbl_arylen_p) s = "arylen_p"; 1260 else if (v == &PL_vtbl_hintselem) s = "hintselem"; 1261 else s = NULL; 1262 if (s) 1263 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s); 1264 else 1265 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0x%"UVxf"\n", PTR2UV(v)); 1266 } 1267 else 1268 Perl_dump_indent(aTHX_ level, file, " MG_VIRTUAL = 0\n"); 1269 1270 if (mg->mg_private) 1271 Perl_dump_indent(aTHX_ level, file, " MG_PRIVATE = %d\n", mg->mg_private); 1272 1273 { 1274 int n; 1275 const char *name = NULL; 1276 for (n = 0; magic_names[n].name; n++) { 1277 if (mg->mg_type == magic_names[n].type) { 1278 name = magic_names[n].name; 1279 break; 1280 } 1281 } 1282 if (name) 1283 Perl_dump_indent(aTHX_ level, file, 1284 " MG_TYPE = PERL_MAGIC_%s\n", name); 1285 else 1286 Perl_dump_indent(aTHX_ level, file, 1287 " MG_TYPE = UNKNOWN(\\%o)\n", mg->mg_type); 1288 } 1289 1290 if (mg->mg_flags) { 1291 Perl_dump_indent(aTHX_ level, file, " MG_FLAGS = 0x%02X\n", mg->mg_flags); 1292 if (mg->mg_type == PERL_MAGIC_envelem && 1293 mg->mg_flags & MGf_TAINTEDDIR) 1294 Perl_dump_indent(aTHX_ level, file, " TAINTEDDIR\n"); 1295 if (mg->mg_flags & MGf_REFCOUNTED) 1296 Perl_dump_indent(aTHX_ level, file, " REFCOUNTED\n"); 1297 if (mg->mg_flags & MGf_GSKIP) 1298 Perl_dump_indent(aTHX_ level, file, " GSKIP\n"); 1299 if (mg->mg_type == PERL_MAGIC_regex_global && 1300 mg->mg_flags & MGf_MINMATCH) 1301 Perl_dump_indent(aTHX_ level, file, " MINMATCH\n"); 1302 } 1303 if (mg->mg_obj) { 1304 Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n", 1305 PTR2UV(mg->mg_obj)); 1306 if (mg->mg_type == PERL_MAGIC_qr) { 1307 REGEXP* const re = (REGEXP *)mg->mg_obj; 1308 SV * const dsv = sv_newmortal(); 1309 const char * const s 1310 = pv_pretty(dsv, RX_WRAPPED(re), RX_WRAPLEN(re), 1311 60, NULL, NULL, 1312 ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE | PERL_PV_PRETTY_ELLIPSES | 1313 (RX_UTF8(re) ? PERL_PV_ESCAPE_UNI : 0)) 1314 ); 1315 Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s); 1316 Perl_dump_indent(aTHX_ level+1, file, " REFCNT = %"IVdf"\n", 1317 (IV)RX_REFCNT(re)); 1318 } 1319 if (mg->mg_flags & MGf_REFCOUNTED) 1320 do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops, pvlim); /* MG is already +1 */ 1321 } 1322 if (mg->mg_len) 1323 Perl_dump_indent(aTHX_ level, file, " MG_LEN = %ld\n", (long)mg->mg_len); 1324 if (mg->mg_ptr) { 1325 Perl_dump_indent(aTHX_ level, file, " MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr)); 1326 if (mg->mg_len >= 0) { 1327 if (mg->mg_type != PERL_MAGIC_utf8) { 1328 SV * const sv = newSVpvs(""); 1329 PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim)); 1330 SvREFCNT_dec(sv); 1331 } 1332 } 1333 else if (mg->mg_len == HEf_SVKEY) { 1334 PerlIO_puts(file, " => HEf_SVKEY\n"); 1335 do_sv_dump(level+2, file, MUTABLE_SV(((mg)->mg_ptr)), nest+1, 1336 maxnest, dumpops, pvlim); /* MG is already +1 */ 1337 continue; 1338 } 1339 else 1340 PerlIO_puts(file, " ???? - please notify IZ"); 1341 PerlIO_putc(file, '\n'); 1342 } 1343 if (mg->mg_type == PERL_MAGIC_utf8) { 1344 const STRLEN * const cache = (STRLEN *) mg->mg_ptr; 1345 if (cache) { 1346 IV i; 1347 for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++) 1348 Perl_dump_indent(aTHX_ level, file, 1349 " %2"IVdf": %"UVuf" -> %"UVuf"\n", 1350 i, 1351 (UV)cache[i * 2], 1352 (UV)cache[i * 2 + 1]); 1353 } 1354 } 1355 } 1356 } 1357 1358 void 1359 Perl_magic_dump(pTHX_ const MAGIC *mg) 1360 { 1361 do_magic_dump(0, Perl_debug_log, mg, 0, 0, FALSE, 0); 1362 } 1363 1364 void 1365 Perl_do_hv_dump(pTHX_ I32 level, PerlIO *file, const char *name, HV *sv) 1366 { 1367 const char *hvname; 1368 1369 PERL_ARGS_ASSERT_DO_HV_DUMP; 1370 1371 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv)); 1372 if (sv && (hvname = HvNAME_get(sv))) 1373 PerlIO_printf(file, "\t\"%s\"\n", hvname); 1374 else 1375 PerlIO_putc(file, '\n'); 1376 } 1377 1378 void 1379 Perl_do_gv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv) 1380 { 1381 PERL_ARGS_ASSERT_DO_GV_DUMP; 1382 1383 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv)); 1384 if (sv && GvNAME(sv)) 1385 PerlIO_printf(file, "\t\"%s\"\n", GvNAME(sv)); 1386 else 1387 PerlIO_putc(file, '\n'); 1388 } 1389 1390 void 1391 Perl_do_gvgv_dump(pTHX_ I32 level, PerlIO *file, const char *name, GV *sv) 1392 { 1393 PERL_ARGS_ASSERT_DO_GVGV_DUMP; 1394 1395 Perl_dump_indent(aTHX_ level, file, "%s = 0x%"UVxf, name, PTR2UV(sv)); 1396 if (sv && GvNAME(sv)) { 1397 const char *hvname; 1398 PerlIO_printf(file, "\t\""); 1399 if (GvSTASH(sv) && (hvname = HvNAME_get(GvSTASH(sv)))) 1400 PerlIO_printf(file, "%s\" :: \"", hvname); 1401 PerlIO_printf(file, "%s\"\n", GvNAME(sv)); 1402 } 1403 else 1404 PerlIO_putc(file, '\n'); 1405 } 1406 1407 void 1408 Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim) 1409 { 1410 dVAR; 1411 SV *d; 1412 const char *s; 1413 U32 flags; 1414 U32 type; 1415 1416 PERL_ARGS_ASSERT_DO_SV_DUMP; 1417 1418 if (!sv) { 1419 Perl_dump_indent(aTHX_ level, file, "SV = 0\n"); 1420 return; 1421 } 1422 1423 flags = SvFLAGS(sv); 1424 type = SvTYPE(sv); 1425 1426 d = Perl_newSVpvf(aTHX_ 1427 "(0x%"UVxf") at 0x%"UVxf"\n%*s REFCNT = %"IVdf"\n%*s FLAGS = (", 1428 PTR2UV(SvANY(sv)), PTR2UV(sv), 1429 (int)(PL_dumpindent*level), "", (IV)SvREFCNT(sv), 1430 (int)(PL_dumpindent*level), ""); 1431 1432 if (!(flags & SVpad_NAME && (type == SVt_PVMG || type == SVt_PVNV))) { 1433 if (flags & SVs_PADSTALE) sv_catpv(d, "PADSTALE,"); 1434 } 1435 if (!(flags & SVpad_NAME && type == SVt_PVMG)) { 1436 if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,"); 1437 if (flags & SVs_PADMY) sv_catpv(d, "PADMY,"); 1438 } 1439 if (flags & SVs_TEMP) sv_catpv(d, "TEMP,"); 1440 if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,"); 1441 if (flags & SVs_GMG) sv_catpv(d, "GMG,"); 1442 if (flags & SVs_SMG) sv_catpv(d, "SMG,"); 1443 if (flags & SVs_RMG) sv_catpv(d, "RMG,"); 1444 1445 if (flags & SVf_IOK) sv_catpv(d, "IOK,"); 1446 if (flags & SVf_NOK) sv_catpv(d, "NOK,"); 1447 if (flags & SVf_POK) sv_catpv(d, "POK,"); 1448 if (flags & SVf_ROK) { 1449 sv_catpv(d, "ROK,"); 1450 if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,"); 1451 } 1452 if (flags & SVf_OOK) sv_catpv(d, "OOK,"); 1453 if (flags & SVf_FAKE) sv_catpv(d, "FAKE,"); 1454 if (flags & SVf_READONLY) sv_catpv(d, "READONLY,"); 1455 if (flags & SVf_BREAK) sv_catpv(d, "BREAK,"); 1456 1457 if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,"); 1458 if (flags & SVp_IOK) sv_catpv(d, "pIOK,"); 1459 if (flags & SVp_NOK) sv_catpv(d, "pNOK,"); 1460 if (flags & SVp_POK) sv_catpv(d, "pPOK,"); 1461 if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) { 1462 if (SvPCS_IMPORTED(sv)) 1463 sv_catpv(d, "PCS_IMPORTED,"); 1464 else 1465 sv_catpv(d, "SCREAM,"); 1466 } 1467 1468 switch (type) { 1469 case SVt_PVCV: 1470 case SVt_PVFM: 1471 if (CvANON(sv)) sv_catpv(d, "ANON,"); 1472 if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,"); 1473 if (CvCLONE(sv)) sv_catpv(d, "CLONE,"); 1474 if (CvCLONED(sv)) sv_catpv(d, "CLONED,"); 1475 if (CvCONST(sv)) sv_catpv(d, "CONST,"); 1476 if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,"); 1477 if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,"); 1478 if (CvLVALUE(sv)) sv_catpv(d, "LVALUE,"); 1479 if (CvMETHOD(sv)) sv_catpv(d, "METHOD,"); 1480 if (CvLOCKED(sv)) sv_catpv(d, "LOCKED,"); 1481 if (CvWEAKOUTSIDE(sv)) sv_catpv(d, "WEAKOUTSIDE,"); 1482 break; 1483 case SVt_PVHV: 1484 if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,"); 1485 if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,"); 1486 if (HvHASKFLAGS(sv)) sv_catpv(d, "HASKFLAGS,"); 1487 if (HvREHASH(sv)) sv_catpv(d, "REHASH,"); 1488 if (flags & SVphv_CLONEABLE) sv_catpv(d, "CLONEABLE,"); 1489 break; 1490 case SVt_PVGV: 1491 case SVt_PVLV: 1492 if (isGV_with_GP(sv)) { 1493 if (GvINTRO(sv)) sv_catpv(d, "INTRO,"); 1494 if (GvMULTI(sv)) sv_catpv(d, "MULTI,"); 1495 if (GvUNIQUE(sv)) sv_catpv(d, "UNIQUE,"); 1496 if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,"); 1497 if (GvIN_PAD(sv)) sv_catpv(d, "IN_PAD,"); 1498 } 1499 if (isGV_with_GP(sv) && GvIMPORTED(sv)) { 1500 sv_catpv(d, "IMPORT"); 1501 if (GvIMPORTED(sv) == GVf_IMPORTED) 1502 sv_catpv(d, "ALL,"); 1503 else { 1504 sv_catpv(d, "("); 1505 if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV"); 1506 if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV"); 1507 if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV"); 1508 if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV"); 1509 sv_catpv(d, " ),"); 1510 } 1511 } 1512 if (SvTAIL(sv)) sv_catpv(d, "TAIL,"); 1513 if (SvVALID(sv)) sv_catpv(d, "VALID,"); 1514 /* FALL THROUGH */ 1515 default: 1516 evaled_or_uv: 1517 if (SvEVALED(sv)) sv_catpv(d, "EVALED,"); 1518 if (SvIsUV(sv) && !(flags & SVf_ROK)) sv_catpv(d, "IsUV,"); 1519 break; 1520 case SVt_PVMG: 1521 if (SvPAD_TYPED(sv)) sv_catpv(d, "TYPED,"); 1522 if (SvPAD_OUR(sv)) sv_catpv(d, "OUR,"); 1523 /* FALL THROUGH */ 1524 case SVt_PVNV: 1525 if (SvPAD_STATE(sv)) sv_catpv(d, "STATE,"); 1526 goto evaled_or_uv; 1527 case SVt_PVAV: 1528 break; 1529 } 1530 /* SVphv_SHAREKEYS is also 0x20000000 */ 1531 if ((type != SVt_PVHV) && SvUTF8(sv)) 1532 sv_catpv(d, "UTF8"); 1533 1534 if (*(SvEND(d) - 1) == ',') { 1535 SvCUR_set(d, SvCUR(d) - 1); 1536 SvPVX(d)[SvCUR(d)] = '\0'; 1537 } 1538 sv_catpv(d, ")"); 1539 s = SvPVX_const(d); 1540 1541 #ifdef DEBUG_LEAKING_SCALARS 1542 Perl_dump_indent(aTHX_ level, file, "ALLOCATED at %s:%d %s %s%s\n", 1543 sv->sv_debug_file ? sv->sv_debug_file : "(unknown)", 1544 sv->sv_debug_line, 1545 sv->sv_debug_inpad ? "for" : "by", 1546 sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)", 1547 sv->sv_debug_cloned ? " (cloned)" : ""); 1548 #endif 1549 Perl_dump_indent(aTHX_ level, file, "SV = "); 1550 if (type < SVt_LAST) { 1551 PerlIO_printf(file, "%s%s\n", svtypenames[type], s); 1552 1553 if (type == SVt_NULL) { 1554 SvREFCNT_dec(d); 1555 return; 1556 } 1557 } else { 1558 PerlIO_printf(file, "UNKNOWN(0x%"UVxf") %s\n", (UV)type, s); 1559 SvREFCNT_dec(d); 1560 return; 1561 } 1562 if ((type >= SVt_PVIV && type != SVt_PVAV && type != SVt_PVHV 1563 && type != SVt_PVCV && !isGV_with_GP(sv)) 1564 || type == SVt_IV) { 1565 if (SvIsUV(sv) 1566 #ifdef PERL_OLD_COPY_ON_WRITE 1567 || SvIsCOW(sv) 1568 #endif 1569 ) 1570 Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv)); 1571 else 1572 Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv)); 1573 if (SvOOK(sv)) 1574 PerlIO_printf(file, " (OFFSET)"); 1575 #ifdef PERL_OLD_COPY_ON_WRITE 1576 if (SvIsCOW_shared_hash(sv)) 1577 PerlIO_printf(file, " (HASH)"); 1578 else if (SvIsCOW_normal(sv)) 1579 PerlIO_printf(file, " (COW from 0x%"UVxf")", (UV)SvUVX(sv)); 1580 #endif 1581 PerlIO_putc(file, '\n'); 1582 } 1583 if ((type == SVt_PVNV || type == SVt_PVMG) && SvFLAGS(sv) & SVpad_NAME) { 1584 Perl_dump_indent(aTHX_ level, file, " COP_LOW = %"UVuf"\n", 1585 (UV) COP_SEQ_RANGE_LOW(sv)); 1586 Perl_dump_indent(aTHX_ level, file, " COP_HIGH = %"UVuf"\n", 1587 (UV) COP_SEQ_RANGE_HIGH(sv)); 1588 } else if ((type >= SVt_PVNV && type != SVt_PVAV && type != SVt_PVHV 1589 && type != SVt_PVCV && type != SVt_PVFM && !isGV_with_GP(sv) 1590 && !SvVALID(sv)) 1591 || type == SVt_NV) { 1592 STORE_NUMERIC_LOCAL_SET_STANDARD(); 1593 /* %Vg doesn't work? --jhi */ 1594 #ifdef USE_LONG_DOUBLE 1595 Perl_dump_indent(aTHX_ level, file, " NV = %.*" PERL_PRIgldbl "\n", LDBL_DIG, SvNVX(sv)); 1596 #else 1597 Perl_dump_indent(aTHX_ level, file, " NV = %.*g\n", DBL_DIG, SvNVX(sv)); 1598 #endif 1599 RESTORE_NUMERIC_LOCAL(); 1600 } 1601 if (SvROK(sv)) { 1602 Perl_dump_indent(aTHX_ level, file, " RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv))); 1603 if (nest < maxnest) 1604 do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim); 1605 } 1606 if (type < SVt_PV) { 1607 SvREFCNT_dec(d); 1608 return; 1609 } 1610 if ((type <= SVt_PVLV && !isGV_with_GP(sv)) || type == SVt_PVFM) { 1611 if (SvPVX_const(sv)) { 1612 Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv))); 1613 if (SvOOK(sv)) 1614 PerlIO_printf(file, "( %s . ) ", pv_display(d, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, pvlim)); 1615 PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim)); 1616 if (SvUTF8(sv)) /* the 6? \x{....} */ 1617 PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ)); 1618 PerlIO_printf(file, "\n"); 1619 Perl_dump_indent(aTHX_ level, file, " CUR = %"IVdf"\n", (IV)SvCUR(sv)); 1620 Perl_dump_indent(aTHX_ level, file, " LEN = %"IVdf"\n", (IV)SvLEN(sv)); 1621 } 1622 else 1623 Perl_dump_indent(aTHX_ level, file, " PV = 0\n"); 1624 } 1625 if (type >= SVt_PVMG) { 1626 if (type == SVt_PVMG && SvPAD_OUR(sv)) { 1627 HV * const ost = SvOURSTASH(sv); 1628 if (ost) 1629 do_hv_dump(level, file, " OURSTASH", ost); 1630 } else { 1631 if (SvMAGIC(sv)) 1632 do_magic_dump(level, file, SvMAGIC(sv), nest, maxnest, dumpops, pvlim); 1633 } 1634 if (SvSTASH(sv)) 1635 do_hv_dump(level, file, " STASH", SvSTASH(sv)); 1636 } 1637 switch (type) { 1638 case SVt_PVAV: 1639 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv))); 1640 if (AvARRAY(sv) != AvALLOC(sv)) { 1641 PerlIO_printf(file, " (offset=%"IVdf")\n", (IV)(AvARRAY(sv) - AvALLOC(sv))); 1642 Perl_dump_indent(aTHX_ level, file, " ALLOC = 0x%"UVxf"\n", PTR2UV(AvALLOC(sv))); 1643 } 1644 else 1645 PerlIO_putc(file, '\n'); 1646 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)AvFILLp(sv)); 1647 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)AvMAX(sv)); 1648 Perl_dump_indent(aTHX_ level, file, " ARYLEN = 0x%"UVxf"\n", SvMAGIC(sv) ? PTR2UV(AvARYLEN(sv)) : 0); 1649 sv_setpvs(d, ""); 1650 if (AvREAL(sv)) sv_catpv(d, ",REAL"); 1651 if (AvREIFY(sv)) sv_catpv(d, ",REIFY"); 1652 Perl_dump_indent(aTHX_ level, file, " FLAGS = (%s)\n", 1653 SvCUR(d) ? SvPVX_const(d) + 1 : ""); 1654 if (nest < maxnest && av_len(MUTABLE_AV(sv)) >= 0) { 1655 int count; 1656 for (count = 0; count <= av_len(MUTABLE_AV(sv)) && count < maxnest; count++) { 1657 SV** const elt = av_fetch(MUTABLE_AV(sv),count,0); 1658 1659 Perl_dump_indent(aTHX_ level + 1, file, "Elt No. %"IVdf"\n", (IV)count); 1660 if (elt) 1661 do_sv_dump(level+1, file, *elt, nest+1, maxnest, dumpops, pvlim); 1662 } 1663 } 1664 break; 1665 case SVt_PVHV: 1666 Perl_dump_indent(aTHX_ level, file, " ARRAY = 0x%"UVxf, PTR2UV(HvARRAY(sv))); 1667 if (HvARRAY(sv) && HvKEYS(sv)) { 1668 /* Show distribution of HEs in the ARRAY */ 1669 int freq[200]; 1670 #define FREQ_MAX ((int)(sizeof freq / sizeof freq[0] - 1)) 1671 int i; 1672 int max = 0; 1673 U32 pow2 = 2, keys = HvKEYS(sv); 1674 NV theoret, sum = 0; 1675 1676 PerlIO_printf(file, " ("); 1677 Zero(freq, FREQ_MAX + 1, int); 1678 for (i = 0; (STRLEN)i <= HvMAX(sv); i++) { 1679 HE* h; 1680 int count = 0; 1681 for (h = HvARRAY(sv)[i]; h; h = HeNEXT(h)) 1682 count++; 1683 if (count > FREQ_MAX) 1684 count = FREQ_MAX; 1685 freq[count]++; 1686 if (max < count) 1687 max = count; 1688 } 1689 for (i = 0; i <= max; i++) { 1690 if (freq[i]) { 1691 PerlIO_printf(file, "%d%s:%d", i, 1692 (i == FREQ_MAX) ? "+" : "", 1693 freq[i]); 1694 if (i != max) 1695 PerlIO_printf(file, ", "); 1696 } 1697 } 1698 PerlIO_putc(file, ')'); 1699 /* The "quality" of a hash is defined as the total number of 1700 comparisons needed to access every element once, relative 1701 to the expected number needed for a random hash. 1702 1703 The total number of comparisons is equal to the sum of 1704 the squares of the number of entries in each bucket. 1705 For a random hash of n keys into k buckets, the expected 1706 value is 1707 n + n(n-1)/2k 1708 */ 1709 1710 for (i = max; i > 0; i--) { /* Precision: count down. */ 1711 sum += freq[i] * i * i; 1712 } 1713 while ((keys = keys >> 1)) 1714 pow2 = pow2 << 1; 1715 theoret = HvKEYS(sv); 1716 theoret += theoret * (theoret-1)/pow2; 1717 PerlIO_putc(file, '\n'); 1718 Perl_dump_indent(aTHX_ level, file, " hash quality = %.1"NVff"%%", theoret/sum*100); 1719 } 1720 PerlIO_putc(file, '\n'); 1721 Perl_dump_indent(aTHX_ level, file, " KEYS = %"IVdf"\n", (IV)HvKEYS(sv)); 1722 Perl_dump_indent(aTHX_ level, file, " FILL = %"IVdf"\n", (IV)HvFILL(sv)); 1723 Perl_dump_indent(aTHX_ level, file, " MAX = %"IVdf"\n", (IV)HvMAX(sv)); 1724 Perl_dump_indent(aTHX_ level, file, " RITER = %"IVdf"\n", (IV)HvRITER_get(sv)); 1725 Perl_dump_indent(aTHX_ level, file, " EITER = 0x%"UVxf"\n", PTR2UV(HvEITER_get(sv))); 1726 { 1727 MAGIC * const mg = mg_find(sv, PERL_MAGIC_symtab); 1728 if (mg && mg->mg_obj) { 1729 Perl_dump_indent(aTHX_ level, file, " PMROOT = 0x%"UVxf"\n", PTR2UV(mg->mg_obj)); 1730 } 1731 } 1732 { 1733 const char * const hvname = HvNAME_get(sv); 1734 if (hvname) 1735 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", hvname); 1736 } 1737 if (SvOOK(sv)) { 1738 AV * const backrefs 1739 = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(sv)); 1740 if (backrefs) { 1741 Perl_dump_indent(aTHX_ level, file, " BACKREFS = 0x%"UVxf"\n", 1742 PTR2UV(backrefs)); 1743 do_sv_dump(level+1, file, MUTABLE_SV(backrefs), nest+1, maxnest, 1744 dumpops, pvlim); 1745 } 1746 } 1747 if (nest < maxnest && !HvEITER_get(sv)) { /* Try to preserve iterator */ 1748 HE *he; 1749 HV * const hv = MUTABLE_HV(sv); 1750 int count = maxnest - nest; 1751 1752 hv_iterinit(hv); 1753 while ((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS)) 1754 && count--) { 1755 STRLEN len; 1756 const U32 hash = HeHASH(he); 1757 SV * const keysv = hv_iterkeysv(he); 1758 const char * const keypv = SvPV_const(keysv, len); 1759 SV * const elt = hv_iterval(hv, he); 1760 1761 Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim)); 1762 if (SvUTF8(keysv)) 1763 PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 6 * SvCUR(keysv), UNI_DISPLAY_QQ)); 1764 if (HeKREHASH(he)) 1765 PerlIO_printf(file, "[REHASH] "); 1766 PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash); 1767 do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim); 1768 } 1769 hv_iterinit(hv); /* Return to status quo */ 1770 } 1771 break; 1772 case SVt_PVCV: 1773 if (SvPOK(sv)) { 1774 STRLEN len; 1775 const char *const proto = SvPV_const(sv, len); 1776 Perl_dump_indent(aTHX_ level, file, " PROTOTYPE = \"%.*s\"\n", 1777 (int) len, proto); 1778 } 1779 /* FALL THROUGH */ 1780 case SVt_PVFM: 1781 do_hv_dump(level, file, " COMP_STASH", CvSTASH(sv)); 1782 if (!CvISXSUB(sv)) { 1783 if (CvSTART(sv)) { 1784 Perl_dump_indent(aTHX_ level, file, 1785 " START = 0x%"UVxf" ===> %"IVdf"\n", 1786 PTR2UV(CvSTART(sv)), 1787 (IV)sequence_num(CvSTART(sv))); 1788 } 1789 Perl_dump_indent(aTHX_ level, file, " ROOT = 0x%"UVxf"\n", 1790 PTR2UV(CvROOT(sv))); 1791 if (CvROOT(sv) && dumpops) { 1792 do_op_dump(level+1, file, CvROOT(sv)); 1793 } 1794 } else { 1795 SV * const constant = cv_const_sv((CV *)sv); 1796 1797 Perl_dump_indent(aTHX_ level, file, " XSUB = 0x%"UVxf"\n", PTR2UV(CvXSUB(sv))); 1798 1799 if (constant) { 1800 Perl_dump_indent(aTHX_ level, file, " XSUBANY = 0x%"UVxf 1801 " (CONST SV)\n", 1802 PTR2UV(CvXSUBANY(sv).any_ptr)); 1803 do_sv_dump(level+1, file, constant, nest+1, maxnest, dumpops, 1804 pvlim); 1805 } else { 1806 Perl_dump_indent(aTHX_ level, file, " XSUBANY = %"IVdf"\n", 1807 (IV)CvXSUBANY(sv).any_i32); 1808 } 1809 } 1810 do_gvgv_dump(level, file, " GVGV::GV", CvGV(sv)); 1811 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", CvFILE(sv)); 1812 if (type == SVt_PVCV) 1813 Perl_dump_indent(aTHX_ level, file, " DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv)); 1814 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv)); 1815 Perl_dump_indent(aTHX_ level, file, " OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv)); 1816 if (type == SVt_PVFM) 1817 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)FmLINES(sv)); 1818 Perl_dump_indent(aTHX_ level, file, " PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv))); 1819 if (nest < maxnest) { 1820 do_dump_pad(level+1, file, CvPADLIST(sv), 0); 1821 } 1822 { 1823 const CV * const outside = CvOUTSIDE(sv); 1824 Perl_dump_indent(aTHX_ level, file, " OUTSIDE = 0x%"UVxf" (%s)\n", 1825 PTR2UV(outside), 1826 (!outside ? "null" 1827 : CvANON(outside) ? "ANON" 1828 : (outside == PL_main_cv) ? "MAIN" 1829 : CvUNIQUE(outside) ? "UNIQUE" 1830 : CvGV(outside) ? GvNAME(CvGV(outside)) : "UNDEFINED")); 1831 } 1832 if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv))) 1833 do_sv_dump(level+1, file, MUTABLE_SV(CvOUTSIDE(sv)), nest+1, maxnest, dumpops, pvlim); 1834 break; 1835 case SVt_PVGV: 1836 case SVt_PVLV: 1837 if (type == SVt_PVLV) { 1838 Perl_dump_indent(aTHX_ level, file, " TYPE = %c\n", LvTYPE(sv)); 1839 Perl_dump_indent(aTHX_ level, file, " TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv)); 1840 Perl_dump_indent(aTHX_ level, file, " TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv)); 1841 Perl_dump_indent(aTHX_ level, file, " TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv))); 1842 if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T') 1843 do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest, 1844 dumpops, pvlim); 1845 } 1846 if (SvVALID(sv)) { 1847 Perl_dump_indent(aTHX_ level, file, " FLAGS = %u\n", (U8)BmFLAGS(sv)); 1848 Perl_dump_indent(aTHX_ level, file, " RARE = %u\n", (U8)BmRARE(sv)); 1849 Perl_dump_indent(aTHX_ level, file, " PREVIOUS = %"UVuf"\n", (UV)BmPREVIOUS(sv)); 1850 Perl_dump_indent(aTHX_ level, file, " USEFUL = %"IVdf"\n", (IV)BmUSEFUL(sv)); 1851 } 1852 if (!isGV_with_GP(sv)) 1853 break; 1854 Perl_dump_indent(aTHX_ level, file, " NAME = \"%s\"\n", GvNAME(sv)); 1855 Perl_dump_indent(aTHX_ level, file, " NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv)); 1856 do_hv_dump (level, file, " GvSTASH", GvSTASH(sv)); 1857 Perl_dump_indent(aTHX_ level, file, " GP = 0x%"UVxf"\n", PTR2UV(GvGP(sv))); 1858 if (!GvGP(sv)) 1859 break; 1860 Perl_dump_indent(aTHX_ level, file, " SV = 0x%"UVxf"\n", PTR2UV(GvSV(sv))); 1861 Perl_dump_indent(aTHX_ level, file, " REFCNT = %"IVdf"\n", (IV)GvREFCNT(sv)); 1862 Perl_dump_indent(aTHX_ level, file, " IO = 0x%"UVxf"\n", PTR2UV(GvIOp(sv))); 1863 Perl_dump_indent(aTHX_ level, file, " FORM = 0x%"UVxf" \n", PTR2UV(GvFORM(sv))); 1864 Perl_dump_indent(aTHX_ level, file, " AV = 0x%"UVxf"\n", PTR2UV(GvAV(sv))); 1865 Perl_dump_indent(aTHX_ level, file, " HV = 0x%"UVxf"\n", PTR2UV(GvHV(sv))); 1866 Perl_dump_indent(aTHX_ level, file, " CV = 0x%"UVxf"\n", PTR2UV(GvCV(sv))); 1867 Perl_dump_indent(aTHX_ level, file, " CVGEN = 0x%"UVxf"\n", (UV)GvCVGEN(sv)); 1868 Perl_dump_indent(aTHX_ level, file, " LINE = %"IVdf"\n", (IV)GvLINE(sv)); 1869 Perl_dump_indent(aTHX_ level, file, " FILE = \"%s\"\n", GvFILE(sv)); 1870 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)GvFLAGS(sv)); 1871 do_gv_dump (level, file, " EGV", GvEGV(sv)); 1872 break; 1873 case SVt_PVIO: 1874 Perl_dump_indent(aTHX_ level, file, " IFP = 0x%"UVxf"\n", PTR2UV(IoIFP(sv))); 1875 Perl_dump_indent(aTHX_ level, file, " OFP = 0x%"UVxf"\n", PTR2UV(IoOFP(sv))); 1876 Perl_dump_indent(aTHX_ level, file, " DIRP = 0x%"UVxf"\n", PTR2UV(IoDIRP(sv))); 1877 Perl_dump_indent(aTHX_ level, file, " LINES = %"IVdf"\n", (IV)IoLINES(sv)); 1878 Perl_dump_indent(aTHX_ level, file, " PAGE = %"IVdf"\n", (IV)IoPAGE(sv)); 1879 Perl_dump_indent(aTHX_ level, file, " PAGE_LEN = %"IVdf"\n", (IV)IoPAGE_LEN(sv)); 1880 Perl_dump_indent(aTHX_ level, file, " LINES_LEFT = %"IVdf"\n", (IV)IoLINES_LEFT(sv)); 1881 if (IoTOP_NAME(sv)) 1882 Perl_dump_indent(aTHX_ level, file, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv)); 1883 if (!IoTOP_GV(sv) || SvTYPE(IoTOP_GV(sv)) == SVt_PVGV) 1884 do_gv_dump (level, file, " TOP_GV", IoTOP_GV(sv)); 1885 else { 1886 Perl_dump_indent(aTHX_ level, file, " TOP_GV = 0x%"UVxf"\n", 1887 PTR2UV(IoTOP_GV(sv))); 1888 do_sv_dump (level+1, file, MUTABLE_SV(IoTOP_GV(sv)), nest+1, 1889 maxnest, dumpops, pvlim); 1890 } 1891 /* Source filters hide things that are not GVs in these three, so let's 1892 be careful out there. */ 1893 if (IoFMT_NAME(sv)) 1894 Perl_dump_indent(aTHX_ level, file, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv)); 1895 if (!IoFMT_GV(sv) || SvTYPE(IoFMT_GV(sv)) == SVt_PVGV) 1896 do_gv_dump (level, file, " FMT_GV", IoFMT_GV(sv)); 1897 else { 1898 Perl_dump_indent(aTHX_ level, file, " FMT_GV = 0x%"UVxf"\n", 1899 PTR2UV(IoFMT_GV(sv))); 1900 do_sv_dump (level+1, file, MUTABLE_SV(IoFMT_GV(sv)), nest+1, 1901 maxnest, dumpops, pvlim); 1902 } 1903 if (IoBOTTOM_NAME(sv)) 1904 Perl_dump_indent(aTHX_ level, file, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv)); 1905 if (!IoBOTTOM_GV(sv) || SvTYPE(IoBOTTOM_GV(sv)) == SVt_PVGV) 1906 do_gv_dump (level, file, " BOTTOM_GV", IoBOTTOM_GV(sv)); 1907 else { 1908 Perl_dump_indent(aTHX_ level, file, " BOTTOM_GV = 0x%"UVxf"\n", 1909 PTR2UV(IoBOTTOM_GV(sv))); 1910 do_sv_dump (level+1, file, MUTABLE_SV(IoBOTTOM_GV(sv)), nest+1, 1911 maxnest, dumpops, pvlim); 1912 } 1913 if (isPRINT(IoTYPE(sv))) 1914 Perl_dump_indent(aTHX_ level, file, " TYPE = '%c'\n", IoTYPE(sv)); 1915 else 1916 Perl_dump_indent(aTHX_ level, file, " TYPE = '\\%o'\n", IoTYPE(sv)); 1917 Perl_dump_indent(aTHX_ level, file, " FLAGS = 0x%"UVxf"\n", (UV)IoFLAGS(sv)); 1918 break; 1919 } 1920 SvREFCNT_dec(d); 1921 } 1922 1923 void 1924 Perl_sv_dump(pTHX_ SV *sv) 1925 { 1926 dVAR; 1927 1928 PERL_ARGS_ASSERT_SV_DUMP; 1929 1930 if (SvROK(sv)) 1931 do_sv_dump(0, Perl_debug_log, sv, 0, 4, 0, 0); 1932 else 1933 do_sv_dump(0, Perl_debug_log, sv, 0, 0, 0, 0); 1934 } 1935 1936 int 1937 Perl_runops_debug(pTHX) 1938 { 1939 dVAR; 1940 if (!PL_op) { 1941 if (ckWARN_d(WARN_DEBUGGING)) 1942 Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN"); 1943 return 0; 1944 } 1945 1946 DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n")); 1947 do { 1948 PERL_ASYNC_CHECK(); 1949 if (PL_debug) { 1950 if (PL_watchaddr && (*PL_watchaddr != PL_watchok)) 1951 PerlIO_printf(Perl_debug_log, 1952 "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n", 1953 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok), 1954 PTR2UV(*PL_watchaddr)); 1955 if (DEBUG_s_TEST_) { 1956 if (DEBUG_v_TEST_) { 1957 PerlIO_printf(Perl_debug_log, "\n"); 1958 deb_stack_all(); 1959 } 1960 else 1961 debstack(); 1962 } 1963 1964 1965 if (DEBUG_t_TEST_) debop(PL_op); 1966 if (DEBUG_P_TEST_) debprof(PL_op); 1967 } 1968 } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX))); 1969 DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n")); 1970 1971 TAINT_NOT; 1972 return 0; 1973 } 1974 1975 I32 1976 Perl_debop(pTHX_ const OP *o) 1977 { 1978 dVAR; 1979 1980 PERL_ARGS_ASSERT_DEBOP; 1981 1982 if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_) 1983 return 0; 1984 1985 Perl_deb(aTHX_ "%s", OP_NAME(o)); 1986 switch (o->op_type) { 1987 case OP_CONST: 1988 /* With ITHREADS, consts are stored in the pad, and the right pad 1989 * may not be active here, so check. 1990 * Looks like only during compiling the pads are illegal. 1991 */ 1992 #ifdef USE_ITHREADS 1993 if ((((SVOP*)o)->op_sv) || !IN_PERL_COMPILETIME) 1994 #endif 1995 PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv)); 1996 break; 1997 case OP_GVSV: 1998 case OP_GV: 1999 if (cGVOPo_gv) { 2000 SV * const sv = newSV(0); 2001 #ifdef PERL_MAD 2002 /* FIXME - is this making unwarranted assumptions about the 2003 UTF-8 cleanliness of the dump file handle? */ 2004 SvUTF8_on(sv); 2005 #endif 2006 gv_fullname3(sv, cGVOPo_gv, NULL); 2007 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv)); 2008 SvREFCNT_dec(sv); 2009 } 2010 else 2011 PerlIO_printf(Perl_debug_log, "(NULL)"); 2012 break; 2013 case OP_PADSV: 2014 case OP_PADAV: 2015 case OP_PADHV: 2016 { 2017 /* print the lexical's name */ 2018 CV * const cv = deb_curcv(cxstack_ix); 2019 SV *sv; 2020 if (cv) { 2021 AV * const padlist = CvPADLIST(cv); 2022 AV * const comppad = MUTABLE_AV(*av_fetch(padlist, 0, FALSE)); 2023 sv = *av_fetch(comppad, o->op_targ, FALSE); 2024 } else 2025 sv = NULL; 2026 if (sv) 2027 PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv)); 2028 else 2029 PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ); 2030 } 2031 break; 2032 default: 2033 break; 2034 } 2035 PerlIO_printf(Perl_debug_log, "\n"); 2036 return 0; 2037 } 2038 2039 STATIC CV* 2040 S_deb_curcv(pTHX_ const I32 ix) 2041 { 2042 dVAR; 2043 const PERL_CONTEXT * const cx = &cxstack[ix]; 2044 if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) 2045 return cx->blk_sub.cv; 2046 else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx)) 2047 return PL_compcv; 2048 else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN) 2049 return PL_main_cv; 2050 else if (ix <= 0) 2051 return NULL; 2052 else 2053 return deb_curcv(ix - 1); 2054 } 2055 2056 void 2057 Perl_watch(pTHX_ char **addr) 2058 { 2059 dVAR; 2060 2061 PERL_ARGS_ASSERT_WATCH; 2062 2063 PL_watchaddr = addr; 2064 PL_watchok = *addr; 2065 PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n", 2066 PTR2UV(PL_watchaddr), PTR2UV(PL_watchok)); 2067 } 2068 2069 STATIC void 2070 S_debprof(pTHX_ const OP *o) 2071 { 2072 dVAR; 2073 2074 PERL_ARGS_ASSERT_DEBPROF; 2075 2076 if (!DEBUG_J_TEST_ && CopSTASH_eq(PL_curcop, PL_debstash)) 2077 return; 2078 if (!PL_profiledata) 2079 Newxz(PL_profiledata, MAXO, U32); 2080 ++PL_profiledata[o->op_type]; 2081 } 2082 2083 void 2084 Perl_debprofdump(pTHX) 2085 { 2086 dVAR; 2087 unsigned i; 2088 if (!PL_profiledata) 2089 return; 2090 for (i = 0; i < MAXO; i++) { 2091 if (PL_profiledata[i]) 2092 PerlIO_printf(Perl_debug_log, 2093 "%5lu %s\n", (unsigned long)PL_profiledata[i], 2094 PL_op_name[i]); 2095 } 2096 } 2097 2098 #ifdef PERL_MAD 2099 /* 2100 * XML variants of most of the above routines 2101 */ 2102 2103 STATIC void 2104 S_xmldump_attr(pTHX_ I32 level, PerlIO *file, const char* pat, ...) 2105 { 2106 va_list args; 2107 2108 PERL_ARGS_ASSERT_XMLDUMP_ATTR; 2109 2110 PerlIO_printf(file, "\n "); 2111 va_start(args, pat); 2112 xmldump_vindent(level, file, pat, &args); 2113 va_end(args); 2114 } 2115 2116 2117 void 2118 Perl_xmldump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...) 2119 { 2120 va_list args; 2121 PERL_ARGS_ASSERT_XMLDUMP_INDENT; 2122 va_start(args, pat); 2123 xmldump_vindent(level, file, pat, &args); 2124 va_end(args); 2125 } 2126 2127 void 2128 Perl_xmldump_vindent(pTHX_ I32 level, PerlIO *file, const char* pat, va_list *args) 2129 { 2130 PERL_ARGS_ASSERT_XMLDUMP_VINDENT; 2131 2132 PerlIO_printf(file, "%*s", (int)(level*PL_dumpindent), ""); 2133 PerlIO_vprintf(file, pat, *args); 2134 } 2135 2136 void 2137 Perl_xmldump_all(pTHX) 2138 { 2139 PerlIO_setlinebuf(PL_xmlfp); 2140 if (PL_main_root) 2141 op_xmldump(PL_main_root); 2142 if (PL_xmlfp != (PerlIO*)PerlIO_stdout()) 2143 PerlIO_close(PL_xmlfp); 2144 PL_xmlfp = 0; 2145 } 2146 2147 void 2148 Perl_xmldump_packsubs(pTHX_ const HV *stash) 2149 { 2150 I32 i; 2151 HE *entry; 2152 2153 PERL_ARGS_ASSERT_XMLDUMP_PACKSUBS; 2154 2155 if (!HvARRAY(stash)) 2156 return; 2157 for (i = 0; i <= (I32) HvMAX(stash); i++) { 2158 for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) { 2159 GV *gv = MUTABLE_GV(HeVAL(entry)); 2160 HV *hv; 2161 if (SvTYPE(gv) != SVt_PVGV || !GvGP(gv)) 2162 continue; 2163 if (GvCVu(gv)) 2164 xmldump_sub(gv); 2165 if (GvFORM(gv)) 2166 xmldump_form(gv); 2167 if (HeKEY(entry)[HeKLEN(entry)-1] == ':' 2168 && (hv = GvHV(gv)) && hv != PL_defstash) 2169 xmldump_packsubs(hv); /* nested package */ 2170 } 2171 } 2172 } 2173 2174 void 2175 Perl_xmldump_sub(pTHX_ const GV *gv) 2176 { 2177 SV * const sv = sv_newmortal(); 2178 2179 PERL_ARGS_ASSERT_XMLDUMP_SUB; 2180 2181 gv_fullname3(sv, gv, NULL); 2182 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nSUB %s = ", SvPVX(sv)); 2183 if (CvXSUB(GvCV(gv))) 2184 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "(xsub 0x%"UVxf" %d)\n", 2185 PTR2UV(CvXSUB(GvCV(gv))), 2186 (int)CvXSUBANY(GvCV(gv)).any_i32); 2187 else if (CvROOT(GvCV(gv))) 2188 op_xmldump(CvROOT(GvCV(gv))); 2189 else 2190 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n"); 2191 } 2192 2193 void 2194 Perl_xmldump_form(pTHX_ const GV *gv) 2195 { 2196 SV * const sv = sv_newmortal(); 2197 2198 PERL_ARGS_ASSERT_XMLDUMP_FORM; 2199 2200 gv_fullname3(sv, gv, NULL); 2201 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "\nFORMAT %s = ", SvPVX(sv)); 2202 if (CvROOT(GvFORM(gv))) 2203 op_xmldump(CvROOT(GvFORM(gv))); 2204 else 2205 Perl_xmldump_indent(aTHX_ 0, PL_xmlfp, "<undef>\n"); 2206 } 2207 2208 void 2209 Perl_xmldump_eval(pTHX) 2210 { 2211 op_xmldump(PL_eval_root); 2212 } 2213 2214 char * 2215 Perl_sv_catxmlsv(pTHX_ SV *dsv, SV *ssv) 2216 { 2217 PERL_ARGS_ASSERT_SV_CATXMLSV; 2218 return sv_catxmlpvn(dsv, SvPVX(ssv), SvCUR(ssv), SvUTF8(ssv)); 2219 } 2220 2221 char * 2222 Perl_sv_catxmlpvn(pTHX_ SV *dsv, const char *pv, STRLEN len, int utf8) 2223 { 2224 unsigned int c; 2225 const char * const e = pv + len; 2226 const char * const start = pv; 2227 STRLEN dsvcur; 2228 STRLEN cl; 2229 2230 PERL_ARGS_ASSERT_SV_CATXMLPVN; 2231 2232 sv_catpvs(dsv,""); 2233 dsvcur = SvCUR(dsv); /* in case we have to restart */ 2234 2235 retry: 2236 while (pv < e) { 2237 if (utf8) { 2238 c = utf8_to_uvchr((U8*)pv, &cl); 2239 if (cl == 0) { 2240 SvCUR(dsv) = dsvcur; 2241 pv = start; 2242 utf8 = 0; 2243 goto retry; 2244 } 2245 } 2246 else 2247 c = (*pv & 255); 2248 2249 switch (c) { 2250 case 0x00: 2251 case 0x01: 2252 case 0x02: 2253 case 0x03: 2254 case 0x04: 2255 case 0x05: 2256 case 0x06: 2257 case 0x07: 2258 case 0x08: 2259 case 0x0b: 2260 case 0x0c: 2261 case 0x0e: 2262 case 0x0f: 2263 case 0x10: 2264 case 0x11: 2265 case 0x12: 2266 case 0x13: 2267 case 0x14: 2268 case 0x15: 2269 case 0x16: 2270 case 0x17: 2271 case 0x18: 2272 case 0x19: 2273 case 0x1a: 2274 case 0x1b: 2275 case 0x1c: 2276 case 0x1d: 2277 case 0x1e: 2278 case 0x1f: 2279 case 0x7f: 2280 case 0x80: 2281 case 0x81: 2282 case 0x82: 2283 case 0x83: 2284 case 0x84: 2285 case 0x86: 2286 case 0x87: 2287 case 0x88: 2288 case 0x89: 2289 case 0x90: 2290 case 0x91: 2291 case 0x92: 2292 case 0x93: 2293 case 0x94: 2294 case 0x95: 2295 case 0x96: 2296 case 0x97: 2297 case 0x98: 2298 case 0x99: 2299 case 0x9a: 2300 case 0x9b: 2301 case 0x9c: 2302 case 0x9d: 2303 case 0x9e: 2304 case 0x9f: 2305 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c); 2306 break; 2307 case '<': 2308 sv_catpvs(dsv, "<"); 2309 break; 2310 case '>': 2311 sv_catpvs(dsv, ">"); 2312 break; 2313 case '&': 2314 sv_catpvs(dsv, "&"); 2315 break; 2316 case '"': 2317 sv_catpvs(dsv, """); 2318 break; 2319 default: 2320 if (c < 0xD800) { 2321 if (c < 32 || c > 127) { 2322 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c); 2323 } 2324 else { 2325 const char string = (char) c; 2326 sv_catpvn(dsv, &string, 1); 2327 } 2328 break; 2329 } 2330 if ((c >= 0xD800 && c <= 0xDB7F) || 2331 (c >= 0xDC00 && c <= 0xDFFF) || 2332 (c >= 0xFFF0 && c <= 0xFFFF) || 2333 c > 0x10ffff) 2334 Perl_sv_catpvf(aTHX_ dsv, "STUPIDXML(#x%X)", c); 2335 else 2336 Perl_sv_catpvf(aTHX_ dsv, "&#x%X;", c); 2337 } 2338 2339 if (utf8) 2340 pv += UTF8SKIP(pv); 2341 else 2342 pv++; 2343 } 2344 2345 return SvPVX(dsv); 2346 } 2347 2348 char * 2349 Perl_sv_xmlpeek(pTHX_ SV *sv) 2350 { 2351 SV * const t = sv_newmortal(); 2352 STRLEN n_a; 2353 int unref = 0; 2354 2355 PERL_ARGS_ASSERT_SV_XMLPEEK; 2356 2357 sv_utf8_upgrade(t); 2358 sv_setpvs(t, ""); 2359 /* retry: */ 2360 if (!sv) { 2361 sv_catpv(t, "VOID=\"\""); 2362 goto finish; 2363 } 2364 else if (sv == (const SV *)0x55555555 || SvTYPE(sv) == 'U') { 2365 sv_catpv(t, "WILD=\"\""); 2366 goto finish; 2367 } 2368 else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) { 2369 if (sv == &PL_sv_undef) { 2370 sv_catpv(t, "SV_UNDEF=\"1\""); 2371 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT| 2372 SVs_GMG|SVs_SMG|SVs_RMG)) && 2373 SvREADONLY(sv)) 2374 goto finish; 2375 } 2376 else if (sv == &PL_sv_no) { 2377 sv_catpv(t, "SV_NO=\"1\""); 2378 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| 2379 SVs_GMG|SVs_SMG|SVs_RMG)) && 2380 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| 2381 SVp_POK|SVp_NOK)) && 2382 SvCUR(sv) == 0 && 2383 SvNVX(sv) == 0.0) 2384 goto finish; 2385 } 2386 else if (sv == &PL_sv_yes) { 2387 sv_catpv(t, "SV_YES=\"1\""); 2388 if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| 2389 SVs_GMG|SVs_SMG|SVs_RMG)) && 2390 !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY| 2391 SVp_POK|SVp_NOK)) && 2392 SvCUR(sv) == 1 && 2393 SvPVX(sv) && *SvPVX(sv) == '1' && 2394 SvNVX(sv) == 1.0) 2395 goto finish; 2396 } 2397 else { 2398 sv_catpv(t, "SV_PLACEHOLDER=\"1\""); 2399 if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT| 2400 SVs_GMG|SVs_SMG|SVs_RMG)) && 2401 SvREADONLY(sv)) 2402 goto finish; 2403 } 2404 sv_catpv(t, " XXX=\"\" "); 2405 } 2406 else if (SvREFCNT(sv) == 0) { 2407 sv_catpv(t, " refcnt=\"0\""); 2408 unref++; 2409 } 2410 else if (DEBUG_R_TEST_) { 2411 int is_tmp = 0; 2412 I32 ix; 2413 /* is this SV on the tmps stack? */ 2414 for (ix=PL_tmps_ix; ix>=0; ix--) { 2415 if (PL_tmps_stack[ix] == sv) { 2416 is_tmp = 1; 2417 break; 2418 } 2419 } 2420 if (SvREFCNT(sv) > 1) 2421 Perl_sv_catpvf(aTHX_ t, " DRT=\"<%"UVuf"%s>\"", (UV)SvREFCNT(sv), 2422 is_tmp ? "T" : ""); 2423 else if (is_tmp) 2424 sv_catpv(t, " DRT=\"<T>\""); 2425 } 2426 2427 if (SvROK(sv)) { 2428 sv_catpv(t, " ROK=\"\""); 2429 } 2430 switch (SvTYPE(sv)) { 2431 default: 2432 sv_catpv(t, " FREED=\"1\""); 2433 goto finish; 2434 2435 case SVt_NULL: 2436 sv_catpv(t, " UNDEF=\"1\""); 2437 goto finish; 2438 case SVt_IV: 2439 sv_catpv(t, " IV=\""); 2440 break; 2441 case SVt_NV: 2442 sv_catpv(t, " NV=\""); 2443 break; 2444 case SVt_RV: 2445 sv_catpv(t, " RV=\""); 2446 break; 2447 case SVt_PV: 2448 sv_catpv(t, " PV=\""); 2449 break; 2450 case SVt_PVIV: 2451 sv_catpv(t, " PVIV=\""); 2452 break; 2453 case SVt_PVNV: 2454 sv_catpv(t, " PVNV=\""); 2455 break; 2456 case SVt_PVMG: 2457 sv_catpv(t, " PVMG=\""); 2458 break; 2459 case SVt_PVLV: 2460 sv_catpv(t, " PVLV=\""); 2461 break; 2462 case SVt_PVAV: 2463 sv_catpv(t, " AV=\""); 2464 break; 2465 case SVt_PVHV: 2466 sv_catpv(t, " HV=\""); 2467 break; 2468 case SVt_PVCV: 2469 if (CvGV(sv)) 2470 Perl_sv_catpvf(aTHX_ t, " CV=\"(%s)\"", GvNAME(CvGV(sv))); 2471 else 2472 sv_catpv(t, " CV=\"()\""); 2473 goto finish; 2474 case SVt_PVGV: 2475 sv_catpv(t, " GV=\""); 2476 break; 2477 case SVt_BIND: 2478 sv_catpv(t, " BIND=\""); 2479 break; 2480 case SVt_PVFM: 2481 sv_catpv(t, " FM=\""); 2482 break; 2483 case SVt_PVIO: 2484 sv_catpv(t, " IO=\""); 2485 break; 2486 } 2487 2488 if (SvPOKp(sv)) { 2489 if (SvPVX(sv)) { 2490 sv_catxmlsv(t, sv); 2491 } 2492 } 2493 else if (SvNOKp(sv)) { 2494 STORE_NUMERIC_LOCAL_SET_STANDARD(); 2495 Perl_sv_catpvf(aTHX_ t, "%"NVgf"",SvNVX(sv)); 2496 RESTORE_NUMERIC_LOCAL(); 2497 } 2498 else if (SvIOKp(sv)) { 2499 if (SvIsUV(sv)) 2500 Perl_sv_catpvf(aTHX_ t, "%"UVuf"", (UV)SvUVX(sv)); 2501 else 2502 Perl_sv_catpvf(aTHX_ t, "%"IVdf"", (IV)SvIVX(sv)); 2503 } 2504 else 2505 sv_catpv(t, ""); 2506 sv_catpv(t, "\""); 2507 2508 finish: 2509 while (unref--) 2510 sv_catpv(t, ")"); 2511 return SvPV(t, n_a); 2512 } 2513 2514 void 2515 Perl_do_pmop_xmldump(pTHX_ I32 level, PerlIO *file, const PMOP *pm) 2516 { 2517 PERL_ARGS_ASSERT_DO_PMOP_XMLDUMP; 2518 2519 if (!pm) { 2520 Perl_xmldump_indent(aTHX_ level, file, "<pmop/>\n"); 2521 return; 2522 } 2523 Perl_xmldump_indent(aTHX_ level, file, "<pmop \n"); 2524 level++; 2525 if (PM_GETRE(pm)) { 2526 REGEXP *const r = PM_GETRE(pm); 2527 SV * const tmpsv 2528 = newSVpvn_utf8(RX_PRECOMP(r), RX_PRELEN(r), RX_UTF8(r)); 2529 sv_utf8_upgrade(tmpsv); 2530 Perl_xmldump_indent(aTHX_ level, file, "pre=\"%s\"\n", 2531 SvPVX(tmpsv)); 2532 SvREFCNT_dec(tmpsv); 2533 Perl_xmldump_indent(aTHX_ level, file, "when=\"%s\"\n", 2534 (pm->op_private & OPpRUNTIME) ? "RUN" : "COMP"); 2535 } 2536 else 2537 Perl_xmldump_indent(aTHX_ level, file, "pre=\"\" when=\"RUN\"\n"); 2538 if (pm->op_pmflags || (PM_GETRE(pm) && RX_CHECK_SUBSTR(PM_GETRE(pm)))) { 2539 SV * const tmpsv = pm_description(pm); 2540 Perl_xmldump_indent(aTHX_ level, file, "pmflags=\"%s\"\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); 2541 SvREFCNT_dec(tmpsv); 2542 } 2543 2544 level--; 2545 if (pm->op_type != OP_PUSHRE && pm->op_pmreplrootu.op_pmreplroot) { 2546 Perl_xmldump_indent(aTHX_ level, file, ">\n"); 2547 Perl_xmldump_indent(aTHX_ level+1, file, "<pm_repl>\n"); 2548 do_op_xmldump(level+2, file, pm->op_pmreplrootu.op_pmreplroot); 2549 Perl_xmldump_indent(aTHX_ level+1, file, "</pm_repl>\n"); 2550 Perl_xmldump_indent(aTHX_ level, file, "</pmop>\n"); 2551 } 2552 else 2553 Perl_xmldump_indent(aTHX_ level, file, "/>\n"); 2554 } 2555 2556 void 2557 Perl_pmop_xmldump(pTHX_ const PMOP *pm) 2558 { 2559 do_pmop_xmldump(0, PL_xmlfp, pm); 2560 } 2561 2562 void 2563 Perl_do_op_xmldump(pTHX_ I32 level, PerlIO *file, const OP *o) 2564 { 2565 UV seq; 2566 int contents = 0; 2567 2568 PERL_ARGS_ASSERT_DO_OP_XMLDUMP; 2569 2570 if (!o) 2571 return; 2572 sequence(o); 2573 seq = sequence_num(o); 2574 Perl_xmldump_indent(aTHX_ level, file, 2575 "<op_%s seq=\"%"UVuf" -> ", 2576 OP_NAME(o), 2577 seq); 2578 level++; 2579 if (o->op_next) 2580 PerlIO_printf(file, seq ? "%"UVuf"\"" : "(%"UVuf")\"", 2581 sequence_num(o->op_next)); 2582 else 2583 PerlIO_printf(file, "DONE\""); 2584 2585 if (o->op_targ) { 2586 if (o->op_type == OP_NULL) 2587 { 2588 PerlIO_printf(file, " was=\"%s\"", PL_op_name[o->op_targ]); 2589 if (o->op_targ == OP_NEXTSTATE) 2590 { 2591 if (CopLINE(cCOPo)) 2592 PerlIO_printf(file, " line=\"%"UVuf"\"", 2593 (UV)CopLINE(cCOPo)); 2594 if (CopSTASHPV(cCOPo)) 2595 PerlIO_printf(file, " package=\"%s\"", 2596 CopSTASHPV(cCOPo)); 2597 if (CopLABEL(cCOPo)) 2598 PerlIO_printf(file, " label=\"%s\"", 2599 CopLABEL(cCOPo)); 2600 } 2601 } 2602 else 2603 PerlIO_printf(file, " targ=\"%ld\"", (long)o->op_targ); 2604 } 2605 #ifdef DUMPADDR 2606 PerlIO_printf(file, " addr=\"0x%"UVxf" => 0x%"UVxf"\"", (UV)o, (UV)o->op_next); 2607 #endif 2608 if (o->op_flags) { 2609 SV * const tmpsv = newSVpvs(""); 2610 switch (o->op_flags & OPf_WANT) { 2611 case OPf_WANT_VOID: 2612 sv_catpv(tmpsv, ",VOID"); 2613 break; 2614 case OPf_WANT_SCALAR: 2615 sv_catpv(tmpsv, ",SCALAR"); 2616 break; 2617 case OPf_WANT_LIST: 2618 sv_catpv(tmpsv, ",LIST"); 2619 break; 2620 default: 2621 sv_catpv(tmpsv, ",UNKNOWN"); 2622 break; 2623 } 2624 if (o->op_flags & OPf_KIDS) 2625 sv_catpv(tmpsv, ",KIDS"); 2626 if (o->op_flags & OPf_PARENS) 2627 sv_catpv(tmpsv, ",PARENS"); 2628 if (o->op_flags & OPf_STACKED) 2629 sv_catpv(tmpsv, ",STACKED"); 2630 if (o->op_flags & OPf_REF) 2631 sv_catpv(tmpsv, ",REF"); 2632 if (o->op_flags & OPf_MOD) 2633 sv_catpv(tmpsv, ",MOD"); 2634 if (o->op_flags & OPf_SPECIAL) 2635 sv_catpv(tmpsv, ",SPECIAL"); 2636 PerlIO_printf(file, " flags=\"%s\"", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : ""); 2637 SvREFCNT_dec(tmpsv); 2638 } 2639 if (o->op_private) { 2640 SV * const tmpsv = newSVpvs(""); 2641 if (PL_opargs[o->op_type] & OA_TARGLEX) { 2642 if (o->op_private & OPpTARGET_MY) 2643 sv_catpv(tmpsv, ",TARGET_MY"); 2644 } 2645 else if (o->op_type == OP_LEAVESUB || 2646 o->op_type == OP_LEAVE || 2647 o->op_type == OP_LEAVESUBLV || 2648 o->op_type == OP_LEAVEWRITE) { 2649 if (o->op_private & OPpREFCOUNTED) 2650 sv_catpv(tmpsv, ",REFCOUNTED"); 2651 } 2652 else if (o->op_type == OP_AASSIGN) { 2653 if (o->op_private & OPpASSIGN_COMMON) 2654 sv_catpv(tmpsv, ",COMMON"); 2655 } 2656 else if (o->op_type == OP_SASSIGN) { 2657 if (o->op_private & OPpASSIGN_BACKWARDS) 2658 sv_catpv(tmpsv, ",BACKWARDS"); 2659 } 2660 else if (o->op_type == OP_TRANS) { 2661 if (o->op_private & OPpTRANS_SQUASH) 2662 sv_catpv(tmpsv, ",SQUASH"); 2663 if (o->op_private & OPpTRANS_DELETE) 2664 sv_catpv(tmpsv, ",DELETE"); 2665 if (o->op_private & OPpTRANS_COMPLEMENT) 2666 sv_catpv(tmpsv, ",COMPLEMENT"); 2667 if (o->op_private & OPpTRANS_IDENTICAL) 2668 sv_catpv(tmpsv, ",IDENTICAL"); 2669 if (o->op_private & OPpTRANS_GROWS) 2670 sv_catpv(tmpsv, ",GROWS"); 2671 } 2672 else if (o->op_type == OP_REPEAT) { 2673 if (o->op_private & OPpREPEAT_DOLIST) 2674 sv_catpv(tmpsv, ",DOLIST"); 2675 } 2676 else if (o->op_type == OP_ENTERSUB || 2677 o->op_type == OP_RV2SV || 2678 o->op_type == OP_GVSV || 2679 o->op_type == OP_RV2AV || 2680 o->op_type == OP_RV2HV || 2681 o->op_type == OP_RV2GV || 2682 o->op_type == OP_AELEM || 2683 o->op_type == OP_HELEM ) 2684 { 2685 if (o->op_type == OP_ENTERSUB) { 2686 if (o->op_private & OPpENTERSUB_AMPER) 2687 sv_catpv(tmpsv, ",AMPER"); 2688 if (o->op_private & OPpENTERSUB_DB) 2689 sv_catpv(tmpsv, ",DB"); 2690 if (o->op_private & OPpENTERSUB_HASTARG) 2691 sv_catpv(tmpsv, ",HASTARG"); 2692 if (o->op_private & OPpENTERSUB_NOPAREN) 2693 sv_catpv(tmpsv, ",NOPAREN"); 2694 if (o->op_private & OPpENTERSUB_INARGS) 2695 sv_catpv(tmpsv, ",INARGS"); 2696 if (o->op_private & OPpENTERSUB_NOMOD) 2697 sv_catpv(tmpsv, ",NOMOD"); 2698 } 2699 else { 2700 switch (o->op_private & OPpDEREF) { 2701 case OPpDEREF_SV: 2702 sv_catpv(tmpsv, ",SV"); 2703 break; 2704 case OPpDEREF_AV: 2705 sv_catpv(tmpsv, ",AV"); 2706 break; 2707 case OPpDEREF_HV: 2708 sv_catpv(tmpsv, ",HV"); 2709 break; 2710 } 2711 if (o->op_private & OPpMAYBE_LVSUB) 2712 sv_catpv(tmpsv, ",MAYBE_LVSUB"); 2713 } 2714 if (o->op_type == OP_AELEM || o->op_type == OP_HELEM) { 2715 if (o->op_private & OPpLVAL_DEFER) 2716 sv_catpv(tmpsv, ",LVAL_DEFER"); 2717 } 2718 else { 2719 if (o->op_private & HINT_STRICT_REFS) 2720 sv_catpv(tmpsv, ",STRICT_REFS"); 2721 if (o->op_private & OPpOUR_INTRO) 2722 sv_catpv(tmpsv, ",OUR_INTRO"); 2723 } 2724 } 2725 else if (o->op_type == OP_CONST) { 2726 if (o->op_private & OPpCONST_BARE) 2727 sv_catpv(tmpsv, ",BARE"); 2728 if (o->op_private & OPpCONST_STRICT) 2729 sv_catpv(tmpsv, ",STRICT"); 2730 if (o->op_private & OPpCONST_ARYBASE) 2731 sv_catpv(tmpsv, ",ARYBASE"); 2732 if (o->op_private & OPpCONST_WARNING) 2733 sv_catpv(tmpsv, ",WARNING"); 2734 if (o->op_private & OPpCONST_ENTERED) 2735 sv_catpv(tmpsv, ",ENTERED"); 2736 } 2737 else if (o->op_type == OP_FLIP) { 2738 if (o->op_private & OPpFLIP_LINENUM) 2739 sv_catpv(tmpsv, ",LINENUM"); 2740 } 2741 else if (o->op_type == OP_FLOP) { 2742 if (o->op_private & OPpFLIP_LINENUM) 2743 sv_catpv(tmpsv, ",LINENUM"); 2744 } 2745 else if (o->op_type == OP_RV2CV) { 2746 if (o->op_private & OPpLVAL_INTRO) 2747 sv_catpv(tmpsv, ",INTRO"); 2748 } 2749 else if (o->op_type == OP_GV) { 2750 if (o->op_private & OPpEARLY_CV) 2751 sv_catpv(tmpsv, ",EARLY_CV"); 2752 } 2753 else if (o->op_type == OP_LIST) { 2754 if (o->op_private & OPpLIST_GUESSED) 2755 sv_catpv(tmpsv, ",GUESSED"); 2756 } 2757 else if (o->op_type == OP_DELETE) { 2758 if (o->op_private & OPpSLICE) 2759 sv_catpv(tmpsv, ",SLICE"); 2760 } 2761 else if (o->op_type == OP_EXISTS) { 2762 if (o->op_private & OPpEXISTS_SUB) 2763 sv_catpv(tmpsv, ",EXISTS_SUB"); 2764 } 2765 else if (o->op_type == OP_SORT) { 2766 if (o->op_private & OPpSORT_NUMERIC) 2767 sv_catpv(tmpsv, ",NUMERIC"); 2768 if (o->op_private & OPpSORT_INTEGER) 2769 sv_catpv(tmpsv, ",INTEGER"); 2770 if (o->op_private & OPpSORT_REVERSE) 2771 sv_catpv(tmpsv, ",REVERSE"); 2772 } 2773 else if (o->op_type == OP_OPEN || o->op_type == OP_BACKTICK) { 2774 if (o->op_private & OPpOPEN_IN_RAW) 2775 sv_catpv(tmpsv, ",IN_RAW"); 2776 if (o->op_private & OPpOPEN_IN_CRLF) 2777 sv_catpv(tmpsv, ",IN_CRLF"); 2778 if (o->op_private & OPpOPEN_OUT_RAW) 2779 sv_catpv(tmpsv, ",OUT_RAW"); 2780 if (o->op_private & OPpOPEN_OUT_CRLF) 2781 sv_catpv(tmpsv, ",OUT_CRLF"); 2782 } 2783 else if (o->op_type == OP_EXIT) { 2784 if (o->op_private & OPpEXIT_VMSISH) 2785 sv_catpv(tmpsv, ",EXIT_VMSISH"); 2786 if (o->op_private & OPpHUSH_VMSISH) 2787 sv_catpv(tmpsv, ",HUSH_VMSISH"); 2788 } 2789 else if (o->op_type == OP_DIE) { 2790 if (o->op_private & OPpHUSH_VMSISH) 2791 sv_catpv(tmpsv, ",HUSH_VMSISH"); 2792 } 2793 else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) { 2794 if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS) 2795 sv_catpv(tmpsv, ",FT_ACCESS"); 2796 if (o->op_private & OPpFT_STACKED) 2797 sv_catpv(tmpsv, ",FT_STACKED"); 2798 } 2799 if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO) 2800 sv_catpv(tmpsv, ",INTRO"); 2801 if (SvCUR(tmpsv)) 2802 S_xmldump_attr(aTHX_ level, file, "private=\"%s\"", SvPVX(tmpsv) + 1); 2803 SvREFCNT_dec(tmpsv); 2804 } 2805 2806 switch (o->op_type) { 2807 case OP_AELEMFAST: 2808 if (o->op_flags & OPf_SPECIAL) { 2809 break; 2810 } 2811 case OP_GVSV: 2812 case OP_GV: 2813 #ifdef USE_ITHREADS 2814 S_xmldump_attr(aTHX_ level, file, "padix=\"%" IVdf "\"", (IV)cPADOPo->op_padix); 2815 #else 2816 if (cSVOPo->op_sv) { 2817 SV * const tmpsv1 = newSVpvn_utf8(NULL, 0, TRUE); 2818 SV * const tmpsv2 = newSVpvn_utf8("", 0, TRUE); 2819 char *s; 2820 STRLEN len; 2821 ENTER; 2822 SAVEFREESV(tmpsv1); 2823 SAVEFREESV(tmpsv2); 2824 gv_fullname3(tmpsv1, MUTABLE_GV(cSVOPo->op_sv), NULL); 2825 s = SvPV(tmpsv1,len); 2826 sv_catxmlpvn(tmpsv2, s, len, 1); 2827 S_xmldump_attr(aTHX_ level, file, "gv=\"%s\"", SvPV(tmpsv2, len)); 2828 LEAVE; 2829 } 2830 else 2831 S_xmldump_attr(aTHX_ level, file, "gv=\"NULL\""); 2832 #endif 2833 break; 2834 case OP_CONST: 2835 case OP_METHOD_NAMED: 2836 #ifndef USE_ITHREADS 2837 /* with ITHREADS, consts are stored in the pad, and the right pad 2838 * may not be active here, so skip */ 2839 S_xmldump_attr(aTHX_ level, file, "%s", sv_xmlpeek(cSVOPo_sv)); 2840 #endif 2841 break; 2842 case OP_ANONCODE: 2843 if (!contents) { 2844 contents = 1; 2845 PerlIO_printf(file, ">\n"); 2846 } 2847 do_op_xmldump(level+1, file, CvROOT(cSVOPo_sv)); 2848 break; 2849 case OP_SETSTATE: 2850 case OP_NEXTSTATE: 2851 case OP_DBSTATE: 2852 if (CopLINE(cCOPo)) 2853 S_xmldump_attr(aTHX_ level, file, "line=\"%"UVuf"\"", 2854 (UV)CopLINE(cCOPo)); 2855 if (CopSTASHPV(cCOPo)) 2856 S_xmldump_attr(aTHX_ level, file, "package=\"%s\"", 2857 CopSTASHPV(cCOPo)); 2858 if (CopLABEL(cCOPo)) 2859 S_xmldump_attr(aTHX_ level, file, "label=\"%s\"", 2860 CopLABEL(cCOPo)); 2861 break; 2862 case OP_ENTERLOOP: 2863 S_xmldump_attr(aTHX_ level, file, "redo=\""); 2864 if (cLOOPo->op_redoop) 2865 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_redoop)); 2866 else 2867 PerlIO_printf(file, "DONE\""); 2868 S_xmldump_attr(aTHX_ level, file, "next=\""); 2869 if (cLOOPo->op_nextop) 2870 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_nextop)); 2871 else 2872 PerlIO_printf(file, "DONE\""); 2873 S_xmldump_attr(aTHX_ level, file, "last=\""); 2874 if (cLOOPo->op_lastop) 2875 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOOPo->op_lastop)); 2876 else 2877 PerlIO_printf(file, "DONE\""); 2878 break; 2879 case OP_COND_EXPR: 2880 case OP_RANGE: 2881 case OP_MAPWHILE: 2882 case OP_GREPWHILE: 2883 case OP_OR: 2884 case OP_AND: 2885 S_xmldump_attr(aTHX_ level, file, "other=\""); 2886 if (cLOGOPo->op_other) 2887 PerlIO_printf(file, "%"UVuf"\"", sequence_num(cLOGOPo->op_other)); 2888 else 2889 PerlIO_printf(file, "DONE\""); 2890 break; 2891 case OP_LEAVE: 2892 case OP_LEAVEEVAL: 2893 case OP_LEAVESUB: 2894 case OP_LEAVESUBLV: 2895 case OP_LEAVEWRITE: 2896 case OP_SCOPE: 2897 if (o->op_private & OPpREFCOUNTED) 2898 S_xmldump_attr(aTHX_ level, file, "refcnt=\"%"UVuf"\"", (UV)o->op_targ); 2899 break; 2900 default: 2901 break; 2902 } 2903 2904 if (PL_madskills && o->op_madprop) { 2905 char prevkey = '\0'; 2906 SV * const tmpsv = newSVpvn_utf8("", 0, TRUE); 2907 const MADPROP* mp = o->op_madprop; 2908 2909 if (!contents) { 2910 contents = 1; 2911 PerlIO_printf(file, ">\n"); 2912 } 2913 Perl_xmldump_indent(aTHX_ level, file, "<madprops>\n"); 2914 level++; 2915 while (mp) { 2916 char tmp = mp->mad_key; 2917 sv_setpvs(tmpsv,"\""); 2918 if (tmp) 2919 sv_catxmlpvn(tmpsv, &tmp, 1, 0); 2920 if ((tmp == '_') || (tmp == '#')) /* '_' '#' whitespace belong to the previous token. */ 2921 sv_catxmlpvn(tmpsv, &prevkey, 1, 0); 2922 else 2923 prevkey = tmp; 2924 sv_catpv(tmpsv, "\""); 2925 switch (mp->mad_type) { 2926 case MAD_NULL: 2927 sv_catpv(tmpsv, "NULL"); 2928 Perl_xmldump_indent(aTHX_ level, file, "<mad_null key=%s/>\n", SvPVX(tmpsv)); 2929 break; 2930 case MAD_PV: 2931 sv_catpv(tmpsv, " val=\""); 2932 sv_catxmlpvn(tmpsv, (char*)mp->mad_val, mp->mad_vlen,1); 2933 sv_catpv(tmpsv, "\""); 2934 Perl_xmldump_indent(aTHX_ level, file, "<mad_pv key=%s/>\n", SvPVX(tmpsv)); 2935 break; 2936 case MAD_SV: 2937 sv_catpv(tmpsv, " val=\""); 2938 sv_catxmlsv(tmpsv, MUTABLE_SV(mp->mad_val)); 2939 sv_catpv(tmpsv, "\""); 2940 Perl_xmldump_indent(aTHX_ level, file, "<mad_sv key=%s/>\n", SvPVX(tmpsv)); 2941 break; 2942 case MAD_OP: 2943 if ((OP*)mp->mad_val) { 2944 Perl_xmldump_indent(aTHX_ level, file, "<mad_op key=%s>\n", SvPVX(tmpsv)); 2945 do_op_xmldump(level+1, file, (OP*)mp->mad_val); 2946 Perl_xmldump_indent(aTHX_ level, file, "</mad_op>\n"); 2947 } 2948 break; 2949 default: 2950 Perl_xmldump_indent(aTHX_ level, file, "<mad_unk key=%s/>\n", SvPVX(tmpsv)); 2951 break; 2952 } 2953 mp = mp->mad_next; 2954 } 2955 level--; 2956 Perl_xmldump_indent(aTHX_ level, file, "</madprops>\n"); 2957 2958 SvREFCNT_dec(tmpsv); 2959 } 2960 2961 switch (o->op_type) { 2962 case OP_PUSHRE: 2963 case OP_MATCH: 2964 case OP_QR: 2965 case OP_SUBST: 2966 if (!contents) { 2967 contents = 1; 2968 PerlIO_printf(file, ">\n"); 2969 } 2970 do_pmop_xmldump(level, file, cPMOPo); 2971 break; 2972 default: 2973 break; 2974 } 2975 2976 if (o->op_flags & OPf_KIDS) { 2977 OP *kid; 2978 if (!contents) { 2979 contents = 1; 2980 PerlIO_printf(file, ">\n"); 2981 } 2982 for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) 2983 do_op_xmldump(level, file, kid); 2984 } 2985 2986 if (contents) 2987 Perl_xmldump_indent(aTHX_ level-1, file, "</op_%s>\n", OP_NAME(o)); 2988 else 2989 PerlIO_printf(file, " />\n"); 2990 } 2991 2992 void 2993 Perl_op_xmldump(pTHX_ const OP *o) 2994 { 2995 PERL_ARGS_ASSERT_OP_XMLDUMP; 2996 2997 do_op_xmldump(0, PL_xmlfp, o); 2998 } 2999 #endif 3000 3001 /* 3002 * Local variables: 3003 * c-indentation-style: bsd 3004 * c-basic-offset: 4 3005 * indent-tabs-mode: t 3006 * End: 3007 * 3008 * ex: set ts=8 sts=4 sw=4 noet: 3009 */ 3010