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; |
224 | AV *params; |
63915d26 |
225 | DefaultParamSpec *defaults; |
226 | int args_min, args_max; |
c311cef3 |
227 | SV *proto; |
228 | OP **attrs_sentinel, *body; |
229 | unsigned builtin_attrs; |
db81d362 |
230 | STRLEN len; |
231 | char *s; |
232 | I32 c; |
233 | |
db81d362 |
234 | declarator = sv_2mortal(newSVpvn(keyword_ptr, keyword_len)); |
db81d362 |
235 | |
db81d362 |
236 | lex_read_space(0); |
237 | |
c311cef3 |
238 | builtin_attrs = 0; |
239 | |
db81d362 |
240 | /* function name */ |
c311cef3 |
241 | saw_name = NULL; |
db81d362 |
242 | s = PL_parser->bufptr; |
63915d26 |
243 | if ((spec->flags & FLAG_NAME_OK) && (len = S_scan_word(aTHX_ s, TRUE))) { |
c311cef3 |
244 | saw_name = sv_2mortal(newSVpvn_flags(s, len, PARSING_UTF ? SVf_UTF8 : 0)); |
245 | |
246 | if (PL_parser->expect != XSTATE) { |
247 | /* bail out early so we don't predeclare $saw_name */ |
248 | croak("In %"SVf": I was expecting a function body, not \"%"SVf"\"", SVfARG(declarator), SVfARG(saw_name)); |
249 | } |
250 | |
db81d362 |
251 | sv_catpvs(declarator, " "); |
c311cef3 |
252 | sv_catsv(declarator, saw_name); |
253 | |
254 | if ( |
255 | sv_eq_pvs(saw_name, "BEGIN") || |
256 | sv_eq_pvs(saw_name, "END") || |
257 | sv_eq_pvs(saw_name, "INIT") || |
258 | sv_eq_pvs(saw_name, "CHECK") || |
259 | sv_eq_pvs(saw_name, "UNITCHECK") |
260 | ) { |
261 | builtin_attrs |= MY_ATTR_SPECIAL; |
262 | } |
263 | |
db81d362 |
264 | lex_read_to(s + len); |
265 | lex_read_space(0); |
63915d26 |
266 | } else if (!(spec->flags & FLAG_ANON_OK)) { |
db81d362 |
267 | croak("I was expecting a function name, not \"%.*s\"", (int)(PL_parser->bufend - s), s); |
268 | } else { |
269 | sv_catpvs(declarator, " (anon)"); |
270 | } |
271 | |
63915d26 |
272 | /* we're a subroutine declaration */ |
c311cef3 |
273 | floor_ix = start_subparse(FALSE, saw_name ? 0 : CVf_ANON); |
274 | SAVEFREESV(PL_compcv); |
275 | |
63915d26 |
276 | /* create outer block: '{' */ |
277 | save_ix = S_block_start(aTHX_ TRUE); |
278 | |
db81d362 |
279 | /* parameters */ |
c311cef3 |
280 | params = NULL; |
63915d26 |
281 | defaults = NULL; |
282 | args_min = 0; |
283 | args_max = -1; |
284 | |
db81d362 |
285 | c = lex_peek_unichar(0); |
286 | if (c == '(') { |
63915d26 |
287 | DefaultParamSpec **pdefaults_tail = &defaults; |
db81d362 |
288 | SV *saw_slurpy = NULL; |
63915d26 |
289 | int param_count = 0; |
290 | args_max = 0; |
db81d362 |
291 | |
292 | lex_read_unichar(0); |
293 | lex_read_space(0); |
294 | |
c311cef3 |
295 | params = newAV(); |
296 | sv_2mortal((SV *)params); |
297 | |
db81d362 |
298 | for (;;) { |
299 | c = lex_peek_unichar(0); |
f5cc9bdd |
300 | if (c == '$' || c == '@' || c == '%') { |
63915d26 |
301 | const char sigil = c; |
c311cef3 |
302 | SV *param; |
303 | |
63915d26 |
304 | param_count++; |
305 | |
db81d362 |
306 | lex_read_unichar(0); |
307 | lex_read_space(0); |
308 | |
309 | s = PL_parser->bufptr; |
7dd35535 |
310 | if (!(len = S_scan_word(aTHX_ s, FALSE))) { |
85bc3fbd |
311 | croak("In %"SVf": missing identifier", SVfARG(declarator)); |
db81d362 |
312 | } |
63915d26 |
313 | param = sv_2mortal(newSVpvf("%c%.*s", sigil, (int)len, s)); |
db81d362 |
314 | if (saw_slurpy) { |
c311cef3 |
315 | croak("In %"SVf": I was expecting \")\" after \"%"SVf"\", not \"%"SVf"\"", SVfARG(declarator), SVfARG(saw_slurpy), SVfARG(param)); |
db81d362 |
316 | } |
63915d26 |
317 | if (sigil == '$') { |
318 | args_max++; |
319 | } else { |
320 | args_max = -1; |
c311cef3 |
321 | saw_slurpy = param; |
db81d362 |
322 | } |
c311cef3 |
323 | av_push(params, SvREFCNT_inc_simple_NN(param)); |
db81d362 |
324 | lex_read_to(s + len); |
325 | lex_read_space(0); |
326 | |
327 | c = lex_peek_unichar(0); |
63915d26 |
328 | |
329 | if (!(c == '=' && (spec->flags & FLAG_DEFAULT_ARGS))) { |
330 | if (sigil == '$' && !defaults) { |
331 | args_min++; |
332 | } |
333 | } else if (sigil != '$') { |
334 | croak("In %"SVf": %s %"SVf" can't have a default value", SVfARG(declarator), sigil == '@' ? "array" : "hash", SVfARG(saw_slurpy)); |
335 | } else { |
336 | DefaultParamSpec *curdef; |
337 | |
338 | lex_read_unichar(0); |
339 | lex_read_space(0); |
340 | |
341 | Newx(curdef, 1, DefaultParamSpec); |
342 | curdef->next = NULL; |
343 | curdef->limit = param_count; |
344 | curdef->name = param; |
345 | curdef->init = NULL; |
346 | SAVEDESTRUCTOR_X(free_defspec, curdef); |
347 | |
348 | curdef->next = *pdefaults_tail; |
349 | *pdefaults_tail = curdef; |
350 | pdefaults_tail = &curdef->next; |
351 | |
352 | /* let perl parse the default parameter value */ |
353 | curdef->init = parse_termexpr(0); |
354 | |
355 | lex_read_space(0); |
356 | c = lex_peek_unichar(0); |
357 | } |
358 | |
db81d362 |
359 | if (c == ',') { |
360 | lex_read_unichar(0); |
361 | lex_read_space(0); |
362 | continue; |
363 | } |
364 | } |
365 | |
366 | if (c == ')') { |
367 | lex_read_unichar(0); |
368 | lex_read_space(0); |
369 | break; |
370 | } |
371 | |
372 | if (c == -1) { |
85bc3fbd |
373 | croak("In %"SVf": unexpected EOF in parameter list", SVfARG(declarator)); |
db81d362 |
374 | } |
85bc3fbd |
375 | croak("In %"SVf": unexpected '%c' in parameter list", SVfARG(declarator), (int)c); |
db81d362 |
376 | } |
377 | } |
378 | |
379 | /* prototype */ |
c311cef3 |
380 | proto = NULL; |
db81d362 |
381 | c = lex_peek_unichar(0); |
382 | if (c == ':') { |
383 | lex_read_unichar(0); |
384 | lex_read_space(0); |
385 | |
386 | c = lex_peek_unichar(0); |
387 | if (c != '(') { |
c311cef3 |
388 | lex_stuff_pvs(":", 0); |
389 | c = ':'; |
db81d362 |
390 | } else { |
c311cef3 |
391 | proto = sv_2mortal(newSVpvs("")); |
392 | if (!S_scan_str(aTHX_ proto, FALSE, FALSE)) { |
f34187b8 |
393 | croak("In %"SVf": prototype not terminated", SVfARG(declarator)); |
db81d362 |
394 | } |
311ced6f |
395 | S_check_prototype(aTHX_ declarator, proto); |
db81d362 |
396 | lex_read_space(0); |
c311cef3 |
397 | c = lex_peek_unichar(0); |
db81d362 |
398 | } |
399 | } |
400 | |
db81d362 |
401 | /* attributes */ |
c311cef3 |
402 | Newx(attrs_sentinel, 1, OP *); |
403 | *attrs_sentinel = NULL; |
311ced6f |
404 | SAVEDESTRUCTOR_X(free_ptr_op, attrs_sentinel); |
c311cef3 |
405 | |
63915d26 |
406 | if (c == ':' || c == '{') /* '}' - hi, vim */ { |
c311cef3 |
407 | |
408 | /* kludge default attributes in */ |
409 | if (SvTRUE(spec->attrs) && SvPV_nolen(spec->attrs)[0] == ':') { |
410 | lex_stuff_sv(spec->attrs, 0); |
411 | c = ':'; |
412 | } |
b72eb6ee |
413 | |
db81d362 |
414 | if (c == ':') { |
db81d362 |
415 | lex_read_unichar(0); |
416 | lex_read_space(0); |
db81d362 |
417 | c = lex_peek_unichar(0); |
c311cef3 |
418 | |
419 | for (;;) { |
420 | SV *attr; |
421 | |
422 | s = PL_parser->bufptr; |
423 | if (!(len = S_scan_word(aTHX_ s, FALSE))) { |
424 | break; |
db81d362 |
425 | } |
c311cef3 |
426 | |
427 | attr = sv_2mortal(newSVpvn_flags(s, len, PARSING_UTF ? SVf_UTF8 : 0)); |
428 | |
429 | lex_read_to(s + len); |
db81d362 |
430 | lex_read_space(0); |
431 | c = lex_peek_unichar(0); |
c311cef3 |
432 | |
433 | if (c != '(') { |
434 | if (sv_eq_pvs(attr, "lvalue")) { |
435 | builtin_attrs |= MY_ATTR_LVALUE; |
436 | attr = NULL; |
437 | } else if (sv_eq_pvs(attr, "method")) { |
438 | builtin_attrs |= MY_ATTR_METHOD; |
439 | attr = NULL; |
440 | } |
441 | } else { |
442 | SV *sv = sv_2mortal(newSVpvs("")); |
443 | if (!S_scan_str(aTHX_ sv, TRUE, TRUE)) { |
444 | croak("In %"SVf": unterminated attribute parameter in attribute list", SVfARG(declarator)); |
445 | } |
446 | sv_catsv(attr, sv); |
447 | |
448 | lex_read_space(0); |
449 | c = lex_peek_unichar(0); |
450 | } |
451 | |
452 | if (attr) { |
453 | *attrs_sentinel = op_append_elem(OP_LIST, *attrs_sentinel, newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(attr))); |
454 | } |
455 | |
456 | if (c == ':') { |
457 | lex_read_unichar(0); |
458 | lex_read_space(0); |
459 | c = lex_peek_unichar(0); |
460 | } |
db81d362 |
461 | } |
462 | } |
463 | } |
464 | |
465 | /* body */ |
63915d26 |
466 | if (c != '{') /* '}' - hi, vim */ { |
85bc3fbd |
467 | croak("In %"SVf": I was expecting a function body, not \"%c\"", SVfARG(declarator), (int)c); |
db81d362 |
468 | } |
c311cef3 |
469 | |
63915d26 |
470 | /* surprise predeclaration! */ |
471 | if (saw_name) { |
472 | /* 'sub NAME (PROTO);' to make name/proto known to perl before it |
473 | starts parsing the body */ |
474 | const I32 sub_ix = start_subparse(FALSE, 0); |
475 | SAVEFREESV(PL_compcv); |
476 | |
477 | SvREFCNT_inc_simple_void(PL_compcv); |
478 | |
479 | newATTRSUB( |
480 | sub_ix, |
481 | newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(saw_name)), |
482 | proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL, |
483 | NULL, |
484 | NULL |
485 | ); |
486 | } |
487 | |
488 | |
c311cef3 |
489 | if (builtin_attrs & MY_ATTR_LVALUE) { |
490 | CvLVALUE_on(PL_compcv); |
db81d362 |
491 | } |
c311cef3 |
492 | if (builtin_attrs & MY_ATTR_METHOD) { |
493 | CvMETHOD_on(PL_compcv); |
494 | } |
495 | if (builtin_attrs & MY_ATTR_SPECIAL) { |
496 | CvSPECIAL_on(PL_compcv); |
db81d362 |
497 | } |
498 | |
c311cef3 |
499 | /* munge */ |
500 | { |
63915d26 |
501 | OP *prelude = NULL; |
c311cef3 |
502 | |
503 | /* my $self = shift; */ |
504 | if (SvTRUE(spec->shift)) { |
505 | OP *const var = newOP(OP_PADSV, OPf_WANT_SCALAR | (OPpLVAL_INTRO << 8)); |
506 | var->op_targ = pad_add_name_sv(spec->shift, 0, NULL, NULL); |
507 | |
63915d26 |
508 | prelude = newASSIGNOP(OPf_STACKED, var, 0, newOP(OP_SHIFT, 0)); |
509 | prelude = newSTATEOP(0, NULL, prelude); |
510 | } |
511 | |
512 | /* min/max argument count checks */ |
513 | if (spec->flags & FLAG_CHECK_NARGS) { |
514 | if (args_min > 0) { |
515 | OP *chk, *cond, *err, *croak; |
516 | |
517 | err = newSVOP(OP_CONST, 0, |
518 | newSVpvf("Not enough arguments for %"SVf, SVfARG(declarator))); |
519 | |
520 | croak = newCVREF(OPf_WANT_SCALAR, |
521 | newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV))); |
522 | err = newUNOP(OP_ENTERSUB, OPf_STACKED, |
523 | op_append_elem(OP_LIST, err, croak)); |
524 | |
525 | cond = newBINOP(OP_LT, 0, |
526 | newAVREF(newGVOP(OP_GV, 0, PL_defgv)), |
527 | newSVOP(OP_CONST, 0, newSViv(args_min))); |
528 | chk = newLOGOP(OP_AND, 0, cond, err); |
529 | |
530 | prelude = op_append_list(OP_LINESEQ, prelude, newSTATEOP(0, NULL, chk)); |
531 | } |
532 | if (args_max != -1) { |
533 | OP *chk, *cond, *err, *croak; |
534 | |
535 | err = newSVOP(OP_CONST, 0, |
536 | newSVpvf("Too many arguments for %"SVf, SVfARG(declarator))); |
537 | |
538 | croak = newCVREF(OPf_WANT_SCALAR, |
539 | newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV))); |
540 | err = newUNOP(OP_ENTERSUB, OPf_STACKED, |
541 | op_append_elem(OP_LIST, err, croak)); |
542 | |
543 | cond = newBINOP(OP_GT, 0, |
544 | newAVREF(newGVOP(OP_GV, 0, PL_defgv)), |
545 | newSVOP(OP_CONST, 0, newSViv(args_max))); |
546 | chk = newLOGOP(OP_AND, 0, cond, err); |
547 | |
548 | prelude = op_append_list(OP_LINESEQ, prelude, newSTATEOP(0, NULL, chk)); |
549 | } |
c311cef3 |
550 | } |
551 | |
552 | /* my (PARAMS) = @_; */ |
553 | if (params && av_len(params) > -1) { |
554 | SV *param; |
555 | OP *init_param, *left, *right; |
556 | |
557 | left = NULL; |
558 | while ((param = av_shift(params)) != &PL_sv_undef) { |
559 | OP *const var = newOP(OP_PADSV, OPf_WANT_LIST | (OPpLVAL_INTRO << 8)); |
560 | var->op_targ = pad_add_name_sv(param, 0, NULL, NULL); |
561 | SvREFCNT_dec(param); |
562 | left = op_append_elem(OP_LIST, left, var); |
563 | } |
564 | |
565 | left->op_flags |= OPf_PARENS; |
566 | right = newAVREF(newGVOP(OP_GV, 0, PL_defgv)); |
567 | init_param = newASSIGNOP(OPf_STACKED, left, 0, right); |
568 | init_param = newSTATEOP(0, NULL, init_param); |
569 | |
63915d26 |
570 | prelude = op_append_list(OP_LINESEQ, prelude, init_param); |
c311cef3 |
571 | } |
572 | |
63915d26 |
573 | /* defaults */ |
574 | { |
575 | OP *gen = NULL; |
576 | DefaultParamSpec *dp; |
577 | |
578 | for (dp = defaults; dp; dp = dp->next) { |
579 | OP *init = dp->init; |
580 | OP *var, *args, *cond; |
581 | |
582 | /* var = `$,name */ |
583 | var = newOP(OP_PADSV, 0); |
584 | var->op_targ = pad_findmy_sv(dp->name, 0); |
585 | |
586 | /* init = `,var = ,init */ |
587 | init = newASSIGNOP(OPf_STACKED, var, 0, init); |
588 | |
589 | /* args = `@_ */ |
590 | args = newAVREF(newGVOP(OP_GV, 0, PL_defgv)); |
591 | |
592 | /* cond = `,args < ,index */ |
593 | cond = newBINOP(OP_LT, 0, args, newSVOP(OP_CONST, 0, newSViv(dp->limit))); |
594 | |
595 | /* init = `,init if ,cond */ |
596 | init = newLOGOP(OP_AND, 0, cond, init); |
597 | |
598 | /* gen = `,gen ; ,init */ |
599 | gen = op_append_list(OP_LINESEQ, gen, newSTATEOP(0, NULL, init)); |
600 | |
601 | dp->init = NULL; |
602 | } |
603 | |
604 | prelude = op_append_list(OP_LINESEQ, prelude, gen); |
c311cef3 |
605 | } |
606 | |
607 | /* finally let perl parse the actual subroutine body */ |
608 | body = parse_block(0); |
609 | |
63915d26 |
610 | /* add '();' to make function return nothing by default */ |
611 | /* (otherwise the invisible parameter initialization can "leak" into |
612 | the return value: fun ($x) {}->("asdf", 0) == 2) */ |
613 | if (prelude) { |
614 | body = newSTATEOP(0, NULL, body); |
615 | } |
c311cef3 |
616 | |
63915d26 |
617 | body = op_append_list(OP_LINESEQ, prelude, body); |
db81d362 |
618 | } |
619 | |
c311cef3 |
620 | /* it's go time. */ |
621 | { |
622 | OP *const attrs = *attrs_sentinel; |
623 | *attrs_sentinel = NULL; |
624 | SvREFCNT_inc_simple_void(PL_compcv); |
625 | |
63915d26 |
626 | /* close outer block: '}' */ |
627 | S_block_end(aTHX_ save_ix, body); |
628 | |
c311cef3 |
629 | if (!saw_name) { |
630 | *pop = newANONATTRSUB( |
631 | floor_ix, |
632 | proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL, |
633 | attrs, |
634 | body |
635 | ); |
636 | return KEYWORD_PLUGIN_EXPR; |
637 | } |
638 | |
639 | newATTRSUB( |
640 | floor_ix, |
641 | newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(saw_name)), |
642 | proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL, |
643 | attrs, |
644 | body |
645 | ); |
646 | *pop = NULL; |
647 | return KEYWORD_PLUGIN_STMT; |
db81d362 |
648 | } |
db81d362 |
649 | } |
650 | |
651 | static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) { |
63915d26 |
652 | KWSpec spec; |
db81d362 |
653 | int ret; |
654 | |
655 | SAVETMPS; |
656 | |
7dd35535 |
657 | if (kw_flags(aTHX_ keyword_ptr, keyword_len, &spec)) { |
658 | ret = parse_fun(aTHX_ op_ptr, keyword_ptr, keyword_len, &spec); |
db81d362 |
659 | } else { |
7dd35535 |
660 | ret = next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr); |
db81d362 |
661 | } |
662 | |
663 | FREETMPS; |
664 | |
665 | return ret; |
666 | } |
667 | |
668 | WARNINGS_RESET |
669 | |
670 | MODULE = Function::Parameters PACKAGE = Function::Parameters |
671 | PROTOTYPES: ENABLE |
672 | |
673 | BOOT: |
674 | WARNINGS_ENABLE { |
675 | HV *const stash = gv_stashpvs(MY_PKG, GV_ADD); |
426a4d69 |
676 | /**/ |
63915d26 |
677 | newCONSTSUB(stash, "FLAG_NAME_OK", newSViv(FLAG_NAME_OK)); |
678 | newCONSTSUB(stash, "FLAG_ANON_OK", newSViv(FLAG_ANON_OK)); |
679 | newCONSTSUB(stash, "FLAG_DEFAULT_ARGS", newSViv(FLAG_DEFAULT_ARGS)); |
680 | newCONSTSUB(stash, "FLAG_CHECK_NARGS", newSViv(FLAG_CHECK_NARGS)); |
db81d362 |
681 | newCONSTSUB(stash, "HINTK_KEYWORDS", newSVpvs(HINTK_KEYWORDS)); |
63915d26 |
682 | newCONSTSUB(stash, "HINTK_FLAGS_", newSVpvs(HINTK_FLAGS_)); |
db81d362 |
683 | newCONSTSUB(stash, "HINTK_SHIFT_", newSVpvs(HINTK_SHIFT_)); |
b72eb6ee |
684 | newCONSTSUB(stash, "HINTK_ATTRS_", newSVpvs(HINTK_ATTRS_)); |
426a4d69 |
685 | /**/ |
db81d362 |
686 | next_keyword_plugin = PL_keyword_plugin; |
687 | PL_keyword_plugin = my_keyword_plugin; |
688 | } WARNINGS_RESET |