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 HvNAME_get
  27 # define HvNAME_get(H) HvNAME(H)
  28 #endif
  29
  30 #ifndef HvNAMELEN_get
  31 # define HvNAMELEN_get(H) strlen(HvNAME_get(H))
  32 #endif
  33
  34 #ifndef SvIS_FREED
  35 # define SvIS_FREED(sv) ((sv)->sv_flags == SVTYPEMASK)
  36 #endif
  37
  38 /* ... Thread safety and multiplicity ...................................... */
  39
  40 #ifndef LT_MULTIPLICITY
  41 # if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
  42 #  define LT_MULTIPLICITY 1
  43 # else
  44 #  define LT_MULTIPLICITY 0
  45 # endif
  46 #endif
  47 #if LT_MULTIPLICITY && !defined(tTHX)
  48 # define tTHX PerlInterpreter*
  49 #endif
  50
  51 #if LT_MULTIPLICITY && defined(USE_ITHREADS) && defined(dMY_CXT) && defined(MY_CXT) && defined(START_MY_CXT) && defined(MY_CXT_INIT) && (defined(MY_CXT_CLONE) || defined(dMY_CXT_SV))
  52 # define LT_THREADSAFE 1
  53 # ifndef MY_CXT_CLONE
  54 #  define MY_CXT_CLONE \
  55     dMY_CXT_SV;                                                      \
  56     my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \
  57     Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \
  58     sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
  59 # endif
  60 #else
  61 # define LT_THREADSAFE 0
  62 #endif
  63
  64 /* --- Helpers ------------------------------------------------------------- */
  65
  66 /* ... Thread-safe hints ................................................... */
  67
  68 #if LT_THREADSAFE
  69
  70 #define PTABLE_NAME        ptable_hints
  71 #define PTABLE_VAL_FREE(V) if ((V) && !SvIS_FREED((SV *) (V))) SvREFCNT_dec(V)
  72
  73 #define pPTBL  pTHX
  74 #define pPTBL_ pTHX_
  75 #define aPTBL  aTHX
  76 #define aPTBL_ aTHX_
  77
  78 #include "ptable.h"
  79
  80 #define ptable_hints_store(T, K, V) ptable_hints_store(aTHX_ (T), (K), (V))
  81 #define ptable_hints_free(T)        ptable_hints_free(aTHX_ (T))
  82
  83 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
  84
  85 typedef struct {
  86  ptable *tbl;
  87  tTHX    owner;
  88 } my_cxt_t;
  89
  90 START_MY_CXT
  91
  92 STATIC void lt_ptable_hints_clone(pTHX_ ptable_ent *ent, void *ud_) {
  93  my_cxt_t *ud  = ud_;
  94  SV       *val = ent->val;
  95
  96  if (ud->owner != aTHX) {
  97   CLONE_PARAMS param;
  98   AV *stashes = (SvTYPE(val) == SVt_PVHV && HvNAME_get(val)) ? newAV() : NULL;
  99   param.stashes    = stashes;
 100   param.flags      = 0;
 101   param.proto_perl = ud->owner;
 102   val = sv_dup(val, &param);
 103   if (stashes) {
 104    av_undef(stashes);
 105    SvREFCNT_dec(stashes);
 106   }
 107  }
 108
 109  ptable_hints_store(ud->tbl, ent->key, val);
 110  SvREFCNT_inc(val);
 111 }
 112
 113 STATIC void lt_thread_cleanup(pTHX_ void *);
 114
 115 STATIC void lt_thread_cleanup(pTHX_ void *ud) {
 116  int *level = ud;
 117
 118  if (*level) {
 119   *level = 0;
 120   LEAVE;
 121   SAVEDESTRUCTOR_X(lt_thread_cleanup, level);
 122   ENTER;
 123  } else {
 124   dMY_CXT;
 125   PerlMemShared_free(level);
 126   ptable_hints_free(MY_CXT.tbl);
 127  }
 128 }
 129
 130 STATIC SV *lt_tag(pTHX_ SV *value) {
 131 #define lt_tag(V) lt_tag(aTHX_ (V))
 132  dMY_CXT;
 133
 134  value = SvOK(value) && SvROK(value) ? SvRV(value) : NULL;
 135  /* We only need for the key to be an unique tag for looking up the value later.
 136   * Allocated memory provides convenient unique identifiers, so that's why we
 137   * use the value pointer as the key itself. */
 138  ptable_hints_store(MY_CXT.tbl, value, value);
 139  SvREFCNT_inc(value);
 140
 141  return newSVuv(PTR2UV(value));
 142 }
 143
 144 STATIC SV *lt_detag(pTHX_ const SV *hint) {
 145 #define lt_detag(H) lt_detag(aTHX_ (H))
 146  void *tag;
 147  SV   *value;
 148
 149  if (!hint || !SvOK(hint) || !SvIOK(hint))
 150   croak("Wrong hint");
 151
 152  tag = INT2PTR(void *, SvIVX(hint));
 153  {
 154   dMY_CXT;
 155   value = ptable_fetch(MY_CXT.tbl, tag);
 156  }
 157
 158  return value;
 159 }
 160
 161 #else
 162
 163 STATIC SV *lt_tag(pTHX_ SV *value) {
 164 #define lt_tag(V) lt_tag(aTHX_ (V))
 165  UV tag = 0;
 166
 167  if (SvOK(value) && SvROK(value)) {
 168   value = SvRV(value);
 169   SvREFCNT_inc(value);
 170   tag = PTR2UV(value);
 171  }
 172
 173  return newSVuv(tag);
 174 }
 175
 176 #define lt_detag(H) INT2PTR(SV *, SvUVX(H))
 177
 178 #endif /* LT_THREADSAFE */
 179
 180 STATIC U32 lt_hash = 0;
 181
 182 STATIC SV *lt_hint(pTHX) {
 183 #define lt_hint() lt_hint(aTHX)
 184  SV *hint;
 185 #if LT_HAS_PERL(5, 9, 5)
 186  hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
 187                                        NULL,
 188                                        __PACKAGE__, __PACKAGE_LEN__,
 189                                        0,
 190                                        lt_hash);
 191 #else
 192  SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, lt_hash);
 193  if (!val)
 194   return 0;
 195  hint = *val;
 196 #endif
 197  return (hint && SvOK(hint)) ? hint : NULL;
 198 }
 199
 200 /* ... op => info map ...................................................... */
 201
 202 #define PTABLE_NAME        ptable_map
 203 #define PTABLE_VAL_FREE(V) PerlMemShared_free(V)
 204
 205 #include "ptable.h"
 206
 207 /* PerlMemShared_free() needs the [ap]PTBLMS_? default values */
 208 #define ptable_map_store(T, K, V) ptable_map_store(aPTBLMS_ (T), (K), (V))
 209
 210 STATIC ptable *lt_op_map = NULL;
 211
 212 #ifdef USE_ITHREADS
 213 STATIC perl_mutex lt_op_map_mutex;
 214 #endif
 215
 216 typedef struct {
 217  SV *orig_pkg;
 218  SV *type_pkg;
 219  SV *type_meth;
 220  OP *(*pp_padsv)(pTHX);
 221 } lt_op_info;
 222
 223 STATIC void lt_map_store(pPTBLMS_ const OP *o, SV *orig_pkg, SV *type_pkg, SV *type_meth, OP *(*pp_padsv)(pTHX)) {
 224 #define lt_map_store(O, OP, TP, TM, PP) lt_map_store(aPTBLMS_ (O), (OP), (TP), (TM), (PP))
 225  lt_op_info *oi;
 226
 227 #ifdef USE_ITHREADS
 228  MUTEX_LOCK(&lt_op_map_mutex);
 229 #endif
 230
 231  if (!(oi = ptable_fetch(lt_op_map, o))) {
 232   oi = PerlMemShared_malloc(sizeof *oi);
 233   ptable_map_store(lt_op_map, o, oi);
 234  }
 235
 236  oi->orig_pkg  = orig_pkg;
 237  oi->type_pkg  = type_pkg;
 238  oi->type_meth = type_meth;
 239  oi->pp_padsv  = pp_padsv;
 240
 241 #ifdef USE_ITHREADS
 242  MUTEX_UNLOCK(&lt_op_map_mutex);
 243 #endif
 244 }
 245
 246 STATIC const lt_op_info *lt_map_fetch(const OP *o, lt_op_info *oi) {
 247  const lt_op_info *val;
 248
 249 #ifdef USE_ITHREADS
 250  MUTEX_LOCK(&lt_op_map_mutex);
 251 #endif
 252
 253  val = ptable_fetch(lt_op_map, o);
 254  if (val) {
 255   *oi = *val;
 256   val = oi;
 257  }
 258
 259 #ifdef USE_ITHREADS
 260  MUTEX_UNLOCK(&lt_op_map_mutex);
 261 #endif
 262
 263  return val;
 264 }
 265
 266 /* --- Hooks --------------------------------------------------------------- */
 267
 268 /* ... Our pp_padsv ........................................................ */
 269
 270 STATIC OP *lt_pp_padsv(pTHX) {
 271  lt_op_info oi;
 272
 273  if ((PL_op->op_private & OPpLVAL_INTRO) && lt_map_fetch(PL_op, &oi)) {
 274   PADOFFSET targ = PL_op->op_targ;
 275   SV *sv         = PAD_SVl(targ);
 276
 277   if (sv) {
 278    int items;
 279    dSP;
 280
 281    ENTER;
 282    SAVETMPS;
 283
 284    PUSHMARK(SP);
 285    EXTEND(SP, 3);
 286    PUSHs(oi.type_pkg);
 287    PUSHs(sv);
 288    PUSHs(oi.orig_pkg);
 289    PUTBACK;
 290
 291    items = call_sv(oi.type_meth, G_ARRAY | G_METHOD);
 292
 293    SPAGAIN;
 294    switch (items) {
 295     case 0:
 296      break;
 297     case 1:
 298      sv_setsv(sv, POPs);
 299      break;
 300     default:
 301      croak("Typed scalar initializer method should return zero or one scalar, but got %d", items);
 302    }
 303    PUTBACK;
 304
 305    FREETMPS;
 306    LEAVE;
 307   }
 308
 309   return CALL_FPTR(oi.pp_padsv)(aTHX);
 310  }
 311
 312  return CALL_FPTR(PL_ppaddr[OP_PADSV])(aTHX);
 313 }
 314
 315 STATIC OP *(*lt_pp_padsv_saved)(pTHX) = 0;
 316
 317 STATIC void lt_pp_padsv_save(void) {
 318  if (lt_pp_padsv_saved)
 319   return;
 320
 321  lt_pp_padsv_saved   = PL_ppaddr[OP_PADSV];
 322  PL_ppaddr[OP_PADSV] = lt_pp_padsv;
 323 }
 324
 325 STATIC void lt_pp_padsv_restore(OP *o) {
 326  if (!lt_pp_padsv_saved)
 327   return;
 328
 329  if (o->op_ppaddr == lt_pp_padsv)
 330   o->op_ppaddr = lt_pp_padsv_saved;
 331
 332  PL_ppaddr[OP_PADSV] = lt_pp_padsv_saved;
 333  lt_pp_padsv_saved   = 0;
 334 }
 335
 336 /* ... Our ck_pad{any,sv} .................................................. */
 337
 338 /* Sadly, the PADSV OPs we are interested in don't trigger the padsv check
 339  * function, but are instead manually mutated from a PADANY. This is why we set
 340  * PL_ppaddr[OP_PADSV] in the padany check function so that PADSV OPs will have
 341  * their pp_ppaddr set to our pp_padsv. PL_ppaddr[OP_PADSV] is then reset at the
 342  * beginning of every ck_pad{any,sv}. Some unwanted OPs can still call our
 343  * pp_padsv, but much less than if we would have set PL_ppaddr[OP_PADSV]
 344  * globally. */
 345
 346 STATIC SV *lt_default_meth = NULL;
 347
 348 STATIC OP *(*lt_old_ck_padany)(pTHX_ OP *) = 0;
 349
 350 STATIC OP *lt_ck_padany(pTHX_ OP *o) {
 351  HV *stash;
 352  SV *hint;
 353
 354  lt_pp_padsv_restore(o);
 355
 356  o = CALL_FPTR(lt_old_ck_padany)(aTHX_ o);
 357
 358  stash = PL_in_my_stash;
 359  if (stash && (hint = lt_hint())) {
 360   SV *orig_pkg  = newSVpvn(HvNAME_get(stash), HvNAMELEN_get(stash));
 361   SV *orig_meth = lt_default_meth;
 362   SV *type_pkg  = NULL;
 363   SV *type_meth = NULL;
 364   SV *code      = lt_detag(hint);
 365
 366   SvREADONLY_on(orig_pkg);
 367
 368   if (code) {
 369    int items;
 370    dSP;
 371
 372    ENTER;
 373    SAVETMPS;
 374
 375    PUSHMARK(SP);
 376    EXTEND(SP, 2);
 377    PUSHs(orig_pkg);
 378    PUSHs(orig_meth);
 379    PUTBACK;
 380
 381    items = call_sv(code, G_ARRAY);
 382
 383    SPAGAIN;
 384    if (items > 2)
 385     croak(__PACKAGE__ " mangler should return zero, one or two scalars, but got %d", items);
 386    if (items == 0) {
 387     SvREFCNT_dec(orig_pkg);
 388     goto skip;
 389    } else {
 390     SV *rsv;
 391     if (items > 1) {
 392      rsv = POPs;
 393      if (SvOK(rsv)) {
 394       type_meth = newSVsv(rsv);
 395       SvREADONLY_on(type_meth);
 396      }
 397     }
 398     rsv = POPs;
 399     if (SvOK(rsv)) {
 400      type_pkg = newSVsv(rsv);
 401      SvREADONLY_on(type_pkg);
 402     }
 403    }
 404    PUTBACK;
 405
 406    FREETMPS;
 407    LEAVE;
 408   }
 409
 410   if (!type_pkg) {
 411    type_pkg = orig_pkg;
 412    SvREFCNT_inc(orig_pkg);
 413   }
 414
 415   if (!type_meth) {
 416    type_meth = orig_meth;
 417    SvREFCNT_inc(orig_meth);
 418   }
 419
 420   lt_pp_padsv_save();
 421
 422   lt_map_store(o, orig_pkg, type_pkg, type_meth, lt_pp_padsv_saved);
 423  }
 424
 425 skip:
 426  return o;
 427 }
 428
 429 STATIC OP *(*lt_old_ck_padsv)(pTHX_ OP *) = 0;
 430
 431 STATIC OP *lt_ck_padsv(pTHX_ OP *o) {
 432  lt_pp_padsv_restore(o);
 433
 434  return CALL_FPTR(lt_old_ck_padsv)(aTHX_ o);
 435 }
 436
 437 STATIC U32 lt_initialized = 0;
 438
 439 /* --- XS ------------------------------------------------------------------ */
 440
 441 MODULE = Lexical::Types      PACKAGE = Lexical::Types
 442
 443 PROTOTYPES: ENABLE
 444
 445 BOOT:
 446 {
 447  if (!lt_initialized++) {
 448   HV *stash;
 449 #if LT_THREADSAFE
 450   MY_CXT_INIT;
 451   MY_CXT.tbl   = ptable_new();
 452   MY_CXT.owner = aTHX;
 453 #endif
 454
 455   lt_op_map = ptable_new();
 456 #ifdef USE_ITHREADS
 457   MUTEX_INIT(&lt_op_map_mutex);
 458 #endif
 459
 460   lt_default_meth = newSVpvn("TYPEDSCALAR", 11);
 461   SvREADONLY_on(lt_default_meth);
 462
 463   PERL_HASH(lt_hash, __PACKAGE__, __PACKAGE_LEN__);
 464
 465   lt_old_ck_padany    = PL_check[OP_PADANY];
 466   PL_check[OP_PADANY] = MEMBER_TO_FPTR(lt_ck_padany);
 467   lt_old_ck_padsv     = PL_check[OP_PADSV];
 468   PL_check[OP_PADSV]  = MEMBER_TO_FPTR(lt_ck_padsv);
 469
 470   stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
 471   newCONSTSUB(stash, "LT_THREADSAFE", newSVuv(LT_THREADSAFE));
 472  }
 473 }
 474
 475 #if LT_THREADSAFE
 476
 477 void
 478 CLONE(...)
 479 PROTOTYPE: DISABLE
 480 PREINIT:
 481  ptable *t;
 482  int    *level;
 483 CODE:
 484  {
 485   my_cxt_t ud;
 486   dMY_CXT;
 487   ud.tbl   = t = ptable_new();
 488   ud.owner = MY_CXT.owner;
 489   ptable_walk(MY_CXT.tbl, lt_ptable_hints_clone, &ud);
 490  }
 491  {
 492   MY_CXT_CLONE;
 493   MY_CXT.tbl   = t;
 494   MY_CXT.owner = aTHX;
 495  }
 496  {
 497   level = PerlMemShared_malloc(sizeof *level);
 498   *level = 1;
 499   LEAVE;
 500   SAVEDESTRUCTOR_X(lt_thread_cleanup, level);
 501   ENTER;
 502  }
 503
 504 #endif
 505
 506 SV *
 507 _tag(SV *value)
 508 PROTOTYPE: $
 509 CODE:
 510  RETVAL = lt_tag(value);
 511 OUTPUT:
 512  RETVAL