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