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