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 LEX_NORMAL    10
  13 #define LEX_INTERPNORMAL   9
  14
  15 /* placeholders for PL_check entries we wrap */
  16
  17 STATIC OP *(*dd_old_ck_rv2cv)(pTHX_ OP *op);
  18 STATIC OP *(*dd_old_ck_nextstate)(pTHX_ OP *op);
  19
  20 /* flag to trigger removal of temporary declaree sub */
  21
  22 static int in_declare = 0;
  23
  24 /* replacement PL_check rv2cv entry */
  25
  26 STATIC OP *dd_ck_rv2cv(pTHX_ OP *o) {
  27   OP* kid;
  28   char* s;
  29   char tmpbuf[sizeof PL_tokenbuf];
  30   STRLEN len;
  31   HV *stash;
  32   HV* is_declarator;
  33   SV** is_declarator_pack_ref;
  34   HV* is_declarator_pack_hash;
  35   SV** is_declarator_flag_ref;
  36   char* cb_args[4];
  37
  38   o = dd_old_ck_rv2cv(aTHX_ o); /* let the original do its job */
  39
  40   if (in_declare) {
  41     cb_args[0] = NULL;
  42     call_argv("Devel::Declare::done_declare", G_VOID|G_DISCARD, cb_args);
  43     in_declare = 0;
  44     return o;
  45   }
  46
  47   kid = cUNOPo->op_first;
  48
  49   if (kid->op_type != OP_GV) /* not a GV so ignore */
  50     return o;
  51
  52   if (PL_lex_state != LEX_NORMAL && PL_lex_state != LEX_INTERPNORMAL)
  53     return o; /* not lexing? */
  54
  55   stash = GvSTASH(kGVOP_gv);
  56
  57   /* printf("Checking GV %s -> %s\n", HvNAME(stash), GvNAME(kGVOP_gv)); */
  58
  59   is_declarator = get_hv("Devel::Declare::declarators", FALSE);
  60
  61   if (!is_declarator)
  62     return o;
  63
  64   is_declarator_pack_ref = hv_fetch(is_declarator, HvNAME(stash),
  65                              strlen(HvNAME(stash)), FALSE);
  66
  67   if (!is_declarator_pack_ref || !SvROK(*is_declarator_pack_ref))
  68     return o; /* not a hashref */
  69
  70   is_declarator_pack_hash = (HV*) SvRV(*is_declarator_pack_ref);
  71
  72   is_declarator_flag_ref = hv_fetch(is_declarator_pack_hash, GvNAME(kGVOP_gv),
  73                                 strlen(GvNAME(kGVOP_gv)), FALSE);
  74
  75   if (!is_declarator_flag_ref || !SvTRUE(*is_declarator_flag_ref))
  76     return o;
  77
  78   s = PL_bufptr; /* copy the current buffer pointer */
  79
  80   while (s < PL_bufend && isSPACE(*s)) s++;
  81   if (memEQ(s, PL_tokenbuf, strlen(PL_tokenbuf)))
  82     s += strlen(PL_tokenbuf);
  83   else
  84     return o;
  85
  86   /* find next word */
  87
  88   s = skipspace(s);
  89
  90   /* 0 in arg 4 is allow_package - not trying that yet :) */
  91
  92   s = scan_word(s, tmpbuf, sizeof tmpbuf, 0, &len);
  93
  94   if (len) {
  95     cb_args[0] = HvNAME(stash);
  96     cb_args[1] = GvNAME(kGVOP_gv);
  97     cb_args[2] = tmpbuf;
  98     cb_args[3] = NULL;
  99     call_argv("Devel::Declare::init_declare", G_VOID|G_DISCARD, cb_args);
 100     in_declare = 1;
 101   }
 102
 103   return o;
 104 }
 105
 106 static int initialized = 0;
 107
 108 MODULE = Devel::Declare  PACKAGE = Devel::Declare
 109
 110 PROTOTYPES: DISABLE
 111
 112 void
 113 setup()
 114   CODE:
 115   if (!initialized++) {
 116     dd_old_ck_rv2cv = PL_check[OP_RV2CV];
 117     PL_check[OP_RV2CV] = dd_ck_rv2cv;
 118   }
 119
 120 void
 121 teardown()
 122   CODE:
 123   /* ensure we only uninit when number of teardown calls matches
 124      number of setup calls */
 125   if (initialized && !--initialized) {
 126     PL_check[OP_RV2CV] = dd_old_ck_rv2cv;
 127   }