Parameters.xs

   1 /*
   2 Copyright 2012 Lukas Mai.
   3
   4 This program is free software; you can redistribute it and/or modify it
   5 under the terms of either: the GNU General Public License as published
   6 by the Free Software Foundation; or the Artistic License.
   7
   8 See http://dev.perl.org/licenses/ for more information.
   9  */
  10
  11 #ifdef __GNUC__
  12  #if (__GNUC__ == 4 && __GNUC_MINOR__ >= 6) || __GNUC__ >= 5
  13   #define PRAGMA_GCC_(X) _Pragma(#X)
  14   #define PRAGMA_GCC(X) PRAGMA_GCC_(GCC X)
  15  #endif
  16 #endif
  17
  18 #ifndef PRAGMA_GCC
  19  #define PRAGMA_GCC(X)
  20 #endif
  21
  22 #ifdef DEVEL
  23  #define WARNINGS_RESET PRAGMA_GCC(diagnostic pop)
  24  #define WARNINGS_ENABLEW(X) PRAGMA_GCC(diagnostic warning #X)
  25  #define WARNINGS_ENABLE \
  26         WARNINGS_ENABLEW(-Wall) \
  27         WARNINGS_ENABLEW(-Wextra) \
  28         WARNINGS_ENABLEW(-Wundef) \
  29         /* WARNINGS_ENABLEW(-Wshadow) :-( */ \
  30         WARNINGS_ENABLEW(-Wbad-function-cast) \
  31         WARNINGS_ENABLEW(-Wcast-align) \
  32         WARNINGS_ENABLEW(-Wwrite-strings) \
  33         /* WARNINGS_ENABLEW(-Wnested-externs) wtf? */ \
  34         WARNINGS_ENABLEW(-Wstrict-prototypes) \
  35         WARNINGS_ENABLEW(-Wmissing-prototypes) \
  36         WARNINGS_ENABLEW(-Winline) \
  37         WARNINGS_ENABLEW(-Wdisabled-optimization)
  38
  39 #else
  40  #define WARNINGS_RESET
  41  #define WARNINGS_ENABLE
  42 #endif
  43
  44
  45 #define PERL_NO_GET_CONTEXT
  46 #include "EXTERN.h"
  47 #include "perl.h"
  48 #include "XSUB.h"
  49
  50 #include <string.h>
  51
  52
  53 WARNINGS_ENABLE
  54
  55
  56 #define HAVE_PERL_VERSION(R, V, S) \
  57         (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
  58
  59 #if HAVE_PERL_VERSION(5, 16, 0)
  60  #define IF_HAVE_PERL_5_16(YES, NO) YES
  61 #else
  62  #define IF_HAVE_PERL_5_16(YES, NO) NO
  63 #endif
  64
  65
  66 #define MY_PKG "Function::Parameters"
  67
  68 #define HINTK_KEYWORDS MY_PKG "/keywords"
  69 #define HINTK_FLAGS_   MY_PKG "/flags:"
  70 #define HINTK_SHIFT_   MY_PKG "/shift:"
  71 #define HINTK_ATTRS_   MY_PKG "/attrs:"
  72
  73 #define DEFSTRUCT(T) typedef struct T T; struct T
  74
  75 DEFSTRUCT(DefaultParamSpec) {
  76         DefaultParamSpec *next;
  77         int limit;
  78         SV *name;
  79         OP *init;
  80 };
  81
  82 enum {
  83         FLAG_NAME_OK      = 0x01,
  84         FLAG_ANON_OK      = 0x02,
  85         FLAG_DEFAULT_ARGS = 0x04,
  86         FLAG_CHECK_NARGS  = 0x08
  87 };
  88
  89 DEFSTRUCT(KWSpec) {
  90         unsigned flags;
  91         SV *shift;
  92         SV *attrs;
  93 };
  94
  95 static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
  96
  97 static int kw_flags(pTHX_ const char *kw_ptr, STRLEN kw_len, KWSpec *spec) {
  98         HV *hints;
  99         SV *sv, **psv;
 100         const char *p, *kw_active;
 101         STRLEN kw_active_len;
 102
 103         spec->flags = 0;
 104         spec->shift = sv_2mortal(newSVpvs(""));
 105         spec->attrs = sv_2mortal(newSVpvs(""));
 106
 107         if (!(hints = GvHV(PL_hintgv))) {
 108                 return FALSE;
 109         }
 110         if (!(psv = hv_fetchs(hints, HINTK_KEYWORDS, 0))) {
 111                 return FALSE;
 112         }
 113         sv = *psv;
 114         kw_active = SvPV(sv, kw_active_len);
 115         if (kw_active_len <= kw_len) {
 116                 return FALSE;
 117         }
 118         for (
 119                 p = kw_active;
 120                 (p = strchr(p, *kw_ptr)) &&
 121                 p < kw_active + kw_active_len - kw_len;
 122                 p++
 123         ) {
 124                 if (
 125                         (p == kw_active || p[-1] == ' ') &&
 126                         p[kw_len] == ' ' &&
 127                         memcmp(kw_ptr, p, kw_len) == 0
 128                 ) {
 129
 130 #define FETCH_HINTK_INTO(NAME, PTR, LEN, X) STMT_START { \
 131         const char *fk_ptr_; \
 132         STRLEN fk_len_; \
 133         SV *fk_sv_; \
 134         fk_sv_ = sv_2mortal(newSVpvs(HINTK_ ## NAME)); \
 135         sv_catpvn(fk_sv_, PTR, LEN); \
 136         fk_ptr_ = SvPV(fk_sv_, fk_len_); \
 137         if (!((X) = hv_fetch(hints, fk_ptr_, fk_len_, 0))) { \
 138                 croak("%s: internal error: $^H{'%.*s'} not set", MY_PKG, (int)fk_len_, fk_ptr_); \
 139         } \
 140 } STMT_END
 141
 142                         FETCH_HINTK_INTO(FLAGS_, kw_ptr, kw_len, psv);
 143                         spec->flags = SvIV(*psv);
 144
 145                         FETCH_HINTK_INTO(SHIFT_, kw_ptr, kw_len, psv);
 146                         SvSetSV(spec->shift, *psv);
 147
 148                         FETCH_HINTK_INTO(ATTRS_, kw_ptr, kw_len, psv);
 149                         SvSetSV(spec->attrs, *psv);
 150
 151 #undef FETCH_HINTK_INTO
 152                         return TRUE;
 153                 }
 154         }
 155         return FALSE;
 156 }
 157
 158
 159 #include "toke_on_crack.c.inc"
 160
 161
 162 static void free_defspec(pTHX_ void *vp) {
 163         DefaultParamSpec *dp = vp;
 164         op_free(dp->init);
 165         Safefree(dp);
 166 }
 167
 168 static void free_ptr_op(pTHX_ void *vp) {
 169         OP **pp = vp;
 170         op_free(*pp);
 171         Safefree(pp);
 172 }
 173
 174 #define sv_eq_pvs(SV, S) my_sv_eq_pvn(aTHX_ SV, "" S "", sizeof (S) - 1)
 175
 176 static int my_sv_eq_pvn(pTHX_ SV *sv, const char *p, STRLEN n) {
 177         STRLEN sv_len;
 178         const char *sv_p = SvPV(sv, sv_len);
 179         return memcmp(sv_p, p, n) == 0;
 180 }
 181
 182
 183 #include "padop_on_crack.c.inc"
 184
 185
 186 #if 0
 187 static PADOFFSET pad_add_my_sv(SV *name) {
 188         PADOFFSET offset;
 189         SV *namesv, *myvar;
 190         char *p;
 191         STRLEN len;
 192
 193         p = SvPV(name, len);
 194         myvar = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, 1);
 195         offset = AvFILLp(PL_comppad);
 196         SvPADMY_on(myvar);
 197         if (*p == '@') {
 198                 SvUPGRADE(myvar, SVt_PVAV);
 199         } else if (*p == '%') {
 200                 SvUPGRADE(myvar, SVt_PVHV);
 201         }
 202         PL_curpad = AvARRAY(PL_comppad);
 203         namesv = newSV_type(SVt_PVMG);
 204         sv_setpvn(namesv, p, len);
 205         COP_SEQ_RANGE_LOW_set(namesv, PL_cop_seqmax);
 206         COP_SEQ_RANGE_HIGH_set(namesv, PERL_PADSEQ_INTRO);
 207         PL_cop_seqmax++;
 208         av_store(PL_comppad_name, offset, namesv);
 209         return offset;
 210 }
 211 #endif
 212
 213 enum {
 214         MY_ATTR_LVALUE = 0x01,
 215         MY_ATTR_METHOD = 0x02,
 216         MY_ATTR_SPECIAL = 0x04
 217 };
 218
 219 static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len, const KWSpec *spec) {
 220         SV *declarator;
 221         I32 floor_ix;
 222         int save_ix;
 223         SV *saw_name;
 224         AV *params;
 225         DefaultParamSpec *defaults;
 226         int args_min, args_max;
 227         SV *proto;
 228         OP **attrs_sentinel, *body;
 229         unsigned builtin_attrs;
 230         STRLEN len;
 231         char *s;
 232         I32 c;
 233
 234         declarator = sv_2mortal(newSVpvn(keyword_ptr, keyword_len));
 235
 236         lex_read_space(0);
 237
 238         builtin_attrs = 0;
 239
 240         /* function name */
 241         saw_name = NULL;
 242         s = PL_parser->bufptr;
 243         if ((spec->flags & FLAG_NAME_OK) && (len = S_scan_word(aTHX_ s, TRUE))) {
 244                 saw_name = sv_2mortal(newSVpvn_flags(s, len, PARSING_UTF ? SVf_UTF8 : 0));
 245
 246                 if (PL_parser->expect != XSTATE) {
 247                         /* bail out early so we don't predeclare $saw_name */
 248                         croak("In %"SVf": I was expecting a function body, not \"%"SVf"\"", SVfARG(declarator), SVfARG(saw_name));
 249                 }
 250
 251                 sv_catpvs(declarator, " ");
 252                 sv_catsv(declarator, saw_name);
 253
 254                 if (
 255                         sv_eq_pvs(saw_name, "BEGIN") ||
 256                         sv_eq_pvs(saw_name, "END") ||
 257                         sv_eq_pvs(saw_name, "INIT") ||
 258                         sv_eq_pvs(saw_name, "CHECK") ||
 259                         sv_eq_pvs(saw_name, "UNITCHECK")
 260                 ) {
 261                         builtin_attrs |= MY_ATTR_SPECIAL;
 262                 }
 263
 264                 lex_read_to(s + len);
 265                 lex_read_space(0);
 266         } else if (!(spec->flags & FLAG_ANON_OK)) {
 267                 croak("I was expecting a function name, not \"%.*s\"", (int)(PL_parser->bufend - s), s);
 268         } else {
 269                 sv_catpvs(declarator, " (anon)");
 270         }
 271
 272         /* we're a subroutine declaration */
 273         floor_ix = start_subparse(FALSE, saw_name ? 0 : CVf_ANON);
 274         SAVEFREESV(PL_compcv);
 275
 276         /* create outer block: '{' */
 277         save_ix = S_block_start(aTHX_ TRUE);
 278
 279         /* parameters */
 280         params = NULL;
 281         defaults = NULL;
 282         args_min = 0;
 283         args_max = -1;
 284
 285         c = lex_peek_unichar(0);
 286         if (c == '(') {
 287                 DefaultParamSpec **pdefaults_tail = &defaults;
 288                 SV *saw_slurpy = NULL;
 289                 int param_count = 0;
 290                 args_max = 0;
 291
 292                 lex_read_unichar(0);
 293                 lex_read_space(0);
 294
 295                 params = newAV();
 296                 sv_2mortal((SV *)params);
 297
 298                 for (;;) {
 299                         c = lex_peek_unichar(0);
 300                         if (c == '$' || c == '@' || c == '%') {
 301                                 const char sigil = c;
 302                                 SV *param;
 303
 304                                 param_count++;
 305
 306                                 lex_read_unichar(0);
 307                                 lex_read_space(0);
 308
 309                                 s = PL_parser->bufptr;
 310                                 if (!(len = S_scan_word(aTHX_ s, FALSE))) {
 311                                         croak("In %"SVf": missing identifier", SVfARG(declarator));
 312                                 }
 313                                 param = sv_2mortal(newSVpvf("%c%.*s", sigil, (int)len, s));
 314                                 if (saw_slurpy) {
 315                                         croak("In %"SVf": I was expecting \")\" after \"%"SVf"\", not \"%"SVf"\"", SVfARG(declarator), SVfARG(saw_slurpy), SVfARG(param));
 316                                 }
 317                                 if (sigil == '$') {
 318                                         args_max++;
 319                                 } else {
 320                                         args_max = -1;
 321                                         saw_slurpy = param;
 322                                 }
 323                                 av_push(params, SvREFCNT_inc_simple_NN(param));
 324                                 lex_read_to(s + len);
 325                                 lex_read_space(0);
 326
 327                                 c = lex_peek_unichar(0);
 328
 329                                 if (!(c == '=' && (spec->flags & FLAG_DEFAULT_ARGS))) {
 330                                         if (sigil == '$' && !defaults) {
 331                                                 args_min++;
 332                                         }
 333                                 } else if (sigil != '$') {
 334                                         croak("In %"SVf": %s %"SVf" can't have a default value", SVfARG(declarator), sigil == '@' ? "array" : "hash", SVfARG(saw_slurpy));
 335                                 } else {
 336                                         DefaultParamSpec *curdef;
 337
 338                                         lex_read_unichar(0);
 339                                         lex_read_space(0);
 340
 341                                         Newx(curdef, 1, DefaultParamSpec);
 342                                         curdef->next = NULL;
 343                                         curdef->limit = param_count;
 344                                         curdef->name = param;
 345                                         curdef->init = NULL;
 346                                         SAVEDESTRUCTOR_X(free_defspec, curdef);
 347
 348                                         curdef->next = *pdefaults_tail;
 349                                         *pdefaults_tail = curdef;
 350                                         pdefaults_tail = &curdef->next;
 351
 352                                         /* let perl parse the default parameter value */
 353                                         curdef->init = parse_termexpr(0);
 354
 355                                         lex_read_space(0);
 356                                         c = lex_peek_unichar(0);
 357                                 }
 358
 359                                 if (c == ',') {
 360                                         lex_read_unichar(0);
 361                                         lex_read_space(0);
 362                                         continue;
 363                                 }
 364                         }
 365
 366                         if (c == ')') {
 367                                 lex_read_unichar(0);
 368                                 lex_read_space(0);
 369                                 break;
 370                         }
 371
 372                         if (c == -1) {
 373                                 croak("In %"SVf": unexpected EOF in parameter list", SVfARG(declarator));
 374                         }
 375                         croak("In %"SVf": unexpected '%c' in parameter list", SVfARG(declarator), (int)c);
 376                 }
 377         }
 378
 379         /* prototype */
 380         proto = NULL;
 381         c = lex_peek_unichar(0);
 382         if (c == ':') {
 383                 lex_read_unichar(0);
 384                 lex_read_space(0);
 385
 386                 c = lex_peek_unichar(0);
 387                 if (c != '(') {
 388                         lex_stuff_pvs(":", 0);
 389                         c = ':';
 390                 } else {
 391                         proto = sv_2mortal(newSVpvs(""));
 392                         if (!S_scan_str(aTHX_ proto, FALSE, FALSE)) {
 393                                 croak("In %"SVf": prototype not terminated", SVfARG(declarator));
 394                         }
 395                         S_check_prototype(aTHX_ declarator, proto);
 396                         lex_read_space(0);
 397                         c = lex_peek_unichar(0);
 398                 }
 399         }
 400
 401         /* attributes */
 402         Newx(attrs_sentinel, 1, OP *);
 403         *attrs_sentinel = NULL;
 404         SAVEDESTRUCTOR_X(free_ptr_op, attrs_sentinel);
 405
 406         if (c == ':' || c == '{') /* '}' - hi, vim */ {
 407
 408                 /* kludge default attributes in */
 409                 if (SvTRUE(spec->attrs) && SvPV_nolen(spec->attrs)[0] == ':') {
 410                         lex_stuff_sv(spec->attrs, 0);
 411                         c = ':';
 412                 }
 413
 414                 if (c == ':') {
 415                         lex_read_unichar(0);
 416                         lex_read_space(0);
 417                         c = lex_peek_unichar(0);
 418
 419                         for (;;) {
 420                                 SV *attr;
 421
 422                                 s = PL_parser->bufptr;
 423                                 if (!(len = S_scan_word(aTHX_ s, FALSE))) {
 424                                         break;
 425                                 }
 426
 427                                 attr = sv_2mortal(newSVpvn_flags(s, len, PARSING_UTF ? SVf_UTF8 : 0));
 428
 429                                 lex_read_to(s + len);
 430                                 lex_read_space(0);
 431                                 c = lex_peek_unichar(0);
 432
 433                                 if (c != '(') {
 434                                         if (sv_eq_pvs(attr, "lvalue")) {
 435                                                 builtin_attrs |= MY_ATTR_LVALUE;
 436                                                 attr = NULL;
 437                                         } else if (sv_eq_pvs(attr, "method")) {
 438                                                 builtin_attrs |= MY_ATTR_METHOD;
 439                                                 attr = NULL;
 440                                         }
 441                                 } else {
 442                                         SV *sv = sv_2mortal(newSVpvs(""));
 443                                         if (!S_scan_str(aTHX_ sv, TRUE, TRUE)) {
 444                                                 croak("In %"SVf": unterminated attribute parameter in attribute list", SVfARG(declarator));
 445                                         }
 446                                         sv_catsv(attr, sv);
 447
 448                                         lex_read_space(0);
 449                                         c = lex_peek_unichar(0);
 450                                 }
 451
 452                                 if (attr) {
 453                                         *attrs_sentinel = op_append_elem(OP_LIST, *attrs_sentinel, newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(attr)));
 454                                 }
 455
 456                                 if (c == ':') {
 457                                         lex_read_unichar(0);
 458                                         lex_read_space(0);
 459                                         c = lex_peek_unichar(0);
 460                                 }
 461                         }
 462                 }
 463         }
 464
 465         /* body */
 466         if (c != '{') /* '}' - hi, vim */ {
 467                 croak("In %"SVf": I was expecting a function body, not \"%c\"", SVfARG(declarator), (int)c);
 468         }
 469
 470         /* surprise predeclaration! */
 471         if (saw_name) {
 472                 /* 'sub NAME (PROTO);' to make name/proto known to perl before it
 473                    starts parsing the body */
 474                 const I32 sub_ix = start_subparse(FALSE, 0);
 475                 SAVEFREESV(PL_compcv);
 476
 477                 SvREFCNT_inc_simple_void(PL_compcv);
 478
 479                 newATTRSUB(
 480                         sub_ix,
 481                         newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(saw_name)),
 482                         proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL,
 483                         NULL,
 484                         NULL
 485                 );
 486         }
 487
 488
 489         if (builtin_attrs & MY_ATTR_LVALUE) {
 490                 CvLVALUE_on(PL_compcv);
 491         }
 492         if (builtin_attrs & MY_ATTR_METHOD) {
 493                 CvMETHOD_on(PL_compcv);
 494         }
 495         if (builtin_attrs & MY_ATTR_SPECIAL) {
 496                 CvSPECIAL_on(PL_compcv);
 497         }
 498
 499         /* munge */
 500         {
 501                 OP **prelude_sentinel = NULL;
 502
 503                 Newx(prelude_sentinel, 1, OP *);
 504                 *prelude_sentinel = NULL;
 505                 SAVEDESTRUCTOR_X(free_ptr_op, prelude_sentinel);
 506
 507                 /* min/max argument count checks */
 508                 if (spec->flags & FLAG_CHECK_NARGS) {
 509                         if (SvTRUE(spec->shift)) {
 510                                 args_min++;
 511                                 if (args_max != -1) {
 512                                         args_max++;
 513                                 }
 514                         }
 515
 516                         if (args_min > 0) {
 517                                 OP *chk, *cond, *err, *croak;
 518
 519                                 err = newSVOP(OP_CONST, 0,
 520                                               newSVpvf("Not enough arguments for %"SVf, SVfARG(declarator)));
 521
 522                                 croak = newCVREF(OPf_WANT_SCALAR,
 523                                                  newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV)));
 524                                 err = newUNOP(OP_ENTERSUB, OPf_STACKED,
 525                                               op_append_elem(OP_LIST, err, croak));
 526
 527                                 cond = newBINOP(OP_LT, 0,
 528                                                 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
 529                                                 newSVOP(OP_CONST, 0, newSViv(args_min)));
 530                                 chk = newLOGOP(OP_AND, 0, cond, err);
 531
 532                                 *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, chk));
 533                         }
 534                         if (args_max != -1) {
 535                                 OP *chk, *cond, *err, *croak;
 536
 537                                 err = newSVOP(OP_CONST, 0,
 538                                               newSVpvf("Too many arguments for %"SVf, SVfARG(declarator)));
 539
 540                                 croak = newCVREF(OPf_WANT_SCALAR,
 541                                                  newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV)));
 542                                 err = newUNOP(OP_ENTERSUB, OPf_STACKED,
 543                                               op_append_elem(OP_LIST, err, croak));
 544
 545                                 cond = newBINOP(OP_GT, 0,
 546                                                 newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
 547                                                 newSVOP(OP_CONST, 0, newSViv(args_max)));
 548                                 chk = newLOGOP(OP_AND, 0, cond, err);
 549
 550                                 *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, chk));
 551                         }
 552                 }
 553
 554                 /* my $self = shift; */
 555                 if (SvTRUE(spec->shift)) {
 556                         OP *var, *shift;
 557
 558                         var = newOP(OP_PADSV, OPf_WANT_SCALAR | (OPpLVAL_INTRO << 8));
 559                         var->op_targ = pad_add_name_sv(spec->shift, 0, NULL, NULL);
 560
 561                         shift = newASSIGNOP(OPf_STACKED, var, 0, newOP(OP_SHIFT, 0));
 562                         *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, shift));
 563                 }
 564
 565                 /* my (PARAMS) = @_; */
 566                 if (params && av_len(params) > -1) {
 567                         SV *param;
 568                         OP *init_param, *left, *right;
 569
 570                         left = NULL;
 571                         while ((param = av_shift(params)) != &PL_sv_undef) {
 572                                 OP *const var = newOP(OP_PADSV, OPf_WANT_LIST | (OPpLVAL_INTRO << 8));
 573                                 var->op_targ = pad_add_name_sv(param, 0, NULL, NULL);
 574                                 SvREFCNT_dec(param);
 575                                 left = op_append_elem(OP_LIST, left, var);
 576                         }
 577
 578                         left->op_flags |= OPf_PARENS;
 579                         right = newAVREF(newGVOP(OP_GV, 0, PL_defgv));
 580                         init_param = newASSIGNOP(OPf_STACKED, left, 0, right);
 581                         init_param = newSTATEOP(0, NULL, init_param);
 582
 583                         *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, init_param);
 584                 }
 585
 586                 /* defaults */
 587                 {
 588                         OP *gen = NULL;
 589                         DefaultParamSpec *dp;
 590
 591                         for (dp = defaults; dp; dp = dp->next) {
 592                                 OP *init = dp->init;
 593                                 OP *var, *args, *cond;
 594
 595                                 /* var = `$,name */
 596                                 var = newOP(OP_PADSV, 0);
 597                                 var->op_targ = pad_findmy_sv(dp->name, 0);
 598
 599                                 /* init = `,var = ,init */
 600                                 init = newASSIGNOP(OPf_STACKED, var, 0, init);
 601
 602                                 /* args = `@_ */
 603                                 args = newAVREF(newGVOP(OP_GV, 0, PL_defgv));
 604
 605                                 /* cond = `,args < ,index */
 606                                 cond = newBINOP(OP_LT, 0, args, newSVOP(OP_CONST, 0, newSViv(dp->limit)));
 607
 608                                 /* init = `,init if ,cond */
 609                                 init = newLOGOP(OP_AND, 0, cond, init);
 610
 611                                 /* gen = `,gen ; ,init */
 612                                 gen = op_append_list(OP_LINESEQ, gen, newSTATEOP(0, NULL, init));
 613
 614                                 dp->init = NULL;
 615                         }
 616
 617                         *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, gen);
 618                 }
 619
 620                 /* finally let perl parse the actual subroutine body */
 621                 body = parse_block(0);
 622
 623                 /* add '();' to make function return nothing by default */
 624                 /* (otherwise the invisible parameter initialization can "leak" into
 625                    the return value: fun ($x) {}->("asdf", 0) == 2) */
 626                 if (*prelude_sentinel) {
 627                         body = newSTATEOP(0, NULL, body);
 628                 }
 629
 630                 body = op_append_list(OP_LINESEQ, *prelude_sentinel, body);
 631                 *prelude_sentinel = NULL;
 632         }
 633
 634         /* it's go time. */
 635         {
 636                 OP *const attrs = *attrs_sentinel;
 637                 *attrs_sentinel = NULL;
 638                 SvREFCNT_inc_simple_void(PL_compcv);
 639
 640                 /* close outer block: '}' */
 641                 S_block_end(aTHX_ save_ix, body);
 642
 643                 if (!saw_name) {
 644                         *pop = newANONATTRSUB(
 645                                 floor_ix,
 646                                 proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL,
 647                                 attrs,
 648                                 body
 649                         );
 650                         return KEYWORD_PLUGIN_EXPR;
 651                 }
 652
 653                 newATTRSUB(
 654                         floor_ix,
 655                         newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(saw_name)),
 656                         proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL,
 657                         attrs,
 658                         body
 659                 );
 660                 *pop = NULL;
 661                 return KEYWORD_PLUGIN_STMT;
 662         }
 663 }
 664
 665 static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) {
 666         KWSpec spec;
 667         int ret;
 668
 669         SAVETMPS;
 670
 671         if (kw_flags(aTHX_ keyword_ptr, keyword_len, &spec)) {
 672                 ret = parse_fun(aTHX_ op_ptr, keyword_ptr, keyword_len, &spec);
 673         } else {
 674                 ret = next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
 675         }
 676
 677         FREETMPS;
 678
 679         return ret;
 680 }
 681
 682 WARNINGS_RESET
 683
 684 MODULE = Function::Parameters   PACKAGE = Function::Parameters
 685 PROTOTYPES: ENABLE
 686
 687 BOOT:
 688 WARNINGS_ENABLE {
 689         HV *const stash = gv_stashpvs(MY_PKG, GV_ADD);
 690         /**/
 691         newCONSTSUB(stash, "FLAG_NAME_OK", newSViv(FLAG_NAME_OK));
 692         newCONSTSUB(stash, "FLAG_ANON_OK", newSViv(FLAG_ANON_OK));
 693         newCONSTSUB(stash, "FLAG_DEFAULT_ARGS", newSViv(FLAG_DEFAULT_ARGS));
 694         newCONSTSUB(stash, "FLAG_CHECK_NARGS", newSViv(FLAG_CHECK_NARGS));
 695         newCONSTSUB(stash, "HINTK_KEYWORDS", newSVpvs(HINTK_KEYWORDS));
 696         newCONSTSUB(stash, "HINTK_FLAGS_", newSVpvs(HINTK_FLAGS_));
 697         newCONSTSUB(stash, "HINTK_SHIFT_", newSVpvs(HINTK_SHIFT_));
 698         newCONSTSUB(stash, "HINTK_ATTRS_", newSVpvs(HINTK_ATTRS_));
 699         /**/
 700         next_keyword_plugin = PL_keyword_plugin;
 701         PL_keyword_plugin = my_keyword_plugin;
 702 } WARNINGS_RESET