| 1 | #define PERL_NO_GET_CONTEXT |
| 2 | #include "EXTERN.h" |
| 3 | #include "perl.h" |
| 4 | #include "XSUB.h" |
| 5 | |
| 6 | static bool |
| 7 | _runops_debug(int flag) |
| 8 | { |
| 9 | dTHX; |
| 10 | const bool d = PL_runops == Perl_runops_debug; |
| 11 | |
| 12 | if (flag >= 0) |
| 13 | PL_runops = flag ? Perl_runops_debug : Perl_runops_standard; |
| 14 | return d; |
| 15 | } |
| 16 | |
| 17 | static SV * |
| 18 | DeadCode(pTHX) |
| 19 | { |
| 20 | #ifdef PURIFY |
| 21 | return Nullsv; |
| 22 | #else |
| 23 | SV* sva; |
| 24 | SV* sv; |
| 25 | SV* ret = newRV_noinc((SV*)newAV()); |
| 26 | SV* svend; |
| 27 | int tm = 0, tref = 0, ts = 0, ta = 0, tas = 0; |
| 28 | |
| 29 | for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) { |
| 30 | svend = &sva[SvREFCNT(sva)]; |
| 31 | for (sv = sva + 1; sv < svend; ++sv) { |
| 32 | if (SvTYPE(sv) == SVt_PVCV) { |
| 33 | CV *cv = (CV*)sv; |
| 34 | PADLIST* padlist = CvPADLIST(cv); |
| 35 | AV *argav; |
| 36 | SV** svp; |
| 37 | SV** pad; |
| 38 | int i = 0, j, levelm, totm = 0, levelref, totref = 0; |
| 39 | int levels, tots = 0, levela, tota = 0, levelas, totas = 0; |
| 40 | int dumpit = 0; |
| 41 | |
| 42 | if (CvISXSUB(sv)) { |
| 43 | continue; /* XSUB */ |
| 44 | } |
| 45 | if (!CvGV(sv)) { |
| 46 | continue; /* file-level scope. */ |
| 47 | } |
| 48 | if (!CvROOT(cv)) { |
| 49 | /* PerlIO_printf(Perl_debug_log, " no root?!\n"); */ |
| 50 | continue; /* autoloading stub. */ |
| 51 | } |
| 52 | do_gvgv_dump(0, Perl_debug_log, "GVGV::GV", CvGV(sv)); |
| 53 | if (CvDEPTH(cv)) { |
| 54 | PerlIO_printf(Perl_debug_log, " busy\n"); |
| 55 | continue; |
| 56 | } |
| 57 | svp = (SV**) PadlistARRAY(padlist); |
| 58 | while (++i <= PadlistMAX(padlist)) { /* Depth. */ |
| 59 | SV **args; |
| 60 | |
| 61 | if (!svp[i]) continue; |
| 62 | pad = AvARRAY((AV*)svp[i]); |
| 63 | argav = (AV*)pad[0]; |
| 64 | if (!argav || (SV*)argav == &PL_sv_undef) { |
| 65 | PerlIO_printf(Perl_debug_log, " closure-template\n"); |
| 66 | continue; |
| 67 | } |
| 68 | args = AvARRAY(argav); |
| 69 | levelm = levels = levelref = levelas = 0; |
| 70 | levela = sizeof(SV*) * (AvMAX(argav) + 1); |
| 71 | if (AvREAL(argav)) { |
| 72 | for (j = 0; j < AvFILL(argav); j++) { |
| 73 | if (SvROK(args[j])) { |
| 74 | PerlIO_printf(Perl_debug_log, " ref in args!\n"); |
| 75 | levelref++; |
| 76 | } |
| 77 | /* else if (SvPOK(args[j]) && SvPVX(args[j])) { */ |
| 78 | else if (SvTYPE(args[j]) >= SVt_PV && SvLEN(args[j])) { |
| 79 | levelas += SvLEN(args[j])/SvREFCNT(args[j]); |
| 80 | } |
| 81 | } |
| 82 | } |
| 83 | for (j = 1; j < AvFILL((AV*)svp[1]); j++) { /* Vars. */ |
| 84 | if (!pad[j]) continue; |
| 85 | if (SvROK(pad[j])) { |
| 86 | levelref++; |
| 87 | do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0); |
| 88 | dumpit = 1; |
| 89 | } |
| 90 | /* else if (SvPOK(pad[j]) && SvPVX(pad[j])) { */ |
| 91 | else if (SvTYPE(pad[j]) >= SVt_PVAV) { |
| 92 | if (!SvPADMY(pad[j])) { |
| 93 | levelref++; |
| 94 | do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0); |
| 95 | dumpit = 1; |
| 96 | } |
| 97 | } |
| 98 | else if (SvTYPE(pad[j]) >= SVt_PV && SvLEN(pad[j])) { |
| 99 | levels++; |
| 100 | levelm += SvLEN(pad[j])/SvREFCNT(pad[j]); |
| 101 | /* Dump(pad[j],4); */ |
| 102 | } |
| 103 | } |
| 104 | PerlIO_printf(Perl_debug_log, " level %i: refs: %i, strings: %i in %i,\targsarray: %i, argsstrings: %i\n", |
| 105 | i, levelref, levelm, levels, levela, levelas); |
| 106 | totm += levelm; |
| 107 | tota += levela; |
| 108 | totas += levelas; |
| 109 | tots += levels; |
| 110 | totref += levelref; |
| 111 | if (dumpit) |
| 112 | do_sv_dump(0, Perl_debug_log, (SV*)cv, 0, 2, 0, 0); |
| 113 | } |
| 114 | if (PadlistMAX(padlist) > 1) { |
| 115 | PerlIO_printf(Perl_debug_log, " total: refs: %i, strings: %i in %i,\targsarrays: %i, argsstrings: %i\n", |
| 116 | totref, totm, tots, tota, totas); |
| 117 | } |
| 118 | tref += totref; |
| 119 | tm += totm; |
| 120 | ts += tots; |
| 121 | ta += tota; |
| 122 | tas += totas; |
| 123 | } |
| 124 | } |
| 125 | } |
| 126 | PerlIO_printf(Perl_debug_log, "total: refs: %i, strings: %i in %i\targsarray: %i, argsstrings: %i\n", tref, tm, ts, ta, tas); |
| 127 | |
| 128 | return ret; |
| 129 | #endif /* !PURIFY */ |
| 130 | } |
| 131 | |
| 132 | #if defined(MYMALLOC) |
| 133 | # define mstat(str) dump_mstats(str) |
| 134 | #else |
| 135 | # define mstat(str) \ |
| 136 | PerlIO_printf(Perl_debug_log, "%s: perl not compiled with MYMALLOC\n",str); |
| 137 | #endif |
| 138 | |
| 139 | #if defined(MYMALLOC) |
| 140 | |
| 141 | /* Very coarse overestimate, 2-per-power-of-2, one more to determine NBUCKETS. */ |
| 142 | # define _NBUCKETS (2*8*IVSIZE+1) |
| 143 | |
| 144 | struct mstats_buffer |
| 145 | { |
| 146 | perl_mstats_t buffer; |
| 147 | UV buf[_NBUCKETS*4]; |
| 148 | }; |
| 149 | |
| 150 | static void |
| 151 | _fill_mstats(struct mstats_buffer *b, int level) |
| 152 | { |
| 153 | dTHX; |
| 154 | b->buffer.nfree = b->buf; |
| 155 | b->buffer.ntotal = b->buf + _NBUCKETS; |
| 156 | b->buffer.bucket_mem_size = b->buf + 2*_NBUCKETS; |
| 157 | b->buffer.bucket_available_size = b->buf + 3*_NBUCKETS; |
| 158 | Zero(b->buf, (level ? 4*_NBUCKETS: 2*_NBUCKETS), unsigned long); |
| 159 | get_mstats(&(b->buffer), _NBUCKETS, level); |
| 160 | } |
| 161 | |
| 162 | static void |
| 163 | fill_mstats(SV *sv, int level) |
| 164 | { |
| 165 | dTHX; |
| 166 | |
| 167 | if (SvREADONLY(sv)) |
| 168 | croak("Cannot modify a readonly value"); |
| 169 | sv_grow(sv, sizeof(struct mstats_buffer)+1); |
| 170 | _fill_mstats((struct mstats_buffer*)SvPVX(sv),level); |
| 171 | SvCUR_set(sv, sizeof(struct mstats_buffer)); |
| 172 | *SvEND(sv) = '\0'; |
| 173 | SvPOK_only(sv); |
| 174 | } |
| 175 | |
| 176 | static void |
| 177 | _mstats_to_hv(HV *hv, const struct mstats_buffer *b, int level) |
| 178 | { |
| 179 | dTHX; |
| 180 | SV **svp; |
| 181 | int type; |
| 182 | |
| 183 | svp = hv_fetch(hv, "topbucket", 9, 1); |
| 184 | sv_setiv(*svp, b->buffer.topbucket); |
| 185 | |
| 186 | svp = hv_fetch(hv, "topbucket_ev", 12, 1); |
| 187 | sv_setiv(*svp, b->buffer.topbucket_ev); |
| 188 | |
| 189 | svp = hv_fetch(hv, "topbucket_odd", 13, 1); |
| 190 | sv_setiv(*svp, b->buffer.topbucket_odd); |
| 191 | |
| 192 | svp = hv_fetch(hv, "totfree", 7, 1); |
| 193 | sv_setiv(*svp, b->buffer.totfree); |
| 194 | |
| 195 | svp = hv_fetch(hv, "total", 5, 1); |
| 196 | sv_setiv(*svp, b->buffer.total); |
| 197 | |
| 198 | svp = hv_fetch(hv, "total_chain", 11, 1); |
| 199 | sv_setiv(*svp, b->buffer.total_chain); |
| 200 | |
| 201 | svp = hv_fetch(hv, "total_sbrk", 10, 1); |
| 202 | sv_setiv(*svp, b->buffer.total_sbrk); |
| 203 | |
| 204 | svp = hv_fetch(hv, "sbrks", 5, 1); |
| 205 | sv_setiv(*svp, b->buffer.sbrks); |
| 206 | |
| 207 | svp = hv_fetch(hv, "sbrk_good", 9, 1); |
| 208 | sv_setiv(*svp, b->buffer.sbrk_good); |
| 209 | |
| 210 | svp = hv_fetch(hv, "sbrk_slack", 10, 1); |
| 211 | sv_setiv(*svp, b->buffer.sbrk_slack); |
| 212 | |
| 213 | svp = hv_fetch(hv, "start_slack", 11, 1); |
| 214 | sv_setiv(*svp, b->buffer.start_slack); |
| 215 | |
| 216 | svp = hv_fetch(hv, "sbrked_remains", 14, 1); |
| 217 | sv_setiv(*svp, b->buffer.sbrked_remains); |
| 218 | |
| 219 | svp = hv_fetch(hv, "minbucket", 9, 1); |
| 220 | sv_setiv(*svp, b->buffer.minbucket); |
| 221 | |
| 222 | svp = hv_fetch(hv, "nbuckets", 8, 1); |
| 223 | sv_setiv(*svp, b->buffer.nbuckets); |
| 224 | |
| 225 | if (_NBUCKETS < b->buffer.nbuckets) |
| 226 | warn("FIXME: internal mstats buffer too short"); |
| 227 | |
| 228 | for (type = 0; type < (level ? 4 : 2); type++) { |
| 229 | UV *p = 0, *p1 = 0, i; |
| 230 | AV *av; |
| 231 | static const char *types[4] = { |
| 232 | "free", "used", "mem_size", "available_size" |
| 233 | }; |
| 234 | |
| 235 | svp = hv_fetch(hv, types[type], strlen(types[type]), 1); |
| 236 | |
| 237 | if (SvOK(*svp) && !(SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV)) |
| 238 | croak("Unexpected value for the key '%s' in the mstats hash", types[type]); |
| 239 | if (!SvOK(*svp)) { |
| 240 | av = newAV(); |
| 241 | (void)SvUPGRADE(*svp, SVt_RV); |
| 242 | SvRV_set(*svp, (SV*)av); |
| 243 | SvROK_on(*svp); |
| 244 | } else |
| 245 | av = (AV*)SvRV(*svp); |
| 246 | |
| 247 | av_extend(av, b->buffer.nbuckets - 1); |
| 248 | /* XXXX What is the official way to reduce the size of the array? */ |
| 249 | switch (type) { |
| 250 | case 0: |
| 251 | p = b->buffer.nfree; |
| 252 | break; |
| 253 | case 1: |
| 254 | p = b->buffer.ntotal; |
| 255 | p1 = b->buffer.nfree; |
| 256 | break; |
| 257 | case 2: |
| 258 | p = b->buffer.bucket_mem_size; |
| 259 | break; |
| 260 | case 3: |
| 261 | p = b->buffer.bucket_available_size; |
| 262 | break; |
| 263 | } |
| 264 | for (i = 0; i < b->buffer.nbuckets; i++) { |
| 265 | svp = av_fetch(av, i, 1); |
| 266 | if (type == 1) |
| 267 | sv_setiv(*svp, p[i]-p1[i]); |
| 268 | else |
| 269 | sv_setuv(*svp, p[i]); |
| 270 | } |
| 271 | } |
| 272 | } |
| 273 | |
| 274 | static void |
| 275 | mstats_fillhash(SV *sv, int level) |
| 276 | { |
| 277 | struct mstats_buffer buf; |
| 278 | |
| 279 | if (!(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV)) |
| 280 | croak("Not a hash reference"); |
| 281 | _fill_mstats(&buf, level); |
| 282 | _mstats_to_hv((HV *)SvRV(sv), &buf, level); |
| 283 | } |
| 284 | |
| 285 | static void |
| 286 | mstats2hash(SV *sv, SV *rv, int level) |
| 287 | { |
| 288 | if (!(SvROK(rv) && SvTYPE(SvRV(rv)) == SVt_PVHV)) |
| 289 | croak("Not a hash reference"); |
| 290 | if (!SvPOK(sv)) |
| 291 | croak("Undefined value when expecting mstats buffer"); |
| 292 | if (SvCUR(sv) != sizeof(struct mstats_buffer)) |
| 293 | croak("Wrong size for a value with a mstats buffer"); |
| 294 | _mstats_to_hv((HV *)SvRV(rv), (struct mstats_buffer*)SvPVX(sv), level); |
| 295 | } |
| 296 | #else /* defined(MYMALLOC) */ |
| 297 | static void |
| 298 | fill_mstats(SV *sv, int level) |
| 299 | { |
| 300 | PERL_UNUSED_ARG(sv); |
| 301 | PERL_UNUSED_ARG(level); |
| 302 | croak("Cannot report mstats without Perl malloc"); |
| 303 | } |
| 304 | |
| 305 | static void |
| 306 | mstats_fillhash(SV *sv, int level) |
| 307 | { |
| 308 | PERL_UNUSED_ARG(sv); |
| 309 | PERL_UNUSED_ARG(level); |
| 310 | croak("Cannot report mstats without Perl malloc"); |
| 311 | } |
| 312 | |
| 313 | static void |
| 314 | mstats2hash(SV *sv, SV *rv, int level) |
| 315 | { |
| 316 | PERL_UNUSED_ARG(sv); |
| 317 | PERL_UNUSED_ARG(rv); |
| 318 | PERL_UNUSED_ARG(level); |
| 319 | croak("Cannot report mstats without Perl malloc"); |
| 320 | } |
| 321 | #endif /* defined(MYMALLOC) */ |
| 322 | |
| 323 | #define _CvGV(cv) \ |
| 324 | (SvROK(cv) && (SvTYPE(SvRV(cv))==SVt_PVCV) \ |
| 325 | ? SvREFCNT_inc(CvGV((CV*)SvRV(cv))) : &PL_sv_undef) |
| 326 | |
| 327 | static void |
| 328 | S_do_dump(pTHX_ SV *const sv, I32 lim) |
| 329 | { |
| 330 | dVAR; |
| 331 | SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", 0); |
| 332 | const STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0; |
| 333 | SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", 0); |
| 334 | const U16 save_dumpindent = PL_dumpindent; |
| 335 | PL_dumpindent = 2; |
| 336 | do_sv_dump(0, Perl_debug_log, sv, 0, lim, |
| 337 | (bool)(dumpop && SvTRUE(dumpop)), pv_lim); |
| 338 | PL_dumpindent = save_dumpindent; |
| 339 | } |
| 340 | |
| 341 | static OP * |
| 342 | S_pp_dump(pTHX) |
| 343 | { |
| 344 | dSP; |
| 345 | const I32 lim = PL_op->op_private == 2 ? (I32)POPi : 4; |
| 346 | dPOPss; |
| 347 | S_do_dump(aTHX_ sv, lim); |
| 348 | RETPUSHUNDEF; |
| 349 | } |
| 350 | |
| 351 | static OP * |
| 352 | S_ck_dump(pTHX_ OP *entersubop, GV *namegv, SV *cv) |
| 353 | { |
| 354 | OP *parent, *pm, *first, *second; |
| 355 | BINOP *newop; |
| 356 | |
| 357 | PERL_UNUSED_ARG(cv); |
| 358 | |
| 359 | ck_entersub_args_proto(entersubop, namegv, |
| 360 | newSVpvn_flags("$;$", 3, SVs_TEMP)); |
| 361 | |
| 362 | parent = entersubop; |
| 363 | pm = cUNOPx(entersubop)->op_first; |
| 364 | if (!OP_HAS_SIBLING(pm)) { |
| 365 | parent = pm; |
| 366 | pm = cUNOPx(pm)->op_first; |
| 367 | } |
| 368 | first = OP_SIBLING(pm); |
| 369 | second = OP_SIBLING(first); |
| 370 | if (!second) { |
| 371 | /* It doesn’t really matter what we return here, as this only |
| 372 | occurs after yyerror. */ |
| 373 | return entersubop; |
| 374 | } |
| 375 | /* we either have Dump($x): [pushmark]->[first]->[ex-cvop] |
| 376 | * or Dump($x,1); [pushmark]->[first]->[second]->[ex-cvop] |
| 377 | */ |
| 378 | if (!OP_HAS_SIBLING(second)) |
| 379 | second = NULL; |
| 380 | |
| 381 | if (first->op_type == OP_RV2AV || |
| 382 | first->op_type == OP_PADAV || |
| 383 | first->op_type == OP_RV2HV || |
| 384 | first->op_type == OP_PADHV |
| 385 | ) |
| 386 | first->op_flags |= OPf_REF; |
| 387 | else |
| 388 | first->op_flags &= ~OPf_MOD; |
| 389 | |
| 390 | /* splice out first (and optionally second) ops, then discard the rest |
| 391 | * of the op tree */ |
| 392 | |
| 393 | op_sibling_splice(parent, pm, second ? 2 : 1, NULL); |
| 394 | op_free(entersubop); |
| 395 | |
| 396 | /* then attach first (and second) to a new binop */ |
| 397 | |
| 398 | NewOp(1234, newop, 1, BINOP); |
| 399 | newop->op_type = OP_CUSTOM; |
| 400 | newop->op_ppaddr = S_pp_dump; |
| 401 | newop->op_private= second ? 2 : 1; |
| 402 | newop->op_flags = OPf_KIDS|OPf_WANT_SCALAR; |
| 403 | op_sibling_splice((OP*)newop, NULL, 0, first); |
| 404 | |
| 405 | return (OP *)newop; |
| 406 | } |
| 407 | |
| 408 | static XOP my_xop; |
| 409 | |
| 410 | MODULE = Devel::Peek PACKAGE = Devel::Peek |
| 411 | |
| 412 | void |
| 413 | mstat(str="Devel::Peek::mstat: ") |
| 414 | const char *str |
| 415 | |
| 416 | void |
| 417 | fill_mstats(SV *sv, int level = 0) |
| 418 | |
| 419 | void |
| 420 | mstats_fillhash(SV *sv, int level = 0) |
| 421 | PROTOTYPE: \%;$ |
| 422 | |
| 423 | void |
| 424 | mstats2hash(SV *sv, SV *rv, int level = 0) |
| 425 | PROTOTYPE: $\%;$ |
| 426 | |
| 427 | void |
| 428 | Dump(sv,lim=4) |
| 429 | SV * sv |
| 430 | I32 lim |
| 431 | PPCODE: |
| 432 | { |
| 433 | S_do_dump(aTHX_ sv, lim); |
| 434 | } |
| 435 | |
| 436 | BOOT: |
| 437 | { |
| 438 | CV * const cv = get_cvn_flags("Devel::Peek::Dump", 17, 0); |
| 439 | assert(cv); |
| 440 | cv_set_call_checker(cv, S_ck_dump, (SV *)cv); |
| 441 | |
| 442 | XopENTRY_set(&my_xop, xop_name, "Dump"); |
| 443 | XopENTRY_set(&my_xop, xop_desc, "Dump"); |
| 444 | XopENTRY_set(&my_xop, xop_class, OA_BINOP); |
| 445 | Perl_custom_op_register(aTHX_ S_pp_dump, &my_xop); |
| 446 | } |
| 447 | |
| 448 | void |
| 449 | DumpArray(lim,...) |
| 450 | I32 lim |
| 451 | PPCODE: |
| 452 | { |
| 453 | long i; |
| 454 | SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", 0); |
| 455 | const STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0; |
| 456 | SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", 0); |
| 457 | const U16 save_dumpindent = PL_dumpindent; |
| 458 | PL_dumpindent = 2; |
| 459 | |
| 460 | for (i=1; i<items; i++) { |
| 461 | PerlIO_printf(Perl_debug_log, "Elt No. %ld 0x%"UVxf"\n", i - 1, PTR2UV(ST(i))); |
| 462 | do_sv_dump(0, Perl_debug_log, ST(i), 0, lim, |
| 463 | (bool)(dumpop && SvTRUE(dumpop)), pv_lim); |
| 464 | } |
| 465 | PL_dumpindent = save_dumpindent; |
| 466 | } |
| 467 | |
| 468 | void |
| 469 | DumpProg() |
| 470 | PPCODE: |
| 471 | { |
| 472 | warn("dumpindent is %d", (int)PL_dumpindent); |
| 473 | if (PL_main_root) |
| 474 | op_dump(PL_main_root); |
| 475 | } |
| 476 | |
| 477 | U32 |
| 478 | SvREFCNT(sv) |
| 479 | SV * sv |
| 480 | PROTOTYPE: \[$@%&*] |
| 481 | CODE: |
| 482 | SvGETMAGIC(sv); |
| 483 | if (!SvROK(sv)) |
| 484 | croak_xs_usage(cv, "SCALAR"); |
| 485 | RETVAL = SvREFCNT(SvRV(sv)) - 1; /* -1 because our ref doesn't count */ |
| 486 | OUTPUT: |
| 487 | RETVAL |
| 488 | |
| 489 | SV * |
| 490 | DeadCode() |
| 491 | CODE: |
| 492 | RETVAL = DeadCode(aTHX); |
| 493 | OUTPUT: |
| 494 | RETVAL |
| 495 | |
| 496 | MODULE = Devel::Peek PACKAGE = Devel::Peek PREFIX = _ |
| 497 | |
| 498 | SV * |
| 499 | _CvGV(cv) |
| 500 | SV *cv |
| 501 | |
| 502 | bool |
| 503 | _runops_debug(int flag = -1) |