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 /* --- Compatibility wrappers ---------------------------------------------- */
  10
  11 #define LT_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
  12
  13 #if LT_HAS_PERL(5, 10, 0) || defined(PL_parser)
  14 # ifndef PL_in_my_stash
  15 #  define PL_in_my_stash PL_parser->in_my_stash
  16 # endif
  17 #else
  18 # ifndef PL_in_my_stash
  19 #  define PL_in_my_stash PL_Iin_my_stash
  20 # endif
  21 #endif
  22
  23 #ifndef Newx
  24 # define Newx(v, n, c) New(0, v, n, c)
  25 #endif
  26
  27 #ifndef HvNAME_get
  28 # define HvNAME_get(H) HvNAME(H)
  29 #endif
  30
  31 #ifndef HvNAMELEN_get
  32 # define HvNAMELEN_get(H) strlen(HvNAME_get(H))
  33 #endif
  34
  35 #define __PACKAGE__     "Lexical::Types"
  36 #define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1)
  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_old_pp_padsv)(pTHX) = 0;
 107
 108 STATIC OP *lt_pp_padsv(pTHX) {
 109  const lt_op_info *oi;
 110
 111  if ((PL_op->op_private & OPpLVAL_INTRO) && (oi = lt_map_fetch(PL_op))) {
 112   PADOFFSET targ = PL_op->op_targ;
 113   SV *sv         = PAD_SVl(targ);
 114
 115   if (sv) {
 116    int items;
 117    dSP;
 118
 119    ENTER;
 120    SAVETMPS;
 121
 122    PUSHMARK(SP);
 123    EXTEND(SP, 3);
 124    PUSHs(oi->type_pkg);
 125    PUSHs(sv);
 126    PUSHs(oi->orig_pkg);
 127    PUTBACK;
 128
 129    items = call_sv(oi->type_meth, G_ARRAY | G_METHOD);
 130
 131    SPAGAIN;
 132    switch (items) {
 133     case 0:
 134      break;
 135     case 1:
 136      sv_setsv(sv, POPs);
 137      break;
 138     default:
 139      croak("Typed scalar initializer method should return zero or one scalar, but got %d", items);
 140    }
 141    PUTBACK;
 142
 143    FREETMPS;
 144    LEAVE;
 145   }
 146
 147   return CALL_FPTR(oi->pp_padsv)(aTHX);
 148  }
 149
 150  return CALL_FPTR(lt_old_pp_padsv)(aTHX);
 151 }
 152
 153 /* ... Our ck_pad{any,sv} .................................................. */
 154
 155 /* Sadly, the PADSV OPs we are interested in don't trigger the padsv check
 156  * function, but are instead manually mutated from a PADANY. This is why we set
 157  * PL_ppaddr[OP_PADSV] in the padany check function so that PADSV OPs will have
 158  * their pp_ppaddr set to our pp_padsv. PL_ppaddr[OP_PADSV] is then reset at the
 159  * beginning of every ck_pad{any,sv}. Some unwanted OPs can still call our
 160  * pp_padsv, but much less than if we would have set PL_ppaddr[OP_PADSV]
 161  * globally. */
 162
 163 STATIC SV *lt_default_meth = NULL;
 164
 165 STATIC OP *(*lt_old_ck_padany)(pTHX_ OP *) = 0;
 166
 167 STATIC OP *lt_ck_padany(pTHX_ OP *o) {
 168  HV *stash;
 169  SV *hint;
 170
 171  PL_ppaddr[OP_PADSV] = lt_old_pp_padsv;
 172
 173  o = CALL_FPTR(lt_old_ck_padany)(aTHX_ o);
 174
 175  stash = PL_in_my_stash;
 176  if (stash && (hint = lt_hint())) {
 177   SV *orig_pkg  = newSVpvn(HvNAME_get(stash), HvNAMELEN_get(stash));
 178   SV *orig_meth = lt_default_meth;
 179   SV *type_pkg  = orig_pkg;
 180   SV *type_meth = orig_meth;
 181   SV *code      = INT2PTR(SV *, SvUVX(hint));
 182
 183   SvREADONLY_on(orig_pkg);
 184
 185   if (code) {
 186    int items;
 187    dSP;
 188
 189    ENTER;
 190    SAVETMPS;
 191
 192    PUSHMARK(SP);
 193    EXTEND(SP, 2);
 194    PUSHs(orig_pkg);
 195    PUSHs(orig_meth);
 196    PUTBACK;
 197
 198    items = call_sv(code, G_ARRAY);
 199
 200    SPAGAIN;
 201    if (items > 2)
 202     croak(__PACKAGE__ " mangler should return zero, one or two scalars, but got %d", items);
 203    if (items == 0) {
 204     SvREFCNT_dec(orig_pkg);
 205     goto skip;
 206    } else {
 207     SV *rsv;
 208     if (items > 1) {
 209      rsv = POPs;
 210      if (SvOK(rsv)) {
 211       type_meth = newSVsv(rsv);
 212       SvREADONLY_on(type_meth);
 213      }
 214     }
 215     rsv = POPs;
 216     if (SvOK(rsv)) {
 217      type_pkg = newSVsv(rsv);
 218      SvREADONLY_on(type_pkg);
 219     }
 220    }
 221    PUTBACK;
 222
 223    FREETMPS;
 224    LEAVE;
 225   }
 226
 227   if (type_meth == orig_meth)
 228    SvREFCNT_inc(orig_meth);
 229   lt_map_store(o, orig_pkg, type_pkg, type_meth, lt_old_pp_padsv);
 230
 231   lt_old_pp_padsv     = PL_ppaddr[OP_PADSV];
 232   PL_ppaddr[OP_PADSV] = lt_pp_padsv;
 233  }
 234
 235 skip:
 236  return o;
 237 }
 238
 239 STATIC OP *(*lt_old_ck_padsv)(pTHX_ OP *) = 0;
 240
 241 STATIC OP *lt_ck_padsv(pTHX_ OP *o) {
 242  PL_ppaddr[OP_PADSV] = lt_old_pp_padsv;
 243  return CALL_FPTR(lt_old_ck_padsv)(aTHX_ o);
 244 }
 245
 246 STATIC U32 lt_initialized = 0;
 247
 248 /* --- XS ------------------------------------------------------------------ */
 249
 250 MODULE = Lexical::Types      PACKAGE = Lexical::Types
 251
 252 PROTOTYPES: DISABLE
 253
 254 BOOT:
 255 {
 256  if (!lt_initialized++) {
 257   lt_default_meth = newSVpvn("TYPEDSCALAR", 11);
 258   SvREADONLY_on(lt_default_meth);
 259
 260   PERL_HASH(lt_hash, __PACKAGE__, __PACKAGE_LEN__);
 261   lt_op_map = newHV();
 262
 263   lt_old_ck_padany    = PL_check[OP_PADANY];
 264   PL_check[OP_PADANY] = MEMBER_TO_FPTR(lt_ck_padany);
 265   lt_old_ck_padsv     = PL_check[OP_PADSV];
 266   PL_check[OP_PADSV]  = MEMBER_TO_FPTR(lt_ck_padsv);
 267   lt_old_pp_padsv     = PL_ppaddr[OP_PADSV];
 268  }
 269 }
 270
 271 SV *_tag(SV *ref)
 272 PREINIT:
 273  SV *ret;
 274 CODE:
 275  if (SvOK(ref) && SvROK(ref)) {
 276   SV *sv = SvRV(ref);
 277   SvREFCNT_inc(sv);
 278   ret = newSVuv(PTR2UV(sv));
 279  } else {
 280   ret = newSVuv(0);
 281  }
 282  RETVAL = ret;
 283 OUTPUT:
 284  RETVAL