File Coverage

true.xs

Criterion	Covered	Total	%
statement	42	44	95.4
branch	37	100	37.0
condition			n/a
subroutine			n/a
pod			n/a
total	79	144	54.8

line	stmt	bran	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 module 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	33		bool returns_true = FALSE;
98
99			#if (PERL_BCDVERSION >= 0x5024000)
100	33		SV ** oldsp = PL_stack_base + cx->blk_oldsp;
101			#endif
102
103			/* make sure it hasn't been unimported */
104	33	50	if ((CxOLD_OP_TYPE(cx) == OP_REQUIRE) && true_enabled(aTHX_ filename)) {
		50
105
106			#if (PERL_BCDVERSION >= 0x5024000)
107			/*
108			* on perl < 5.24, forcibly return true regardless of whether or not
109			* it's needed (i.e. don't run this check to see if the module has
110			* returned true).
111			*
112			* XXX this is a hack to fix RT-124745 [1]. it's no longer needed on
113			* perl >= 5.24
114			*
115			* [1] https://rt.cpan.org/Public/Bug/Display.html?id=124745
116			*/
117
118			/* XXX is the context ever not scalar? */
119	33	50	if (cx->blk_gimme == G_SCALAR) {
120			/* sv_dump(SP); /
121	33	50	returns_true = SvTRUE_NN(*SP);
		100
		50
		50
		50
		0
		0
		0
		0
		50
		50
		50
		50
		0
122			} else {
123	0		returns_true = SP > oldsp;
124			}
125			#endif
126
127	33	50	if (!returns_true) {
128	33	50	XPUSHs(&PL_sv_yes);
129	33		PUTBACK;
130			}
131
132	33		true_unregister(aTHX_ filename);
133			}
134
135	33		return annotation->op_ppaddr(aTHX);
136			}
137
138			MODULE = true PACKAGE = true
139
140			PROTOTYPES: ENABLE
141
142			BOOT:
143	11		TRUE_ANNOTATIONS = op_annotation_group_new();
144	11		TRUE_HASH = get_hv("true::TRUE", GV_ADD);
145
146			void
147			END()
148			PROTOTYPE:
149			CODE:
150	11	50	if (TRUE_ANNOTATIONS) { /* make sure it was initialised */
151	11		op_annotation_group_free(aTHX_ TRUE_ANNOTATIONS);
152			}
153
154			void
155			xs_enter()
156			PROTOTYPE:
157			CODE:
158			/* don't hook OP_LEAVEEVAL if it's already been hooked */
159	41	100	if (TRUE_COMPILING == 0) {
160	31		TRUE_COMPILING = 1;
161	31		TRUE_CHECK_LEAVEEVAL_ID = hook_op_check(OP_LEAVEEVAL, true_check_leaveeval, NULL);
162			}
163
164			void
165			xs_leave()
166			PROTOTYPE:
167			CODE:
168	4		true_leave(aTHX);