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