File Coverage

true.xs
Criterion Covered Total %
statement 41 45 91.1
branch 38 102 37.2
condition n/a
subroutine n/a
pod n/a
total 79 147 53.7


line stmt bran cond sub pod time code
1             #define PERL_NO_GET_CONTEXT
2              
3             #include "EXTERN.h"
4             #include "perl.h"
5             #include "XSUB.h"
6             #include "ppport.h"
7              
8             #include "hook_op_check.h"
9             #include "hook_op_annotation.h"
10              
11             /* return a pointer to the current context */
12             /* FIXME this (introduced in 2015) should be in ppport.h */
13             #ifndef CX_CUR
14             #define CX_CUR() (&cxstack[cxstack_ix])
15             #endif
16              
17             #ifndef CxOLD_OP_TYPE
18             #define CxOLD_OP_TYPE(cx) (cx->blk_eval.old_op_type)
19             #endif
20              
21             STATIC hook_op_check_id TRUE_CHECK_LEAVEEVAL_ID = 0;
22             STATIC HV * TRUE_HASH = NULL;
23             STATIC OPAnnotationGroup TRUE_ANNOTATIONS = NULL;
24             STATIC OP * true_check_leaveeval(pTHX_ OP * o, void * user_data);
25             STATIC OP * true_leaveeval(pTHX);
26             STATIC U32 TRUE_COMPILING = 0;
27             STATIC U32 true_enabled(pTHX_ const char * const filename);
28             STATIC void true_leave(pTHX);
29             STATIC void true_unregister(pTHX_ const char * const filename);
30              
31             /*
32             * remove our custom checker for LEAVEEVAL OPs
33             */
34 29           STATIC void true_leave(pTHX) {
35 29 50         if (TRUE_COMPILING != 1) {
36 0           croak("true: scope underflow");
37             } else {
38 29           TRUE_COMPILING = 0;
39 29           hook_op_check_remove(OP_LEAVEEVAL, TRUE_CHECK_LEAVEEVAL_ID);
40             }
41 29           }
42              
43             /*
44             * look in the global filename (string) -> registered (boolean)
45             * hash (%TRUE) and return true if the supplied filename is
46             * registered i.e. if we should hook the op_ppaddr function.
47             */
48 92           STATIC U32 true_enabled(pTHX_ const char * const filename) {
49             SV **svp;
50 92           svp = hv_fetch(TRUE_HASH, filename, strlen(filename), 0);
51 92 100         return svp && *svp && SvOK(*svp) && SvTRUE(*svp);
    50          
    50          
    0          
    0          
    50          
    50          
    0          
    50          
    0          
    0          
    50          
    0          
    0          
    0          
    0          
    0          
    50          
    50          
    50          
    0          
    0          
    50          
    0          
52             }
53              
54             /*
55             * delete a filename from the %TRUE hash. if this empties the hash,
56             * unregister the file i.e. stop hooking LEAVEEVAL checks.
57             */
58 33           STATIC void true_unregister(pTHX_ const char * const filename) {
59             /* warn("true: deleting %s\n", filename); */
60 33           (void)hv_delete(TRUE_HASH, filename, strlen(filename), G_DISCARD);
61              
62 33 50         if (HvKEYS(TRUE_HASH) == 0) {
    100          
63             /* warn("true: hash is empty: disabling true\n"); */
64 25           true_leave(aTHX);
65             }
66 33           }
67              
68             /*
69             * assign a new implementation function (op_ppaddr) to a LEAVEEVAL OP
70             * if true.pm is enabled for the currently-compiling file
71             */
72 59           STATIC OP * true_check_leaveeval(pTHX_ OP * o, void * user_data) {
73 59 50         char * const ccfile = CopFILE(&PL_compiling);
74             PERL_UNUSED_VAR(user_data);
75              
76 59 100         if (true_enabled(aTHX_ ccfile)) {
77 33           op_annotate(TRUE_ANNOTATIONS, o, ccfile, NULL);
78 33           o->op_ppaddr = true_leaveeval;
79             }
80              
81 59           return o;
82             }
83              
84             /*
85             * our custom version of the LEAVEEVAL OP's implementation function (op_ppaddr),
86             * which forcibly returns a true value (by pushing the internal true SV on the
87             * stack) if one hasn't been returned already
88             *
89             * only applied if a) this OP is attached to a `require` and b) true.pm is
90             * enabled for the `require`d file
91             */
92 33           STATIC OP * true_leaveeval(pTHX) {
93 33           dVAR; dSP;
94 33           const PERL_CONTEXT * cx = CX_CUR();
95 33           OPAnnotation * annotation = op_annotation_get(TRUE_ANNOTATIONS, PL_op);
96 33           const char * const filename = annotation->data;
97             bool file_returns_true;
98              
99             /* make sure it hasn't been unimported */
100 33 50         bool enabled = (CxOLD_OP_TYPE(cx) == OP_REQUIRE) && true_enabled(aTHX_ filename);
    50          
101              
102 33 50         if (!enabled) {
103 0           goto done;
104             }
105              
106             #if (PERL_BCDVERSION < 0x5024000)
107             /*
108             * on perl < 5.24, forcibly return true regardless of whether or not it's
109             * needed (i.e. don't check to see if the file has returned true).
110             *
111             * XXX this is a hack to fix RT-124745 [1]. it's no longer needed on perl >=
112             * 5.24
113             *
114             * [1] https://rt.cpan.org/Public/Bug/Display.html?id=124745
115             */
116             file_returns_true = FALSE;
117             #else
118             {
119             SV ** oldsp;
120              
121             /* XXX is the context ever not scalar? */
122 33 50         if (cx->blk_gimme == G_SCALAR) {
123 33 50         file_returns_true = SvTRUE_NN(*SP);
    100          
    50          
    50          
    50          
    0          
    0          
    0          
    0          
    50          
    50          
    50          
    50          
    0          
124             } else {
125 0           oldsp = PL_stack_base + cx->blk_oldsp;
126 0           file_returns_true = SP > oldsp;
127             }
128             }
129             #endif
130              
131 33 50         if (!file_returns_true) {
132 33 50         XPUSHs(&PL_sv_yes);
133 33           PUTBACK;
134             }
135              
136 33           true_unregister(aTHX_ filename);
137              
138             done:
139 33           return annotation->op_ppaddr(aTHX);
140             }
141              
142             MODULE = true PACKAGE = true
143              
144             PROTOTYPES: ENABLE
145              
146             BOOT:
147 11           TRUE_ANNOTATIONS = op_annotation_group_new();
148 11           TRUE_HASH = get_hv("true::TRUE", GV_ADD);
149              
150             void
151             END()
152             PROTOTYPE:
153             CODE:
154 11 50         if (TRUE_ANNOTATIONS) { /* make sure it was initialised */
155 11           op_annotation_group_free(aTHX_ TRUE_ANNOTATIONS);
156             }
157              
158             void
159             xs_enter()
160             PROTOTYPE:
161             CODE:
162             /* don't hook OP_LEAVEEVAL if it's already been hooked */
163 41 100         if (TRUE_COMPILING == 0) {
164 31           TRUE_COMPILING = 1;
165 31           TRUE_CHECK_LEAVEEVAL_ID = hook_op_check(OP_LEAVEEVAL, true_check_leaveeval, NULL);
166             }
167              
168             void
169             xs_leave()
170             PROTOTYPE:
171             CODE:
172 4           true_leave(aTHX);