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