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_force(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   if (strnEQ(PL_bufptr, "->", 2)) {
 385     return o;
 386   }
 387
 388   {
 389     char buf[256];
 390     STRLEN len;
 391     char *s = PL_bufptr;
 392     STRLEN old_offset = PL_bufptr - SvPVX(PL_linestr);
 393
 394     s = scan_word(s, buf, sizeof buf, FALSE, &len);
 395     if (strnEQ(buf, name, len)) {
 396       char *d;
 397       SV *inject = newSVpvn(SvPVX(PL_linestr), PL_bufptr - SvPVX(PL_linestr));
 398       sv_catpvn(inject, buf, len);
 399
 400       d = peekspace(s);
 401       sv_catpvn(inject, s, d - s);
 402
 403       if ((PL_bufend - d) >= 2 && strnEQ(d, "=>", 2)) {
 404         return o;
 405       }
 406
 407       sv_catpv(inject, d);
 408       dd_set_linestr(aTHX_ SvPV_nolen(inject));
 409       PL_bufptr = SvPVX(PL_linestr) + old_offset;
 410       SvREFCNT_dec (inject);
 411     }
 412   }
 413
 414   dd_linestr_callback(aTHX_ "const", name);
 415
 416   return o;
 417 }
 418
 419 static int initialized = 0;
 420
 421 MODULE = Devel::Declare  PACKAGE = Devel::Declare
 422
 423 PROTOTYPES: DISABLE
 424
 425 void
 426 setup()
 427   CODE:
 428   if (!initialized++) {
 429     hook_op_check(OP_RV2CV, dd_ck_rv2cv, NULL);
 430     hook_op_check(OP_ENTEREVAL, dd_ck_entereval, NULL);
 431     hook_op_check(OP_CONST, dd_ck_const, NULL);
 432   }
 433   filter_add(dd_filter_realloc, NULL);
 434
 435 char*
 436 get_linestr()
 437   CODE:
 438     RETVAL = dd_get_linestr(aTHX);
 439   OUTPUT:
 440     RETVAL
 441
 442 void
 443 set_linestr(char* new_value)
 444   CODE:
 445     dd_set_linestr(aTHX_ new_value);
 446
 447 char*
 448 get_lex_stuff()
 449   CODE:
 450     RETVAL = dd_get_lex_stuff(aTHX);
 451   OUTPUT:
 452     RETVAL
 453
 454 void
 455 clear_lex_stuff()
 456   CODE:
 457     dd_clear_lex_stuff(aTHX);
 458
 459 char*
 460 get_curstash_name()
 461   CODE:
 462     RETVAL = dd_get_curstash_name(aTHX);
 463   OUTPUT:
 464     RETVAL
 465
 466 int
 467 get_linestr_offset()
 468   CODE:
 469     RETVAL = dd_get_linestr_offset(aTHX);
 470   OUTPUT:
 471     RETVAL
 472
 473 int
 474 toke_scan_word(int offset, int handle_package)
 475   CODE:
 476     RETVAL = dd_toke_scan_word(aTHX_ offset, handle_package);
 477   OUTPUT:
 478     RETVAL
 479
 480 int
 481 toke_move_past_token(int offset);
 482   CODE:
 483     RETVAL = dd_toke_move_past_token(aTHX_ offset);
 484   OUTPUT:
 485     RETVAL
 486
 487 int
 488 toke_scan_str(int offset);
 489   CODE:
 490     RETVAL = dd_toke_scan_str(aTHX_ offset);
 491   OUTPUT:
 492     RETVAL
 493
 494 int
 495 toke_scan_ident(int offset)
 496   CODE:
 497     RETVAL = dd_toke_scan_ident(aTHX_ offset);
 498   OUTPUT:
 499     RETVAL
 500
 501 int
 502 toke_skipspace(int offset)
 503   CODE:
 504     RETVAL = dd_toke_skipspace(aTHX_ offset);
 505   OUTPUT:
 506     RETVAL
 507
 508 int
 509 get_in_declare()
 510   CODE:
 511     RETVAL = in_declare;
 512   OUTPUT:
 513     RETVAL
 514
 515 void
 516 set_in_declare(int value)
 517   CODE:
 518     in_declare = value;
 519
 520 BOOT:
 521 {
 522   char *endptr;
 523   char *debug_str = getenv ("DD_DEBUG");
 524   if (debug_str) {
 525     dd_debug = strtol (debug_str, &endptr, 10);
 526     if (*endptr != '\0') {
 527       dd_debug = 0;
 528     }
 529   }
 530 }