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 PTABLE_VAL_FREE(V) PerlMemShared_free(V)
  65
  66 #include "ptable.h"
  67
  68 STATIC ptable *lt_op_map = NULL;
  69
  70 typedef struct {
  71  SV *orig_pkg;
  72  SV *type_pkg;
  73  SV *type_meth;
  74  OP *(*pp_padsv)(pTHX);
  75 } lt_op_info;
  76
  77 STATIC void lt_map_store(const OP *o, SV *orig_pkg, SV *type_pkg, SV *type_meth, OP *(*pp_padsv)(pTHX)) {
  78  lt_op_info *oi = ptable_fetch(lt_op_map, o);
  79
  80  if (!oi) {
  81   oi = PerlMemShared_malloc(sizeof *oi);
  82   ptable_store(lt_op_map, o, oi);
  83  }
  84
  85  oi->orig_pkg  = orig_pkg;
  86  oi->type_pkg  = type_pkg;
  87  oi->type_meth = type_meth;
  88  oi->pp_padsv  = pp_padsv;
  89 }
  90
  91 STATIC const lt_op_info *lt_map_fetch(const OP *o) {
  92  const lt_op_info *oi;
  93
  94  oi = ptable_fetch(lt_op_map, o);
  95
  96  return oi;
  97 }
  98
  99 /* --- Hooks --------------------------------------------------------------- */
 100
 101 /* ... Our pp_padsv ........................................................ */
 102
 103 STATIC OP *lt_pp_padsv(pTHX) {
 104  const lt_op_info *oi;
 105
 106  if ((PL_op->op_private & OPpLVAL_INTRO) && (oi = lt_map_fetch(PL_op))) {
 107   PADOFFSET targ = PL_op->op_targ;
 108   SV *sv         = PAD_SVl(targ);
 109
 110   if (sv) {
 111    int items;
 112    dSP;
 113
 114    ENTER;
 115    SAVETMPS;
 116
 117    PUSHMARK(SP);
 118    EXTEND(SP, 3);
 119    PUSHs(oi->type_pkg);
 120    PUSHs(sv);
 121    PUSHs(oi->orig_pkg);
 122    PUTBACK;
 123
 124    items = call_sv(oi->type_meth, G_ARRAY | G_METHOD);
 125
 126    SPAGAIN;
 127    switch (items) {
 128     case 0:
 129      break;
 130     case 1:
 131      sv_setsv(sv, POPs);
 132      break;
 133     default:
 134      croak("Typed scalar initializer method should return zero or one scalar, but got %d", items);
 135    }
 136    PUTBACK;
 137
 138    FREETMPS;
 139    LEAVE;
 140   }
 141
 142   return CALL_FPTR(oi->pp_padsv)(aTHX);
 143  }
 144
 145  return CALL_FPTR(PL_ppaddr[OP_PADSV])(aTHX);
 146 }
 147
 148 STATIC OP *(*lt_pp_padsv_saved)(pTHX) = 0;
 149
 150 STATIC void lt_pp_padsv_save(void) {
 151  if (lt_pp_padsv_saved)
 152   return;
 153
 154  lt_pp_padsv_saved   = PL_ppaddr[OP_PADSV];
 155  PL_ppaddr[OP_PADSV] = lt_pp_padsv;
 156 }
 157
 158 STATIC void lt_pp_padsv_restore(OP *o) {
 159  if (!lt_pp_padsv_saved)
 160   return;
 161
 162  if (o->op_ppaddr == lt_pp_padsv)
 163   o->op_ppaddr = lt_pp_padsv_saved;
 164
 165  PL_ppaddr[OP_PADSV] = lt_pp_padsv_saved;
 166  lt_pp_padsv_saved   = 0;
 167 }
 168
 169 /* ... Our ck_pad{any,sv} .................................................. */
 170
 171 /* Sadly, the PADSV OPs we are interested in don't trigger the padsv check
 172  * function, but are instead manually mutated from a PADANY. This is why we set
 173  * PL_ppaddr[OP_PADSV] in the padany check function so that PADSV OPs will have
 174  * their pp_ppaddr set to our pp_padsv. PL_ppaddr[OP_PADSV] is then reset at the
 175  * beginning of every ck_pad{any,sv}. Some unwanted OPs can still call our
 176  * pp_padsv, but much less than if we would have set PL_ppaddr[OP_PADSV]
 177  * globally. */
 178
 179 STATIC SV *lt_default_meth = NULL;
 180
 181 STATIC OP *(*lt_old_ck_padany)(pTHX_ OP *) = 0;
 182
 183 STATIC OP *lt_ck_padany(pTHX_ OP *o) {
 184  HV *stash;
 185  SV *hint;
 186
 187  lt_pp_padsv_restore(o);
 188
 189  o = CALL_FPTR(lt_old_ck_padany)(aTHX_ o);
 190
 191  stash = PL_in_my_stash;
 192  if (stash && (hint = lt_hint())) {
 193   SV *orig_pkg  = newSVpvn(HvNAME_get(stash), HvNAMELEN_get(stash));
 194   SV *orig_meth = lt_default_meth;
 195   SV *type_pkg  = NULL;
 196   SV *type_meth = NULL;
 197   SV *code      = INT2PTR(SV *, SvUVX(hint));
 198
 199   SvREADONLY_on(orig_pkg);
 200
 201   if (code) {
 202    int items;
 203    dSP;
 204
 205    ENTER;
 206    SAVETMPS;
 207
 208    PUSHMARK(SP);
 209    EXTEND(SP, 2);
 210    PUSHs(orig_pkg);
 211    PUSHs(orig_meth);
 212    PUTBACK;
 213
 214    items = call_sv(code, G_ARRAY);
 215
 216    SPAGAIN;
 217    if (items > 2)
 218     croak(__PACKAGE__ " mangler should return zero, one or two scalars, but got %d", items);
 219    if (items == 0) {
 220     SvREFCNT_dec(orig_pkg);
 221     goto skip;
 222    } else {
 223     SV *rsv;
 224     if (items > 1) {
 225      rsv = POPs;
 226      if (SvOK(rsv)) {
 227       type_meth = newSVsv(rsv);
 228       SvREADONLY_on(type_meth);
 229      }
 230     }
 231     rsv = POPs;
 232     if (SvOK(rsv)) {
 233      type_pkg = newSVsv(rsv);
 234      SvREADONLY_on(type_pkg);
 235     }
 236    }
 237    PUTBACK;
 238
 239    FREETMPS;
 240    LEAVE;
 241   }
 242
 243   if (!type_pkg) {
 244    type_pkg = orig_pkg;
 245    SvREFCNT_inc(orig_pkg);
 246   }
 247
 248   if (!type_meth) {
 249    type_meth = orig_meth;
 250    SvREFCNT_inc(orig_meth);
 251   }
 252
 253   lt_pp_padsv_save();
 254
 255   lt_map_store(o, orig_pkg, type_pkg, type_meth, lt_pp_padsv_saved);
 256  }
 257
 258 skip:
 259  return o;
 260 }
 261
 262 STATIC OP *(*lt_old_ck_padsv)(pTHX_ OP *) = 0;
 263
 264 STATIC OP *lt_ck_padsv(pTHX_ OP *o) {
 265  lt_pp_padsv_restore(o);
 266
 267  return CALL_FPTR(lt_old_ck_padsv)(aTHX_ o);
 268 }
 269
 270 STATIC U32 lt_initialized = 0;
 271
 272 /* --- XS ------------------------------------------------------------------ */
 273
 274 MODULE = Lexical::Types      PACKAGE = Lexical::Types
 275
 276 PROTOTYPES: DISABLE
 277
 278 BOOT:
 279 {
 280  if (!lt_initialized++) {
 281   lt_op_map = ptable_new();
 282
 283   lt_default_meth = newSVpvn("TYPEDSCALAR", 11);
 284   SvREADONLY_on(lt_default_meth);
 285
 286   PERL_HASH(lt_hash, __PACKAGE__, __PACKAGE_LEN__);
 287
 288   lt_old_ck_padany    = PL_check[OP_PADANY];
 289   PL_check[OP_PADANY] = MEMBER_TO_FPTR(lt_ck_padany);
 290   lt_old_ck_padsv     = PL_check[OP_PADSV];
 291   PL_check[OP_PADSV]  = MEMBER_TO_FPTR(lt_ck_padsv);
 292  }
 293 }
 294
 295 SV *_tag(SV *ref)
 296 PREINIT:
 297  SV *ret;
 298 CODE:
 299  if (SvOK(ref) && SvROK(ref)) {
 300   SV *sv = SvRV(ref);
 301   SvREFCNT_inc(sv);
 302   ret = newSVuv(PTR2UV(sv));
 303  } else {
 304   ret = newSVuv(0);
 305  }
 306  RETVAL = ret;
 307 OUTPUT:
 308  RETVAL