Types.xs

   1 /* This file is part of the Lexical-Types Perl module.
   2  * See http://search.cpan.org/dist/Lexical-Types/ */
   3
   4 #define PERL_NO_GET_CONTEXT
   5 #include "EXTERN.h"
   6 #include "perl.h"
   7 #include "XSUB.h"
   8
   9 #define __PACKAGE__     "Lexical::Types"
  10 #define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1)
  11
  12 /* --- Compatibility wrappers ---------------------------------------------- */
  13
  14 #define LT_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
  15
  16 #if LT_HAS_PERL(5, 10, 0) || defined(PL_parser)
  17 # ifndef PL_in_my_stash
  18 #  define PL_in_my_stash PL_parser->in_my_stash
  19 # endif
  20 #else
  21 # ifndef PL_in_my_stash
  22 #  define PL_in_my_stash PL_Iin_my_stash
  23 # endif
  24 #endif
  25
  26 #ifndef Newx
  27 # define Newx(v, n, c) New(0, v, n, c)
  28 #endif
  29
  30 #ifndef HvNAME_get
  31 # define HvNAME_get(H) HvNAME(H)
  32 #endif
  33
  34 #ifndef HvNAMELEN_get
  35 # define HvNAMELEN_get(H) strlen(HvNAME_get(H))
  36 #endif
  37
  38 /* --- Helpers ------------------------------------------------------------- */
  39
  40 /* ... Hints ............................................................... */
  41
  42 STATIC U32 lt_hash = 0;
  43
  44 STATIC SV *lt_hint(pTHX) {
  45 #define lt_hint() lt_hint(aTHX)
  46  SV *id;
  47 #if LT_HAS_PERL(5, 10, 0)
  48  id = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
  49                                      NULL,
  50                                      __PACKAGE__, __PACKAGE_LEN__,
  51                                      0,
  52                                      lt_hash);
  53 #else
  54  SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, lt_hash);
  55  if (!val)
  56   return 0;
  57  id = *val;
  58 #endif
  59  return (id && SvOK(id)) ? id : NULL;
  60 }
  61
  62 /* ... op => info map ...................................................... */
  63
  64 #define OP2STR_BUF char buf[(CHAR_BIT * sizeof(UV)) / 2]
  65 #define OP2STR(O)  (sprintf(buf, "%"UVxf, PTR2UV(O)))
  66
  67 STATIC HV *lt_op_map = NULL;
  68
  69 typedef struct {
  70  SV *orig_pkg;
  71  SV *type_pkg;
  72  SV *type_meth;
  73  OP *(*pp_padsv)(pTHX);
  74 } lt_op_info;
  75
  76 STATIC void lt_map_store(pTHX_ const OP *o, SV *orig_pkg, SV *type_pkg, SV *type_meth, OP *(*pp_padsv)(pTHX)) {
  77 #define lt_map_store(O, P1, P2, M, PP) lt_map_store(aTHX_ (O), (P1), (P2), (M), (PP))
  78  OP2STR_BUF;
  79  SV *val;
  80  lt_op_info *oi;
  81
  82  Newx(oi, 1, lt_op_info);
  83  oi->orig_pkg  = orig_pkg;
  84  oi->type_pkg  = type_pkg;
  85  oi->type_meth = type_meth;
  86  oi->pp_padsv  = pp_padsv;
  87  val = newSVuv(PTR2UV(oi));
  88
  89  (void)hv_store(lt_op_map, buf, OP2STR(o), val, 0);
  90 }
  91
  92 STATIC const lt_op_info *lt_map_fetch(pTHX_ const OP *o) {
  93 #define lt_map_fetch(O) lt_map_fetch(aTHX_ (O))
  94  OP2STR_BUF;
  95  SV **svp;
  96
  97  svp = hv_fetch(lt_op_map, buf, OP2STR(o), 0);
  98
  99  return svp ? INT2PTR(const lt_op_info *, SvUVX(*svp)) : NULL;
 100 }
 101
 102 /* --- Hooks --------------------------------------------------------------- */
 103
 104 /* ... Our pp_padsv ........................................................ */
 105
 106 STATIC OP *lt_pp_padsv(pTHX) {
 107  const lt_op_info *oi;
 108
 109  if ((PL_op->op_private & OPpLVAL_INTRO) && (oi = lt_map_fetch(PL_op))) {
 110   PADOFFSET targ = PL_op->op_targ;
 111   SV *sv         = PAD_SVl(targ);
 112
 113   if (sv) {
 114    int items;
 115    dSP;
 116
 117    ENTER;
 118    SAVETMPS;
 119
 120    PUSHMARK(SP);
 121    EXTEND(SP, 3);
 122    PUSHs(oi->type_pkg);
 123    PUSHs(sv);
 124    PUSHs(oi->orig_pkg);
 125    PUTBACK;
 126
 127    items = call_sv(oi->type_meth, G_ARRAY | G_METHOD);
 128
 129    SPAGAIN;
 130    switch (items) {
 131     case 0:
 132      break;
 133     case 1:
 134      sv_setsv(sv, POPs);
 135      break;
 136     default:
 137      croak("Typed scalar initializer method should return zero or one scalar, but got %d", items);
 138    }
 139    PUTBACK;
 140
 141    FREETMPS;
 142    LEAVE;
 143   }
 144
 145   return CALL_FPTR(oi->pp_padsv)(aTHX);
 146  }
 147
 148  return CALL_FPTR(PL_ppaddr[OP_PADSV])(aTHX);
 149 }
 150
 151 STATIC OP *(*lt_pp_padsv_saved)(pTHX) = 0;
 152
 153 STATIC void lt_pp_padsv_save(void) {
 154  if (lt_pp_padsv_saved)
 155   return;
 156
 157  lt_pp_padsv_saved   = PL_ppaddr[OP_PADSV];
 158  PL_ppaddr[OP_PADSV] = lt_pp_padsv;
 159 }
 160
 161 STATIC void lt_pp_padsv_restore(OP *o) {
 162  if (!lt_pp_padsv_saved)
 163   return;
 164
 165  if (o->op_ppaddr == lt_pp_padsv)
 166   o->op_ppaddr = lt_pp_padsv_saved;
 167
 168  PL_ppaddr[OP_PADSV] = lt_pp_padsv_saved;
 169  lt_pp_padsv_saved   = 0;
 170 }
 171
 172 /* ... Our ck_pad{any,sv} .................................................. */
 173
 174 /* Sadly, the PADSV OPs we are interested in don't trigger the padsv check
 175  * function, but are instead manually mutated from a PADANY. This is why we set
 176  * PL_ppaddr[OP_PADSV] in the padany check function so that PADSV OPs will have
 177  * their pp_ppaddr set to our pp_padsv. PL_ppaddr[OP_PADSV] is then reset at the
 178  * beginning of every ck_pad{any,sv}. Some unwanted OPs can still call our
 179  * pp_padsv, but much less than if we would have set PL_ppaddr[OP_PADSV]
 180  * globally. */
 181
 182 STATIC SV *lt_default_meth = NULL;
 183
 184 STATIC OP *(*lt_old_ck_padany)(pTHX_ OP *) = 0;
 185
 186 STATIC OP *lt_ck_padany(pTHX_ OP *o) {
 187  HV *stash;
 188  SV *hint;
 189
 190  lt_pp_padsv_restore(o);
 191
 192  o = CALL_FPTR(lt_old_ck_padany)(aTHX_ o);
 193
 194  stash = PL_in_my_stash;
 195  if (stash && (hint = lt_hint())) {
 196   SV *orig_pkg  = newSVpvn(HvNAME_get(stash), HvNAMELEN_get(stash));
 197   SV *orig_meth = lt_default_meth;
 198   SV *type_pkg  = orig_pkg;
 199   SV *type_meth = orig_meth;
 200   SV *code      = INT2PTR(SV *, SvUVX(hint));
 201
 202   SvREADONLY_on(orig_pkg);
 203
 204   if (code) {
 205    int items;
 206    dSP;
 207
 208    ENTER;
 209    SAVETMPS;
 210
 211    PUSHMARK(SP);
 212    EXTEND(SP, 2);
 213    PUSHs(orig_pkg);
 214    PUSHs(orig_meth);
 215    PUTBACK;
 216
 217    items = call_sv(code, G_ARRAY);
 218
 219    SPAGAIN;
 220    if (items > 2)
 221     croak(__PACKAGE__ " mangler should return zero, one or two scalars, but got %d", items);
 222    if (items == 0) {
 223     SvREFCNT_dec(orig_pkg);
 224     goto skip;
 225    } else {
 226     SV *rsv;
 227     if (items > 1) {
 228      rsv = POPs;
 229      if (SvOK(rsv)) {
 230       type_meth = newSVsv(rsv);
 231       SvREADONLY_on(type_meth);
 232      }
 233     }
 234     rsv = POPs;
 235     if (SvOK(rsv)) {
 236      type_pkg = newSVsv(rsv);
 237      SvREADONLY_on(type_pkg);
 238     }
 239    }
 240    PUTBACK;
 241
 242    FREETMPS;
 243    LEAVE;
 244   }
 245
 246   if (type_meth == orig_meth)
 247    SvREFCNT_inc(orig_meth);
 248
 249   lt_pp_padsv_save();
 250
 251   lt_map_store(o, orig_pkg, type_pkg, type_meth, lt_pp_padsv_saved);
 252  }
 253
 254 skip:
 255  return o;
 256 }
 257
 258 STATIC OP *(*lt_old_ck_padsv)(pTHX_ OP *) = 0;
 259
 260 STATIC OP *lt_ck_padsv(pTHX_ OP *o) {
 261  lt_pp_padsv_restore(o);
 262
 263  return CALL_FPTR(lt_old_ck_padsv)(aTHX_ o);
 264 }
 265
 266 STATIC U32 lt_initialized = 0;
 267
 268 /* --- XS ------------------------------------------------------------------ */
 269
 270 MODULE = Lexical::Types      PACKAGE = Lexical::Types
 271
 272 PROTOTYPES: DISABLE
 273
 274 BOOT:
 275 {
 276  if (!lt_initialized++) {
 277   lt_default_meth = newSVpvn("TYPEDSCALAR", 11);
 278   SvREADONLY_on(lt_default_meth);
 279
 280   PERL_HASH(lt_hash, __PACKAGE__, __PACKAGE_LEN__);
 281   lt_op_map = newHV();
 282
 283   lt_old_ck_padany    = PL_check[OP_PADANY];
 284   PL_check[OP_PADANY] = MEMBER_TO_FPTR(lt_ck_padany);
 285   lt_old_ck_padsv     = PL_check[OP_PADSV];
 286   PL_check[OP_PADSV]  = MEMBER_TO_FPTR(lt_ck_padsv);
 287  }
 288 }
 289
 290 SV *_tag(SV *ref)
 291 PREINIT:
 292  SV *ret;
 293 CODE:
 294  if (SvOK(ref) && SvROK(ref)) {
 295   SV *sv = SvRV(ref);
 296   SvREFCNT_inc(sv);
 297   ret = newSVuv(PTR2UV(sv));
 298  } else {
 299   ret = newSVuv(0);
 300  }
 301  RETVAL = ret;
 302 OUTPUT:
 303  RETVAL