ext/XS-APItest-KeywordRPN/KeywordRPN.xs

   1 #define PERL_CORE 1   /* for pad_findmy() */
   2 #include "EXTERN.h"
   3 #include "perl.h"
   4 #include "XSUB.h"
   5
   6 #define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV)
   7 #define sv_is_regexp(sv) (SvTYPE(sv) == SVt_REGEXP)
   8 #define sv_is_string(sv) \
   9         (!sv_is_glob(sv) && !sv_is_regexp(sv) && \
  10          (SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK)))
  11
  12 static SV *hintkey_rpn_sv, *hintkey_calcrpn_sv;
  13 static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
  14
  15 /* low-level parser helpers */
  16
  17 #define PL_bufptr (PL_parser->bufptr)
  18 #define PL_bufend (PL_parser->bufend)
  19
  20 static char THX_peek_char(pTHX)
  21 {
  22         if(PL_bufptr == PL_bufend)
  23                 Perl_croak(aTHX_
  24                         "unexpected EOF "
  25                         "(or you were unlucky about buffer position, FIXME)");
  26         return *PL_bufptr;
  27 }
  28 #define peek_char() THX_peek_char(aTHX)
  29
  30 static char THX_read_char(pTHX)
  31 {
  32         char c = peek_char();
  33         PL_bufptr++;
  34         if(c == '\n') CopLINE_inc(PL_curcop);
  35         return c;
  36 }
  37 #define read_char() THX_read_char(aTHX)
  38
  39 static void THX_skip_opt_ws(pTHX)
  40 {
  41         while(1) {
  42                 switch(peek_char()) {
  43                         case '\t': case '\n': case '\v': case '\f': case ' ':
  44                                 read_char();
  45                                 break;
  46                         default:
  47                                 return;
  48                 }
  49         }
  50 }
  51 #define skip_opt_ws() THX_skip_opt_ws(aTHX)
  52
  53 /* RPN parser */
  54
  55 static OP *THX_parse_var(pTHX)
  56 {
  57         SV *varname = sv_2mortal(newSVpvs("$"));
  58         PADOFFSET varpos;
  59         OP *padop;
  60         if(peek_char() != '$') Perl_croak(aTHX_ "RPN syntax error");
  61         read_char();
  62         while(1) {
  63                 char c = peek_char();
  64                 if(!isALNUM(c)) break;
  65                 read_char();
  66                 sv_catpvn_nomg(varname, &c, 1);
  67         }
  68         if(SvCUR(varname) < 2) Perl_croak(aTHX_ "RPN syntax error");
  69         varpos = pad_findmy(SvPVX(varname), SvCUR(varname), 0);
  70         if(varpos == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(varpos))
  71                 Perl_croak(aTHX_ "RPN only supports \"my\" variables");
  72         padop = newOP(OP_PADSV, 0);
  73         padop->op_targ = varpos;
  74         return padop;
  75 }
  76 #define parse_var() THX_parse_var(aTHX)
  77
  78 #define push_rpn_item(o) \
  79         (tmpop = (o), tmpop->op_sibling = stack, stack = tmpop)
  80 #define pop_rpn_item() \
  81         (!stack ? (Perl_croak(aTHX_ "RPN stack underflow"), (OP*)NULL) : \
  82          (tmpop = stack, stack = stack->op_sibling, \
  83           tmpop->op_sibling = NULL, tmpop))
  84
  85 static OP *THX_parse_rpn_expr(pTHX)
  86 {
  87         OP *stack = NULL, *tmpop;
  88         while(1) {
  89                 char c;
  90                 skip_opt_ws();
  91                 c = peek_char();
  92                 switch(c) {
  93                         case /*(*/')': case /*{*/'}': {
  94                                 OP *result = pop_rpn_item();
  95                                 if(stack)
  96                                         Perl_croak(aTHX_
  97                                                 "RPN expression must return "
  98                                                 "a single value");
  99                                 return result;
 100                         } break;
 101                         case '0': case '1': case '2': case '3': case '4':
 102                         case '5': case '6': case '7': case '8': case '9': {
 103                                 UV val = 0;
 104                                 do {
 105                                         read_char();
 106                                         val = 10*val + (c - '0');
 107                                         c = peek_char();
 108                                 } while(c >= '0' && c <= '9');
 109                                 push_rpn_item(newSVOP(OP_CONST, 0,
 110                                         newSVuv(val)));
 111                         } break;
 112                         case '$': {
 113                                 push_rpn_item(parse_var());
 114                         } break;
 115                         case '+': {
 116                                 OP *b = pop_rpn_item();
 117                                 OP *a = pop_rpn_item();
 118                                 read_char();
 119                                 push_rpn_item(newBINOP(OP_I_ADD, 0, a, b));
 120                         } break;
 121                         case '-': {
 122                                 OP *b = pop_rpn_item();
 123                                 OP *a = pop_rpn_item();
 124                                 read_char();
 125                                 push_rpn_item(newBINOP(OP_I_SUBTRACT, 0, a, b));
 126                         } break;
 127                         case '*': {
 128                                 OP *b = pop_rpn_item();
 129                                 OP *a = pop_rpn_item();
 130                                 read_char();
 131                                 push_rpn_item(newBINOP(OP_I_MULTIPLY, 0, a, b));
 132                         } break;
 133                         case '/': {
 134                                 OP *b = pop_rpn_item();
 135                                 OP *a = pop_rpn_item();
 136                                 read_char();
 137                                 push_rpn_item(newBINOP(OP_I_DIVIDE, 0, a, b));
 138                         } break;
 139                         case '%': {
 140                                 OP *b = pop_rpn_item();
 141                                 OP *a = pop_rpn_item();
 142                                 read_char();
 143                                 push_rpn_item(newBINOP(OP_I_MODULO, 0, a, b));
 144                         } break;
 145                         default: {
 146                                 Perl_croak(aTHX_ "RPN syntax error");
 147                         } break;
 148                 }
 149         }
 150 }
 151 #define parse_rpn_expr() THX_parse_rpn_expr(aTHX)
 152
 153 static OP *THX_parse_keyword_rpn(pTHX)
 154 {
 155         OP *op;
 156         skip_opt_ws();
 157         if(peek_char() != '('/*)*/)
 158                 Perl_croak(aTHX_ "RPN expression must be parenthesised");
 159         read_char();
 160         op = parse_rpn_expr();
 161         if(peek_char() != /*(*/')')
 162                 Perl_croak(aTHX_ "RPN expression must be parenthesised");
 163         read_char();
 164         return op;
 165 }
 166 #define parse_keyword_rpn() THX_parse_keyword_rpn(aTHX)
 167
 168 static OP *THX_parse_keyword_calcrpn(pTHX)
 169 {
 170         OP *varop, *exprop;
 171         skip_opt_ws();
 172         varop = parse_var();
 173         skip_opt_ws();
 174         if(peek_char() != '{'/*}*/)
 175                 Perl_croak(aTHX_ "RPN expression must be braced");
 176         read_char();
 177         exprop = parse_rpn_expr();
 178         if(peek_char() != /*{*/'}')
 179                 Perl_croak(aTHX_ "RPN expression must be braced");
 180         read_char();
 181         return newASSIGNOP(OPf_STACKED, varop, 0, exprop);
 182 }
 183 #define parse_keyword_calcrpn() THX_parse_keyword_calcrpn(aTHX)
 184
 185 /* plugin glue */
 186
 187 static int THX_keyword_active(pTHX_ SV *hintkey_sv)
 188 {
 189         HE *he;
 190         if(!GvHV(PL_hintgv)) return 0;
 191         he = hv_fetch_ent(GvHV(PL_hintgv), hintkey_sv, 0,
 192                                 SvSHARED_HASH(hintkey_sv));
 193         return he && SvTRUE(HeVAL(he));
 194 }
 195 #define keyword_active(hintkey_sv) THX_keyword_active(aTHX_ hintkey_sv)
 196
 197 static void THX_keyword_enable(pTHX_ SV *hintkey_sv)
 198 {
 199         SV *val_sv = newSViv(1);
 200         HE *he;
 201         PL_hints |= HINT_LOCALIZE_HH;
 202         gv_HVadd(PL_hintgv);
 203         he = hv_store_ent(GvHV(PL_hintgv),
 204                 hintkey_sv, val_sv, SvSHARED_HASH(hintkey_sv));
 205         if(he) {
 206                 SV *val = HeVAL(he);
 207                 SvSETMAGIC(val);
 208         } else {
 209                 SvREFCNT_dec(val_sv);
 210         }
 211 }
 212 #define keyword_enable(hintkey_sv) THX_keyword_enable(aTHX_ hintkey_sv)
 213
 214 static void THX_keyword_disable(pTHX_ SV *hintkey_sv)
 215 {
 216         if(GvHV(PL_hintgv)) {
 217                 PL_hints |= HINT_LOCALIZE_HH;
 218                 hv_delete_ent(GvHV(PL_hintgv),
 219                         hintkey_sv, G_DISCARD, SvSHARED_HASH(hintkey_sv));
 220         }
 221 }
 222 #define keyword_disable(hintkey_sv) THX_keyword_disable(aTHX_ hintkey_sv)
 223
 224 static int my_keyword_plugin(pTHX_
 225         char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
 226 {
 227         if(keyword_len == 3 && strnEQ(keyword_ptr, "rpn", 3) &&
 228                         keyword_active(hintkey_rpn_sv)) {
 229                 *op_ptr = parse_keyword_rpn();
 230                 return KEYWORD_PLUGIN_EXPR;
 231         } else if(keyword_len == 7 && strnEQ(keyword_ptr, "calcrpn", 7) &&
 232                         keyword_active(hintkey_calcrpn_sv)) {
 233                 *op_ptr = parse_keyword_calcrpn();
 234                 return KEYWORD_PLUGIN_STMT;
 235         } else {
 236                 return next_keyword_plugin(aTHX_
 237                                 keyword_ptr, keyword_len, op_ptr);
 238         }
 239 }
 240
 241 MODULE = XS::APItest::KeywordRPN PACKAGE = XS::APItest::KeywordRPN
 242
 243 BOOT:
 244         hintkey_rpn_sv = newSVpvs_share("XS::APItest::KeywordRPN/rpn");
 245         hintkey_calcrpn_sv = newSVpvs_share("XS::APItest::KeywordRPN/calcrpn");
 246         next_keyword_plugin = PL_keyword_plugin;
 247         PL_keyword_plugin = my_keyword_plugin;
 248
 249 void
 250 import(SV *classname, ...)
 251 PREINIT:
 252         int i;
 253 PPCODE:
 254         for(i = 1; i != items; i++) {
 255                 SV *item = ST(i);
 256                 if(sv_is_string(item) && strEQ(SvPVX(item), "rpn")) {
 257                         keyword_enable(hintkey_rpn_sv);
 258                 } else if(sv_is_string(item) && strEQ(SvPVX(item), "calcrpn")) {
 259                         keyword_enable(hintkey_calcrpn_sv);
 260                 } else {
 261                         Perl_croak(aTHX_
 262                                 "\"%s\" is not exported by the %s module",
 263                                 SvPV_nolen(item), SvPV_nolen(ST(0)));
 264                 }
 265         }
 266
 267 void
 268 unimport(SV *classname, ...)
 269 PREINIT:
 270         int i;
 271 PPCODE:
 272         for(i = 1; i != items; i++) {
 273                 SV *item = ST(i);
 274                 if(sv_is_string(item) && strEQ(SvPVX(item), "rpn")) {
 275                         keyword_disable(hintkey_rpn_sv);
 276                 } else if(sv_is_string(item) && strEQ(SvPVX(item), "calcrpn")) {
 277                         keyword_disable(hintkey_calcrpn_sv);
 278                 } else {
 279                         Perl_croak(aTHX_
 280                                 "\"%s\" is not exported by the %s module",
 281                                 SvPV_nolen(item), SvPV_nolen(ST(0)));
 282                 }
 283         }