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 WARNINGS_ENABLE
  53
  54 #define MY_PKG "Function::Parameters"
  55
  56 #define HINTK_KEYWORDS MY_PKG "/keywords"
  57 #define HINTK_NAME_    MY_PKG "/name:"
  58 #define HINTK_SHIFT_   MY_PKG "/shift:"
  59 #define HINTK_ATTRS_   MY_PKG "/attrs:"
  60
  61 #define HAVE_PERL_VERSION(R, V, S) \
  62         (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
  63
  64 #if HAVE_PERL_VERSION(5, 16, 0)
  65  #define IF_HAVE_PERL_5_16(YES, NO) YES
  66 #else
  67  #define IF_HAVE_PERL_5_16(YES, NO) NO
  68 #endif
  69
  70 typedef struct {
  71         enum {
  72                 FLAG_NAME_OPTIONAL = 1,
  73                 FLAG_NAME_REQUIRED,
  74                 FLAG_NAME_PROHIBITED
  75         } name;
  76         SV *shift;
  77         SV *attrs;
  78 } Spec;
  79
  80 static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
  81
  82 static int kw_flags(pTHX_ const char *kw_ptr, STRLEN kw_len, Spec *spec) {
  83         HV *hints;
  84         SV *sv, **psv;
  85         const char *p, *kw_active;
  86         STRLEN kw_active_len;
  87
  88         spec->name = 0;
  89         spec->shift = sv_2mortal(newSVpvs(""));
  90         spec->attrs = sv_2mortal(newSVpvs(""));
  91
  92         if (!(hints = GvHV(PL_hintgv))) {
  93                 return FALSE;
  94         }
  95         if (!(psv = hv_fetchs(hints, HINTK_KEYWORDS, 0))) {
  96                 return FALSE;
  97         }
  98         sv = *psv;
  99         kw_active = SvPV(sv, kw_active_len);
 100         if (kw_active_len <= kw_len) {
 101                 return FALSE;
 102         }
 103         for (
 104                 p = kw_active;
 105                 (p = strchr(p, *kw_ptr)) &&
 106                 p < kw_active + kw_active_len - kw_len;
 107                 p++
 108         ) {
 109                 if (
 110                         (p == kw_active || p[-1] == ' ') &&
 111                         p[kw_len] == ' ' &&
 112                         memcmp(kw_ptr, p, kw_len) == 0
 113                 ) {
 114
 115 #define FETCH_HINTK_INTO(NAME, PTR, LEN, X) STMT_START { \
 116         const char *fk_ptr_; \
 117         STRLEN fk_len_; \
 118         SV *fk_sv_; \
 119         fk_sv_ = sv_2mortal(newSVpvs(HINTK_ ## NAME)); \
 120         sv_catpvn(fk_sv_, PTR, LEN); \
 121         fk_ptr_ = SvPV(fk_sv_, fk_len_); \
 122         if (!((X) = hv_fetch(hints, fk_ptr_, fk_len_, 0))) { \
 123                 croak("%s: internal error: $^H{'%.*s'} not set", MY_PKG, (int)fk_len_, fk_ptr_); \
 124         } \
 125 } STMT_END
 126
 127                         FETCH_HINTK_INTO(NAME_, kw_ptr, kw_len, psv);
 128                         spec->name = SvIV(*psv);
 129
 130                         FETCH_HINTK_INTO(SHIFT_, kw_ptr, kw_len, psv);
 131                         SvSetSV(spec->shift, *psv);
 132
 133                         FETCH_HINTK_INTO(ATTRS_, kw_ptr, kw_len, psv);
 134                         SvSetSV(spec->attrs, *psv);
 135
 136 #undef FETCH_HINTK_INTO
 137                         return TRUE;
 138                 }
 139         }
 140         return FALSE;
 141 }
 142
 143
 144 #include "toke_on_crack.c.inc"
 145
 146
 147 static void free_ptr_op(pTHX_ void *vp) {
 148         OP **pp = vp;
 149         op_free(*pp);
 150         Safefree(pp);
 151 }
 152
 153 #define sv_eq_pvs(SV, S) sv_eq_pvn(aTHX_ SV, "" S "", sizeof (S) - 1)
 154
 155 static int sv_eq_pvn(pTHX_ SV *sv, const char *p, STRLEN n) {
 156         STRLEN sv_len;
 157         const char *sv_p = SvPV(sv, sv_len);
 158         return
 159                 sv_len == n &&
 160                 memcmp(sv_p, p, n) == 0
 161         ;
 162 }
 163
 164
 165 #include "padop_on_crack.c.inc"
 166
 167
 168 #if 0
 169 static PADOFFSET pad_add_my_sv(SV *name) {
 170         PADOFFSET offset;
 171         SV *namesv, *myvar;
 172         char *p;
 173         STRLEN len;
 174
 175         p = SvPV(name, len);
 176         myvar = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, 1);
 177         offset = AvFILLp(PL_comppad);
 178         SvPADMY_on(myvar);
 179         if (*p == '@') {
 180                 SvUPGRADE(myvar, SVt_PVAV);
 181         } else if (*p == '%') {
 182                 SvUPGRADE(myvar, SVt_PVHV);
 183         }
 184         PL_curpad = AvARRAY(PL_comppad);
 185         namesv = newSV_type(SVt_PVMG);
 186         sv_setpvn(namesv, p, len);
 187         COP_SEQ_RANGE_LOW_set(namesv, PL_cop_seqmax);
 188         COP_SEQ_RANGE_HIGH_set(namesv, PERL_PADSEQ_INTRO);
 189         PL_cop_seqmax++;
 190         av_store(PL_comppad_name, offset, namesv);
 191         return offset;
 192 }
 193 #endif
 194
 195 enum {
 196         MY_ATTR_LVALUE = 0x01,
 197         MY_ATTR_METHOD = 0x02,
 198         MY_ATTR_SPECIAL = 0x04
 199 };
 200
 201 static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len, const Spec *spec) {
 202         SV *declarator;
 203         I32 floor_ix;
 204         SV *saw_name;
 205         AV *params;
 206         SV *proto;
 207         OP **attrs_sentinel, *body;
 208         unsigned builtin_attrs;
 209         int saw_colon;
 210         STRLEN len;
 211         char *s;
 212         I32 c;
 213
 214         declarator = sv_2mortal(newSVpvn(keyword_ptr, keyword_len));
 215
 216         lex_read_space(0);
 217
 218         builtin_attrs = 0;
 219
 220         /* function name */
 221         saw_name = NULL;
 222         s = PL_parser->bufptr;
 223         if (spec->name != FLAG_NAME_PROHIBITED && (len = S_scan_word(aTHX_ s, TRUE))) {
 224                 saw_name = sv_2mortal(newSVpvn_flags(s, len, PARSING_UTF ? SVf_UTF8 : 0));
 225
 226                 if (PL_parser->expect != XSTATE) {
 227                         /* bail out early so we don't predeclare $saw_name */
 228                         croak("In %"SVf": I was expecting a function body, not \"%"SVf"\"", SVfARG(declarator), SVfARG(saw_name));
 229                 }
 230
 231                 sv_catpvs(declarator, " ");
 232                 sv_catsv(declarator, saw_name);
 233
 234                 if (
 235                         sv_eq_pvs(saw_name, "BEGIN") ||
 236                         sv_eq_pvs(saw_name, "END") ||
 237                         sv_eq_pvs(saw_name, "INIT") ||
 238                         sv_eq_pvs(saw_name, "CHECK") ||
 239                         sv_eq_pvs(saw_name, "UNITCHECK")
 240                 ) {
 241                         builtin_attrs |= MY_ATTR_SPECIAL;
 242                 }
 243
 244                 lex_read_to(s + len);
 245                 lex_read_space(0);
 246         } else if (spec->name == FLAG_NAME_REQUIRED) {
 247                 croak("I was expecting a function name, not \"%.*s\"", (int)(PL_parser->bufend - s), s);
 248         } else {
 249                 sv_catpvs(declarator, " (anon)");
 250         }
 251
 252         floor_ix = start_subparse(FALSE, saw_name ? 0 : CVf_ANON);
 253         SAVEFREESV(PL_compcv);
 254
 255         /* parameters */
 256         params = NULL;
 257         c = lex_peek_unichar(0);
 258         if (c == '(') {
 259                 SV *saw_slurpy = NULL;
 260
 261                 lex_read_unichar(0);
 262                 lex_read_space(0);
 263
 264                 params = newAV();
 265                 sv_2mortal((SV *)params);
 266
 267                 for (;;) {
 268                         c = lex_peek_unichar(0);
 269                         if (c == '$' || c == '@' || c == '%') {
 270                                 SV *param;
 271
 272                                 lex_read_unichar(0);
 273                                 lex_read_space(0);
 274
 275                                 s = PL_parser->bufptr;
 276                                 if (!(len = S_scan_word(aTHX_ s, FALSE))) {
 277                                         croak("In %"SVf": missing identifier", SVfARG(declarator));
 278                                 }
 279                                 param = sv_2mortal(newSVpvf("%c%.*s", (int)c, (int)len, s));
 280                                 if (saw_slurpy) {
 281                                         croak("In %"SVf": I was expecting \")\" after \"%"SVf"\", not \"%"SVf"\"", SVfARG(declarator), SVfARG(saw_slurpy), SVfARG(param));
 282                                 }
 283                                 if (c != '$') {
 284                                         saw_slurpy = param;
 285                                 }
 286                                 av_push(params, SvREFCNT_inc_simple_NN(param));
 287                                 lex_read_to(s + len);
 288                                 lex_read_space(0);
 289
 290                                 c = lex_peek_unichar(0);
 291                                 if (c == ',') {
 292                                         lex_read_unichar(0);
 293                                         lex_read_space(0);
 294                                         continue;
 295                                 }
 296                         }
 297
 298                         if (c == ')') {
 299                                 lex_read_unichar(0);
 300                                 lex_read_space(0);
 301                                 break;
 302                         }
 303
 304                         if (c == -1) {
 305                                 croak("In %"SVf": unexpected EOF in parameter list", SVfARG(declarator));
 306                         }
 307                         croak("In %"SVf": unexpected '%c' in parameter list", SVfARG(declarator), (int)c);
 308                 }
 309         }
 310
 311         /* prototype */
 312         proto = NULL;
 313         saw_colon = 0;
 314         c = lex_peek_unichar(0);
 315         if (c == ':') {
 316                 lex_read_unichar(0);
 317                 lex_read_space(0);
 318
 319                 c = lex_peek_unichar(0);
 320                 if (c != '(') {
 321                         lex_stuff_pvs(":", 0);
 322                         c = ':';
 323                 } else {
 324                         proto = sv_2mortal(newSVpvs(""));
 325                         if (!S_scan_str(aTHX_ proto, FALSE, FALSE)) {
 326                                 croak("In %"SVf": prototype not terminated", SVfARG(declarator));
 327                         }
 328                         S_check_prototype(aTHX_ declarator, proto);
 329                         lex_read_space(0);
 330                         c = lex_peek_unichar(0);
 331                 }
 332         }
 333
 334         /* surprise predeclaration! */
 335         if (saw_name) {
 336                 /* 'sub NAME (PROTO);' to make name/proto known to perl before it
 337                    starts parsing the body */
 338                 SvREFCNT_inc_simple_void(PL_compcv);
 339
 340                 newATTRSUB(
 341                         floor_ix,
 342                         newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(saw_name)),
 343                         proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL,
 344                         NULL,
 345                         NULL
 346                 );
 347
 348                 floor_ix = start_subparse(FALSE, 0);
 349                 SAVEFREESV(PL_compcv);
 350         }
 351
 352
 353         /* attributes */
 354         Newx(attrs_sentinel, 1, OP *);
 355         *attrs_sentinel = NULL;
 356         SAVEDESTRUCTOR_X(free_ptr_op, attrs_sentinel);
 357
 358         if (c == ':' || c == '{') {
 359
 360                 /* kludge default attributes in */
 361                 if (SvTRUE(spec->attrs) && SvPV_nolen(spec->attrs)[0] == ':') {
 362                         lex_stuff_sv(spec->attrs, 0);
 363                         c = ':';
 364                 }
 365
 366                 if (c == ':') {
 367                         lex_read_unichar(0);
 368                         lex_read_space(0);
 369                         c = lex_peek_unichar(0);
 370
 371                         for (;;) {
 372                                 SV *attr;
 373
 374                                 s = PL_parser->bufptr;
 375                                 if (!(len = S_scan_word(aTHX_ s, FALSE))) {
 376                                         break;
 377                                 }
 378
 379                                 attr = sv_2mortal(newSVpvn_flags(s, len, PARSING_UTF ? SVf_UTF8 : 0));
 380
 381                                 lex_read_to(s + len);
 382                                 lex_read_space(0);
 383                                 c = lex_peek_unichar(0);
 384
 385                                 if (c != '(') {
 386                                         if (sv_eq_pvs(attr, "lvalue")) {
 387                                                 builtin_attrs |= MY_ATTR_LVALUE;
 388                                                 attr = NULL;
 389                                         } else if (sv_eq_pvs(attr, "method")) {
 390                                                 builtin_attrs |= MY_ATTR_METHOD;
 391                                                 attr = NULL;
 392                                         }
 393                                 } else {
 394                                         SV *sv = sv_2mortal(newSVpvs(""));
 395                                         if (!S_scan_str(aTHX_ sv, TRUE, TRUE)) {
 396                                                 croak("In %"SVf": unterminated attribute parameter in attribute list", SVfARG(declarator));
 397                                         }
 398                                         sv_catsv(attr, sv);
 399
 400                                         lex_read_space(0);
 401                                         c = lex_peek_unichar(0);
 402                                 }
 403
 404                                 if (attr) {
 405                                         *attrs_sentinel = op_append_elem(OP_LIST, *attrs_sentinel, newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(attr)));
 406                                 }
 407
 408                                 if (c == ':') {
 409                                         lex_read_unichar(0);
 410                                         lex_read_space(0);
 411                                         c = lex_peek_unichar(0);
 412                                 }
 413                         }
 414                 }
 415         }
 416
 417         /* body */
 418         if (c != '{') {
 419                 croak("In %"SVf": I was expecting a function body, not \"%c\"", SVfARG(declarator), (int)c);
 420         }
 421
 422         if (builtin_attrs & MY_ATTR_LVALUE) {
 423                 CvLVALUE_on(PL_compcv);
 424         }
 425         if (builtin_attrs & MY_ATTR_METHOD) {
 426                 CvMETHOD_on(PL_compcv);
 427         }
 428         if (builtin_attrs & MY_ATTR_SPECIAL) {
 429                 CvSPECIAL_on(PL_compcv);
 430         }
 431
 432         /* munge */
 433         {
 434                 /* create outer block: '{' */
 435                 const int save_ix = S_block_start(aTHX_ TRUE);
 436                 OP *init = NULL;
 437
 438                 /* my $self = shift; */
 439                 if (SvTRUE(spec->shift)) {
 440                         OP *const var = newOP(OP_PADSV, OPf_WANT_SCALAR | (OPpLVAL_INTRO << 8));
 441                         var->op_targ = pad_add_name_sv(spec->shift, 0, NULL, NULL);
 442
 443                         init = newASSIGNOP(OPf_STACKED, var, 0, newOP(OP_SHIFT, 0));
 444                         init = newSTATEOP(0, NULL, init);
 445                 }
 446
 447                 /* my (PARAMS) = @_; */
 448                 if (params && av_len(params) > -1) {
 449                         SV *param;
 450                         OP *init_param, *left, *right;
 451
 452                         left = NULL;
 453                         while ((param = av_shift(params)) != &PL_sv_undef) {
 454                                 OP *const var = newOP(OP_PADSV, OPf_WANT_LIST | (OPpLVAL_INTRO << 8));
 455                                 var->op_targ = pad_add_name_sv(param, 0, NULL, NULL);
 456                                 SvREFCNT_dec(param);
 457                                 left = op_append_elem(OP_LIST, left, var);
 458                         }
 459
 460                         left->op_flags |= OPf_PARENS;
 461                         right = newAVREF(newGVOP(OP_GV, 0, PL_defgv));
 462                         init_param = newASSIGNOP(OPf_STACKED, left, 0, right);
 463                         init_param = newSTATEOP(0, NULL, init_param);
 464
 465                         init = op_append_list(OP_LINESEQ, init, init_param);
 466                 }
 467
 468                 /* add '();' to make function return nothing by default */
 469                 /* (otherwise the invisible parameter initialization can "leak" into
 470                    the return value: fun ($x) {}->("asdf", 0) == 2) */
 471                 if (init) {
 472                         init = op_append_list(OP_LINESEQ, init, newSTATEOP(0, NULL, newOP(OP_STUB, OPf_PARENS)));
 473                 }
 474
 475                 /* finally let perl parse the actual subroutine body */
 476                 body = parse_block(0);
 477
 478                 body = op_append_list(OP_LINESEQ, init, body);
 479
 480                 /* close outer block: '}' */
 481                 S_block_end(aTHX_ save_ix, body);
 482         }
 483
 484         /* it's go time. */
 485         {
 486                 OP *const attrs = *attrs_sentinel;
 487                 *attrs_sentinel = NULL;
 488                 SvREFCNT_inc_simple_void(PL_compcv);
 489
 490                 if (!saw_name) {
 491                         *pop = newANONATTRSUB(
 492                                 floor_ix,
 493                                 proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL,
 494                                 attrs,
 495                                 body
 496                         );
 497                         return KEYWORD_PLUGIN_EXPR;
 498                 }
 499
 500                 newATTRSUB(
 501                         floor_ix,
 502                         newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(saw_name)),
 503                         proto ? newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(proto)) : NULL,
 504                         attrs,
 505                         body
 506                 );
 507                 *pop = NULL;
 508                 return KEYWORD_PLUGIN_STMT;
 509         }
 510 }
 511
 512 static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) {
 513         Spec spec;
 514         int ret;
 515
 516         SAVETMPS;
 517
 518         if (kw_flags(aTHX_ keyword_ptr, keyword_len, &spec)) {
 519                 ret = parse_fun(aTHX_ op_ptr, keyword_ptr, keyword_len, &spec);
 520         } else {
 521                 ret = next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
 522         }
 523
 524         FREETMPS;
 525
 526         return ret;
 527 }
 528
 529 WARNINGS_RESET
 530
 531 MODULE = Function::Parameters   PACKAGE = Function::Parameters
 532 PROTOTYPES: ENABLE
 533
 534 BOOT:
 535 WARNINGS_ENABLE {
 536         HV *const stash = gv_stashpvs(MY_PKG, GV_ADD);
 537         /**/
 538         newCONSTSUB(stash, "FLAG_NAME_OPTIONAL", newSViv(FLAG_NAME_OPTIONAL));
 539         newCONSTSUB(stash, "FLAG_NAME_REQUIRED", newSViv(FLAG_NAME_REQUIRED));
 540         newCONSTSUB(stash, "FLAG_NAME_PROHIBITED", newSViv(FLAG_NAME_PROHIBITED));
 541         newCONSTSUB(stash, "HINTK_KEYWORDS", newSVpvs(HINTK_KEYWORDS));
 542         newCONSTSUB(stash, "HINTK_NAME_", newSVpvs(HINTK_NAME_));
 543         newCONSTSUB(stash, "HINTK_SHIFT_", newSVpvs(HINTK_SHIFT_));
 544         newCONSTSUB(stash, "HINTK_ATTRS_", newSVpvs(HINTK_ATTRS_));
 545         /**/
 546         next_keyword_plugin = PL_keyword_plugin;
 547         PL_keyword_plugin = my_keyword_plugin;
 548 } WARNINGS_RESET