File Coverage

Pluggable.xs
Criterion Covered Total %
statement 87 100 87.0
branch 53 98 54.0
condition n/a
subroutine n/a
pod n/a
total 140 198 70.7


line stmt bran cond sub pod time code
1             /*
2             Copyright 2012, 2013, 2017 Lukas Mai.
3              
4             This program is free software; you can redistribute it and/or modify it
5             under the terms of either: the GNU General Public License as published
6             by the Free Software Foundation; or the Artistic License.
7              
8             See http://dev.perl.org/licenses/ for more information.
9             */
10              
11             #ifdef __GNUC__
12             #if __GNUC__ >= 5
13             #define IF_HAVE_GCC_5(X) X
14             #endif
15              
16             #if (__GNUC__ == 4 && __GNUC_MINOR__ >= 6) || __GNUC__ >= 5
17             #define PRAGMA_GCC_(X) _Pragma(#X)
18             #define PRAGMA_GCC(X) PRAGMA_GCC_(GCC X)
19             #endif
20             #endif
21              
22             #ifndef IF_HAVE_GCC_5
23             #define IF_HAVE_GCC_5(X)
24             #endif
25              
26             #ifndef PRAGMA_GCC
27             #define PRAGMA_GCC(X)
28             #endif
29              
30             #ifdef DEVEL
31             #define WARNINGS_RESET PRAGMA_GCC(diagnostic pop)
32             #define WARNINGS_ENABLEW(X) PRAGMA_GCC(diagnostic error #X)
33             #define WARNINGS_ENABLE \
34             WARNINGS_ENABLEW(-Wall) \
35             WARNINGS_ENABLEW(-Wextra) \
36             WARNINGS_ENABLEW(-Wundef) \
37             WARNINGS_ENABLEW(-Wshadow) \
38             WARNINGS_ENABLEW(-Wbad-function-cast) \
39             WARNINGS_ENABLEW(-Wcast-align) \
40             WARNINGS_ENABLEW(-Wwrite-strings) \
41             WARNINGS_ENABLEW(-Wstrict-prototypes) \
42             WARNINGS_ENABLEW(-Wmissing-prototypes) \
43             WARNINGS_ENABLEW(-Winline) \
44             WARNINGS_ENABLEW(-Wdisabled-optimization) \
45             IF_HAVE_GCC_5(WARNINGS_ENABLEW(-Wnested-externs))
46              
47             #else
48             #define WARNINGS_RESET
49             #define WARNINGS_ENABLE
50             #endif
51              
52              
53             #define PERL_NO_GET_CONTEXT
54             #include "EXTERN.h"
55             #include "perl.h"
56             #include "XSUB.h"
57              
58             #include
59             #include
60              
61             #ifdef DEVEL
62             #undef NDEBUG
63             #endif
64             #include
65              
66             #define HAVE_PERL_VERSION(R, V, S) \
67             (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
68              
69             #ifndef STATIC_ASSERT_STMT
70             #if (defined(static_assert) || (defined(__cplusplus) && __cplusplus >= 201103L)) && (!defined(__IBMC__) || __IBMC__ >= 1210)
71             /* static_assert is a macro defined in in C11 or a compiler
72             builtin in C++11. But IBM XL C V11 does not support _Static_assert, no
73             matter what says.
74             */
75             # define STATIC_ASSERT_DECL(COND) static_assert(COND, #COND)
76             #else
77             /* We use a bit-field instead of an array because gcc accepts
78             'typedef char x[n]' where n is not a compile-time constant.
79             We want to enforce constantness.
80             */
81             # define STATIC_ASSERT_2(COND, SUFFIX) \
82             typedef struct { \
83             unsigned int _static_assertion_failed_##SUFFIX : (COND) ? 1 : -1; \
84             } _static_assertion_failed_##SUFFIX PERL_UNUSED_DECL
85             # define STATIC_ASSERT_1(COND, SUFFIX) STATIC_ASSERT_2(COND, SUFFIX)
86             # define STATIC_ASSERT_DECL(COND) STATIC_ASSERT_1(COND, __LINE__)
87             #endif
88             /* We need this wrapper even in C11 because 'case X: static_assert(...);' is an
89             error (static_assert is a declaration, and only statements can have labels).
90             */
91             #define STATIC_ASSERT_STMT(COND) do { STATIC_ASSERT_DECL(COND); } while (0)
92             #endif
93              
94             WARNINGS_ENABLE
95              
96              
97             #define MY_PKG "Keyword::Pluggable"
98              
99             #define KEYWORDS "/keywords"
100             #define HINTK_KEYWORDS MY_PKG KEYWORDS
101              
102              
103             #ifndef PL_rsfp_filters
104             #define PL_rsfp_filters (PL_parser->rsfp_filters)
105             #endif
106              
107             #ifndef PL_parser_filtered
108             #if HAVE_PERL_VERSION(5, 15, 5)
109             #define PL_parser_filtered (PL_parser->filtered)
110             #else
111             #define PL_parser_filtered 0
112             #endif
113             #endif
114              
115             static HV * global_kw = NULL;
116              
117             static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
118              
119 14516           static SV *kw_handler(pTHX_ const char *kw_ptr, STRLEN kw_len, int * is_expr) {
120             HV *hints;
121 14516           SV **psv, *sv, *sv2 = NULL;
122             AV *av;
123             I32 kw_xlen;
124              
125              
126             /* don't bother doing anything fancy after a syntax error */
127 14516 50         if (PL_parser && PL_parser->error_count) {
    50          
128 0           return NULL;
129             }
130              
131             STATIC_ASSERT_STMT(~(STRLEN)0 > (U32)I32_MAX);
132 14516 50         if (kw_len > (STRLEN)I32_MAX) {
133 0           return NULL;
134             }
135 14516           kw_xlen = kw_len;
136 14516 50         if (lex_bufutf8()) {
137 0           kw_xlen = -kw_xlen;
138             }
139              
140 14516 50         if ((hints = GvHV(PL_hintgv)) && (psv = hv_fetchs(hints, HINTK_KEYWORDS, 0))) {
    100          
141 73           sv = *psv;
142 73 50         if (!(SvROK(sv) && (sv2 = SvRV(sv), SvTYPE(sv2) == SVt_PVHV))) {
    50          
143 0           croak("%s: internal error: $^H{'%s'} not a hashref: %"SVf, MY_PKG, HINTK_KEYWORDS, SVfARG(sv));
144             }
145 14443 50         } else if (PL_curstash && (psv = hv_fetchs(PL_curstash, KEYWORDS, 0))) {
    100          
146 13           sv = *psv;
147 13 50         if (SvTYPE(sv) != SVt_PVGV)
148 0 0         croak("%s: internal error: %s{'%s'} not a stash: %"SVf, MY_PKG, HvNAME(PL_curstash), KEYWORDS, SVfARG(sv));
    0          
    0          
    0          
    0          
    0          
149 13           sv2 = (SV*) GvHV((GV*) sv);
150             } else {
151 14430           sv2 = (SV*) global_kw;
152             }
153 14516 100         if (!sv2 || !(psv = hv_fetch((HV *)sv2, kw_ptr, kw_xlen, 0))) {
    100          
154 14501           return NULL;
155             }
156              
157 15           sv = *psv;
158 15 50         if (!(SvROK(sv) && (av = (AV*)SvRV(sv), SvTYPE((SV*)av) == SVt_PVAV))) {
    50          
159 0           croak("%s: internal error: $^H{'%s'}{'%.*s'} not an arrayref: %"SVf, MY_PKG, HINTK_KEYWORDS, (int)kw_len, kw_ptr, SVfARG(sv));
160             }
161              
162 15 50         if (av_len(av) != 1) {
163 0           croak("%s: internal error: $^H{'%s'}{'%.*s'} bad arrayref: %"SVf, MY_PKG, HINTK_KEYWORDS, (int)kw_len, kw_ptr, SVfARG(sv));
164             }
165              
166 15 50         if ( !( psv = av_fetch(av, 0, 0))) {
167 0           croak("%s: internal error: $^H{'%s'}{'%.*s'} bad item #0: %"SVf, MY_PKG, HINTK_KEYWORDS, (int)kw_len, kw_ptr, SVfARG(sv));
168             }
169 15           sv2 = *psv;
170              
171 15 50         if ( !( psv = av_fetch(av, 1, 0))) {
172 0           croak("%s: internal error: $^H{'%s'}{'%.*s'} bad item #1: %"SVf, MY_PKG, HINTK_KEYWORDS, (int)kw_len, kw_ptr, SVfARG(sv));
173             }
174 15 50         *is_expr = SvIV(*psv);
175              
176 15           return sv2;
177             }
178              
179 107           static I32 playback(pTHX_ int idx, SV *buf, int n) {
180             char *ptr;
181             STRLEN len, d;
182 107 50         SV *sv = FILTER_DATA(idx);
183              
184 107 50         ptr = SvPV(sv, len);
185 107 100         if (!len) {
186 12           return 0;
187             }
188              
189 95 100         if (!n) {
190 88           char *nl = memchr(ptr, '\n', len);
191 88 50         d = nl ? (STRLEN)(nl - ptr + 1) : len;
192             } else {
193 7 50         d = n < 0 ? INT_MAX : n;
194 7 50         if (d > len) {
195 7           d = len;
196             }
197             }
198              
199 95           sv_catpvn(buf, ptr, d);
200 95           sv_chop(sv, ptr + d);
201 107           return 1;
202             }
203              
204 15           static void total_recall(pTHX_ SV *cb) {
205             SV *sv;
206 15           dSP;
207              
208 15           ENTER;
209 15           SAVETMPS;
210              
211 15           sv = sv_2mortal(newSVpvs(""));
212 15 50         if (lex_bufutf8()) {
213 0           SvUTF8_on(sv);
214             }
215              
216             /* sluuuuuurrrrp */
217              
218 15           sv_setpvn(sv, PL_parser->bufptr, PL_parser->bufend - PL_parser->bufptr);
219 15           lex_unstuff(PL_parser->bufend); /* you saw nothing */
220              
221 15 100         if (PL_parser->rsfp || PL_parser_filtered) {
    50          
222 12 50         if (!PL_rsfp_filters) {
223             /* because FILTER_READ fails with filters=null but DTRT with filters=[] */
224 0           PL_rsfp_filters = newAV();
225             }
226 24 100         while (FILTER_READ(0, sv, 4096) > 0)
227             ;
228             }
229              
230 15 50         PUSHMARK(SP);
231 15 50         mXPUSHs(newRV_inc(sv));
232 15           PUTBACK;
233              
234 15           call_sv(cb, G_VOID);
235 15           SPAGAIN;
236              
237             { /* $sv .= "\n" */
238             char *p;
239             STRLEN n;
240 15 50         SvPV_force(sv, n);
241 15 50         p = SvGROW(sv, n + 2);
    50          
242 15           p[n] = '\n';
243 15           p[n + 1] = '\0';
244 15           SvCUR_set(sv, n + 1);
245             }
246              
247 15 100         if (PL_parser->rsfp || PL_parser_filtered) {
    50          
248 12           filter_add(playback, SvREFCNT_inc_simple_NN(sv));
249 12           CopLINE_dec(PL_curcop);
250             } else {
251 3           lex_stuff_sv(sv, 0);
252             }
253              
254 15 50         FREETMPS;
255 15           LEAVE;
256 15           }
257              
258 14516           static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) {
259             SV *cb;
260             int is_expr;
261              
262 14516 100         if ((cb = kw_handler(aTHX_ keyword_ptr, keyword_len, &is_expr))) {
263 15           total_recall(aTHX_ cb);
264 15 100         if ( is_expr ) {
265 3           *op_ptr = parse_fullexpr(0);
266 3           return KEYWORD_PLUGIN_EXPR;
267             } else {
268 12           *op_ptr = newOP(OP_NULL, 0);
269 12           return KEYWORD_PLUGIN_STMT;
270             }
271             }
272              
273 14516           return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
274             }
275              
276              
277 6           static void my_boot(pTHX) {
278 6           HV *const stash = gv_stashpvs(MY_PKG, GV_ADD);
279              
280 6           newCONSTSUB(stash, "HINTK_KEYWORDS", newSVpvs(HINTK_KEYWORDS));
281              
282 6           next_keyword_plugin = PL_keyword_plugin;
283 6           PL_keyword_plugin = my_keyword_plugin;
284 6           global_kw = newHV();
285 6           }
286              
287             WARNINGS_RESET
288              
289             MODULE = Keyword::Pluggable PACKAGE = Keyword::Pluggable
290             PROTOTYPES: ENABLE
291              
292             BOOT:
293 6           my_boot(aTHX);
294              
295              
296             void define_global (char *kw, SV *entry)
297             PPCODE:
298             {
299 2 50         if ( !global_kw ) return;
300 2           hv_store( global_kw, kw, strlen(kw), newSVsv(entry), 0);
301             }
302              
303             void undefine_global (char *kw)
304             PPCODE:
305             {
306 0 0         if ( !global_kw ) return;
307 0           hv_delete( global_kw, kw, strlen(kw), G_DISCARD);
308             }
309              
310             void cleanup()
311             PPCODE:
312             {
313 6           sv_free(( SV *) global_kw);
314 6           global_kw = NULL;
315             }
316