File Coverage

ext/Devel-Peek/Peek.xs
Criterion Covered Total %
statement 45 135 33.3
branch n/a
condition n/a
subroutine n/a
total 45 135 33.3


line stmt bran cond sub time code
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 0         const bool d = PL_runops == Perl_runops_debug;
11            
12 0         if (flag >= 0)
13 0         PL_runops = flag ? Perl_runops_debug : Perl_runops_standard;
14           return d;
15           }
16            
17           static SV *
18 0         DeadCode(pTHX)
19           {
20           #ifdef PURIFY
21           return Nullsv;
22           #else
23           SV* sva;
24           SV* sv;
25 0         SV* ret = newRV_noinc((SV*)newAV());
26           SV* svend;
27           int tm = 0, tref = 0, ts = 0, ta = 0, tas = 0;
28            
29 0         for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
30 0         svend = &sva[SvREFCNT(sva)];
31 0         for (sv = sva + 1; sv < svend; ++sv) {
32 0         if (SvTYPE(sv) == SVt_PVCV) {
33           CV *cv = (CV*)sv;
34 0         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 0         if (CvISXSUB(sv)) {
43 0         continue; /* XSUB */
44           }
45 0         if (!CvGV(sv)) {
46 0         continue; /* file-level scope. */
47           }
48 0         if (!CvROOT(cv)) {
49           /* PerlIO_printf(Perl_debug_log, " no root?!\n"); */
50 0         continue; /* autoloading stub. */
51           }
52 0         do_gvgv_dump(0, Perl_debug_log, "GVGV::GV", CvGV(sv));
53 0         if (CvDEPTH(cv)) {
54 0         PerlIO_printf(Perl_debug_log, " busy\n");
55 0         continue;
56           }
57 0         svp = (SV**) PadlistARRAY(padlist);
58 0         while (++i <= PadlistMAX(padlist)) { /* Depth. */
59           SV **args;
60          
61 0         if (!svp[i]) continue;
62 0         pad = AvARRAY((AV*)svp[i]);
63 0         argav = (AV*)pad[0];
64 0         if (!argav || (SV*)argav == &PL_sv_undef) {
65 0         PerlIO_printf(Perl_debug_log, " closure-template\n");
66 0         continue;
67           }
68 0         args = AvARRAY(argav);
69           levelm = levels = levelref = levelas = 0;
70 0         levela = sizeof(SV*) * (AvMAX(argav) + 1);
71 0         if (AvREAL(argav)) {
72 0         for (j = 0; j < AvFILL(argav); j++) {
73 0         if (SvROK(args[j])) {
74 0         PerlIO_printf(Perl_debug_log, " ref in args!\n");
75 0         levelref++;
76           }
77           /* else if (SvPOK(args[j]) && SvPVX(args[j])) { */
78 0         else if (SvTYPE(args[j]) >= SVt_PV && SvLEN(args[j])) {
79 0         levelas += SvLEN(args[j])/SvREFCNT(args[j]);
80           }
81           }
82           }
83 0         for (j = 1; j < AvFILL((AV*)svp[1]); j++) { /* Vars. */
84 0         if (!pad[j]) continue;
85 0         if (SvROK(pad[j])) {
86 0         levelref++;
87 0         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 0         else if (SvTYPE(pad[j]) >= SVt_PVAV) {
92 0         if (!SvPADMY(pad[j])) {
93 0         levelref++;
94 0         do_sv_dump(0, Perl_debug_log, pad[j], 0, 4, 0, 0);
95           dumpit = 1;
96           }
97           }
98 0         else if (SvTYPE(pad[j]) >= SVt_PV && SvLEN(pad[j])) {
99 0         levels++;
100 0         levelm += SvLEN(pad[j])/SvREFCNT(pad[j]);
101           /* Dump(pad[j],4); */
102           }
103           }
104 0         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 0         totm += levelm;
107 0         tota += levela;
108 0         totas += levelas;
109 0         tots += levels;
110 0         totref += levelref;
111 0         if (dumpit)
112 0         do_sv_dump(0, Perl_debug_log, (SV*)cv, 0, 2, 0, 0);
113           }
114 0         if (PadlistMAX(padlist) > 1) {
115 0         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 0         tref += totref;
119 0         tm += totm;
120 0         ts += tots;
121 0         ta += tota;
122 0         tas += totas;
123           }
124           }
125           }
126 0         PerlIO_printf(Perl_debug_log, "total: refs: %i, strings: %i in %i\targsarray: %i, argsstrings: %i\n", tref, tm, ts, ta, tas);
127            
128 0         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 0         fill_mstats(SV *sv, int level)
299           {
300           PERL_UNUSED_ARG(sv);
301           PERL_UNUSED_ARG(level);
302 0         croak("Cannot report mstats without Perl malloc");
303           }
304            
305           static void
306 0         mstats_fillhash(SV *sv, int level)
307           {
308           PERL_UNUSED_ARG(sv);
309           PERL_UNUSED_ARG(level);
310 0         croak("Cannot report mstats without Perl malloc");
311           }
312            
313           static void
314 0         mstats2hash(SV *sv, SV *rv, int level)
315           {
316           PERL_UNUSED_ARG(sv);
317           PERL_UNUSED_ARG(rv);
318           PERL_UNUSED_ARG(level);
319 0         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 56         S_do_dump(pTHX_ SV *const sv, I32 lim)
329           {
330           dVAR;
331 56         SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", 0);
332 56         const STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0;
333 56         SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", 0);
334 56         const U16 save_dumpindent = PL_dumpindent;
335 56         PL_dumpindent = 2;
336 56         do_sv_dump(0, Perl_debug_log, sv, 0, lim,
337           (bool)(dumpop && SvTRUE(dumpop)), pv_lim);
338 56         PL_dumpindent = save_dumpindent;
339 56         }
340            
341           static OP *
342 56         S_pp_dump(pTHX)
343           {
344 56         dSP;
345 56         const I32 lim = PL_op->op_private == 2 ? (I32)POPi : 4;
346 56         dPOPss;
347 56         S_do_dump(aTHX_ sv, lim);
348 56         RETPUSHUNDEF;
349           }
350            
351           static OP *
352 6         S_ck_dump(pTHX_ OP *entersubop, GV *namegv, SV *cv)
353           {
354           OP *aop, *prev, *first, *second = NULL;
355           BINOP *newop;
356           size_t arg = 0;
357            
358 6         ck_entersub_args_proto(entersubop, namegv,
359           newSVpvn_flags("$;$", 3, SVs_TEMP));
360            
361 6         aop = cUNOPx(entersubop)->op_first;
362 6         if (!aop->op_sibling)
363 6         aop = cUNOPx(aop)->op_first;
364           prev = aop;
365 6         aop = aop->op_sibling;
366           while (PL_madskills && aop->op_type == OP_STUB) {
367           prev = aop;
368           aop = aop->op_sibling;
369           }
370           if (PL_madskills && aop->op_type == OP_NULL) {
371           first = ((UNOP*)aop)->op_first;
372           ((UNOP*)aop)->op_first = NULL;
373           prev = aop;
374           }
375           else {
376           first = aop;
377 6         prev->op_sibling = first->op_sibling;
378           }
379 6         if (first->op_type == OP_RV2AV ||
380 6         first->op_type == OP_PADAV ||
381 12         first->op_type == OP_RV2HV ||
382 6         first->op_type == OP_PADHV
383           )
384 0         first->op_flags |= OPf_REF;
385           else
386 6         first->op_flags &= ~OPf_MOD;
387 6         aop = aop->op_sibling;
388           while (PL_madskills && aop->op_type == OP_STUB) {
389           prev = aop;
390           aop = aop->op_sibling;
391           }
392           /* aop now points to the second arg if there is one, the cvop otherwise
393           */
394 6         if (aop->op_sibling) {
395 0         prev->op_sibling = aop->op_sibling;
396           second = aop;
397 0         second->op_sibling = NULL;
398           }
399 6         first->op_sibling = second;
400            
401 6         op_free(entersubop);
402            
403 6         NewOp(1234, newop, 1, BINOP);
404 6         newop->op_type = OP_CUSTOM;
405 6         newop->op_ppaddr = S_pp_dump;
406 6         newop->op_first = first;
407 6         newop->op_last = second;
408 6         newop->op_private= second ? 2 : 1;
409 6         newop->op_flags = OPf_KIDS|OPf_WANT_SCALAR;
410            
411 6         return (OP *)newop;
412           }
413            
414           static XOP my_xop;
415            
416           MODULE = Devel::Peek PACKAGE = Devel::Peek
417            
418           void
419           mstat(str="Devel::Peek::mstat: ")
420           const char *str
421            
422           void
423           fill_mstats(SV *sv, int level = 0)
424            
425           void
426           mstats_fillhash(SV *sv, int level = 0)
427           PROTOTYPE: \%;$
428            
429           void
430           mstats2hash(SV *sv, SV *rv, int level = 0)
431           PROTOTYPE: $\%;$
432            
433           void
434           Dump(sv,lim=4)
435           SV * sv
436           I32 lim
437           PPCODE:
438           {
439 0         S_do_dump(aTHX_ sv, lim);
440           }
441            
442           BOOT:
443           {
444 8         CV * const cv = get_cvn_flags("Devel::Peek::Dump", 17, 0);
445 8         cv_set_call_checker(cv, S_ck_dump, (SV *)cv);
446            
447 8         XopENTRY_set(&my_xop, xop_name, "Dump");
448 8         XopENTRY_set(&my_xop, xop_desc, "Dump");
449 8         XopENTRY_set(&my_xop, xop_class, OA_BINOP);
450 8         Perl_custom_op_register(aTHX_ S_pp_dump, &my_xop);
451           }
452            
453           void
454           DumpArray(lim,...)
455           I32 lim
456           PPCODE:
457           {
458           long i;
459 0         SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", 0);
460 0         const STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0;
461 0         SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", 0);
462 0         const U16 save_dumpindent = PL_dumpindent;
463 0         PL_dumpindent = 2;
464            
465 0         for (i=1; i
466 0         PerlIO_printf(Perl_debug_log, "Elt No. %ld 0x%"UVxf"\n", i - 1, PTR2UV(ST(i)));
467 0         do_sv_dump(0, Perl_debug_log, ST(i), 0, lim,
468           (bool)(dumpop && SvTRUE(dumpop)), pv_lim);
469           }
470 0         PL_dumpindent = save_dumpindent;
471           }
472            
473           void
474           DumpProg()
475           PPCODE:
476           {
477 0         warn("dumpindent is %d", (int)PL_dumpindent);
478 0         if (PL_main_root)
479 0         op_dump(PL_main_root);
480           }
481            
482           U32
483           SvREFCNT(sv)
484           SV * sv
485           PROTOTYPE: \[$@%&*]
486           CODE:
487 0         RETVAL = SvREFCNT(SvRV(sv)) - 1; /* -1 because our ref doesn't count */
488           OUTPUT:
489           RETVAL
490            
491           SV *
492           DeadCode()
493           CODE:
494 0         RETVAL = DeadCode(aTHX);
495           OUTPUT:
496           RETVAL
497            
498           MODULE = Devel::Peek PACKAGE = Devel::Peek PREFIX = _
499            
500           SV *
501           _CvGV(cv)
502           SV *cv
503            
504           bool
505           _runops_debug(int flag = -1)