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 LT_WORKAROUND_REQUIRE_PROPAGATION
  27 # define LT_WORKAROUND_REQUIRE_PROPAGATION !LT_HAS_PERL(5, 10, 1)
  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 #ifndef SvREFCNT_inc_simple_NN
  39 # define SvREFCNT_inc_simple_NN SvREFCNT_inc
  40 #endif
  41
  42 #undef ENTERn
  43 #if defined(ENTER_with_name) && !LT_HAS_PERL(5, 11, 4)
  44 # define ENTERn(N) ENTER_with_name(N)
  45 #else
  46 # define ENTERn(N) ENTER
  47 #endif
  48
  49 #undef LEAVEn
  50 #if defined(LEAVE_with_name) && !LT_HAS_PERL(5, 11, 4)
  51 # define LEAVEn(N) LEAVE_with_name(N)
  52 #else
  53 # define LEAVEn(N) LEAVE
  54 #endif
  55
  56 /* ... Thread safety and multiplicity ...................................... */
  57
  58 #ifndef LT_MULTIPLICITY
  59 # if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
  60 #  define LT_MULTIPLICITY 1
  61 # else
  62 #  define LT_MULTIPLICITY 0
  63 # endif
  64 #endif
  65 #if LT_MULTIPLICITY && !defined(tTHX)
  66 # define tTHX PerlInterpreter*
  67 #endif
  68
  69 #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))
  70 # define LT_THREADSAFE 1
  71 # ifndef MY_CXT_CLONE
  72 #  define MY_CXT_CLONE \
  73     dMY_CXT_SV;                                                      \
  74     my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \
  75     Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \
  76     sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
  77 # endif
  78 #else
  79 # define LT_THREADSAFE 0
  80 # undef  dMY_CXT
  81 # define dMY_CXT      dNOOP
  82 # undef  MY_CXT
  83 # define MY_CXT       lt_globaldata
  84 # undef  START_MY_CXT
  85 # define START_MY_CXT STATIC my_cxt_t MY_CXT;
  86 # undef  MY_CXT_INIT
  87 # define MY_CXT_INIT  NOOP
  88 # undef  MY_CXT_CLONE
  89 # define MY_CXT_CLONE NOOP
  90 # undef  pMY_CXT
  91 # define pMY_CXT
  92 # undef  pMY_CXT_
  93 # define pMY_CXT_
  94 # undef  aMY_CXT
  95 # define aMY_CXT
  96 # undef  aMY_CXT_
  97 # define aMY_CXT_
  98 #endif
  99
 100 /* --- Helpers ------------------------------------------------------------- */
 101
 102 /* ... Thread-safe hints ................................................... */
 103
 104 #if LT_WORKAROUND_REQUIRE_PROPAGATION
 105
 106 typedef struct {
 107  SV *code;
 108  IV  cxreq;
 109 } lt_hint_t;
 110
 111 #define LT_HINT_STRUCT 1
 112
 113 #define LT_HINT_CODE(H) ((H)->code)
 114
 115 #define LT_HINT_FREE(H) { \
 116  lt_hint_t *h = (H);      \
 117  SvREFCNT_dec(h->code);   \
 118  PerlMemShared_free(h);   \
 119 }
 120
 121 #else  /*  LT_WORKAROUND_REQUIRE_PROPAGATION */
 122
 123 typedef SV lt_hint_t;
 124
 125 #define LT_HINT_STRUCT 0
 126
 127 #define LT_HINT_CODE(H) (H)
 128
 129 #define LT_HINT_FREE(H) SvREFCNT_dec(H);
 130
 131 #endif /* !LT_WORKAROUND_REQUIRE_PROPAGATION */
 132
 133 #if LT_THREADSAFE
 134
 135 #define PTABLE_NAME        ptable_hints
 136 #define PTABLE_VAL_FREE(V) LT_HINT_FREE(V)
 137
 138 #define pPTBL  pTHX
 139 #define pPTBL_ pTHX_
 140 #define aPTBL  aTHX
 141 #define aPTBL_ aTHX_
 142
 143 #include "ptable.h"
 144
 145 #define ptable_hints_store(T, K, V) ptable_hints_store(aTHX_ (T), (K), (V))
 146 #define ptable_hints_free(T)        ptable_hints_free(aTHX_ (T))
 147
 148 #endif /* LT_THREADSAFE */
 149
 150 /* ... Global data ......................................................... */
 151
 152 #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
 153
 154 typedef struct {
 155 #if LT_THREADSAFE
 156  ptable *tbl; /* It really is a ptable_hints */
 157  tTHX    owner;
 158 #endif
 159  SV     *default_meth;
 160  OP *  (*pp_padsv_saved)(pTHX);
 161 } my_cxt_t;
 162
 163 START_MY_CXT
 164
 165 /* ... Cloning global data ................................................. */
 166
 167 #if LT_THREADSAFE
 168
 169 STATIC SV *lt_clone(pTHX_ SV *sv, tTHX owner) {
 170 #define lt_clone(S, O) lt_clone(aTHX_ (S), (O))
 171  CLONE_PARAMS  param;
 172  AV           *stashes = NULL;
 173  SV           *dupsv;
 174
 175  if (SvTYPE(sv) == SVt_PVHV && HvNAME_get(sv))
 176   stashes = newAV();
 177
 178  param.stashes    = stashes;
 179  param.flags      = 0;
 180  param.proto_perl = owner;
 181
 182  dupsv = sv_dup(sv, &param);
 183
 184  if (stashes) {
 185   av_undef(stashes);
 186   SvREFCNT_dec(stashes);
 187  }
 188
 189  return SvREFCNT_inc(dupsv);
 190 }
 191
 192 STATIC void lt_ptable_hints_clone(pTHX_ ptable_ent *ent, void *ud_) {
 193  my_cxt_t  *ud  = ud_;
 194  lt_hint_t *h1 = ent->val;
 195  lt_hint_t *h2;
 196
 197  if (ud->owner == aTHX)
 198   return;
 199
 200 #if LT_HINT_STRUCT
 201
 202  h2        = PerlMemShared_malloc(sizeof *h2);
 203  h2->code  = lt_clone(h1->code, ud->owner);
 204  SvREFCNT_inc(h2->code);
 205 #if LT_WORKAROUND_REQUIRE_PROPAGATION
 206  h2->cxreq = h1->cxreq;
 207 #endif
 208
 209 #else /*   LT_HINT_STRUCT */
 210
 211  h2 = lt_clone(h1, ud->owner);
 212  SvREFCNT_inc(h2);
 213
 214 #endif /* !LT_HINT_STRUCT */
 215
 216  ptable_hints_store(ud->tbl, ent->key, h2);
 217 }
 218
 219 #include "reap.h"
 220
 221 STATIC void lt_thread_cleanup(pTHX_ void *ud) {
 222  dMY_CXT;
 223
 224  ptable_hints_free(MY_CXT.tbl);
 225 }
 226
 227 #endif /* LT_THREADSAFE */
 228
 229 /* ... Hint tags ........................................................... */
 230
 231 #if LT_WORKAROUND_REQUIRE_PROPAGATION
 232 STATIC IV lt_require_tag(pTHX) {
 233 #define lt_require_tag() lt_require_tag(aTHX)
 234  const PERL_SI *si;
 235
 236  for (si = PL_curstackinfo; si; si = si->si_prev) {
 237   I32 cxix;
 238
 239   for (cxix = si->si_cxix; cxix >= 0; --cxix) {
 240    const PERL_CONTEXT *cx = si->si_cxstack + cxix;
 241
 242    if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_REQUIRE)
 243     return PTR2IV(cx);
 244   }
 245  }
 246
 247  return PTR2IV(NULL);
 248 }
 249 #endif /* LT_WORKAROUND_REQUIRE_PROPAGATION */
 250
 251 STATIC SV *lt_tag(pTHX_ SV *value) {
 252 #define lt_tag(V) lt_tag(aTHX_ (V))
 253  lt_hint_t *h;
 254  SV *code = NULL;
 255  dMY_CXT;
 256
 257  if (SvROK(value)) {
 258   value = SvRV(value);
 259   if (SvTYPE(value) >= SVt_PVCV) {
 260    code = value;
 261    SvREFCNT_inc_simple_NN(code);
 262   }
 263  }
 264
 265 #if LT_HINT_STRUCT
 266  h = PerlMemShared_malloc(sizeof *h);
 267  h->code  = code;
 268 # if LT_WORKAROUND_REQUIRE_PROPAGATION
 269  h->cxreq = lt_require_tag();
 270 # endif /* LT_WORKAROUND_REQUIRE_PROPAGATION */
 271 #else  /*  LT_HINT_STRUCT */
 272  h = code;
 273 #endif /* !LT_HINT_STRUCT */
 274
 275 #if LT_THREADSAFE
 276  /* We only need for the key to be an unique tag for looking up the value later.
 277   * Allocated memory provides convenient unique identifiers, so that's why we
 278   * use the hint as the key itself. */
 279  ptable_hints_store(MY_CXT.tbl, h, h);
 280 #endif /* LT_THREADSAFE */
 281
 282  return newSViv(PTR2IV(h));
 283 }
 284
 285 STATIC SV *lt_detag(pTHX_ const SV *hint) {
 286 #define lt_detag(H) lt_detag(aTHX_ (H))
 287  lt_hint_t *h;
 288  dMY_CXT;
 289
 290  if (!(hint && SvIOK(hint)))
 291   return NULL;
 292
 293  h = INT2PTR(lt_hint_t *, SvIVX(hint));
 294 #if LT_THREADSAFE
 295  h = ptable_fetch(MY_CXT.tbl, h);
 296 #endif /* LT_THREADSAFE */
 297 #if LT_WORKAROUND_REQUIRE_PROPAGATION
 298  if (lt_require_tag() != h->cxreq)
 299   return NULL;
 300 #endif /* LT_WORKAROUND_REQUIRE_PROPAGATION */
 301
 302  return LT_HINT_CODE(h);
 303 }
 304
 305 STATIC U32 lt_hash = 0;
 306
 307 STATIC SV *lt_hint(pTHX) {
 308 #define lt_hint() lt_hint(aTHX)
 309  SV *hint;
 310 #if LT_HAS_PERL(5, 9, 5)
 311  hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
 312                                        NULL,
 313                                        __PACKAGE__, __PACKAGE_LEN__,
 314                                        0,
 315                                        lt_hash);
 316 #else
 317  SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, lt_hash);
 318  if (!val)
 319   return 0;
 320  hint = *val;
 321 #endif
 322  return lt_detag(hint);
 323 }
 324
 325 /* ... op => info map ...................................................... */
 326
 327 #define PTABLE_NAME        ptable_map
 328 #define PTABLE_VAL_FREE(V) PerlMemShared_free(V)
 329
 330 #include "ptable.h"
 331
 332 /* PerlMemShared_free() needs the [ap]PTBLMS_? default values */
 333 #define ptable_map_store(T, K, V) ptable_map_store(aPTBLMS_ (T), (K), (V))
 334
 335 STATIC ptable *lt_op_map = NULL;
 336
 337 #ifdef USE_ITHREADS
 338 STATIC perl_mutex lt_op_map_mutex;
 339 #endif
 340
 341 typedef struct {
 342 #ifdef MULTIPLICITY
 343  STRLEN buf_size, orig_pkg_len, type_pkg_len, type_meth_len;
 344  char *buf;
 345 #else /* MULTIPLICITY */
 346  SV *orig_pkg;
 347  SV *type_pkg;
 348  SV *type_meth;
 349 #endif /* !MULTIPLICITY */
 350  OP *(*old_pp_padsv)(pTHX);
 351 } lt_op_info;
 352
 353 STATIC void lt_map_store(pTHX_ const OP *o, SV *orig_pkg, SV *type_pkg, SV *type_meth, OP *(*old_pp_padsv)(pTHX)) {
 354 #define lt_map_store(O, OP, TP, TM, PP) lt_map_store(aTHX_ (O), (OP), (TP), (TM), (PP))
 355  lt_op_info *oi;
 356
 357 #ifdef USE_ITHREADS
 358  MUTEX_LOCK(&lt_op_map_mutex);
 359 #endif
 360
 361  if (!(oi = ptable_fetch(lt_op_map, o))) {
 362   oi = PerlMemShared_malloc(sizeof *oi);
 363   ptable_map_store(lt_op_map, o, oi);
 364 #ifdef MULTIPLICITY
 365   oi->buf      = NULL;
 366   oi->buf_size = 0;
 367 #else /* MULTIPLICITY */
 368  } else {
 369   SvREFCNT_dec(oi->orig_pkg);
 370   SvREFCNT_dec(oi->type_pkg);
 371   SvREFCNT_dec(oi->type_meth);
 372 #endif /* !MULTIPLICITY */
 373  }
 374
 375 #ifdef MULTIPLICITY
 376  {
 377   STRLEN op_len       = SvCUR(orig_pkg);
 378   STRLEN tp_len       = SvCUR(type_pkg);
 379   STRLEN tm_len       = SvCUR(type_meth);
 380   STRLEN new_buf_size = op_len + tp_len + tm_len;
 381   char *buf;
 382   if (new_buf_size > oi->buf_size) {
 383    PerlMemShared_free(oi->buf);
 384    oi->buf      = PerlMemShared_malloc(new_buf_size);
 385    oi->buf_size = new_buf_size;
 386   }
 387   buf  = oi->buf;
 388   Copy(SvPVX(orig_pkg),  buf, op_len, char);
 389   buf += op_len;
 390   Copy(SvPVX(type_pkg),  buf, tp_len, char);
 391   buf += tp_len;
 392   Copy(SvPVX(type_meth), buf, tm_len, char);
 393   oi->orig_pkg_len  = op_len;
 394   oi->type_pkg_len  = tp_len;
 395   oi->type_meth_len = tm_len;
 396   SvREFCNT_dec(orig_pkg);
 397   SvREFCNT_dec(type_pkg);
 398   SvREFCNT_dec(type_meth);
 399  }
 400 #else /* MULTIPLICITY */
 401  oi->orig_pkg  = orig_pkg;
 402  oi->type_pkg  = type_pkg;
 403  oi->type_meth = type_meth;
 404 #endif /* !MULTIPLICITY */
 405
 406  oi->old_pp_padsv = old_pp_padsv;
 407
 408 #ifdef USE_ITHREADS
 409  MUTEX_UNLOCK(&lt_op_map_mutex);
 410 #endif
 411 }
 412
 413 STATIC const lt_op_info *lt_map_fetch(const OP *o, lt_op_info *oi) {
 414  const lt_op_info *val;
 415
 416 #ifdef USE_ITHREADS
 417  MUTEX_LOCK(&lt_op_map_mutex);
 418 #endif
 419
 420  val = ptable_fetch(lt_op_map, o);
 421  if (val) {
 422   *oi = *val;
 423   val = oi;
 424  }
 425
 426 #ifdef USE_ITHREADS
 427  MUTEX_UNLOCK(&lt_op_map_mutex);
 428 #endif
 429
 430  return val;
 431 }
 432
 433 STATIC void lt_map_delete(pTHX_ const OP *o) {
 434 #define lt_map_delete(O) lt_map_delete(aTHX_ (O))
 435 #ifdef USE_ITHREADS
 436  MUTEX_LOCK(&lt_op_map_mutex);
 437 #endif
 438
 439  ptable_map_store(lt_op_map, o, NULL);
 440
 441 #ifdef USE_ITHREADS
 442  MUTEX_UNLOCK(&lt_op_map_mutex);
 443 #endif
 444 }
 445
 446 /* --- Hooks --------------------------------------------------------------- */
 447
 448 /* ... Our pp_padsv ........................................................ */
 449
 450 STATIC OP *lt_pp_padsv(pTHX) {
 451  lt_op_info oi;
 452
 453  if ((PL_op->op_private & OPpLVAL_INTRO) && lt_map_fetch(PL_op, &oi)) {
 454   PADOFFSET targ = PL_op->op_targ;
 455   SV *sv         = PAD_SVl(targ);
 456
 457   if (sv) {
 458    SV *orig_pkg, *type_pkg, *type_meth;
 459    int items;
 460    dSP;
 461
 462    ENTER;
 463    SAVETMPS;
 464
 465 #ifdef MULTIPLICITY
 466    {
 467     STRLEN op_len = oi.orig_pkg_len, tp_len = oi.type_pkg_len;
 468     char *buf = oi.buf;
 469     orig_pkg  = sv_2mortal(newSVpvn(buf, op_len));
 470     SvREADONLY_on(orig_pkg);
 471     buf      += op_len;
 472     type_pkg  = sv_2mortal(newSVpvn(buf, tp_len));
 473     SvREADONLY_on(type_pkg);
 474     buf      += tp_len;
 475     type_meth = sv_2mortal(newSVpvn(buf, oi.type_meth_len));
 476     SvREADONLY_on(type_meth);
 477    }
 478 #else /* MULTIPLICITY */
 479    orig_pkg  = oi.orig_pkg;
 480    type_pkg  = oi.type_pkg;
 481    type_meth = oi.type_meth;
 482 #endif /* !MULTIPLICITY */
 483
 484    PUSHMARK(SP);
 485    EXTEND(SP, 3);
 486    PUSHs(type_pkg);
 487    PUSHs(sv);
 488    PUSHs(orig_pkg);
 489    PUTBACK;
 490
 491    items = call_sv(type_meth, G_ARRAY | G_METHOD);
 492
 493    SPAGAIN;
 494    switch (items) {
 495     case 0:
 496      break;
 497     case 1:
 498      sv_setsv(sv, POPs);
 499      break;
 500     default:
 501      croak("Typed scalar initializer method should return zero or one scalar, but got %d", items);
 502    }
 503    PUTBACK;
 504
 505    FREETMPS;
 506    LEAVE;
 507   }
 508
 509   return CALL_FPTR(oi.old_pp_padsv)(aTHX);
 510  }
 511
 512  return CALL_FPTR(PL_ppaddr[OP_PADSV])(aTHX);
 513 }
 514
 515 STATIC void lt_pp_padsv_save(pMY_CXT) {
 516 #define lt_pp_padsv_save() lt_pp_padsv_save(aMY_CXT)
 517  if (MY_CXT.pp_padsv_saved)
 518   return;
 519
 520  MY_CXT.pp_padsv_saved = PL_ppaddr[OP_PADSV];
 521  PL_ppaddr[OP_PADSV]   = lt_pp_padsv;
 522 }
 523
 524 STATIC void lt_pp_padsv_restore(pMY_CXT_ OP *o) {
 525 #define lt_pp_padsv_restore(O) lt_pp_padsv_restore(aMY_CXT_ (O))
 526  OP *(*saved)(pTHX) = MY_CXT.pp_padsv_saved;
 527
 528  if (!saved)
 529   return;
 530
 531  if (o->op_ppaddr == lt_pp_padsv)
 532   o->op_ppaddr = saved;
 533
 534  PL_ppaddr[OP_PADSV]   = saved;
 535  MY_CXT.pp_padsv_saved = 0;
 536 }
 537
 538 /* ... Our ck_pad{any,sv} .................................................. */
 539
 540 /* Sadly, the PADSV OPs we are interested in don't trigger the padsv check
 541  * function, but are instead manually mutated from a PADANY. This is why we set
 542  * PL_ppaddr[OP_PADSV] in the padany check function so that PADSV OPs will have
 543  * their pp_ppaddr set to our pp_padsv. PL_ppaddr[OP_PADSV] is then reset at the
 544  * beginning of every ck_pad{any,sv}. Some unwanted OPs can still call our
 545  * pp_padsv, but much less than if we would have set PL_ppaddr[OP_PADSV]
 546  * globally. */
 547
 548 STATIC OP *(*lt_old_ck_padany)(pTHX_ OP *) = 0;
 549
 550 STATIC OP *lt_ck_padany(pTHX_ OP *o) {
 551  HV *stash;
 552  SV *code;
 553  dMY_CXT;
 554
 555  lt_pp_padsv_restore(o);
 556
 557  o = CALL_FPTR(lt_old_ck_padany)(aTHX_ o);
 558
 559  stash = PL_in_my_stash;
 560  if (stash && (code = lt_hint())) {
 561   SV *orig_pkg  = newSVpvn(HvNAME_get(stash), HvNAMELEN_get(stash));
 562   SV *orig_meth = MY_CXT.default_meth;
 563   SV *type_pkg  = NULL;
 564   SV *type_meth = NULL;
 565   int items;
 566
 567   dSP;
 568
 569   SvREADONLY_on(orig_pkg);
 570
 571   ENTER;
 572   SAVETMPS;
 573
 574   PUSHMARK(SP);
 575   EXTEND(SP, 2);
 576   PUSHs(orig_pkg);
 577   PUSHs(orig_meth);
 578   PUTBACK;
 579
 580   items = call_sv(code, G_ARRAY);
 581
 582   SPAGAIN;
 583   if (items > 2)
 584    croak(__PACKAGE__ " mangler should return zero, one or two scalars, but got %d", items);
 585   if (items == 0) {
 586    SvREFCNT_dec(orig_pkg);
 587    FREETMPS;
 588    LEAVE;
 589    goto skip;
 590   } else {
 591    SV *rsv;
 592    if (items > 1) {
 593     rsv = POPs;
 594     if (SvOK(rsv)) {
 595      type_meth = newSVsv(rsv);
 596      SvREADONLY_on(type_meth);
 597     }
 598    }
 599    rsv = POPs;
 600    if (SvOK(rsv)) {
 601     type_pkg = newSVsv(rsv);
 602     SvREADONLY_on(type_pkg);
 603    }
 604   }
 605   PUTBACK;
 606
 607   FREETMPS;
 608   LEAVE;
 609
 610   if (!type_pkg) {
 611    type_pkg = orig_pkg;
 612    SvREFCNT_inc(orig_pkg);
 613   }
 614
 615   if (!type_meth) {
 616    type_meth = orig_meth;
 617    SvREFCNT_inc(orig_meth);
 618   }
 619
 620   lt_pp_padsv_save();
 621
 622   lt_map_store(o, orig_pkg, type_pkg, type_meth, MY_CXT.pp_padsv_saved);
 623  } else {
 624 skip:
 625   lt_map_delete(o);
 626  }
 627
 628  return o;
 629 }
 630
 631 STATIC OP *(*lt_old_ck_padsv)(pTHX_ OP *) = 0;
 632
 633 STATIC OP *lt_ck_padsv(pTHX_ OP *o) {
 634  dMY_CXT;
 635
 636  lt_pp_padsv_restore(o);
 637
 638  lt_map_delete(o);
 639
 640  return CALL_FPTR(lt_old_ck_padsv)(aTHX_ o);
 641 }
 642
 643 STATIC U32 lt_initialized = 0;
 644
 645 STATIC void lt_teardown(pTHX_ void *root) {
 646  dMY_CXT;
 647
 648  if (!lt_initialized)
 649   return;
 650
 651 #if LT_MULTIPLICITY
 652  if (aTHX != root)
 653   return;
 654 #endif
 655
 656 #if LT_THREADSAFE
 657  ptable_hints_free(MY_CXT.tbl);
 658 #endif
 659  SvREFCNT_dec(MY_CXT.default_meth);
 660
 661  PL_check[OP_PADANY] = MEMBER_TO_FPTR(lt_old_ck_padany);
 662  lt_old_ck_padany    = 0;
 663  PL_check[OP_PADSV]  = MEMBER_TO_FPTR(lt_old_ck_padsv);
 664  lt_old_ck_padsv     = 0;
 665
 666  lt_initialized = 0;
 667 }
 668
 669 STATIC void lt_setup(pTHX) {
 670 #define lt_setup() lt_setup(aTHX)
 671  if (lt_initialized)
 672   return;
 673
 674  {
 675   MY_CXT_INIT;
 676 #if LT_THREADSAFE
 677   MY_CXT.tbl            = ptable_new();
 678   MY_CXT.owner          = aTHX;
 679 #endif
 680   MY_CXT.pp_padsv_saved = 0;
 681   MY_CXT.default_meth   = newSVpvn("TYPEDSCALAR", 11);
 682   SvREADONLY_on(MY_CXT.default_meth);
 683  }
 684
 685  lt_old_ck_padany    = PL_check[OP_PADANY];
 686  PL_check[OP_PADANY] = MEMBER_TO_FPTR(lt_ck_padany);
 687  lt_old_ck_padsv     = PL_check[OP_PADSV];
 688  PL_check[OP_PADSV]  = MEMBER_TO_FPTR(lt_ck_padsv);
 689
 690 #if LT_MULTIPLICITY
 691  call_atexit(lt_teardown, aTHX);
 692 #else
 693  call_atexit(lt_teardown, NULL);
 694 #endif
 695
 696  lt_initialized = 1;
 697 }
 698
 699 STATIC U32 lt_booted = 0;
 700
 701 /* --- XS ------------------------------------------------------------------ */
 702
 703 MODULE = Lexical::Types      PACKAGE = Lexical::Types
 704
 705 PROTOTYPES: ENABLE
 706
 707 BOOT:
 708 {
 709  if (!lt_booted++) {
 710   HV *stash;
 711
 712   lt_op_map = ptable_new();
 713 #ifdef USE_ITHREADS
 714   MUTEX_INIT(&lt_op_map_mutex);
 715 #endif
 716
 717   PERL_HASH(lt_hash, __PACKAGE__, __PACKAGE_LEN__);
 718
 719   stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
 720   newCONSTSUB(stash, "LT_THREADSAFE", newSVuv(LT_THREADSAFE));
 721  }
 722
 723  lt_setup();
 724 }
 725
 726 #if LT_THREADSAFE
 727
 728 void
 729 CLONE(...)
 730 PROTOTYPE: DISABLE
 731 PREINIT:
 732  ptable *t;
 733  SV     *cloned_default_meth;
 734 PPCODE:
 735  {
 736   my_cxt_t ud;
 737   dMY_CXT;
 738   ud.tbl   = t = ptable_new();
 739   ud.owner = MY_CXT.owner;
 740   ptable_walk(MY_CXT.tbl, lt_ptable_hints_clone, &ud);
 741   cloned_default_meth = lt_clone(MY_CXT.default_meth, MY_CXT.owner);
 742  }
 743  {
 744   MY_CXT_CLONE;
 745   MY_CXT.tbl            = t;
 746   MY_CXT.owner          = aTHX;
 747   MY_CXT.pp_padsv_saved = 0;
 748   MY_CXT.default_meth   = cloned_default_meth;
 749  }
 750  reap(3, lt_thread_cleanup, NULL);
 751  XSRETURN(0);
 752
 753 #endif
 754
 755 SV *
 756 _tag(SV *value)
 757 PROTOTYPE: $
 758 CODE:
 759  RETVAL = lt_tag(value);
 760 OUTPUT:
 761  RETVAL