prune unused code
[p5sagit/Function-Parameters.git] / Parameters.xs
CommitLineData
db81d362 1/*
2Copyright 2012 Lukas Mai.
3
4This program is free software; you can redistribute it and/or modify it
5under the terms of either: the GNU General Public License as published
6by the Free Software Foundation; or the Artistic License.
7
8See 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 53WARNINGS_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
e158cf8f 65#if 0
66 #if HAVE_PERL_VERSION(5, 17, 6)
67 #error "internal error: missing definition of KEY_my (your perl is too new)"
68 #elif HAVE_PERL_VERSION(5, 15, 8)
69 #define S_KEY_my 134
70 #elif HAVE_PERL_VERSION(5, 15, 6)
71 #define S_KEY_my 133
72 #elif HAVE_PERL_VERSION(5, 15, 5)
73 #define S_KEY_my 132
74 #elif HAVE_PERL_VERSION(5, 13, 0)
75 #define S_KEY_my 131
76 #else
77 #error "internal error: missing definition of KEY_my (your perl is too old)"
78 #endif
79#endif
80
63915d26 81
82#define MY_PKG "Function::Parameters"
83
84#define HINTK_KEYWORDS MY_PKG "/keywords"
85#define HINTK_FLAGS_ MY_PKG "/flags:"
86#define HINTK_SHIFT_ MY_PKG "/shift:"
87#define HINTK_ATTRS_ MY_PKG "/attrs:"
88
89#define DEFSTRUCT(T) typedef struct T T; struct T
90
0f875412 91#define UV_BITS (sizeof (UV) * CHAR_BIT)
63915d26 92
93enum {
94 FLAG_NAME_OK = 0x01,
95 FLAG_ANON_OK = 0x02,
96 FLAG_DEFAULT_ARGS = 0x04,
d8e5d540 97 FLAG_CHECK_NARGS = 0x08,
e158cf8f 98 FLAG_INVOCANT = 0x10,
99 FLAG_NAMED_PARAMS = 0x20
63915d26 100};
101
102DEFSTRUCT(KWSpec) {
103 unsigned flags;
b72eb6ee 104 SV *shift;
105 SV *attrs;
63915d26 106};
db81d362 107
108static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
109
e4648f19 110DEFSTRUCT(Resource) {
111 Resource *next;
112 void *data;
113 void (*destroy)(pTHX_ void *);
114};
115
116typedef Resource *Sentinel[1];
117
118static void sentinel_clear_void(pTHX_ void *p) {
119 Resource **pp = p;
120 while (*pp) {
121 Resource *cur = *pp;
122 cur->destroy(aTHX_ cur->data);
123 cur->data = (void *)"no";
124 cur->destroy = NULL;
125 *pp = cur->next;
126 Safefree(cur);
127 }
128}
129
130static void sentinel_register(Sentinel sen, void *data, void (*destroy)(pTHX_ void *)) {
131 Resource *cur;
132
133 Newx(cur, 1, Resource);
134 cur->data = data;
135 cur->destroy = destroy;
136 cur->next = *sen;
137 *sen = cur;
138}
139
140static void my_sv_refcnt_dec_void(pTHX_ void *p) {
141 SV *sv = p;
142 SvREFCNT_dec(sv);
143}
144
145static SV *sentinel_mortalize(Sentinel sen, SV *sv) {
146 sentinel_register(sen, sv, my_sv_refcnt_dec_void);
147 return sv;
148}
149
e4648f19 150static int kw_flags(pTHX_ Sentinel sen, const char *kw_ptr, STRLEN kw_len, KWSpec *spec) {
db81d362 151 HV *hints;
152 SV *sv, **psv;
153 const char *p, *kw_active;
154 STRLEN kw_active_len;
155
63915d26 156 spec->flags = 0;
e4648f19 157 spec->shift = sentinel_mortalize(sen, newSVpvs(""));
158 spec->attrs = sentinel_mortalize(sen, newSVpvs(""));
db81d362 159
160 if (!(hints = GvHV(PL_hintgv))) {
161 return FALSE;
162 }
163 if (!(psv = hv_fetchs(hints, HINTK_KEYWORDS, 0))) {
164 return FALSE;
165 }
166 sv = *psv;
167 kw_active = SvPV(sv, kw_active_len);
168 if (kw_active_len <= kw_len) {
169 return FALSE;
170 }
e88490f6 171 for (
172 p = kw_active;
173 (p = strchr(p, *kw_ptr)) &&
174 p < kw_active + kw_active_len - kw_len;
175 p++
176 ) {
db81d362 177 if (
178 (p == kw_active || p[-1] == ' ') &&
179 p[kw_len] == ' ' &&
180 memcmp(kw_ptr, p, kw_len) == 0
181 ) {
b72eb6ee 182
d970c3e7 183#define FETCH_HINTK_INTO(NAME, PTR, LEN, X) STMT_START { \
b72eb6ee 184 const char *fk_ptr_; \
185 STRLEN fk_len_; \
186 SV *fk_sv_; \
e4648f19 187 fk_sv_ = sentinel_mortalize(sen, newSVpvs(HINTK_ ## NAME)); \
b72eb6ee 188 sv_catpvn(fk_sv_, PTR, LEN); \
189 fk_ptr_ = SvPV(fk_sv_, fk_len_); \
190 if (!((X) = hv_fetch(hints, fk_ptr_, fk_len_, 0))) { \
191 croak("%s: internal error: $^H{'%.*s'} not set", MY_PKG, (int)fk_len_, fk_ptr_); \
192 } \
d970c3e7 193} STMT_END
b72eb6ee 194
63915d26 195 FETCH_HINTK_INTO(FLAGS_, kw_ptr, kw_len, psv);
196 spec->flags = SvIV(*psv);
db81d362 197
b72eb6ee 198 FETCH_HINTK_INTO(SHIFT_, kw_ptr, kw_len, psv);
199 SvSetSV(spec->shift, *psv);
db81d362 200
b72eb6ee 201 FETCH_HINTK_INTO(ATTRS_, kw_ptr, kw_len, psv);
202 SvSetSV(spec->attrs, *psv);
203
204#undef FETCH_HINTK_INTO
db81d362 205 return TRUE;
206 }
207 }
208 return FALSE;
209}
210
211
311ced6f 212static void free_ptr_op(pTHX_ void *vp) {
c311cef3 213 OP **pp = vp;
214 op_free(*pp);
215 Safefree(pp);
216}
217
59016bfb 218#define sv_eq_pvs(SV, S) my_sv_eq_pvn(aTHX_ SV, "" S "", sizeof (S) - 1)
c311cef3 219
59016bfb 220static int my_sv_eq_pvn(pTHX_ SV *sv, const char *p, STRLEN n) {
c311cef3 221 STRLEN sv_len;
222 const char *sv_p = SvPV(sv, sv_len);
59016bfb 223 return memcmp(sv_p, p, n) == 0;
c311cef3 224}
225
226
227#include "padop_on_crack.c.inc"
228
229
c311cef3 230enum {
231 MY_ATTR_LVALUE = 0x01,
232 MY_ATTR_METHOD = 0x02,
233 MY_ATTR_SPECIAL = 0x04
234};
235
31534187 236static void my_sv_cat_c(pTHX_ SV *sv, U32 c) {
237 char ds[UTF8_MAXBYTES + 1], *d;
67fc1ddb 238 d = (char *)uvchr_to_utf8((U8 *)ds, c);
31534187 239 if (d - ds > 1) {
240 sv_utf8_upgrade(sv);
241 }
242 sv_catpvn(sv, ds, d - ds);
243}
244
245static bool my_is_uni_xidfirst(pTHX_ UV c) {
246 U8 tmpbuf[UTF8_MAXBYTES + 1];
247 uvchr_to_utf8(tmpbuf, c);
248 return is_utf8_xidfirst(tmpbuf);
249}
250
251static bool my_is_uni_xidcont(pTHX_ UV c) {
252 U8 tmpbuf[UTF8_MAXBYTES + 1];
253 uvchr_to_utf8(tmpbuf, c);
254 return is_utf8_xidcont(tmpbuf);
255}
256
e4648f19 257static SV *my_scan_word(pTHX_ Sentinel sen, bool allow_package) {
31534187 258 bool at_start, at_substart;
259 I32 c;
e4648f19 260 SV *sv = sentinel_mortalize(sen, newSVpvs(""));
31534187 261 if (lex_bufutf8()) {
262 SvUTF8_on(sv);
263 }
264
265 at_start = at_substart = TRUE;
266 c = lex_peek_unichar(0);
267
268 while (c != -1) {
269 if (at_substart ? my_is_uni_xidfirst(aTHX_ c) : my_is_uni_xidcont(aTHX_ c)) {
270 lex_read_unichar(0);
271 my_sv_cat_c(aTHX_ sv, c);
272 at_substart = FALSE;
273 c = lex_peek_unichar(0);
274 } else if (allow_package && !at_substart && c == '\'') {
275 lex_read_unichar(0);
276 c = lex_peek_unichar(0);
277 if (!my_is_uni_xidfirst(aTHX_ c)) {
278 lex_stuff_pvs("'", 0);
279 break;
280 }
281 sv_catpvs(sv, "'");
282 at_substart = TRUE;
283 } else if (allow_package && (at_start || !at_substart) && c == ':') {
284 lex_read_unichar(0);
285 if (lex_peek_unichar(0) != ':') {
286 lex_stuff_pvs(":", 0);
287 break;
288 }
289 lex_read_unichar(0);
290 c = lex_peek_unichar(0);
291 if (!my_is_uni_xidfirst(aTHX_ c)) {
292 lex_stuff_pvs("::", 0);
293 break;
294 }
295 sv_catpvs(sv, "::");
296 at_substart = TRUE;
297 } else {
298 break;
299 }
300 at_start = FALSE;
301 }
302
303 return SvCUR(sv) ? sv : NULL;
304}
305
e4648f19 306static SV *my_scan_parens_tail(pTHX_ Sentinel sen, bool keep_backslash) {
31534187 307 I32 c, nesting;
308 SV *sv;
309 line_t start;
310
311 start = CopLINE(PL_curcop);
312
e4648f19 313 sv = sentinel_mortalize(sen, newSVpvs(""));
31534187 314 if (lex_bufutf8()) {
315 SvUTF8_on(sv);
316 }
317
318 nesting = 0;
319 for (;;) {
320 c = lex_read_unichar(0);
321 if (c == EOF) {
322 CopLINE_set(PL_curcop, start);
323 return NULL;
324 }
325
326 if (c == '\\') {
327 c = lex_read_unichar(0);
328 if (c == EOF) {
329 CopLINE_set(PL_curcop, start);
330 return NULL;
331 }
332 if (keep_backslash || (c != '(' && c != ')')) {
333 sv_catpvs(sv, "\\");
334 }
335 } else if (c == '(') {
336 nesting++;
337 } else if (c == ')') {
338 if (!nesting) {
339 break;
340 }
341 nesting--;
342 }
343
344 my_sv_cat_c(aTHX_ sv, c);
345 }
346
347 return sv;
348}
349
e4648f19 350static void my_check_prototype(pTHX_ Sentinel sen, const SV *declarator, SV *proto) {
31534187 351 char *start, *r, *w, *end;
352 STRLEN len;
353
354 /* strip spaces */
355 start = SvPV(proto, len);
356 end = start + len;
357
358 for (w = r = start; r < end; r++) {
359 if (!isSPACE(*r)) {
360 *w++ = *r;
361 }
362 }
363 *w = '\0';
364 SvCUR_set(proto, w - start);
365 end = w;
366 len = end - start;
367
368 if (!ckWARN(WARN_ILLEGALPROTO)) {
369 return;
370 }
371
372 /* check for bad characters */
373 if (strspn(start, "$@%*;[]&\\_+") != len) {
e4648f19 374 SV *dsv = sentinel_mortalize(sen, newSVpvs(""));
31534187 375 warner(
376 packWARN(WARN_ILLEGALPROTO),
377 "Illegal character in prototype for %"SVf" : %s",
378 SVfARG(declarator),
379 SvUTF8(proto)
380 ? sv_uni_display(
381 dsv,
382 proto,
383 len,
384 UNI_DISPLAY_ISPRINT
385 )
386 : pv_pretty(dsv, start, len, 60, NULL, NULL,
387 PERL_PV_ESCAPE_NONASCII
388 )
389 );
390 return;
391 }
392
393 for (r = start; r < end; r++) {
394 switch (*r) {
395 default:
396 warner(
397 packWARN(WARN_ILLEGALPROTO),
398 "Illegal character in prototype for %"SVf" : %s",
399 SVfARG(declarator), r
400 );
401 return;
402
403 case '_':
404 if (r[1] && !strchr(";@%", *r)) {
405 warner(
406 packWARN(WARN_ILLEGALPROTO),
407 "Illegal character after '_' in prototype for %"SVf" : %s",
408 SVfARG(declarator), r
409 );
410 return;
411 }
412 break;
413
414 case '@':
415 case '%':
416 if (r[1]) {
417 warner(
418 packWARN(WARN_ILLEGALPROTO),
419 "prototype after '%c' for %"SVf": %s",
420 *r, SVfARG(declarator), r + 1
421 );
422 return;
423 }
424 break;
425
426 case '\\':
427 r++;
428 if (strchr("$@%&*", *r)) {
429 break;
430 }
431 if (*r == '[') {
432 r++;
433 for (; r < end && *r != ']'; r++) {
434 if (!strchr("$@%&*", *r)) {
435 break;
436 }
437 }
438 if (*r == ']' && r[-1] != '[') {
439 break;
440 }
441 }
442 warner(
443 packWARN(WARN_ILLEGALPROTO),
444 "Illegal character after '\\' in prototype for %"SVf" : %s",
445 SVfARG(declarator), r
446 );
447 return;
448
449 case '$':
450 case '*':
451 case '&':
452 case ';':
453 case '+':
454 break;
455 }
456 }
457}
458
e158cf8f 459
460DEFSTRUCT(Param) {
461 SV *name;
462 PADOFFSET padoff;
463};
464
465DEFSTRUCT(ParamInit) {
466 Param param;
467 OP *init;
468};
469
470#define VEC(B) B ## _Vec
471
472#define DEFVECTOR(B) DEFSTRUCT(VEC(B)) { \
473 B (*data); \
474 size_t used, size; \
475}
476
477DEFVECTOR(Param);
478DEFVECTOR(ParamInit);
479
480#define DEFVECTOR_INIT(N, B) static void N(VEC(B) *p) { \
481 p->used = 0; \
482 p->size = 23; \
483 Newx(p->data, p->size, B); \
484} static void N(VEC(B) *)
485
486DEFSTRUCT(ParamSpec) {
487 Param invocant;
488 VEC(Param) positional_required;
489 VEC(ParamInit) positional_optional;
490 VEC(Param) named_required;
491 VEC(ParamInit) named_optional;
492 Param slurpy;
fc634bba 493 PADOFFSET rest_hash;
e158cf8f 494};
495
496DEFVECTOR_INIT(pv_init, Param);
497DEFVECTOR_INIT(piv_init, ParamInit);
498
499static void p_init(Param *p) {
500 p->name = NULL;
501 p->padoff = NOT_IN_PAD;
502}
503
504static void ps_init(ParamSpec *ps) {
505 p_init(&ps->invocant);
506 pv_init(&ps->positional_required);
507 piv_init(&ps->positional_optional);
508 pv_init(&ps->named_required);
509 piv_init(&ps->named_optional);
510 p_init(&ps->slurpy);
fc634bba 511 ps->rest_hash = NOT_IN_PAD;
e158cf8f 512}
513
514#define DEFVECTOR_EXTEND(N, B) static B (*N(VEC(B) *p)) { \
515 assert(p->used <= p->size); \
516 if (p->used == p->size) { \
517 const size_t n = p->size / 2 * 3 + 1; \
518 Renew(p->data, n, B); \
519 p->size = n; \
520 } \
521 return &p->data[p->used]; \
522} static B (*N(VEC(B) *))
523
524DEFVECTOR_EXTEND(pv_extend, Param);
525DEFVECTOR_EXTEND(piv_extend, ParamInit);
526
527#define DEFVECTOR_CLEAR(N, B, F) static void N(pTHX_ VEC(B) *p) { \
528 while (p->used) { \
529 p->used--; \
530 F(aTHX_ &p->data[p->used]); \
531 } \
532 Safefree(p->data); \
533 p->data = NULL; \
534 p->size = 0; \
535} static void N(pTHX_ VEC(B) *)
536
537static void p_clear(pTHX_ Param *p) {
538 p->name = NULL;
539 p->padoff = NOT_IN_PAD;
540}
541
542static void pi_clear(pTHX_ ParamInit *pi) {
543 p_clear(aTHX_ &pi->param);
544 if (pi->init) {
545 op_free(pi->init);
546 pi->init = NULL;
547 }
548}
549
550DEFVECTOR_CLEAR(pv_clear, Param, p_clear);
551DEFVECTOR_CLEAR(piv_clear, ParamInit, pi_clear);
552
553static void ps_clear(pTHX_ ParamSpec *ps) {
554 p_clear(aTHX_ &ps->invocant);
555
556 pv_clear(aTHX_ &ps->positional_required);
557 piv_clear(aTHX_ &ps->positional_optional);
558
559 pv_clear(aTHX_ &ps->named_required);
560 piv_clear(aTHX_ &ps->named_optional);
561
562 p_clear(aTHX_ &ps->slurpy);
563}
564
565static int ps_contains(pTHX_ const ParamSpec *ps, SV *sv) {
566 size_t i, lim;
567
568 if (ps->invocant.name && sv_eq(sv, ps->invocant.name)) {
569 return 1;
570 }
571
572 for (i = 0, lim = ps->positional_required.used; i < lim; i++) {
573 if (sv_eq(sv, ps->positional_required.data[i].name)) {
574 return 1;
575 }
576 }
577
578 for (i = 0, lim = ps->positional_optional.used; i < lim; i++) {
579 if (sv_eq(sv, ps->positional_optional.data[i].param.name)) {
580 return 1;
581 }
582 }
583
584 for (i = 0, lim = ps->named_required.used; i < lim; i++) {
585 if (sv_eq(sv, ps->named_required.data[i].name)) {
586 return 1;
587 }
588 }
589
590 for (i = 0, lim = ps->named_optional.used; i < lim; i++) {
591 if (sv_eq(sv, ps->named_optional.data[i].param.name)) {
592 return 1;
593 }
594 }
595
596 return 0;
597}
598
599static void ps_free_void(pTHX_ void *p) {
600 ps_clear(aTHX_ p);
601 Safefree(p);
602}
603
604static int args_min(pTHX_ const ParamSpec *ps, const KWSpec *ks) {
605 int n = 0;
606 if (!ps) {
607 return SvTRUE(ks->shift) ? 1 : 0;
608 }
609 if (ps->invocant.name) {
610 n++;
611 }
612 n += ps->positional_required.used;
613 n += ps->named_required.used * 2;
614 return n;
615}
616
617static int args_max(const ParamSpec *ps) {
618 int n = 0;
619 if (!ps) {
620 return -1;
621 }
622 if (ps->invocant.name) {
623 n++;
624 }
625 n += ps->positional_required.used;
626 n += ps->positional_optional.used;
627 if (ps->named_required.used || ps->named_optional.used || ps->slurpy.name) {
628 n = -1;
629 }
630 return n;
631}
632
633static size_t count_positional_params(const ParamSpec *ps) {
634 return ps->positional_required.used + ps->positional_optional.used;
635}
636
637static size_t count_named_params(const ParamSpec *ps) {
638 return ps->named_required.used + ps->named_optional.used;
639}
640
641enum {
642 PARAM_INVOCANT = 0x01,
643 PARAM_NAMED = 0x02
644};
645
646/* *pinit must be NULL on entry.
647 * caller must free *pinit on error.
648 */
649static PADOFFSET parse_param(
650 pTHX_
e4648f19 651 Sentinel sen,
e158cf8f 652 const SV *declarator, const KWSpec *spec, ParamSpec *param_spec,
653 int *pflags, SV **pname, OP **pinit
654) {
655 I32 c;
656 char sigil;
657 SV *name;
658
659 assert(!*pinit);
660 *pflags = 0;
661
662 c = lex_peek_unichar(0);
663
664 if (c == ':') {
665 lex_read_unichar(0);
666 lex_read_space(0);
667
668 *pflags |= PARAM_NAMED;
669
670 c = lex_peek_unichar(0);
671 }
672
673 if (c == -1) {
674 croak("In %"SVf": unterminated parameter list", SVfARG(declarator));
675 }
676 if (!(c == '$' || c == '@' || c == '%')) {
677 croak("In %"SVf": unexpected '%c' in parameter list (expecting a sigil)", SVfARG(declarator), (int)c);
678 }
679
680 sigil = c;
681
682 lex_read_unichar(0);
683 lex_read_space(0);
684
e4648f19 685 if (!(name = my_scan_word(aTHX_ sen, FALSE))) {
e158cf8f 686 croak("In %"SVf": missing identifier after '%c'", SVfARG(declarator), sigil);
687 }
688 sv_insert(name, 0, 0, &sigil, 1);
689 *pname = name;
690
691 lex_read_space(0);
692 c = lex_peek_unichar(0);
693
694 if (c == '=') {
695 lex_read_unichar(0);
696 lex_read_space(0);
697
698
699 if (!param_spec->invocant.name && SvTRUE(spec->shift)) {
700 param_spec->invocant.name = spec->shift;
701 param_spec->invocant.padoff = pad_add_name_sv(param_spec->invocant.name, 0, NULL, NULL);
702 }
703
704 *pinit = parse_termexpr(0);
705
706 lex_read_space(0);
707 c = lex_peek_unichar(0);
708 }
709
710 if (c == ':') {
711 *pflags |= PARAM_INVOCANT;
712 lex_read_unichar(0);
713 lex_read_space(0);
714 } else if (c == ',') {
715 lex_read_unichar(0);
716 lex_read_space(0);
717 } else if (c != ')') {
718 if (c == -1) {
719 croak("In %"SVf": unterminated parameter list", SVfARG(declarator));
720 }
721 croak("In %"SVf": unexpected '%c' in parameter list (expecting ',')", SVfARG(declarator), (int)c);
722 }
723
724 return pad_add_name_sv(*pname, IF_HAVE_PERL_5_16(padadd_NO_DUP_CHECK, 0), NULL, NULL);
725}
726
727static OP *my_var_g(pTHX_ I32 type, I32 flags, PADOFFSET padoff) {
728 OP *var = newOP(type, flags);
729 var->op_targ = padoff;
730 return var;
731}
732
733static OP *my_var(pTHX_ I32 flags, PADOFFSET padoff) {
734 return my_var_g(aTHX_ OP_PADSV, flags, padoff);
735}
736
fc634bba 737static OP *mkhvelem(pTHX_ PADOFFSET h, OP *k) {
738 OP *hv = my_var_g(aTHX_ OP_PADHV, OPf_REF, h);
739 return newBINOP(OP_HELEM, 0, hv, k);
740}
741
742static OP *mkconstsv(pTHX_ SV *sv) {
743 return newSVOP(OP_CONST, 0, sv);
744}
745
746static OP *mkconstiv(pTHX_ IV i) {
747 return mkconstsv(aTHX_ newSViv(i));
748}
749
750static OP *mkconstpv(pTHX_ const char *p, size_t n) {
751 return mkconstsv(aTHX_ newSVpv(p, n));
752}
753
754#define mkconstpvs(S) mkconstpv(aTHX_ "" S "", sizeof S - 1)
755
e4648f19 756static int parse_fun(pTHX_ Sentinel sen, OP **pop, const char *keyword_ptr, STRLEN keyword_len, const KWSpec *spec) {
e158cf8f 757 ParamSpec *param_spec;
c311cef3 758 SV *declarator;
759 I32 floor_ix;
63915d26 760 int save_ix;
c311cef3 761 SV *saw_name;
1e0f1595 762 OP **prelude_sentinel;
c311cef3 763 SV *proto;
764 OP **attrs_sentinel, *body;
765 unsigned builtin_attrs;
db81d362 766 I32 c;
767
e4648f19 768 declarator = sentinel_mortalize(sen, newSVpvn(keyword_ptr, keyword_len));
db81d362 769
db81d362 770 lex_read_space(0);
771
c311cef3 772 builtin_attrs = 0;
773
db81d362 774 /* function name */
c311cef3 775 saw_name = NULL;
e4648f19 776 if ((spec->flags & FLAG_NAME_OK) && (saw_name = my_scan_word(aTHX_ sen, TRUE))) {
c311cef3 777
778 if (PL_parser->expect != XSTATE) {
779 /* bail out early so we don't predeclare $saw_name */
780 croak("In %"SVf": I was expecting a function body, not \"%"SVf"\"", SVfARG(declarator), SVfARG(saw_name));
781 }
782
db81d362 783 sv_catpvs(declarator, " ");
c311cef3 784 sv_catsv(declarator, saw_name);
785
786 if (
787 sv_eq_pvs(saw_name, "BEGIN") ||
788 sv_eq_pvs(saw_name, "END") ||
789 sv_eq_pvs(saw_name, "INIT") ||
790 sv_eq_pvs(saw_name, "CHECK") ||
791 sv_eq_pvs(saw_name, "UNITCHECK")
792 ) {
793 builtin_attrs |= MY_ATTR_SPECIAL;
794 }
795
db81d362 796 lex_read_space(0);
63915d26 797 } else if (!(spec->flags & FLAG_ANON_OK)) {
31534187 798 croak("I was expecting a function name, not \"%.*s\"", (int)(PL_parser->bufend - PL_parser->bufptr), PL_parser->bufptr);
db81d362 799 } else {
800 sv_catpvs(declarator, " (anon)");
801 }
802
63915d26 803 /* we're a subroutine declaration */
c311cef3 804 floor_ix = start_subparse(FALSE, saw_name ? 0 : CVf_ANON);
805 SAVEFREESV(PL_compcv);
806
63915d26 807 /* create outer block: '{' */
808 save_ix = S_block_start(aTHX_ TRUE);
809
1e0f1595 810 /* initialize synthetic optree */
811 Newx(prelude_sentinel, 1, OP *);
812 *prelude_sentinel = NULL;
e4648f19 813 sentinel_register(sen, prelude_sentinel, free_ptr_op);
1e0f1595 814
db81d362 815 /* parameters */
e158cf8f 816 param_spec = NULL;
63915d26 817
db81d362 818 c = lex_peek_unichar(0);
819 if (c == '(') {
e158cf8f 820 OP **init_sentinel;
821
822 Newx(init_sentinel, 1, OP *);
823 *init_sentinel = NULL;
e4648f19 824 sentinel_register(sen, init_sentinel, free_ptr_op);
e158cf8f 825
826 Newx(param_spec, 1, ParamSpec);
827 ps_init(param_spec);
e4648f19 828 sentinel_register(sen, param_spec, ps_free_void);
db81d362 829
830 lex_read_unichar(0);
831 lex_read_space(0);
832
e158cf8f 833 while ((c = lex_peek_unichar(0)) != ')') {
834 int flags;
835 SV *name;
836 char sigil;
837 PADOFFSET padoff;
c311cef3 838
e4648f19 839 padoff = parse_param(aTHX_ sen, declarator, spec, param_spec, &flags, &name, init_sentinel);
c311cef3 840
e158cf8f 841 S_intro_my(aTHX);
63915d26 842
e158cf8f 843 sigil = SvPV_nolen(name)[0];
db81d362 844
e158cf8f 845 /* internal consistency */
846 if (flags & PARAM_NAMED) {
847 if (flags & PARAM_INVOCANT) {
848 croak("In %"SVf": invocant %"SVf" can't be a named parameter", SVfARG(declarator), SVfARG(name));
db81d362 849 }
e158cf8f 850 if (sigil != '$') {
851 croak("In %"SVf": named parameter %"SVf" can't be a%s", SVfARG(declarator), SVfARG(name), sigil == '@' ? "n array" : " hash");
db81d362 852 }
e158cf8f 853 } else if (flags & PARAM_INVOCANT) {
854 if (*init_sentinel) {
855 croak("In %"SVf": invocant %"SVf" can't have a default value", SVfARG(declarator), SVfARG(name));
db81d362 856 }
e158cf8f 857 if (sigil != '$') {
858 croak("In %"SVf": invocant %"SVf" can't be a%s", SVfARG(declarator), SVfARG(name), sigil == '@' ? "n array" : " hash");
859 }
860 } else if (sigil != '$' && *init_sentinel) {
861 croak("In %"SVf": %s %"SVf" can't have a default value", SVfARG(declarator), sigil == '@' ? "array" : "hash", SVfARG(name));
862 }
db81d362 863
e158cf8f 864 /* external constraints */
865 if (param_spec->slurpy.name) {
866 croak("In %"SVf": I was expecting \")\" after \"%"SVf"\", not \"%"SVf"\"", SVfARG(declarator), SVfARG(param_spec->slurpy.name), SVfARG(name));
867 }
868 if (sigil != '$') {
869 assert(!*init_sentinel);
870 param_spec->slurpy.name = name;
871 param_spec->slurpy.padoff = padoff;
872 continue;
873 }
d8e5d540 874
e158cf8f 875 if (!(flags & PARAM_NAMED) && count_named_params(param_spec)) {
876 croak("In %"SVf": positional parameter %"SVf" can't appear after named parameter %"SVf"", SVfARG(declarator), SVfARG(name), SVfARG((param_spec->named_required.used ? param_spec->named_required.data[0] : param_spec->named_optional.data[0].param).name));
877 }
d8e5d540 878
e158cf8f 879 if (flags & PARAM_INVOCANT) {
880 if (param_spec->invocant.name) {
881 croak("In %"SVf": invalid double invocants %"SVf", %"SVf"", SVfARG(declarator), SVfARG(param_spec->invocant.name), SVfARG(name));
882 }
883 if (count_positional_params(param_spec) || count_named_params(param_spec)) {
884 croak("In %"SVf": invocant %"SVf" must be first in parameter list", SVfARG(declarator), SVfARG(name));
63915d26 885 }
e158cf8f 886 if (!(spec->flags & FLAG_INVOCANT)) {
887 croak("In %"SVf": invocant %"SVf" not allowed here", SVfARG(declarator), SVfARG(name));
888 }
889 param_spec->invocant.name = name;
890 param_spec->invocant.padoff = padoff;
891 continue;
892 }
63915d26 893
e158cf8f 894 if (*init_sentinel && !(spec->flags & FLAG_DEFAULT_ARGS)) {
895 croak("In %"SVf": default argument for %"SVf" not allowed here", SVfARG(declarator), SVfARG(name));
896 }
1e0f1595 897
e158cf8f 898 if (ps_contains(aTHX_ param_spec, name)) {
899 croak("In %"SVf": %"SVf" can't appear twice in the same parameter list", SVfARG(declarator), SVfARG(name));
900 }
1e0f1595 901
e158cf8f 902 if (flags & PARAM_NAMED) {
903 if (!(spec->flags & FLAG_NAMED_PARAMS)) {
904 croak("In %"SVf": named parameter :%"SVf" not allowed here", SVfARG(declarator), SVfARG(name));
1e0f1595 905 }
906
e158cf8f 907 if (*init_sentinel) {
908 ParamInit *pi = piv_extend(&param_spec->named_optional);
909 pi->param.name = name;
910 pi->param.padoff = padoff;
911 pi->init = *init_sentinel;
912 *init_sentinel = NULL;
913 param_spec->named_optional.used++;
914 } else {
67fc1ddb 915 Param *p;
916
e158cf8f 917 if (param_spec->positional_optional.used) {
918 croak("In %"SVf": can't combine optional positional (%"SVf") and required named (%"SVf") parameters", SVfARG(declarator), SVfARG(param_spec->positional_optional.data[0].param.name), SVfARG(name));
919 }
d8e5d540 920
67fc1ddb 921 p = pv_extend(&param_spec->named_required);
e158cf8f 922 p->name = name;
923 p->padoff = padoff;
924 param_spec->named_required.used++;
925 }
926 } else {
927 if (*init_sentinel || param_spec->positional_optional.used) {
928 ParamInit *pi = piv_extend(&param_spec->positional_optional);
929 pi->param.name = name;
930 pi->param.padoff = padoff;
931 pi->init = *init_sentinel;
932 *init_sentinel = NULL;
933 param_spec->positional_optional.used++;
934 } else {
935 Param *p = pv_extend(&param_spec->positional_required);
936 p->name = name;
937 p->padoff = padoff;
938 param_spec->positional_required.used++;
db81d362 939 }
940 }
941
e158cf8f 942 }
943 lex_read_unichar(0);
944 lex_read_space(0);
945 *init_sentinel = NULL;
db81d362 946
e158cf8f 947 if (!param_spec->invocant.name && SvTRUE(spec->shift)) {
948 if (ps_contains(aTHX_ param_spec, spec->shift)) {
949 croak("In %"SVf": %"SVf" can't appear twice in the same parameter list", SVfARG(declarator), SVfARG(spec->shift));
db81d362 950 }
e158cf8f 951
952 param_spec->invocant.name = spec->shift;
953 param_spec->invocant.padoff = pad_add_name_sv(param_spec->invocant.name, 0, NULL, NULL);
db81d362 954 }
955 }
956
957 /* prototype */
c311cef3 958 proto = NULL;
db81d362 959 c = lex_peek_unichar(0);
960 if (c == ':') {
961 lex_read_unichar(0);
962 lex_read_space(0);
963
964 c = lex_peek_unichar(0);
965 if (c != '(') {
c311cef3 966 lex_stuff_pvs(":", 0);
967 c = ':';
db81d362 968 } else {
31534187 969 lex_read_unichar(0);
e4648f19 970 if (!(proto = my_scan_parens_tail(aTHX_ sen, FALSE))) {
f34187b8 971 croak("In %"SVf": prototype not terminated", SVfARG(declarator));
db81d362 972 }
e4648f19 973 my_check_prototype(aTHX_ sen, declarator, proto);
db81d362 974 lex_read_space(0);
c311cef3 975 c = lex_peek_unichar(0);
514bcaa6 976 if (!(c == ':' || c == '{')) {
977 lex_stuff_pvs(":", 0);
978 c = ':';
979 }
db81d362 980 }
981 }
982
db81d362 983 /* attributes */
c311cef3 984 Newx(attrs_sentinel, 1, OP *);
985 *attrs_sentinel = NULL;
e4648f19 986 sentinel_register(sen, attrs_sentinel, free_ptr_op);
c311cef3 987
63915d26 988 if (c == ':' || c == '{') /* '}' - hi, vim */ {
c311cef3 989
990 /* kludge default attributes in */
991 if (SvTRUE(spec->attrs) && SvPV_nolen(spec->attrs)[0] == ':') {
992 lex_stuff_sv(spec->attrs, 0);
993 c = ':';
994 }
b72eb6ee 995
db81d362 996 if (c == ':') {
db81d362 997 lex_read_unichar(0);
998 lex_read_space(0);
db81d362 999 c = lex_peek_unichar(0);
c311cef3 1000
1001 for (;;) {
1002 SV *attr;
1003
e4648f19 1004 if (!(attr = my_scan_word(aTHX_ sen, FALSE))) {
c311cef3 1005 break;
db81d362 1006 }
c311cef3 1007
db81d362 1008 lex_read_space(0);
1009 c = lex_peek_unichar(0);
c311cef3 1010
1011 if (c != '(') {
1012 if (sv_eq_pvs(attr, "lvalue")) {
1013 builtin_attrs |= MY_ATTR_LVALUE;
1014 attr = NULL;
1015 } else if (sv_eq_pvs(attr, "method")) {
1016 builtin_attrs |= MY_ATTR_METHOD;
1017 attr = NULL;
1018 }
1019 } else {
31534187 1020 SV *sv;
1021 lex_read_unichar(0);
e4648f19 1022 if (!(sv = my_scan_parens_tail(aTHX_ sen, TRUE))) {
c311cef3 1023 croak("In %"SVf": unterminated attribute parameter in attribute list", SVfARG(declarator));
1024 }
31534187 1025 sv_catpvs(attr, "(");
c311cef3 1026 sv_catsv(attr, sv);
31534187 1027 sv_catpvs(attr, ")");
c311cef3 1028
1029 lex_read_space(0);
1030 c = lex_peek_unichar(0);
1031 }
1032
1033 if (attr) {
fc634bba 1034 *attrs_sentinel = op_append_elem(OP_LIST, *attrs_sentinel, mkconstsv(aTHX_ SvREFCNT_inc_simple_NN(attr)));
c311cef3 1035 }
1036
1037 if (c == ':') {
1038 lex_read_unichar(0);
1039 lex_read_space(0);
1040 c = lex_peek_unichar(0);
1041 }
db81d362 1042 }
1043 }
1044 }
1045
1046 /* body */
63915d26 1047 if (c != '{') /* '}' - hi, vim */ {
85bc3fbd 1048 croak("In %"SVf": I was expecting a function body, not \"%c\"", SVfARG(declarator), (int)c);
db81d362 1049 }
c311cef3 1050
63915d26 1051 /* surprise predeclaration! */
1052 if (saw_name) {
1053 /* 'sub NAME (PROTO);' to make name/proto known to perl before it
1054 starts parsing the body */
1055 const I32 sub_ix = start_subparse(FALSE, 0);
1056 SAVEFREESV(PL_compcv);
1057
1058 SvREFCNT_inc_simple_void(PL_compcv);
1059
1060 newATTRSUB(
1061 sub_ix,
fc634bba 1062 mkconstsv(aTHX_ SvREFCNT_inc_simple_NN(saw_name)),
1063 proto ? mkconstsv(aTHX_ SvREFCNT_inc_simple_NN(proto)) : NULL,
63915d26 1064 NULL,
1065 NULL
1066 );
1067 }
1068
c311cef3 1069 if (builtin_attrs & MY_ATTR_LVALUE) {
1070 CvLVALUE_on(PL_compcv);
db81d362 1071 }
c311cef3 1072 if (builtin_attrs & MY_ATTR_METHOD) {
1073 CvMETHOD_on(PL_compcv);
1074 }
1075 if (builtin_attrs & MY_ATTR_SPECIAL) {
1076 CvSPECIAL_on(PL_compcv);
db81d362 1077 }
1078
e158cf8f 1079 /* check number of arguments */
1e0f1595 1080 if (spec->flags & FLAG_CHECK_NARGS) {
e158cf8f 1081 int amin, amax;
abccbe86 1082
e158cf8f 1083 amin = args_min(aTHX_ param_spec, spec);
1084 if (amin > 0) {
67fc1ddb 1085 OP *chk, *cond, *err, *xcroak;
63915d26 1086
fc634bba 1087 err = mkconstsv(aTHX_ newSVpvf("Not enough arguments for %"SVf" (expected %d, got ", SVfARG(declarator), amin));
1088 err = newBINOP(
1089 OP_CONCAT, 0,
1090 err,
1091 newAVREF(newGVOP(OP_GV, 0, PL_defgv))
1092 );
1093 err = newBINOP(
1094 OP_CONCAT, 0,
1095 err,
1096 mkconstpvs(")")
1097 );
63915d26 1098
67fc1ddb 1099 xcroak = newCVREF(OPf_WANT_SCALAR,
1100 newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV)));
1e0f1595 1101 err = newUNOP(OP_ENTERSUB, OPf_STACKED,
67fc1ddb 1102 op_append_elem(OP_LIST, err, xcroak));
63915d26 1103
1e0f1595 1104 cond = newBINOP(OP_LT, 0,
5f50e017 1105 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
fc634bba 1106 mkconstiv(aTHX_ amin));
1e0f1595 1107 chk = newLOGOP(OP_AND, 0, cond, err);
63915d26 1108
1e0f1595 1109 *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, chk));
1110 }
abccbe86 1111
e158cf8f 1112 amax = args_max(param_spec);
1113 if (amax >= 0) {
67fc1ddb 1114 OP *chk, *cond, *err, *xcroak;
63915d26 1115
fc634bba 1116 err = mkconstsv(aTHX_ newSVpvf("Too many arguments for %"SVf" (expected %d, got ", SVfARG(declarator), amax));
1117 err = newBINOP(
1118 OP_CONCAT, 0,
1119 err,
1120 newAVREF(newGVOP(OP_GV, 0, PL_defgv))
1121 );
1122 err = newBINOP(
1123 OP_CONCAT, 0,
1124 err,
1125 mkconstpvs(")")
1126 );
63915d26 1127
67fc1ddb 1128 xcroak = newCVREF(
fc634bba 1129 OPf_WANT_SCALAR,
1130 newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV))
1131 );
1e0f1595 1132 err = newUNOP(OP_ENTERSUB, OPf_STACKED,
67fc1ddb 1133 op_append_elem(OP_LIST, err, xcroak));
63915d26 1134
fc634bba 1135 cond = newBINOP(
1136 OP_GT, 0,
1137 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
1138 mkconstiv(aTHX_ amax)
1139 );
1e0f1595 1140 chk = newLOGOP(OP_AND, 0, cond, err);
63915d26 1141
1e0f1595 1142 *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, chk));
1143 }
e158cf8f 1144
1145 if (param_spec && (count_named_params(param_spec) || (param_spec->slurpy.name && SvPV_nolen(param_spec->slurpy.name)[0] == '%'))) {
67fc1ddb 1146 OP *chk, *cond, *err, *xcroak;
e158cf8f 1147 const UV fixed = count_positional_params(param_spec) + !!param_spec->invocant.name;
63915d26 1148
fc634bba 1149 err = mkconstsv(aTHX_ newSVpvf("Odd number of paired arguments for %"SVf"", SVfARG(declarator)));
63915d26 1150
67fc1ddb 1151 xcroak = newCVREF(
fc634bba 1152 OPf_WANT_SCALAR,
1153 newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV))
1154 );
1e0f1595 1155 err = newUNOP(OP_ENTERSUB, OPf_STACKED,
67fc1ddb 1156 op_append_elem(OP_LIST, err, xcroak));
63915d26 1157
1e0f1595 1158 cond = newBINOP(OP_GT, 0,
5f50e017 1159 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
fc634bba 1160 mkconstiv(aTHX_ fixed));
e158cf8f 1161 cond = newLOGOP(OP_AND, 0,
fc634bba 1162 cond,
1163 newBINOP(OP_MODULO, 0,
1164 fixed
1165 ? newBINOP(OP_SUBTRACT, 0,
1166 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
1167 mkconstiv(aTHX_ fixed))
1168 : newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
1169 mkconstiv(aTHX_ 2)));
1e0f1595 1170 chk = newLOGOP(OP_AND, 0, cond, err);
63915d26 1171
1e0f1595 1172 *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, chk));
c311cef3 1173 }
1e0f1595 1174 }
c311cef3 1175
e158cf8f 1176 if (!param_spec) {
1177 /* my $invocant = shift; */
1178 if (SvTRUE(spec->shift)) {
1179 OP *var;
abccbe86 1180
e158cf8f 1181 var = my_var(
1182 aTHX_
1183 OPf_MOD | (OPpLVAL_INTRO << 8),
1184 pad_add_name_sv(spec->shift, 0, NULL, NULL)
1185 );
1186 var = newASSIGNOP(OPf_STACKED, var, 0, newOP(OP_SHIFT, 0));
c311cef3 1187
e158cf8f 1188 *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, var));
1189 }
1190 } else {
1191 /* my $invocant = shift; */
1192 if (param_spec->invocant.name) {
1193 OP *var;
c311cef3 1194
e158cf8f 1195 var = my_var(
1196 aTHX_
1197 OPf_MOD | (OPpLVAL_INTRO << 8),
1198 param_spec->invocant.padoff
1199 );
1200 var = newASSIGNOP(OPf_STACKED, var, 0, newOP(OP_SHIFT, 0));
1e0f1595 1201
e158cf8f 1202 *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, var));
c311cef3 1203 }
1204
e158cf8f 1205 /* my (...) = @_; */
1206 {
1207 OP *lhs;
1208 size_t i, lim;
63915d26 1209
e158cf8f 1210 lhs = NULL;
63915d26 1211
e158cf8f 1212 for (i = 0, lim = param_spec->positional_required.used; i < lim; i++) {
1213 OP *const var = my_var(
1214 aTHX_
1215 OPf_WANT_LIST | (OPpLVAL_INTRO << 8),
1216 param_spec->positional_required.data[i].padoff
1217 );
1218 lhs = op_append_elem(OP_LIST, lhs, var);
1219 }
63915d26 1220
e158cf8f 1221 for (i = 0, lim = param_spec->positional_optional.used; i < lim; i++) {
1222 OP *const var = my_var(
1223 aTHX_
1224 OPf_WANT_LIST | (OPpLVAL_INTRO << 8),
1225 param_spec->positional_optional.data[i].param.padoff
1226 );
1227 lhs = op_append_elem(OP_LIST, lhs, var);
1228 }
63915d26 1229
fc634bba 1230 {
1231 PADOFFSET padoff;
1232 I32 type;
1233 bool slurpy_hash;
1234
1235 /*
1236 * cases:
1237 * 1) no named params
1238 * 1.1) slurpy
1239 * => put it in
1240 * 1.2) no slurpy
1241 * => nop
1242 * 2) named params
1243 * 2.1) no slurpy
1244 * => synthetic %{rest}
1245 * 2.2) slurpy is a hash
1246 * => put it in
1247 * 2.3) slurpy is an array
1248 * => synthetic %{rest}
1249 * remember to declare array later
1250 */
1251
1252 slurpy_hash = param_spec->slurpy.name && SvPV_nolen(param_spec->slurpy.name)[0] == '%';
1253 if (!count_named_params(param_spec)) {
1254 if (param_spec->slurpy.name) {
1255 padoff = param_spec->slurpy.padoff;
1256 type = slurpy_hash ? OP_PADHV : OP_PADAV;
1257 } else {
1258 padoff = NOT_IN_PAD;
1259 type = OP_PADSV;
1260 }
1261 } else if (slurpy_hash) {
1262 padoff = param_spec->slurpy.padoff;
1263 type = OP_PADHV;
e158cf8f 1264 } else {
fc634bba 1265 padoff = param_spec->rest_hash = pad_add_name_pvs("%{rest}", 0, NULL, NULL);
1266 type = OP_PADHV;
1267 }
1268
1269 if (padoff != NOT_IN_PAD) {
e158cf8f 1270 OP *const var = my_var_g(
1271 aTHX_
fc634bba 1272 type,
e158cf8f 1273 OPf_WANT_LIST | (OPpLVAL_INTRO << 8),
fc634bba 1274 padoff
e158cf8f 1275 );
fc634bba 1276
e158cf8f 1277 lhs = op_append_elem(OP_LIST, lhs, var);
fc634bba 1278
1279 if (type == OP_PADHV) {
1280 param_spec->rest_hash = padoff;
1281 }
e158cf8f 1282 }
1283 }
63915d26 1284
e158cf8f 1285 if (lhs) {
1286 OP *rhs;
1287 lhs->op_flags |= OPf_PARENS;
1288 rhs = newAVREF(newGVOP(OP_GV, 0, PL_defgv));
1289
1290 *prelude_sentinel = op_append_list(
1291 OP_LINESEQ, *prelude_sentinel,
1292 newSTATEOP(
1293 0, NULL,
1294 newASSIGNOP(OPf_STACKED, lhs, 0, rhs)
1295 )
1296 );
1297 }
1298 }
63915d26 1299
fc634bba 1300 /* default positional arguments */
e158cf8f 1301 {
1302 size_t i, lim, req;
1303 OP *nest;
63915d26 1304
e158cf8f 1305 nest = NULL;
63915d26 1306
e158cf8f 1307 req = param_spec->positional_required.used;
1308 for (i = 0, lim = param_spec->positional_optional.used; i < lim; i++) {
1309 ParamInit *cur = &param_spec->positional_optional.data[i];
1310 OP *var, *cond;
63915d26 1311
e158cf8f 1312 cond = newBINOP(
1313 OP_LT, 0,
1314 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
fc634bba 1315 mkconstiv(aTHX_ req + i + 1)
e158cf8f 1316 );
63915d26 1317
e158cf8f 1318 var = my_var(aTHX_ 0, cur->param.padoff);
63915d26 1319
e158cf8f 1320 nest = op_append_list(
1321 OP_LINESEQ, nest,
1322 newASSIGNOP(OPf_STACKED, var, 0, cur->init)
1323 );
1324 cur->init = NULL;
1325 nest = newCONDOP(
1326 0,
1327 cond,
1328 nest,
1329 NULL
1330 );
1331 }
1e0f1595 1332
e158cf8f 1333 *prelude_sentinel = op_append_list(
1334 OP_LINESEQ, *prelude_sentinel,
1335 nest
1336 );
c311cef3 1337 }
1338
e158cf8f 1339 /* named parameters */
1340 if (count_named_params(param_spec)) {
fc634bba 1341 size_t i, lim;
1342
1343 assert(param_spec->rest_hash != NOT_IN_PAD);
1344
1345 for (i = 0, lim = param_spec->named_required.used; i < lim; i++) {
1346 Param *cur = &param_spec->named_required.data[i];
1347 size_t n;
1348 char *p = SvPV(cur->name, n);
1349 OP *var, *cond;
1350
1351 cond = mkhvelem(aTHX_ param_spec->rest_hash, mkconstpv(aTHX_ p + 1, n - 1));
1352
1353 if (spec->flags & FLAG_CHECK_NARGS) {
67fc1ddb 1354 OP *xcroak, *msg;
fc634bba 1355
1356 var = mkhvelem(aTHX_ param_spec->rest_hash, mkconstpv(aTHX_ p + 1, n - 1));
1357 var = newUNOP(OP_DELETE, 0, var);
1358
1359 msg = mkconstsv(aTHX_ newSVpvf("In %"SVf": missing named parameter: %.*s", SVfARG(declarator), (int)(n - 1), p + 1));
67fc1ddb 1360 xcroak = newCVREF(
fc634bba 1361 OPf_WANT_SCALAR,
1362 newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV))
1363 );
67fc1ddb 1364 xcroak = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, msg, xcroak));
fc634bba 1365
1366 cond = newUNOP(OP_EXISTS, 0, cond);
1367
67fc1ddb 1368 cond = newCONDOP(0, cond, var, xcroak);
fc634bba 1369 }
1370
1371 var = my_var(
1372 aTHX_
1373 OPf_MOD | (OPpLVAL_INTRO << 8),
1374 cur->padoff
1375 );
1376 var = newASSIGNOP(OPf_STACKED, var, 0, cond);
1377
1378 *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, var));
1379 }
1380
1381 for (i = 0, lim = param_spec->named_optional.used; i < lim; i++) {
1382 ParamInit *cur = &param_spec->named_optional.data[i];
1383 size_t n;
1384 char *p = SvPV(cur->param.name, n);
1385 OP *var, *cond;
1386
1387 var = mkhvelem(aTHX_ param_spec->rest_hash, mkconstpv(aTHX_ p + 1, n - 1));
1388 var = newUNOP(OP_DELETE, 0, var);
1389
1390 cond = mkhvelem(aTHX_ param_spec->rest_hash, mkconstpv(aTHX_ p + 1, n - 1));
1391 cond = newUNOP(OP_EXISTS, 0, cond);
1392
1393 cond = newCONDOP(0, cond, var, cur->init);
1394 cur->init = NULL;
1395
1396 var = my_var(
1397 aTHX_
1398 OPf_MOD | (OPpLVAL_INTRO << 8),
1399 cur->param.padoff
1400 );
1401 var = newASSIGNOP(OPf_STACKED, var, 0, cond);
1402
1403 *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, var));
1404 }
1405
1406 if (!param_spec->slurpy.name) {
1407 if (spec->flags & FLAG_CHECK_NARGS) {
1408 /* croak if %{rest} */
67fc1ddb 1409 OP *xcroak, *cond, *keys, *msg;
fc634bba 1410
1411 keys = newUNOP(OP_KEYS, 0, my_var_g(aTHX_ OP_PADHV, 0, param_spec->rest_hash));
1412 keys = newLISTOP(OP_SORT, 0, newOP(OP_PUSHMARK, 0), keys);
1413 {
1414 OP *first, *mid, *last;
1415
1416 last = keys;
1417
1418 mid = mkconstpvs(", ");
1419 mid->op_sibling = last;
1420
1421 first = newOP(OP_PUSHMARK, 0);
1422
1423 keys = newLISTOP(OP_JOIN, 0, first, mid);
1424 keys->op_targ = pad_alloc(OP_JOIN, SVs_PADTMP);
1425 ((LISTOP *)keys)->op_last = last;
1426 }
1427
1428 msg = mkconstsv(aTHX_ newSVpvf("In %"SVf": no such named parameter: ", SVfARG(declarator)));
1429 msg = newBINOP(OP_CONCAT, 0, msg, keys);
1430
67fc1ddb 1431 xcroak = newCVREF(
fc634bba 1432 OPf_WANT_SCALAR,
1433 newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV))
1434 );
67fc1ddb 1435 xcroak = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, msg, xcroak));
fc634bba 1436
1437 cond = newUNOP(OP_KEYS, 0, my_var_g(aTHX_ OP_PADHV, 0, param_spec->rest_hash));
67fc1ddb 1438 xcroak = newCONDOP(0, cond, xcroak, NULL);
fc634bba 1439
67fc1ddb 1440 *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, xcroak));
fc634bba 1441 } else {
1442 OP *clear;
1443
1444 clear = newASSIGNOP(
1445 OPf_STACKED,
1446 my_var_g(aTHX_ OP_PADHV, 0, param_spec->rest_hash),
1447 0,
1448 newNULLLIST()
1449 );
1450
1451 *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, clear));
1452 }
1453 } else if (param_spec->slurpy.padoff != param_spec->rest_hash) {
1454 OP *var, *clear;
1455
1456 assert(SvPV_nolen(param_spec->slurpy.name)[0] == '@');
1457
1458 var = my_var_g(
1459 aTHX_
1460 OP_PADAV,
1461 OPf_MOD | (OPpLVAL_INTRO << 8),
1462 param_spec->slurpy.padoff
1463 );
1464
1465 var = newASSIGNOP(OPf_STACKED, var, 0, my_var_g(aTHX_ OP_PADHV, 0, param_spec->rest_hash));
1466
1467 *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, var));
1468
1469 clear = newASSIGNOP(
1470 OPf_STACKED,
1471 my_var_g(aTHX_ OP_PADHV, 0, param_spec->rest_hash),
1472 0,
1473 newNULLLIST()
1474 );
1475
1476 *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, clear));
1477 }
1478 }
1e0f1595 1479 }
c311cef3 1480
1e0f1595 1481 /* finally let perl parse the actual subroutine body */
1482 body = parse_block(0);
c311cef3 1483
1e0f1595 1484 /* add '();' to make function return nothing by default */
1485 /* (otherwise the invisible parameter initialization can "leak" into
1486 the return value: fun ($x) {}->("asdf", 0) == 2) */
1487 if (*prelude_sentinel) {
1488 body = newSTATEOP(0, NULL, body);
db81d362 1489 }
1490
1e0f1595 1491 body = op_append_list(OP_LINESEQ, *prelude_sentinel, body);
1492 *prelude_sentinel = NULL;
1493
c311cef3 1494 /* it's go time. */
1495 {
1496 OP *const attrs = *attrs_sentinel;
1497 *attrs_sentinel = NULL;
1498 SvREFCNT_inc_simple_void(PL_compcv);
1499
63915d26 1500 /* close outer block: '}' */
1501 S_block_end(aTHX_ save_ix, body);
1502
c311cef3 1503 if (!saw_name) {
1504 *pop = newANONATTRSUB(
1505 floor_ix,
1506 proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL,
1507 attrs,
1508 body
1509 );
1510 return KEYWORD_PLUGIN_EXPR;
1511 }
1512
1513 newATTRSUB(
1514 floor_ix,
1515 newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(saw_name)),
1516 proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL,
1517 attrs,
1518 body
1519 );
5efe0e0e 1520 *pop = newOP(OP_NULL, 0);
c311cef3 1521 return KEYWORD_PLUGIN_STMT;
db81d362 1522 }
db81d362 1523}
1524
1525static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) {
63915d26 1526 KWSpec spec;
db81d362 1527 int ret;
e4648f19 1528 Sentinel sen = { NULL };
db81d362 1529
e4648f19 1530 ENTER;
db81d362 1531 SAVETMPS;
1532
e4648f19 1533 SAVEDESTRUCTOR_X(sentinel_clear_void, sen);
1534
1535 if (kw_flags(aTHX_ sen, keyword_ptr, keyword_len, &spec)) {
1536 ret = parse_fun(aTHX_ sen, op_ptr, keyword_ptr, keyword_len, &spec);
db81d362 1537 } else {
7dd35535 1538 ret = next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
db81d362 1539 }
1540
1541 FREETMPS;
e4648f19 1542 LEAVE;
db81d362 1543
1544 return ret;
1545}
1546
1547WARNINGS_RESET
1548
1549MODULE = Function::Parameters PACKAGE = Function::Parameters
1550PROTOTYPES: ENABLE
1551
1552BOOT:
1553WARNINGS_ENABLE {
1554 HV *const stash = gv_stashpvs(MY_PKG, GV_ADD);
426a4d69 1555 /**/
d8e5d540 1556 newCONSTSUB(stash, "FLAG_NAME_OK", newSViv(FLAG_NAME_OK));
1557 newCONSTSUB(stash, "FLAG_ANON_OK", newSViv(FLAG_ANON_OK));
63915d26 1558 newCONSTSUB(stash, "FLAG_DEFAULT_ARGS", newSViv(FLAG_DEFAULT_ARGS));
d8e5d540 1559 newCONSTSUB(stash, "FLAG_CHECK_NARGS", newSViv(FLAG_CHECK_NARGS));
1560 newCONSTSUB(stash, "FLAG_INVOCANT", newSViv(FLAG_INVOCANT));
e158cf8f 1561 newCONSTSUB(stash, "FLAG_NAMED_PARAMS", newSViv(FLAG_NAMED_PARAMS));
db81d362 1562 newCONSTSUB(stash, "HINTK_KEYWORDS", newSVpvs(HINTK_KEYWORDS));
d8e5d540 1563 newCONSTSUB(stash, "HINTK_FLAGS_", newSVpvs(HINTK_FLAGS_));
1564 newCONSTSUB(stash, "HINTK_SHIFT_", newSVpvs(HINTK_SHIFT_));
1565 newCONSTSUB(stash, "HINTK_ATTRS_", newSVpvs(HINTK_ATTRS_));
426a4d69 1566 /**/
db81d362 1567 next_keyword_plugin = PL_keyword_plugin;
1568 PL_keyword_plugin = my_keyword_plugin;
1569} WARNINGS_RESET