Declare.xs

   1 #include "EXTERN.h"
   2 #include "perl.h"
   3 #include "XSUB.h"
   4 #include "hook_op_check.h"
   5 #undef printf
   6 #include "stolen_chunk_of_toke.c"
   7 #include <stdio.h>
   8 #include <string.h>
   9
  10 #ifndef Newx
  11 # define Newx(v,n,t) New(0,v,n,t)
  12 #endif /* !Newx */
  13
  14 #define DD_DEBUGf_UPDATED_LINESTR 1
  15 #define DD_DEBUGf_TRACE 2
  16
  17 #define DD_DEBUG_UPDATED_LINESTR (dd_debug & DD_DEBUGf_UPDATED_LINESTR)
  18 #define DD_DEBUG_TRACE (dd_debug & DD_DEBUGf_TRACE)
  19 static int dd_debug = 0;
  20
  21 #define LEX_NORMAL    10
  22 #define LEX_INTERPNORMAL   9
  23
  24 /* flag to trigger removal of temporary declaree sub */
  25
  26 static int in_declare = 0;
  27
  28 /* in 5.10, PL_parser will be NULL if we aren't parsing, and PL_lex_stuff
  29    is a lookup into it - so if anything else we can use to tell, so we
  30    need to be a bit more careful if PL_parser exists */
  31
  32 #define DD_AM_LEXING_CHECK (PL_lex_state == LEX_NORMAL || PL_lex_state == LEX_INTERPNORMAL)
  33
  34 #if defined(PL_parser) || defined(PERL_5_9_PLUS)
  35 #define DD_HAVE_PARSER PL_parser
  36 #define DD_HAVE_LEX_STUFF (PL_parser && PL_lex_stuff)
  37 #define DD_AM_LEXING (PL_parser && DD_AM_LEXING_CHECK)
  38 #else
  39 #define DD_HAVE_PARSER 1
  40 #define DD_HAVE_LEX_STUFF PL_lex_stuff
  41 #define DD_AM_LEXING DD_AM_LEXING_CHECK
  42 #endif
  43
  44 /* thing that decides whether we're dealing with a declarator */
  45
  46 int dd_is_declarator(pTHX_ char* name) {
  47   HV* is_declarator;
  48   SV** is_declarator_pack_ref;
  49   HV* is_declarator_pack_hash;
  50   SV** is_declarator_flag_ref;
  51   int dd_flags;
  52
  53   is_declarator = get_hv("Devel::Declare::declarators", FALSE);
  54
  55   if (!is_declarator)
  56     return -1;
  57
  58   /* $declarators{$current_package_name} */
  59
  60   if (!HvNAME(PL_curstash))
  61     return -1;
  62
  63   is_declarator_pack_ref = hv_fetch(is_declarator, HvNAME(PL_curstash),
  64                              strlen(HvNAME(PL_curstash)), FALSE);
  65
  66   if (!is_declarator_pack_ref || !SvROK(*is_declarator_pack_ref))
  67     return -1; /* not a hashref */
  68
  69   is_declarator_pack_hash = (HV*) SvRV(*is_declarator_pack_ref);
  70
  71   /* $declarators{$current_package_name}{$name} */
  72
  73   is_declarator_flag_ref = hv_fetch(
  74     is_declarator_pack_hash, name,
  75     strlen(name), FALSE
  76   );
  77
  78   /* requires SvIOK as well as TRUE since flags not being an int is useless */
  79
  80   if (!is_declarator_flag_ref
  81         || !SvIOK(*is_declarator_flag_ref)
  82         || !SvTRUE(*is_declarator_flag_ref))
  83     return -1;
  84
  85   dd_flags = SvIVX(*is_declarator_flag_ref);
  86
  87   return dd_flags;
  88 }
  89
  90 /* callback thingy */
  91
  92 void dd_linestr_callback (pTHX_ char* type, char* name) {
  93
  94   char* linestr = SvPVX(PL_linestr);
  95   int offset = PL_bufptr - linestr;
  96
  97   dSP;
  98
  99   ENTER;
 100   SAVETMPS;
 101
 102   PUSHMARK(SP);
 103   XPUSHs(sv_2mortal(newSVpv(type, 0)));
 104   XPUSHs(sv_2mortal(newSVpv(name, 0)));
 105   XPUSHs(sv_2mortal(newSViv(offset)));
 106   PUTBACK;
 107
 108   call_pv("Devel::Declare::linestr_callback", G_VOID|G_DISCARD);
 109
 110   FREETMPS;
 111   LEAVE;
 112 }
 113
 114 char* dd_get_linestr(pTHX) {
 115   if (!DD_HAVE_PARSER) {
 116     return NULL;
 117   }
 118   return SvPVX(PL_linestr);
 119 }
 120
 121 void dd_set_linestr(pTHX_ char* new_value) {
 122   unsigned int new_len = strlen(new_value);
 123
 124   if (SvLEN(PL_linestr) < new_len) {
 125     croak("PL_linestr not long enough, was Devel::Declare loaded soon enough in %s",
 126       CopFILE(&PL_compiling)
 127     );
 128   }
 129
 130
 131   memcpy(SvPVX(PL_linestr), new_value, new_len+1);
 132
 133   SvCUR_set(PL_linestr, new_len);
 134
 135   PL_bufend = SvPVX(PL_linestr) + new_len;
 136
 137   if ( DD_DEBUG_UPDATED_LINESTR && PERLDB_LINE && PL_curstash != PL_debstash) {
 138     // Cribbed from toke.c
 139     SV * const sv = NEWSV(85,0);
 140
 141     sv_upgrade(sv, SVt_PVMG);
 142     sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
 143     (void)SvIOK_on(sv);
 144     SvIV_set(sv, 0);
 145     av_store(CopFILEAV(&PL_compiling),(I32)CopLINE(&PL_compiling),sv);
 146   }
 147 }
 148
 149 char* dd_get_lex_stuff(pTHX) {
 150   return (DD_HAVE_LEX_STUFF ? SvPVX(PL_lex_stuff) : "");
 151 }
 152
 153 void dd_clear_lex_stuff(pTHX) {
 154   if (DD_HAVE_PARSER)
 155     PL_lex_stuff = (SV*)NULL;
 156 }
 157
 158 char* dd_get_curstash_name(pTHX) {
 159   return HvNAME(PL_curstash);
 160 }
 161
 162 int dd_get_linestr_offset(pTHX) {
 163   char* linestr;
 164   if (!DD_HAVE_PARSER) {
 165     return -1;
 166   }
 167   linestr = SvPVX(PL_linestr);
 168   return PL_bufptr - linestr;
 169 }
 170
 171 char* dd_move_past_token (pTHX_ char* s) {
 172
 173   /*
 174    *   buffer will be at the beginning of the declarator, -unless- the
 175    *   declarator is at EOL in which case it'll be the next useful line
 176    *   so we don't short-circuit out if we don't find the declarator
 177    */
 178
 179   while (s < PL_bufend && isSPACE(*s)) s++;
 180   if (memEQ(s, PL_tokenbuf, strlen(PL_tokenbuf)))
 181     s += strlen(PL_tokenbuf);
 182   return s;
 183 }
 184
 185 int dd_toke_move_past_token (pTHX_ int offset) {
 186   char* base_s = SvPVX(PL_linestr) + offset;
 187   char* s = dd_move_past_token(aTHX_ base_s);
 188   return s - base_s;
 189 }
 190
 191 int dd_toke_scan_word(pTHX_ int offset, int handle_package) {
 192   char tmpbuf[sizeof PL_tokenbuf];
 193   char* base_s = SvPVX(PL_linestr) + offset;
 194   STRLEN len;
 195   char* s = scan_word(base_s, tmpbuf, sizeof tmpbuf, handle_package, &len);
 196   return s - base_s;
 197 }
 198
 199 int dd_toke_scan_ident(pTHX_ int offset) {
 200     char tmpbuf[sizeof PL_tokenbuf];
 201     char* base_s = SvPVX(PL_linestr) + offset;
 202     char* s = scan_ident(base_s, PL_bufend, tmpbuf, sizeof tmpbuf, 0);
 203     return s - base_s;
 204 }
 205
 206 int dd_toke_scan_str(pTHX_ int offset) {
 207   STRLEN remaining = sv_len(PL_linestr) - offset;
 208   SV* line_copy = newSVsv(PL_linestr);
 209   char* base_s = SvPVX(PL_linestr) + offset;
 210   char* s = scan_str(base_s, FALSE, FALSE);
 211   if (s != base_s && sv_len(PL_lex_stuff) > remaining) {
 212     int ret = (s - SvPVX(PL_linestr)) + remaining;
 213     sv_catsv(line_copy, PL_linestr);
 214     dd_set_linestr(aTHX_ SvPV_nolen(line_copy));
 215     SvREFCNT_dec(line_copy);
 216     return ret;
 217   }
 218   return s - base_s;
 219 }
 220
 221 int dd_toke_skipspace(pTHX_ int offset) {
 222   char* base_s = SvPVX(PL_linestr) + offset;
 223   char* s = skipspace(base_s);
 224   return s - base_s;
 225 }
 226
 227 /* replacement PL_check rv2cv entry */
 228
 229 STATIC OP *dd_ck_rv2cv(pTHX_ OP *o, void *user_data) {
 230   dSP;
 231   OP* kid;
 232   int dd_flags;
 233
 234   PERL_UNUSED_VAR(user_data);
 235
 236   if (in_declare) {
 237     if (DD_DEBUG_TRACE) {
 238       printf("Deconstructing declare\n");
 239       printf("PL_bufptr: %s\n", PL_bufptr);
 240       printf("bufend at: %i\n", PL_bufend - PL_bufptr);
 241       printf("linestr: %s\n", SvPVX(PL_linestr));
 242       printf("linestr len: %i\n", PL_bufend - SvPVX(PL_linestr));
 243     }
 244
 245     ENTER;
 246     SAVETMPS;
 247
 248     PUSHMARK(SP);
 249
 250     call_pv("Devel::Declare::done_declare", G_VOID|G_DISCARD);
 251
 252     FREETMPS;
 253     LEAVE;
 254
 255     if (DD_DEBUG_TRACE) {
 256       printf("PL_bufptr: %s\n", PL_bufptr);
 257       printf("bufend at: %i\n", PL_bufend - PL_bufptr);
 258       printf("linestr: %s\n", SvPVX(PL_linestr));
 259       printf("linestr len: %i\n", PL_bufend - SvPVX(PL_linestr));
 260       printf("actual len: %i\n", strlen(PL_bufptr));
 261     }
 262     return o;
 263   }
 264
 265   kid = cUNOPo->op_first;
 266
 267   if (kid->op_type != OP_GV) /* not a GV so ignore */
 268     return o;
 269
 270   if (!DD_AM_LEXING)
 271     return o; /* not lexing? */
 272
 273   if (DD_DEBUG_TRACE) {
 274     printf("Checking GV %s -> %s\n", HvNAME(GvSTASH(kGVOP_gv)), GvNAME(kGVOP_gv));
 275   }
 276
 277   dd_flags = dd_is_declarator(aTHX_ GvNAME(kGVOP_gv));
 278
 279   if (dd_flags == -1)
 280     return o;
 281
 282   if (DD_DEBUG_TRACE) {
 283     printf("dd_flags are: %i\n", dd_flags);
 284     printf("PL_tokenbuf: %s\n", PL_tokenbuf);
 285   }
 286
 287   dd_linestr_callback(aTHX_ "rv2cv", GvNAME(kGVOP_gv));
 288
 289   return o;
 290 }
 291
 292 OP* dd_pp_entereval(pTHX) {
 293   dSP;
 294   STRLEN len;
 295   const char* s;
 296   SV *sv;
 297 #ifdef PERL_5_9_PLUS
 298   SV *saved_hh;
 299   if (PL_op->op_private & OPpEVAL_HAS_HH) {
 300     saved_hh = POPs;
 301   }
 302 #endif
 303   sv = POPs;
 304   if (SvPOK(sv)) {
 305     if (DD_DEBUG_TRACE) {
 306       printf("mangling eval sv\n");
 307     }
 308     if (SvREADONLY(sv))
 309       sv = sv_2mortal(newSVsv(sv));
 310     s = SvPVX(sv);
 311     len = SvCUR(sv);
 312     if (!len || s[len-1] != ';') {
 313       if (!(SvFLAGS(sv) & SVs_TEMP))
 314         sv = sv_2mortal(newSVsv(sv));
 315       sv_catpvn(sv, "\n;", 2);
 316     }
 317     SvGROW(sv, 8192);
 318   }
 319   PUSHs(sv);
 320 #ifdef PERL_5_9_PLUS
 321   if (PL_op->op_private & OPpEVAL_HAS_HH) {
 322     PUSHs(saved_hh);
 323   }
 324 #endif
 325   return PL_ppaddr[OP_ENTEREVAL](aTHX);
 326 }
 327
 328 STATIC OP *dd_ck_entereval(pTHX_ OP *o, void *user_data) {
 329   PERL_UNUSED_VAR(user_data);
 330
 331   if (o->op_ppaddr == PL_ppaddr[OP_ENTEREVAL])
 332     o->op_ppaddr = dd_pp_entereval;
 333   return o;
 334 }
 335
 336 static I32 dd_filter_realloc(pTHX_ int idx, SV *sv, int maxlen)
 337 {
 338   const I32 count = FILTER_READ(idx+1, sv, maxlen);
 339   SvGROW(sv, 8192); /* please try not to have a line longer than this :) */
 340   /* filter_del(dd_filter_realloc); */
 341   return count;
 342 }
 343
 344 STATIC OP *dd_ck_const(pTHX_ OP *o, void *user_data) {
 345   int dd_flags;
 346   char* name;
 347
 348   PERL_UNUSED_VAR(user_data);
 349
 350   if (DD_HAVE_PARSER && PL_expect == XOPERATOR) {
 351     return o;
 352   }
 353
 354   /* if this is set, we just grabbed a delimited string or something,
 355      not a bareword, so NO TOUCHY */
 356
 357   if (DD_HAVE_LEX_STUFF)
 358     return o;
 359
 360   /* don't try and look this up if it's not a string const */
 361   if (!SvPOK(cSVOPo->op_sv))
 362     return o;
 363
 364   name = SvPVX(cSVOPo->op_sv);
 365
 366   dd_flags = dd_is_declarator(aTHX_ name);
 367
 368   if (dd_flags == -1)
 369     return o;
 370
 371   switch (PL_lex_inwhat) {
 372     case OP_QR:
 373     case OP_MATCH:
 374     case OP_SUBST:
 375     case OP_TRANS:
 376     case OP_BACKTICK:
 377     case OP_STRINGIFY:
 378       return o;
 379       break;
 380     default:
 381       break;
 382   }
 383
 384   dd_linestr_callback(aTHX_ "const", name);
 385
 386   return o;
 387 }
 388
 389 static int initialized = 0;
 390
 391 MODULE = Devel::Declare  PACKAGE = Devel::Declare
 392
 393 PROTOTYPES: DISABLE
 394
 395 void
 396 setup()
 397   CODE:
 398   if (!initialized++) {
 399     hook_op_check(OP_RV2CV, dd_ck_rv2cv, NULL);
 400     hook_op_check(OP_ENTEREVAL, dd_ck_entereval, NULL);
 401     hook_op_check(OP_CONST, dd_ck_const, NULL);
 402   }
 403   filter_add(dd_filter_realloc, NULL);
 404
 405 char*
 406 get_linestr()
 407   CODE:
 408     RETVAL = dd_get_linestr(aTHX);
 409   OUTPUT:
 410     RETVAL
 411
 412 void
 413 set_linestr(char* new_value)
 414   CODE:
 415     dd_set_linestr(aTHX_ new_value);
 416
 417 char*
 418 get_lex_stuff()
 419   CODE:
 420     RETVAL = dd_get_lex_stuff(aTHX);
 421   OUTPUT:
 422     RETVAL
 423
 424 void
 425 clear_lex_stuff()
 426   CODE:
 427     dd_clear_lex_stuff(aTHX);
 428
 429 char*
 430 get_curstash_name()
 431   CODE:
 432     RETVAL = dd_get_curstash_name(aTHX);
 433   OUTPUT:
 434     RETVAL
 435
 436 int
 437 get_linestr_offset()
 438   CODE:
 439     RETVAL = dd_get_linestr_offset(aTHX);
 440   OUTPUT:
 441     RETVAL
 442
 443 int
 444 toke_scan_word(int offset, int handle_package)
 445   CODE:
 446     RETVAL = dd_toke_scan_word(aTHX_ offset, handle_package);
 447   OUTPUT:
 448     RETVAL
 449
 450 int
 451 toke_move_past_token(int offset);
 452   CODE:
 453     RETVAL = dd_toke_move_past_token(aTHX_ offset);
 454   OUTPUT:
 455     RETVAL
 456
 457 int
 458 toke_scan_str(int offset);
 459   CODE:
 460     RETVAL = dd_toke_scan_str(aTHX_ offset);
 461   OUTPUT:
 462     RETVAL
 463
 464 int
 465 toke_scan_ident(int offset)
 466   CODE:
 467     RETVAL = dd_toke_scan_ident(aTHX_ offset);
 468   OUTPUT:
 469     RETVAL
 470
 471 int
 472 toke_skipspace(int offset)
 473   CODE:
 474     RETVAL = dd_toke_skipspace(aTHX_ offset);
 475   OUTPUT:
 476     RETVAL
 477
 478 int
 479 get_in_declare()
 480   CODE:
 481     RETVAL = in_declare;
 482   OUTPUT:
 483     RETVAL
 484
 485 void
 486 set_in_declare(int value)
 487   CODE:
 488     in_declare = value;
 489
 490 BOOT:
 491   char *endptr;
 492   char *debug_str = getenv ("DD_DEBUG");
 493   if (debug_str) {
 494     dd_debug = strtol (debug_str, &endptr, 10);
 495     if (*endptr != '\0') {
 496       dd_debug = 0;
 497     }
 498   }