File Coverage

Callsite.xs
Criterion Covered Total %
statement 9 12 75.0
branch 8 12 66.6
condition n/a
subroutine n/a
pod n/a
total 17 24 70.8


line stmt bran cond sub pod time code
1             #include
2             #include
3             #include
4              
5             #define NEED_caller_cx
6              
7             #include "ppport.h"
8              
9             #if PERL_VERSION > 8
10             # define MY_RETOP(c) PTR2UV((c)->blk_sub.retop)
11             #else
12             # define MY_RETOP(c) ((UV)PL_retstack[(c)->blk_oldretsp - 1])
13             #endif
14              
15             /* addr_to_op code provided by ikegami.
16             See https://www.perlmonks.org/?node_id=1218517
17             */
18             static const char * const opclassnames[] = {
19             "B::NULL",
20             "B::OP",
21             "B::UNOP",
22             "B::BINOP",
23             "B::LOGOP",
24             "B::LISTOP",
25             "B::PMOP",
26             "B::SVOP",
27             "B::PADOP",
28             "B::PVOP",
29             "B::LOOP",
30             "B::COP",
31             "B::METHOP",
32             "B::UNOP_AUX"
33             };
34             MODULE = Devel::Callsite PACKAGE = Devel::Callsite
35              
36             PROTOTYPES: DISABLE
37              
38              
39             SV *
40             addr_to_op(IV o_addr)
41             CODE:
42 2           const OP *o = INT2PTR(OP*, o_addr);
43 2           RETVAL = newSV(0);
44 2           sv_setiv(newSVrv(RETVAL, opclassnames[op_class(o)]), o_addr);
45             OUTPUT:
46             RETVAL
47              
48              
49             SV *
50             callsite(level = 0)
51             I32 level
52             PREINIT:
53             const PERL_CONTEXT *cx, *dbcx;
54 13           int rv = 1;
55             PPCODE:
56 13           cx = caller_cx(level, &dbcx);
57 13 100         if (!cx) XSRETURN_EMPTY;
58              
59 11 50         mXPUSHu(MY_RETOP(cx));
60 11 100         if (GIMME == G_ARRAY && CopSTASH_eq(PL_curcop, PL_debstash)) {
    100          
    50          
61 0           rv = 2;
62 0 0         mXPUSHu(MY_RETOP(dbcx));
63             }
64 13           XSRETURN(rv);
65              
66             UV
67             context()
68             CODE:
69 0           RETVAL = PTR2UV(PERL_GET_CONTEXT);
70             OUTPUT:
71             RETVAL