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 STATIC void lt_map_delete(pTHX_ const OP *o) {
 267 #define lt_map_delete(O) lt_map_delete(aTHX_ (O))
 268 #ifdef USE_ITHREADS
 269  MUTEX_LOCK(&lt_op_map_mutex);
 270 #endif
 271
 272  ptable_map_store(lt_op_map, o, NULL);
 273
 274 #ifdef USE_ITHREADS
 275  MUTEX_UNLOCK(&lt_op_map_mutex);
 276 #endif
 277 }
 278
 279 /* --- Hooks --------------------------------------------------------------- */
 280
 281 /* ... Our pp_padsv ........................................................ */
 282
 283 STATIC OP *lt_pp_padsv(pTHX) {
 284  lt_op_info oi;
 285
 286  if ((PL_op->op_private & OPpLVAL_INTRO) && lt_map_fetch(PL_op, &oi)) {
 287   PADOFFSET targ = PL_op->op_targ;
 288   SV *sv         = PAD_SVl(targ);
 289
 290   if (sv) {
 291    int items;
 292    dSP;
 293
 294    ENTER;
 295    SAVETMPS;
 296
 297    PUSHMARK(SP);
 298    EXTEND(SP, 3);
 299    PUSHs(oi.type_pkg);
 300    PUSHs(sv);
 301    PUSHs(oi.orig_pkg);
 302    PUTBACK;
 303
 304    items = call_sv(oi.type_meth, G_ARRAY | G_METHOD);
 305
 306    SPAGAIN;
 307    switch (items) {
 308     case 0:
 309      break;
 310     case 1:
 311      sv_setsv(sv, POPs);
 312      break;
 313     default:
 314      croak("Typed scalar initializer method should return zero or one scalar, but got %d", items);
 315    }
 316    PUTBACK;
 317
 318    FREETMPS;
 319    LEAVE;
 320   }
 321
 322   return CALL_FPTR(oi.pp_padsv)(aTHX);
 323  }
 324
 325  return CALL_FPTR(PL_ppaddr[OP_PADSV])(aTHX);
 326 }
 327
 328 STATIC OP *(*lt_pp_padsv_saved)(pTHX) = 0;
 329
 330 STATIC void lt_pp_padsv_save(void) {
 331  if (lt_pp_padsv_saved)
 332   return;
 333
 334  lt_pp_padsv_saved   = PL_ppaddr[OP_PADSV];
 335  PL_ppaddr[OP_PADSV] = lt_pp_padsv;
 336 }
 337
 338 STATIC void lt_pp_padsv_restore(OP *o) {
 339  if (!lt_pp_padsv_saved)
 340   return;
 341
 342  if (o->op_ppaddr == lt_pp_padsv)
 343   o->op_ppaddr = lt_pp_padsv_saved;
 344
 345  PL_ppaddr[OP_PADSV] = lt_pp_padsv_saved;
 346  lt_pp_padsv_saved   = 0;
 347 }
 348
 349 /* ... Our ck_pad{any,sv} .................................................. */
 350
 351 /* Sadly, the PADSV OPs we are interested in don't trigger the padsv check
 352  * function, but are instead manually mutated from a PADANY. This is why we set
 353  * PL_ppaddr[OP_PADSV] in the padany check function so that PADSV OPs will have
 354  * their pp_ppaddr set to our pp_padsv. PL_ppaddr[OP_PADSV] is then reset at the
 355  * beginning of every ck_pad{any,sv}. Some unwanted OPs can still call our
 356  * pp_padsv, but much less than if we would have set PL_ppaddr[OP_PADSV]
 357  * globally. */
 358
 359 STATIC SV *lt_default_meth = NULL;
 360
 361 STATIC OP *(*lt_old_ck_padany)(pTHX_ OP *) = 0;
 362
 363 STATIC OP *lt_ck_padany(pTHX_ OP *o) {
 364  HV *stash;
 365  SV *hint;
 366
 367  lt_pp_padsv_restore(o);
 368
 369  o = CALL_FPTR(lt_old_ck_padany)(aTHX_ o);
 370
 371  stash = PL_in_my_stash;
 372  if (stash && (hint = lt_hint())) {
 373   SV *orig_pkg  = newSVpvn(HvNAME_get(stash), HvNAMELEN_get(stash));
 374   SV *orig_meth = lt_default_meth;
 375   SV *type_pkg  = NULL;
 376   SV *type_meth = NULL;
 377   SV *code      = lt_detag(hint);
 378
 379   SvREADONLY_on(orig_pkg);
 380
 381   if (code) {
 382    int items;
 383    dSP;
 384
 385    ENTER;
 386    SAVETMPS;
 387
 388    PUSHMARK(SP);
 389    EXTEND(SP, 2);
 390    PUSHs(orig_pkg);
 391    PUSHs(orig_meth);
 392    PUTBACK;
 393
 394    items = call_sv(code, G_ARRAY);
 395
 396    SPAGAIN;
 397    if (items > 2)
 398     croak(__PACKAGE__ " mangler should return zero, one or two scalars, but got %d", items);
 399    if (items == 0) {
 400     SvREFCNT_dec(orig_pkg);
 401     goto skip;
 402    } else {
 403     SV *rsv;
 404     if (items > 1) {
 405      rsv = POPs;
 406      if (SvOK(rsv)) {
 407       type_meth = newSVsv(rsv);
 408       SvREADONLY_on(type_meth);
 409      }
 410     }
 411     rsv = POPs;
 412     if (SvOK(rsv)) {
 413      type_pkg = newSVsv(rsv);
 414      SvREADONLY_on(type_pkg);
 415     }
 416    }
 417    PUTBACK;
 418
 419    FREETMPS;
 420    LEAVE;
 421   }
 422
 423   if (!type_pkg) {
 424    type_pkg = orig_pkg;
 425    SvREFCNT_inc(orig_pkg);
 426   }
 427
 428   if (!type_meth) {
 429    type_meth = orig_meth;
 430    SvREFCNT_inc(orig_meth);
 431   }
 432
 433   lt_pp_padsv_save();
 434
 435   lt_map_store(o, orig_pkg, type_pkg, type_meth, lt_pp_padsv_saved);
 436  } else {
 437 skip:
 438   lt_map_delete(o);
 439  }
 440
 441  return o;
 442 }
 443
 444 STATIC OP *(*lt_old_ck_padsv)(pTHX_ OP *) = 0;
 445
 446 STATIC OP *lt_ck_padsv(pTHX_ OP *o) {
 447  lt_pp_padsv_restore(o);
 448
 449  lt_map_delete(o);
 450
 451  return CALL_FPTR(lt_old_ck_padsv)(aTHX_ o);
 452 }
 453
 454 STATIC U32 lt_initialized = 0;
 455
 456 /* --- XS ------------------------------------------------------------------ */
 457
 458 MODULE = Lexical::Types      PACKAGE = Lexical::Types
 459
 460 PROTOTYPES: ENABLE
 461
 462 BOOT:
 463 {
 464  if (!lt_initialized++) {
 465   HV *stash;
 466 #if LT_THREADSAFE
 467   MY_CXT_INIT;
 468   MY_CXT.tbl   = ptable_new();
 469   MY_CXT.owner = aTHX;
 470 #endif
 471
 472   lt_op_map = ptable_new();
 473 #ifdef USE_ITHREADS
 474   MUTEX_INIT(&lt_op_map_mutex);
 475 #endif
 476
 477   lt_default_meth = newSVpvn("TYPEDSCALAR", 11);
 478   SvREADONLY_on(lt_default_meth);
 479
 480   PERL_HASH(lt_hash, __PACKAGE__, __PACKAGE_LEN__);
 481
 482   lt_old_ck_padany    = PL_check[OP_PADANY];
 483   PL_check[OP_PADANY] = MEMBER_TO_FPTR(lt_ck_padany);
 484   lt_old_ck_padsv     = PL_check[OP_PADSV];
 485   PL_check[OP_PADSV]  = MEMBER_TO_FPTR(lt_ck_padsv);
 486
 487   stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
 488   newCONSTSUB(stash, "LT_THREADSAFE", newSVuv(LT_THREADSAFE));
 489  }
 490 }
 491
 492 #if LT_THREADSAFE
 493
 494 void
 495 CLONE(...)
 496 PROTOTYPE: DISABLE
 497 PREINIT:
 498  ptable *t;
 499  int    *level;
 500 CODE:
 501  {
 502   my_cxt_t ud;
 503   dMY_CXT;
 504   ud.tbl   = t = ptable_new();
 505   ud.owner = MY_CXT.owner;
 506   ptable_walk(MY_CXT.tbl, lt_ptable_hints_clone, &ud);
 507  }
 508  {
 509   MY_CXT_CLONE;
 510   MY_CXT.tbl   = t;
 511   MY_CXT.owner = aTHX;
 512  }
 513  {
 514   level = PerlMemShared_malloc(sizeof *level);
 515   *level = 1;
 516   LEAVE;
 517   SAVEDESTRUCTOR_X(lt_thread_cleanup, level);
 518   ENTER;
 519  }
 520
 521 #endif
 522
 523 SV *
 524 _tag(SV *value)
 525 PROTOTYPE: $
 526 CODE:
 527  RETVAL = lt_tag(value);
 528 OUTPUT:
 529  RETVAL