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 /* flag to trigger removal of temporary declaree sub */
  37
  38 static int in_declare = 0;
  39
  40 /* thing that decides whether we're dealing with a declarator */
  41
  42 int dd_is_declarator(pTHX_ char* name) {
  43   HV* is_declarator;
  44   SV** is_declarator_pack_ref;
  45   HV* is_declarator_pack_hash;
  46   SV** is_declarator_flag_ref;
  47   int dd_flags;
  48
  49   is_declarator = get_hv("Devel::Declare::declarators", FALSE);
  50
  51   if (!is_declarator)
  52     return -1;
  53
  54   is_declarator_pack_ref = hv_fetch(is_declarator, HvNAME(PL_curstash),
  55                              strlen(HvNAME(PL_curstash)), FALSE);
  56
  57   if (!is_declarator_pack_ref || !SvROK(*is_declarator_pack_ref))
  58     return -1; /* not a hashref */
  59
  60   is_declarator_pack_hash = (HV*) SvRV(*is_declarator_pack_ref);
  61
  62   is_declarator_flag_ref = hv_fetch(
  63     is_declarator_pack_hash, name,
  64     strlen(name), FALSE
  65   );
  66
  67   /* requires SvIOK as well as TRUE since flags not being an int is useless */
  68
  69   if (!is_declarator_flag_ref
  70         || !SvIOK(*is_declarator_flag_ref)
  71         || !SvTRUE(*is_declarator_flag_ref))
  72     return -1;
  73
  74   dd_flags = SvIVX(*is_declarator_flag_ref);
  75
  76   return dd_flags;
  77 }
  78
  79 /* replacement PL_check rv2cv entry */
  80
  81 STATIC OP *(*dd_old_ck_rv2cv)(pTHX_ OP *op);
  82
  83 STATIC OP *dd_ck_rv2cv(pTHX_ OP *o) {
  84   OP* kid;
  85   char* s;
  86   char* save_s;
  87   char tmpbuf[sizeof PL_tokenbuf];
  88   char found_name[sizeof PL_tokenbuf];
  89   char* found_proto = NULL, *found_traits = NULL;
  90   STRLEN len = 0;
  91   int dd_flags;
  92   char* cb_args[6];
  93   dSP; /* define stack pointer for later call stuff */
  94   char* retstr;
  95   STRLEN n_a; /* for POPpx */
  96
  97   o = dd_old_ck_rv2cv(aTHX_ o); /* let the original do its job */
  98
  99   if (in_declare) {
 100     cb_args[0] = NULL;
 101 #ifdef DD_DEBUG
 102     printf("Deconstructing declare\n");
 103     printf("PL_bufptr: %s\n", PL_bufptr);
 104     printf("bufend at: %i\n", PL_bufend - PL_bufptr);
 105     printf("linestr: %s\n", SvPVX(PL_linestr));
 106     printf("linestr len: %i\n", PL_bufend - SvPVX(PL_linestr));
 107 #endif
 108     call_argv("Devel::Declare::done_declare", G_VOID|G_DISCARD, cb_args);
 109     in_declare--;
 110 #ifdef DD_DEBUG
 111     printf("PL_bufptr: %s\n", PL_bufptr);
 112     printf("bufend at: %i\n", PL_bufend - PL_bufptr);
 113     printf("linestr: %s\n", SvPVX(PL_linestr));
 114     printf("linestr len: %i\n", PL_bufend - SvPVX(PL_linestr));
 115     printf("actual len: %i\n", strlen(PL_bufptr));
 116 #endif
 117     return o;
 118   }
 119
 120   kid = cUNOPo->op_first;
 121
 122   if (kid->op_type != OP_GV) /* not a GV so ignore */
 123     return o;
 124
 125   if (PL_lex_state != LEX_NORMAL && PL_lex_state != LEX_INTERPNORMAL)
 126     return o; /* not lexing? */
 127
 128   /* I was doing this, but the CONST wrap can't so it didn't gain anything
 129   stash = GvSTASH(kGVOP_gv); */
 130
 131 #ifdef DD_DEBUG
 132   printf("Checking GV %s -> %s\n", HvNAME(GvSTASH(kGVOP_gv)), GvNAME(kGVOP_gv));
 133 #endif
 134
 135   dd_flags = dd_is_declarator(aTHX_ GvNAME(kGVOP_gv));
 136
 137   if (dd_flags == -1)
 138     return o;
 139
 140 #ifdef DD_DEBUG
 141   printf("dd_flags are: %i\n", dd_flags);
 142 #endif
 143
 144   s = PL_bufptr; /* copy the current buffer pointer */
 145
 146   DD_DEBUG_S
 147
 148 #ifdef DD_DEBUG
 149   printf("PL_tokenbuf: %s\n", PL_tokenbuf);
 150 #endif
 151
 152   /*
 153    *   buffer will be at the beginning of the declarator, -unless- the
 154    *   declarator is at EOL in which case it'll be the next useful line
 155    *   so we don't short-circuit out if we don't find the declarator
 156    */
 157
 158   while (s < PL_bufend && isSPACE(*s)) s++;
 159   if (memEQ(s, PL_tokenbuf, strlen(PL_tokenbuf)))
 160     s += strlen(PL_tokenbuf);
 161
 162   DD_DEBUG_S
 163
 164   if (dd_flags & DD_HANDLE_NAME) {
 165
 166     /* find next word */
 167
 168     s = skipspace(s);
 169
 170     DD_DEBUG_S
 171
 172     /* kill the :: added in the ck_const */
 173     if (*s == ':')
 174       *s++ = ' ';
 175     if (*s == ':')
 176       *s++ = ' ';
 177
 178     /* arg 4 is allow_package */
 179
 180     s = scan_word(s, tmpbuf, sizeof tmpbuf, dd_flags & DD_HANDLE_PACKAGE, &len);
 181
 182     DD_DEBUG_S
 183
 184     if (len) {
 185       strcpy(found_name, tmpbuf);
 186 #ifdef DD_DEBUG
 187       printf("Found %s\n", found_name);
 188 #endif
 189     }
 190   }
 191
 192   if (dd_flags & DD_HANDLE_PROTO) {
 193
 194     s = skipspace(s);
 195
 196     if (*s == '(') { /* found a prototype-ish thing */
 197       save_s = s;
 198       s = scan_str(s, FALSE, FALSE); /* no keep_quoted, no keep_delims */
 199 #ifdef DD_HAS_TRAITS
 200       {
 201           char *traitstart = s = skipspace(s);
 202
 203           while (*s && *s != '{') ++s;
 204           if (*s) {
 205               int tlen = s - traitstart;
 206               Newx(found_traits, tlen+1, char);
 207               Copy(traitstart, found_traits, tlen, char);
 208               found_traits[tlen] = 0;
 209 #ifdef DD_DEBUG
 210               printf("found traits..... (%s)\n", found_traits);
 211 #endif
 212           }
 213       }
 214 #endif
 215
 216       if (SvPOK(PL_lex_stuff)) {
 217 #ifdef DD_DEBUG
 218         printf("Found proto %s\n", SvPVX(PL_lex_stuff));
 219 #endif
 220         found_proto = SvPVX(PL_lex_stuff);
 221         if (len) /* foo name () => foo name  X, only foo parsed so works */
 222           *save_s++ = ' ';
 223         else /* foo () => foo =X, TOKEN('&') won't handle foo X */
 224           *save_s++ = '=';
 225         *save_s++ = 'X';
 226         while (save_s < s) {
 227           *save_s++ = ' ';
 228         }
 229 #ifdef DD_DEBUG
 230         printf("Curbuf %s\n", PL_bufptr);
 231 #endif
 232       }
 233     }
 234   }
 235
 236   if (!len)
 237     found_name[0] = 0;
 238
 239 #ifdef DD_DEBUG
 240   printf("Calling init_declare\n");
 241 #endif
 242   cb_args[0] = HvNAME(PL_curstash);
 243   cb_args[1] = GvNAME(kGVOP_gv);
 244   cb_args[2] = HvNAME(PL_curstash);
 245   cb_args[3] = found_name;
 246   cb_args[4] = found_proto;
 247   cb_args[5] = found_traits;
 248   cb_args[6] = NULL;
 249
 250   if (len && found_proto)
 251     in_declare = 2;
 252   else if (len || found_proto)
 253     in_declare = 1;
 254   if (found_proto)
 255     PL_lex_stuff = Nullsv;
 256   s = skipspace(s);
 257 #ifdef DD_DEBUG
 258   printf("cur buf: %s\n", s);
 259   printf("bufend at: %i\n", PL_bufend - s);
 260   printf("linestr: %s\n", SvPVX(PL_linestr));
 261   printf("linestr len: %i\n", PL_bufend - SvPVX(PL_linestr));
 262 #endif
 263
 264   if (*s++ == '{') {
 265     call_argv("Devel::Declare::init_declare", G_SCALAR, cb_args);
 266     SPAGAIN;
 267     retstr = POPpx;
 268     PUTBACK;
 269     if (retstr && strlen(retstr)) {
 270       const char* old_start = SvPVX(PL_linestr);
 271       int start_diff;
 272       const int old_len = SvCUR(PL_linestr);
 273 #ifdef DD_DEBUG
 274       printf("Got string %s\n", retstr);
 275 #endif
 276       SvGROW(PL_linestr, (STRLEN)(old_len + strlen(retstr)));
 277       if (start_diff = SvPVX(PL_linestr) - old_start) {
 278         Perl_croak(aTHX_ "forced to realloc PL_linestr for line %s, bailing out before we crash harder", SvPVX(PL_linestr));
 279       }
 280       memmove(s+strlen(retstr), s, (PL_bufend - s)+1);
 281       memmove(s, retstr, strlen(retstr));
 282       SvCUR_set(PL_linestr, old_len + strlen(retstr));
 283       PL_bufend += strlen(retstr);
 284 #ifdef DD_DEBUG
 285   printf("cur buf: %s\n", s);
 286   printf("PL_bufptr: %s\n", PL_bufptr);
 287   printf("bufend at: %i\n", PL_bufend - s);
 288   printf("linestr: %s\n", SvPVX(PL_linestr));
 289   printf("linestr len: %i\n", PL_bufend - SvPVX(PL_linestr));
 290   printf("tokenbuf now: %s\n", PL_tokenbuf);
 291 #endif
 292     }
 293   } else {
 294     call_argv("Devel::Declare::init_declare", G_VOID|G_DISCARD, cb_args);
 295   }
 296   return o;
 297 }
 298
 299 STATIC OP *(*dd_old_ck_entereval)(pTHX_ OP *op);
 300
 301 OP* dd_pp_entereval(pTHX) {
 302   dSP;
 303   dPOPss;
 304   STRLEN len;
 305   const char* s;
 306   if (SvPOK(sv)) {
 307 #ifdef DD_DEBUG
 308     printf("mangling eval sv\n");
 309 #endif
 310     if (SvREADONLY(sv))
 311       sv = sv_2mortal(newSVsv(sv));
 312     s = SvPVX(sv);
 313     len = SvCUR(sv);
 314     if (!len || s[len-1] != ';') {
 315       if (!(SvFLAGS(sv) & SVs_TEMP))
 316         sv = sv_2mortal(newSVsv(sv));
 317       sv_catpvn(sv, "\n;", 2);
 318     }
 319     SvGROW(sv, 8192);
 320   }
 321   PUSHs(sv);
 322   return PL_ppaddr[OP_ENTEREVAL](aTHX);
 323 }
 324
 325 STATIC OP *dd_ck_entereval(pTHX_ OP *o) {
 326   o = dd_old_ck_entereval(aTHX_ o); /* let the original do its job */
 327   if (o->op_ppaddr == PL_ppaddr[OP_ENTEREVAL])
 328     o->op_ppaddr = dd_pp_entereval;
 329   return o;
 330 }
 331
 332 static I32 dd_filter_realloc(pTHX_ int idx, SV *sv, int maxlen)
 333 {
 334   const I32 count = FILTER_READ(idx+1, sv, maxlen);
 335   SvGROW(sv, 8192); /* please try not to have a line longer than this :) */
 336   /* filter_del(dd_filter_realloc); */
 337   return count;
 338 }
 339
 340 STATIC OP *(*dd_old_ck_const)(pTHX_ OP*op);
 341
 342 STATIC OP *dd_ck_const(pTHX_ OP *o) {
 343   HV* is_declarator;
 344   SV** is_declarator_pack_ref;
 345   HV* is_declarator_pack_hash;
 346   SV** is_declarator_flag_ref;
 347   int dd_flags;
 348   char* s;
 349   char tmpbuf[sizeof PL_tokenbuf];
 350   char found_name[sizeof PL_tokenbuf];
 351   STRLEN len = 0;
 352
 353   o = dd_old_ck_const(aTHX_ o); /* let the original do its job */
 354
 355   is_declarator = get_hv("Devel::Declare::declarators", FALSE);
 356
 357   is_declarator_pack_ref = hv_fetch(is_declarator, HvNAME(PL_curstash),
 358                              strlen(HvNAME(PL_curstash)), FALSE);
 359
 360   if (!is_declarator_pack_ref || !SvROK(*is_declarator_pack_ref))
 361     return o; /* not a hashref */
 362
 363   is_declarator_pack_hash = (HV*) SvRV(*is_declarator_pack_ref);
 364
 365   /* don't try and look this up if it's not a string const */
 366   if (!SvPOK(cSVOPo->op_sv))
 367     return o;
 368
 369   is_declarator_flag_ref = hv_fetch(
 370     is_declarator_pack_hash, SvPVX(cSVOPo->op_sv),
 371     strlen(SvPVX(cSVOPo->op_sv)), FALSE
 372   );
 373
 374   /* requires SvIOK as well as TRUE since flags not being an int is useless */
 375
 376   if (!is_declarator_flag_ref
 377         || !SvIOK(*is_declarator_flag_ref)
 378         || !SvTRUE(*is_declarator_flag_ref))
 379     return o;
 380
 381   dd_flags = SvIVX(*is_declarator_flag_ref);
 382
 383   if (!(dd_flags & DD_HANDLE_NAME))
 384     return o; /* if we're not handling name, method intuiting not an issue */
 385
 386 #ifdef DD_DEBUG
 387   printf("Think I found a declarator %s\n", PL_tokenbuf);
 388   printf("linestr: %s\n", SvPVX(PL_linestr));
 389 #endif
 390
 391   s = PL_bufptr;
 392
 393   while (s < PL_bufend && isSPACE(*s)) s++;
 394   if (memEQ(s, PL_tokenbuf, strlen(PL_tokenbuf)))
 395     s += strlen(PL_tokenbuf);
 396
 397   DD_DEBUG_S
 398
 399   /* find next word */
 400
 401   s = skipspace(s);
 402
 403   DD_DEBUG_S
 404
 405   /* arg 4 is allow_package */
 406
 407   s = scan_word(s, tmpbuf, sizeof tmpbuf, dd_flags & DD_HANDLE_PACKAGE, &len);
 408
 409   DD_DEBUG_S
 410
 411   if (len) {
 412     const char* old_start = SvPVX(PL_linestr);
 413     int start_diff;
 414     const int old_len = SvCUR(PL_linestr);
 415
 416     strcpy(found_name, tmpbuf);
 417 #ifdef DD_DEBUG
 418     printf("Found %s\n", found_name);
 419 #endif
 420
 421     s -= len;
 422     SvGROW(PL_linestr, (STRLEN)(old_len + 2));
 423     if (start_diff = SvPVX(PL_linestr) - old_start) {
 424       Perl_croak(aTHX_ "forced to realloc PL_linestr for line %s, bailing out before we crash harder", SvPVX(PL_linestr));
 425     }
 426     memmove(s+2, s, (PL_bufend - s)+1);
 427     *s = ':';
 428     s++;
 429     *s = ':';
 430     SvCUR_set(PL_linestr, old_len + 2);
 431     PL_bufend += 2;
 432   }
 433   return o;
 434 }
 435
 436 static int initialized = 0;
 437
 438 MODULE = Devel::Declare  PACKAGE = Devel::Declare
 439
 440 PROTOTYPES: DISABLE
 441
 442 void
 443 setup()
 444   CODE:
 445   if (!initialized++) {
 446     dd_old_ck_rv2cv = PL_check[OP_RV2CV];
 447     PL_check[OP_RV2CV] = dd_ck_rv2cv;
 448     dd_old_ck_entereval = PL_check[OP_ENTEREVAL];
 449     PL_check[OP_ENTEREVAL] = dd_ck_entereval;
 450     dd_old_ck_const = PL_check[OP_CONST];
 451     PL_check[OP_CONST] = dd_ck_const;
 452   }
 453   filter_add(dd_filter_realloc, NULL);