#if LT_HAS_PERL(5, 10, 0) || defined(PL_parser)
# ifndef PL_in_my_stash
# define PL_in_my_stash PL_parser->in_my_stash
+# define PL_tokenbuf PL_parser->tokenbuf
# endif
#else
# ifndef PL_in_my_stash
# define PL_in_my_stash PL_Iin_my_stash
+# define PL_tokenbuf PL_Itokenbuf
# endif
#endif
# define LT_HAS_RPEEP LT_HAS_PERL(5, 13, 5)
#endif
+#ifndef STR_WITH_LEN
+# define STR_WITH_LEN(s) ("" s ""), (sizeof(s)-1)
+#endif
+
+#ifndef newSVpvs
+# define newSVpvs(S) Perl_newSVpvn(aTHX_ STR_WITH_LEN(S))
+#endif
+
#ifndef HvNAME_get
# define HvNAME_get(H) HvNAME(H)
#endif
#define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
+#define LT_TYPE_SCALAR 0
+
+#if LT_HAS_PERL(5, 11, 1)
+
+#define LT_TYPE_ARRAY 1
+#define LT_TYPE_HASH 2
+
+#define LT_TYPE_COUNT 3
+
+#else
+
+#define LT_TYPE_COUNT 1
+
+#endif
+
typedef struct {
#if LT_THREADSAFE
ptable *tbl; /* It really is a ptable_hints */
tTHX owner;
#endif
ptable *seen; /* It really is a ptable_seen */
- SV *default_meth;
+ SV *default_meth[LT_TYPE_COUNT];
} my_cxt_t;
START_MY_CXT
#endif /* !MULTIPLICITY */
} lt_op_padxv_info;
+STATIC const char lt_type_desc_scalar[] = "scalar";
+STATIC const char lt_type_desc_array[] = "array";
+STATIC const char lt_type_desc_hash[] = "hash";
+
STATIC void lt_op_padxv_info_call(pTHX_ const lt_op_padxv_info *oi, SV *sv) {
#define lt_op_padxv_info_call(O, S) lt_op_padxv_info_call(aTHX_ (O), (S))
SV *orig_pkg, *type_pkg, *type_meth;
+ svtype var_type;
int items;
dSP;
PUSHMARK(SP);
EXTEND(SP, 3);
PUSHs(type_pkg);
- PUSHs(sv);
+ var_type = SvTYPE(sv);
+ switch (var_type) {
+ case SVt_PVAV:
+ case SVt_PVHV:
+ PUSHs(sv_2mortal(newRV_inc(sv)));
+ break;
+ default:
+ PUSHs(sv);
+ break;
+ }
PUSHs(orig_pkg);
PUTBACK;
switch (items) {
case 0:
break;
- case 1:
- sv_setsv(sv, POPs);
+ case 1: {
+ SV *rsv = POPs;
+ switch (var_type) {
+ case SVt_PVAV:
+ if (SvROK(rsv) && SvTYPE(SvRV(rsv)) == var_type) {
+ AV *av = (AV *) SvRV(rsv);
+ SV **src, **dst;
+ I32 len = av_len(av);
+ I32 i;
+ av_fill((AV *) sv, len);
+ src = AvARRAY(av);
+ dst = AvARRAY(sv);
+ for (i = 0; i <= len; ++i, ++src, ++dst) {
+ SvREFCNT_dec(*dst);
+ *dst = SvREFCNT_inc(*src);
+ }
+ } else {
+ goto type_mismatch;
+ }
+ break;
+ case SVt_PVHV:
+ if (SvROK(rsv) && SvTYPE(SvRV(rsv)) == var_type) {
+ HV *hv = (HV *) SvRV(rsv);
+ HE *he;
+ hv_iterinit(hv);
+ hv_clear((HV *) sv);
+ while ((he = hv_iternext(hv)) != NULL) {
+ SV *val = SvREFCNT_inc(HeVAL(he));
+ if (!hv_store((HV *) sv, HeKEY(he), HeKLEN(he), val, HeHASH(he)))
+ SvREFCNT_dec(val);
+ }
+ } else {
+ goto type_mismatch;
+ }
+ break;
+ default:
+ sv_setsv(sv, rsv);
+ break;
+ }
break;
- default:
- croak("Typed scalar initializer method should return zero or one scalar, but got %d", items);
+type_mismatch:
+ croak("Type mismatch");
+ }
+ default: {
+ const char *type_desc;
+ switch (var_type) {
+ case SVt_PVAV:
+ type_desc = lt_type_desc_array;
+ break;
+ case SVt_PVHV:
+ type_desc = lt_type_desc_hash;
+ break;
+ default:
+ type_desc = lt_type_desc_scalar;
+ break;
+ }
+ croak("Typed %s initializer method should return zero or one scalar, but got %d", type_desc, items);
+ }
}
PUTBACK;
/* ... Our pp_padsv ........................................................ */
-STATIC OP *lt_pp_padsv(pTHX) {
+STATIC OP *lt_pp_padxv(pTHX) {
lt_op_padxv_info oi;
if (lt_padxv_map_fetch(PL_op, &oi)) {
for (i = 0, p = roi.padxv_start; i < count && p; ++i, p = p->op_sibling) {
lt_op_padxv_info oi;
- if (p->op_type == OP_PADSV && lt_padxv_map_fetch(p, &oi))
- lt_op_padxv_info_call(&oi, PAD_SV(base + i));
+
+ switch (p->op_type) {
+ case OP_PADSV:
+#if LT_HAS_PERL(5, 11, 1)
+ case OP_PADAV:
+ case OP_PADHV:
+#endif
+ if (lt_padxv_map_fetch(p, &oi))
+ lt_op_padxv_info_call(&oi, PAD_SV(base + i));
+ break;
+ default:
+ break;
+ }
}
return roi.old_pp(aTHX);
#endif
-/* ... Our ck_pad{any,sv} .................................................. */
+/* ... Our ck_pad{any,sv,av,hv} ............................................ */
-/* Sadly, the padsv OPs we are interested in don't trigger the padsv check
- * function, but are instead manually mutated from a padany. So we store
+/* Sadly, the padxv OPs we are interested in don't trigger the padxv check
+ * functions, but are instead manually mutated from a padany. So we store
* the op entry in the op map in the padany check function, and we set their
* op_ppaddr member in our peephole optimizer replacement below. */
if (stash && (code = lt_hint())) {
dMY_CXT;
SV *orig_pkg = newSVpvn(HvNAME_get(stash), HvNAMELEN_get(stash));
- SV *orig_meth = MY_CXT.default_meth;
+ SV *orig_meth = NULL;
SV *type_pkg = NULL;
SV *type_meth = NULL;
+ unsigned int type;
+ const char *s;
int items;
+ s = PL_tokenbuf;
+ while (*s && isSPACE(*s))
+ ++s;
+ switch (*s) {
+ case '$':
+ type = LT_TYPE_SCALAR;
+ break;
+#if LT_HAS_PERL(5, 11, 1)
+ case '@':
+ type = LT_TYPE_ARRAY;
+ break;
+ case '%':
+ type = LT_TYPE_HASH;
+ break;
+#endif
+ default:
+ croak("Unsupported sigil '%c'", *s);
+ break;
+ }
+ orig_meth = MY_CXT.default_meth[type];
+
dSP;
SvREADONLY_on(orig_pkg);
return lt_old_ck_padsv(aTHX_ o);
}
+#if LT_HAS_PERL(5, 11, 1)
+
+STATIC OP *(*lt_old_ck_padav)(pTHX_ OP *) = 0;
+
+STATIC OP *lt_ck_padav(pTHX_ OP *o) {
+ lt_map_delete(o);
+
+ return lt_old_ck_padav(aTHX_ o);
+}
+
+STATIC OP *(*lt_old_ck_padhv)(pTHX_ OP *) = 0;
+
+STATIC OP *lt_ck_padhv(pTHX_ OP *o) {
+ lt_map_delete(o);
+
+ return lt_old_ck_padhv(aTHX_ o);
+}
+
+#endif
+
/* ... Our peephole optimizer .............................................. */
#if LT_HAS_PERL(5, 17, 6)
count = o->op_private & OPpPADRANGE_COUNTMASK;
for (i = 0, p = start; i < count && p; ++i, p = p->op_sibling) {
- if (p->op_type == OP_PADSV) {
- /* In a padrange sequence, either all lexicals are typed, or none are.
- * Thus we can stop at the first padsv op. However, note that these
- * lexicals can need to call different methods in different packages. */
- LT_LOCK(<_op_map_mutex);
- if (ptable_fetch(lt_op_padxv_map, p)) {
- LT_UNLOCK(<_op_map_mutex);
- lt_padrange_map_store(o, start, o->op_ppaddr);
- o->op_ppaddr = lt_pp_padrange;
- } else {
- LT_UNLOCK(<_op_map_mutex);
- }
- return 1;
+ switch (p->op_type) {
+ case OP_PADSV:
+#if LT_HAS_PERL(5, 11, 1)
+ case OP_PADAV:
+ case OP_PADHV:
+#endif
+ /* In a padrange sequence, either all lexicals are typed, or none are.
+ * Thus we can stop at the first padsv op. However, note that these
+ * lexicals can need to call different methods in different packages. */
+ LT_LOCK(<_op_map_mutex);
+ if (ptable_fetch(lt_op_padxv_map, p)) {
+ LT_UNLOCK(<_op_map_mutex);
+ lt_padrange_map_store(o, start, o->op_ppaddr);
+ o->op_ppaddr = lt_pp_padrange;
+ } else {
+ LT_UNLOCK(<_op_map_mutex);
+ }
+ return 1;
+ break;
+ default:
+ break;
}
}
switch (o->op_type) {
case OP_PADSV:
- if (o->op_ppaddr != lt_pp_padsv && o->op_private & OPpLVAL_INTRO) {
+#if LT_HAS_PERL(5, 11, 1)
+ case OP_PADAV:
+ case OP_PADHV:
+#endif
+ if (o->op_ppaddr != lt_pp_padxv && o->op_private & OPpLVAL_INTRO) {
lt_op_padxv_info *oi;
LT_LOCK(<_op_map_mutex);
oi = ptable_fetch(lt_op_padxv_map, o);
if (oi) {
oi->old_pp = o->op_ppaddr;
- o->op_ppaddr = lt_pp_padsv;
+ o->op_ppaddr = lt_pp_padxv;
}
LT_UNLOCK(<_op_map_mutex);
}
#endif
{
+ unsigned int i;
dMY_CXT;
#if LT_THREADSAFE
ptable_hints_free(MY_CXT.tbl);
#endif
ptable_seen_free(MY_CXT.seen);
- SvREFCNT_dec(MY_CXT.default_meth);
+ for (i = 0; i < LT_TYPE_COUNT; ++i)
+ SvREFCNT_dec(MY_CXT.default_meth[i]);
}
lt_ck_restore(OP_PADANY, <_old_ck_padany);
lt_ck_restore(OP_PADSV, <_old_ck_padsv);
+#if LT_HAS_PERL(5, 11, 1)
+ lt_ck_restore(OP_PADAV, <_old_ck_padav);
+ lt_ck_restore(OP_PADHV, <_old_ck_padhv);
+#endif
#if LT_HAS_RPEEP
PL_rpeepp = lt_old_peep;
{
MY_CXT_INIT;
#if LT_THREADSAFE
- MY_CXT.tbl = ptable_new();
- MY_CXT.owner = aTHX;
+ MY_CXT.tbl = ptable_new();
+ MY_CXT.owner = aTHX;
+#endif
+ MY_CXT.seen = ptable_new();
+ MY_CXT.default_meth[LT_TYPE_SCALAR] = newSVpvs("TYPEDSCALAR");
+ SvREADONLY_on(MY_CXT.default_meth[LT_TYPE_SCALAR]);
+#if LT_HAS_PERL(5, 11, 1)
+ MY_CXT.default_meth[LT_TYPE_ARRAY] = newSVpvs("TYPEDARRAY");
+ SvREADONLY_on(MY_CXT.default_meth[LT_TYPE_ARRAY]);
+ MY_CXT.default_meth[LT_TYPE_HASH] = newSVpvs("TYPEDHASH");
+ SvREADONLY_on(MY_CXT.default_meth[LT_TYPE_HASH]);
#endif
- MY_CXT.seen = ptable_new();
- MY_CXT.default_meth = newSVpvn("TYPEDSCALAR", 11);
- SvREADONLY_on(MY_CXT.default_meth);
}
lt_ck_replace(OP_PADANY, lt_ck_padany, <_old_ck_padany);
lt_ck_replace(OP_PADSV, lt_ck_padsv, <_old_ck_padsv);
+#if LT_HAS_PERL(5, 11, 1)
+ lt_ck_replace(OP_PADAV, lt_ck_padav, <_old_ck_padav);
+ lt_ck_replace(OP_PADHV, lt_ck_padhv, <_old_ck_padhv);
+#endif
#if LT_HAS_RPEEP
lt_old_peep = PL_rpeepp;
CLONE(...)
PROTOTYPE: DISABLE
PREINIT:
- ptable *t;
- ptable *s;
- SV *cloned_default_meth;
+ ptable *t;
+ ptable *s;
+ SV *cloned_default_meth[LT_TYPE_COUNT];
+ unsigned int i;
PPCODE:
{
{
t = ptable_new();
lt_ptable_clone_ud_init(ud, t, MY_CXT.owner);
ptable_walk(MY_CXT.tbl, lt_ptable_clone, &ud);
- cloned_default_meth = lt_dup_inc(MY_CXT.default_meth, &ud);
+ for (i = 0; i < LT_TYPE_COUNT; ++i)
+ cloned_default_meth[i] = lt_dup_inc(MY_CXT.default_meth[i], &ud);
lt_ptable_clone_ud_deinit(ud);
}
s = ptable_new();
}
{
MY_CXT_CLONE;
- MY_CXT.tbl = t;
- MY_CXT.owner = aTHX;
- MY_CXT.seen = s;
- MY_CXT.default_meth = cloned_default_meth;
+ MY_CXT.tbl = t;
+ MY_CXT.owner = aTHX;
+ MY_CXT.seen = s;
+ for (i = 0; i < LT_TYPE_COUNT; ++i)
+ MY_CXT.default_meth[i] = cloned_default_meth[i];
}
reap(3, lt_thread_cleanup, NULL);
XSRETURN(0);