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::Simple" |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
#define HINTK_KEYWORDS MY_PKG "/keywords" |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
#ifndef PL_rsfp_filters |
103
|
|
|
|
|
|
|
#define PL_rsfp_filters (PL_parser->rsfp_filters) |
104
|
|
|
|
|
|
|
#endif |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
#ifndef PL_parser_filtered |
107
|
|
|
|
|
|
|
#if HAVE_PERL_VERSION(5, 15, 5) |
108
|
|
|
|
|
|
|
#define PL_parser_filtered (PL_parser->filtered) |
109
|
|
|
|
|
|
|
#else |
110
|
|
|
|
|
|
|
#define PL_parser_filtered 0 |
111
|
|
|
|
|
|
|
#endif |
112
|
|
|
|
|
|
|
#endif |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **); |
116
|
|
|
|
|
|
|
|
117
|
3827
|
|
|
|
|
|
static SV *kw_handler(pTHX_ const char *kw_ptr, STRLEN kw_len) { |
118
|
|
|
|
|
|
|
HV *hints; |
119
|
|
|
|
|
|
|
SV **psv, *sv, *sv2; |
120
|
|
|
|
|
|
|
I32 kw_xlen; |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
/* don't bother doing anything fancy after a syntax error */ |
124
|
3827
|
50
|
|
|
|
|
if (PL_parser && PL_parser->error_count) { |
|
|
50
|
|
|
|
|
|
125
|
0
|
|
|
|
|
|
return NULL; |
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
STATIC_ASSERT_STMT(~(STRLEN)0 > (U32)I32_MAX); |
129
|
3827
|
50
|
|
|
|
|
if (kw_len > (STRLEN)I32_MAX) { |
130
|
0
|
|
|
|
|
|
return NULL; |
131
|
|
|
|
|
|
|
} |
132
|
|
|
|
|
|
|
|
133
|
3827
|
50
|
|
|
|
|
if (!(hints = GvHV(PL_hintgv))) { |
134
|
0
|
|
|
|
|
|
return NULL; |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
|
137
|
3827
|
100
|
|
|
|
|
if (!(psv = hv_fetchs(hints, HINTK_KEYWORDS, 0))) { |
138
|
3757
|
|
|
|
|
|
return NULL; |
139
|
|
|
|
|
|
|
} |
140
|
|
|
|
|
|
|
|
141
|
70
|
|
|
|
|
|
sv = *psv; |
142
|
70
|
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
|
|
|
|
|
|
|
|
146
|
70
|
|
|
|
|
|
kw_xlen = kw_len; |
147
|
70
|
50
|
|
|
|
|
if (lex_bufutf8()) { |
148
|
0
|
|
|
|
|
|
kw_xlen = -kw_xlen; |
149
|
|
|
|
|
|
|
} |
150
|
70
|
100
|
|
|
|
|
if (!(psv = hv_fetch((HV *)sv2, kw_ptr, kw_xlen, 0))) { |
151
|
60
|
|
|
|
|
|
return NULL; |
152
|
|
|
|
|
|
|
} |
153
|
|
|
|
|
|
|
|
154
|
10
|
|
|
|
|
|
sv = *psv; |
155
|
10
|
50
|
|
|
|
|
if (!(SvROK(sv) && (sv2 = SvRV(sv), SvTYPE(sv2) == SVt_PVCV))) { |
|
|
50
|
|
|
|
|
|
156
|
0
|
|
|
|
|
|
croak("%s: internal error: $^H{'%s'}{'%.*s'} not a coderef: %"SVf, MY_PKG, HINTK_KEYWORDS, (int)kw_len, kw_ptr, SVfARG(sv)); |
157
|
|
|
|
|
|
|
} |
158
|
|
|
|
|
|
|
|
159
|
10
|
|
|
|
|
|
return sv2; |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
|
162
|
72
|
|
|
|
|
|
static I32 playback(pTHX_ int idx, SV *buf, int n) { |
163
|
|
|
|
|
|
|
char *ptr; |
164
|
|
|
|
|
|
|
STRLEN len, d; |
165
|
72
|
50
|
|
|
|
|
SV *sv = FILTER_DATA(idx); |
166
|
|
|
|
|
|
|
|
167
|
72
|
50
|
|
|
|
|
ptr = SvPV(sv, len); |
168
|
72
|
100
|
|
|
|
|
if (!len) { |
169
|
7
|
|
|
|
|
|
return 0; |
170
|
|
|
|
|
|
|
} |
171
|
|
|
|
|
|
|
|
172
|
65
|
100
|
|
|
|
|
if (!n) { |
173
|
61
|
|
|
|
|
|
char *nl = memchr(ptr, '\n', len); |
174
|
61
|
50
|
|
|
|
|
d = nl ? (STRLEN)(nl - ptr + 1) : len; |
175
|
|
|
|
|
|
|
} else { |
176
|
4
|
50
|
|
|
|
|
d = n < 0 ? INT_MAX : n; |
177
|
4
|
50
|
|
|
|
|
if (d > len) { |
178
|
4
|
|
|
|
|
|
d = len; |
179
|
|
|
|
|
|
|
} |
180
|
|
|
|
|
|
|
} |
181
|
|
|
|
|
|
|
|
182
|
65
|
|
|
|
|
|
sv_catpvn(buf, ptr, d); |
183
|
65
|
|
|
|
|
|
sv_chop(sv, ptr + d); |
184
|
72
|
|
|
|
|
|
return 1; |
185
|
|
|
|
|
|
|
} |
186
|
|
|
|
|
|
|
|
187
|
10
|
|
|
|
|
|
static void total_recall(pTHX_ SV *cb) { |
188
|
|
|
|
|
|
|
SV *sv; |
189
|
10
|
|
|
|
|
|
dSP; |
190
|
|
|
|
|
|
|
|
191
|
10
|
|
|
|
|
|
ENTER; |
192
|
10
|
|
|
|
|
|
SAVETMPS; |
193
|
|
|
|
|
|
|
|
194
|
10
|
|
|
|
|
|
sv = sv_2mortal(newSVpvs("")); |
195
|
10
|
50
|
|
|
|
|
if (lex_bufutf8()) { |
196
|
0
|
|
|
|
|
|
SvUTF8_on(sv); |
197
|
|
|
|
|
|
|
} |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
/* sluuuuuurrrrp */ |
200
|
|
|
|
|
|
|
|
201
|
10
|
|
|
|
|
|
sv_setpvn(sv, PL_parser->bufptr, PL_parser->bufend - PL_parser->bufptr); |
202
|
10
|
|
|
|
|
|
lex_unstuff(PL_parser->bufend); /* you saw nothing */ |
203
|
|
|
|
|
|
|
|
204
|
10
|
100
|
|
|
|
|
if (PL_parser->rsfp || PL_parser_filtered) { |
|
|
50
|
|
|
|
|
|
205
|
7
|
50
|
|
|
|
|
if (!PL_rsfp_filters) { |
206
|
|
|
|
|
|
|
/* because FILTER_READ fails with filters=null but DTRT with filters=[] */ |
207
|
0
|
|
|
|
|
|
PL_rsfp_filters = newAV(); |
208
|
|
|
|
|
|
|
} |
209
|
14
|
100
|
|
|
|
|
while (FILTER_READ(0, sv, 4096) > 0) |
210
|
|
|
|
|
|
|
; |
211
|
|
|
|
|
|
|
} |
212
|
|
|
|
|
|
|
|
213
|
10
|
50
|
|
|
|
|
PUSHMARK(SP); |
214
|
10
|
50
|
|
|
|
|
mXPUSHs(newRV_inc(sv)); |
215
|
10
|
|
|
|
|
|
PUTBACK; |
216
|
|
|
|
|
|
|
|
217
|
10
|
|
|
|
|
|
call_sv(cb, G_VOID); |
218
|
10
|
|
|
|
|
|
SPAGAIN; |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
{ /* $sv .= "\n" */ |
221
|
|
|
|
|
|
|
char *p; |
222
|
|
|
|
|
|
|
STRLEN n; |
223
|
10
|
50
|
|
|
|
|
SvPV_force(sv, n); |
224
|
10
|
50
|
|
|
|
|
p = SvGROW(sv, n + 2); |
|
|
50
|
|
|
|
|
|
225
|
10
|
|
|
|
|
|
p[n] = '\n'; |
226
|
10
|
|
|
|
|
|
p[n + 1] = '\0'; |
227
|
10
|
|
|
|
|
|
SvCUR_set(sv, n + 1); |
228
|
|
|
|
|
|
|
} |
229
|
|
|
|
|
|
|
|
230
|
10
|
100
|
|
|
|
|
if (PL_parser->rsfp || PL_parser_filtered) { |
|
|
50
|
|
|
|
|
|
231
|
7
|
|
|
|
|
|
filter_add(playback, SvREFCNT_inc_simple_NN(sv)); |
232
|
7
|
|
|
|
|
|
CopLINE_dec(PL_curcop); |
233
|
|
|
|
|
|
|
} else { |
234
|
3
|
|
|
|
|
|
lex_stuff_sv(sv, 0); |
235
|
|
|
|
|
|
|
} |
236
|
|
|
|
|
|
|
|
237
|
10
|
50
|
|
|
|
|
FREETMPS; |
238
|
10
|
|
|
|
|
|
LEAVE; |
239
|
10
|
|
|
|
|
|
} |
240
|
|
|
|
|
|
|
|
241
|
3827
|
|
|
|
|
|
static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) { |
242
|
|
|
|
|
|
|
SV *cb; |
243
|
|
|
|
|
|
|
|
244
|
3827
|
100
|
|
|
|
|
if ((cb = kw_handler(aTHX_ keyword_ptr, keyword_len))) { |
245
|
10
|
|
|
|
|
|
total_recall(aTHX_ cb); |
246
|
10
|
|
|
|
|
|
*op_ptr = newOP(OP_NULL, 0); |
247
|
10
|
|
|
|
|
|
return KEYWORD_PLUGIN_STMT; |
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
|
250
|
3817
|
|
|
|
|
|
return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr); |
251
|
|
|
|
|
|
|
} |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
|
254
|
4
|
|
|
|
|
|
static void my_boot(pTHX) { |
255
|
4
|
|
|
|
|
|
HV *const stash = gv_stashpvs(MY_PKG, GV_ADD); |
256
|
|
|
|
|
|
|
|
257
|
4
|
|
|
|
|
|
newCONSTSUB(stash, "HINTK_KEYWORDS", newSVpvs(HINTK_KEYWORDS)); |
258
|
|
|
|
|
|
|
|
259
|
4
|
|
|
|
|
|
next_keyword_plugin = PL_keyword_plugin; |
260
|
4
|
|
|
|
|
|
PL_keyword_plugin = my_keyword_plugin; |
261
|
4
|
|
|
|
|
|
} |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
WARNINGS_RESET |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
MODULE = Keyword::Simple PACKAGE = Keyword::Simple |
266
|
|
|
|
|
|
|
PROTOTYPES: ENABLE |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
BOOT: |
269
|
4
|
|
|
|
|
|
my_boot(aTHX); |