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) do { \
 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 } while (0)
 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 int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len, const Spec *spec) {
 148         SV *gen, *declarator, *params, *sv;
 149         int saw_name, saw_colon;
 150         STRLEN len;
 151         char *s;
 152         I32 c;
 153
 154         gen = sv_2mortal(newSVpvs("sub"));
 155         declarator = sv_2mortal(newSVpvn(keyword_ptr, keyword_len));
 156         params = sv_2mortal(newSVpvs(""));
 157
 158         lex_read_space(0);
 159
 160         /* function name */
 161         saw_name = 0;
 162         s = PL_parser->bufptr;
 163         if (spec->name != FLAG_NAME_PROHIBITED && (len = S_scan_word(aTHX_ s, TRUE))) {
 164                 sv_catpvs(gen, " ");
 165                 sv_catpvn(gen, s, len);
 166                 sv_catpvs(declarator, " ");
 167                 sv_catpvn(declarator, s, len);
 168                 lex_read_to(s + len);
 169                 lex_read_space(0);
 170                 saw_name = 1;
 171         } else if (spec->name == FLAG_NAME_REQUIRED) {
 172                 croak("I was expecting a function name, not \"%.*s\"", (int)(PL_parser->bufend - s), s);
 173         } else {
 174                 sv_catpvs(declarator, " (anon)");
 175         }
 176
 177         /* parameters */
 178         c = lex_peek_unichar(0);
 179         if (c == '(') {
 180                 SV *saw_slurpy = NULL;
 181
 182                 lex_read_unichar(0);
 183                 lex_read_space(0);
 184
 185                 for (;;) {
 186                         c = lex_peek_unichar(0);
 187                         if (c == '$' || c == '@' || c == '%') {
 188                                 sv_catpvf(params, "%c", (int)c);
 189                                 lex_read_unichar(0);
 190                                 lex_read_space(0);
 191
 192                                 s = PL_parser->bufptr;
 193                                 if (!(len = S_scan_word(aTHX_ s, FALSE))) {
 194                                         croak("In %"SVf": missing identifier", SVfARG(declarator));
 195                                 }
 196                                 if (saw_slurpy) {
 197                                         croak("In %"SVf": I was expecting \")\" after \"%"SVf"\", not \"%c%.*s\"", SVfARG(declarator), SVfARG(saw_slurpy), (int)c, (int)len, s);
 198                                 }
 199                                 if (c != '$') {
 200                                         saw_slurpy = sv_2mortal(newSVpvf("%c%.*s", (int)c, (int)len, s));
 201                                 }
 202                                 sv_catpvn(params, s, len);
 203                                 sv_catpvs(params, ",");
 204                                 lex_read_to(s + len);
 205                                 lex_read_space(0);
 206
 207                                 c = lex_peek_unichar(0);
 208                                 if (c == ',') {
 209                                         lex_read_unichar(0);
 210                                         lex_read_space(0);
 211                                         continue;
 212                                 }
 213                         }
 214
 215                         if (c == ')') {
 216                                 lex_read_unichar(0);
 217                                 lex_read_space(0);
 218                                 break;
 219                         }
 220
 221                         if (c == -1) {
 222                                 croak("In %"SVf": unexpected EOF in parameter list", SVfARG(declarator));
 223                         }
 224                         croak("In %"SVf": unexpected '%c' in parameter list", SVfARG(declarator), (int)c);
 225                 }
 226         }
 227
 228         /* prototype */
 229         saw_colon = 0;
 230         c = lex_peek_unichar(0);
 231         if (c == ':') {
 232                 lex_read_unichar(0);
 233                 lex_read_space(0);
 234
 235                 c = lex_peek_unichar(0);
 236                 if (c != '(') {
 237                         saw_colon = 1;
 238                 } else {
 239                         sv = sv_2mortal(newSVpvs(""));
 240                         if (!S_scan_str(aTHX_ sv, TRUE, TRUE)) {
 241                                 croak("In %"SVf": prototype not terminated", SVfARG(declarator));
 242                         }
 243                         sv_catsv(gen, sv);
 244                         lex_read_space(0);
 245                 }
 246         }
 247
 248         if (saw_name) {
 249                 len = SvCUR(gen);
 250                 s = SvGROW(gen, (len + 1) * 2);
 251                 sv_catpvs(gen, ";");
 252                 sv_catpvn(gen, s, len);
 253         }
 254
 255         /* attributes */
 256         if (SvTRUE(spec->attrs)) {
 257                 sv_catsv(gen, spec->attrs);
 258         }
 259
 260         if (!saw_colon) {
 261                 c = lex_peek_unichar(0);
 262                 if (c == ':') {
 263                         saw_colon = 1;
 264                         lex_read_unichar(0);
 265                         lex_read_space(0);
 266                 }
 267         }
 268         if (saw_colon) {
 269                 for (;;) {
 270                         s = PL_parser->bufptr;
 271                         if (!(len = S_scan_word(aTHX_ s, FALSE))) {
 272                                 break;
 273                         }
 274                         sv_catpvs(gen, ":");
 275                         sv_catpvn(gen, s, len);
 276                         lex_read_to(s + len);
 277                         lex_read_space(0);
 278                         c = lex_peek_unichar(0);
 279                         if (c == '(') {
 280                                 sv = sv_2mortal(newSVpvs(""));
 281                                 if (!S_scan_str(aTHX_ sv, TRUE, TRUE)) {
 282                                         croak("In %"SVf": unterminated attribute parameter in attribute list", SVfARG(declarator));
 283                                 }
 284                                 sv_catsv(gen, sv);
 285                                 lex_read_space(0);
 286                                 c = lex_peek_unichar(0);
 287                         }
 288                         if (c == ':') {
 289                                 lex_read_unichar(0);
 290                                 lex_read_space(0);
 291                         }
 292                 }
 293         }
 294
 295         /* body */
 296         c = lex_peek_unichar(0);
 297         if (c != '{') {
 298                 croak("In %"SVf": I was expecting a function body, not \"%c\"", SVfARG(declarator), (int)c);
 299         }
 300         lex_read_unichar(0);
 301         sv_catpvs(gen, "{");
 302         if (SvTRUE(spec->shift)) {
 303                 sv_catpvs(gen, "my");
 304                 sv_catsv(gen, spec->shift);
 305                 sv_catpvs(gen, "=shift;");
 306         }
 307         if (SvCUR(params)) {
 308                 sv_catpvs(gen, "my(");
 309                 sv_catsv(gen, params);
 310                 sv_catpvs(gen, ")=@_;");
 311         }
 312
 313         /* named sub */
 314         if (saw_name) {
 315                 /* fprintf(stderr, "! [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */
 316                 lex_stuff_sv(gen, SvUTF8(gen));
 317                 *pop = parse_barestmt(0);
 318                 return KEYWORD_PLUGIN_STMT;
 319         }
 320
 321         /* anon sub */
 322         sv_catpvs(gen, "BEGIN{" MY_PKG "::_fini}");
 323         /* fprintf(stderr, "!> [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */
 324         lex_stuff_sv(gen, SvUTF8(gen));
 325         *pop = parse_arithexpr(0);
 326         s = PL_parser->bufptr;
 327         if (*s != '}') {
 328                 croak("%s: internal error: expected '}', found '%c'", MY_PKG, *s);
 329         }
 330         lex_unstuff(s + 1);
 331         /* fprintf(stderr, "!< [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */
 332         return KEYWORD_PLUGIN_EXPR;
 333 }
 334
 335 static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) {
 336         Spec spec;
 337         int ret;
 338
 339         SAVETMPS;
 340
 341         if (kw_flags(aTHX_ keyword_ptr, keyword_len, &spec)) {
 342                 ret = parse_fun(aTHX_ op_ptr, keyword_ptr, keyword_len, &spec);
 343         } else {
 344                 ret = next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
 345         }
 346
 347         FREETMPS;
 348
 349         return ret;
 350 }
 351
 352 static int magic_free(pTHX_ SV *sv, MAGIC *mg) {
 353         lex_stuff_pvn("}", 1, 0);
 354         /* fprintf(stderr, "!~ [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */
 355         return 0;
 356 }
 357
 358 static int magic_nop(pTHX_ SV *sv, MAGIC *mg) {
 359         return 0;
 360 }
 361
 362 static MGVTBL my_vtbl = {
 363         0,           /* get   */
 364         0,           /* set   */
 365         0,           /* len   */
 366         0,           /* clear */
 367         magic_free,  /* free  */
 368         0,           /* copy  */
 369         0,           /* dup   */
 370         magic_nop    /* local */
 371 };
 372
 373 WARNINGS_RESET
 374
 375 MODULE = Function::Parameters   PACKAGE = Function::Parameters
 376 PROTOTYPES: ENABLE
 377
 378 BOOT:
 379 WARNINGS_ENABLE {
 380         HV *const stash = gv_stashpvs(MY_PKG, GV_ADD);
 381         /**/
 382         newCONSTSUB(stash, "FLAG_NAME_OPTIONAL", newSViv(FLAG_NAME_OPTIONAL));
 383         newCONSTSUB(stash, "FLAG_NAME_REQUIRED", newSViv(FLAG_NAME_REQUIRED));
 384         newCONSTSUB(stash, "FLAG_NAME_PROHIBITED", newSViv(FLAG_NAME_PROHIBITED));
 385         newCONSTSUB(stash, "HINTK_KEYWORDS", newSVpvs(HINTK_KEYWORDS));
 386         newCONSTSUB(stash, "HINTK_NAME_", newSVpvs(HINTK_NAME_));
 387         newCONSTSUB(stash, "HINTK_SHIFT_", newSVpvs(HINTK_SHIFT_));
 388         newCONSTSUB(stash, "HINTK_ATTRS_", newSVpvs(HINTK_ATTRS_));
 389         /**/
 390         next_keyword_plugin = PL_keyword_plugin;
 391         PL_keyword_plugin = my_keyword_plugin;
 392 } WARNINGS_RESET
 393
 394 void
 395 _fini()
 396         CODE:
 397         sv_magicext((SV *)GvHV(PL_hintgv), NULL, PERL_MAGIC_ext, &my_vtbl, NULL, 0);