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, |
d8e5d540 |
86 | FLAG_CHECK_NARGS = 0x08, |
87 | FLAG_INVOCANT = 0x10 |
63915d26 |
88 | }; |
89 | |
90 | DEFSTRUCT(KWSpec) { |
91 | unsigned flags; |
b72eb6ee |
92 | SV *shift; |
93 | SV *attrs; |
63915d26 |
94 | }; |
db81d362 |
95 | |
96 | static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **); |
97 | |
63915d26 |
98 | static int kw_flags(pTHX_ const char *kw_ptr, STRLEN kw_len, KWSpec *spec) { |
db81d362 |
99 | HV *hints; |
100 | SV *sv, **psv; |
101 | const char *p, *kw_active; |
102 | STRLEN kw_active_len; |
103 | |
63915d26 |
104 | spec->flags = 0; |
b72eb6ee |
105 | spec->shift = sv_2mortal(newSVpvs("")); |
106 | spec->attrs = sv_2mortal(newSVpvs("")); |
db81d362 |
107 | |
108 | if (!(hints = GvHV(PL_hintgv))) { |
109 | return FALSE; |
110 | } |
111 | if (!(psv = hv_fetchs(hints, HINTK_KEYWORDS, 0))) { |
112 | return FALSE; |
113 | } |
114 | sv = *psv; |
115 | kw_active = SvPV(sv, kw_active_len); |
116 | if (kw_active_len <= kw_len) { |
117 | return FALSE; |
118 | } |
e88490f6 |
119 | for ( |
120 | p = kw_active; |
121 | (p = strchr(p, *kw_ptr)) && |
122 | p < kw_active + kw_active_len - kw_len; |
123 | p++ |
124 | ) { |
db81d362 |
125 | if ( |
126 | (p == kw_active || p[-1] == ' ') && |
127 | p[kw_len] == ' ' && |
128 | memcmp(kw_ptr, p, kw_len) == 0 |
129 | ) { |
b72eb6ee |
130 | |
d970c3e7 |
131 | #define FETCH_HINTK_INTO(NAME, PTR, LEN, X) STMT_START { \ |
b72eb6ee |
132 | const char *fk_ptr_; \ |
133 | STRLEN fk_len_; \ |
134 | SV *fk_sv_; \ |
135 | fk_sv_ = sv_2mortal(newSVpvs(HINTK_ ## NAME)); \ |
136 | sv_catpvn(fk_sv_, PTR, LEN); \ |
137 | fk_ptr_ = SvPV(fk_sv_, fk_len_); \ |
138 | if (!((X) = hv_fetch(hints, fk_ptr_, fk_len_, 0))) { \ |
139 | croak("%s: internal error: $^H{'%.*s'} not set", MY_PKG, (int)fk_len_, fk_ptr_); \ |
140 | } \ |
d970c3e7 |
141 | } STMT_END |
b72eb6ee |
142 | |
63915d26 |
143 | FETCH_HINTK_INTO(FLAGS_, kw_ptr, kw_len, psv); |
144 | spec->flags = SvIV(*psv); |
db81d362 |
145 | |
b72eb6ee |
146 | FETCH_HINTK_INTO(SHIFT_, kw_ptr, kw_len, psv); |
147 | SvSetSV(spec->shift, *psv); |
db81d362 |
148 | |
b72eb6ee |
149 | FETCH_HINTK_INTO(ATTRS_, kw_ptr, kw_len, psv); |
150 | SvSetSV(spec->attrs, *psv); |
151 | |
152 | #undef FETCH_HINTK_INTO |
db81d362 |
153 | return TRUE; |
154 | } |
155 | } |
156 | return FALSE; |
157 | } |
158 | |
159 | |
63915d26 |
160 | static void free_defspec(pTHX_ void *vp) { |
161 | DefaultParamSpec *dp = vp; |
162 | op_free(dp->init); |
163 | Safefree(dp); |
164 | } |
165 | |
311ced6f |
166 | static void free_ptr_op(pTHX_ void *vp) { |
c311cef3 |
167 | OP **pp = vp; |
168 | op_free(*pp); |
169 | Safefree(pp); |
170 | } |
171 | |
59016bfb |
172 | #define sv_eq_pvs(SV, S) my_sv_eq_pvn(aTHX_ SV, "" S "", sizeof (S) - 1) |
c311cef3 |
173 | |
59016bfb |
174 | static int my_sv_eq_pvn(pTHX_ SV *sv, const char *p, STRLEN n) { |
c311cef3 |
175 | STRLEN sv_len; |
176 | const char *sv_p = SvPV(sv, sv_len); |
59016bfb |
177 | return memcmp(sv_p, p, n) == 0; |
c311cef3 |
178 | } |
179 | |
180 | |
181 | #include "padop_on_crack.c.inc" |
182 | |
183 | |
184 | #if 0 |
185 | static PADOFFSET pad_add_my_sv(SV *name) { |
186 | PADOFFSET offset; |
187 | SV *namesv, *myvar; |
188 | char *p; |
189 | STRLEN len; |
190 | |
191 | p = SvPV(name, len); |
192 | myvar = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, 1); |
193 | offset = AvFILLp(PL_comppad); |
194 | SvPADMY_on(myvar); |
195 | if (*p == '@') { |
196 | SvUPGRADE(myvar, SVt_PVAV); |
197 | } else if (*p == '%') { |
198 | SvUPGRADE(myvar, SVt_PVHV); |
199 | } |
200 | PL_curpad = AvARRAY(PL_comppad); |
201 | namesv = newSV_type(SVt_PVMG); |
202 | sv_setpvn(namesv, p, len); |
203 | COP_SEQ_RANGE_LOW_set(namesv, PL_cop_seqmax); |
204 | COP_SEQ_RANGE_HIGH_set(namesv, PERL_PADSEQ_INTRO); |
205 | PL_cop_seqmax++; |
206 | av_store(PL_comppad_name, offset, namesv); |
207 | return offset; |
208 | } |
209 | #endif |
210 | |
211 | enum { |
212 | MY_ATTR_LVALUE = 0x01, |
213 | MY_ATTR_METHOD = 0x02, |
214 | MY_ATTR_SPECIAL = 0x04 |
215 | }; |
216 | |
31534187 |
217 | static void my_sv_cat_c(pTHX_ SV *sv, U32 c) { |
218 | char ds[UTF8_MAXBYTES + 1], *d; |
219 | d = uvchr_to_utf8(ds, c); |
220 | if (d - ds > 1) { |
221 | sv_utf8_upgrade(sv); |
222 | } |
223 | sv_catpvn(sv, ds, d - ds); |
224 | } |
225 | |
226 | static bool my_is_uni_xidfirst(pTHX_ UV c) { |
227 | U8 tmpbuf[UTF8_MAXBYTES + 1]; |
228 | uvchr_to_utf8(tmpbuf, c); |
229 | return is_utf8_xidfirst(tmpbuf); |
230 | } |
231 | |
232 | static bool my_is_uni_xidcont(pTHX_ UV c) { |
233 | U8 tmpbuf[UTF8_MAXBYTES + 1]; |
234 | uvchr_to_utf8(tmpbuf, c); |
235 | return is_utf8_xidcont(tmpbuf); |
236 | } |
237 | |
238 | static SV *my_scan_word(pTHX_ bool allow_package) { |
239 | bool at_start, at_substart; |
240 | I32 c; |
241 | SV *sv = sv_2mortal(newSVpvs("")); |
242 | if (lex_bufutf8()) { |
243 | SvUTF8_on(sv); |
244 | } |
245 | |
246 | at_start = at_substart = TRUE; |
247 | c = lex_peek_unichar(0); |
248 | |
249 | while (c != -1) { |
250 | if (at_substart ? my_is_uni_xidfirst(aTHX_ c) : my_is_uni_xidcont(aTHX_ c)) { |
251 | lex_read_unichar(0); |
252 | my_sv_cat_c(aTHX_ sv, c); |
253 | at_substart = FALSE; |
254 | c = lex_peek_unichar(0); |
255 | } else if (allow_package && !at_substart && c == '\'') { |
256 | lex_read_unichar(0); |
257 | c = lex_peek_unichar(0); |
258 | if (!my_is_uni_xidfirst(aTHX_ c)) { |
259 | lex_stuff_pvs("'", 0); |
260 | break; |
261 | } |
262 | sv_catpvs(sv, "'"); |
263 | at_substart = TRUE; |
264 | } else if (allow_package && (at_start || !at_substart) && c == ':') { |
265 | lex_read_unichar(0); |
266 | if (lex_peek_unichar(0) != ':') { |
267 | lex_stuff_pvs(":", 0); |
268 | break; |
269 | } |
270 | lex_read_unichar(0); |
271 | c = lex_peek_unichar(0); |
272 | if (!my_is_uni_xidfirst(aTHX_ c)) { |
273 | lex_stuff_pvs("::", 0); |
274 | break; |
275 | } |
276 | sv_catpvs(sv, "::"); |
277 | at_substart = TRUE; |
278 | } else { |
279 | break; |
280 | } |
281 | at_start = FALSE; |
282 | } |
283 | |
284 | return SvCUR(sv) ? sv : NULL; |
285 | } |
286 | |
287 | static SV *my_scan_parens_tail(pTHX_ bool keep_backslash) { |
288 | I32 c, nesting; |
289 | SV *sv; |
290 | line_t start; |
291 | |
292 | start = CopLINE(PL_curcop); |
293 | |
294 | sv = sv_2mortal(newSVpvs("")); |
295 | if (lex_bufutf8()) { |
296 | SvUTF8_on(sv); |
297 | } |
298 | |
299 | nesting = 0; |
300 | for (;;) { |
301 | c = lex_read_unichar(0); |
302 | if (c == EOF) { |
303 | CopLINE_set(PL_curcop, start); |
304 | return NULL; |
305 | } |
306 | |
307 | if (c == '\\') { |
308 | c = lex_read_unichar(0); |
309 | if (c == EOF) { |
310 | CopLINE_set(PL_curcop, start); |
311 | return NULL; |
312 | } |
313 | if (keep_backslash || (c != '(' && c != ')')) { |
314 | sv_catpvs(sv, "\\"); |
315 | } |
316 | } else if (c == '(') { |
317 | nesting++; |
318 | } else if (c == ')') { |
319 | if (!nesting) { |
320 | break; |
321 | } |
322 | nesting--; |
323 | } |
324 | |
325 | my_sv_cat_c(aTHX_ sv, c); |
326 | } |
327 | |
328 | return sv; |
329 | } |
330 | |
331 | static void my_check_prototype(pTHX_ const SV *declarator, SV *proto) { |
332 | char *start, *r, *w, *end; |
333 | STRLEN len; |
334 | |
335 | /* strip spaces */ |
336 | start = SvPV(proto, len); |
337 | end = start + len; |
338 | |
339 | for (w = r = start; r < end; r++) { |
340 | if (!isSPACE(*r)) { |
341 | *w++ = *r; |
342 | } |
343 | } |
344 | *w = '\0'; |
345 | SvCUR_set(proto, w - start); |
346 | end = w; |
347 | len = end - start; |
348 | |
349 | if (!ckWARN(WARN_ILLEGALPROTO)) { |
350 | return; |
351 | } |
352 | |
353 | /* check for bad characters */ |
354 | if (strspn(start, "$@%*;[]&\\_+") != len) { |
355 | SV *dsv = newSVpvs_flags("", SVs_TEMP); |
356 | warner( |
357 | packWARN(WARN_ILLEGALPROTO), |
358 | "Illegal character in prototype for %"SVf" : %s", |
359 | SVfARG(declarator), |
360 | SvUTF8(proto) |
361 | ? sv_uni_display( |
362 | dsv, |
363 | proto, |
364 | len, |
365 | UNI_DISPLAY_ISPRINT |
366 | ) |
367 | : pv_pretty(dsv, start, len, 60, NULL, NULL, |
368 | PERL_PV_ESCAPE_NONASCII |
369 | ) |
370 | ); |
371 | return; |
372 | } |
373 | |
374 | for (r = start; r < end; r++) { |
375 | switch (*r) { |
376 | default: |
377 | warner( |
378 | packWARN(WARN_ILLEGALPROTO), |
379 | "Illegal character in prototype for %"SVf" : %s", |
380 | SVfARG(declarator), r |
381 | ); |
382 | return; |
383 | |
384 | case '_': |
385 | if (r[1] && !strchr(";@%", *r)) { |
386 | warner( |
387 | packWARN(WARN_ILLEGALPROTO), |
388 | "Illegal character after '_' in prototype for %"SVf" : %s", |
389 | SVfARG(declarator), r |
390 | ); |
391 | return; |
392 | } |
393 | break; |
394 | |
395 | case '@': |
396 | case '%': |
397 | if (r[1]) { |
398 | warner( |
399 | packWARN(WARN_ILLEGALPROTO), |
400 | "prototype after '%c' for %"SVf": %s", |
401 | *r, SVfARG(declarator), r + 1 |
402 | ); |
403 | return; |
404 | } |
405 | break; |
406 | |
407 | case '\\': |
408 | r++; |
409 | if (strchr("$@%&*", *r)) { |
410 | break; |
411 | } |
412 | if (*r == '[') { |
413 | r++; |
414 | for (; r < end && *r != ']'; r++) { |
415 | if (!strchr("$@%&*", *r)) { |
416 | break; |
417 | } |
418 | } |
419 | if (*r == ']' && r[-1] != '[') { |
420 | break; |
421 | } |
422 | } |
423 | warner( |
424 | packWARN(WARN_ILLEGALPROTO), |
425 | "Illegal character after '\\' in prototype for %"SVf" : %s", |
426 | SVfARG(declarator), r |
427 | ); |
428 | return; |
429 | |
430 | case '$': |
431 | case '*': |
432 | case '&': |
433 | case ';': |
434 | case '+': |
435 | break; |
436 | } |
437 | } |
438 | } |
439 | |
63915d26 |
440 | static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len, const KWSpec *spec) { |
c311cef3 |
441 | SV *declarator; |
442 | I32 floor_ix; |
63915d26 |
443 | int save_ix; |
c311cef3 |
444 | SV *saw_name; |
1e0f1595 |
445 | OP **prelude_sentinel; |
d8e5d540 |
446 | int did_invocant_decl; |
447 | SV *invocant; |
c311cef3 |
448 | AV *params; |
63915d26 |
449 | DefaultParamSpec *defaults; |
450 | int args_min, args_max; |
c311cef3 |
451 | SV *proto; |
452 | OP **attrs_sentinel, *body; |
453 | unsigned builtin_attrs; |
db81d362 |
454 | STRLEN len; |
db81d362 |
455 | I32 c; |
456 | |
db81d362 |
457 | declarator = sv_2mortal(newSVpvn(keyword_ptr, keyword_len)); |
db81d362 |
458 | |
db81d362 |
459 | lex_read_space(0); |
460 | |
c311cef3 |
461 | builtin_attrs = 0; |
462 | |
db81d362 |
463 | /* function name */ |
c311cef3 |
464 | saw_name = NULL; |
31534187 |
465 | if ((spec->flags & FLAG_NAME_OK) && (saw_name = my_scan_word(aTHX_ TRUE))) { |
c311cef3 |
466 | |
467 | if (PL_parser->expect != XSTATE) { |
468 | /* bail out early so we don't predeclare $saw_name */ |
469 | croak("In %"SVf": I was expecting a function body, not \"%"SVf"\"", SVfARG(declarator), SVfARG(saw_name)); |
470 | } |
471 | |
db81d362 |
472 | sv_catpvs(declarator, " "); |
c311cef3 |
473 | sv_catsv(declarator, saw_name); |
474 | |
475 | if ( |
476 | sv_eq_pvs(saw_name, "BEGIN") || |
477 | sv_eq_pvs(saw_name, "END") || |
478 | sv_eq_pvs(saw_name, "INIT") || |
479 | sv_eq_pvs(saw_name, "CHECK") || |
480 | sv_eq_pvs(saw_name, "UNITCHECK") |
481 | ) { |
482 | builtin_attrs |= MY_ATTR_SPECIAL; |
483 | } |
484 | |
db81d362 |
485 | lex_read_space(0); |
63915d26 |
486 | } else if (!(spec->flags & FLAG_ANON_OK)) { |
31534187 |
487 | croak("I was expecting a function name, not \"%.*s\"", (int)(PL_parser->bufend - PL_parser->bufptr), PL_parser->bufptr); |
db81d362 |
488 | } else { |
489 | sv_catpvs(declarator, " (anon)"); |
490 | } |
491 | |
63915d26 |
492 | /* we're a subroutine declaration */ |
c311cef3 |
493 | floor_ix = start_subparse(FALSE, saw_name ? 0 : CVf_ANON); |
494 | SAVEFREESV(PL_compcv); |
495 | |
63915d26 |
496 | /* create outer block: '{' */ |
497 | save_ix = S_block_start(aTHX_ TRUE); |
498 | |
1e0f1595 |
499 | /* initialize synthetic optree */ |
500 | Newx(prelude_sentinel, 1, OP *); |
501 | *prelude_sentinel = NULL; |
502 | SAVEDESTRUCTOR_X(free_ptr_op, prelude_sentinel); |
503 | |
db81d362 |
504 | /* parameters */ |
d8e5d540 |
505 | did_invocant_decl = 0; |
506 | invocant = NULL; |
c311cef3 |
507 | params = NULL; |
63915d26 |
508 | defaults = NULL; |
509 | args_min = 0; |
510 | args_max = -1; |
511 | |
db81d362 |
512 | c = lex_peek_unichar(0); |
513 | if (c == '(') { |
63915d26 |
514 | DefaultParamSpec **pdefaults_tail = &defaults; |
db81d362 |
515 | SV *saw_slurpy = NULL; |
63915d26 |
516 | int param_count = 0; |
517 | args_max = 0; |
db81d362 |
518 | |
519 | lex_read_unichar(0); |
520 | lex_read_space(0); |
521 | |
c311cef3 |
522 | params = newAV(); |
523 | sv_2mortal((SV *)params); |
524 | |
db81d362 |
525 | for (;;) { |
526 | c = lex_peek_unichar(0); |
f5cc9bdd |
527 | if (c == '$' || c == '@' || c == '%') { |
63915d26 |
528 | const char sigil = c; |
c311cef3 |
529 | SV *param; |
530 | |
63915d26 |
531 | param_count++; |
532 | |
db81d362 |
533 | lex_read_unichar(0); |
534 | lex_read_space(0); |
535 | |
31534187 |
536 | if (!(param = my_scan_word(aTHX_ FALSE))) { |
85bc3fbd |
537 | croak("In %"SVf": missing identifier", SVfARG(declarator)); |
db81d362 |
538 | } |
31534187 |
539 | sv_insert(param, 0, 0, &sigil, 1); |
db81d362 |
540 | if (saw_slurpy) { |
c311cef3 |
541 | croak("In %"SVf": I was expecting \")\" after \"%"SVf"\", not \"%"SVf"\"", SVfARG(declarator), SVfARG(saw_slurpy), SVfARG(param)); |
db81d362 |
542 | } |
63915d26 |
543 | if (sigil == '$') { |
544 | args_max++; |
545 | } else { |
546 | args_max = -1; |
c311cef3 |
547 | saw_slurpy = param; |
db81d362 |
548 | } |
db81d362 |
549 | |
d8e5d540 |
550 | lex_read_space(0); |
db81d362 |
551 | c = lex_peek_unichar(0); |
63915d26 |
552 | |
d8e5d540 |
553 | assert(param_count >= 1); |
554 | |
555 | if (c == ':') { |
556 | if (invocant) { |
557 | croak("In %"SVf": invalid double invocants %"SVf", %"SVf"", SVfARG(declarator), SVfARG(invocant), SVfARG(param)); |
558 | } |
559 | if (param_count != 1) { |
560 | croak("In %"SVf": invocant %"SVf" must be first in parameter list", SVfARG(declarator), SVfARG(param)); |
561 | } |
562 | if (!(spec->flags & FLAG_INVOCANT)) { |
563 | croak("In %"SVf": invocant %"SVf" not allowed here", SVfARG(declarator), SVfARG(param)); |
564 | } |
565 | if (sigil != '$') { |
566 | croak("In %"SVf": invocant %"SVf" can't be a %s", SVfARG(declarator), SVfARG(param), sigil == '@' ? "array" : "hash"); |
63915d26 |
567 | } |
63915d26 |
568 | |
569 | lex_read_unichar(0); |
570 | lex_read_space(0); |
571 | |
d8e5d540 |
572 | args_max--; |
573 | param_count--; |
574 | invocant = param; |
575 | } else { |
576 | av_push(params, SvREFCNT_inc_simple_NN(param)); |
577 | |
578 | if (c == '=' && (spec->flags & FLAG_DEFAULT_ARGS)) { |
579 | DefaultParamSpec *curdef; |
63915d26 |
580 | |
d8e5d540 |
581 | if (sigil != '$') { |
582 | croak("In %"SVf": %s %"SVf" can't have a default value", SVfARG(declarator), sigil == '@' ? "array" : "hash", SVfARG(saw_slurpy)); |
583 | } |
63915d26 |
584 | |
d8e5d540 |
585 | lex_read_unichar(0); |
586 | lex_read_space(0); |
63915d26 |
587 | |
d8e5d540 |
588 | /* my $self; # in scope for default argument */ |
589 | if (!invocant && !did_invocant_decl && SvTRUE(spec->shift)) { |
590 | OP *var; |
591 | |
592 | var = newOP(OP_PADSV, OPf_MOD | (OPpLVAL_INTRO << 8)); |
593 | var->op_targ = pad_add_name_sv(spec->shift, 0, NULL, NULL); |
594 | |
595 | *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, var)); |
596 | |
597 | did_invocant_decl = 1; |
598 | } |
599 | |
600 | Newx(curdef, 1, DefaultParamSpec); |
601 | curdef->next = NULL; |
602 | curdef->limit = param_count; |
603 | curdef->name = param; |
604 | curdef->init = NULL; |
605 | SAVEDESTRUCTOR_X(free_defspec, curdef); |
606 | |
607 | curdef->next = *pdefaults_tail; |
608 | *pdefaults_tail = curdef; |
609 | pdefaults_tail = &curdef->next; |
610 | |
611 | /* let perl parse the default parameter value */ |
612 | curdef->init = parse_termexpr(0); |
613 | |
614 | lex_read_space(0); |
615 | c = lex_peek_unichar(0); |
616 | } else { |
617 | if (sigil == '$' && !defaults) { |
618 | args_min++; |
619 | } |
620 | } |
63915d26 |
621 | } |
622 | |
1e0f1595 |
623 | /* my $param; */ |
624 | { |
625 | OP *var; |
626 | |
627 | var = newOP(OP_PADSV, OPf_MOD | (OPpLVAL_INTRO << 8)); |
628 | var->op_targ = pad_add_name_sv(param, 0, NULL, NULL); |
629 | |
630 | *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, var)); |
631 | } |
632 | |
d8e5d540 |
633 | if (param_count == 0) { |
634 | continue; |
635 | } |
636 | |
db81d362 |
637 | if (c == ',') { |
638 | lex_read_unichar(0); |
639 | lex_read_space(0); |
640 | continue; |
641 | } |
642 | } |
643 | |
644 | if (c == ')') { |
645 | lex_read_unichar(0); |
646 | lex_read_space(0); |
647 | break; |
648 | } |
649 | |
650 | if (c == -1) { |
85bc3fbd |
651 | croak("In %"SVf": unexpected EOF in parameter list", SVfARG(declarator)); |
db81d362 |
652 | } |
85bc3fbd |
653 | croak("In %"SVf": unexpected '%c' in parameter list", SVfARG(declarator), (int)c); |
db81d362 |
654 | } |
655 | } |
656 | |
657 | /* prototype */ |
c311cef3 |
658 | proto = NULL; |
db81d362 |
659 | c = lex_peek_unichar(0); |
660 | if (c == ':') { |
661 | lex_read_unichar(0); |
662 | lex_read_space(0); |
663 | |
664 | c = lex_peek_unichar(0); |
665 | if (c != '(') { |
c311cef3 |
666 | lex_stuff_pvs(":", 0); |
667 | c = ':'; |
db81d362 |
668 | } else { |
31534187 |
669 | lex_read_unichar(0); |
670 | if (!(proto = my_scan_parens_tail(aTHX_ FALSE))) { |
f34187b8 |
671 | croak("In %"SVf": prototype not terminated", SVfARG(declarator)); |
db81d362 |
672 | } |
31534187 |
673 | my_check_prototype(aTHX_ declarator, proto); |
db81d362 |
674 | lex_read_space(0); |
c311cef3 |
675 | c = lex_peek_unichar(0); |
db81d362 |
676 | } |
677 | } |
678 | |
db81d362 |
679 | /* attributes */ |
c311cef3 |
680 | Newx(attrs_sentinel, 1, OP *); |
681 | *attrs_sentinel = NULL; |
311ced6f |
682 | SAVEDESTRUCTOR_X(free_ptr_op, attrs_sentinel); |
c311cef3 |
683 | |
63915d26 |
684 | if (c == ':' || c == '{') /* '}' - hi, vim */ { |
c311cef3 |
685 | |
686 | /* kludge default attributes in */ |
687 | if (SvTRUE(spec->attrs) && SvPV_nolen(spec->attrs)[0] == ':') { |
688 | lex_stuff_sv(spec->attrs, 0); |
689 | c = ':'; |
690 | } |
b72eb6ee |
691 | |
db81d362 |
692 | if (c == ':') { |
db81d362 |
693 | lex_read_unichar(0); |
694 | lex_read_space(0); |
db81d362 |
695 | c = lex_peek_unichar(0); |
c311cef3 |
696 | |
697 | for (;;) { |
698 | SV *attr; |
699 | |
31534187 |
700 | if (!(attr = my_scan_word(aTHX_ FALSE))) { |
c311cef3 |
701 | break; |
db81d362 |
702 | } |
c311cef3 |
703 | |
db81d362 |
704 | lex_read_space(0); |
705 | c = lex_peek_unichar(0); |
c311cef3 |
706 | |
707 | if (c != '(') { |
708 | if (sv_eq_pvs(attr, "lvalue")) { |
709 | builtin_attrs |= MY_ATTR_LVALUE; |
710 | attr = NULL; |
711 | } else if (sv_eq_pvs(attr, "method")) { |
712 | builtin_attrs |= MY_ATTR_METHOD; |
713 | attr = NULL; |
714 | } |
715 | } else { |
31534187 |
716 | SV *sv; |
717 | lex_read_unichar(0); |
718 | if (!(sv = my_scan_parens_tail(aTHX_ TRUE))) { |
c311cef3 |
719 | croak("In %"SVf": unterminated attribute parameter in attribute list", SVfARG(declarator)); |
720 | } |
31534187 |
721 | sv_catpvs(attr, "("); |
c311cef3 |
722 | sv_catsv(attr, sv); |
31534187 |
723 | sv_catpvs(attr, ")"); |
c311cef3 |
724 | |
725 | lex_read_space(0); |
726 | c = lex_peek_unichar(0); |
727 | } |
728 | |
729 | if (attr) { |
730 | *attrs_sentinel = op_append_elem(OP_LIST, *attrs_sentinel, newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(attr))); |
731 | } |
732 | |
733 | if (c == ':') { |
734 | lex_read_unichar(0); |
735 | lex_read_space(0); |
736 | c = lex_peek_unichar(0); |
737 | } |
db81d362 |
738 | } |
739 | } |
740 | } |
741 | |
742 | /* body */ |
63915d26 |
743 | if (c != '{') /* '}' - hi, vim */ { |
85bc3fbd |
744 | croak("In %"SVf": I was expecting a function body, not \"%c\"", SVfARG(declarator), (int)c); |
db81d362 |
745 | } |
c311cef3 |
746 | |
63915d26 |
747 | /* surprise predeclaration! */ |
748 | if (saw_name) { |
749 | /* 'sub NAME (PROTO);' to make name/proto known to perl before it |
750 | starts parsing the body */ |
751 | const I32 sub_ix = start_subparse(FALSE, 0); |
752 | SAVEFREESV(PL_compcv); |
753 | |
754 | SvREFCNT_inc_simple_void(PL_compcv); |
755 | |
756 | newATTRSUB( |
757 | sub_ix, |
758 | newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(saw_name)), |
759 | proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL, |
760 | NULL, |
761 | NULL |
762 | ); |
763 | } |
764 | |
c311cef3 |
765 | if (builtin_attrs & MY_ATTR_LVALUE) { |
766 | CvLVALUE_on(PL_compcv); |
db81d362 |
767 | } |
c311cef3 |
768 | if (builtin_attrs & MY_ATTR_METHOD) { |
769 | CvMETHOD_on(PL_compcv); |
770 | } |
771 | if (builtin_attrs & MY_ATTR_SPECIAL) { |
772 | CvSPECIAL_on(PL_compcv); |
db81d362 |
773 | } |
774 | |
d8e5d540 |
775 | if (!invocant) { |
776 | invocant = spec->shift; |
777 | |
778 | /* my $self; # wasn't needed yet */ |
779 | if (SvTRUE(invocant) && !did_invocant_decl) { |
780 | OP *var; |
781 | |
782 | var = newOP(OP_PADSV, OPf_MOD | (OPpLVAL_INTRO << 8)); |
783 | var->op_targ = pad_add_name_sv(invocant, 0, NULL, NULL); |
784 | |
785 | *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, var)); |
786 | } |
787 | } |
788 | |
1e0f1595 |
789 | /* min/max argument count checks */ |
790 | if (spec->flags & FLAG_CHECK_NARGS) { |
d8e5d540 |
791 | if (SvTRUE(invocant)) { |
1e0f1595 |
792 | args_min++; |
793 | if (args_max != -1) { |
794 | args_max++; |
abccbe86 |
795 | } |
1e0f1595 |
796 | } |
abccbe86 |
797 | |
1e0f1595 |
798 | if (args_min > 0) { |
799 | OP *chk, *cond, *err, *croak; |
63915d26 |
800 | |
1e0f1595 |
801 | err = newSVOP(OP_CONST, 0, |
5f50e017 |
802 | newSVpvf("Not enough arguments for %"SVf, SVfARG(declarator))); |
63915d26 |
803 | |
1e0f1595 |
804 | croak = newCVREF(OPf_WANT_SCALAR, |
5f50e017 |
805 | newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV))); |
1e0f1595 |
806 | err = newUNOP(OP_ENTERSUB, OPf_STACKED, |
5f50e017 |
807 | op_append_elem(OP_LIST, err, croak)); |
63915d26 |
808 | |
1e0f1595 |
809 | cond = newBINOP(OP_LT, 0, |
5f50e017 |
810 | newAVREF(newGVOP(OP_GV, 0, PL_defgv)), |
811 | newSVOP(OP_CONST, 0, newSViv(args_min))); |
1e0f1595 |
812 | chk = newLOGOP(OP_AND, 0, cond, err); |
63915d26 |
813 | |
1e0f1595 |
814 | *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, chk)); |
815 | } |
816 | if (args_max != -1) { |
817 | OP *chk, *cond, *err, *croak; |
63915d26 |
818 | |
1e0f1595 |
819 | err = newSVOP(OP_CONST, 0, |
5f50e017 |
820 | newSVpvf("Too many arguments for %"SVf, SVfARG(declarator))); |
63915d26 |
821 | |
1e0f1595 |
822 | croak = newCVREF(OPf_WANT_SCALAR, |
5f50e017 |
823 | newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV))); |
1e0f1595 |
824 | err = newUNOP(OP_ENTERSUB, OPf_STACKED, |
5f50e017 |
825 | op_append_elem(OP_LIST, err, croak)); |
63915d26 |
826 | |
1e0f1595 |
827 | cond = newBINOP(OP_GT, 0, |
5f50e017 |
828 | newAVREF(newGVOP(OP_GV, 0, PL_defgv)), |
829 | newSVOP(OP_CONST, 0, newSViv(args_max))); |
1e0f1595 |
830 | chk = newLOGOP(OP_AND, 0, cond, err); |
63915d26 |
831 | |
1e0f1595 |
832 | *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, chk)); |
c311cef3 |
833 | } |
1e0f1595 |
834 | } |
c311cef3 |
835 | |
1e0f1595 |
836 | /* $self = shift; */ |
d8e5d540 |
837 | if (SvTRUE(invocant)) { |
1e0f1595 |
838 | OP *var, *shift; |
abccbe86 |
839 | |
1e0f1595 |
840 | var = newOP(OP_PADSV, OPf_WANT_SCALAR); |
d8e5d540 |
841 | var->op_targ = pad_findmy_sv(invocant, 0); |
c311cef3 |
842 | |
1e0f1595 |
843 | shift = newASSIGNOP(OPf_STACKED, var, 0, newOP(OP_SHIFT, 0)); |
844 | *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, shift)); |
845 | } |
c311cef3 |
846 | |
1e0f1595 |
847 | /* (PARAMS) = @_; */ |
848 | if (params && av_len(params) > -1) { |
849 | SV *param; |
850 | OP *init_param, *left, *right; |
851 | |
852 | left = NULL; |
853 | while ((param = av_shift(params)) != &PL_sv_undef) { |
854 | OP *const var = newOP(OP_PADSV, OPf_WANT_LIST); |
855 | var->op_targ = pad_findmy_sv(param, 0); |
856 | SvREFCNT_dec(param); |
857 | left = op_append_elem(OP_LIST, left, var); |
c311cef3 |
858 | } |
859 | |
1e0f1595 |
860 | left->op_flags |= OPf_PARENS; |
861 | right = newAVREF(newGVOP(OP_GV, 0, PL_defgv)); |
862 | init_param = newASSIGNOP(OPf_STACKED, left, 0, right); |
863 | init_param = newSTATEOP(0, NULL, init_param); |
63915d26 |
864 | |
1e0f1595 |
865 | *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, init_param); |
866 | } |
63915d26 |
867 | |
1e0f1595 |
868 | /* defaults */ |
869 | { |
870 | OP *gen = NULL; |
871 | DefaultParamSpec *dp; |
63915d26 |
872 | |
1e0f1595 |
873 | for (dp = defaults; dp; dp = dp->next) { |
874 | OP *init = dp->init; |
875 | OP *var, *args, *cond; |
63915d26 |
876 | |
1e0f1595 |
877 | /* var = `$,name */ |
878 | var = newOP(OP_PADSV, 0); |
879 | var->op_targ = pad_findmy_sv(dp->name, 0); |
63915d26 |
880 | |
1e0f1595 |
881 | /* init = `,var = ,init */ |
882 | init = newASSIGNOP(OPf_STACKED, var, 0, init); |
63915d26 |
883 | |
1e0f1595 |
884 | /* args = `@_ */ |
885 | args = newAVREF(newGVOP(OP_GV, 0, PL_defgv)); |
63915d26 |
886 | |
1e0f1595 |
887 | /* cond = `,args < ,index */ |
888 | cond = newBINOP(OP_LT, 0, args, newSVOP(OP_CONST, 0, newSViv(dp->limit))); |
63915d26 |
889 | |
1e0f1595 |
890 | /* init = `,init if ,cond */ |
891 | init = newLOGOP(OP_AND, 0, cond, init); |
63915d26 |
892 | |
1e0f1595 |
893 | /* gen = `,gen ; ,init */ |
894 | gen = op_append_list(OP_LINESEQ, gen, newSTATEOP(0, NULL, init)); |
895 | |
896 | dp->init = NULL; |
c311cef3 |
897 | } |
898 | |
1e0f1595 |
899 | *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, gen); |
900 | } |
c311cef3 |
901 | |
1e0f1595 |
902 | /* finally let perl parse the actual subroutine body */ |
903 | body = parse_block(0); |
c311cef3 |
904 | |
1e0f1595 |
905 | /* add '();' to make function return nothing by default */ |
906 | /* (otherwise the invisible parameter initialization can "leak" into |
907 | the return value: fun ($x) {}->("asdf", 0) == 2) */ |
908 | if (*prelude_sentinel) { |
909 | body = newSTATEOP(0, NULL, body); |
db81d362 |
910 | } |
911 | |
1e0f1595 |
912 | body = op_append_list(OP_LINESEQ, *prelude_sentinel, body); |
913 | *prelude_sentinel = NULL; |
914 | |
c311cef3 |
915 | /* it's go time. */ |
916 | { |
917 | OP *const attrs = *attrs_sentinel; |
918 | *attrs_sentinel = NULL; |
919 | SvREFCNT_inc_simple_void(PL_compcv); |
920 | |
63915d26 |
921 | /* close outer block: '}' */ |
922 | S_block_end(aTHX_ save_ix, body); |
923 | |
c311cef3 |
924 | if (!saw_name) { |
925 | *pop = newANONATTRSUB( |
926 | floor_ix, |
927 | proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL, |
928 | attrs, |
929 | body |
930 | ); |
931 | return KEYWORD_PLUGIN_EXPR; |
932 | } |
933 | |
934 | newATTRSUB( |
935 | floor_ix, |
936 | newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(saw_name)), |
937 | proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL, |
938 | attrs, |
939 | body |
940 | ); |
5efe0e0e |
941 | *pop = newOP(OP_NULL, 0); |
c311cef3 |
942 | return KEYWORD_PLUGIN_STMT; |
db81d362 |
943 | } |
db81d362 |
944 | } |
945 | |
946 | static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) { |
63915d26 |
947 | KWSpec spec; |
db81d362 |
948 | int ret; |
949 | |
950 | SAVETMPS; |
951 | |
7dd35535 |
952 | if (kw_flags(aTHX_ keyword_ptr, keyword_len, &spec)) { |
953 | ret = parse_fun(aTHX_ op_ptr, keyword_ptr, keyword_len, &spec); |
db81d362 |
954 | } else { |
7dd35535 |
955 | ret = next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr); |
db81d362 |
956 | } |
957 | |
958 | FREETMPS; |
959 | |
960 | return ret; |
961 | } |
962 | |
963 | WARNINGS_RESET |
964 | |
965 | MODULE = Function::Parameters PACKAGE = Function::Parameters |
966 | PROTOTYPES: ENABLE |
967 | |
968 | BOOT: |
969 | WARNINGS_ENABLE { |
970 | HV *const stash = gv_stashpvs(MY_PKG, GV_ADD); |
426a4d69 |
971 | /**/ |
d8e5d540 |
972 | newCONSTSUB(stash, "FLAG_NAME_OK", newSViv(FLAG_NAME_OK)); |
973 | newCONSTSUB(stash, "FLAG_ANON_OK", newSViv(FLAG_ANON_OK)); |
63915d26 |
974 | newCONSTSUB(stash, "FLAG_DEFAULT_ARGS", newSViv(FLAG_DEFAULT_ARGS)); |
d8e5d540 |
975 | newCONSTSUB(stash, "FLAG_CHECK_NARGS", newSViv(FLAG_CHECK_NARGS)); |
976 | newCONSTSUB(stash, "FLAG_INVOCANT", newSViv(FLAG_INVOCANT)); |
db81d362 |
977 | newCONSTSUB(stash, "HINTK_KEYWORDS", newSVpvs(HINTK_KEYWORDS)); |
d8e5d540 |
978 | newCONSTSUB(stash, "HINTK_FLAGS_", newSVpvs(HINTK_FLAGS_)); |
979 | newCONSTSUB(stash, "HINTK_SHIFT_", newSVpvs(HINTK_SHIFT_)); |
980 | newCONSTSUB(stash, "HINTK_ATTRS_", newSVpvs(HINTK_ATTRS_)); |
426a4d69 |
981 | /**/ |
db81d362 |
982 | next_keyword_plugin = PL_keyword_plugin; |
983 | PL_keyword_plugin = my_keyword_plugin; |
984 | } WARNINGS_RESET |