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); |