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(sv_2mortal(newSVsv(oi->type_pkg)));
 125    PUSHs(sv);
 126    PUSHs(sv_2mortal(newSVsv(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 U32 lt_TYPEDSCALAR_hash = 0;
 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 = newSVpvn_share("TYPEDSCALAR", 11, lt_TYPEDSCALAR_hash);
 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   SvREADONLY_on(orig_meth);
 185
 186   if (code) {
 187    int items;
 188    dSP;
 189
 190    ENTER;
 191    SAVETMPS;
 192
 193    PUSHMARK(SP);
 194    EXTEND(SP, 2);
 195    PUSHs(orig_pkg);
 196    PUSHs(orig_meth);
 197    PUTBACK;
 198
 199    items = call_sv(code, G_ARRAY);
 200
 201    SPAGAIN;
 202    if (items > 2)
 203     croak(__PACKAGE__ " mangler should return zero, one or two scalars, but got %d", items);
 204    if (items) {
 205     SV *rsv;
 206     if (items > 1) {
 207      rsv = POPs;
 208      if (SvOK(rsv))
 209       type_meth = newSVsv(rsv);
 210     }
 211     rsv = POPs;
 212     if (SvOK(rsv))
 213      type_pkg = newSVsv(rsv);
 214    }
 215    PUTBACK;
 216
 217    FREETMPS;
 218    LEAVE;
 219   }
 220
 221   lt_old_pp_padsv     = PL_ppaddr[OP_PADSV];
 222   lt_map_store(o, orig_pkg, type_pkg, type_meth, lt_old_pp_padsv);
 223   PL_ppaddr[OP_PADSV] = lt_pp_padsv;
 224  }
 225
 226  return o;
 227 }
 228
 229 STATIC OP *(*lt_old_ck_padsv)(pTHX_ OP *) = 0;
 230
 231 STATIC OP *lt_ck_padsv(pTHX_ OP *o) {
 232  PL_ppaddr[OP_PADSV] = lt_old_pp_padsv;
 233  return CALL_FPTR(lt_old_ck_padsv)(aTHX_ o);
 234 }
 235
 236 STATIC U32 lt_initialized = 0;
 237
 238 /* --- XS ------------------------------------------------------------------ */
 239
 240 MODULE = Lexical::Types      PACKAGE = Lexical::Types
 241
 242 PROTOTYPES: DISABLE
 243
 244 BOOT:
 245 {
 246  if (!lt_initialized++) {
 247   PERL_HASH(lt_TYPEDSCALAR_hash, "TYPEDSCALAR", 11);
 248
 249   PERL_HASH(lt_hash, __PACKAGE__, __PACKAGE_LEN__);
 250   lt_op_map = newHV();
 251
 252   lt_old_ck_padany    = PL_check[OP_PADANY];
 253   PL_check[OP_PADANY] = MEMBER_TO_FPTR(lt_ck_padany);
 254   lt_old_ck_padsv     = PL_check[OP_PADSV];
 255   PL_check[OP_PADSV]  = MEMBER_TO_FPTR(lt_ck_padsv);
 256   lt_old_pp_padsv     = PL_ppaddr[OP_PADSV];
 257  }
 258 }
 259
 260 SV *_tag(SV *ref)
 261 PREINIT:
 262  SV *ret;
 263 CODE:
 264  if (SvOK(ref) && SvROK(ref)) {
 265   SV *sv = SvRV(ref);
 266   SvREFCNT_inc(sv);
 267   ret = newSVuv(PTR2UV(sv));
 268  } else {
 269   ret = newSVuv(0);
 270  }
 271  RETVAL = ret;
 272 OUTPUT:
 273  RETVAL