Declare.xs

   1 #define PERL_CORE
   2 #define PERL_NO_GET_CONTEXT
   3 #include "EXTERN.h"
   4 #include "perl.h"
   5 #include "XSUB.h"
   6 #undef printf
   7 #include "stolen_chunk_of_toke.c"
   8 #include <stdio.h>
   9 #include <string.h>
  10
  11 #ifndef Newx
  12 # define Newx(v,n,t) New(0,v,n,t)
  13 #endif /* !Newx */
  14
  15 #if 1
  16 #define DD_HAS_TRAITS
  17 #endif
  18
  19 #if 0
  20 #define DD_DEBUG
  21 #endif
  22
  23 #define DD_HANDLE_NAME 1
  24 #define DD_HANDLE_PROTO 2
  25 #define DD_HANDLE_PACKAGE 8
  26
  27 #ifdef DD_DEBUG
  28 #define DD_DEBUG_S printf("Buffer: %s\n", s);
  29 #else
  30 #define DD_DEBUG_S
  31 #endif
  32
  33 #define LEX_NORMAL    10
  34 #define LEX_INTERPNORMAL   9
  35
  36 /* placeholders for PL_check entries we wrap */
  37
  38 STATIC OP *(*dd_old_ck_rv2cv)(pTHX_ OP *op);
  39 STATIC OP *(*dd_old_ck_entereval)(pTHX_ OP *op);
  40
  41 /* flag to trigger removal of temporary declaree sub */
  42
  43 static int in_declare = 0;
  44
  45 /* replacement PL_check rv2cv entry */
  46
  47 STATIC OP *dd_ck_rv2cv(pTHX_ OP *o) {
  48   OP* kid;
  49   char* s;
  50   char* save_s;
  51   char tmpbuf[sizeof PL_tokenbuf];
  52   char found_name[sizeof PL_tokenbuf];
  53   char* found_proto = NULL, *found_traits = NULL;
  54   STRLEN len = 0;
  55   HV *stash;
  56   HV* is_declarator;
  57   SV** is_declarator_pack_ref;
  58   HV* is_declarator_pack_hash;
  59   SV** is_declarator_flag_ref;
  60   int dd_flags;
  61   char* cb_args[6];
  62   dSP; /* define stack pointer for later call stuff */
  63   char* retstr;
  64   STRLEN n_a; /* for POPpx */
  65
  66   o = dd_old_ck_rv2cv(aTHX_ o); /* let the original do its job */
  67
  68   if (in_declare) {
  69     cb_args[0] = NULL;
  70 #ifdef DD_DEBUG
  71     printf("Deconstructing declare\n");
  72     printf("PL_bufptr: %s\n", PL_bufptr);
  73     printf("bufend at: %i\n", PL_bufend - PL_bufptr);
  74     printf("linestr: %s\n", SvPVX(PL_linestr));
  75     printf("linestr len: %i\n", PL_bufend - SvPVX(PL_linestr));
  76 #endif
  77     call_argv("Devel::Declare::done_declare", G_VOID|G_DISCARD, cb_args);
  78     in_declare--;
  79 #ifdef DD_DEBUG
  80     printf("PL_bufptr: %s\n", PL_bufptr);
  81     printf("bufend at: %i\n", PL_bufend - PL_bufptr);
  82     printf("linestr: %s\n", SvPVX(PL_linestr));
  83     printf("linestr len: %i\n", PL_bufend - SvPVX(PL_linestr));
  84     printf("actual len: %i\n", strlen(PL_bufptr));
  85 #endif
  86     return o;
  87   }
  88
  89   kid = cUNOPo->op_first;
  90
  91   if (kid->op_type != OP_GV) /* not a GV so ignore */
  92     return o;
  93
  94   if (PL_lex_state != LEX_NORMAL && PL_lex_state != LEX_INTERPNORMAL)
  95     return o; /* not lexing? */
  96
  97   stash = GvSTASH(kGVOP_gv);
  98
  99 #ifdef DD_DEBUG
 100   printf("Checking GV %s -> %s\n", HvNAME(stash), GvNAME(kGVOP_gv));
 101 #endif
 102
 103   is_declarator = get_hv("Devel::Declare::declarators", FALSE);
 104
 105   if (!is_declarator)
 106     return o;
 107
 108   is_declarator_pack_ref = hv_fetch(is_declarator, HvNAME(stash),
 109                              strlen(HvNAME(stash)), FALSE);
 110
 111   if (!is_declarator_pack_ref || !SvROK(*is_declarator_pack_ref))
 112     return o; /* not a hashref */
 113
 114   is_declarator_pack_hash = (HV*) SvRV(*is_declarator_pack_ref);
 115
 116   is_declarator_flag_ref = hv_fetch(is_declarator_pack_hash, GvNAME(kGVOP_gv),
 117                                 strlen(GvNAME(kGVOP_gv)), FALSE);
 118
 119   /* requires SvIOK as well as TRUE since flags not being an int is useless */
 120
 121   if (!is_declarator_flag_ref
 122         || !SvIOK(*is_declarator_flag_ref)
 123         || !SvTRUE(*is_declarator_flag_ref))
 124     return o;
 125
 126   dd_flags = SvIVX(*is_declarator_flag_ref);
 127
 128 #ifdef DD_DEBUG
 129   printf("dd_flags are: %i\n", dd_flags);
 130 #endif
 131
 132   s = PL_bufptr; /* copy the current buffer pointer */
 133
 134   DD_DEBUG_S
 135
 136 #ifdef DD_DEBUG
 137   printf("PL_tokenbuf: %s\n", PL_tokenbuf);
 138 #endif
 139
 140   /*
 141    *   buffer will be at the beginning of the declarator, -unless- the
 142    *   declarator is at EOL in which case it'll be the next useful line
 143    *   so we don't short-circuit out if we don't find the declarator
 144    */
 145
 146   while (s < PL_bufend && isSPACE(*s)) s++;
 147   if (memEQ(s, PL_tokenbuf, strlen(PL_tokenbuf)))
 148     s += strlen(PL_tokenbuf);
 149
 150   DD_DEBUG_S
 151
 152   if (dd_flags & DD_HANDLE_NAME) {
 153
 154     /* find next word */
 155
 156     s = skipspace(s);
 157
 158     DD_DEBUG_S
 159
 160     /* arg 4 is allow_package */
 161
 162     s = scan_word(s, tmpbuf, sizeof tmpbuf, dd_flags & DD_HANDLE_PACKAGE, &len);
 163
 164     DD_DEBUG_S
 165
 166     if (len) {
 167       strcpy(found_name, tmpbuf);
 168 #ifdef DD_DEBUG
 169       printf("Found %s\n", found_name);
 170 #endif
 171     }
 172   }
 173
 174   if (dd_flags & DD_HANDLE_PROTO) {
 175
 176     s = skipspace(s);
 177
 178     if (*s == '(') { /* found a prototype-ish thing */
 179       save_s = s;
 180       s = scan_str(s, FALSE, FALSE); /* no keep_quoted, no keep_delims */
 181 #ifdef DD_HAS_TRAITS
 182       {
 183           char *traitstart = s = skipspace(s);
 184
 185           while (*s && *s != '{') ++s;
 186           if (*s) {
 187               int tlen = s - traitstart;
 188               Newx(found_traits, tlen+1, char);
 189               Copy(traitstart, found_traits, tlen, char);
 190               found_traits[tlen] = 0;
 191 #ifdef DD_DEBUG
 192               printf("found traits..... (%s)\n", found_traits);
 193 #endif
 194           }
 195       }
 196 #endif
 197
 198       if (SvPOK(PL_lex_stuff)) {
 199 #ifdef DD_DEBUG
 200         printf("Found proto %s\n", SvPVX(PL_lex_stuff));
 201 #endif
 202         found_proto = SvPVX(PL_lex_stuff);
 203         if (len) /* foo name () => foo name  X, only foo parsed so works */
 204           *save_s++ = ' ';
 205         else /* foo () => foo =X, TOKEN('&') won't handle foo X */
 206           *save_s++ = '=';
 207         *save_s++ = 'X';
 208         while (save_s < s) {
 209           *save_s++ = ' ';
 210         }
 211 #ifdef DD_DEBUG
 212         printf("Curbuf %s\n", PL_bufptr);
 213 #endif
 214       }
 215     }
 216   }
 217
 218   if (!len)
 219     found_name[0] = 0;
 220
 221 #ifdef DD_DEBUG
 222   printf("Calling init_declare\n");
 223 #endif
 224   cb_args[0] = HvNAME(stash);
 225   cb_args[1] = GvNAME(kGVOP_gv);
 226   cb_args[2] = HvNAME(PL_curstash);
 227   cb_args[3] = found_name;
 228   cb_args[4] = found_proto;
 229   cb_args[5] = found_traits;
 230   cb_args[6] = NULL;
 231
 232   if (len && found_proto)
 233     in_declare = 2;
 234   else if (len || found_proto)
 235     in_declare = 1;
 236   if (found_proto)
 237     PL_lex_stuff = Nullsv;
 238   s = skipspace(s);
 239 #ifdef DD_DEBUG
 240   printf("cur buf: %s\n", s);
 241   printf("bufend at: %i\n", PL_bufend - s);
 242   printf("linestr: %s\n", SvPVX(PL_linestr));
 243   printf("linestr len: %i\n", PL_bufend - SvPVX(PL_linestr));
 244 #endif
 245   if (*s++ == '{') {
 246     call_argv("Devel::Declare::init_declare", G_SCALAR, cb_args);
 247     SPAGAIN;
 248     retstr = POPpx;
 249     PUTBACK;
 250     if (retstr && strlen(retstr)) {
 251       const char* old_start = SvPVX(PL_linestr);
 252       int start_diff;
 253       const int old_len = SvCUR(PL_linestr);
 254 #ifdef DD_DEBUG
 255       printf("Got string %s\n", retstr);
 256 #endif
 257       SvGROW(PL_linestr, (STRLEN)(old_len + strlen(retstr)));
 258       if (start_diff = SvPVX(PL_linestr) - old_start) {
 259         Perl_croak(aTHX_ "forced to realloc PL_linestr for line %s, bailing out before we crash harder", SvPVX(PL_linestr));
 260       }
 261       memmove(s+strlen(retstr), s, (PL_bufend - s)+1);
 262       memmove(s, retstr, strlen(retstr));
 263       SvCUR_set(PL_linestr, old_len + strlen(retstr));
 264       PL_bufend += strlen(retstr);
 265 #ifdef DD_DEBUG
 266   printf("cur buf: %s\n", s);
 267   printf("PL_bufptr: %s\n", PL_bufptr);
 268   printf("bufend at: %i\n", PL_bufend - s);
 269   printf("linestr: %s\n", SvPVX(PL_linestr));
 270   printf("linestr len: %i\n", PL_bufend - SvPVX(PL_linestr));
 271   printf("tokenbuf now: %s\n", PL_tokenbuf);
 272 #endif
 273     }
 274   } else {
 275     call_argv("Devel::Declare::init_declare", G_VOID|G_DISCARD, cb_args);
 276   }
 277   return o;
 278 }
 279
 280 OP* dd_pp_entereval(pTHX) {
 281   dSP;
 282   dPOPss;
 283   STRLEN len;
 284   const char* s;
 285   if (SvPOK(sv)) {
 286 #ifdef DD_DEBUG
 287     printf("mangling eval sv\n");
 288 #endif
 289     if (SvREADONLY(sv))
 290       sv = sv_2mortal(newSVsv(sv));
 291     s = SvPVX(sv);
 292     len = SvCUR(sv);
 293     if (!len || s[len-1] != ';') {
 294       if (!(SvFLAGS(sv) & SVs_TEMP))
 295         sv = sv_2mortal(newSVsv(sv));
 296       sv_catpvn(sv, "\n;", 2);
 297     }
 298     SvGROW(sv, 8192);
 299   }
 300   PUSHs(sv);
 301   return PL_ppaddr[OP_ENTEREVAL](aTHX);
 302 }
 303
 304 STATIC OP *dd_ck_entereval(pTHX_ OP *o) {
 305   o = dd_old_ck_entereval(aTHX_ o); /* let the original do its job */
 306   if (o->op_ppaddr == PL_ppaddr[OP_ENTEREVAL])
 307     o->op_ppaddr = dd_pp_entereval;
 308   return o;
 309 }
 310
 311 static I32 dd_filter_realloc(pTHX_ int idx, SV *sv, int maxlen)
 312 {
 313   const I32 count = FILTER_READ(idx+1, sv, maxlen);
 314   SvGROW(sv, 8192); /* please try not to have a line longer than this :) */
 315   /* filter_del(dd_filter_realloc); */
 316   return count;
 317 }
 318
 319 static int initialized = 0;
 320
 321 MODULE = Devel::Declare  PACKAGE = Devel::Declare
 322
 323 PROTOTYPES: DISABLE
 324
 325 void
 326 setup()
 327   CODE:
 328   if (!initialized++) {
 329     dd_old_ck_rv2cv = PL_check[OP_RV2CV];
 330     PL_check[OP_RV2CV] = dd_ck_rv2cv;
 331     dd_old_ck_entereval = PL_check[OP_ENTEREVAL];
 332     PL_check[OP_ENTEREVAL] = dd_ck_entereval;
 333   }
 334   filter_add(dd_filter_realloc, NULL);