Declare.xs

   1 #define PERL_NO_GET_CONTEXT 1
   2 #include "EXTERN.h"
   3 #include "perl.h"
   4 #include "XSUB.h"
   5 #include "hook_op_check.h"
   6 #undef printf
   7 #include "stolen_chunk_of_toke.c"
   8 #include <stdio.h>
   9 #include <string.h>
  10
  11 #define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s)
  12 #define PERL_DECIMAL_VERSION \
  13   PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION)
  14 #define PERL_VERSION_GE(r,v,s) \
  15   (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s))
  16
  17 #ifndef Newx
  18 # define Newx(v,n,t) New(0,v,n,t)
  19 #endif /* !Newx */
  20
  21 #define DD_DEBUGf_UPDATED_LINESTR 1
  22 #define DD_DEBUGf_TRACE 2
  23
  24 #define DD_DEBUG_UPDATED_LINESTR (dd_debug & DD_DEBUGf_UPDATED_LINESTR)
  25 #define DD_DEBUG_TRACE (dd_debug & DD_DEBUGf_TRACE)
  26 static int dd_debug = 0;
  27
  28 #define DD_CONST_VIA_RV2CV PERL_VERSION_GE(5,11,2)
  29
  30 #define DD_GROW_VIA_BLOCKHOOK PERL_VERSION_GE(5,13,3)
  31
  32 #define LEX_NORMAL    10
  33 #define LEX_INTERPNORMAL   9
  34
  35 /* please try not to have a line longer than this :) */
  36
  37 #define DD_PREFERRED_LINESTR_SIZE 16384
  38
  39 /* flag to trigger removal of temporary declaree sub */
  40
  41 static int in_declare = 0;
  42
  43 /* in 5.10, PL_parser will be NULL if we aren't parsing, and PL_lex_stuff
  44    is a lookup into it - so if anything else we can use to tell, so we
  45    need to be a bit more careful if PL_parser exists */
  46
  47 #define DD_AM_LEXING_CHECK (PL_lex_state == LEX_NORMAL || PL_lex_state == LEX_INTERPNORMAL)
  48
  49 #if defined(PL_parser) || defined(PERL_5_9_PLUS)
  50 #define DD_HAVE_PARSER PL_parser
  51 #define DD_HAVE_LEX_STUFF (PL_parser && PL_lex_stuff)
  52 #define DD_AM_LEXING (PL_parser && DD_AM_LEXING_CHECK)
  53 #else
  54 #define DD_HAVE_PARSER 1
  55 #define DD_HAVE_LEX_STUFF PL_lex_stuff
  56 #define DD_AM_LEXING DD_AM_LEXING_CHECK
  57 #endif
  58
  59 /* thing that decides whether we're dealing with a declarator */
  60
  61 int dd_is_declarator(pTHX_ char* name) {
  62   HV* is_declarator;
  63   SV** is_declarator_pack_ref;
  64   HV* is_declarator_pack_hash;
  65   SV** is_declarator_flag_ref;
  66   int dd_flags;
  67   char* curstash_name;
  68
  69   is_declarator = get_hv("Devel::Declare::declarators", FALSE);
  70
  71   if (!is_declarator)
  72     return -1;
  73
  74   /* $declarators{$current_package_name} */
  75
  76   curstash_name = HvNAME(PL_curstash);
  77   if (!curstash_name)
  78     return -1;
  79
  80   is_declarator_pack_ref = hv_fetch(is_declarator, curstash_name,
  81                              strlen(curstash_name), FALSE);
  82
  83   if (!is_declarator_pack_ref || !SvROK(*is_declarator_pack_ref))
  84     return -1; /* not a hashref */
  85
  86   is_declarator_pack_hash = (HV*) SvRV(*is_declarator_pack_ref);
  87
  88   /* $declarators{$current_package_name}{$name} */
  89
  90   is_declarator_flag_ref = hv_fetch(
  91     is_declarator_pack_hash, name,
  92     strlen(name), FALSE
  93   );
  94
  95   /* requires SvIOK as well as TRUE since flags not being an int is useless */
  96
  97   if (!is_declarator_flag_ref
  98         || !SvIOK(*is_declarator_flag_ref)
  99         || !SvTRUE(*is_declarator_flag_ref))
 100     return -1;
 101
 102   dd_flags = SvIVX(*is_declarator_flag_ref);
 103
 104   return dd_flags;
 105 }
 106
 107 /* callback thingy */
 108
 109 void dd_linestr_callback (pTHX_ char* type, char* name) {
 110
 111   char* linestr = SvPVX(PL_linestr);
 112   int offset = PL_bufptr - linestr;
 113
 114   dSP;
 115
 116   ENTER;
 117   SAVETMPS;
 118
 119   PUSHMARK(SP);
 120   XPUSHs(sv_2mortal(newSVpv(type, 0)));
 121   XPUSHs(sv_2mortal(newSVpv(name, 0)));
 122   XPUSHs(sv_2mortal(newSViv(offset)));
 123   PUTBACK;
 124
 125   call_pv("Devel::Declare::linestr_callback", G_VOID|G_DISCARD);
 126
 127   FREETMPS;
 128   LEAVE;
 129 }
 130
 131 char* dd_get_linestr(pTHX) {
 132   if (!DD_HAVE_PARSER) {
 133     return NULL;
 134   }
 135   return SvPVX(PL_linestr);
 136 }
 137
 138 void dd_set_linestr(pTHX_ char* new_value) {
 139   unsigned int new_len = strlen(new_value);
 140
 141   if (SvLEN(PL_linestr) < new_len) {
 142     croak("PL_linestr not long enough, was Devel::Declare loaded soon enough in %s",
 143       CopFILE(&PL_compiling)
 144     );
 145   }
 146
 147
 148   memcpy(SvPVX(PL_linestr), new_value, new_len+1);
 149
 150   SvCUR_set(PL_linestr, new_len);
 151
 152   PL_bufend = SvPVX(PL_linestr) + new_len;
 153
 154   if ( DD_DEBUG_UPDATED_LINESTR && PERLDB_LINE && PL_curstash != PL_debstash) {
 155     /* Cribbed from toke.c */
 156     AV *fileav = CopFILEAV(&PL_compiling);
 157     if (fileav) {
 158       SV * const sv = NEWSV(85,0);
 159
 160       sv_upgrade(sv, SVt_PVMG);
 161       sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
 162       (void)SvIOK_on(sv);
 163       SvIV_set(sv, 0);
 164       av_store(fileav,(I32)CopLINE(&PL_compiling),sv);
 165     }
 166   }
 167 }
 168
 169 char* dd_get_lex_stuff(pTHX) {
 170   return (DD_HAVE_LEX_STUFF ? SvPVX(PL_lex_stuff) : "");
 171 }
 172
 173 void dd_clear_lex_stuff(pTHX) {
 174   if (DD_HAVE_PARSER)
 175     PL_lex_stuff = (SV*)NULL;
 176 }
 177
 178 char* dd_get_curstash_name(pTHX) {
 179   return HvNAME(PL_curstash);
 180 }
 181
 182 int dd_get_linestr_offset(pTHX) {
 183   char* linestr;
 184   if (!DD_HAVE_PARSER) {
 185     return -1;
 186   }
 187   linestr = SvPVX(PL_linestr);
 188   return PL_bufptr - linestr;
 189 }
 190
 191 char* dd_move_past_token (pTHX_ char* s) {
 192
 193   /*
 194    *   buffer will be at the beginning of the declarator, -unless- the
 195    *   declarator is at EOL in which case it'll be the next useful line
 196    *   so we don't short-circuit out if we don't find the declarator
 197    */
 198
 199   while (s < PL_bufend && isSPACE(*s)) s++;
 200   if (memEQ(s, PL_tokenbuf, strlen(PL_tokenbuf)))
 201     s += strlen(PL_tokenbuf);
 202   return s;
 203 }
 204
 205 int dd_toke_move_past_token (pTHX_ int offset) {
 206   char* base_s = SvPVX(PL_linestr) + offset;
 207   char* s = dd_move_past_token(aTHX_ base_s);
 208   return s - base_s;
 209 }
 210
 211 int dd_toke_scan_word(pTHX_ int offset, int handle_package) {
 212   char tmpbuf[sizeof PL_tokenbuf];
 213   char* base_s = SvPVX(PL_linestr) + offset;
 214   STRLEN len;
 215   char* s = scan_word(base_s, tmpbuf, sizeof tmpbuf, handle_package, &len);
 216   return s - base_s;
 217 }
 218
 219 int dd_toke_scan_ident(pTHX_ int offset) {
 220     char tmpbuf[sizeof PL_tokenbuf];
 221     char* base_s = SvPVX(PL_linestr) + offset;
 222     char* s = scan_ident(base_s, PL_bufend, tmpbuf, sizeof tmpbuf, 0);
 223     return s - base_s;
 224 }
 225
 226 int dd_toke_scan_str(pTHX_ int offset) {
 227   char* old_pvx = SvPVX(PL_linestr);
 228   SV* line_copy = sv_2mortal(newSVsv(PL_linestr));
 229   char* base_s = SvPVX(PL_linestr) + offset;
 230   char* s = scan_str(base_s, FALSE, FALSE);
 231   if(SvPVX(PL_linestr) != old_pvx)
 232     croak("PL_linestr reallocated during scan_str, "
 233       "Devel::Declare can't continue");
 234   if (!s)
 235     return 0;
 236   if (s <= base_s || memcmp(SvPVX(line_copy), SvPVX(PL_linestr), offset)) {
 237     s += SvCUR(line_copy);
 238     sv_catsv(line_copy, PL_linestr);
 239     dd_set_linestr(aTHX_ SvPV_nolen(line_copy));
 240   }
 241   return s - base_s;
 242 }
 243
 244 int dd_toke_skipspace(pTHX_ int offset) {
 245   char* old_pvx = SvPVX(PL_linestr);
 246   char* base_s = SvPVX(PL_linestr) + offset;
 247   char* s = skipspace_force(base_s);
 248   if(SvPVX(PL_linestr) != old_pvx)
 249     croak("PL_linestr reallocated during skipspace, "
 250       "Devel::Declare can't continue");
 251   return s - base_s;
 252 }
 253
 254 static void call_done_declare(pTHX) {
 255   dSP;
 256
 257   if (DD_DEBUG_TRACE) {
 258     printf("Deconstructing declare\n");
 259     printf("PL_bufptr: %s\n", PL_bufptr);
 260     printf("bufend at: %i\n", (int)(PL_bufend - PL_bufptr));
 261     printf("linestr: %s\n", SvPVX(PL_linestr));
 262     printf("linestr len: %i\n", (int)(PL_bufend - SvPVX(PL_linestr)));
 263   }
 264
 265   ENTER;
 266   SAVETMPS;
 267
 268   PUSHMARK(SP);
 269
 270   call_pv("Devel::Declare::done_declare", G_VOID|G_DISCARD);
 271
 272   FREETMPS;
 273   LEAVE;
 274
 275   if (DD_DEBUG_TRACE) {
 276     printf("PL_bufptr: %s\n", PL_bufptr);
 277     printf("bufend at: %i\n", (int)(PL_bufend - PL_bufptr));
 278     printf("linestr: %s\n", SvPVX(PL_linestr));
 279     printf("linestr len: %i\n", (int)(PL_bufend - SvPVX(PL_linestr)));
 280     printf("actual len: %i\n", (int)strlen(PL_bufptr));
 281   }
 282 }
 283
 284 static int dd_handle_const(pTHX_ char *name);
 285
 286 /* replacement PL_check rv2cv entry */
 287
 288 STATIC OP *dd_ck_rv2cv(pTHX_ OP *o, void *user_data) {
 289   OP* kid;
 290   int dd_flags;
 291
 292   PERL_UNUSED_VAR(user_data);
 293
 294   if (!DD_AM_LEXING)
 295     return o; /* not lexing? */
 296
 297   if (in_declare) {
 298     call_done_declare(aTHX);
 299     return o;
 300   }
 301
 302   kid = cUNOPo->op_first;
 303
 304   if (kid->op_type != OP_GV) /* not a GV so ignore */
 305     return o;
 306
 307   if (DD_DEBUG_TRACE) {
 308     printf("Checking GV %s -> %s\n", HvNAME(GvSTASH(kGVOP_gv)), GvNAME(kGVOP_gv));
 309   }
 310
 311   dd_flags = dd_is_declarator(aTHX_ GvNAME(kGVOP_gv));
 312
 313   if (dd_flags == -1)
 314     return o;
 315
 316   if (DD_DEBUG_TRACE) {
 317     printf("dd_flags are: %i\n", dd_flags);
 318     printf("PL_tokenbuf: %s\n", PL_tokenbuf);
 319   }
 320
 321 #if DD_CONST_VIA_RV2CV
 322   if (PL_expect != XOPERATOR) {
 323     if (!dd_handle_const(aTHX_ GvNAME(kGVOP_gv)))
 324       return o;
 325     CopLINE(PL_curcop) = PL_copline;
 326     /* The parser behaviour that we're simulating depends on what comes
 327        after the declarator. */
 328     if (*skipspace(PL_bufptr + strlen(GvNAME(kGVOP_gv))) != '(') {
 329       if (in_declare) {
 330         call_done_declare(aTHX);
 331       } else {
 332         dd_linestr_callback(aTHX_ "rv2cv", GvNAME(kGVOP_gv));
 333       }
 334     }
 335     return o;
 336   }
 337 #endif /* DD_CONST_VIA_RV2CV */
 338
 339   dd_linestr_callback(aTHX_ "rv2cv", GvNAME(kGVOP_gv));
 340
 341   return o;
 342 }
 343
 344 #if DD_GROW_VIA_BLOCKHOOK
 345
 346 static void dd_block_start(pTHX_ int full)
 347 {
 348   PERL_UNUSED_VAR(full);
 349   if (SvLEN(PL_linestr) < DD_PREFERRED_LINESTR_SIZE)
 350     (void) lex_grow_linestr(DD_PREFERRED_LINESTR_SIZE);
 351 }
 352
 353 #else /* !DD_GROW_VIA_BLOCKHOOK */
 354
 355 OP* dd_pp_entereval(pTHX) {
 356   dSP;
 357   STRLEN len;
 358   const char* s;
 359   SV *sv;
 360 #ifdef PERL_5_9_PLUS
 361   SV *saved_hh = NULL;
 362   if (PL_op->op_private & OPpEVAL_HAS_HH) {
 363     saved_hh = POPs;
 364   }
 365 #endif
 366   sv = POPs;
 367   if (SvPOK(sv)) {
 368     if (DD_DEBUG_TRACE) {
 369       printf("mangling eval sv\n");
 370     }
 371     if (SvREADONLY(sv))
 372       sv = sv_2mortal(newSVsv(sv));
 373     s = SvPVX(sv);
 374     len = SvCUR(sv);
 375     if (!len || s[len-1] != ';') {
 376       if (!(SvFLAGS(sv) & SVs_TEMP))
 377         sv = sv_2mortal(newSVsv(sv));
 378       sv_catpvn(sv, "\n;", 2);
 379     }
 380     SvGROW(sv, DD_PREFERRED_LINESTR_SIZE);
 381   }
 382   PUSHs(sv);
 383 #ifdef PERL_5_9_PLUS
 384   if (PL_op->op_private & OPpEVAL_HAS_HH) {
 385     PUSHs(saved_hh);
 386   }
 387 #endif
 388   return PL_ppaddr[OP_ENTEREVAL](aTHX);
 389 }
 390
 391 STATIC OP *dd_ck_entereval(pTHX_ OP *o, void *user_data) {
 392   PERL_UNUSED_VAR(user_data);
 393
 394   if (o->op_ppaddr == PL_ppaddr[OP_ENTEREVAL])
 395     o->op_ppaddr = dd_pp_entereval;
 396   return o;
 397 }
 398
 399 #endif /* !DD_GROW_VIA_BLOCKHOOK */
 400
 401 static I32 dd_filter_realloc(pTHX_ int idx, SV *sv, int maxlen)
 402 {
 403   SV *filter_datasv;
 404   const I32 count = FILTER_READ(idx+1, sv, maxlen);
 405   SvGROW(sv, DD_PREFERRED_LINESTR_SIZE);
 406   /* Filters can only be deleted in the correct order (reverse of the
 407      order in which they were added).  Insisting on deleting the filter
 408      here would break if another filter were added after ours and is
 409      still around.  Not deleting the filter at all would break if another
 410      filter were added earlier and attempts to delete itself later.
 411      We can play nicely to the maximum possible extent by deleting our
 412      filter iff it is currently deletable (i.e., it is on the top of
 413      the filter stack).  Can still run into trouble in more complex
 414      situations, but can't avoid that. */
 415   if (PL_rsfp_filters && AvFILLp(PL_rsfp_filters) >= 0 &&
 416       (filter_datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters))) &&
 417       IoANY(filter_datasv) == FPTR2DPTR(void *, dd_filter_realloc)) {
 418     filter_del(dd_filter_realloc);
 419   }
 420   return count;
 421 }
 422
 423 static int dd_handle_const(pTHX_ char *name) {
 424   switch (PL_lex_inwhat) {
 425     case OP_QR:
 426     case OP_MATCH:
 427     case OP_SUBST:
 428     case OP_TRANS:
 429     case OP_BACKTICK:
 430     case OP_STRINGIFY:
 431       return 0;
 432       break;
 433     default:
 434       break;
 435   }
 436
 437   if (strnEQ(PL_bufptr, "->", 2)) {
 438     return 0;
 439   }
 440
 441   {
 442     char buf[256];
 443     STRLEN len;
 444     char *s = PL_bufptr;
 445     STRLEN old_offset = PL_bufptr - SvPVX(PL_linestr);
 446
 447     s = scan_word(s, buf, sizeof buf, FALSE, &len);
 448     if (strnEQ(buf, name, len)) {
 449       char *d;
 450       SV *inject = newSVpvn(SvPVX(PL_linestr), PL_bufptr - SvPVX(PL_linestr));
 451       sv_catpvn(inject, buf, len);
 452
 453       d = peekspace(s);
 454       sv_catpvn(inject, s, d - s);
 455
 456       if ((PL_bufend - d) >= 2 && strnEQ(d, "=>", 2)) {
 457         return 0;
 458       }
 459
 460       sv_catpv(inject, d);
 461       dd_set_linestr(aTHX_ SvPV_nolen(inject));
 462       PL_bufptr = SvPVX(PL_linestr) + old_offset;
 463       SvREFCNT_dec (inject);
 464     }
 465   }
 466
 467   dd_linestr_callback(aTHX_ "const", name);
 468
 469   return 1;
 470 }
 471
 472 #if !DD_CONST_VIA_RV2CV
 473
 474 STATIC OP *dd_ck_const(pTHX_ OP *o, void *user_data) {
 475   int dd_flags;
 476   char* name;
 477
 478   PERL_UNUSED_VAR(user_data);
 479
 480   if (DD_HAVE_PARSER && PL_expect == XOPERATOR) {
 481     return o;
 482   }
 483
 484   /* if this is set, we just grabbed a delimited string or something,
 485      not a bareword, so NO TOUCHY */
 486
 487   if (DD_HAVE_LEX_STUFF)
 488     return o;
 489
 490   /* don't try and look this up if it's not a string const */
 491   if (!SvPOK(cSVOPo->op_sv))
 492     return o;
 493
 494   name = SvPVX(cSVOPo->op_sv);
 495
 496   dd_flags = dd_is_declarator(aTHX_ name);
 497
 498   if (dd_flags == -1)
 499     return o;
 500
 501   dd_handle_const(aTHX_ name);
 502
 503   return o;
 504 }
 505
 506 #endif /* !DD_CONST_VIA_RV2CV */
 507
 508 STATIC void dd_initialize(pTHX) {
 509   static int initialized = 0;
 510   if (!initialized) {
 511     initialized = 1;
 512 #if DD_GROW_VIA_BLOCKHOOK
 513     {
 514       static BHK bhk;
 515 #if PERL_VERSION_GE(5,13,6)
 516       BhkENTRY_set(&bhk, bhk_start, dd_block_start);
 517 #else /* <5.13.6 */
 518       BhkENTRY_set(&bhk, start, dd_block_start);
 519 #endif /* <5.13.6 */
 520       Perl_blockhook_register(aTHX_ &bhk);
 521     }
 522 #else /* !DD_GROW_VIA_BLOCKHOOK */
 523     hook_op_check(OP_ENTEREVAL, dd_ck_entereval, NULL);
 524 #endif /* !DD_GROW_VIA_BLOCKHOOK */
 525     hook_op_check(OP_RV2CV, dd_ck_rv2cv, NULL);
 526 #if !DD_CONST_VIA_RV2CV
 527     hook_op_check(OP_CONST, dd_ck_const, NULL);
 528 #endif /* !DD_CONST_VIA_RV2CV */
 529   }
 530 }
 531
 532 MODULE = Devel::Declare  PACKAGE = Devel::Declare
 533
 534 PROTOTYPES: DISABLE
 535
 536 void
 537 initialize()
 538   CODE:
 539     dd_initialize(aTHX);
 540
 541 void
 542 setup()
 543   CODE:
 544     dd_initialize(aTHX);
 545     filter_add(dd_filter_realloc, NULL);
 546
 547 char*
 548 get_linestr()
 549   CODE:
 550     RETVAL = dd_get_linestr(aTHX);
 551   OUTPUT:
 552     RETVAL
 553
 554 void
 555 set_linestr(char* new_value)
 556   CODE:
 557     dd_set_linestr(aTHX_ new_value);
 558
 559 char*
 560 get_lex_stuff()
 561   CODE:
 562     RETVAL = dd_get_lex_stuff(aTHX);
 563   OUTPUT:
 564     RETVAL
 565
 566 void
 567 clear_lex_stuff()
 568   CODE:
 569     dd_clear_lex_stuff(aTHX);
 570
 571 char*
 572 get_curstash_name()
 573   CODE:
 574     RETVAL = dd_get_curstash_name(aTHX);
 575   OUTPUT:
 576     RETVAL
 577
 578 int
 579 get_linestr_offset()
 580   CODE:
 581     RETVAL = dd_get_linestr_offset(aTHX);
 582   OUTPUT:
 583     RETVAL
 584
 585 int
 586 toke_scan_word(int offset, int handle_package)
 587   CODE:
 588     RETVAL = dd_toke_scan_word(aTHX_ offset, handle_package);
 589   OUTPUT:
 590     RETVAL
 591
 592 int
 593 toke_move_past_token(int offset);
 594   CODE:
 595     RETVAL = dd_toke_move_past_token(aTHX_ offset);
 596   OUTPUT:
 597     RETVAL
 598
 599 SV*
 600 toke_scan_str(int offset);
 601   PREINIT:
 602     int len;
 603   CODE:
 604     len = dd_toke_scan_str(aTHX_ offset);
 605     RETVAL = len ? newSViv(len) : &PL_sv_undef;
 606   OUTPUT:
 607     RETVAL
 608
 609 int
 610 toke_scan_ident(int offset)
 611   CODE:
 612     RETVAL = dd_toke_scan_ident(aTHX_ offset);
 613   OUTPUT:
 614     RETVAL
 615
 616 int
 617 toke_skipspace(int offset)
 618   CODE:
 619     RETVAL = dd_toke_skipspace(aTHX_ offset);
 620   OUTPUT:
 621     RETVAL
 622
 623 int
 624 get_in_declare()
 625   CODE:
 626     RETVAL = in_declare;
 627   OUTPUT:
 628     RETVAL
 629
 630 void
 631 set_in_declare(int value)
 632   CODE:
 633     in_declare = value;
 634
 635 BOOT:
 636 {
 637   char *endptr;
 638   char *debug_str = getenv ("DD_DEBUG");
 639   if (debug_str) {
 640     dd_debug = strtol (debug_str, &endptr, 10);
 641     if (*endptr != '\0') {
 642       dd_debug = 0;
 643     }
 644   }
 645 }