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