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