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