Commit | Line | Data |
db81d362 |
1 | /* |
2 | Copyright 2012 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__ == 4 && __GNUC_MINOR__ >= 6) || __GNUC__ >= 5 |
13 | #define PRAGMA_GCC_(X) _Pragma(#X) |
14 | #define PRAGMA_GCC(X) PRAGMA_GCC_(GCC X) |
15 | #endif |
16 | #endif |
17 | |
18 | #ifndef PRAGMA_GCC |
19 | #define PRAGMA_GCC(X) |
20 | #endif |
21 | |
22 | #ifdef DEVEL |
23 | #define WARNINGS_RESET PRAGMA_GCC(diagnostic pop) |
24 | #define WARNINGS_ENABLEW(X) PRAGMA_GCC(diagnostic warning #X) |
25 | #define WARNINGS_ENABLE \ |
26 | WARNINGS_ENABLEW(-Wall) \ |
27 | WARNINGS_ENABLEW(-Wextra) \ |
28 | WARNINGS_ENABLEW(-Wundef) \ |
c3e72f35 |
29 | /* WARNINGS_ENABLEW(-Wshadow) :-( */ \ |
db81d362 |
30 | WARNINGS_ENABLEW(-Wbad-function-cast) \ |
31 | WARNINGS_ENABLEW(-Wcast-align) \ |
32 | WARNINGS_ENABLEW(-Wwrite-strings) \ |
33 | /* WARNINGS_ENABLEW(-Wnested-externs) wtf? */ \ |
34 | WARNINGS_ENABLEW(-Wstrict-prototypes) \ |
35 | WARNINGS_ENABLEW(-Wmissing-prototypes) \ |
36 | WARNINGS_ENABLEW(-Winline) \ |
37 | WARNINGS_ENABLEW(-Wdisabled-optimization) |
38 | |
39 | #else |
40 | #define WARNINGS_RESET |
1bc47886 |
41 | #define WARNINGS_ENABLE |
db81d362 |
42 | #endif |
43 | |
44 | |
7dd35535 |
45 | #define PERL_NO_GET_CONTEXT |
db81d362 |
46 | #include "EXTERN.h" |
47 | #include "perl.h" |
48 | #include "XSUB.h" |
49 | |
50 | #include <string.h> |
51 | |
63915d26 |
52 | |
db81d362 |
53 | WARNINGS_ENABLE |
54 | |
db81d362 |
55 | |
7dd35535 |
56 | #define HAVE_PERL_VERSION(R, V, S) \ |
57 | (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S)))))) |
58 | |
de013990 |
59 | #if HAVE_PERL_VERSION(5, 16, 0) |
60 | #define IF_HAVE_PERL_5_16(YES, NO) YES |
61 | #else |
62 | #define IF_HAVE_PERL_5_16(YES, NO) NO |
63 | #endif |
64 | |
63915d26 |
65 | |
66 | #define MY_PKG "Function::Parameters" |
67 | |
68 | #define HINTK_KEYWORDS MY_PKG "/keywords" |
69 | #define HINTK_FLAGS_ MY_PKG "/flags:" |
70 | #define HINTK_SHIFT_ MY_PKG "/shift:" |
71 | #define HINTK_ATTRS_ MY_PKG "/attrs:" |
72 | |
73 | #define DEFSTRUCT(T) typedef struct T T; struct T |
74 | |
75 | DEFSTRUCT(DefaultParamSpec) { |
76 | DefaultParamSpec *next; |
77 | int limit; |
78 | SV *name; |
79 | OP *init; |
80 | }; |
81 | |
82 | enum { |
83 | FLAG_NAME_OK = 0x01, |
84 | FLAG_ANON_OK = 0x02, |
85 | FLAG_DEFAULT_ARGS = 0x04, |
86 | FLAG_CHECK_NARGS = 0x08 |
87 | }; |
88 | |
89 | DEFSTRUCT(KWSpec) { |
90 | unsigned flags; |
b72eb6ee |
91 | SV *shift; |
92 | SV *attrs; |
63915d26 |
93 | }; |
db81d362 |
94 | |
95 | static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **); |
96 | |
63915d26 |
97 | static int kw_flags(pTHX_ const char *kw_ptr, STRLEN kw_len, KWSpec *spec) { |
db81d362 |
98 | HV *hints; |
99 | SV *sv, **psv; |
100 | const char *p, *kw_active; |
101 | STRLEN kw_active_len; |
102 | |
63915d26 |
103 | spec->flags = 0; |
b72eb6ee |
104 | spec->shift = sv_2mortal(newSVpvs("")); |
105 | spec->attrs = sv_2mortal(newSVpvs("")); |
db81d362 |
106 | |
107 | if (!(hints = GvHV(PL_hintgv))) { |
108 | return FALSE; |
109 | } |
110 | if (!(psv = hv_fetchs(hints, HINTK_KEYWORDS, 0))) { |
111 | return FALSE; |
112 | } |
113 | sv = *psv; |
114 | kw_active = SvPV(sv, kw_active_len); |
115 | if (kw_active_len <= kw_len) { |
116 | return FALSE; |
117 | } |
e88490f6 |
118 | for ( |
119 | p = kw_active; |
120 | (p = strchr(p, *kw_ptr)) && |
121 | p < kw_active + kw_active_len - kw_len; |
122 | p++ |
123 | ) { |
db81d362 |
124 | if ( |
125 | (p == kw_active || p[-1] == ' ') && |
126 | p[kw_len] == ' ' && |
127 | memcmp(kw_ptr, p, kw_len) == 0 |
128 | ) { |
b72eb6ee |
129 | |
d970c3e7 |
130 | #define FETCH_HINTK_INTO(NAME, PTR, LEN, X) STMT_START { \ |
b72eb6ee |
131 | const char *fk_ptr_; \ |
132 | STRLEN fk_len_; \ |
133 | SV *fk_sv_; \ |
134 | fk_sv_ = sv_2mortal(newSVpvs(HINTK_ ## NAME)); \ |
135 | sv_catpvn(fk_sv_, PTR, LEN); \ |
136 | fk_ptr_ = SvPV(fk_sv_, fk_len_); \ |
137 | if (!((X) = hv_fetch(hints, fk_ptr_, fk_len_, 0))) { \ |
138 | croak("%s: internal error: $^H{'%.*s'} not set", MY_PKG, (int)fk_len_, fk_ptr_); \ |
139 | } \ |
d970c3e7 |
140 | } STMT_END |
b72eb6ee |
141 | |
63915d26 |
142 | FETCH_HINTK_INTO(FLAGS_, kw_ptr, kw_len, psv); |
143 | spec->flags = SvIV(*psv); |
db81d362 |
144 | |
b72eb6ee |
145 | FETCH_HINTK_INTO(SHIFT_, kw_ptr, kw_len, psv); |
146 | SvSetSV(spec->shift, *psv); |
db81d362 |
147 | |
b72eb6ee |
148 | FETCH_HINTK_INTO(ATTRS_, kw_ptr, kw_len, psv); |
149 | SvSetSV(spec->attrs, *psv); |
150 | |
151 | #undef FETCH_HINTK_INTO |
db81d362 |
152 | return TRUE; |
153 | } |
154 | } |
155 | return FALSE; |
156 | } |
157 | |
158 | |
159 | #include "toke_on_crack.c.inc" |
160 | |
161 | |
63915d26 |
162 | static void free_defspec(pTHX_ void *vp) { |
163 | DefaultParamSpec *dp = vp; |
164 | op_free(dp->init); |
165 | Safefree(dp); |
166 | } |
167 | |
311ced6f |
168 | static void free_ptr_op(pTHX_ void *vp) { |
c311cef3 |
169 | OP **pp = vp; |
170 | op_free(*pp); |
171 | Safefree(pp); |
172 | } |
173 | |
59016bfb |
174 | #define sv_eq_pvs(SV, S) my_sv_eq_pvn(aTHX_ SV, "" S "", sizeof (S) - 1) |
c311cef3 |
175 | |
59016bfb |
176 | static int my_sv_eq_pvn(pTHX_ SV *sv, const char *p, STRLEN n) { |
c311cef3 |
177 | STRLEN sv_len; |
178 | const char *sv_p = SvPV(sv, sv_len); |
59016bfb |
179 | return memcmp(sv_p, p, n) == 0; |
c311cef3 |
180 | } |
181 | |
182 | |
183 | #include "padop_on_crack.c.inc" |
184 | |
185 | |
186 | #if 0 |
187 | static PADOFFSET pad_add_my_sv(SV *name) { |
188 | PADOFFSET offset; |
189 | SV *namesv, *myvar; |
190 | char *p; |
191 | STRLEN len; |
192 | |
193 | p = SvPV(name, len); |
194 | myvar = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, 1); |
195 | offset = AvFILLp(PL_comppad); |
196 | SvPADMY_on(myvar); |
197 | if (*p == '@') { |
198 | SvUPGRADE(myvar, SVt_PVAV); |
199 | } else if (*p == '%') { |
200 | SvUPGRADE(myvar, SVt_PVHV); |
201 | } |
202 | PL_curpad = AvARRAY(PL_comppad); |
203 | namesv = newSV_type(SVt_PVMG); |
204 | sv_setpvn(namesv, p, len); |
205 | COP_SEQ_RANGE_LOW_set(namesv, PL_cop_seqmax); |
206 | COP_SEQ_RANGE_HIGH_set(namesv, PERL_PADSEQ_INTRO); |
207 | PL_cop_seqmax++; |
208 | av_store(PL_comppad_name, offset, namesv); |
209 | return offset; |
210 | } |
211 | #endif |
212 | |
213 | enum { |
214 | MY_ATTR_LVALUE = 0x01, |
215 | MY_ATTR_METHOD = 0x02, |
216 | MY_ATTR_SPECIAL = 0x04 |
217 | }; |
218 | |
63915d26 |
219 | static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len, const KWSpec *spec) { |
c311cef3 |
220 | SV *declarator; |
221 | I32 floor_ix; |
63915d26 |
222 | int save_ix; |
c311cef3 |
223 | SV *saw_name; |
1e0f1595 |
224 | OP **prelude_sentinel; |
c311cef3 |
225 | AV *params; |
63915d26 |
226 | DefaultParamSpec *defaults; |
227 | int args_min, args_max; |
c311cef3 |
228 | SV *proto; |
229 | OP **attrs_sentinel, *body; |
230 | unsigned builtin_attrs; |
db81d362 |
231 | STRLEN len; |
232 | char *s; |
233 | I32 c; |
234 | |
db81d362 |
235 | declarator = sv_2mortal(newSVpvn(keyword_ptr, keyword_len)); |
db81d362 |
236 | |
db81d362 |
237 | lex_read_space(0); |
238 | |
c311cef3 |
239 | builtin_attrs = 0; |
240 | |
db81d362 |
241 | /* function name */ |
c311cef3 |
242 | saw_name = NULL; |
db81d362 |
243 | s = PL_parser->bufptr; |
63915d26 |
244 | if ((spec->flags & FLAG_NAME_OK) && (len = S_scan_word(aTHX_ s, TRUE))) { |
c311cef3 |
245 | saw_name = sv_2mortal(newSVpvn_flags(s, len, PARSING_UTF ? SVf_UTF8 : 0)); |
246 | |
247 | if (PL_parser->expect != XSTATE) { |
248 | /* bail out early so we don't predeclare $saw_name */ |
249 | croak("In %"SVf": I was expecting a function body, not \"%"SVf"\"", SVfARG(declarator), SVfARG(saw_name)); |
250 | } |
251 | |
db81d362 |
252 | sv_catpvs(declarator, " "); |
c311cef3 |
253 | sv_catsv(declarator, saw_name); |
254 | |
255 | if ( |
256 | sv_eq_pvs(saw_name, "BEGIN") || |
257 | sv_eq_pvs(saw_name, "END") || |
258 | sv_eq_pvs(saw_name, "INIT") || |
259 | sv_eq_pvs(saw_name, "CHECK") || |
260 | sv_eq_pvs(saw_name, "UNITCHECK") |
261 | ) { |
262 | builtin_attrs |= MY_ATTR_SPECIAL; |
263 | } |
264 | |
db81d362 |
265 | lex_read_to(s + len); |
266 | lex_read_space(0); |
63915d26 |
267 | } else if (!(spec->flags & FLAG_ANON_OK)) { |
db81d362 |
268 | croak("I was expecting a function name, not \"%.*s\"", (int)(PL_parser->bufend - s), s); |
269 | } else { |
270 | sv_catpvs(declarator, " (anon)"); |
271 | } |
272 | |
63915d26 |
273 | /* we're a subroutine declaration */ |
c311cef3 |
274 | floor_ix = start_subparse(FALSE, saw_name ? 0 : CVf_ANON); |
275 | SAVEFREESV(PL_compcv); |
276 | |
63915d26 |
277 | /* create outer block: '{' */ |
278 | save_ix = S_block_start(aTHX_ TRUE); |
279 | |
1e0f1595 |
280 | /* initialize synthetic optree */ |
281 | Newx(prelude_sentinel, 1, OP *); |
282 | *prelude_sentinel = NULL; |
283 | SAVEDESTRUCTOR_X(free_ptr_op, prelude_sentinel); |
284 | |
db81d362 |
285 | /* parameters */ |
c311cef3 |
286 | params = NULL; |
63915d26 |
287 | defaults = NULL; |
288 | args_min = 0; |
289 | args_max = -1; |
290 | |
1e0f1595 |
291 | /* my $self; */ |
292 | if (SvTRUE(spec->shift)) { |
293 | OP *var; |
294 | |
295 | var = newOP(OP_PADSV, OPf_MOD | (OPpLVAL_INTRO << 8)); |
296 | var->op_targ = pad_add_name_sv(spec->shift, 0, NULL, NULL); |
297 | |
298 | *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, var)); |
299 | } |
300 | |
db81d362 |
301 | c = lex_peek_unichar(0); |
302 | if (c == '(') { |
63915d26 |
303 | DefaultParamSpec **pdefaults_tail = &defaults; |
db81d362 |
304 | SV *saw_slurpy = NULL; |
63915d26 |
305 | int param_count = 0; |
306 | args_max = 0; |
db81d362 |
307 | |
308 | lex_read_unichar(0); |
309 | lex_read_space(0); |
310 | |
c311cef3 |
311 | params = newAV(); |
312 | sv_2mortal((SV *)params); |
313 | |
db81d362 |
314 | for (;;) { |
315 | c = lex_peek_unichar(0); |
f5cc9bdd |
316 | if (c == '$' || c == '@' || c == '%') { |
63915d26 |
317 | const char sigil = c; |
c311cef3 |
318 | SV *param; |
319 | |
63915d26 |
320 | param_count++; |
321 | |
db81d362 |
322 | lex_read_unichar(0); |
323 | lex_read_space(0); |
324 | |
325 | s = PL_parser->bufptr; |
7dd35535 |
326 | if (!(len = S_scan_word(aTHX_ s, FALSE))) { |
85bc3fbd |
327 | croak("In %"SVf": missing identifier", SVfARG(declarator)); |
db81d362 |
328 | } |
63915d26 |
329 | param = sv_2mortal(newSVpvf("%c%.*s", sigil, (int)len, s)); |
db81d362 |
330 | if (saw_slurpy) { |
c311cef3 |
331 | croak("In %"SVf": I was expecting \")\" after \"%"SVf"\", not \"%"SVf"\"", SVfARG(declarator), SVfARG(saw_slurpy), SVfARG(param)); |
db81d362 |
332 | } |
63915d26 |
333 | if (sigil == '$') { |
334 | args_max++; |
335 | } else { |
336 | args_max = -1; |
c311cef3 |
337 | saw_slurpy = param; |
db81d362 |
338 | } |
c311cef3 |
339 | av_push(params, SvREFCNT_inc_simple_NN(param)); |
db81d362 |
340 | lex_read_to(s + len); |
341 | lex_read_space(0); |
342 | |
343 | c = lex_peek_unichar(0); |
63915d26 |
344 | |
345 | if (!(c == '=' && (spec->flags & FLAG_DEFAULT_ARGS))) { |
346 | if (sigil == '$' && !defaults) { |
347 | args_min++; |
348 | } |
349 | } else if (sigil != '$') { |
350 | croak("In %"SVf": %s %"SVf" can't have a default value", SVfARG(declarator), sigil == '@' ? "array" : "hash", SVfARG(saw_slurpy)); |
351 | } else { |
352 | DefaultParamSpec *curdef; |
353 | |
354 | lex_read_unichar(0); |
355 | lex_read_space(0); |
356 | |
357 | Newx(curdef, 1, DefaultParamSpec); |
358 | curdef->next = NULL; |
359 | curdef->limit = param_count; |
360 | curdef->name = param; |
361 | curdef->init = NULL; |
362 | SAVEDESTRUCTOR_X(free_defspec, curdef); |
363 | |
364 | curdef->next = *pdefaults_tail; |
365 | *pdefaults_tail = curdef; |
366 | pdefaults_tail = &curdef->next; |
367 | |
368 | /* let perl parse the default parameter value */ |
369 | curdef->init = parse_termexpr(0); |
370 | |
371 | lex_read_space(0); |
372 | c = lex_peek_unichar(0); |
373 | } |
374 | |
1e0f1595 |
375 | /* my $param; */ |
376 | { |
377 | OP *var; |
378 | |
379 | var = newOP(OP_PADSV, OPf_MOD | (OPpLVAL_INTRO << 8)); |
380 | var->op_targ = pad_add_name_sv(param, 0, NULL, NULL); |
381 | |
382 | *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, var)); |
383 | } |
384 | |
db81d362 |
385 | if (c == ',') { |
386 | lex_read_unichar(0); |
387 | lex_read_space(0); |
388 | continue; |
389 | } |
390 | } |
391 | |
392 | if (c == ')') { |
393 | lex_read_unichar(0); |
394 | lex_read_space(0); |
395 | break; |
396 | } |
397 | |
398 | if (c == -1) { |
85bc3fbd |
399 | croak("In %"SVf": unexpected EOF in parameter list", SVfARG(declarator)); |
db81d362 |
400 | } |
85bc3fbd |
401 | croak("In %"SVf": unexpected '%c' in parameter list", SVfARG(declarator), (int)c); |
db81d362 |
402 | } |
403 | } |
404 | |
405 | /* prototype */ |
c311cef3 |
406 | proto = NULL; |
db81d362 |
407 | c = lex_peek_unichar(0); |
408 | if (c == ':') { |
409 | lex_read_unichar(0); |
410 | lex_read_space(0); |
411 | |
412 | c = lex_peek_unichar(0); |
413 | if (c != '(') { |
c311cef3 |
414 | lex_stuff_pvs(":", 0); |
415 | c = ':'; |
db81d362 |
416 | } else { |
c311cef3 |
417 | proto = sv_2mortal(newSVpvs("")); |
418 | if (!S_scan_str(aTHX_ proto, FALSE, FALSE)) { |
f34187b8 |
419 | croak("In %"SVf": prototype not terminated", SVfARG(declarator)); |
db81d362 |
420 | } |
311ced6f |
421 | S_check_prototype(aTHX_ declarator, proto); |
db81d362 |
422 | lex_read_space(0); |
c311cef3 |
423 | c = lex_peek_unichar(0); |
db81d362 |
424 | } |
425 | } |
426 | |
db81d362 |
427 | /* attributes */ |
c311cef3 |
428 | Newx(attrs_sentinel, 1, OP *); |
429 | *attrs_sentinel = NULL; |
311ced6f |
430 | SAVEDESTRUCTOR_X(free_ptr_op, attrs_sentinel); |
c311cef3 |
431 | |
63915d26 |
432 | if (c == ':' || c == '{') /* '}' - hi, vim */ { |
c311cef3 |
433 | |
434 | /* kludge default attributes in */ |
435 | if (SvTRUE(spec->attrs) && SvPV_nolen(spec->attrs)[0] == ':') { |
436 | lex_stuff_sv(spec->attrs, 0); |
437 | c = ':'; |
438 | } |
b72eb6ee |
439 | |
db81d362 |
440 | if (c == ':') { |
db81d362 |
441 | lex_read_unichar(0); |
442 | lex_read_space(0); |
db81d362 |
443 | c = lex_peek_unichar(0); |
c311cef3 |
444 | |
445 | for (;;) { |
446 | SV *attr; |
447 | |
448 | s = PL_parser->bufptr; |
449 | if (!(len = S_scan_word(aTHX_ s, FALSE))) { |
450 | break; |
db81d362 |
451 | } |
c311cef3 |
452 | |
453 | attr = sv_2mortal(newSVpvn_flags(s, len, PARSING_UTF ? SVf_UTF8 : 0)); |
454 | |
455 | lex_read_to(s + len); |
db81d362 |
456 | lex_read_space(0); |
457 | c = lex_peek_unichar(0); |
c311cef3 |
458 | |
459 | if (c != '(') { |
460 | if (sv_eq_pvs(attr, "lvalue")) { |
461 | builtin_attrs |= MY_ATTR_LVALUE; |
462 | attr = NULL; |
463 | } else if (sv_eq_pvs(attr, "method")) { |
464 | builtin_attrs |= MY_ATTR_METHOD; |
465 | attr = NULL; |
466 | } |
467 | } else { |
468 | SV *sv = sv_2mortal(newSVpvs("")); |
469 | if (!S_scan_str(aTHX_ sv, TRUE, TRUE)) { |
470 | croak("In %"SVf": unterminated attribute parameter in attribute list", SVfARG(declarator)); |
471 | } |
472 | sv_catsv(attr, sv); |
473 | |
474 | lex_read_space(0); |
475 | c = lex_peek_unichar(0); |
476 | } |
477 | |
478 | if (attr) { |
479 | *attrs_sentinel = op_append_elem(OP_LIST, *attrs_sentinel, newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(attr))); |
480 | } |
481 | |
482 | if (c == ':') { |
483 | lex_read_unichar(0); |
484 | lex_read_space(0); |
485 | c = lex_peek_unichar(0); |
486 | } |
db81d362 |
487 | } |
488 | } |
489 | } |
490 | |
491 | /* body */ |
63915d26 |
492 | if (c != '{') /* '}' - hi, vim */ { |
85bc3fbd |
493 | croak("In %"SVf": I was expecting a function body, not \"%c\"", SVfARG(declarator), (int)c); |
db81d362 |
494 | } |
c311cef3 |
495 | |
63915d26 |
496 | /* surprise predeclaration! */ |
497 | if (saw_name) { |
498 | /* 'sub NAME (PROTO);' to make name/proto known to perl before it |
499 | starts parsing the body */ |
500 | const I32 sub_ix = start_subparse(FALSE, 0); |
501 | SAVEFREESV(PL_compcv); |
502 | |
503 | SvREFCNT_inc_simple_void(PL_compcv); |
504 | |
505 | newATTRSUB( |
506 | sub_ix, |
507 | newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(saw_name)), |
508 | proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL, |
509 | NULL, |
510 | NULL |
511 | ); |
512 | } |
513 | |
c311cef3 |
514 | if (builtin_attrs & MY_ATTR_LVALUE) { |
515 | CvLVALUE_on(PL_compcv); |
db81d362 |
516 | } |
c311cef3 |
517 | if (builtin_attrs & MY_ATTR_METHOD) { |
518 | CvMETHOD_on(PL_compcv); |
519 | } |
520 | if (builtin_attrs & MY_ATTR_SPECIAL) { |
521 | CvSPECIAL_on(PL_compcv); |
db81d362 |
522 | } |
523 | |
1e0f1595 |
524 | /* min/max argument count checks */ |
525 | if (spec->flags & FLAG_CHECK_NARGS) { |
526 | if (SvTRUE(spec->shift)) { |
527 | args_min++; |
528 | if (args_max != -1) { |
529 | args_max++; |
abccbe86 |
530 | } |
1e0f1595 |
531 | } |
abccbe86 |
532 | |
1e0f1595 |
533 | if (args_min > 0) { |
534 | OP *chk, *cond, *err, *croak; |
63915d26 |
535 | |
1e0f1595 |
536 | err = newSVOP(OP_CONST, 0, |
537 | newSVpvf("Not enough arguments for %"SVf, SVfARG(declarator))); |
63915d26 |
538 | |
1e0f1595 |
539 | croak = newCVREF(OPf_WANT_SCALAR, |
540 | newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV))); |
541 | err = newUNOP(OP_ENTERSUB, OPf_STACKED, |
542 | op_append_elem(OP_LIST, err, croak)); |
63915d26 |
543 | |
1e0f1595 |
544 | cond = newBINOP(OP_LT, 0, |
545 | newAVREF(newGVOP(OP_GV, 0, PL_defgv)), |
546 | newSVOP(OP_CONST, 0, newSViv(args_min))); |
547 | chk = newLOGOP(OP_AND, 0, cond, err); |
63915d26 |
548 | |
1e0f1595 |
549 | *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, chk)); |
550 | } |
551 | if (args_max != -1) { |
552 | OP *chk, *cond, *err, *croak; |
63915d26 |
553 | |
1e0f1595 |
554 | err = newSVOP(OP_CONST, 0, |
555 | newSVpvf("Too many arguments for %"SVf, SVfARG(declarator))); |
63915d26 |
556 | |
1e0f1595 |
557 | croak = newCVREF(OPf_WANT_SCALAR, |
558 | newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV))); |
559 | err = newUNOP(OP_ENTERSUB, OPf_STACKED, |
560 | op_append_elem(OP_LIST, err, croak)); |
63915d26 |
561 | |
1e0f1595 |
562 | cond = newBINOP(OP_GT, 0, |
563 | newAVREF(newGVOP(OP_GV, 0, PL_defgv)), |
564 | newSVOP(OP_CONST, 0, newSViv(args_max))); |
565 | chk = newLOGOP(OP_AND, 0, cond, err); |
63915d26 |
566 | |
1e0f1595 |
567 | *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, chk)); |
c311cef3 |
568 | } |
1e0f1595 |
569 | } |
c311cef3 |
570 | |
1e0f1595 |
571 | /* $self = shift; */ |
572 | if (SvTRUE(spec->shift)) { |
573 | OP *var, *shift; |
abccbe86 |
574 | |
1e0f1595 |
575 | var = newOP(OP_PADSV, OPf_WANT_SCALAR); |
576 | var->op_targ = pad_findmy_sv(spec->shift, 0); |
c311cef3 |
577 | |
1e0f1595 |
578 | shift = newASSIGNOP(OPf_STACKED, var, 0, newOP(OP_SHIFT, 0)); |
579 | *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, shift)); |
580 | } |
c311cef3 |
581 | |
1e0f1595 |
582 | /* (PARAMS) = @_; */ |
583 | if (params && av_len(params) > -1) { |
584 | SV *param; |
585 | OP *init_param, *left, *right; |
586 | |
587 | left = NULL; |
588 | while ((param = av_shift(params)) != &PL_sv_undef) { |
589 | OP *const var = newOP(OP_PADSV, OPf_WANT_LIST); |
590 | var->op_targ = pad_findmy_sv(param, 0); |
591 | SvREFCNT_dec(param); |
592 | left = op_append_elem(OP_LIST, left, var); |
c311cef3 |
593 | } |
594 | |
1e0f1595 |
595 | left->op_flags |= OPf_PARENS; |
596 | right = newAVREF(newGVOP(OP_GV, 0, PL_defgv)); |
597 | init_param = newASSIGNOP(OPf_STACKED, left, 0, right); |
598 | init_param = newSTATEOP(0, NULL, init_param); |
63915d26 |
599 | |
1e0f1595 |
600 | *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, init_param); |
601 | } |
63915d26 |
602 | |
1e0f1595 |
603 | /* defaults */ |
604 | { |
605 | OP *gen = NULL; |
606 | DefaultParamSpec *dp; |
63915d26 |
607 | |
1e0f1595 |
608 | for (dp = defaults; dp; dp = dp->next) { |
609 | OP *init = dp->init; |
610 | OP *var, *args, *cond; |
63915d26 |
611 | |
1e0f1595 |
612 | /* var = `$,name */ |
613 | var = newOP(OP_PADSV, 0); |
614 | var->op_targ = pad_findmy_sv(dp->name, 0); |
63915d26 |
615 | |
1e0f1595 |
616 | /* init = `,var = ,init */ |
617 | init = newASSIGNOP(OPf_STACKED, var, 0, init); |
63915d26 |
618 | |
1e0f1595 |
619 | /* args = `@_ */ |
620 | args = newAVREF(newGVOP(OP_GV, 0, PL_defgv)); |
63915d26 |
621 | |
1e0f1595 |
622 | /* cond = `,args < ,index */ |
623 | cond = newBINOP(OP_LT, 0, args, newSVOP(OP_CONST, 0, newSViv(dp->limit))); |
63915d26 |
624 | |
1e0f1595 |
625 | /* init = `,init if ,cond */ |
626 | init = newLOGOP(OP_AND, 0, cond, init); |
63915d26 |
627 | |
1e0f1595 |
628 | /* gen = `,gen ; ,init */ |
629 | gen = op_append_list(OP_LINESEQ, gen, newSTATEOP(0, NULL, init)); |
630 | |
631 | dp->init = NULL; |
c311cef3 |
632 | } |
633 | |
1e0f1595 |
634 | *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, gen); |
635 | } |
c311cef3 |
636 | |
1e0f1595 |
637 | /* finally let perl parse the actual subroutine body */ |
638 | body = parse_block(0); |
c311cef3 |
639 | |
1e0f1595 |
640 | /* add '();' to make function return nothing by default */ |
641 | /* (otherwise the invisible parameter initialization can "leak" into |
642 | the return value: fun ($x) {}->("asdf", 0) == 2) */ |
643 | if (*prelude_sentinel) { |
644 | body = newSTATEOP(0, NULL, body); |
db81d362 |
645 | } |
646 | |
1e0f1595 |
647 | body = op_append_list(OP_LINESEQ, *prelude_sentinel, body); |
648 | *prelude_sentinel = NULL; |
649 | |
c311cef3 |
650 | /* it's go time. */ |
651 | { |
652 | OP *const attrs = *attrs_sentinel; |
653 | *attrs_sentinel = NULL; |
654 | SvREFCNT_inc_simple_void(PL_compcv); |
655 | |
63915d26 |
656 | /* close outer block: '}' */ |
657 | S_block_end(aTHX_ save_ix, body); |
658 | |
c311cef3 |
659 | if (!saw_name) { |
660 | *pop = newANONATTRSUB( |
661 | floor_ix, |
662 | proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL, |
663 | attrs, |
664 | body |
665 | ); |
666 | return KEYWORD_PLUGIN_EXPR; |
667 | } |
668 | |
669 | newATTRSUB( |
670 | floor_ix, |
671 | newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(saw_name)), |
672 | proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL, |
673 | attrs, |
674 | body |
675 | ); |
676 | *pop = NULL; |
677 | return KEYWORD_PLUGIN_STMT; |
db81d362 |
678 | } |
db81d362 |
679 | } |
680 | |
681 | static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) { |
63915d26 |
682 | KWSpec spec; |
db81d362 |
683 | int ret; |
684 | |
685 | SAVETMPS; |
686 | |
7dd35535 |
687 | if (kw_flags(aTHX_ keyword_ptr, keyword_len, &spec)) { |
688 | ret = parse_fun(aTHX_ op_ptr, keyword_ptr, keyword_len, &spec); |
db81d362 |
689 | } else { |
7dd35535 |
690 | ret = next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr); |
db81d362 |
691 | } |
692 | |
693 | FREETMPS; |
694 | |
695 | return ret; |
696 | } |
697 | |
698 | WARNINGS_RESET |
699 | |
700 | MODULE = Function::Parameters PACKAGE = Function::Parameters |
701 | PROTOTYPES: ENABLE |
702 | |
703 | BOOT: |
704 | WARNINGS_ENABLE { |
705 | HV *const stash = gv_stashpvs(MY_PKG, GV_ADD); |
426a4d69 |
706 | /**/ |
63915d26 |
707 | newCONSTSUB(stash, "FLAG_NAME_OK", newSViv(FLAG_NAME_OK)); |
708 | newCONSTSUB(stash, "FLAG_ANON_OK", newSViv(FLAG_ANON_OK)); |
709 | newCONSTSUB(stash, "FLAG_DEFAULT_ARGS", newSViv(FLAG_DEFAULT_ARGS)); |
710 | newCONSTSUB(stash, "FLAG_CHECK_NARGS", newSViv(FLAG_CHECK_NARGS)); |
db81d362 |
711 | newCONSTSUB(stash, "HINTK_KEYWORDS", newSVpvs(HINTK_KEYWORDS)); |
63915d26 |
712 | newCONSTSUB(stash, "HINTK_FLAGS_", newSVpvs(HINTK_FLAGS_)); |
db81d362 |
713 | newCONSTSUB(stash, "HINTK_SHIFT_", newSVpvs(HINTK_SHIFT_)); |
b72eb6ee |
714 | newCONSTSUB(stash, "HINTK_ATTRS_", newSVpvs(HINTK_ATTRS_)); |
426a4d69 |
715 | /**/ |
db81d362 |
716 | next_keyword_plugin = PL_keyword_plugin; |
717 | PL_keyword_plugin = my_keyword_plugin; |
718 | } WARNINGS_RESET |