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
  60 #define HAVE_PERL_VERSION(R, V, S) \
  61         (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
  62
  63 typedef struct {
  64         enum {
  65                 FLAG_NAME_OPTIONAL = 1,
  66                 FLAG_NAME_REQUIRED,
  67                 FLAG_NAME_PROHIBITED
  68         } name;
  69         char shift[256];
  70 } Spec;
  71
  72 static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
  73
  74 static int kw_flags(pTHX_ const char *kw_ptr, STRLEN kw_len, Spec *spec) {
  75         HV *hints;
  76         SV *sv, **psv;
  77         const char *p, *kw_active;
  78         STRLEN kw_active_len;
  79
  80         spec->name = 0;
  81         spec->shift[0] = '\0';
  82
  83         if (!(hints = GvHV(PL_hintgv))) {
  84                 return FALSE;
  85         }
  86         if (!(psv = hv_fetchs(hints, HINTK_KEYWORDS, 0))) {
  87                 return FALSE;
  88         }
  89         sv = *psv;
  90         kw_active = SvPV(sv, kw_active_len);
  91         if (kw_active_len <= kw_len) {
  92                 return FALSE;
  93         }
  94         for (p = kw_active; p < kw_active + kw_active_len - kw_len; p++) {
  95                 if (
  96                         (p == kw_active || p[-1] == ' ') &&
  97                         p[kw_len] == ' ' &&
  98                         memcmp(kw_ptr, p, kw_len) == 0
  99                 ) {
 100                         const char *kf_ptr;
 101                         STRLEN kf_len;
 102                         SV *kf_sv;
 103
 104                         kf_sv = sv_2mortal(newSVpvs(HINTK_NAME_));
 105                         sv_catpvn(kf_sv, kw_ptr, kw_len);
 106                         kf_ptr = SvPV(kf_sv, kf_len);
 107                         if (!(psv = hv_fetch(hints, kf_ptr, kf_len, 0))) {
 108                                 croak("%s: internal error: $^H{'%.*s'} not set", MY_PKG, (int)kf_len, kf_ptr);
 109                         }
 110                         spec->name = SvIV(*psv);
 111
 112                         kf_sv = sv_2mortal(newSVpvs(HINTK_SHIFT_));
 113                         sv_catpvn(kf_sv, kw_ptr, kw_len);
 114                         kf_ptr = SvPV(kf_sv, kf_len);
 115                         if (!(psv = hv_fetch(hints, kf_ptr, kf_len, 0))) {
 116                                 croak("%s: internal error: $^H{'%.*s'} not set", MY_PKG, (int)kf_len, kf_ptr);
 117                         }
 118                         my_sprintf(spec->shift, "%.*s", (int)(sizeof spec->shift - 1), SvPV_nolen(*psv));
 119
 120                         return TRUE;
 121                 }
 122         }
 123         return FALSE;
 124 }
 125
 126
 127 #include "toke_on_crack.c.inc"
 128
 129
 130 static int parse_fun(pTHX_ OP **pop, const char *keyword_ptr, STRLEN keyword_len, const Spec *spec) {
 131         SV *gen, *declarator, *params, *sv;
 132         line_t line_start;
 133         int saw_name, saw_colon;
 134         STRLEN len;
 135         char *s;
 136         I32 c;
 137
 138         gen = sv_2mortal(newSVpvs("sub"));
 139         declarator = sv_2mortal(newSVpvn(keyword_ptr, keyword_len));
 140         params = sv_2mortal(newSVpvs(""));
 141
 142         line_start = CopLINE(PL_curcop);
 143         lex_read_space(0);
 144
 145         /* function name */
 146         saw_name = 0;
 147         s = PL_parser->bufptr;
 148         if (spec->name != FLAG_NAME_PROHIBITED && (len = S_scan_word(aTHX_ s, TRUE))) {
 149                 sv_catpvs(gen, " ");
 150                 sv_catpvn(gen, s, len);
 151                 sv_catpvs(declarator, " ");
 152                 sv_catpvn(declarator, s, len);
 153                 lex_read_to(s + len);
 154                 lex_read_space(0);
 155                 saw_name = 1;
 156         } else if (spec->name == FLAG_NAME_REQUIRED) {
 157                 croak("I was expecting a function name, not \"%.*s\"", (int)(PL_parser->bufend - s), s);
 158         } else {
 159                 sv_catpvs(declarator, " (anon)");
 160         }
 161
 162         /* parameters */
 163         c = lex_peek_unichar(0);
 164         if (c == '(') {
 165                 SV *saw_slurpy = NULL;
 166
 167                 lex_read_unichar(0);
 168                 lex_read_space(0);
 169
 170                 for (;;) {
 171                         c = lex_peek_unichar(0);
 172                         if (c && strchr("$@%", c)) {
 173                                 sv_catpvf(params, "%c", (int)c);
 174                                 lex_read_unichar(0);
 175                                 lex_read_space(0);
 176
 177                                 s = PL_parser->bufptr;
 178                                 if (!(len = S_scan_word(aTHX_ s, FALSE))) {
 179                                         croak("In %.*s: missing identifier", (int)SvCUR(declarator), SvPV_nolen(declarator));
 180                                 }
 181                                 if (saw_slurpy) {
 182                                         croak("In %.*s: I was expecting \")\" after \"%s\", not \"%c%.*s\"", (int)SvCUR(declarator), SvPV_nolen(declarator), SvPV_nolen(saw_slurpy), (int)c, (int)len, s);
 183                                 }
 184                                 if (c != '$') {
 185                                         saw_slurpy = sv_2mortal(newSVpvf("%c%.*s", (int)c, (int)len, s));
 186                                 }
 187                                 sv_catpvn(params, s, len);
 188                                 sv_catpvs(params, ",");
 189                                 lex_read_to(s + len);
 190                                 lex_read_space(0);
 191
 192                                 c = lex_peek_unichar(0);
 193                                 if (c == ',') {
 194                                         lex_read_unichar(0);
 195                                         lex_read_space(0);
 196                                         continue;
 197                                 }
 198                         }
 199
 200                         if (c == ')') {
 201                                 lex_read_unichar(0);
 202                                 lex_read_space(0);
 203                                 break;
 204                         }
 205
 206                         if (c == -1) {
 207                                 croak("In %.*s: unexpected EOF in parameter list", (int)SvCUR(declarator), SvPV_nolen(declarator));
 208                         }
 209                         croak("In %.*s: unexpected '%c' in parameter list", (int)SvCUR(declarator), SvPV_nolen(declarator), (int)c);
 210                 }
 211         }
 212
 213         /* prototype */
 214         saw_colon = 0;
 215         c = lex_peek_unichar(0);
 216         if (c == ':') {
 217                 lex_read_unichar(0);
 218                 lex_read_space(0);
 219
 220                 c = lex_peek_unichar(0);
 221                 if (c != '(') {
 222                         saw_colon = 1;
 223                 } else {
 224                         sv = sv_2mortal(newSVpvs(""));
 225                         if (!S_scan_str(aTHX_ sv, TRUE, TRUE)) {
 226                                 croak("In %.*s: malformed prototype", (int)SvCUR(declarator), SvPV_nolen(declarator));
 227                         }
 228                         sv_catsv(gen, sv);
 229                         lex_read_space(0);
 230                 }
 231         }
 232
 233         if (saw_name) {
 234                 len = SvCUR(gen);
 235                 s = SvGROW(gen, (len + 1) * 2);
 236                 sv_catpvs(gen, ";");
 237                 sv_catpvn(gen, s, len);
 238         }
 239
 240         /* attributes */
 241         if (!saw_colon) {
 242                 c = lex_peek_unichar(0);
 243                 if (c == ':') {
 244                         saw_colon = 1;
 245                         lex_read_unichar(0);
 246                         lex_read_space(0);
 247                 }
 248         }
 249         if (saw_colon) {
 250                 for (;;) {
 251                         s = PL_parser->bufptr;
 252                         if (!(len = S_scan_word(aTHX_ s, FALSE))) {
 253                                 break;
 254                         }
 255                         sv_catpvs(gen, ":");
 256                         sv_catpvn(gen, s, len);
 257                         lex_read_to(s + len);
 258                         lex_read_space(0);
 259                         c = lex_peek_unichar(0);
 260                         if (c == '(') {
 261                                 sv = sv_2mortal(newSVpvs(""));
 262                                 if (!S_scan_str(aTHX_ sv, TRUE, TRUE)) {
 263                                         croak("In %.*s: malformed attribute argument list", (int)SvCUR(declarator), SvPV_nolen(declarator));
 264                                 }
 265                                 sv_catsv(gen, sv);
 266                                 lex_read_space(0);
 267                                 c = lex_peek_unichar(0);
 268                         }
 269                         if (c == ':') {
 270                                 lex_read_unichar(0);
 271                                 lex_read_space(0);
 272                         }
 273                 }
 274         }
 275
 276         /* body */
 277         c = lex_peek_unichar(0);
 278         if (c != '{') {
 279                 croak("In %.*s: I was expecting a function body, not \"%c\"", (int)SvCUR(declarator), SvPV_nolen(declarator), (int)c);
 280         }
 281         lex_read_unichar(0);
 282         sv_catpvs(gen, "{");
 283         if (spec->shift[0]) {
 284                 sv_catpvf(gen, "my%s=shift;", spec->shift);
 285         }
 286         if (SvCUR(params)) {
 287                 sv_catpvs(gen, "my(");
 288                 sv_catsv(gen, params);
 289                 sv_catpvs(gen, ")=@_;");
 290         }
 291
 292
 293         /* named sub */
 294         if (saw_name) {
 295                 /* fprintf(stderr, "! [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */
 296                 lex_stuff_sv(gen, SvUTF8(gen));
 297                 *pop = parse_barestmt(0);
 298                 return KEYWORD_PLUGIN_STMT;
 299         }
 300
 301         /* anon sub */
 302         sv_catpvs(gen, "BEGIN{" MY_PKG "::_fini}");
 303         /* fprintf(stderr, "!> [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */
 304         lex_stuff_sv(gen, SvUTF8(gen));
 305         *pop = parse_arithexpr(0);
 306         s = PL_parser->bufptr;
 307         if (*s != '}') {
 308                 croak("%s: internal error: expected '}', found '%c'", MY_PKG, *s);
 309         }
 310         lex_unstuff(s + 1);
 311         /* fprintf(stderr, "!< [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */
 312         return KEYWORD_PLUGIN_EXPR;
 313 }
 314
 315 static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) {
 316         Spec spec;
 317         int ret;
 318
 319         SAVETMPS;
 320
 321         if (kw_flags(aTHX_ keyword_ptr, keyword_len, &spec)) {
 322                 ret = parse_fun(aTHX_ op_ptr, keyword_ptr, keyword_len, &spec);
 323         } else {
 324                 ret = next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
 325         }
 326
 327         FREETMPS;
 328
 329         return ret;
 330 }
 331
 332 static int magic_free(pTHX_ SV *sv, MAGIC *mg) {
 333         lex_stuff_pvn("}", 1, 0);
 334         /* fprintf(stderr, "!~ [%.*s]\n", (int)(PL_bufend - PL_bufptr), PL_bufptr); */
 335         return 0;
 336 }
 337
 338 static int magic_nop(pTHX_ SV *sv, MAGIC *mg) {
 339         return 0;
 340 }
 341
 342 static MGVTBL my_vtbl = {
 343         0,           /* get   */
 344         0,           /* set   */
 345         0,           /* len   */
 346         0,           /* clear */
 347         magic_free,  /* free  */
 348         0,           /* copy  */
 349         0,           /* dup   */
 350         magic_nop    /* local */
 351 };
 352
 353 WARNINGS_RESET
 354
 355 MODULE = Function::Parameters   PACKAGE = Function::Parameters
 356 PROTOTYPES: ENABLE
 357
 358 BOOT:
 359 WARNINGS_ENABLE {
 360         HV *const stash = gv_stashpvs(MY_PKG, GV_ADD);
 361         newCONSTSUB(stash, "FLAG_NAME_OPTIONAL", newSViv(FLAG_NAME_OPTIONAL));
 362         newCONSTSUB(stash, "FLAG_NAME_REQUIRED", newSViv(FLAG_NAME_REQUIRED));
 363         newCONSTSUB(stash, "FLAG_NAME_PROHIBITED", newSViv(FLAG_NAME_PROHIBITED));
 364         newCONSTSUB(stash, "HINTK_KEYWORDS", newSVpvs(HINTK_KEYWORDS));
 365         newCONSTSUB(stash, "HINTK_NAME_", newSVpvs(HINTK_NAME_));
 366         newCONSTSUB(stash, "HINTK_SHIFT_", newSVpvs(HINTK_SHIFT_));
 367         newCONSTSUB(stash, "SHIFT_NAME_LIMIT", newSViv(sizeof ((Spec *)NULL)->shift));
 368         next_keyword_plugin = PL_keyword_plugin;
 369         PL_keyword_plugin = my_keyword_plugin;
 370 } WARNINGS_RESET
 371
 372 void
 373 _fini()
 374         CODE:
 375         sv_magicext((SV *)GvHV(PL_hintgv), NULL, PERL_MAGIC_ext, &my_vtbl, NULL, 0);