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