File Coverage

File:Types.xs
Coverage:97.1%

linestmtbrancondsubpodtimecode
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 LT_HAS_RPEEP
31# define LT_HAS_RPEEP LT_HAS_PERL(5, 13, 5)
32#endif
33
34#ifndef HvNAME_get
35# define HvNAME_get(H) HvNAME(H)
36#endif
37
38#ifndef HvNAMELEN_get
39# define HvNAMELEN_get(H) strlen(HvNAME_get(H))
40#endif
41
42#ifndef SvREFCNT_inc_simple_NN
43# define SvREFCNT_inc_simple_NN SvREFCNT_inc
44#endif
45
46/* ... Thread safety and multiplicity ...................................... */
47
48/* Safe unless stated otherwise in Makefile.PL */
49#ifndef LT_FORKSAFE
50# define LT_FORKSAFE 1
51#endif
52
53#ifndef LT_MULTIPLICITY
54# if defined(MULTIPLICITY) || defined(PERL_IMPLICIT_CONTEXT)
55# define LT_MULTIPLICITY 1
56# else
57# define LT_MULTIPLICITY 0
58# endif
59#endif
60
61#ifndef tTHX
62# define tTHX PerlInterpreter*
63#endif
64
65#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))
66# define LT_THREADSAFE 1
67# ifndef MY_CXT_CLONE
68# define MY_CXT_CLONE \
69    dMY_CXT_SV; \
70    my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \
71    Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \
72    sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
73# endif
74#else
75# define LT_THREADSAFE 0
76# undef dMY_CXT
77# define dMY_CXT dNOOP
78# undef MY_CXT
79# define MY_CXT lt_globaldata
80# undef START_MY_CXT
81# define START_MY_CXT STATIC my_cxt_t MY_CXT;
82# undef MY_CXT_INIT
83# define MY_CXT_INIT NOOP
84# undef MY_CXT_CLONE
85# define MY_CXT_CLONE NOOP
86# undef pMY_CXT
87# define pMY_CXT
88# undef pMY_CXT_
89# define pMY_CXT_
90# undef aMY_CXT
91# define aMY_CXT
92# undef aMY_CXT_
93# define aMY_CXT_
94#endif
95
96/* --- Helpers ------------------------------------------------------------- */
97
98/* ... Thread-safe hints ................................................... */
99
100#if LT_WORKAROUND_REQUIRE_PROPAGATION
101
102typedef struct {
103 SV *code;
104 IV require_tag;
105} lt_hint_t;
106
107#define LT_HINT_STRUCT 1
108
109#define LT_HINT_CODE(H) ((H)->code)
110
111#define LT_HINT_FREE(H) { \
112 lt_hint_t *h = (H); \
113 SvREFCNT_dec(h->code); \
114 PerlMemShared_free(h); \
115}
116
117#else /* LT_WORKAROUND_REQUIRE_PROPAGATION */
118
119typedef SV lt_hint_t;
120
121#define LT_HINT_STRUCT 0
122
123#define LT_HINT_CODE(H) (H)
124
125#define LT_HINT_FREE(H) SvREFCNT_dec(H);
126
127#endif /* !LT_WORKAROUND_REQUIRE_PROPAGATION */
128
129#if LT_THREADSAFE
130
131#define PTABLE_NAME ptable_hints
132#define PTABLE_VAL_FREE(V) LT_HINT_FREE(V)
133
134#define pPTBL pTHX
135#define pPTBL_ pTHX_
136#define aPTBL aTHX
137#define aPTBL_ aTHX_
138
139#include "ptable.h"
140
141#define ptable_hints_store(T, K, V) ptable_hints_store(aTHX_ (T), (K), (V))
142#define ptable_hints_free(T) ptable_hints_free(aTHX_ (T))
143
144#endif /* LT_THREADSAFE */
145
146/* ... "Seen" pointer table ................................................ */
147
148#define PTABLE_NAME ptable_seen
149#define PTABLE_VAL_FREE(V) NOOP
150
151#include "ptable.h"
152
153/* PerlMemShared_free() needs the [ap]PTBLMS_? default values */
154#define ptable_seen_store(T, K, V) ptable_seen_store(aPTBLMS_ (T), (K), (V))
155#define ptable_seen_clear(T) ptable_seen_clear(aPTBLMS_ (T))
156#define ptable_seen_free(T) ptable_seen_free(aPTBLMS_ (T))
157
158/* ... Global data ......................................................... */
159
160#define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
161
162typedef struct {
163#if LT_THREADSAFE
164 ptable *tbl; /* It really is a ptable_hints */
165 tTHX owner;
166#endif
167 ptable *seen; /* It really is a ptable_seen */
168 SV *default_meth;
169} my_cxt_t;
170
171START_MY_CXT
172
173/* ... Cloning global data ................................................. */
174
175#if LT_THREADSAFE
176
177typedef struct {
178 ptable *tbl;
179#if LT_HAS_PERL(5, 13, 2)
180 CLONE_PARAMS *params;
181#else
182 CLONE_PARAMS params;
183#endif
184} lt_ptable_clone_ud;
185
186#if LT_HAS_PERL(5, 13, 2)
187# define lt_ptable_clone_ud_init(U, T, O) \
188   (U).tbl = (T); \
189   (U).params = Perl_clone_params_new((O), aTHX)
190# define lt_ptable_clone_ud_deinit(U) Perl_clone_params_del((U).params)
191# define lt_dup_inc(S, U) SvREFCNT_inc(sv_dup((S), (U)->params))
192#else
193# define lt_ptable_clone_ud_init(U, T, O) \
194   (U).tbl = (T); \
195   (U).params.stashes = newAV(); \
196   (U).params.flags = 0; \
197   (U).params.proto_perl = (O)
198# define lt_ptable_clone_ud_deinit(U) SvREFCNT_dec((U).params.stashes)
199# define lt_dup_inc(S, U) SvREFCNT_inc(sv_dup((S), &((U)->params)))
200#endif
201
202STATIC void lt_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
203 lt_ptable_clone_ud *ud = ud_;
204 lt_hint_t *h1 = ent->val;
205 lt_hint_t *h2;
206
207#if LT_HINT_STRUCT
208
209 h2 = PerlMemShared_malloc(sizeof *h2);
210 h2->code = lt_dup_inc(h1->code, ud);
211#if LT_WORKAROUND_REQUIRE_PROPAGATION
212 h2->require_tag = PTR2IV(lt_dup_inc(INT2PTR(SV *, h1->require_tag), ud));
213#endif
214
215#else /* LT_HINT_STRUCT */
216
217 h2 = lt_dup_inc(h1, ud);
218
219#endif /* !LT_HINT_STRUCT */
220
221 ptable_hints_store(ud->tbl, ent->key, h2);
222}
223
224#include "reap.h"
225
226STATIC void lt_thread_cleanup(pTHX_ void *ud) {
227 dMY_CXT;
228
229 ptable_hints_free(MY_CXT.tbl);
230 ptable_seen_free(MY_CXT.seen);
231}
232
233#endif /* LT_THREADSAFE */
234
235/* ... Hint tags ........................................................... */
236
237#if LT_WORKAROUND_REQUIRE_PROPAGATION
238
239STATIC IV lt_require_tag(pTHX) {
240#define lt_require_tag() lt_require_tag(aTHX)
241 const CV *cv, *outside;
242
243 cv = PL_compcv;
244
245 if (!cv) {
246  /* If for some reason the pragma is operational at run-time, try to discover
247   * the current cv in use. */
248  const PERL_SI *si;
249
250  for (si = PL_curstackinfo; si; si = si->si_prev) {
251   I32 cxix;
252
253   for (cxix = si->si_cxix; cxix >= 0; --cxix) {
254    const PERL_CONTEXT *cx = si->si_cxstack + cxix;
255
256    switch (CxTYPE(cx)) {
257     case CXt_SUB:
258     case CXt_FORMAT:
259      /* The propagation workaround is only needed up to 5.10.0 and at that
260       * time format and sub contexts were still identical. And even later the
261       * cv members offsets should have been kept the same. */
262      cv = cx->blk_sub.cv;
263      goto get_enclosing_cv;
264     case CXt_EVAL:
265      cv = cx->blk_eval.cv;
266      goto get_enclosing_cv;
267     default:
268      break;
269    }
270   }
271  }
272
273  cv = PL_main_cv;
274 }
275
276get_enclosing_cv:
277 for (outside = CvOUTSIDE(cv); outside; outside = CvOUTSIDE(cv))
278  cv = outside;
279
280 return PTR2IV(cv);
281}
282
283#endif /* LT_WORKAROUND_REQUIRE_PROPAGATION */
284
285
1039
STATIC SV *lt_tag(pTHX_ SV *value) {
286#define lt_tag(V) lt_tag(aTHX_ (V))
287 lt_hint_t *h;
288
1039
 SV *code = NULL;
289
290
1039
 if (SvROK(value)) {
291
1039
  value = SvRV(value);
292
1039
  if (SvTYPE(value) >= SVt_PVCV) {
293
1039
   code = value;
294
1039
   SvREFCNT_inc_simple_NN(code);
295  }
296 }
297
298#if LT_HINT_STRUCT
299 h = PerlMemShared_malloc(sizeof *h);
300 h->code = code;
301# if LT_WORKAROUND_REQUIRE_PROPAGATION
302 h->require_tag = lt_require_tag();
303# endif /* LT_WORKAROUND_REQUIRE_PROPAGATION */
304#else /* LT_HINT_STRUCT */
305
1039
 h = code;
306#endif /* !LT_HINT_STRUCT */
307
308#if LT_THREADSAFE
309 {
310  dMY_CXT;
311  /* We only need for the key to be an unique tag for looking up the value later
312   * Allocated memory provides convenient unique identifiers, so that's why we
313   * use the hint as the key itself. */
314  ptable_hints_store(MY_CXT.tbl, h, h);
315 }
316#endif /* LT_THREADSAFE */
317
318
1039
 return newSViv(PTR2IV(h));
319}
320
321
1068
STATIC SV *lt_detag(pTHX_ const SV *hint) {
322#define lt_detag(H) lt_detag(aTHX_ (H))
323 lt_hint_t *h;
324#if LT_THREADSAFE
325 dMY_CXT;
326#endif
327
328
1068
 if (!(hint && SvIOK(hint)))
329
8
  return NULL;
330
331
1060
 h = INT2PTR(lt_hint_t *, SvIVX(hint));
332#if LT_THREADSAFE
333 h = ptable_fetch(MY_CXT.tbl, h);
334#endif /* LT_THREADSAFE */
335#if LT_WORKAROUND_REQUIRE_PROPAGATION
336 if (lt_require_tag() != h->require_tag)
337  return NULL;
338#endif /* LT_WORKAROUND_REQUIRE_PROPAGATION */
339
340
1068
 return LT_HINT_CODE(h);
341}
342
343STATIC U32 lt_hash = 0;
344
345
1068
STATIC SV *lt_hint(pTHX) {
346#define lt_hint() lt_hint(aTHX)
347 SV *hint;
348#ifdef cop_hints_fetch_pvn
349
1068
 hint = cop_hints_fetch_pvn(PL_curcop, __PACKAGE__, __PACKAGE_LEN__, lt_hash,0);
350#elif LT_HAS_PERL(5, 9, 5)
351 hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
352                                       NULL,
353                                       __PACKAGE__, __PACKAGE_LEN__,
354                                       0,
355                                       lt_hash);
356#else
357 SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, lt_hash);
358 if (!val)
359  return 0;
360 hint = *val;
361#endif
362
1068
 return lt_detag(hint);
363}
364
365/* ... op => info map ...................................................... */
366
367#define PTABLE_NAME ptable_map
368#define PTABLE_VAL_FREE(V) PerlMemShared_free(V)
369
370#include "ptable.h"
371
372/* PerlMemShared_free() needs the [ap]PTBLMS_? default values */
373#define ptable_map_store(T, K, V) ptable_map_store(aPTBLMS_ (T), (K), (V))
374#define ptable_map_delete(T, K) ptable_map_delete(aPTBLMS_ (T), (K))
375
376STATIC ptable *lt_op_map = NULL;
377
378#ifdef USE_ITHREADS
379
380STATIC perl_mutex lt_op_map_mutex;
381
382#define LT_LOCK(M) MUTEX_LOCK(M)
383#define LT_UNLOCK(M) MUTEX_UNLOCK(M)
384
385#else /* USE_ITHREADS */
386
387#define LT_LOCK(M)
388#define LT_UNLOCK(M)
389
390#endif /* !USE_ITHREADS */
391
392typedef struct {
393#ifdef MULTIPLICITY
394 STRLEN buf_size, orig_pkg_len, type_pkg_len, type_meth_len;
395 char *buf;
396#else /* MULTIPLICITY */
397 SV *orig_pkg;
398 SV *type_pkg;
399 SV *type_meth;
400#endif /* !MULTIPLICITY */
401 OP *(*old_pp_padsv)(pTHX);
402} lt_op_info;
403
404
1053
STATIC void lt_map_store(pTHX_ const OP *o, SV *orig_pkg, SV *type_pkg, SV *type_meth, OP *(*old_pp_padsv)(pTHX)) {
405#define lt_map_store(O, OP, TP, TM, PP) lt_map_store(aTHX_ (O), (OP), (TP), (TM), (PP))
406 lt_op_info *oi;
407
408 LT_LOCK(&lt_op_map_mutex);
409
410
1053
 if (!(oi = ptable_fetch(lt_op_map, o))) {
411
1053
  oi = PerlMemShared_malloc(sizeof *oi);
412
1053
  ptable_map_store(lt_op_map, o, oi);
413#ifdef MULTIPLICITY
414  oi->buf = NULL;
415  oi->buf_size = 0;
416#else /* MULTIPLICITY */
417 } else {
418
0
  SvREFCNT_dec(oi->orig_pkg);
419
0
  SvREFCNT_dec(oi->type_pkg);
420
0
  SvREFCNT_dec(oi->type_meth);
421#endif /* !MULTIPLICITY */
422 }
423
424#ifdef MULTIPLICITY
425 {
426  STRLEN op_len = SvCUR(orig_pkg);
427  STRLEN tp_len = SvCUR(type_pkg);
428  STRLEN tm_len = SvCUR(type_meth);
429  STRLEN new_buf_size = op_len + tp_len + tm_len;
430  char *buf;
431  if (new_buf_size > oi->buf_size) {
432   PerlMemShared_free(oi->buf);
433   oi->buf = PerlMemShared_malloc(new_buf_size);
434   oi->buf_size = new_buf_size;
435  }
436  buf = oi->buf;
437  Copy(SvPVX(orig_pkg), buf, op_len, char);
438  buf += op_len;
439  Copy(SvPVX(type_pkg), buf, tp_len, char);
440  buf += tp_len;
441  Copy(SvPVX(type_meth), buf, tm_len, char);
442  oi->orig_pkg_len = op_len;
443  oi->type_pkg_len = tp_len;
444  oi->type_meth_len = tm_len;
445  SvREFCNT_dec(orig_pkg);
446  SvREFCNT_dec(type_pkg);
447  SvREFCNT_dec(type_meth);
448 }
449#else /* MULTIPLICITY */
450
1053
 oi->orig_pkg = orig_pkg;
451
1053
 oi->type_pkg = type_pkg;
452
1053
 oi->type_meth = type_meth;
453#endif /* !MULTIPLICITY */
454
455
1053
 oi->old_pp_padsv = old_pp_padsv;
456
457 LT_UNLOCK(&lt_op_map_mutex);
458
1053
}
459
460
1086
STATIC const lt_op_info *lt_map_fetch(const OP *o, lt_op_info *oi) {
461 const lt_op_info *val;
462
463 LT_LOCK(&lt_op_map_mutex);
464
465
1086
 val = ptable_fetch(lt_op_map, o);
466
1086
 if (val) {
467
1086
  *oi = *val;
468
1086
  val = oi;
469 }
470
471 LT_UNLOCK(&lt_op_map_mutex);
472
473
1086
 return val;
474}
475
476
3989
STATIC void lt_map_delete(pTHX_ const OP *o) {
477#define lt_map_delete(O) lt_map_delete(aTHX_ (O))
478 LT_LOCK(&lt_op_map_mutex);
479
480
3989
 ptable_map_delete(lt_op_map, o);
481
482 LT_UNLOCK(&lt_op_map_mutex);
483
3989
}
484
485/* --- Hooks --------------------------------------------------------------- */
486
487/* ... Our pp_padsv ........................................................ */
488
489
1086
STATIC OP *lt_pp_padsv(pTHX) {
490 lt_op_info oi;
491
492
1086
 if (lt_map_fetch(PL_op, &oi)) {
493  SV *orig_pkg, *type_pkg, *type_meth;
494  int items;
495
1086
  dSP;
496
1086
  dTARGET;
497
498
1086
  ENTER;
499
1086
  SAVETMPS;
500
501#ifdef MULTIPLICITY
502  {
503   STRLEN op_len = oi.orig_pkg_len, tp_len = oi.type_pkg_len;
504   char *buf = oi.buf;
505   orig_pkg = sv_2mortal(newSVpvn(buf, op_len));
506   SvREADONLY_on(orig_pkg);
507   buf += op_len;
508   type_pkg = sv_2mortal(newSVpvn(buf, tp_len));
509   SvREADONLY_on(type_pkg);
510   buf += tp_len;
511   type_meth = sv_2mortal(newSVpvn(buf, oi.type_meth_len));
512   SvREADONLY_on(type_meth);
513  }
514#else /* MULTIPLICITY */
515
1086
  orig_pkg = oi.orig_pkg;
516
1086
  type_pkg = oi.type_pkg;
517
1086
  type_meth = oi.type_meth;
518#endif /* !MULTIPLICITY */
519
520
1086
  PUSHMARK(SP);
521
1086
  EXTEND(SP, 3);
522
1086
  PUSHs(type_pkg);
523
1086
  PUSHTARG;
524
1086
  PUSHs(orig_pkg);
525
1086
  PUTBACK;
526
527
1086
  items = call_sv(type_meth, G_ARRAY | G_METHOD);
528
529
1083
  SPAGAIN;
530
1083
  switch (items) {
531   case 0:
532
26
    break;
533   case 1:
534
1056
    sv_setsv(TARG, POPs);
535
1056
    break;
536   default:
537
1
    croak("Typed scalar initializer method should return zero or one scalar, but got %d", items);
538  }
539
1082
  PUTBACK;
540
541
1082
  FREETMPS;
542
1082
  LEAVE;
543
544
1082
  return oi.old_pp_padsv(aTHX);
545 }
546
547
1082
 return PL_op->op_ppaddr(aTHX);
548}
549
550/* ... Our ck_pad{any,sv} .................................................. */
551
552/* Sadly, the padsv OPs we are interested in don't trigger the padsv check
553 * function, but are instead manually mutated from a padany. So we store
554 * the op entry in the op map in the padany check function, and we set their
555 * op_ppaddr member in our peephole optimizer replacement below. */
556
557STATIC OP *(*lt_old_ck_padany)(pTHX_ OP *) = 0;
558
559
5044
STATIC OP *lt_ck_padany(pTHX_ OP *o) {
560 HV *stash;
561 SV *code;
562
563
5044
 o = lt_old_ck_padany(aTHX_ o);
564
565
5044
 stash = PL_in_my_stash;
566
6097
 if (stash && (code = lt_hint())) {
567  dMY_CXT;
568
1060
  SV *orig_pkg = newSVpvn(HvNAME_get(stash), HvNAMELEN_get(stash));
569
1060
  SV *orig_meth = MY_CXT.default_meth;
570
1060
  SV *type_pkg = NULL;
571
1060
  SV *type_meth = NULL;
572  int items;
573
574
1060
  dSP;
575
576
1060
  SvREADONLY_on(orig_pkg);
577
578
1060
  ENTER;
579
1060
  SAVETMPS;
580
581
1060
  PUSHMARK(SP);
582
1060
  EXTEND(SP, 2);
583
1060
  PUSHs(orig_pkg);
584
1060
  PUSHs(orig_meth);
585
1060
  PUTBACK;
586
587
1060
  items = call_sv(code, G_ARRAY);
588
589
1057
  SPAGAIN;
590
1057
  if (items > 2)
591
1
   croak(__PACKAGE__ " mangler should return zero, one or two scalars, but got %d", items);
592
1056
  if (items == 0) {
593
3
   SvREFCNT_dec(orig_pkg);
594
3
   FREETMPS;
595
3
   LEAVE;
596
3
   goto skip;
597  } else {
598   SV *rsv;
599
1053
   if (items > 1) {
600
1043
    rsv = POPs;
601
1043
    if (SvOK(rsv)) {
602
1042
     type_meth = newSVsv(rsv);
603
1042
     SvREADONLY_on(type_meth);
604    }
605   }
606
1053
   rsv = POPs;
607
1053
   if (SvOK(rsv)) {
608
1052
    type_pkg = newSVsv(rsv);
609
1052
    SvREADONLY_on(type_pkg);
610   }
611  }
612
1053
  PUTBACK;
613
614
1053
  FREETMPS;
615
1053
  LEAVE;
616
617
1053
  if (!type_pkg) {
618
1
   type_pkg = orig_pkg;
619
1
   SvREFCNT_inc(orig_pkg);
620  }
621
622
1053
  if (!type_meth) {
623
11
   type_meth = orig_meth;
624
11
   SvREFCNT_inc(orig_meth);
625  }
626
627
1053
  lt_map_store(o, orig_pkg, type_pkg, type_meth, o->op_ppaddr);
628 } else {
629skip:
630
3987
  lt_map_delete(o);
631 }
632
633
5040
 return o;
634}
635
636STATIC OP *(*lt_old_ck_padsv)(pTHX_ OP *) = 0;
637
638
2
STATIC OP *lt_ck_padsv(pTHX_ OP *o) {
639
2
 lt_map_delete(o);
640
641
2
 return lt_old_ck_padsv(aTHX_ o);
642}
643
644/* ... Our peephole optimizer .............................................. */
645
646STATIC peep_t lt_old_peep = 0; /* This is actually the rpeep past 5.13.5 */
647
648
3905
STATIC void lt_peep_rec(pTHX_ OP *o, ptable *seen) {
649#define lt_peep_rec(O) lt_peep_rec(aTHX_ (O), seen)
650
56837
 for (; o; o = o->op_next) {
651
52935
  lt_op_info *oi = NULL;
652
653
52935
  if (ptable_fetch(seen, o))
654
3
   break;
655
52932
  ptable_seen_store(seen, o, o);
656
657
52932
  switch (o->op_type) {
658   case OP_PADSV:
659
6125
    if (o->op_ppaddr != lt_pp_padsv && o->op_private & OPpLVAL_INTRO) {
660     LT_LOCK(&lt_op_map_mutex);
661
1498
     oi = ptable_fetch(lt_op_map, o);
662
1498
     if (oi) {
663
1052
      oi->old_pp_padsv = o->op_ppaddr;
664
1052
      o->op_ppaddr = lt_pp_padsv;
665     }
666     LT_UNLOCK(&lt_op_map_mutex);
667    }
668
6125
    break;
669#if !LT_HAS_RPEEP
670   case OP_MAPWHILE:
671   case OP_GREPWHILE:
672   case OP_AND:
673   case OP_OR:
674   case OP_ANDASSIGN:
675   case OP_ORASSIGN:
676   case OP_COND_EXPR:
677   case OP_RANGE:
678# if LT_HAS_PERL(5, 10, 0)
679   case OP_ONCE:
680   case OP_DOR:
681   case OP_DORASSIGN:
682# endif
683    lt_peep_rec(cLOGOPo->op_other);
684    break;
685   case OP_ENTERLOOP:
686   case OP_ENTERITER:
687    lt_peep_rec(cLOOPo->op_redoop);
688    lt_peep_rec(cLOOPo->op_nextop);
689    lt_peep_rec(cLOOPo->op_lastop);
690    break;
691# if LT_HAS_PERL(5, 9, 5)
692   case OP_SUBST:
693    lt_peep_rec(cPMOPo->op_pmstashstartu.op_pmreplstart);
694    break;
695# else
696   case OP_QR:
697   case OP_MATCH:
698   case OP_SUBST:
699    lt_peep_rec(cPMOPo->op_pmreplstart);
700    break;
701# endif
702#endif /* !LT_HAS_RPEEP */
703   default:
704
46807
    break;
705  }
706 }
707
3905
}
708
709
3905
STATIC void lt_peep(pTHX_ OP *o) {
710 dMY_CXT;
711
3905
 ptable *seen = MY_CXT.seen;
712
713
3905
 lt_old_peep(aTHX_ o);
714
715
3905
 ptable_seen_clear(seen);
716
3905
 lt_peep_rec(o);
717
3905
 ptable_seen_clear(seen);
718
3905
}
719
720/* --- Interpreter setup/teardown ------------------------------------------ */
721
722
723STATIC U32 lt_initialized = 0;
724
725
15
STATIC void lt_teardown(pTHX_ void *root) {
726
15
 if (!lt_initialized)
727
0
  return;
728
729#if LT_MULTIPLICITY
730 if (aTHX != root)
731  return;
732#endif
733
734 {
735  dMY_CXT;
736#if LT_THREADSAFE
737  ptable_hints_free(MY_CXT.tbl);
738#endif
739
15
  ptable_seen_free(MY_CXT.seen);
740
15
  SvREFCNT_dec(MY_CXT.default_meth);
741 }
742
743
15
 PL_check[OP_PADANY] = MEMBER_TO_FPTR(lt_old_ck_padany);
744
15
 lt_old_ck_padany = 0;
745
15
 PL_check[OP_PADSV] = MEMBER_TO_FPTR(lt_old_ck_padsv);
746
15
 lt_old_ck_padsv = 0;
747
748#if LT_HAS_RPEEP
749
15
 PL_rpeepp = lt_old_peep;
750#else
751 PL_peepp = lt_old_peep;
752#endif
753
15
 lt_old_peep = 0;
754
755
15
 lt_initialized = 0;
756}
757
758
15
STATIC void lt_setup(pTHX) {
759#define lt_setup() lt_setup(aTHX)
760
15
 if (lt_initialized)
761
0
  return;
762
763 {
764  MY_CXT_INIT;
765#if LT_THREADSAFE
766  MY_CXT.tbl = ptable_new();
767  MY_CXT.owner = aTHX;
768#endif
769
15
  MY_CXT.seen = ptable_new();
770
15
  MY_CXT.default_meth = newSVpvn("TYPEDSCALAR", 11);
771
15
  SvREADONLY_on(MY_CXT.default_meth);
772 }
773
774
15
 lt_old_ck_padany = PL_check[OP_PADANY];
775
15
 PL_check[OP_PADANY] = MEMBER_TO_FPTR(lt_ck_padany);
776
15
 lt_old_ck_padsv = PL_check[OP_PADSV];
777
15
 PL_check[OP_PADSV] = MEMBER_TO_FPTR(lt_ck_padsv);
778
779#if LT_HAS_RPEEP
780
15
 lt_old_peep = PL_rpeepp;
781
15
 PL_rpeepp = lt_peep;
782#else
783 lt_old_peep = PL_peepp;
784 PL_peepp = lt_peep;
785#endif
786
787#if LT_MULTIPLICITY
788 call_atexit(lt_teardown, aTHX);
789#else
790
15
 call_atexit(lt_teardown, NULL);
791#endif
792
793
15
 lt_initialized = 1;
794}
795
796STATIC U32 lt_booted = 0;
797
798/* --- XS ------------------------------------------------------------------ */
799
800MODULE = Lexical::Types PACKAGE = Lexical::Types
801
802PROTOTYPES: ENABLE
803
804BOOT:
805{
806
15
 if (!lt_booted++) {
807  HV *stash;
808
809
15
  lt_op_map = ptable_new();
810#ifdef USE_ITHREADS
811  MUTEX_INIT(&lt_op_map_mutex);
812#endif
813
814
225
  PERL_HASH(lt_hash, __PACKAGE__, __PACKAGE_LEN__);
815
816
15
  stash = gv_stashpvn(__PACKAGE__, __PACKAGE_LEN__, 1);
817
15
  newCONSTSUB(stash, "LT_THREADSAFE", newSVuv(LT_THREADSAFE));
818
15
  newCONSTSUB(stash, "LT_FORKSAFE", newSVuv(LT_FORKSAFE));
819 }
820
821
15
 lt_setup();
822}
823
824#if LT_THREADSAFE
825
826void
827CLONE(...)
828PROTOTYPE: DISABLE
829PREINIT:
830 ptable *t;
831 ptable *s;
832 SV *cloned_default_meth;
833PPCODE:
834 {
835  {
836   lt_ptable_clone_ud ud;
837   dMY_CXT;
838
839   t = ptable_new();
840   lt_ptable_clone_ud_init(ud, t, MY_CXT.owner);
841   ptable_walk(MY_CXT.tbl, lt_ptable_clone, &ud);
842   cloned_default_meth = lt_dup_inc(MY_CXT.default_meth, &ud);
843   lt_ptable_clone_ud_deinit(ud);
844  }
845  s = ptable_new();
846 }
847 {
848  MY_CXT_CLONE;
849  MY_CXT.tbl = t;
850  MY_CXT.owner = aTHX;
851  MY_CXT.seen = s;
852  MY_CXT.default_meth = cloned_default_meth;
853 }
854 reap(3, lt_thread_cleanup, NULL);
855 XSRETURN(0);
856
857#endif
858
859SV *
860_tag(SV *value)
861PROTOTYPE: $
862CODE:
863
1039
 RETVAL = lt_tag(value);
864OUTPUT:
865 RETVAL