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         OP **prelude_sentinel;
 225         AV *params;
 226         DefaultParamSpec *defaults;
 227         int args_min, args_max;
 228         SV *proto;
 229         OP **attrs_sentinel, *body;
 230         unsigned builtin_attrs;
 231         STRLEN len;
 232         char *s;
 233         I32 c;
 234
 235         declarator = sv_2mortal(newSVpvn(keyword_ptr, keyword_len));
 236
 237         lex_read_space(0);
 238
 239         builtin_attrs = 0;
 240
 241         /* function name */
 242         saw_name = NULL;
 243         s = PL_parser->bufptr;
 244         if ((spec->flags & FLAG_NAME_OK) && (len = S_scan_word(aTHX_ s, TRUE))) {
 245                 saw_name = sv_2mortal(newSVpvn_flags(s, len, PARSING_UTF ? SVf_UTF8 : 0));
 246
 247                 if (PL_parser->expect != XSTATE) {
 248                         /* bail out early so we don't predeclare $saw_name */
 249                         croak("In %"SVf": I was expecting a function body, not \"%"SVf"\"", SVfARG(declarator), SVfARG(saw_name));
 250                 }
 251
 252                 sv_catpvs(declarator, " ");
 253                 sv_catsv(declarator, saw_name);
 254
 255                 if (
 256                         sv_eq_pvs(saw_name, "BEGIN") ||
 257                         sv_eq_pvs(saw_name, "END") ||
 258                         sv_eq_pvs(saw_name, "INIT") ||
 259                         sv_eq_pvs(saw_name, "CHECK") ||
 260                         sv_eq_pvs(saw_name, "UNITCHECK")
 261                 ) {
 262                         builtin_attrs |= MY_ATTR_SPECIAL;
 263                 }
 264
 265                 lex_read_to(s + len);
 266                 lex_read_space(0);
 267         } else if (!(spec->flags & FLAG_ANON_OK)) {
 268                 croak("I was expecting a function name, not \"%.*s\"", (int)(PL_parser->bufend - s), s);
 269         } else {
 270                 sv_catpvs(declarator, " (anon)");
 271         }
 272
 273         /* we're a subroutine declaration */
 274         floor_ix = start_subparse(FALSE, saw_name ? 0 : CVf_ANON);
 275         SAVEFREESV(PL_compcv);
 276
 277         /* create outer block: '{' */
 278         save_ix = S_block_start(aTHX_ TRUE);
 279
 280         /* initialize synthetic optree */
 281         Newx(prelude_sentinel, 1, OP *);
 282         *prelude_sentinel = NULL;
 283         SAVEDESTRUCTOR_X(free_ptr_op, prelude_sentinel);
 284
 285         /* parameters */
 286         params = NULL;
 287         defaults = NULL;
 288         args_min = 0;
 289         args_max = -1;
 290
 291         /* my $self; */
 292         if (SvTRUE(spec->shift)) {
 293                 OP *var;
 294
 295                 var = newOP(OP_PADSV, OPf_MOD | (OPpLVAL_INTRO << 8));
 296                 var->op_targ = pad_add_name_sv(spec->shift, 0, NULL, NULL);
 297
 298                 *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, var));
 299         }
 300
 301         c = lex_peek_unichar(0);
 302         if (c == '(') {
 303                 DefaultParamSpec **pdefaults_tail = &defaults;
 304                 SV *saw_slurpy = NULL;
 305                 int param_count = 0;
 306                 args_max = 0;
 307
 308                 lex_read_unichar(0);
 309                 lex_read_space(0);
 310
 311                 params = newAV();
 312                 sv_2mortal((SV *)params);
 313
 314                 for (;;) {
 315                         c = lex_peek_unichar(0);
 316                         if (c == '$' || c == '@' || c == '%') {
 317                                 const char sigil = c;
 318                                 SV *param;
 319
 320                                 param_count++;
 321
 322                                 lex_read_unichar(0);
 323                                 lex_read_space(0);
 324
 325                                 s = PL_parser->bufptr;
 326                                 if (!(len = S_scan_word(aTHX_ s, FALSE))) {
 327                                         croak("In %"SVf": missing identifier", SVfARG(declarator));
 328                                 }
 329                                 param = sv_2mortal(newSVpvf("%c%.*s", sigil, (int)len, s));
 330                                 if (saw_slurpy) {
 331                                         croak("In %"SVf": I was expecting \")\" after \"%"SVf"\", not \"%"SVf"\"", SVfARG(declarator), SVfARG(saw_slurpy), SVfARG(param));
 332                                 }
 333                                 if (sigil == '$') {
 334                                         args_max++;
 335                                 } else {
 336                                         args_max = -1;
 337                                         saw_slurpy = param;
 338                                 }
 339                                 av_push(params, SvREFCNT_inc_simple_NN(param));
 340                                 lex_read_to(s + len);
 341                                 lex_read_space(0);
 342
 343                                 c = lex_peek_unichar(0);
 344
 345                                 if (!(c == '=' && (spec->flags & FLAG_DEFAULT_ARGS))) {
 346                                         if (sigil == '$' && !defaults) {
 347                                                 args_min++;
 348                                         }
 349                                 } else if (sigil != '$') {
 350                                         croak("In %"SVf": %s %"SVf" can't have a default value", SVfARG(declarator), sigil == '@' ? "array" : "hash", SVfARG(saw_slurpy));
 351                                 } else {
 352                                         DefaultParamSpec *curdef;
 353
 354                                         lex_read_unichar(0);
 355                                         lex_read_space(0);
 356
 357                                         Newx(curdef, 1, DefaultParamSpec);
 358                                         curdef->next = NULL;
 359                                         curdef->limit = param_count;
 360                                         curdef->name = param;
 361                                         curdef->init = NULL;
 362                                         SAVEDESTRUCTOR_X(free_defspec, curdef);
 363
 364                                         curdef->next = *pdefaults_tail;
 365                                         *pdefaults_tail = curdef;
 366                                         pdefaults_tail = &curdef->next;
 367
 368                                         /* let perl parse the default parameter value */
 369                                         curdef->init = parse_termexpr(0);
 370
 371                                         lex_read_space(0);
 372                                         c = lex_peek_unichar(0);
 373                                 }
 374
 375                                 /* my $param; */
 376                                 {
 377                                         OP *var;
 378
 379                                         var = newOP(OP_PADSV, OPf_MOD | (OPpLVAL_INTRO << 8));
 380                                         var->op_targ = pad_add_name_sv(param, 0, NULL, NULL);
 381
 382                                         *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, var));
 383                                 }
 384
 385                                 if (c == ',') {
 386                                         lex_read_unichar(0);
 387                                         lex_read_space(0);
 388                                         continue;
 389                                 }
 390                         }
 391
 392                         if (c == ')') {
 393                                 lex_read_unichar(0);
 394                                 lex_read_space(0);
 395                                 break;
 396                         }
 397
 398                         if (c == -1) {
 399                                 croak("In %"SVf": unexpected EOF in parameter list", SVfARG(declarator));
 400                         }
 401                         croak("In %"SVf": unexpected '%c' in parameter list", SVfARG(declarator), (int)c);
 402                 }
 403         }
 404
 405         /* prototype */
 406         proto = NULL;
 407         c = lex_peek_unichar(0);
 408         if (c == ':') {
 409                 lex_read_unichar(0);
 410                 lex_read_space(0);
 411
 412                 c = lex_peek_unichar(0);
 413                 if (c != '(') {
 414                         lex_stuff_pvs(":", 0);
 415                         c = ':';
 416                 } else {
 417                         proto = sv_2mortal(newSVpvs(""));
 418                         if (!S_scan_str(aTHX_ proto, FALSE, FALSE)) {
 419                                 croak("In %"SVf": prototype not terminated", SVfARG(declarator));
 420                         }
 421                         S_check_prototype(aTHX_ declarator, proto);
 422                         lex_read_space(0);
 423                         c = lex_peek_unichar(0);
 424                 }
 425         }
 426
 427         /* attributes */
 428         Newx(attrs_sentinel, 1, OP *);
 429         *attrs_sentinel = NULL;
 430         SAVEDESTRUCTOR_X(free_ptr_op, attrs_sentinel);
 431
 432         if (c == ':' || c == '{') /* '}' - hi, vim */ {
 433
 434                 /* kludge default attributes in */
 435                 if (SvTRUE(spec->attrs) && SvPV_nolen(spec->attrs)[0] == ':') {
 436                         lex_stuff_sv(spec->attrs, 0);
 437                         c = ':';
 438                 }
 439
 440                 if (c == ':') {
 441                         lex_read_unichar(0);
 442                         lex_read_space(0);
 443                         c = lex_peek_unichar(0);
 444
 445                         for (;;) {
 446                                 SV *attr;
 447
 448                                 s = PL_parser->bufptr;
 449                                 if (!(len = S_scan_word(aTHX_ s, FALSE))) {
 450                                         break;
 451                                 }
 452
 453                                 attr = sv_2mortal(newSVpvn_flags(s, len, PARSING_UTF ? SVf_UTF8 : 0));
 454
 455                                 lex_read_to(s + len);
 456                                 lex_read_space(0);
 457                                 c = lex_peek_unichar(0);
 458
 459                                 if (c != '(') {
 460                                         if (sv_eq_pvs(attr, "lvalue")) {
 461                                                 builtin_attrs |= MY_ATTR_LVALUE;
 462                                                 attr = NULL;
 463                                         } else if (sv_eq_pvs(attr, "method")) {
 464                                                 builtin_attrs |= MY_ATTR_METHOD;
 465                                                 attr = NULL;
 466                                         }
 467                                 } else {
 468                                         SV *sv = sv_2mortal(newSVpvs(""));
 469                                         if (!S_scan_str(aTHX_ sv, TRUE, TRUE)) {
 470                                                 croak("In %"SVf": unterminated attribute parameter in attribute list", SVfARG(declarator));
 471                                         }
 472                                         sv_catsv(attr, sv);
 473
 474                                         lex_read_space(0);
 475                                         c = lex_peek_unichar(0);
 476                                 }
 477
 478                                 if (attr) {
 479                                         *attrs_sentinel = op_append_elem(OP_LIST, *attrs_sentinel, newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(attr)));
 480                                 }
 481
 482                                 if (c == ':') {
 483                                         lex_read_unichar(0);
 484                                         lex_read_space(0);
 485                                         c = lex_peek_unichar(0);
 486                                 }
 487                         }
 488                 }
 489         }
 490
 491         /* body */
 492         if (c != '{') /* '}' - hi, vim */ {
 493                 croak("In %"SVf": I was expecting a function body, not \"%c\"", SVfARG(declarator), (int)c);
 494         }
 495
 496         /* surprise predeclaration! */
 497         if (saw_name) {
 498                 /* 'sub NAME (PROTO);' to make name/proto known to perl before it
 499                    starts parsing the body */
 500                 const I32 sub_ix = start_subparse(FALSE, 0);
 501                 SAVEFREESV(PL_compcv);
 502
 503                 SvREFCNT_inc_simple_void(PL_compcv);
 504
 505                 newATTRSUB(
 506                         sub_ix,
 507                         newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(saw_name)),
 508                         proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL,
 509                         NULL,
 510                         NULL
 511                 );
 512         }
 513
 514         if (builtin_attrs & MY_ATTR_LVALUE) {
 515                 CvLVALUE_on(PL_compcv);
 516         }
 517         if (builtin_attrs & MY_ATTR_METHOD) {
 518                 CvMETHOD_on(PL_compcv);
 519         }
 520         if (builtin_attrs & MY_ATTR_SPECIAL) {
 521                 CvSPECIAL_on(PL_compcv);
 522         }
 523
 524         /* min/max argument count checks */
 525         if (spec->flags & FLAG_CHECK_NARGS) {
 526                 if (SvTRUE(spec->shift)) {
 527                         args_min++;
 528                         if (args_max != -1) {
 529                                 args_max++;
 530                         }
 531                 }
 532
 533                 if (args_min > 0) {
 534                         OP *chk, *cond, *err, *croak;
 535
 536                         err = newSVOP(OP_CONST, 0,
 537                                           newSVpvf("Not enough arguments for %"SVf, SVfARG(declarator)));
 538
 539                         croak = newCVREF(OPf_WANT_SCALAR,
 540                                              newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV)));
 541                         err = newUNOP(OP_ENTERSUB, OPf_STACKED,
 542                                           op_append_elem(OP_LIST, err, croak));
 543
 544                         cond = newBINOP(OP_LT, 0,
 545                                             newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
 546                                             newSVOP(OP_CONST, 0, newSViv(args_min)));
 547                         chk = newLOGOP(OP_AND, 0, cond, err);
 548
 549                         *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, chk));
 550                 }
 551                 if (args_max != -1) {
 552                         OP *chk, *cond, *err, *croak;
 553
 554                         err = newSVOP(OP_CONST, 0,
 555                                           newSVpvf("Too many arguments for %"SVf, SVfARG(declarator)));
 556
 557                         croak = newCVREF(OPf_WANT_SCALAR,
 558                                              newGVOP(OP_GV, 0, gv_fetchpvs("Carp::croak", 0, SVt_PVCV)));
 559                         err = newUNOP(OP_ENTERSUB, OPf_STACKED,
 560                                           op_append_elem(OP_LIST, err, croak));
 561
 562                         cond = newBINOP(OP_GT, 0,
 563                                             newAVREF(newGVOP(OP_GV, 0, PL_defgv)),
 564                                             newSVOP(OP_CONST, 0, newSViv(args_max)));
 565                         chk = newLOGOP(OP_AND, 0, cond, err);
 566
 567                         *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, chk));
 568                 }
 569         }
 570
 571         /* $self = shift; */
 572         if (SvTRUE(spec->shift)) {
 573                 OP *var, *shift;
 574
 575                 var = newOP(OP_PADSV, OPf_WANT_SCALAR);
 576                 var->op_targ = pad_findmy_sv(spec->shift, 0);
 577
 578                 shift = newASSIGNOP(OPf_STACKED, var, 0, newOP(OP_SHIFT, 0));
 579                 *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, newSTATEOP(0, NULL, shift));
 580         }
 581
 582         /* (PARAMS) = @_; */
 583         if (params && av_len(params) > -1) {
 584                 SV *param;
 585                 OP *init_param, *left, *right;
 586
 587                 left = NULL;
 588                 while ((param = av_shift(params)) != &PL_sv_undef) {
 589                         OP *const var = newOP(OP_PADSV, OPf_WANT_LIST);
 590                         var->op_targ = pad_findmy_sv(param, 0);
 591                         SvREFCNT_dec(param);
 592                         left = op_append_elem(OP_LIST, left, var);
 593                 }
 594
 595                 left->op_flags |= OPf_PARENS;
 596                 right = newAVREF(newGVOP(OP_GV, 0, PL_defgv));
 597                 init_param = newASSIGNOP(OPf_STACKED, left, 0, right);
 598                 init_param = newSTATEOP(0, NULL, init_param);
 599
 600                 *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, init_param);
 601         }
 602
 603         /* defaults */
 604         {
 605                 OP *gen = NULL;
 606                 DefaultParamSpec *dp;
 607
 608                 for (dp = defaults; dp; dp = dp->next) {
 609                         OP *init = dp->init;
 610                         OP *var, *args, *cond;
 611
 612                         /* var = `$,name */
 613                         var = newOP(OP_PADSV, 0);
 614                         var->op_targ = pad_findmy_sv(dp->name, 0);
 615
 616                         /* init = `,var = ,init */
 617                         init = newASSIGNOP(OPf_STACKED, var, 0, init);
 618
 619                         /* args = `@_ */
 620                         args = newAVREF(newGVOP(OP_GV, 0, PL_defgv));
 621
 622                         /* cond = `,args < ,index */
 623                         cond = newBINOP(OP_LT, 0, args, newSVOP(OP_CONST, 0, newSViv(dp->limit)));
 624
 625                         /* init = `,init if ,cond */
 626                         init = newLOGOP(OP_AND, 0, cond, init);
 627
 628                         /* gen = `,gen ; ,init */
 629                         gen = op_append_list(OP_LINESEQ, gen, newSTATEOP(0, NULL, init));
 630
 631                         dp->init = NULL;
 632                 }
 633
 634                 *prelude_sentinel = op_append_list(OP_LINESEQ, *prelude_sentinel, gen);
 635         }
 636
 637         /* finally let perl parse the actual subroutine body */
 638         body = parse_block(0);
 639
 640         /* add '();' to make function return nothing by default */
 641         /* (otherwise the invisible parameter initialization can "leak" into
 642            the return value: fun ($x) {}->("asdf", 0) == 2) */
 643         if (*prelude_sentinel) {
 644                 body = newSTATEOP(0, NULL, body);
 645         }
 646
 647         body = op_append_list(OP_LINESEQ, *prelude_sentinel, body);
 648         *prelude_sentinel = NULL;
 649
 650         /* it's go time. */
 651         {
 652                 OP *const attrs = *attrs_sentinel;
 653                 *attrs_sentinel = NULL;
 654                 SvREFCNT_inc_simple_void(PL_compcv);
 655
 656                 /* close outer block: '}' */
 657                 S_block_end(aTHX_ save_ix, body);
 658
 659                 if (!saw_name) {
 660                         *pop = newANONATTRSUB(
 661                                 floor_ix,
 662                                 proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL,
 663                                 attrs,
 664                                 body
 665                         );
 666                         return KEYWORD_PLUGIN_EXPR;
 667                 }
 668
 669                 newATTRSUB(
 670                         floor_ix,
 671                         newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(saw_name)),
 672                         proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL,
 673                         attrs,
 674                         body
 675                 );
 676                 *pop = NULL;
 677                 return KEYWORD_PLUGIN_STMT;
 678         }
 679 }
 680
 681 static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) {
 682         KWSpec spec;
 683         int ret;
 684
 685         SAVETMPS;
 686
 687         if (kw_flags(aTHX_ keyword_ptr, keyword_len, &spec)) {
 688                 ret = parse_fun(aTHX_ op_ptr, keyword_ptr, keyword_len, &spec);
 689         } else {
 690                 ret = next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
 691         }
 692
 693         FREETMPS;
 694
 695         return ret;
 696 }
 697
 698 WARNINGS_RESET
 699
 700 MODULE = Function::Parameters   PACKAGE = Function::Parameters
 701 PROTOTYPES: ENABLE
 702
 703 BOOT:
 704 WARNINGS_ENABLE {
 705         HV *const stash = gv_stashpvs(MY_PKG, GV_ADD);
 706         /**/
 707         newCONSTSUB(stash, "FLAG_NAME_OK", newSViv(FLAG_NAME_OK));
 708         newCONSTSUB(stash, "FLAG_ANON_OK", newSViv(FLAG_ANON_OK));
 709         newCONSTSUB(stash, "FLAG_DEFAULT_ARGS", newSViv(FLAG_DEFAULT_ARGS));
 710         newCONSTSUB(stash, "FLAG_CHECK_NARGS", newSViv(FLAG_CHECK_NARGS));
 711         newCONSTSUB(stash, "HINTK_KEYWORDS", newSVpvs(HINTK_KEYWORDS));
 712         newCONSTSUB(stash, "HINTK_FLAGS_", newSVpvs(HINTK_FLAGS_));
 713         newCONSTSUB(stash, "HINTK_SHIFT_", newSVpvs(HINTK_SHIFT_));
 714         newCONSTSUB(stash, "HINTK_ATTRS_", newSVpvs(HINTK_ATTRS_));
 715         /**/
 716         next_keyword_plugin = PL_keyword_plugin;
 717         PL_keyword_plugin = my_keyword_plugin;
 718 } WARNINGS_RESET