File Coverage

Parameters.xs
Criterion Covered Total %
statement 1085 1207 89.8
branch 595 826 72.0
condition n/a
subroutine n/a
pod n/a
total 1680 2033 82.6


line stmt bran cond sub pod time code
1             /*
2             Copyright 2012, 2014, 2023 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__ >= 5
13             #define IF_HAVE_GCC_5(X) X
14             #endif
15              
16             #if (__GNUC__ == 4 && __GNUC_MINOR__ >= 6) || __GNUC__ >= 5
17             #define PRAGMA_GCC_(X) _Pragma(#X)
18             #define PRAGMA_GCC(X) PRAGMA_GCC_(GCC X)
19             #endif
20             #endif
21              
22             #ifndef IF_HAVE_GCC_5
23             #define IF_HAVE_GCC_5(X)
24             #endif
25              
26             #ifndef PRAGMA_GCC
27             #define PRAGMA_GCC(X)
28             #endif
29              
30             #ifdef DEVEL
31             #define WARNINGS_RESET PRAGMA_GCC(diagnostic pop)
32             #define WARNINGS_ENABLEW(X) PRAGMA_GCC(diagnostic error #X)
33             #define WARNINGS_ENABLE \
34             WARNINGS_ENABLEW(-Wall) \
35             WARNINGS_ENABLEW(-Wextra) \
36             WARNINGS_ENABLEW(-Wundef) \
37             WARNINGS_ENABLEW(-Wshadow) \
38             WARNINGS_ENABLEW(-Wbad-function-cast) \
39             WARNINGS_ENABLEW(-Wcast-align) \
40             WARNINGS_ENABLEW(-Wwrite-strings) \
41             WARNINGS_ENABLEW(-Wstrict-prototypes) \
42             WARNINGS_ENABLEW(-Wmissing-prototypes) \
43             WARNINGS_ENABLEW(-Winline) \
44             WARNINGS_ENABLEW(-Wdisabled-optimization) \
45             IF_HAVE_GCC_5(WARNINGS_ENABLEW(-Wnested-externs))
46              
47             #else
48             #define WARNINGS_RESET
49             #define WARNINGS_ENABLE
50             #endif
51              
52              
53             #define PERL_NO_GET_CONTEXT
54             #include "EXTERN.h"
55             #include "perl.h"
56             #include "XSUB.h"
57              
58             #include <string.h>
59              
60             #ifdef DEVEL
61             #undef NDEBUG
62             #include <assert.h>
63             #endif
64              
65             #ifdef PERL_MAD
66             #error "MADness is not supported."
67             #endif
68              
69             #define HAVE_PERL_VERSION(R, V, S) \
70             (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
71              
72             #if HAVE_PERL_VERSION(5, 19, 3)
73             #define IF_HAVE_PERL_5_19_3(YES, NO) YES
74             #else
75             #define IF_HAVE_PERL_5_19_3(YES, NO) NO
76             #endif
77              
78             #ifndef SvREFCNT_dec_NN
79             #define SvREFCNT_dec_NN(SV) SvREFCNT_dec(SV)
80             #endif
81              
82              
83             #define MY_PKG "Function::Parameters"
84              
85             /* 5.22+ shouldn't require any hax */
86             #if !HAVE_PERL_VERSION(5, 22, 0)
87              
88             #if !HAVE_PERL_VERSION(5, 16, 0)
89             #include "hax/pad_alloc.c.inc"
90             #include "hax/pad_add_name_sv.c.inc"
91             #include "hax/pad_add_name_pvs.c.inc"
92              
93             #ifndef padadd_NO_DUP_CHECK
94             #define padadd_NO_DUP_CHECK 0
95             #endif
96             #endif
97              
98             #include "hax/newDEFSVOP.c.inc"
99             #include "hax/intro_my.c.inc"
100             #include "hax/block_start.c.inc"
101             #include "hax/block_end.c.inc"
102              
103             #include "hax/op_convert_list.c.inc" /* < 5.22 */
104             #include "hax/STATIC_ASSERT_STMT.c.inc"
105             #endif
106              
107              
108             WARNINGS_ENABLE
109              
110             #ifdef newSVpvf
111             #undef newSVpvf
112             #endif
113             #define newSVpvf @"perlapi says Perl_newSVpvf must be called explicitly (with aTHX_)"
114             #ifdef warner
115             #undef warner
116             #endif
117             #define warner @"perlapi says Perl_warner must be called explicitly (with aTHX_)"
118             #ifdef croak
119             #undef croak
120             #endif
121             #define croak @"perlapi says Perl_croak must be called explicitly (with aTHX_)"
122              
123             #define HAVE_BUG_GH_15557 (HAVE_PERL_VERSION(5, 21, 7) && !HAVE_PERL_VERSION(5, 25, 5))
124              
125             #define HINTK_CONFIG MY_PKG "/config"
126             #define HINTSK_FLAGS "flags"
127             #define HINTSK_SHIFT "shift"
128             #define HINTSK_SHIF2 "shift_types"
129             #define HINTSK_ATTRS "attrs"
130             #define HINTSK_REIFY "reify"
131             #define HINTSK_INSTL "instl"
132              
133             #define DEFSTRUCT(T) typedef struct T T; struct T
134              
135             #define VEC(B) B ## _Vec
136              
137             #define DEFVECTOR(B) DEFSTRUCT(VEC(B)) { \
138             B (*data); \
139             size_t used, size; \
140             }
141              
142             #define DEFVECTOR_INIT(N, B) static void N(VEC(B) *p) { \
143             p->used = 0; \
144             p->size = 23; \
145             Newx(p->data, p->size, B); \
146             } static void N(VEC(B) *)
147              
148             #define DEFVECTOR_EXTEND(N, B) static B (*N(VEC(B) *p)) { \
149             assert(p->used <= p->size); \
150             if (p->used == p->size) { \
151             const size_t n = p->size / 2 * 3 + 1; \
152             Renew(p->data, n, B); \
153             p->size = n; \
154             } \
155             return &p->data[p->used]; \
156             } static B (*N(VEC(B) *))
157              
158             #define DEFVECTOR_CLEAR_GENERIC(N, N_PARAM_, B, F, F_ARG_) static void N(N_PARAM_ VEC(B) *p) { \
159             while (p->used) { \
160             p->used--; \
161             F(F_ARG_ &p->data[p->used]); \
162             } \
163             Safefree(p->data); \
164             p->data = NULL; \
165             p->size = 0; \
166             } static void N(N_PARAM_ VEC(B) *)
167              
168             #define DEFVECTOR_CLEAR(N, B, F) DEFVECTOR_CLEAR_GENERIC(N, , B, F, )
169             #define DEFVECTOR_CLEAR_THX(N, B, F) DEFVECTOR_CLEAR_GENERIC(N, pTHX_, B, F, aTHX_)
170              
171             enum {
172             FLAG_NAME_OK = 0x001,
173             FLAG_ANON_OK = 0x002,
174             FLAG_DEFAULT_ARGS = 0x004,
175             FLAG_CHECK_NARGS = 0x008,
176             FLAG_INVOCANT = 0x010,
177             FLAG_NAMED_PARAMS = 0x020,
178             FLAG_TYPES_OK = 0x040,
179             FLAG_CHECK_TARGS = 0x080,
180             FLAG_RUNTIME = 0x100
181             };
182              
183             DEFSTRUCT(SpecParam) {
184             SV *name;
185             SV *type;
186             };
187              
188             DEFVECTOR(SpecParam);
189 628 50         DEFVECTOR_INIT(spv_init, SpecParam);
190              
191 201           static void sp_clear(SpecParam *p) {
192 201           p->name = NULL;
193 201           p->type = NULL;
194 201           }
195              
196 829 100         DEFVECTOR_CLEAR(spv_clear, SpecParam, sp_clear);
197              
198 201 50         DEFVECTOR_EXTEND(spv_extend, SpecParam);
    0          
199              
200 201           static void spv_push(VEC(SpecParam) *ps, SV *name, SV *type) {
201 201           SpecParam *p = spv_extend(ps);
202 201           p->name = name;
203 201           p->type = type;
204 201           ps->used++;
205 201           }
206              
207             DEFSTRUCT(KWSpec) {
208             unsigned flags;
209             SV *reify_type;
210             VEC(SpecParam) shift;
211             SV *attrs;
212             SV *install_sub;
213             };
214              
215 628           static void kws_free_void(pTHX_ void *p) {
216 628           KWSpec *const spec = p;
217             PERL_UNUSED_CONTEXT;
218 628           spv_clear(&spec->shift);
219 628           spec->attrs = NULL;
220 628           spec->install_sub = NULL;
221 628           Safefree(spec);
222 628           }
223              
224             DEFSTRUCT(Resource) {
225             Resource *next;
226             void *data;
227             void (*destroy)(pTHX_ void *);
228             };
229              
230             typedef Resource *Sentinel[1];
231              
232 628           static void sentinel_clear_void(pTHX_ void *pv) {
233 628           Resource **pp = pv;
234 628           Resource *p = *pp;
235 628           Safefree(pp);
236 8021 100         while (p) {
237 7393           Resource *cur = p;
238 7393 50         if (cur->destroy) {
239 7393           cur->destroy(aTHX_ cur->data);
240             }
241 7393           cur->data = (void *)"no";
242 7393           cur->destroy = NULL;
243 7393           p = cur->next;
244 7393           Safefree(cur);
245             }
246 628           }
247              
248 7393           static Resource *sentinel_register(Sentinel sen, void *data, void (*destroy)(pTHX_ void *)) {
249             Resource *cur;
250              
251 7393           Newx(cur, 1, Resource);
252 7393           cur->data = data;
253 7393           cur->destroy = destroy;
254 7393           cur->next = *sen;
255 7393           *sen = cur;
256              
257 7393           return cur;
258             }
259              
260 0           static void sentinel_disarm(Resource *p) {
261 0           p->destroy = NULL;
262 0           }
263              
264 3770           static void my_sv_refcnt_dec_void(pTHX_ void *p) {
265 3770           SV *sv = p;
266 3770           SvREFCNT_dec(sv);
267 3770           }
268              
269 3770           static SV *sentinel_mortalize(Sentinel sen, SV *sv) {
270 3770           sentinel_register(sen, sv, my_sv_refcnt_dec_void);
271 3770           return sv;
272             }
273              
274             DEFSTRUCT(RStore_U32) {
275             U32 *where;
276             U32 what;
277             };
278              
279 561           static void resource_store_u32(pTHX_ void *p) {
280             PERL_UNUSED_CONTEXT;
281 561           RStore_U32 *rs = p;
282 561           *rs->where = rs->what;
283 561           Safefree(rs);
284 561           }
285              
286 561           static void sentinel_save_u32(Sentinel sen, U32 *pu) {
287             RStore_U32 *rs;
288 561           Newx(rs, 1, RStore_U32);
289 561           rs->where = pu;
290 561           rs->what = *pu;
291 561           sentinel_register(sen, rs, resource_store_u32);
292 561           }
293              
294             #if HAVE_PERL_VERSION(5, 17, 2)
295             #define MY_OP_SLABBED(O) ((O)->op_slabbed)
296             #else
297             #define MY_OP_SLABBED(O) 0
298             #endif
299              
300             DEFSTRUCT(OpGuard) {
301             OP *op;
302             bool needs_freed;
303             };
304              
305 3210           static void op_guard_init(OpGuard *p) {
306 3210           p->op = NULL;
307 3210           p->needs_freed = FALSE;
308 3210           }
309              
310 1389           static OpGuard op_guard_transfer(OpGuard *p) {
311 1389           OpGuard r = *p;
312 1389           op_guard_init(p);
313 1389           return r;
314             }
315              
316 1254           static OP *op_guard_relinquish(OpGuard *p) {
317 1254           return op_guard_transfer(p).op;
318             }
319              
320 2172           static void op_guard_update(OpGuard *p, OP *o) {
321 2172           p->op = o;
322 2172 100         p->needs_freed = o && !MY_OP_SLABBED(o);
    50          
323 2172           }
324              
325 1956           static void op_guard_clear(pTHX_ OpGuard *p) {
326 1956 50         if (p->needs_freed) {
327 0           op_free(p->op);
328             }
329 1956           }
330              
331 1821           static void free_op_guard_void(pTHX_ void *vp) {
332 1821           OpGuard *p = vp;
333 1821           op_guard_clear(aTHX_ p);
334 1821           Safefree(p);
335 1821           }
336              
337 0           static void free_op_void(pTHX_ void *vp) {
338 0           OP *p = vp;
339 0           op_free(p);
340 0           }
341              
342             #define sv_eq_pvs(SV, S) my_sv_eq_pvn(aTHX_ SV, "" S "", sizeof S - 1)
343              
344 3085           static int my_sv_eq_pvn(pTHX_ SV *sv, const char *p, STRLEN n) {
345             STRLEN sv_len;
346 3085           const char *sv_p = SvPV(sv, sv_len);
347 3085 100         return sv_len == n && memcmp(sv_p, p, n) == 0;
    100          
348             }
349              
350              
351             #ifndef newMETHOP
352             #define newMETHOP newUNOP
353             #endif
354              
355             enum {
356             MY_ATTR_LVALUE = 0x01,
357             MY_ATTR_METHOD = 0x02,
358             MY_ATTR_SPECIAL = 0x04
359             };
360              
361 11315           static void my_sv_cat_c(pTHX_ SV *sv, U32 c) {
362             char ds[UTF8_MAXBYTES + 1], *d;
363 11315           d = (char *)uvchr_to_utf8((U8 *)ds, c);
364 11315 100         if (d - ds > 1) {
365 28           sv_utf8_upgrade(sv);
366             }
367 11315           sv_catpvn(sv, ds, d - ds);
368 11315           }
369              
370              
371             #define MY_UNI_IDFIRST(C) isIDFIRST_uni(C)
372             #define MY_UNI_IDCONT(C) isALNUM_uni(C)
373             #if HAVE_PERL_VERSION(5, 25, 9)
374             #define MY_UNI_IDFIRST_utf8(P, Z) isIDFIRST_utf8_safe((const unsigned char *)(P), (const unsigned char *)(Z))
375             #define MY_UNI_IDCONT_utf8(P, Z) isWORDCHAR_utf8_safe((const unsigned char *)(P), (const unsigned char *)(Z))
376             #else
377             #define MY_UNI_IDFIRST_utf8(P, Z) isIDFIRST_utf8((const unsigned char *)(P))
378             #define MY_UNI_IDCONT_utf8(P, Z) isALNUM_utf8((const unsigned char *)(P))
379             #endif
380              
381 2067           static SV *my_scan_word(pTHX_ Sentinel sen, bool allow_package) {
382             bool at_start, at_substart;
383             I32 c;
384 2067           SV *sv = sentinel_mortalize(sen, newSVpvs(""));
385 2067 100         if (lex_bufutf8()) {
386 31           SvUTF8_on(sv);
387             }
388              
389 2067           at_start = at_substart = TRUE;
390 2067           c = lex_peek_unichar(0);
391              
392 13176 50         while (c != -1) {
393 13176 100         if (at_substart ? MY_UNI_IDFIRST(c) : MY_UNI_IDCONT(c)) {
    100          
    50          
    100          
    100          
    50          
    100          
    100          
394 11081           lex_read_unichar(0);
395 11081           my_sv_cat_c(aTHX_ sv, c);
396 11081           at_substart = FALSE;
397 11081           c = lex_peek_unichar(0);
398 2095 100         } else if (allow_package && !at_substart && c == '\'') {
    100          
    50          
399 0           lex_read_unichar(0);
400 0           c = lex_peek_unichar(0);
401 0 0         if (!MY_UNI_IDFIRST(c)) {
    0          
    0          
    0          
402 0           lex_stuff_pvs("'", 0);
403 0           break;
404             }
405 0           sv_catpvs(sv, "'");
406 0           at_substart = TRUE;
407 2095 100         } else if (allow_package && (at_start || !at_substart) && c == ':') {
    100          
    50          
    100          
408 30           lex_read_unichar(0);
409 30 50         if (lex_peek_unichar(0) != ':') {
410 0           lex_stuff_pvs(":", 0);
411 0           break;
412             }
413 30           lex_read_unichar(0);
414 30           c = lex_peek_unichar(0);
415 30 50         if (!MY_UNI_IDFIRST(c)) {
    50          
    100          
    100          
416 2           lex_stuff_pvs("::", 0);
417 2           break;
418             }
419 28           sv_catpvs(sv, "::");
420 28           at_substart = TRUE;
421             } else {
422             break;
423             }
424 11109           at_start = FALSE;
425             }
426              
427 2067 100         return SvCUR(sv) ? sv : NULL;
428             }
429              
430 68           static SV *my_scan_parens_tail(pTHX_ Sentinel sen, bool keep_backslash) {
431             I32 c, nesting;
432             SV *sv;
433             line_t start;
434              
435 68           start = CopLINE(PL_curcop);
436              
437 68           sv = sentinel_mortalize(sen, newSVpvs(""));
438 68 50         if (lex_bufutf8()) {
439 0           SvUTF8_on(sv);
440             }
441              
442 68           nesting = 0;
443             for (;;) {
444 242           c = lex_read_unichar(0);
445 242 50         if (c == EOF) {
446 0           CopLINE_set(PL_curcop, start);
447 0           return NULL;
448             }
449              
450 242 100         if (c == '\\') {
451 26           c = lex_read_unichar(0);
452 26 50         if (c == EOF) {
453 0           CopLINE_set(PL_curcop, start);
454 0           return NULL;
455             }
456 26 50         if (keep_backslash || (c != '(' && c != ')')) {
    0          
    0          
457 26           sv_catpvs(sv, "\\");
458             }
459 216 50         } else if (c == '(') {
460 0           nesting++;
461 216 100         } else if (c == ')') {
462 68 50         if (!nesting) {
463 68           break;
464             }
465 0           nesting--;
466             }
467              
468 174           my_sv_cat_c(aTHX_ sv, c);
469             }
470              
471 68           return sv;
472             }
473              
474 67           static void my_check_prototype(pTHX_ Sentinel sen, const SV *declarator, SV *proto) {
475             char *start, *r, *w, *end;
476             STRLEN len;
477              
478             /* strip spaces */
479 67           start = SvPVbyte_force(proto, len);
480 67           end = start + len;
481              
482 266 100         for (w = r = start; r < end; r++) {
483 199 100         if (!isSPACE(*r)) {
484 178           *w++ = *r;
485             }
486             }
487 67           *w = '\0';
488 67           SvCUR_set(proto, w - start);
489 67           end = w;
490 67           len = end - start;
491              
492 67 100         if (!ckWARN(WARN_ILLEGALPROTO)) {
493 22           return;
494             }
495              
496             /* check for bad characters */
497 45 50         if (strspn(start, "$@%*;[]&\\_+") != len) {
498 0           SV *dsv = sentinel_mortalize(sen, newSVpvs(""));
499 0           Perl_warner(
500             aTHX_
501             packWARN(WARN_ILLEGALPROTO),
502             "Illegal character in prototype for %"SVf" : %s",
503             SVfARG(declarator),
504 0 0         SvUTF8(proto)
505 0           ? sv_uni_display(
506             dsv,
507             proto,
508             len,
509             UNI_DISPLAY_ISPRINT
510             )
511 0           : pv_pretty(dsv, start, len, 60, NULL, NULL,
512             PERL_PV_ESCAPE_NONASCII
513             )
514             );
515 0           return;
516             }
517              
518 81 100         for (r = start; r < end; r++) {
519 58           switch (*r) {
520 6           default:
521 6           Perl_warner(
522             aTHX_
523             packWARN(WARN_ILLEGALPROTO),
524             "Illegal character in prototype for %"SVf" : %s",
525             SVfARG(declarator), r
526             );
527 0           return;
528              
529 11           case '_':
530 11 100         if (r[1] && !strchr(";@%", r[1])) {
    100          
531 6           Perl_warner(
532             aTHX_
533             packWARN(WARN_ILLEGALPROTO),
534             "Illegal character after '_' in prototype for %"SVf" : %s",
535             SVfARG(declarator), r + 1
536             );
537 0           return;
538             }
539 5           break;
540              
541 5           case '@':
542             case '%':
543 5 50         if (r[1]) {
544 0           Perl_warner(
545             aTHX_
546             packWARN(WARN_ILLEGALPROTO),
547             "prototype after '%c' for %"SVf": %s",
548 0           *r, SVfARG(declarator), r + 1
549             );
550 0           return;
551             }
552 5           break;
553              
554 12           case '\\':
555 12           r++;
556 12 100         if (strchr("$@%&*", *r)) {
557 2           break;
558             }
559 10 100         if (*r == '[') {
560 4           r++;
561 4 50         for (; r < end && *r != ']'; r++) {
    50          
562 4 50         if (!strchr("$@%&*", *r)) {
563 4           break;
564             }
565             }
566 4 50         if (*r == ']' && r[-1] != '[') {
    0          
567 0           break;
568             }
569             }
570 10           Perl_warner(
571             aTHX_
572             packWARN(WARN_ILLEGALPROTO),
573             "Illegal character after '\\' in prototype for %"SVf" : %s",
574             SVfARG(declarator), r
575             );
576 0           return;
577              
578 24           case '$':
579             case '*':
580             case '&':
581             case ';':
582             case '+':
583 24           break;
584             }
585             }
586             }
587              
588             static SV *parse_type(pTHX_ Sentinel, const SV *, char);
589              
590 80           static SV *parse_type_paramd(pTHX_ Sentinel sen, const SV *declarator, char prev) {
591             I32 c;
592             SV *t;
593              
594 80 100         if (!(t = my_scan_word(aTHX_ sen, TRUE))) {
595 1           Perl_croak(aTHX_ "In %"SVf": missing type name after '%c'", SVfARG(declarator), prev);
596             }
597 79           lex_read_space(0);
598              
599 79           c = lex_peek_unichar(0);
600 79 100         if (c == '[') {
601             do {
602             SV *u;
603              
604 22           lex_read_unichar(0);
605 22           lex_read_space(0);
606 22           my_sv_cat_c(aTHX_ t, c);
607              
608 22           u = parse_type(aTHX_ sen, declarator, c);
609 21           sv_catsv(t, u);
610              
611 21           c = lex_peek_unichar(0);
612 21 100         } while (c == ',');
613 13 50         if (c != ']') {
614 0           Perl_croak(aTHX_ "In %"SVf": missing ']' after '%"SVf"'", SVfARG(declarator), SVfARG(t));
615             }
616 13           lex_read_unichar(0);
617 13           lex_read_space(0);
618              
619 13           my_sv_cat_c(aTHX_ t, c);
620             }
621              
622 78           return t;
623             }
624              
625 82           static SV *parse_type_term(pTHX_ Sentinel sen, const SV *declarator, char prev) {
626             I32 c;
627             SV *t, *u;
628              
629 82           t = sentinel_mortalize(sen, newSVpvs(""));
630              
631 86 100         while ((c = lex_peek_unichar(0)) == '~') {
632 4           lex_read_unichar(0);
633 4           lex_read_space(0);
634              
635 4           my_sv_cat_c(aTHX_ t, c);
636 4           prev = c;
637             }
638              
639 82 100         if (c == '(') {
640 2           lex_read_unichar(0);
641 2           lex_read_space(0);
642              
643 2           my_sv_cat_c(aTHX_ t, c);
644 2           u = parse_type(aTHX_ sen, declarator, c);
645 2           sv_catsv(t, u);
646              
647 2           c = lex_peek_unichar(0);
648 2 50         if (c != ')') {
649 0           Perl_croak(aTHX_ "In %"SVf": missing ')' after '%"SVf"'", SVfARG(declarator), SVfARG(t));
650             }
651 2           my_sv_cat_c(aTHX_ t, c);
652 2           lex_read_unichar(0);
653 2           lex_read_space(0);
654              
655 2           return t;
656             }
657              
658 80           u = parse_type_paramd(aTHX_ sen, declarator, prev);
659 78           sv_catsv(t, u);
660 78           return t;
661             }
662              
663 80           static SV *parse_type_alt(pTHX_ Sentinel sen, const SV *declarator, char prev) {
664             I32 c;
665             SV *t;
666              
667 80           t = parse_type_term(aTHX_ sen, declarator, prev);
668              
669 80 100         while ((c = lex_peek_unichar(0)) == '/') {
670             SV *u;
671              
672 2           lex_read_unichar(0);
673 2           lex_read_space(0);
674              
675 2           my_sv_cat_c(aTHX_ t, c);
676 2           u = parse_type_term(aTHX_ sen, declarator, c);
677 2           sv_catsv(t, u);
678             }
679              
680 78           return t;
681             }
682              
683 76           static SV *parse_type_intersect(pTHX_ Sentinel sen, const SV *declarator, char prev) {
684             I32 c;
685             SV *t;
686              
687 76           t = parse_type_alt(aTHX_ sen, declarator, prev);
688              
689 78 100         while ((c = lex_peek_unichar(0)) == '&') {
690             SV *u;
691              
692 4           lex_read_unichar(0);
693 4           lex_read_space(0);
694              
695 4           my_sv_cat_c(aTHX_ t, c);
696 4           u = parse_type_alt(aTHX_ sen, declarator, c);
697 4           sv_catsv(t, u);
698             }
699              
700 74           return t;
701             }
702              
703 65           static SV *parse_type(pTHX_ Sentinel sen, const SV *declarator, char prev) {
704             I32 c;
705             SV *t;
706              
707 65           t = parse_type_intersect(aTHX_ sen, declarator, prev);
708              
709 74 100         while ((c = lex_peek_unichar(0)) == '|') {
710             SV *u;
711              
712 11           lex_read_unichar(0);
713 11           lex_read_space(0);
714              
715 11           my_sv_cat_c(aTHX_ t, c);
716 11           u = parse_type_intersect(aTHX_ sen, declarator, c);
717 11           sv_catsv(t, u);
718             }
719              
720 63           return t;
721             }
722              
723 77           static SV *call_from_curstash(pTHX_ Sentinel sen, SV *sv, SV **args, size_t nargs, I32 flags) {
724             SV *r;
725             COP curcop_with_stash;
726             I32 want;
727 77           dSP;
728              
729             assert(sv != NULL);
730              
731 77 100         if ((flags & G_WANT) == 0) {
732 73           flags |= G_SCALAR;
733             }
734 77           want = flags & G_WANT;
735              
736 77           ENTER;
737 77           SAVETMPS;
738              
739 77 50         PUSHMARK(SP);
740 77 100         if (!args) {
741 12           flags |= G_NOARGS;
742             } else {
743             size_t i;
744 65 50         EXTEND(SP, (SSize_t)nargs);
    50          
745 139 100         for (i = 0; i < nargs; i++) {
746 74           PUSHs(args[i]);
747             }
748             }
749 77           PUTBACK;
750              
751             assert(PL_curcop == &PL_compiling);
752 77           curcop_with_stash = PL_compiling;
753 77           CopSTASH_set(&curcop_with_stash, PL_curstash);
754 77           PL_curcop = &curcop_with_stash;
755 77           call_sv(sv, flags);
756 74           PL_curcop = &PL_compiling;
757              
758 74 100         if (want == G_VOID) {
759 4           r = NULL;
760             } else {
761             assert(want == G_SCALAR);
762 70           SPAGAIN;
763 70           r = sentinel_mortalize(sen, SvREFCNT_inc(POPs));
764 70           PUTBACK;
765             }
766              
767 74 100         FREETMPS;
768 74           LEAVE;
769              
770 74           return r;
771             }
772              
773 45           static SV *reify_type(pTHX_ Sentinel sen, const SV *declarator, const KWSpec *spec, SV *name) {
774             SV *t;
775              
776 45           t = call_from_curstash(aTHX_ sen, spec->reify_type, &name, 1, 0);
777              
778 42 50         if (!sv_isobject(t)) {
779 0           Perl_croak(aTHX_ "In %"SVf": invalid type '%"SVf"' (%"SVf" is not a type object)", SVfARG(declarator), SVfARG(name), SVfARG(t));
780             }
781              
782 42           return t;
783             }
784              
785              
786             DEFSTRUCT(Param) {
787             SV *name;
788             PADOFFSET padoff;
789             SV *type;
790             };
791              
792             typedef enum {
793             ICOND_EXISTS,
794             ICOND_DEFINED
795             } InitCond;
796              
797             DEFSTRUCT(ParamInit) {
798             Param param;
799             OpGuard init;
800             InitCond cond;
801             };
802              
803             DEFVECTOR(Param);
804             DEFVECTOR(ParamInit);
805              
806             DEFSTRUCT(ParamSpec) {
807             size_t shift;
808             VEC(Param) positional_required;
809             VEC(ParamInit) positional_optional;
810             VEC(Param) named_required;
811             VEC(ParamInit) named_optional;
812             Param slurpy;
813             PADOFFSET rest_hash;
814             };
815              
816 1226 50         DEFVECTOR_INIT(pv_init, Param);
817 1226 50         DEFVECTOR_INIT(piv_init, ParamInit);
818              
819 774           static void p_init(Param *p) {
820 774           p->name = NULL;
821 774           p->padoff = NOT_IN_PAD;
822 774           p->type = NULL;
823 774           }
824              
825 613           static void ps_init(ParamSpec *ps) {
826 613           ps->shift = 0;
827 613           pv_init(&ps->positional_required);
828 613           piv_init(&ps->positional_optional);
829 613           pv_init(&ps->named_required);
830 613           piv_init(&ps->named_optional);
831 613           p_init(&ps->slurpy);
832 613           ps->rest_hash = NOT_IN_PAD;
833 613           }
834              
835 699 100         DEFVECTOR_EXTEND(pv_extend, Param);
    50          
836 135 50         DEFVECTOR_EXTEND(piv_extend, ParamInit);
    0          
837              
838 699           static void pv_push(VEC(Param) *ps, SV *name, PADOFFSET padoff, SV *type) {
839 699           Param *p = pv_extend(ps);
840 699           p->name = name;
841 699           p->padoff = padoff;
842 699           p->type = type;
843 699           ps->used++;
844 699           }
845              
846 155           static Param *pv_unshift(VEC(Param) *ps, size_t n) {
847             size_t i;
848             assert(ps->used <= ps->size);
849 155 50         if (ps->used + n > ps->size) {
850 0           const size_t n2 = ps->used + n + 10;
851 0 0         Renew(ps->data, n2, Param);
852 0           ps->size = n2;
853             }
854 155 50         Move(ps->data, ps->data + n, ps->used, Param);
855 316 100         for (i = 0; i < n; i++) {
856 161           p_init(&ps->data[i]);
857             }
858 155           ps->used += n;
859 155           return ps->data;
860             }
861              
862 1608           static void p_clear(Param *p) {
863 1608           p->name = NULL;
864 1608           p->padoff = NOT_IN_PAD;
865 1608           p->type = NULL;
866 1608           }
867              
868 135           static void pi_clear(pTHX_ ParamInit *pi) {
869 135           p_clear(&pi->param);
870 135           op_guard_clear(aTHX_ &pi->init);
871 135           }
872              
873 2086 100         DEFVECTOR_CLEAR(pv_clear, Param, p_clear);
874 1361 100         DEFVECTOR_CLEAR_THX(piv_clear, ParamInit, pi_clear);
875              
876 613           static void ps_clear(pTHX_ ParamSpec *ps) {
877 613           pv_clear(&ps->positional_required);
878 613           piv_clear(aTHX_ &ps->positional_optional);
879              
880 613           pv_clear(&ps->named_required);
881 613           piv_clear(aTHX_ &ps->named_optional);
882              
883 613           p_clear(&ps->slurpy);
884 613           }
885              
886 981           static int ps_contains(pTHX_ const ParamSpec *ps, SV *sv) {
887             size_t i, lim;
888              
889 46604 100         for (i = 0, lim = ps->positional_required.used; i < lim; i++) {
890 45625 100         if (sv_eq(sv, ps->positional_required.data[i].name)) {
891 2           return 1;
892             }
893             }
894              
895 1049 100         for (i = 0, lim = ps->positional_optional.used; i < lim; i++) {
896 70 50         if (sv_eq(sv, ps->positional_optional.data[i].param.name)) {
897 0           return 1;
898             }
899             }
900              
901 1082 100         for (i = 0, lim = ps->named_required.used; i < lim; i++) {
902 104 100         if (sv_eq(sv, ps->named_required.data[i].name)) {
903 1           return 1;
904             }
905             }
906              
907 996 100         for (i = 0, lim = ps->named_optional.used; i < lim; i++) {
908 18 50         if (sv_eq(sv, ps->named_optional.data[i].param.name)) {
909 0           return 1;
910             }
911             }
912              
913 978           return 0;
914             }
915              
916 613           static void ps_free_void(pTHX_ void *p) {
917 613           ps_clear(aTHX_ p);
918 613           Safefree(p);
919 613           }
920              
921 535           static int args_min(const ParamSpec *ps) {
922 535           return ps->positional_required.used + ps->named_required.used * 2;
923             }
924              
925 535           static int args_max(const ParamSpec *ps) {
926 535 100         if (ps->named_required.used || ps->named_optional.used || ps->slurpy.name) {
    100          
    100          
927 61           return -1;
928             }
929 474           return ps->positional_required.used + ps->positional_optional.used;
930             }
931              
932 30           static size_t count_positional_params(const ParamSpec *ps) {
933 30           return ps->positional_required.used + ps->positional_optional.used;
934             }
935              
936 2418           static size_t count_named_params(const ParamSpec *ps) {
937 2418           return ps->named_required.used + ps->named_optional.used;
938             }
939              
940 12           static SV *my_eval(pTHX_ Sentinel sen, I32 floor_ix, OP *op) {
941             CV *cv;
942 12           cv = newATTRSUB(floor_ix, NULL, NULL, NULL, op);
943 12           return call_from_curstash(aTHX_ sen, (SV *)cv, NULL, 0, 0);
944             }
945              
946 1424           static OP *my_var_g(pTHX_ I32 type, I32 flags, PADOFFSET padoff) {
947 1424           OP *var = newOP(type, flags);
948 1424           var->op_targ = padoff;
949 1424           return var;
950             }
951              
952 1163           static OP *my_var(pTHX_ I32 flags, PADOFFSET padoff) {
953 1163           return my_var_g(aTHX_ OP_PADSV, flags, padoff);
954             }
955              
956 151           static OP *mkhvelem(pTHX_ PADOFFSET h, OP *k) {
957 151           OP *hv = my_var_g(aTHX_ OP_PADHV, OPf_REF, h);
958 151           return newBINOP(OP_HELEM, 0, hv, k);
959             }
960              
961 4475           static OP *mkconstsv(pTHX_ SV *sv) {
962 4475           return newSVOP(OP_CONST, 0, sv);
963             }
964              
965 982           static OP *mkconstiv(pTHX_ IV i) {
966 982           return mkconstsv(aTHX_ newSViv(i));
967             }
968              
969 1083           static OP *mkconstpv(pTHX_ const char *p, size_t n) {
970 1083           return mkconstsv(aTHX_ newSVpv(p, n));
971             }
972              
973             #define mkconstpvs(S) mkconstpv(aTHX_ "" S "", sizeof S - 1)
974              
975 968           static OP *mkcroak(pTHX_ OP *msg) {
976             OP *xcroak;
977 968           xcroak = newCVREF(
978             OPf_WANT_SCALAR,
979             mkconstsv(aTHX_ newSVpvs(MY_PKG "::_croak"))
980             );
981 968           xcroak = newUNOP(OP_ENTERSUB, OPf_STACKED, op_append_elem(OP_LIST, msg, xcroak));
982 968           return xcroak;
983             }
984              
985 51           static OP *mktypecheckv(pTHX_ Sentinel sen, const SV *declarator, size_t nr, SV *name, PADOFFSET padoff, SV *type, int is_invocant) {
986             /* $type->can("has_coercion") && $type->has_coercion
987             * ? $type->check($value = $type->coerce($value)) or F:P::_croak "...: " . $type->get_message($value)
988             * : $type->check($value) or F:P::_croak "...: " . $type->get_message($value)
989             */
990             OP *chk, *err, *msg, *xcroak;
991 51           bool has_coercion = FALSE, can_be_inlined = FALSE;
992              
993             {
994             GV *can_has_coercion;
995 51 100         if ((can_has_coercion = gv_fetchmethod_autoload(SvSTASH(SvRV(type)), "has_coercion", TRUE))) {
996 6           SV *ret = call_from_curstash(aTHX_ sen, MUTABLE_SV(GvCV(can_has_coercion)), &type, 1, 0);
997 6 100         if (SvTRUE(ret)) {
998 3           has_coercion = TRUE;
999             }
1000             }
1001             }
1002              
1003             {
1004             GV *can_can_be_inlined;
1005 51 100         if ((can_can_be_inlined = gv_fetchmethod_autoload(SvSTASH(SvRV(type)), "can_be_inlined", TRUE))) {
1006 5           SV *ret = call_from_curstash(aTHX_ sen, MUTABLE_SV(GvCV(can_can_be_inlined)), &type, 1, 0);
1007 5 50         if (SvTRUE(ret)) {
1008 5           can_be_inlined = TRUE;
1009             }
1010             }
1011             }
1012              
1013 51 100         if (can_be_inlined) {
1014             GV *can_inline_check;
1015             SV *src;
1016              
1017 5           can_inline_check = gv_fetchmethod_autoload(SvSTASH(SvRV(type)), "inline_check", FALSE);
1018 5 50         if (!can_inline_check) {
1019 0           can_inline_check = gv_fetchmethod_autoload(SvSTASH(SvRV(type)), "_inline_check", TRUE);
1020 0 0         if (!can_inline_check) {
1021 0           goto cannot_inline;
1022             }
1023             }
1024              
1025             {
1026             SV *f_args[2];
1027 5           f_args[0] = type;
1028 5           f_args[1] = padoff == NOT_IN_PAD
1029 0           ? sentinel_mortalize(sen, newSVpvs("$_"))
1030 5 50         : name;
1031 5           src = call_from_curstash(aTHX_ sen, MUTABLE_SV(GvCV(can_inline_check)), f_args, 2, 0);
1032             }
1033              
1034 5           ENTER;
1035 5           SAVETMPS;
1036             {
1037 5 50         SV *virt_file = sentinel_mortalize(sen, Perl_newSVpvf(aTHX_ "(inline_check:%s:%lu)", CopFILE(PL_curcop), (unsigned long)CopLINE(PL_curcop)));
1038 5           SAVECOPLINE(PL_curcop);
1039 5           SAVECOPFILE_FREE(PL_curcop);
1040              
1041             {
1042             /* local variable because otherwise 5.30.0-DEBUGGING fails under -Werror=shadow */
1043 5           char *ptr = SvPV_nolen(virt_file);
1044 5           CopFILE_set(PL_curcop, ptr);
1045             }
1046 5           CopLINE_set(PL_curcop, 1);
1047              
1048 5           lex_start(src, NULL, 0);
1049 5           chk = parse_fullexpr(0);
1050 4 50         if (PL_parser->error_count) {
1051 0           op_free(chk);
1052 0           chk = NULL;
1053             }
1054             }
1055 4 50         FREETMPS;
1056 4           LEAVE;
1057              
1058 4 50         if (!chk) {
1059 0 0         SV *e = sentinel_mortalize(sen, Perl_newSVpvf(
1060             aTHX_ "In %"SVf": inlining type constraint %"SVf" for %s %lu (%"SVf") failed",
1061             SVfARG(declarator),
1062             SVfARG(type),
1063             is_invocant ? "invocant" : "parameter",
1064             (unsigned long)nr,
1065             SVfARG(name)
1066             ));
1067 0           SV *const errsv =
1068 0 0         PL_errors && SvCUR(PL_errors)
1069             ? PL_errors
1070 0 0         : ERRSV;
    0          
1071 0 0         if (SvTRUE(errsv)) {
1072             char *ptr;
1073             STRLEN len;
1074 0           e = mess_sv(e, TRUE);
1075 0           ptr = SvPV_force(e, len);
1076 0 0         if (len >= 2 && ptr[len - 1] == '\n' && ptr[len - 2] == '.') {
    0          
    0          
1077 0           ptr[len - 2] = ':';
1078 0           ptr[len - 1] = ' ';
1079             }
1080 0           sv_catsv(e, errsv);
1081             }
1082 0           croak_sv(e);
1083             }
1084              
1085 4 50         if (has_coercion) {
1086 0           OP *args2 = NULL, *coerce;
1087              
1088 0           args2 = op_append_elem(OP_LIST, args2, mkconstsv(aTHX_ SvREFCNT_inc_simple_NN(type)));
1089 0 0         args2 = op_append_elem(OP_LIST, args2, padoff == NOT_IN_PAD ? newDEFSVOP() : my_var(aTHX_ 0, padoff));
1090              
1091 0           coerce = op_convert_list(
1092             OP_ENTERSUB, OPf_STACKED,
1093             op_append_elem(OP_LIST, args2, newMETHOP(OP_METHOD, 0, mkconstpvs("coerce")))
1094             );
1095              
1096 0 0         coerce = newASSIGNOP(
1097             OPf_STACKED,
1098             padoff == NOT_IN_PAD ? newDEFSVOP() : my_var(aTHX_ 0, padoff),
1099             0,
1100             coerce
1101             );
1102              
1103 0           chk = op_append_elem(OP_LIST, coerce, chk);
1104             }
1105 46           } else cannot_inline: {
1106 46           OP *args = NULL, *arg;
1107              
1108 46           arg = padoff == NOT_IN_PAD
1109 1           ? newDEFSVOP()
1110 46 100         : my_var(aTHX_ 0, padoff);
1111              
1112 46 100         if (has_coercion) {
1113 3           OP *args2 = NULL, *coerce;
1114              
1115 3           args2 = op_append_elem(OP_LIST, args2, mkconstsv(aTHX_ SvREFCNT_inc_simple_NN(type)));
1116 3           args2 = op_append_elem(OP_LIST, args2, arg);
1117              
1118 3           coerce = op_convert_list(
1119             OP_ENTERSUB, OPf_STACKED,
1120             op_append_elem(OP_LIST, args2, newMETHOP(OP_METHOD, 0, mkconstpvs("coerce")))
1121             );
1122              
1123 3 50         arg = newASSIGNOP(
1124             OPf_STACKED,
1125             padoff == NOT_IN_PAD ? newDEFSVOP() : my_var(aTHX_ 0, padoff),
1126             0,
1127             coerce
1128             );
1129             }
1130              
1131 46           args = op_append_elem(OP_LIST, args, mkconstsv(aTHX_ SvREFCNT_inc_simple_NN(type)));
1132 46           args = op_append_elem(OP_LIST, args, arg);
1133              
1134 46           chk = op_convert_list(
1135             OP_ENTERSUB, OPf_STACKED,
1136             op_append_elem(OP_LIST, args, newMETHOP(OP_METHOD, 0, mkconstpvs("check")))
1137             );
1138             }
1139              
1140 100 100         err = mkconstsv(
1141             aTHX_
1142             is_invocant == -1
1143 3           ? Perl_newSVpvf(aTHX_ "In %"SVf": invocant (%"SVf"): ", SVfARG(declarator), SVfARG(name))
1144 47 100         : Perl_newSVpvf(aTHX_ "In %"SVf": %s %lu (%"SVf"): ", SVfARG(declarator), is_invocant ? "invocant" : "parameter", (unsigned long)nr, SVfARG(name))
1145             );
1146              
1147             {
1148 50           OP *args = NULL;
1149              
1150 50           args = op_append_elem(OP_LIST, args, mkconstsv(aTHX_ SvREFCNT_inc_simple_NN(type)));
1151 50 100         args = op_append_elem(
1152             OP_LIST, args,
1153             padoff == NOT_IN_PAD
1154             ? newDEFSVOP()
1155             : my_var(aTHX_ 0, padoff)
1156             );
1157              
1158 50           msg = op_convert_list(
1159             OP_ENTERSUB, OPf_STACKED,
1160             op_append_elem(OP_LIST, args, newMETHOP(OP_METHOD, 0, mkconstpvs("get_message")))
1161             );
1162             }
1163              
1164 50           msg = newBINOP(OP_CONCAT, 0, err, msg);
1165              
1166 50           xcroak = mkcroak(aTHX_ msg);
1167              
1168 50           chk = newLOGOP(OP_OR, 0, chk, xcroak);
1169 50           return chk;
1170             }
1171              
1172 1           static OP *mktypecheck(pTHX_ Sentinel sen, const SV *declarator, size_t nr, SV *name, PADOFFSET padoff, SV *type) {
1173 1           return mktypecheckv(aTHX_ sen, declarator, nr, name, padoff, type, 0);
1174             }
1175              
1176 0           static OP *mktypecheckp(pTHX_ Sentinel sen, const SV *declarator, size_t nr, const Param *param) {
1177 0           return mktypecheck(aTHX_ sen, declarator, nr, param->name, param->padoff, param->type);
1178             }
1179              
1180 50           static OP *mktypecheckpv(pTHX_ Sentinel sen, const SV *declarator, size_t nr, const Param *param, int is_invocant) {
1181 50           return mktypecheckv(aTHX_ sen, declarator, nr, param->name, param->padoff, param->type, is_invocant);
1182             }
1183              
1184 238           static OP *mkanonsub(pTHX_ CV *cv) {
1185             #if HAVE_PERL_VERSION(5, 37, 5)
1186 238           return newSVOP(OP_ANONCODE, OPf_REF, (SV *)cv);
1187             #else
1188             return newUNOP(
1189             OP_REFGEN, 0,
1190             newSVOP(OP_ANONCODE, 0, (SV *)cv)
1191             );
1192             #endif
1193             }
1194              
1195             enum {
1196             PARAM_INVOCANT = 0x01,
1197             PARAM_NAMED = 0x02,
1198             PARAM_DEFINED_OR = 0x04
1199             };
1200              
1201 902           static PADOFFSET parse_param(
1202             pTHX_
1203             Sentinel sen,
1204             const SV *declarator, const KWSpec *spec, ParamSpec *param_spec,
1205             int *pflags, SV **pname, OpGuard *ginit, SV **ptype
1206             ) {
1207             I32 c;
1208             char sigil;
1209             SV *name;
1210             bool is_defined_or;
1211              
1212             assert(!ginit->op);
1213 902           *pflags = 0;
1214 902           *ptype = NULL;
1215              
1216 902           c = lex_peek_unichar(0);
1217              
1218 902 50         if (spec->flags & FLAG_TYPES_OK) {
1219 902 100         if (c == '(') {
1220             I32 floor_ix;
1221             OP *expr;
1222             Resource *expr_sentinel;
1223              
1224 12           lex_read_unichar(0);
1225              
1226 12           floor_ix = start_subparse(FALSE, 0);
1227 12           SAVEFREESV(PL_compcv);
1228 12           CvSPECIAL_on(PL_compcv);
1229              
1230 12 50         if (!(expr = parse_fullexpr(PARSE_OPTIONAL))) {
1231 0           Perl_croak(aTHX_ "In %"SVf": invalid type expression", SVfARG(declarator));
1232             }
1233 12 50         if (MY_OP_SLABBED(expr)) {
1234 12           expr_sentinel = NULL;
1235             } else {
1236 0           expr_sentinel = sentinel_register(sen, expr, free_op_void);
1237             }
1238              
1239 12           lex_read_space(0);
1240 12           c = lex_peek_unichar(0);
1241 12 50         if (c != ')') {
1242 0           Perl_croak(aTHX_ "In %"SVf": missing ')' after type expression", SVfARG(declarator));
1243             }
1244 12           lex_read_unichar(0);
1245 12           lex_read_space(0);
1246              
1247 12 50         SvREFCNT_inc_simple_void(PL_compcv);
1248 12 50         if (expr_sentinel) {
1249 0           sentinel_disarm(expr_sentinel);
1250             }
1251 12           *ptype = my_eval(aTHX_ sen, floor_ix, expr);
1252 12 100         if (!SvROK(*ptype)) {
1253 5           *ptype = reify_type(aTHX_ sen, declarator, spec, *ptype);
1254 7 50         } else if (!sv_isobject(*ptype)) {
1255 0           Perl_croak(aTHX_ "In %"SVf": invalid type (%"SVf" is not a type object)", SVfARG(declarator), SVfARG(*ptype));
1256             }
1257              
1258 11           c = lex_peek_unichar(0);
1259 890 50         } else if (MY_UNI_IDFIRST(c) || c == '~') {
    50          
    100          
    100          
    0          
    50          
1260 41           *ptype = parse_type(aTHX_ sen, declarator, ',');
1261 40           *ptype = reify_type(aTHX_ sen, declarator, spec, *ptype);
1262              
1263 38           c = lex_peek_unichar(0);
1264             }
1265             }
1266              
1267 898 100         if (c == ':') {
1268 85           lex_read_unichar(0);
1269 85           lex_read_space(0);
1270              
1271 85           *pflags |= PARAM_NAMED;
1272              
1273 85           c = lex_peek_unichar(0);
1274             }
1275              
1276 898 50         if (c == -1) {
1277 0           Perl_croak(aTHX_ "In %"SVf": unterminated parameter list", SVfARG(declarator));
1278             }
1279              
1280 898 100         if (!(c == '$' || c == '@' || c == '%')) {
    100          
    50          
1281 0           Perl_croak(aTHX_ "In %"SVf": unexpected '%c' in parameter list (expecting a sigil)", SVfARG(declarator), (int)c);
1282             }
1283              
1284 898           sigil = c;
1285              
1286 898           lex_read_unichar(0);
1287              
1288 898           c = lex_peek_unichar(0);
1289 898 50         if (c == '#') {
1290 0           Perl_croak(aTHX_ "In %"SVf": unexpected '%c#' in parameter list (expecting an identifier)", SVfARG(declarator), sigil);
1291             }
1292              
1293 898           lex_read_space(0);
1294              
1295 898 100         if (!(name = my_scan_word(aTHX_ sen, FALSE))) {
1296 17           name = sentinel_mortalize(sen, newSVpvs(""));
1297 881 50         } else if (sv_eq_pvs(name, "_")) {
1298 0           Perl_croak(aTHX_ "In %"SVf": Can't use global %c_ as a parameter", SVfARG(declarator), sigil);
1299             }
1300 898           sv_insert(name, 0, 0, &sigil, 1);
1301 898           *pname = name;
1302              
1303 898           lex_read_space(0);
1304 898           c = lex_peek_unichar(0);
1305              
1306 898           is_defined_or = FALSE;
1307 898 100         if (c == '/') {
1308 17           lex_read_unichar(0);
1309 17           c = lex_peek_unichar(0);
1310 17 50         if (c != '/') {
1311 0 0         Perl_croak(aTHX_ "In %"SVf": unexpected '%s' after '%"SVf"' (expecting '//=' or '=')", SVfARG(declarator), c == '=' ? "/=" : "/", SVfARG(name));
1312             }
1313 17           lex_read_unichar(0);
1314 17           c = lex_peek_unichar(0);
1315              
1316 17 50         if (c != '=') {
1317 0           Perl_croak(aTHX_ "In %"SVf": unexpected '%c' after '%"SVf" //' (expecting '=')", SVfARG(declarator), (int)c, SVfARG(name));
1318             }
1319 17           *pflags |= PARAM_DEFINED_OR;
1320 17           is_defined_or = TRUE;
1321             /* fall through */
1322             }
1323              
1324 898 100         if (c == '=') {
1325 141           lex_read_unichar(0);
1326 141           lex_read_space(0);
1327              
1328 141           c = lex_peek_unichar(0);
1329 141 100         if (c == ',' || c == ')') {
    100          
1330 6 50         if (is_defined_or) {
1331 0           Perl_croak(aTHX_ "In %"SVf": unexpected '%c' after '//=' (expecting expression)", SVfARG(declarator), (int)c);
1332             }
1333 6           op_guard_update(ginit, newOP(OP_UNDEF, 0));
1334             } else {
1335 135 100         if (param_spec->shift == 0 && spec->shift.used) {
    100          
1336 11           size_t i, lim = spec->shift.used;
1337 11           Param *p = pv_unshift(&param_spec->positional_required, lim);
1338 23 100         for (i = 0; i < lim; i++) {
1339 12           p[i].name = spec->shift.data[i].name;
1340 12           p[i].padoff = pad_add_name_sv(p[i].name, 0, NULL, NULL);
1341 12           p[i].type = spec->shift.data[i].type;
1342             }
1343 11           param_spec->shift = lim;
1344 11           intro_my();
1345             }
1346              
1347 135           op_guard_update(ginit, parse_termexpr(0));
1348              
1349 135           lex_read_space(0);
1350 135           c = lex_peek_unichar(0);
1351             }
1352             }
1353              
1354 898 100         if (c == ':') {
1355 36           *pflags |= PARAM_INVOCANT;
1356 36           lex_read_unichar(0);
1357 36           lex_read_space(0);
1358 862 100         } else if (c == ',') {
1359 557           lex_read_unichar(0);
1360 557           lex_read_space(0);
1361 305 50         } else if (c != ')') {
1362 0 0         if (c == -1) {
1363 0           Perl_croak(aTHX_ "In %"SVf": unterminated parameter list", SVfARG(declarator));
1364             }
1365 0           Perl_croak(aTHX_ "In %"SVf": unexpected '%c' in parameter list (expecting ',')", SVfARG(declarator), (int)c);
1366             }
1367              
1368 898           return SvCUR(*pname) < 2
1369             ? NOT_IN_PAD
1370 898 100         : pad_add_name_sv(*pname, padadd_NO_DUP_CHECK, NULL, NULL)
1371             ;
1372             }
1373              
1374 556           static void register_info(pTHX_ UV key, SV *declarator, const ParamSpec *ps) {
1375 556           dSP;
1376              
1377 556           ENTER;
1378 556           SAVETMPS;
1379              
1380 556 50         PUSHMARK(SP);
1381 556 50         EXTEND(SP, 9);
1382              
1383             /* 0 */ {
1384 556           mPUSHu(key);
1385             }
1386             /* 1 */ {
1387             STRLEN n;
1388 556           char *p = SvPV(declarator, n);
1389 556           char *q = memchr(p, ' ', n);
1390 556 50         SV *tmp = newSVpvn_utf8(p, q ? (size_t)(q - p) : n, SvUTF8(declarator));
1391 556           mPUSHs(tmp);
1392             }
1393             /* 2 */ {
1394 556           mPUSHu(ps->shift);
1395             }
1396             /* 3 */ {
1397             size_t i, lim;
1398             AV *av;
1399              
1400 556           lim = ps->positional_required.used;
1401              
1402 556           av = newAV();
1403 556 100         if (lim) {
1404 340           av_extend(av, (lim - 1) * 2);
1405 1122 100         for (i = 0; i < lim; i++) {
1406 782           Param *cur = &ps->positional_required.data[i];
1407 782           av_push(av, SvREFCNT_inc_simple_NN(cur->name));
1408 782 100         av_push(av, cur->type ? SvREFCNT_inc_simple_NN(cur->type) : &PL_sv_undef);
1409             }
1410             }
1411              
1412 556           mPUSHs(newRV_noinc((SV *)av));
1413             }
1414             /* 4 */ {
1415             size_t i, lim;
1416             AV *av;
1417              
1418 556           lim = ps->positional_optional.used;
1419              
1420 556           av = newAV();
1421 556 100         if (lim) {
1422 72           av_extend(av, (lim - 1) * 2);
1423 183 100         for (i = 0; i < lim; i++) {
1424 111           Param *cur = &ps->positional_optional.data[i].param;
1425 111           av_push(av, SvREFCNT_inc_simple_NN(cur->name));
1426 111 50         av_push(av, cur->type ? SvREFCNT_inc_simple_NN(cur->type) : &PL_sv_undef);
1427             }
1428             }
1429              
1430 556           mPUSHs(newRV_noinc((SV *)av));
1431             }
1432             /* 5 */ {
1433             size_t i, lim;
1434             AV *av;
1435              
1436 556           lim = ps->named_required.used;
1437              
1438 556           av = newAV();
1439 556 100         if (lim) {
1440 22           av_extend(av, (lim - 1) * 2);
1441 78 100         for (i = 0; i < lim; i++) {
1442 56           Param *cur = &ps->named_required.data[i];
1443 56           av_push(av, SvREFCNT_inc_simple_NN(cur->name));
1444 56 50         av_push(av, cur->type ? SvREFCNT_inc_simple_NN(cur->type) : &PL_sv_undef);
1445             }
1446             }
1447              
1448 556           mPUSHs(newRV_noinc((SV *)av));
1449             }
1450             /* 6 */ {
1451             size_t i, lim;
1452             AV *av;
1453              
1454 556           lim = ps->named_optional.used;
1455              
1456 556           av = newAV();
1457 556 100         if (lim) {
1458 12           av_extend(av, (lim - 1) * 2);
1459 35 100         for (i = 0; i < lim; i++) {
1460 23           Param *cur = &ps->named_optional.data[i].param;
1461 23           av_push(av, SvREFCNT_inc_simple_NN(cur->name));
1462 23 50         av_push(av, cur->type ? SvREFCNT_inc_simple_NN(cur->type) : &PL_sv_undef);
1463             }
1464             }
1465              
1466 556           mPUSHs(newRV_noinc((SV *)av));
1467             }
1468             /* 7, 8 */ {
1469 556 100         if (ps->slurpy.name) {
1470 36           PUSHs(ps->slurpy.name);
1471 36 100         if (ps->slurpy.type) {
1472 1           PUSHs(ps->slurpy.type);
1473             } else {
1474 35           PUSHmortal;
1475             }
1476             } else {
1477 520           PUSHmortal;
1478 520           PUSHmortal;
1479             }
1480             }
1481 556           PUTBACK;
1482              
1483 556           call_pv(MY_PKG "::_register_info", G_VOID);
1484              
1485 556 50         FREETMPS;
1486 556           LEAVE;
1487 556           }
1488              
1489 628           static int parse_fun(pTHX_ Sentinel sen, OP **pop, const char *keyword_ptr, STRLEN keyword_len, const KWSpec *spec) {
1490             ParamSpec *param_spec;
1491             SV *declarator;
1492             I32 floor_ix;
1493             int save_ix;
1494             SV *saw_name;
1495             OpGuard *prelude_sentinel;
1496             SV *proto;
1497             OpGuard *attrs_sentinel;
1498             OP *body;
1499             unsigned builtin_attrs;
1500             I32 c;
1501              
1502 628           declarator = sentinel_mortalize(sen, newSVpvn(keyword_ptr, keyword_len));
1503 628 100         if (lex_bufutf8()) {
1504 22           SvUTF8_on(declarator);
1505             }
1506              
1507 628           lex_read_space(0);
1508              
1509 628           builtin_attrs = 0;
1510              
1511             /* function name */
1512 628           saw_name = NULL;
1513 628 100         if ((spec->flags & FLAG_NAME_OK) && (saw_name = my_scan_word(aTHX_ sen, TRUE))) {
    100          
1514              
1515 356 100         if (PL_parser->expect != XSTATE) {
1516             /* bail out early so we don't predeclare $saw_name */
1517 2           Perl_croak(aTHX_ "In %"SVf": I was expecting a parameter list, not \"%"SVf"\"", SVfARG(declarator), SVfARG(saw_name));
1518             }
1519              
1520 354           sv_catpvs(declarator, " ");
1521 354           sv_catsv(declarator, saw_name);
1522              
1523 354 50         if (
1524 708 50         sv_eq_pvs(saw_name, "BEGIN") ||
1525 708 50         sv_eq_pvs(saw_name, "END") ||
1526 708 50         sv_eq_pvs(saw_name, "INIT") ||
1527 708 50         sv_eq_pvs(saw_name, "CHECK") ||
1528 354           sv_eq_pvs(saw_name, "UNITCHECK")
1529             ) {
1530 0           builtin_attrs |= MY_ATTR_SPECIAL;
1531             }
1532              
1533 354           lex_read_space(0);
1534 272 100         } else if (!(spec->flags & FLAG_ANON_OK)) {
1535 3           Perl_croak(aTHX_ "I was expecting a function name, not \"%.*s\"", (int)(PL_parser->bufend - PL_parser->bufptr), PL_parser->bufptr);
1536             } else {
1537 269           sv_catpvs(declarator, " (anon)");
1538             }
1539              
1540             /* we're a subroutine declaration */
1541 623 100         floor_ix = start_subparse(FALSE, saw_name ? 0 : CVf_ANON);
1542 623           SAVEFREESV(PL_compcv);
1543              
1544             /* create outer block: '{' */
1545 623           save_ix = block_start(TRUE);
1546              
1547             /* initialize synthetic optree */
1548 623           Newx(prelude_sentinel, 1, OpGuard);
1549 623           op_guard_init(prelude_sentinel);
1550 623           sentinel_register(sen, prelude_sentinel, free_op_guard_void);
1551              
1552             /* parameters */
1553 623           c = lex_peek_unichar(0);
1554 623 100         if (c != '(') {
1555 10           Perl_croak(aTHX_ "In %"SVf": I was expecting a parameter list, not \"%c\"", SVfARG(declarator), (int)c);
1556             }
1557              
1558 613           lex_read_unichar(0);
1559 613           lex_read_space(0);
1560              
1561 613           Newx(param_spec, 1, ParamSpec);
1562 613           ps_init(param_spec);
1563 613           sentinel_register(sen, param_spec, ps_free_void);
1564              
1565             {
1566             OpGuard *init_sentinel;
1567              
1568 613           Newx(init_sentinel, 1, OpGuard);
1569 613           op_guard_init(init_sentinel);
1570 613           sentinel_register(sen, init_sentinel, free_op_guard_void);
1571              
1572 1489 100         while ((c = lex_peek_unichar(0)) != ')') {
1573             int flags;
1574             SV *name, *type;
1575             char sigil;
1576             PADOFFSET padoff;
1577              
1578 902           padoff = parse_param(aTHX_ sen, declarator, spec, param_spec, &flags, &name, init_sentinel, &type);
1579              
1580 898 100         if (padoff != NOT_IN_PAD) {
1581 881           intro_my();
1582             }
1583              
1584 898           sigil = SvPV_nolen(name)[0];
1585              
1586             /* internal consistency */
1587 898 100         if (flags & PARAM_NAMED) {
1588 85 50         if (padoff == NOT_IN_PAD) {
1589 0           Perl_croak(aTHX_ "In %"SVf": named parameter %"SVf" can't be unnamed", SVfARG(declarator), SVfARG(name));
1590             }
1591 85 100         if (flags & PARAM_INVOCANT) {
1592 1           Perl_croak(aTHX_ "In %"SVf": invocant %"SVf" can't be a named parameter", SVfARG(declarator), SVfARG(name));
1593             }
1594 84 50         if (sigil != '$') {
1595 0 0         Perl_croak(aTHX_ "In %"SVf": named parameter %"SVf" can't be a%s", SVfARG(declarator), SVfARG(name), sigil == '@' ? "n array" : " hash");
1596             }
1597 813 100         } else if (flags & PARAM_INVOCANT) {
1598 35 50         if (init_sentinel->op) {
1599 0           Perl_croak(aTHX_ "In %"SVf": invocant %"SVf" can't have a default value", SVfARG(declarator), SVfARG(name));
1600             }
1601 35 100         if (sigil != '$') {
1602 2 100         Perl_croak(aTHX_ "In %"SVf": invocant %"SVf" can't be a%s", SVfARG(declarator), SVfARG(name), sigil == '@' ? "n array" : " hash");
1603             }
1604 778 100         } else if (sigil != '$' && init_sentinel->op) {
    100          
1605 4 100         Perl_croak(aTHX_ "In %"SVf": %s %"SVf" can't have a default value", SVfARG(declarator), sigil == '@' ? "array" : "hash", SVfARG(name));
1606             }
1607 891 100         if (type && padoff == NOT_IN_PAD) {
    50          
1608 0           Perl_croak(aTHX_ "In %"SVf": unnamed parameter %"SVf" can't have a type", SVfARG(declarator), SVfARG(name));
1609             }
1610              
1611             /* external constraints */
1612 891 100         if (param_spec->slurpy.name) {
1613 5           Perl_croak(aTHX_ "In %"SVf": \"%"SVf"\" can't appear after slurpy parameter \"%"SVf"\"", SVfARG(declarator), SVfARG(name), SVfARG(param_spec->slurpy.name));
1614             }
1615 886 100         if (sigil != '$') {
1616             assert(!init_sentinel->op);
1617 42           param_spec->slurpy.name = name;
1618 42           param_spec->slurpy.padoff = padoff;
1619 42           param_spec->slurpy.type = type;
1620 42           continue;
1621             }
1622              
1623 844 100         if (!(flags & PARAM_NAMED) && count_named_params(param_spec)) {
    100          
1624 1 50         Perl_croak(aTHX_ "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));
1625             }
1626              
1627 843 100         if (flags & PARAM_INVOCANT) {
1628 33 50         if (param_spec->shift) {
1629             assert(param_spec->shift <= param_spec->positional_required.used);
1630 0           Perl_croak(aTHX_ "In %"SVf": invalid double invocants (... %"SVf": ... %"SVf":)", SVfARG(declarator), SVfARG(param_spec->positional_required.data[param_spec->shift - 1].name), SVfARG(name));
1631             }
1632 33 100         if (!(spec->flags & FLAG_INVOCANT)) {
1633 2           Perl_croak(aTHX_ "In %"SVf": invocant %"SVf" not allowed here", SVfARG(declarator), SVfARG(name));
1634             }
1635 31 100         if (spec->shift.used && spec->shift.used != param_spec->positional_required.used + 1) {
    100          
1636 3           Perl_croak(aTHX_ "In %"SVf": number of invocants in parameter list (%lu) differs from number of invocants in keyword definition (%lu)", SVfARG(declarator), (unsigned long)(param_spec->positional_required.used + 1), (unsigned long)spec->shift.used);
1637             }
1638             }
1639              
1640 838 100         if (!(flags & PARAM_NAMED) && !init_sentinel->op && param_spec->positional_optional.used) {
    100          
    50          
1641 0           Perl_croak(aTHX_ "In %"SVf": required parameter %"SVf" can't appear after optional parameter %"SVf"", SVfARG(declarator), SVfARG(name), SVfARG(param_spec->positional_optional.data[0].param.name));
1642             }
1643              
1644 838 100         if (init_sentinel->op && !(spec->flags & FLAG_DEFAULT_ARGS)) {
    100          
1645 2           Perl_croak(aTHX_ "In %"SVf": default argument for %"SVf" not allowed here", SVfARG(declarator), SVfARG(name));
1646             }
1647              
1648 836 100         if (padoff != NOT_IN_PAD && ps_contains(aTHX_ param_spec, name)) {
    100          
1649 1           Perl_croak(aTHX_ "In %"SVf": %"SVf" can't appear twice in the same parameter list", SVfARG(declarator), SVfARG(name));
1650             }
1651              
1652 835 100         if (flags & PARAM_NAMED) {
1653 82 50         if (!(spec->flags & FLAG_NAMED_PARAMS)) {
1654 0           Perl_croak(aTHX_ "In %"SVf": named parameter :%"SVf" not allowed here", SVfARG(declarator), SVfARG(name));
1655             }
1656              
1657 82 100         if (init_sentinel->op) {
1658 23           ParamInit *pi = piv_extend(&param_spec->named_optional);
1659 23           pi->param.name = name;
1660 23           pi->param.padoff = padoff;
1661 23           pi->param.type = type;
1662 23           pi->init = op_guard_transfer(init_sentinel);
1663 23           pi->cond = flags & PARAM_DEFINED_OR ? ICOND_DEFINED : ICOND_EXISTS;
1664 23           param_spec->named_optional.used++;
1665             } else {
1666 59 100         if (param_spec->positional_optional.used) {
1667 1           Perl_croak(aTHX_ "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));
1668             }
1669              
1670 58           pv_push(&param_spec->named_required, name, padoff, type);
1671             }
1672             } else {
1673 753 100         if (init_sentinel->op) {
1674 112           ParamInit *pi = piv_extend(&param_spec->positional_optional);
1675 112           pi->param.name = name;
1676 112           pi->param.padoff = padoff;
1677 112           pi->param.type = type;
1678 112           pi->init = op_guard_transfer(init_sentinel);
1679 112           pi->cond = flags & PARAM_DEFINED_OR ? ICOND_DEFINED : ICOND_EXISTS;
1680 112           param_spec->positional_optional.used++;
1681             } else {
1682             assert(param_spec->positional_optional.used == 0);
1683 641           pv_push(&param_spec->positional_required, name, padoff, type);
1684 641 100         if (flags & PARAM_INVOCANT) {
1685             assert(param_spec->shift == 0);
1686 28           param_spec->shift = param_spec->positional_required.used;
1687             }
1688             }
1689             }
1690              
1691             }
1692 587           lex_read_unichar(0);
1693 587           lex_read_space(0);
1694              
1695 587 100         if (param_spec->shift == 0 && spec->shift.used) {
    100          
1696 144           size_t i, lim = spec->shift.used;
1697             Param *p;
1698 144           p = pv_unshift(&param_spec->positional_required, lim);
1699 290 100         for (i = 0; i < lim; i++) {
1700 148           const SpecParam *const cur = &spec->shift.data[i];
1701 148 100         if (ps_contains(aTHX_ param_spec, cur->name)) {
1702 2           Perl_croak(aTHX_ "In %"SVf": %"SVf" can't appear twice in the same parameter list", SVfARG(declarator), SVfARG(cur->name));
1703             }
1704              
1705 146           p[i].name = cur->name;
1706 146           p[i].padoff = pad_add_name_sv(p[i].name, 0, NULL, NULL);
1707 146           p[i].type = cur->type;
1708             }
1709 142           param_spec->shift = lim;
1710             }
1711             }
1712              
1713             /* attributes */
1714 585           Newx(attrs_sentinel, 1, OpGuard);
1715 585           op_guard_init(attrs_sentinel);
1716 585           sentinel_register(sen, attrs_sentinel, free_op_guard_void);
1717 585           proto = NULL;
1718              
1719 585           c = lex_peek_unichar(0);
1720 585 100         if (c == ':' || c == '{') /* '}' - hi, vim */ {
    50          
1721              
1722             /* kludge default attributes in */
1723 585 100         if (SvTRUE(spec->attrs) && SvPV_nolen(spec->attrs)[0] == ':') {
    50          
1724 177           lex_stuff_sv(spec->attrs, 0);
1725 177           c = ':';
1726             }
1727              
1728 585 100         if (c == ':') {
1729 239           lex_read_unichar(0);
1730 239           lex_read_space(0);
1731 239           c = lex_peek_unichar(0);
1732              
1733 224           for (;;) {
1734             SV *attr;
1735              
1736 463 100         if (!(attr = my_scan_word(aTHX_ sen, FALSE))) {
1737 216           break;
1738             }
1739              
1740 247           lex_read_space(0);
1741 247           c = lex_peek_unichar(0);
1742              
1743 247 100         if (c != '(') {
1744 179 100         if (sv_eq_pvs(attr, "lvalue")) {
1745 3           builtin_attrs |= MY_ATTR_LVALUE;
1746 3           attr = NULL;
1747 176 50         } else if (sv_eq_pvs(attr, "method")) {
1748 176           builtin_attrs |= MY_ATTR_METHOD;
1749 176           attr = NULL;
1750             }
1751             } else {
1752             SV *sv;
1753 68           lex_read_unichar(0);
1754 68 50         if (!(sv = my_scan_parens_tail(aTHX_ sen, TRUE))) {
1755 0           Perl_croak(aTHX_ "In %"SVf": unterminated attribute parameter in attribute list", SVfARG(declarator));
1756             }
1757              
1758 68 50         if (sv_eq_pvs(attr, "prototype")) {
1759 68 100         if (proto) {
1760 1           Perl_croak(aTHX_ "In %"SVf": Can't redefine prototype (%"SVf") using attribute prototype(%"SVf")", SVfARG(declarator), SVfARG(proto), SVfARG(sv));
1761             }
1762 67           proto = sv;
1763 67           my_check_prototype(aTHX_ sen, declarator, proto);
1764 45           attr = NULL;
1765             } else {
1766 0           sv_catpvs(attr, "(");
1767 0           sv_catsv(attr, sv);
1768 0           sv_catpvs(attr, ")");
1769             }
1770              
1771 45           lex_read_space(0);
1772 45           c = lex_peek_unichar(0);
1773             }
1774              
1775 224 50         if (attr) {
1776 0           op_guard_update(attrs_sentinel, op_append_elem(OP_LIST, attrs_sentinel->op, mkconstsv(aTHX_ SvREFCNT_inc_simple_NN(attr))));
1777             }
1778              
1779 224 100         if (c == ':') {
1780 9           lex_read_unichar(0);
1781 9           lex_read_space(0);
1782 9           c = lex_peek_unichar(0);
1783             }
1784             }
1785             }
1786             }
1787              
1788             /* body */
1789 562 100         if (c != '{') /* '}' - hi, vim */ {
1790 1           Perl_croak(aTHX_ "In %"SVf": I was expecting a function body, not \"%c\"", SVfARG(declarator), (int)c);
1791             }
1792              
1793             /* turn off line debugging for generated code */
1794 561           sentinel_save_u32(sen, &PL_perldb);
1795 561           const U32 prev_db_line = PL_perldb & PERLDBf_LINE;
1796 561           PL_perldb &= ~PERLDBf_LINE;
1797              
1798             /* surprise predeclaration! */
1799 561 100         if (saw_name && !spec->install_sub && !(spec->flags & FLAG_RUNTIME)) {
    100          
    100          
1800             /* 'sub NAME (PROTO);' to make name/proto known to perl before it
1801             starts parsing the body */
1802 318           const I32 sub_ix = start_subparse(FALSE, 0);
1803 318           SAVEFREESV(PL_compcv);
1804              
1805 318 50         SvREFCNT_inc_simple_void(PL_compcv);
1806              
1807             #if HAVE_BUG_GH_15557
1808             {
1809             CV *const outside = CvOUTSIDE(PL_compcv);
1810             if (outside) {
1811             CvOUTSIDE(PL_compcv) = NULL;
1812             if (!CvWEAKOUTSIDE(PL_compcv)) {
1813             SvREFCNT_dec_NN(outside);
1814             }
1815             }
1816             }
1817             #endif
1818 318 100         newATTRSUB(
1819             sub_ix,
1820             mkconstsv(aTHX_ SvREFCNT_inc_simple_NN(saw_name)),
1821             proto ? mkconstsv(aTHX_ SvREFCNT_inc_simple_NN(proto)) : NULL,
1822             NULL,
1823             NULL
1824             );
1825             }
1826              
1827 561 100         if (builtin_attrs & MY_ATTR_LVALUE) {
1828 3           CvLVALUE_on(PL_compcv);
1829             }
1830 561 100         if (builtin_attrs & MY_ATTR_METHOD) {
1831 176           CvMETHOD_on(PL_compcv);
1832             }
1833 561 50         if (builtin_attrs & MY_ATTR_SPECIAL) {
1834 0           CvSPECIAL_on(PL_compcv);
1835             }
1836              
1837             /* check number of arguments */
1838 561 100         if (spec->flags & FLAG_CHECK_NARGS) {
1839             int amin, amax;
1840              
1841 535           amin = args_min(param_spec);
1842 535 100         if (amin > 0) {
1843             OP *chk, *cond, *err;
1844              
1845 335           err = mkconstsv(aTHX_ Perl_newSVpvf(aTHX_ "Too few arguments for %"SVf" (expected %d, got ", SVfARG(declarator), amin));
1846 335           err = newBINOP(
1847             OP_CONCAT, 0,
1848             err,
1849             newAVREF(newGVOP(OP_GV, 0, PL_defgv))
1850             );
1851 335           err = newBINOP(
1852             OP_CONCAT, 0,
1853             err,
1854             mkconstpvs(")")
1855             );
1856              
1857 335           err = mkcroak(aTHX_ err);
1858              
1859 335           cond = newBINOP(OP_LT, 0,
1860             newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
1861             mkconstiv(aTHX_ amin));
1862 335           chk = newLOGOP(OP_AND, 0, cond, err);
1863              
1864 335           op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, chk)));
1865             }
1866              
1867 535           amax = args_max(param_spec);
1868 535 100         if (amax >= 0) {
1869             OP *chk, *cond, *err;
1870              
1871 474           err = mkconstsv(aTHX_ Perl_newSVpvf(aTHX_ "Too many arguments for %"SVf" (expected %d, got ", SVfARG(declarator), amax));
1872 474           err = newBINOP(
1873             OP_CONCAT, 0,
1874             err,
1875             newAVREF(newGVOP(OP_GV, 0, PL_defgv))
1876             );
1877 474           err = newBINOP(
1878             OP_CONCAT, 0,
1879             err,
1880             mkconstpvs(")")
1881             );
1882              
1883 474           err = mkcroak(aTHX_ err);
1884              
1885 474           cond = newBINOP(
1886             OP_GT, 0,
1887             newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
1888             mkconstiv(aTHX_ amax)
1889             );
1890 474           chk = newLOGOP(OP_AND, 0, cond, err);
1891              
1892 474           op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, chk)));
1893             }
1894              
1895 535 100         if (count_named_params(param_spec) || (param_spec->slurpy.name && SvPV_nolen(param_spec->slurpy.name)[0] == '%')) {
    100          
    50          
1896             OP *chk, *cond, *err;
1897 30           const UV fixed = count_positional_params(param_spec);
1898              
1899 30           err = mkconstsv(aTHX_ Perl_newSVpvf(aTHX_ "Odd number of paired arguments for %"SVf"", SVfARG(declarator)));
1900              
1901 30           err = mkcroak(aTHX_ err);
1902              
1903 30           cond = newBINOP(OP_GT, 0,
1904             newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
1905             mkconstiv(aTHX_ fixed));
1906 30 100         cond = newLOGOP(OP_AND, 0,
1907             cond,
1908             newBINOP(OP_MODULO, 0,
1909             fixed
1910             ? newBINOP(OP_SUBTRACT, 0,
1911             newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
1912             mkconstiv(aTHX_ fixed))
1913             : newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
1914             mkconstiv(aTHX_ 2)));
1915 30           chk = newLOGOP(OP_AND, 0, cond, err);
1916              
1917 30           op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, chk)));
1918             }
1919             }
1920              
1921             assert(param_spec->shift <= param_spec->positional_required.used);
1922 561 100         if (param_spec->shift) {
1923 181           bool all_anon = TRUE;
1924             {
1925             size_t i;
1926 181 50         for (i = 0; i < param_spec->shift; i++) {
1927 181 50         if (param_spec->positional_required.data[i].padoff != NOT_IN_PAD) {
1928 181           all_anon = FALSE;
1929 181           break;
1930             }
1931             }
1932             }
1933 181 100         if (param_spec->shift == 1) {
1934 174 50         if (all_anon) {
1935             /* shift; */
1936 0           op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, newOP(OP_SHIFT, 0))));
1937             } else {
1938             /* my $invocant = shift; */
1939             OP *var;
1940              
1941 174           var = my_var(
1942             aTHX_
1943             OPf_MOD | (OPpLVAL_INTRO << 8),
1944 174           param_spec->positional_required.data[0].padoff
1945             );
1946 174           var = newASSIGNOP(OPf_STACKED, var, 0, newOP(OP_SHIFT, 0));
1947              
1948 174           op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, var)));
1949             }
1950             } else {
1951 7           OP *const rhs = op_convert_list(OP_SPLICE, 0,
1952             op_append_elem(
1953             OP_LIST,
1954             op_append_elem(
1955             OP_LIST,
1956             newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
1957             mkconstiv(aTHX_ 0)
1958             ),
1959             mkconstiv(aTHX_ param_spec->shift)));
1960 7 50         if (all_anon) {
1961             /* splice @_, 0, $n; */
1962 0           op_guard_update(
1963             prelude_sentinel,
1964             op_append_list(
1965             OP_LINESEQ,
1966             prelude_sentinel->op,
1967             newSTATEOP(0, NULL, rhs)));
1968             } else {
1969             /* my (...) = splice @_, 0, $n; */
1970             OP *lhs;
1971             size_t i, lim;
1972              
1973 7           lhs = NULL;
1974              
1975 21 100         for (i = 0, lim = param_spec->shift; i < lim; i++) {
1976 14           const PADOFFSET padoff = param_spec->positional_required.data[i].padoff;
1977 14 50         lhs = op_append_elem(
1978             OP_LIST,
1979             lhs,
1980             padoff == NOT_IN_PAD
1981             ? newOP(OP_UNDEF, 0)
1982             : my_var(
1983             aTHX_
1984             OPf_WANT_LIST | (OPpLVAL_INTRO << 8),
1985             padoff
1986             )
1987             );
1988             }
1989              
1990 7           lhs->op_flags |= OPf_PARENS;
1991              
1992 7           op_guard_update(prelude_sentinel, op_append_list(
1993             OP_LINESEQ, prelude_sentinel->op,
1994             newSTATEOP(
1995             0, NULL,
1996             newASSIGNOP(OPf_STACKED, lhs, 0, rhs)
1997             )
1998             ));
1999             }
2000             }
2001             }
2002              
2003             /* my (...) = @_; */
2004             {
2005             OP *lhs;
2006             size_t i, lim;
2007              
2008 561           lhs = NULL;
2009              
2010 1161 100         for (i = param_spec->shift, lim = param_spec->positional_required.used; i < lim; i++) {
2011 600           const PADOFFSET padoff = param_spec->positional_required.data[i].padoff;
2012 600 100         lhs = op_append_elem(
2013             OP_LIST,
2014             lhs,
2015             padoff == NOT_IN_PAD
2016             ? newOP(OP_UNDEF, 0)
2017             : my_var(
2018             aTHX_
2019             OPf_WANT_LIST | (OPpLVAL_INTRO << 8),
2020             padoff
2021             )
2022             );
2023             }
2024              
2025 672 100         for (i = 0, lim = param_spec->positional_optional.used; i < lim; i++) {
2026 111           const PADOFFSET padoff = param_spec->positional_optional.data[i].param.padoff;
2027 111 100         lhs = op_append_elem(
2028             OP_LIST,
2029             lhs,
2030             padoff == NOT_IN_PAD
2031             ? newOP(OP_UNDEF, 0)
2032             : my_var(
2033             aTHX_
2034             OPf_WANT_LIST | (OPpLVAL_INTRO << 8),
2035             padoff
2036             )
2037             );
2038             }
2039              
2040             {
2041             PADOFFSET padoff;
2042             I32 type;
2043             bool slurpy_hash;
2044              
2045             /*
2046             * cases:
2047             * 1) no named params
2048             * 1.1) slurpy
2049             * => put it in
2050             * 1.2) no slurpy
2051             * => nop
2052             * 2) named params
2053             * 2.1) no slurpy
2054             * => synthetic %{__rest}
2055             * 2.2) slurpy is a hash
2056             * => put it in
2057             * 2.3) slurpy is an array
2058             * => synthetic %{__rest}
2059             * remember to declare array later
2060             */
2061              
2062 561 100         slurpy_hash = param_spec->slurpy.name && SvPV_nolen(param_spec->slurpy.name)[0] == '%';
    100          
2063 561 100         if (!count_named_params(param_spec)) {
2064 530 100         if (param_spec->slurpy.name && param_spec->slurpy.padoff != NOT_IN_PAD) {
    100          
2065 17           padoff = param_spec->slurpy.padoff;
2066 17 50         type = slurpy_hash ? OP_PADHV : OP_PADAV;
2067             } else {
2068 513           padoff = NOT_IN_PAD;
2069 513           type = OP_PADSV;
2070             }
2071 31 100         } else if (slurpy_hash && param_spec->slurpy.padoff != NOT_IN_PAD) {
    50          
2072 2           padoff = param_spec->slurpy.padoff;
2073 2           type = OP_PADHV;
2074             } else {
2075 29           padoff = pad_add_name_pvs("%{__rest}", 0, NULL, NULL);
2076 29           type = OP_PADHV;
2077             }
2078              
2079 561 100         if (padoff != NOT_IN_PAD) {
2080 48           OP *const var = my_var_g(
2081             aTHX_
2082             type,
2083             OPf_WANT_LIST | (OPpLVAL_INTRO << 8),
2084             padoff
2085             );
2086              
2087 48           lhs = op_append_elem(OP_LIST, lhs, var);
2088              
2089 48 100         if (type == OP_PADHV) {
2090 31           param_spec->rest_hash = padoff;
2091             }
2092             }
2093             }
2094              
2095 561 100         if (lhs) {
2096 288           OP *const rhs = newAVREF(newGVOP(OP_GV, 0, PL_defgv));
2097 288           lhs->op_flags |= OPf_PARENS;
2098              
2099 288           op_guard_update(prelude_sentinel, op_append_list(
2100             OP_LINESEQ, prelude_sentinel->op,
2101             newSTATEOP(
2102             0, NULL,
2103             newASSIGNOP(OPf_STACKED, lhs, 0, rhs)
2104             )
2105             ));
2106             }
2107             }
2108              
2109             /* default positional arguments */
2110             {
2111             size_t i, lim, req;
2112             OP *nest, *sequ;
2113              
2114 561           nest = NULL;
2115 561           sequ = NULL;
2116              
2117 561           req = param_spec->positional_required.used - param_spec->shift;
2118 672 100         for (i = 0, lim = param_spec->positional_optional.used; i < lim; i++) {
2119 111           ParamInit *cur = &param_spec->positional_optional.data[i];
2120             OP *cond, *init;
2121              
2122             {
2123 111           OP *const init_op = cur->init.op;
2124 111 100         if (init_op->op_type == OP_UNDEF && !(init_op->op_flags & OPf_KIDS)) {
    50          
2125 18           op_free(op_guard_relinquish(&cur->init));
2126 18           continue;
2127             }
2128             }
2129              
2130 93           switch (cur->cond) {
2131              
2132 12           case ICOND_DEFINED:
2133 12           init = op_guard_relinquish(&cur->init);
2134 12 100         if (cur->param.padoff == NOT_IN_PAD) {
2135 1           OP *arg = newBINOP(
2136             OP_AELEM, 0,
2137             newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
2138             mkconstiv(aTHX_ req + i)
2139             );
2140 1           init = newLOGOP(OP_DOR, 0, arg, init);
2141             } else {
2142 11           OP *var = my_var(aTHX_ 0, cur->param.padoff);
2143 11           init = newASSIGNOP(OPf_STACKED, var, OP_DORASSIGN, init);
2144             }
2145 12           sequ = op_append_list(OP_LINESEQ, sequ, nest);
2146 12           nest = NULL;
2147 12           sequ = op_append_list(OP_LINESEQ, sequ, init);
2148 12           break;
2149              
2150 81           case ICOND_EXISTS:
2151 81           cond = newBINOP(
2152             OP_LT, 0,
2153             newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
2154             mkconstiv(aTHX_ req + i + 1)
2155             );
2156              
2157 81           init = op_guard_relinquish(&cur->init);
2158 81 100         if (cur->param.padoff != NOT_IN_PAD) {
2159 80           OP *var = my_var(aTHX_ 0, cur->param.padoff);
2160 80           init = newASSIGNOP(OPf_STACKED, var, 0, init);
2161             }
2162              
2163 81           nest = op_append_list(OP_LINESEQ, nest, init);
2164 81           nest = newCONDOP(0, cond, nest, NULL);
2165 81           break;
2166             }
2167             }
2168              
2169 561           sequ = op_append_list(OP_LINESEQ, sequ, nest);
2170              
2171 561           op_guard_update(prelude_sentinel, op_append_list(
2172             OP_LINESEQ, prelude_sentinel->op,
2173             sequ
2174             ));
2175             }
2176              
2177             /* named parameters */
2178 561 100         if (count_named_params(param_spec)) {
2179             size_t i, lim;
2180              
2181             assert(param_spec->rest_hash != NOT_IN_PAD);
2182              
2183 87 100         for (i = 0, lim = param_spec->named_required.used; i < lim; i++) {
2184 56           Param *cur = &param_spec->named_required.data[i];
2185             size_t n;
2186 56           char *p = SvPV(cur->name, n);
2187             OP *var, *cond;
2188              
2189             assert(cur->padoff != NOT_IN_PAD);
2190              
2191 56           cond = mkhvelem(aTHX_ param_spec->rest_hash, mkconstpv(aTHX_ p + 1, n - 1));
2192              
2193 56 100         if (spec->flags & FLAG_CHECK_NARGS) {
2194             OP *xcroak, *msg;
2195              
2196 55           var = mkhvelem(aTHX_ param_spec->rest_hash, mkconstpv(aTHX_ p + 1, n - 1));
2197 55           var = newUNOP(OP_DELETE, 0, var);
2198              
2199 55           msg = mkconstsv(aTHX_ Perl_newSVpvf(aTHX_ "In %"SVf": missing named parameter: %.*s", SVfARG(declarator), (int)(n - 1), p + 1));
2200 55           xcroak = mkcroak(aTHX_ msg);
2201              
2202 55           cond = newUNOP(OP_EXISTS, 0, cond);
2203              
2204 55           cond = newCONDOP(0, cond, var, xcroak);
2205             }
2206              
2207 56           var = my_var(
2208             aTHX_
2209             OPf_MOD | (OPpLVAL_INTRO << 8),
2210             cur->padoff
2211             );
2212 56           var = newASSIGNOP(OPf_STACKED, var, 0, cond);
2213              
2214 56           op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, var)));
2215             }
2216              
2217 54 100         for (i = 0, lim = param_spec->named_optional.used; i < lim; i++) {
2218 23           ParamInit *cur = &param_spec->named_optional.data[i];
2219             size_t n;
2220 23           char *p = SvPV(cur->param.name, n);
2221             OP *var, *expr;
2222              
2223 23           expr = mkhvelem(aTHX_ param_spec->rest_hash, mkconstpv(aTHX_ p + 1, n - 1));
2224 23           expr = newUNOP(OP_DELETE, 0, expr);
2225              
2226             {
2227 23           OP *const init = cur->init.op;
2228 23 100         if (init->op_type == OP_UNDEF && !(init->op_flags & OPf_KIDS)) {
    50          
2229 4           op_free(op_guard_relinquish(&cur->init));
2230             } else {
2231 19           switch (cur->cond) {
2232 2           case ICOND_DEFINED:
2233 2           expr = newLOGOP(OP_DOR, 0, expr, op_guard_relinquish(&cur->init));
2234 2           break;
2235              
2236 17           case ICOND_EXISTS: {
2237             OP *cond;
2238              
2239 17           cond = mkhvelem(aTHX_ param_spec->rest_hash, mkconstpv(aTHX_ p + 1, n - 1));
2240 17           cond = newUNOP(OP_EXISTS, 0, cond);
2241              
2242 17           expr = newCONDOP(0, cond, expr, op_guard_relinquish(&cur->init));
2243 17           break;
2244             }
2245             }
2246             }
2247             }
2248              
2249 23           var = my_var(
2250             aTHX_
2251             OPf_MOD | (OPpLVAL_INTRO << 8),
2252             cur->param.padoff
2253             );
2254 23           var = newASSIGNOP(OPf_STACKED, var, 0, expr);
2255              
2256 23           op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, var)));
2257             }
2258              
2259 31 100         if (!param_spec->slurpy.name) {
2260 25 100         if (spec->flags & FLAG_CHECK_NARGS) {
2261             /* croak if %{__rest} */
2262             OP *xcroak, *cond, *keys, *msg;
2263              
2264 24           keys = newUNOP(OP_KEYS, 0, my_var_g(aTHX_ OP_PADHV, 0, param_spec->rest_hash));
2265 24           keys = newLISTOP(OP_SORT, 0, newOP(OP_PUSHMARK, 0), keys);
2266 24           keys->op_flags = (keys->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
2267 24           keys = op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, mkconstpvs(", "), keys));
2268 24           keys->op_targ = pad_alloc(OP_JOIN, SVs_PADTMP);
2269              
2270 24           msg = mkconstsv(aTHX_ Perl_newSVpvf(aTHX_ "In %"SVf": no such named parameter: ", SVfARG(declarator)));
2271 24           msg = newBINOP(OP_CONCAT, 0, msg, keys);
2272              
2273 24           xcroak = mkcroak(aTHX_ msg);
2274              
2275 24           cond = newUNOP(OP_KEYS, 0, my_var_g(aTHX_ OP_PADHV, 0, param_spec->rest_hash));
2276 24           xcroak = newCONDOP(0, cond, xcroak, NULL);
2277              
2278 24           op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, xcroak)));
2279             } else {
2280             OP *clear;
2281              
2282 1           clear = newASSIGNOP(
2283             OPf_STACKED,
2284             my_var_g(aTHX_ OP_PADHV, 0, param_spec->rest_hash),
2285             0,
2286             newNULLLIST()
2287             );
2288              
2289 1           op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, clear)));
2290             }
2291 6 100         } else if (param_spec->slurpy.padoff != param_spec->rest_hash) {
2292             OP *clear;
2293              
2294             assert(param_spec->rest_hash != NOT_IN_PAD);
2295 4 50         if (SvPV_nolen(param_spec->slurpy.name)[0] == '%') {
2296             assert(param_spec->slurpy.padoff == NOT_IN_PAD);
2297             } else {
2298              
2299             assert(SvPV_nolen(param_spec->slurpy.name)[0] == '@');
2300              
2301 4 50         if (param_spec->slurpy.padoff != NOT_IN_PAD) {
2302 4           OP *var = my_var_g(
2303             aTHX_
2304             OP_PADAV,
2305             OPf_MOD | (OPpLVAL_INTRO << 8),
2306             param_spec->slurpy.padoff
2307             );
2308              
2309 4           var = newASSIGNOP(OPf_STACKED, var, 0, my_var_g(aTHX_ OP_PADHV, 0, param_spec->rest_hash));
2310              
2311 4           op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, var)));
2312             }
2313             }
2314              
2315 4           clear = newASSIGNOP(
2316             OPf_STACKED,
2317             my_var_g(aTHX_ OP_PADHV, 0, param_spec->rest_hash),
2318             0,
2319             newNULLLIST()
2320             );
2321              
2322 4           op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, clear)));
2323             }
2324             }
2325              
2326 561 50         if (spec->flags & FLAG_CHECK_TARGS) {
2327             size_t i, lim, base;
2328              
2329 561           base = 1;
2330 1348 100         for (i = 0, lim = param_spec->positional_required.used; i < lim; i++) {
2331 788           Param *cur = &param_spec->positional_required.data[i];
2332              
2333 788 100         if (cur->type) {
2334 50           const bool is_invocant = i < param_spec->shift;
2335 50           const size_t shift = param_spec->shift;
2336             assert(cur->padoff != NOT_IN_PAD);
2337 50 100         op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, mktypecheckpv(aTHX_ sen, declarator, base + i - (is_invocant ? 0 : shift), cur, !is_invocant ? 0 : shift == 1 ? -1 : 1))));
    100          
    100          
2338             }
2339             }
2340 560           base += i - param_spec->shift;
2341              
2342 671 100         for (i = 0, lim = param_spec->positional_optional.used; i < lim; i++) {
2343 111           Param *cur = &param_spec->positional_optional.data[i].param;
2344              
2345 111 50         if (cur->type) {
2346             assert(cur->padoff != NOT_IN_PAD);
2347 0           op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, mktypecheckp(aTHX_ sen, declarator, base + i, cur))));
2348             }
2349             }
2350 560           base += i;
2351              
2352 616 100         for (i = 0, lim = param_spec->named_required.used; i < lim; i++) {
2353 56           Param *cur = &param_spec->named_required.data[i];
2354              
2355 56 50         if (cur->type) {
2356             assert(cur->padoff != NOT_IN_PAD);
2357 0           op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, mktypecheckp(aTHX_ sen, declarator, base + i, cur))));
2358             }
2359             }
2360 560           base += i;
2361              
2362 583 100         for (i = 0, lim = param_spec->named_optional.used; i < lim; i++) {
2363 23           Param *cur = &param_spec->named_optional.data[i].param;
2364              
2365 23 50         if (cur->type) {
2366             assert(cur->padoff != NOT_IN_PAD);
2367 0           op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, mktypecheckp(aTHX_ sen, declarator, base + i, cur))));
2368             }
2369             }
2370 560           base += i;
2371              
2372 560 100         if (param_spec->slurpy.type) {
2373             /* $type->valid($_) or croak $type->get_message($_) for @rest / values %rest */
2374             OP *check, *list, *loop;
2375              
2376             assert(param_spec->slurpy.padoff != NOT_IN_PAD);
2377              
2378 1           check = mktypecheck(aTHX_ sen, declarator, base, param_spec->slurpy.name, NOT_IN_PAD, param_spec->slurpy.type);
2379              
2380 1 50         if (SvPV_nolen(param_spec->slurpy.name)[0] == '@') {
2381 1           list = my_var_g(aTHX_ OP_PADAV, 0, param_spec->slurpy.padoff);
2382             } else {
2383 0           list = my_var_g(aTHX_ OP_PADHV, 0, param_spec->slurpy.padoff);
2384 0           list = newUNOP(OP_VALUES, 0, list);
2385             }
2386              
2387 1           loop = newFOROP(0, NULL, list, check, NULL);
2388              
2389 1           op_guard_update(prelude_sentinel, op_append_list(OP_LINESEQ, prelude_sentinel->op, newSTATEOP(0, NULL, loop)));
2390             }
2391             }
2392              
2393 560           PL_perldb |= prev_db_line;
2394              
2395             /* finally let perl parse the actual subroutine body */
2396 560           body = parse_block(0);
2397              
2398             /* add '();' to make function return nothing by default */
2399             /* (otherwise the invisible parameter initialization can "leak" into
2400             the return value: fun ($x) {}->("asdf", 0) == 2) */
2401 560 100         if (prelude_sentinel->op) {
2402 546           body = newSTATEOP(0, NULL, body);
2403             }
2404              
2405 560           body = op_append_list(OP_LINESEQ, op_guard_relinquish(prelude_sentinel), body);
2406              
2407             /* it's go time. */
2408             {
2409 560           const bool runtime = cBOOL(spec->flags & FLAG_RUNTIME);
2410             CV *cv;
2411 560           OP *const attrs = op_guard_relinquish(attrs_sentinel);
2412              
2413 560 50         SvREFCNT_inc_simple_void(PL_compcv);
2414              
2415             /* close outer block: '}' */
2416 560           body = block_end(save_ix, body);
2417              
2418 560 100         cv = newATTRSUB(
    100          
    100          
    100          
2419             floor_ix,
2420             saw_name && !runtime && !spec->install_sub
2421             ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(saw_name)) : NULL,
2422             proto
2423             ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL,
2424             attrs,
2425             body
2426             );
2427              
2428 560 100         if (cv) {
2429             assert(cv != CvOUTSIDE(cv));
2430 556           register_info(aTHX_ PTR2UV(CvROOT(cv)), declarator, param_spec);
2431             }
2432              
2433 560 100         if (saw_name) {
2434 343 100         if (!runtime) {
2435 322 100         if (spec->install_sub) {
2436             SV *args[2];
2437 4           args[0] = saw_name;
2438 4           args[1] = sentinel_mortalize(sen, newRV_noinc((SV *)cv));
2439 4           call_from_curstash(aTHX_ sen, spec->install_sub, args, 2, G_VOID);
2440             }
2441 322           *pop = newOP(OP_NULL, 0);
2442             } else {
2443 21 100         *pop = newUNOP(
2444             OP_ENTERSUB, OPf_STACKED,
2445             op_append_elem(
2446             OP_LIST,
2447             op_append_elem(
2448             OP_LIST,
2449             mkconstsv(aTHX_ SvREFCNT_inc_simple_NN(saw_name)),
2450             mkanonsub(aTHX_ cv)
2451             ),
2452             newCVREF(
2453             OPf_WANT_SCALAR,
2454             mkconstsv(aTHX_
2455             spec->install_sub
2456             ? SvREFCNT_inc_simple_NN(spec->install_sub)
2457             : newSVpvs(MY_PKG "::_defun")
2458             )
2459             )
2460             )
2461             );
2462             }
2463 343           return KEYWORD_PLUGIN_STMT;
2464             }
2465              
2466 217           *pop = mkanonsub(aTHX_ cv);
2467 217           return KEYWORD_PLUGIN_EXPR;
2468             }
2469             }
2470              
2471 277765           static int kw_flags_enter(pTHX_ Sentinel **ppsen, const char *kw_ptr, STRLEN kw_len, KWSpec **ppspec) {
2472             HV *hints, *config;
2473              
2474             /* don't bother doing anything fancy after a syntax error */
2475 277765 50         if (PL_parser && PL_parser->error_count) {
    100          
2476 1           return FALSE;
2477             }
2478              
2479             STATIC_ASSERT_STMT(~(STRLEN)0 > (U32)I32_MAX);
2480 277764 50         if (kw_len > (STRLEN)I32_MAX) {
2481 0           return FALSE;
2482             }
2483              
2484 277764 50         if (!(hints = GvHV(PL_hintgv))) {
2485 0           return FALSE;
2486             }
2487              
2488             {
2489             SV **psv, *sv, *sv2;
2490 277764           I32 kw_xlen = kw_len;
2491              
2492 277764 100         if (!(psv = hv_fetchs(hints, HINTK_CONFIG, 0))) {
2493 273457           return FALSE;
2494             }
2495 4307           sv = *psv;
2496 4307 100         if (!SvROK(sv)) {
2497             /* something is wrong: $^H{'Function::Parameters/config'} has turned into a string */
2498 2           dSP;
2499              
2500 2 50         PUSHMARK(SP);
2501 2           call_pv(MY_PKG "::_warn_config_not_a_reference", G_VOID);
2502              
2503             /* don't warn twice within the same scope */
2504 2           hv_delete(hints, HINTK_CONFIG, sizeof HINTK_CONFIG - 1, G_DISCARD);
2505              
2506 2           return FALSE;
2507             }
2508 4305           sv2 = SvRV(sv);
2509 4305 50         if (SvTYPE(sv2) != SVt_PVHV) {
2510 0           Perl_croak(aTHX_ "%s: internal error: $^H{'%s'} not a hashref: %"SVf, MY_PKG, HINTK_CONFIG, SVfARG(sv));
2511             }
2512 4305 100         if (lex_bufutf8()) {
2513 142           kw_xlen = -kw_xlen;
2514             }
2515 4305 100         if (!(psv = hv_fetch((HV *)sv2, kw_ptr, kw_xlen, 0))) {
2516 3677           return FALSE;
2517             }
2518 628           sv = *psv;
2519 628 50         if (!(SvROK(sv) && (sv2 = SvRV(sv), SvTYPE(sv2) == SVt_PVHV))) {
    50          
2520 0           Perl_croak(aTHX_ "%s: internal error: $^H{'%s'}{'%.*s'} not a hashref: %"SVf, MY_PKG, HINTK_CONFIG, (int)kw_len, kw_ptr, SVfARG(sv));
2521             }
2522 628           config = (HV *)sv2;
2523             }
2524              
2525 628           ENTER;
2526 628           SAVETMPS;
2527              
2528 628           Newx(*ppsen, 1, Sentinel);
2529 628           ***ppsen = NULL;
2530 628           SAVEDESTRUCTOR_X(sentinel_clear_void, *ppsen);
2531              
2532 628           Newx(*ppspec, 1, KWSpec);
2533 628           (*ppspec)->flags = 0;
2534 628           (*ppspec)->reify_type = NULL;
2535 628           spv_init(&(*ppspec)->shift);
2536 628           (*ppspec)->attrs = sentinel_mortalize(**ppsen, newSVpvs(""));
2537 628           (*ppspec)->install_sub = NULL;
2538 628           sentinel_register(**ppsen, *ppspec, kws_free_void);
2539              
2540             #define FETCH_HINTSK_INTO(NAME, PSV) STMT_START { \
2541             SV **hsk_psv_; \
2542             if (!(hsk_psv_ = hv_fetchs(config, HINTSK_ ## NAME, 0))) { \
2543             Perl_croak(aTHX_ "%s: internal error: $^H{'%s'}{'%.*s'}{'%s'} not set", MY_PKG, HINTK_CONFIG, (int)kw_len, kw_ptr, HINTSK_ ## NAME); \
2544             } \
2545             *(PSV) = *hsk_psv_; \
2546             } STMT_END
2547              
2548             {
2549             SV *sv;
2550              
2551 628 50         FETCH_HINTSK_INTO(FLAGS, &sv);
2552 628           (*ppspec)->flags = SvIV(sv);
2553              
2554 628 50         FETCH_HINTSK_INTO(REIFY, &sv);
2555 628 50         if (!sv || !SvROK(sv) || SvTYPE(SvRV(sv)) != SVt_PVCV) {
    50          
    50          
2556 0           Perl_croak(aTHX_ "%s: internal error: $^H{'%s'}{'%.*s'}{'%s'} not a coderef: %"SVf, MY_PKG, HINTK_CONFIG, (int)kw_len, kw_ptr, HINTSK_REIFY, SVfARG(sv));
2557             }
2558 628           (*ppspec)->reify_type = sv;
2559              
2560 628 50         FETCH_HINTSK_INTO(SHIFT, &sv);
2561             {
2562             STRLEN sv_len;
2563 628           const char *const sv_p = SvPVutf8(sv, sv_len);
2564 628           const char *const sv_p_end = sv_p + sv_len;
2565 628           const char *p = sv_p;
2566 628           AV *shift_types = NULL;
2567 628           SV *type = NULL;
2568              
2569 829 100         while (p < sv_p_end) {
2570 201           const char *const v_start = p, *v_end;
2571 201 50         if (*p != '$') {
2572 0           Perl_croak(aTHX_ "%s: internal error: $^H{'%s'}{'%.*s'}{'%s'}: expected '$', found '%.*s'", MY_PKG, HINTK_CONFIG, (int)kw_len, kw_ptr, HINTSK_SHIFT, (int)(sv_p_end - p), p);
2573             }
2574 201           p++;
2575 201 50         if (p >= sv_p_end || !MY_UNI_IDFIRST_utf8(p, sv_p_end)) {
    50          
    50          
    50          
    0          
    0          
    0          
    0          
    0          
2576 0           Perl_croak(aTHX_ "%s: internal error: $^H{'%s'}{'%.*s'}{'%s'}: expected idfirst, found '%.*s'", MY_PKG, HINTK_CONFIG, (int)kw_len, kw_ptr, HINTSK_SHIFT, (int)(sv_p_end - p), p);
2577             }
2578 201           p += UTF8SKIP(p);
2579 832 50         while (p < sv_p_end && MY_UNI_IDCONT_utf8(p, sv_p_end)) {
    50          
    50          
    100          
    0          
    0          
    0          
    0          
    0          
2580 631           p += UTF8SKIP(p);
2581             }
2582 201           v_end = p;
2583 201 50         if (v_end == v_start + 2 && v_start[1] == '_') {
    0          
2584 0           Perl_croak(aTHX_ "%s: internal error: $^H{'%s'}{'%.*s'}{'%s'}: can't use global $_ as a parameter", MY_PKG, HINTK_CONFIG, (int)kw_len, kw_ptr, HINTSK_SHIFT);
2585             }
2586             {
2587 201           size_t i, lim = (*ppspec)->shift.used;
2588 212 100         for (i = 0; i < lim; i++) {
2589 11 50         if (my_sv_eq_pvn(aTHX_ (*ppspec)->shift.data[i].name, v_start, v_end - v_start)) {
2590 0           Perl_croak(aTHX_ "%s: internal error: $^H{'%s'}{'%.*s'}{'%s'}: %"SVf" can't appear twice", MY_PKG, HINTK_CONFIG, (int)kw_len, kw_ptr, HINTSK_SHIFT, SVfARG((*ppspec)->shift.data[i].name));
2591             }
2592             }
2593             }
2594 201 50         if (p < sv_p_end && *p == '/') {
    100          
2595 2           SSize_t tix = 0;
2596             SV **ptype;
2597 2           p++;
2598 4 50         while (p < sv_p_end && isDIGIT(*p)) {
    100          
2599 2           tix = tix * 10 + (*p - '0');
2600 2           p++;
2601             }
2602              
2603 2 50         if (!shift_types) {
2604             SV *sv2;
2605 2 50         FETCH_HINTSK_INTO(SHIF2, &sv);
2606 2 50         if (!(SvROK(sv) && (sv2 = SvRV(sv), SvTYPE(sv2) == SVt_PVAV))) {
    50          
2607 0           Perl_croak(aTHX_ "%s: internal error: $^H{'%s'}{'%.*s'}{'%s'} not an arrayref: %"SVf, MY_PKG, HINTK_CONFIG, (int)kw_len, kw_ptr, HINTSK_SHIF2, SVfARG(sv));
2608             }
2609 2           shift_types = (AV *)sv2;
2610             }
2611 2 50         if (tix < 0 || tix > av_len(shift_types)) {
    50          
2612 0           Perl_croak(aTHX_ "%s: internal error: $^H{'%s'}{'%.*s'}{'%s'}: tix [%ld] out of range [%ld]", MY_PKG, HINTK_CONFIG, (int)kw_len, kw_ptr, HINTSK_SHIFT, (long)tix, (long)(av_len(shift_types) + 1));
2613             }
2614 2           ptype = av_fetch(shift_types, tix, 0);
2615 2 50         if (!ptype) {
2616 0           Perl_croak(aTHX_ "%s: internal error: $^H{'%s'}{'%.*s'}{'%s'}: tix [%ld] doesn't exist", MY_PKG, HINTK_CONFIG, (int)kw_len, kw_ptr, HINTSK_SHIFT, (long)tix);
2617             }
2618 2           type = *ptype;
2619 2 50         if (!sv_isobject(type)) {
2620 0           Perl_croak(aTHX_ "%s: internal error: $^H{'%s'}{'%.*s'}{'%s'}: tix [%ld] is not an object (%"SVf")", MY_PKG, HINTK_CONFIG, (int)kw_len, kw_ptr, HINTSK_SHIFT, (long)tix, SVfARG(type));
2621             }
2622             }
2623              
2624 201           spv_push(&(*ppspec)->shift, sentinel_mortalize(**ppsen, newSVpvn_utf8(v_start, v_end - v_start, TRUE)), type);
2625 201 50         if (p < sv_p_end) {
2626 201 50         if (*p != ' ') {
2627 0           Perl_croak(aTHX_ "%s: internal error: $^H{'%s'}{'%.*s'}{'%s'}: expected ' ', found '%.*s'", MY_PKG, HINTK_CONFIG, (int)kw_len, kw_ptr, HINTSK_SHIFT, (int)(sv_p_end - p), p);
2628             }
2629 201           p++;
2630             }
2631             }
2632             }
2633              
2634 628 50         FETCH_HINTSK_INTO(ATTRS, &sv);
2635 628 50         SvSetSV((*ppspec)->attrs, sv);
2636              
2637 628 50         FETCH_HINTSK_INTO(INSTL, &sv);
2638 628 100         if (SvTRUE(sv)) {
2639             assert(SvROK(sv) || !(isDIGIT(*SvPV_nolen(sv))));
2640 12           (*ppspec)->install_sub = sv;
2641             }
2642             }
2643             #undef FETCH_HINTSK_INTO
2644              
2645 628           return TRUE;
2646             }
2647              
2648             static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
2649              
2650 277765           static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) {
2651             Sentinel *psen;
2652             KWSpec *pspec;
2653             int ret;
2654              
2655 277765 100         if (kw_flags_enter(aTHX_ &psen, keyword_ptr, keyword_len, &pspec)) {
2656             /* scope was entered, 'psen' and 'pspec' are initialized */
2657 628           ret = parse_fun(aTHX_ *psen, op_ptr, keyword_ptr, keyword_len, pspec);
2658 560 100         FREETMPS;
2659 560           LEAVE;
2660             } else {
2661             /* not one of our keywords, no allocation done */
2662 277137           ret = next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
2663             }
2664              
2665 277697           return ret;
2666             }
2667              
2668             /* https://rt.perl.org/Public/Bug/Display.html?id=132413 */
2669             #ifndef wrap_keyword_plugin
2670             #define wrap_keyword_plugin(A, B) S_wrap_keyword_plugin(aTHX_ A, B)
2671             static void S_wrap_keyword_plugin(pTHX_ Perl_keyword_plugin_t new_plugin, Perl_keyword_plugin_t *old_plugin_p) {
2672             PERL_UNUSED_CONTEXT;
2673             if (*old_plugin_p) {
2674             return;
2675             }
2676             MUTEX_LOCK(&PL_op_mutex);
2677             if (!*old_plugin_p) {
2678             *old_plugin_p = PL_keyword_plugin;
2679             PL_keyword_plugin = new_plugin;
2680             }
2681             MUTEX_UNLOCK(&PL_op_mutex);
2682             }
2683             #endif
2684              
2685 49           static void my_boot(pTHX) {
2686 49           HV *const stash = gv_stashpvs(MY_PKG, GV_ADD);
2687              
2688 49           newCONSTSUB(stash, "FLAG_NAME_OK", newSViv(FLAG_NAME_OK));
2689 49           newCONSTSUB(stash, "FLAG_ANON_OK", newSViv(FLAG_ANON_OK));
2690 49           newCONSTSUB(stash, "FLAG_DEFAULT_ARGS", newSViv(FLAG_DEFAULT_ARGS));
2691 49           newCONSTSUB(stash, "FLAG_CHECK_NARGS", newSViv(FLAG_CHECK_NARGS));
2692 49           newCONSTSUB(stash, "FLAG_INVOCANT", newSViv(FLAG_INVOCANT));
2693 49           newCONSTSUB(stash, "FLAG_NAMED_PARAMS", newSViv(FLAG_NAMED_PARAMS));
2694 49           newCONSTSUB(stash, "FLAG_TYPES_OK", newSViv(FLAG_TYPES_OK));
2695 49           newCONSTSUB(stash, "FLAG_CHECK_TARGS", newSViv(FLAG_CHECK_TARGS));
2696 49           newCONSTSUB(stash, "FLAG_RUNTIME", newSViv(FLAG_RUNTIME));
2697 49           newCONSTSUB(stash, "HINTK_CONFIG", newSVpvs(HINTK_CONFIG));
2698 49           newCONSTSUB(stash, "HINTSK_FLAGS", newSVpvs(HINTSK_FLAGS));
2699 49           newCONSTSUB(stash, "HINTSK_SHIFT", newSVpvs(HINTSK_SHIFT));
2700 49           newCONSTSUB(stash, "HINTSK_SHIF2", newSVpvs(HINTSK_SHIF2));
2701 49           newCONSTSUB(stash, "HINTSK_ATTRS", newSVpvs(HINTSK_ATTRS));
2702 49           newCONSTSUB(stash, "HINTSK_REIFY", newSVpvs(HINTSK_REIFY));
2703 49           newCONSTSUB(stash, "HINTSK_INSTL", newSVpvs(HINTSK_INSTL));
2704              
2705 49           wrap_keyword_plugin(my_keyword_plugin, &next_keyword_plugin);
2706 49           }
2707              
2708             #ifndef assert_
2709             #ifdef DEBUGGING
2710             #define assert_(X) assert(X),
2711             #else
2712             #define assert_(X)
2713             #endif
2714             #endif
2715              
2716             #ifndef gv_method_changed
2717             #define gv_method_changed(GV) ( \
2718             assert_(isGV_with_GP(GV)) \
2719             GvREFCNT(GV) > 1 \
2720             ? (void)PL_sub_generation++ \
2721             : mro_method_changed_in(GvSTASH(GV)) \
2722             )
2723             #endif
2724              
2725             WARNINGS_RESET
2726              
2727             MODULE = Function::Parameters PACKAGE = Function::Parameters PREFIX = fp_
2728             PROTOTYPES: ENABLE
2729              
2730             UV
2731             fp__cv_root(sv)
2732             SV *sv
2733             PREINIT:
2734             CV *xcv;
2735             HV *hv;
2736             GV *gv;
2737             CODE:
2738 18           xcv = sv_2cv(sv, &hv, &gv, 0);
2739 18 50         RETVAL = PTR2UV(xcv ? CvROOT(xcv) : NULL);
    100          
2740             OUTPUT:
2741             RETVAL
2742              
2743             void
2744             fp__defun(name, body)
2745             SV *name
2746             CV *body
2747             PREINIT:
2748             GV *gv;
2749             CV *xcv;
2750             CODE:
2751             assert(SvTYPE(body) == SVt_PVCV);
2752 12           gv = gv_fetchsv(name, GV_ADDMULTI, SVt_PVCV);
2753 12           xcv = GvCV(gv);
2754 12 100         if (xcv) {
2755 1 50         if (!GvCVGEN(gv) && (CvROOT(xcv) || CvXSUB(xcv)) && ckWARN(WARN_REDEFINE)) {
    50          
    0          
    50          
2756 0           Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Subroutine %"SVf" redefined", SVfARG(name));
2757             }
2758 1           SvREFCNT_dec_NN(xcv);
2759             }
2760 12           GvCVGEN(gv) = 0;
2761 12           GvASSUMECV_on(gv);
2762 12 50         if (GvSTASH(gv)) {
2763 12 100         gv_method_changed(gv);
2764             }
2765 12           GvCV_set(gv, (CV *)SvREFCNT_inc_simple_NN(body));
2766 12           CvGV_set(body, gv);
2767 12           CvANON_off(body);
2768              
2769             BOOT:
2770 49           my_boot(aTHX);