Declare.xs

   1 #define PERL_IN_TOKE_C
   2 #define PERL_CORE
   3 #define PERL_NO_GET_CONTEXT
   4 #include "EXTERN.h"
   5 #include "perl.h"
   6 #include "XSUB.h"
   7 #undef printf
   8 #include "stolen_chunk_of_toke.c"
   9 #include <stdio.h>
  10 #include <string.h>
  11
  12 #define DD_DEBUG 0
  13
  14 #ifdef DD_DEBUG
  15 #define DD_DEBUG_S printf("Buffer: %s\n", s);
  16 #else
  17 #define DD_DEBUG_S
  18 #endif
  19
  20 #define LEX_NORMAL    10
  21 #define LEX_INTERPNORMAL   9
  22
  23 /* placeholders for PL_check entries we wrap */
  24
  25 STATIC OP *(*dd_old_ck_rv2cv)(pTHX_ OP *op);
  26 STATIC OP *(*dd_old_ck_nextstate)(pTHX_ OP *op);
  27
  28 /* flag to trigger removal of temporary declaree sub */
  29
  30 static int in_declare = 0;
  31
  32 /* replacement PL_check rv2cv entry */
  33
  34 STATIC OP *dd_ck_rv2cv(pTHX_ OP *o) {
  35   OP* kid;
  36   char* s;
  37   char tmpbuf[sizeof PL_tokenbuf];
  38   STRLEN len;
  39   HV *stash;
  40   HV* is_declarator;
  41   SV** is_declarator_pack_ref;
  42   HV* is_declarator_pack_hash;
  43   SV** is_declarator_flag_ref;
  44   char* cb_args[4];
  45
  46   o = dd_old_ck_rv2cv(aTHX_ o); /* let the original do its job */
  47
  48   if (in_declare) {
  49     cb_args[0] = NULL;
  50     call_argv("Devel::Declare::done_declare", G_VOID|G_DISCARD, cb_args);
  51     in_declare = 0;
  52     return o;
  53   }
  54
  55   kid = cUNOPo->op_first;
  56
  57   if (kid->op_type != OP_GV) /* not a GV so ignore */
  58     return o;
  59
  60   if (PL_lex_state != LEX_NORMAL && PL_lex_state != LEX_INTERPNORMAL)
  61     return o; /* not lexing? */
  62
  63   stash = GvSTASH(kGVOP_gv);
  64
  65 #ifdef DD_DEBUG
  66   printf("Checking GV %s -> %s\n", HvNAME(stash), GvNAME(kGVOP_gv));
  67 #endif
  68
  69   is_declarator = get_hv("Devel::Declare::declarators", FALSE);
  70
  71   if (!is_declarator)
  72     return o;
  73
  74   is_declarator_pack_ref = hv_fetch(is_declarator, HvNAME(stash),
  75                              strlen(HvNAME(stash)), FALSE);
  76
  77   if (!is_declarator_pack_ref || !SvROK(*is_declarator_pack_ref))
  78     return o; /* not a hashref */
  79
  80   is_declarator_pack_hash = (HV*) SvRV(*is_declarator_pack_ref);
  81
  82   is_declarator_flag_ref = hv_fetch(is_declarator_pack_hash, GvNAME(kGVOP_gv),
  83                                 strlen(GvNAME(kGVOP_gv)), FALSE);
  84
  85   if (!is_declarator_flag_ref || !SvTRUE(*is_declarator_flag_ref))
  86     return o;
  87
  88   s = PL_bufptr; /* copy the current buffer pointer */
  89
  90   DD_DEBUG_S
  91
  92 #ifdef DD_DEBUG
  93   printf("PL_tokenbuf: %s", PL_tokenbuf);
  94 #endif
  95
  96   /*
  97    *   buffer will be at the beginning of the declarator, -unless- the
  98    *   declarator is at EOL in which case it'll be the next useful line
  99    *   so we don't short-circuit out if we don't find the declarator
 100    */
 101
 102   while (s < PL_bufend && isSPACE(*s)) s++;
 103   if (memEQ(s, PL_tokenbuf, strlen(PL_tokenbuf)))
 104     s += strlen(PL_tokenbuf);
 105
 106   DD_DEBUG_S
 107
 108   /* find next word */
 109
 110   s = skipspace(s);
 111
 112   DD_DEBUG_S
 113
 114   /* 0 in arg 4 is allow_package - not trying that yet :) */
 115
 116   s = scan_word(s, tmpbuf, sizeof tmpbuf, 0, &len);
 117
 118   DD_DEBUG_S
 119
 120   if (len) {
 121     cb_args[0] = HvNAME(stash);
 122     cb_args[1] = GvNAME(kGVOP_gv);
 123     cb_args[2] = tmpbuf;
 124     cb_args[3] = NULL;
 125     call_argv("Devel::Declare::init_declare", G_VOID|G_DISCARD, cb_args);
 126     in_declare = 1;
 127   }
 128
 129   return o;
 130 }
 131
 132 static int initialized = 0;
 133
 134 MODULE = Devel::Declare  PACKAGE = Devel::Declare
 135
 136 PROTOTYPES: DISABLE
 137
 138 void
 139 setup()
 140   CODE:
 141   if (!initialized++) {
 142     dd_old_ck_rv2cv = PL_check[OP_RV2CV];
 143     PL_check[OP_RV2CV] = dd_ck_rv2cv;
 144   }
 145
 146 void
 147 teardown()
 148   CODE:
 149   /* ensure we only uninit when number of teardown calls matches
 150      number of setup calls */
 151   if (initialized && !--initialized) {
 152     PL_check[OP_RV2CV] = dd_old_ck_rv2cv;
 153   }