autovivification-0.18/000755 000765 000024 00000000000 13177355077 015655 5ustar00vincentstaff000000 000000 autovivification-0.18/autovivification.xs000644 000765 000024 00000075112 13137651547 021617 0ustar00vincentstaff000000 000000 /* This file is part of the autovivification Perl module. * See http://search.cpan.org/dist/autovivification/ */ #define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" /* --- XS helpers ---------------------------------------------------------- */ #define XSH_PACKAGE "autovivification" #include "xsh/caps.h" #include "xsh/util.h" #include "xsh/ops.h" #include "xsh/peep.h" /* ... Lexical hints ....................................................... */ /* Used both for hints and op flags */ #define A_HINT_STRICT 1 #define A_HINT_WARN 2 #define A_HINT_FETCH 4 #define A_HINT_STORE 8 #define A_HINT_KEYS 16 #define A_HINT_VALUES 32 #define A_HINT_EXISTS 64 #define A_HINT_DELETE 128 #define A_HINT_NOTIFY (A_HINT_STRICT|A_HINT_WARN) #define A_HINT_DO (A_HINT_FETCH|A_HINT_STORE|A_HINT_KEYS|A_HINT_VALUES|A_HINT_EXISTS|A_HINT_DELETE) #define A_HINT_MASK (A_HINT_NOTIFY|A_HINT_DO) /* Only used in op flags */ #define A_HINT_ROOT 256 #define A_HINT_SECOND 512 #define A_HINT_DEREF 1024 #define XSH_HINTS_TYPE_UV 1 #include "xsh/hints.h" #define a_hint() xsh_hints_detag(xsh_hints_fetch()) /* ... Thread-local storage ................................................ */ #define XSH_THREADS_COMPILE_TIME_PROTECTION 1 #define XSH_THREADS_USER_CONTEXT 0 #include "xsh/threads.h" /* --- Compatibility wrappers ---------------------------------------------- */ #ifndef HvNAME_get # define HvNAME_get(H) HvNAME(H) #endif #ifndef HvNAMELEN_get # define HvNAMELEN_get(H) strlen(HvNAME_get(H)) #endif #ifndef A_HAS_MULTIDEREF # define A_HAS_MULTIDEREF XSH_HAS_PERL(5, 21, 7) #endif #ifndef A_HAS_SCALARKEYS_OPT # define A_HAS_SCALARKEYS_OPT XSH_HAS_PERL(5, 27, 3) #endif /* ... Our vivify_ref() .................................................... */ /* Perl_vivify_ref() is not exported, so we have to reimplement it. */ #if A_HAS_MULTIDEREF static SV *a_vivify_ref(pTHX_ SV *sv, int to_hash) { #define a_vivify_ref(S, TH) a_vivify_ref(aTHX_ (S), (TH)) SvGETMAGIC(sv); if (!SvOK(sv)) { SV *val; if (SvREADONLY(sv)) Perl_croak_no_modify(); /* Inlined prepare_SV_for_RV() */ if (SvTYPE(sv) < SVt_PV && SvTYPE(sv) != SVt_IV) { sv_upgrade(sv, SVt_IV); } else if (SvTYPE(sv) >= SVt_PV) { SvPV_free(sv); SvLEN_set(sv, 0); SvCUR_set(sv, 0); } val = to_hash ? MUTABLE_SV(newHV()) : MUTABLE_SV(newAV()); SvRV_set(sv, val); SvROK_on(sv); SvSETMAGIC(sv); SvGETMAGIC(sv); } if (SvGMAGICAL(sv)) { SV *msv = sv_newmortal(); sv_setsv_nomg(msv, sv); return msv; } return sv; } #endif /* A_HAS_MULTIDEREF */ /* --- op => info map ------------------------------------------------------ */ typedef struct { OP *(*old_pp)(pTHX); void *next; UV flags; } a_op_info; #define PTABLE_NAME ptable_map #define PTABLE_VAL_FREE(V) XSH_SHARED_FREE((V), 1, a_op_info) #define PTABLE_VAL_NEED_CONTEXT 0 #define PTABLE_NEED_DELETE 1 #define PTABLE_NEED_WALK 0 #include "xsh/ptable.h" #define ptable_map_store(T, K, V) ptable_map_store(aPMS_ (T), (K), (V)) #define ptable_map_delete(T, K) ptable_map_delete(aPMS_ (T), (K)) #define ptable_map_free(T) ptable_map_free(aPMS_ (T)) static ptable *a_op_map = NULL; #ifdef USE_ITHREADS #define dA_MAP_THX a_op_info a_op_map_tmp_oi static perl_mutex a_op_map_mutex; static const a_op_info *a_map_fetch(const OP *o, a_op_info *oi) { const a_op_info *val; XSH_LOCK(&a_op_map_mutex); val = ptable_fetch(a_op_map, o); if (val) { *oi = *val; val = oi; } XSH_UNLOCK(&a_op_map_mutex); return val; } #define a_map_fetch(O) a_map_fetch((O), &a_op_map_tmp_oi) #else /* USE_ITHREADS */ #define dA_MAP_THX dNOOP #define a_map_fetch(O) ptable_fetch(a_op_map, (O)) #endif /* !USE_ITHREADS */ static const a_op_info *a_map_store_locked(pPMS_ const OP *o, OP *(*old_pp)(pTHX), void *next, UV flags) { #define a_map_store_locked(O, PP, N, F) a_map_store_locked(aPMS_ (O), (PP), (N), (F)) a_op_info *oi; if (!(oi = ptable_fetch(a_op_map, o))) { XSH_SHARED_ALLOC(oi, 1, a_op_info); ptable_map_store(a_op_map, o, oi); } oi->old_pp = old_pp; oi->next = next; oi->flags = flags; return oi; } static void a_map_store(pTHX_ const OP *o, OP *(*old_pp)(pTHX), void *next, UV flags) { #define a_map_store(O, PP, N, F) a_map_store(aTHX_ (O), (PP), (N), (F)) XSH_LOCK(&a_op_map_mutex); a_map_store_locked(o, old_pp, next, flags); XSH_UNLOCK(&a_op_map_mutex); } static void a_map_delete(pTHX_ const OP *o) { #define a_map_delete(O) a_map_delete(aTHX_ (O)) XSH_LOCK(&a_op_map_mutex); ptable_map_delete(a_op_map, o); XSH_UNLOCK(&a_op_map_mutex); } static const OP *a_map_descend(const OP *o) { switch (PL_opargs[o->op_type] & OA_CLASS_MASK) { case OA_BASEOP: case OA_UNOP: case OA_BINOP: case OA_BASEOP_OR_UNOP: return cUNOPo->op_first; case OA_LIST: case OA_LISTOP: return cLISTOPo->op_last; } return NULL; } static void a_map_store_root(pTHX_ const OP *root, OP *(*old_pp)(pTHX), UV flags) { #define a_map_store_root(R, PP, F) a_map_store_root(aTHX_ (R), (PP), (F)) const a_op_info *roi; a_op_info *oi; const OP *o = root; XSH_LOCK(&a_op_map_mutex); roi = a_map_store_locked(o, old_pp, (OP *) root, flags | A_HINT_ROOT); while (o->op_flags & OPf_KIDS) { o = a_map_descend(o); if (!o) break; if ((oi = ptable_fetch(a_op_map, o))) { oi->flags &= ~A_HINT_ROOT; oi->next = (a_op_info *) roi; break; } } XSH_UNLOCK(&a_op_map_mutex); return; } static void a_map_update_flags_topdown(const OP *root, UV mask, UV flags) { a_op_info *oi; const OP *o = root; XSH_LOCK(&a_op_map_mutex); mask |= A_HINT_ROOT; flags &= ~mask; do { if ((oi = ptable_fetch(a_op_map, o))) oi->flags = (oi->flags & mask) | flags; if (!(o->op_flags & OPf_KIDS)) break; o = a_map_descend(o); } while (o); XSH_UNLOCK(&a_op_map_mutex); return; } static void a_map_update_flags_bottomup(const OP *o, UV flags, UV rflags) { a_op_info *oi; XSH_LOCK(&a_op_map_mutex); flags &= ~A_HINT_ROOT; rflags |= A_HINT_ROOT; oi = ptable_fetch(a_op_map, o); while (!(oi->flags & A_HINT_ROOT)) { oi->flags = flags; oi = oi->next; } oi->flags = rflags; XSH_UNLOCK(&a_op_map_mutex); return; } /* ... Decide whether this expression should be autovivified or not ........ */ static UV a_map_resolve(const OP *o, const a_op_info *oi) { UV flags = 0, rflags; const OP *root; const a_op_info *roi = oi; while (!(roi->flags & A_HINT_ROOT)) roi = roi->next; if (!roi) goto cancel; rflags = roi->flags & ~A_HINT_ROOT; if (!rflags) goto cancel; root = roi->next; if (root->op_flags & OPf_MOD) { if (rflags & A_HINT_STORE) flags = (A_HINT_STORE|A_HINT_DEREF); } else { if (rflags & (A_HINT_FETCH|A_HINT_KEYS|A_HINT_VALUES)) flags = (rflags|A_HINT_DEREF); } if (!flags) { cancel: a_map_update_flags_bottomup(o, 0, 0); return 0; } flags |= (rflags & A_HINT_NOTIFY); a_map_update_flags_bottomup(o, flags, 0); return oi->flags & A_HINT_ROOT ? 0 : flags; } /* ... Inspired from pp_defined() .......................................... */ static int a_undef(pTHX_ SV *sv) { #define a_undef(S) a_undef(aTHX_ (S)) switch (SvTYPE(sv)) { case SVt_NULL: return 1; case SVt_PVAV: if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) return 0; break; case SVt_PVHV: if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied))) return 0; break; default: SvGETMAGIC(sv); if (SvOK(sv)) return 0; } return 1; } /* --- PP functions -------------------------------------------------------- */ /* Be aware that we restore PL_op->op_ppaddr from the pointer table old_pp * value, another extension might have saved our pp replacement as the ppaddr * for this op, so this doesn't ensure that our function will never be called * again. That's why we don't remove the op info from our map, so that it can * still run correctly if required. */ /* ... pp_rv2av ............................................................ */ static OP *a_pp_rv2av(pTHX) { dA_MAP_THX; const a_op_info *oi; dSP; oi = a_map_fetch(PL_op); if (oi->flags & A_HINT_DEREF) { if (a_undef(TOPs)) { /* We always need to push an empty array to fool the pp_aelem() that comes * later. */ SV *av; (void) POPs; av = sv_2mortal((SV *) newAV()); PUSHs(av); RETURN; } } return oi->old_pp(aTHX); } /* ... pp_rv2hv ............................................................ */ static OP *a_pp_rv2hv_simple(pTHX) { dA_MAP_THX; const a_op_info *oi; dSP; oi = a_map_fetch(PL_op); if (oi->flags & A_HINT_DEREF) { if (a_undef(TOPs)) RETURN; } return oi->old_pp(aTHX); } static OP *a_pp_rv2hv(pTHX) { dA_MAP_THX; const a_op_info *oi; dSP; oi = a_map_fetch(PL_op); if (oi->flags & A_HINT_DEREF) { if (a_undef(TOPs)) { SV *hv; (void) POPs; hv = sv_2mortal((SV *) newHV()); PUSHs(hv); RETURN; } } return oi->old_pp(aTHX); } #if A_HAS_SCALARKEYS_OPT static OP *a_pp_rv2hv_dokeys(pTHX) { dA_MAP_THX; const a_op_info *oi; dSP; oi = a_map_fetch(PL_op); if (oi->flags & A_HINT_KEYS) { if (a_undef(TOPs)) { dTARGET; (void) POPs; PUSHi(0); RETURN; } } return oi->old_pp(aTHX); } #endif /* ... pp_deref (aelem,helem,rv2sv,padsv) .................................. */ static void a_cannot_vivify(pTHX_ UV flags) { #define a_cannot_vivify(F) a_cannot_vivify(aTHX_ (F)) if (flags & A_HINT_STRICT) croak("Reference vivification forbidden"); else if (flags & A_HINT_WARN) warn("Reference was vivified"); else /* A_HINT_STORE */ croak("Can't vivify reference"); } static OP *a_pp_deref(pTHX) { dA_MAP_THX; const a_op_info *oi; UV flags; dSP; oi = a_map_fetch(PL_op); flags = oi->flags; if (flags & A_HINT_DEREF) { OP *o; o = oi->old_pp(aTHX); if (flags & (A_HINT_NOTIFY|A_HINT_STORE)) { SPAGAIN; if (a_undef(TOPs)) a_cannot_vivify(flags); } return o; } return oi->old_pp(aTHX); } /* ... pp_root (exists,delete,keys,values) ................................. */ static OP *a_pp_root_unop(pTHX) { dSP; if (a_undef(TOPs)) { (void) POPs; /* Can only be reached by keys or values */ if (GIMME_V == G_SCALAR) { dTARGET; PUSHi(0); } RETURN; } { dA_MAP_THX; const a_op_info *oi = a_map_fetch(PL_op); return oi->old_pp(aTHX); } } static OP *a_pp_root_binop(pTHX) { dSP; if (a_undef(TOPm1s)) { (void) POPs; (void) POPs; if (PL_op->op_type == OP_EXISTS) RETPUSHNO; else RETPUSHUNDEF; } { dA_MAP_THX; const a_op_info *oi = a_map_fetch(PL_op); return oi->old_pp(aTHX); } } #if A_HAS_MULTIDEREF /* ... pp_multideref ....................................................... */ /* This pp replacement is actually only called for topmost exists/delete ops, * because we hijack the [ah]elem check functions and this disables the * optimization for lvalue and rvalue dereferencing. In particular, the * OPf_MOD branches should never be covered. In the future, the multideref * optimization might also be disabled for custom exists/delete check functions, * which will make this section unnecessary. However, the code tries to be as * general as possible in case I think of a way to reenable the multideref * optimization even when this module is in use. */ static UV a_do_multideref(const OP *o, UV flags) { UV isexdel, other_flags; XSH_ASSERT(o->op_type == OP_MULTIDEREF); other_flags = flags & ~A_HINT_DO; isexdel = o->op_private & (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE); if (isexdel) { if (isexdel & OPpMULTIDEREF_EXISTS) { flags &= A_HINT_EXISTS; } else { flags &= A_HINT_DELETE; } } else { if (o->op_flags & OPf_MOD) { flags &= A_HINT_STORE; } else { flags &= A_HINT_FETCH; } } return flags ? (flags | other_flags) : 0; } static SV *a_do_fake_pp(pTHX_ OP *op) { #define a_do_fake_pp(O) a_do_fake_pp(aTHX_ (O)) { OP *o = PL_op; ENTER; SAVEOP(); PL_op = op; PL_op->op_ppaddr(aTHX); PL_op = o; LEAVE; } { SV *ret; dSP; ret = POPs; PUTBACK; return ret; } } static void a_do_fake_pp_unop_init(pTHX_ UNOP *unop, U32 type, U32 flags) { #define a_do_fake_pp_unop_init(O, T, F) a_do_fake_pp_unop_init(aTHX_ (O), (T), (F)) unop->op_type = type; unop->op_flags = OPf_WANT_SCALAR | (~OPf_WANT & flags); unop->op_private = 0; unop->op_first = NULL; unop->op_ppaddr = PL_ppaddr[type]; } static SV *a_do_fake_pp_unop_arg1(pTHX_ U32 type, U32 flags, SV *arg) { #define a_do_fake_pp_unop_arg1(T, F, A) a_do_fake_pp_unop_arg1(aTHX_ (T), (F), (A)) UNOP unop; dSP; a_do_fake_pp_unop_init(&unop, type, flags); EXTEND(SP, 1); PUSHs(arg); PUTBACK; return a_do_fake_pp((OP *) &unop); } static SV *a_do_fake_pp_unop_arg2(pTHX_ U32 type, U32 flags, SV *arg1, SV *arg2) { #define a_do_fake_pp_unop_arg2(T, F, A1, A2) a_do_fake_pp_unop_arg2(aTHX_ (T), (F), (A1), (A2)) UNOP unop; dSP; a_do_fake_pp_unop_init(&unop, type, flags); EXTEND(SP, 2); PUSHs(arg1); PUSHs(arg2); PUTBACK; return a_do_fake_pp((OP *) &unop); } #define a_do_pp_rv2av(R) a_do_fake_pp_unop_arg1(OP_RV2AV, OPf_REF, (R)) #define a_do_pp_afetch(A, I) a_do_fake_pp_unop_arg2(OP_AELEM, 0, (A), (I)) #define a_do_pp_afetch_lv(A, I) a_do_fake_pp_unop_arg2(OP_AELEM, OPf_MOD, (A), (I)) #define a_do_pp_aexists(A, I) a_do_fake_pp_unop_arg2(OP_EXISTS, OPf_SPECIAL, (A), (I)) #define a_do_pp_adelete(A, I) a_do_fake_pp_unop_arg2(OP_DELETE, OPf_SPECIAL, (A), (I)) #define a_do_pp_rv2hv(R) a_do_fake_pp_unop_arg1(OP_RV2HV, OPf_REF, (R)) #define a_do_pp_hfetch(H, K) a_do_fake_pp_unop_arg2(OP_HELEM, 0, (H), (K)) #define a_do_pp_hfetch_lv(H, K) a_do_fake_pp_unop_arg2(OP_HELEM, OPf_MOD, (H), (K)) #define a_do_pp_hexists(H, K) a_do_fake_pp_unop_arg2(OP_EXISTS, 0, (H), (K)) #define a_do_pp_hdelete(H, K) a_do_fake_pp_unop_arg2(OP_DELETE, 0, (H), (K)) static OP *a_pp_multideref(pTHX) { UNOP_AUX_item *items; UV actions; UV flags = 0; SV *sv = NULL; dSP; { dA_MAP_THX; const a_op_info *oi = a_map_fetch(PL_op); XSH_ASSERT(oi); flags = a_do_multideref(PL_op, oi->flags); if (!flags) return oi->old_pp(aTHX); } items = cUNOP_AUXx(PL_op)->op_aux; actions = items->uv; PL_multideref_pc = items; while (1) { switch (actions & MDEREF_ACTION_MASK) { case MDEREF_reload: actions = (++items)->uv; continue; case MDEREF_AV_padav_aelem: /* $lex[...] */ sv = PAD_SVl((++items)->pad_offset); if (a_undef(sv)) goto ret_undef; goto do_AV_aelem; case MDEREF_AV_gvav_aelem: /* $pkg[...] */ sv = UNOP_AUX_item_sv(++items); XSH_ASSERT(isGV_with_GP(sv)); sv = (SV *) GvAVn((GV *) sv); if (a_undef(sv)) goto ret_undef; goto do_AV_aelem; case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */ sv = POPs; if (a_undef(sv)) goto ret_undef; goto do_AV_rv2av_aelem; case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */ sv = UNOP_AUX_item_sv(++items); XSH_ASSERT(isGV_with_GP(sv)); sv = GvSVn((GV *) sv); if (a_undef(sv)) goto ret_undef; goto do_AV_vivify_rv2av_aelem; case MDEREF_AV_padsv_vivify_rv2av_aelem: /* $lex->[...] */ sv = PAD_SVl((++items)->pad_offset); /* FALLTHROUGH */ case MDEREF_AV_vivify_rv2av_aelem: /* vivify, ->[...] */ if (a_undef(sv)) goto ret_undef; do_AV_vivify_rv2av_aelem: sv = a_vivify_ref(sv, 0); do_AV_rv2av_aelem: sv = a_do_pp_rv2av(sv); do_AV_aelem: { SV *esv; XSH_ASSERT(SvTYPE(sv) == SVt_PVAV); switch (actions & MDEREF_INDEX_MASK) { case MDEREF_INDEX_none: goto finish; case MDEREF_INDEX_const: esv = sv_2mortal(newSViv((++items)->iv)); break; case MDEREF_INDEX_padsv: esv = PAD_SVl((++items)->pad_offset); goto check_elem; case MDEREF_INDEX_gvsv: esv = UNOP_AUX_item_sv(++items); XSH_ASSERT(isGV_with_GP(esv)); esv = GvSVn((GV *) esv); check_elem: if (UNLIKELY(SvROK(esv) && !SvGAMAGIC(esv) && ckWARN(WARN_MISC))) Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", SVfARG(esv)); break; } PL_multideref_pc = items; if (actions & MDEREF_FLAG_last) { switch (flags & A_HINT_DO) { case A_HINT_FETCH: sv = a_do_pp_afetch(sv, esv); break; case A_HINT_STORE: sv = a_do_pp_afetch_lv(sv, esv); break; case A_HINT_EXISTS: sv = a_do_pp_aexists(sv, esv); break; case A_HINT_DELETE: sv = a_do_pp_adelete(sv, esv); break; } goto finish; } sv = a_do_pp_afetch(sv, esv); break; } case MDEREF_HV_padhv_helem: /* $lex{...} */ sv = PAD_SVl((++items)->pad_offset); if (a_undef(sv)) goto ret_undef; goto do_HV_helem; case MDEREF_HV_gvhv_helem: /* $pkg{...} */ sv = UNOP_AUX_item_sv(++items); XSH_ASSERT(isGV_with_GP(sv)); sv = (SV *) GvHVn((GV *) sv); if (a_undef(sv)) goto ret_undef; goto do_HV_helem; case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */ sv = POPs; if (a_undef(sv)) goto ret_undef; goto do_HV_rv2hv_helem; case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */ sv = UNOP_AUX_item_sv(++items); XSH_ASSERT(isGV_with_GP(sv)); sv = GvSVn((GV *) sv); if (a_undef(sv)) goto ret_undef; goto do_HV_vivify_rv2hv_helem; case MDEREF_HV_padsv_vivify_rv2hv_helem: /* $lex->{...} */ sv = PAD_SVl((++items)->pad_offset); /* FALLTHROUGH */ case MDEREF_HV_vivify_rv2hv_helem: /* vivify, ->{...} */ if (a_undef(sv)) goto ret_undef; do_HV_vivify_rv2hv_helem: sv = a_vivify_ref(sv, 1); do_HV_rv2hv_helem: sv = a_do_pp_rv2hv(sv); do_HV_helem: { SV *key; XSH_ASSERT(SvTYPE(sv) == SVt_PVHV); switch (actions & MDEREF_INDEX_MASK) { case MDEREF_INDEX_none: goto finish; case MDEREF_INDEX_const: key = UNOP_AUX_item_sv(++items); break; case MDEREF_INDEX_padsv: key = PAD_SVl((++items)->pad_offset); break; case MDEREF_INDEX_gvsv: key = UNOP_AUX_item_sv(++items); XSH_ASSERT(isGV_with_GP(key)); key = GvSVn((GV *) key); break; } PL_multideref_pc = items; if (actions & MDEREF_FLAG_last) { switch (flags & A_HINT_DO) { case A_HINT_FETCH: sv = a_do_pp_hfetch(sv, key); break; case A_HINT_STORE: sv = a_do_pp_hfetch_lv(sv, key); break; case A_HINT_EXISTS: sv = a_do_pp_hexists(sv, key); break; case A_HINT_DELETE: sv = a_do_pp_hdelete(sv, key); break; default: break; } goto finish; } sv = a_do_pp_hfetch(sv, key); break; } } actions >>= MDEREF_SHIFT; } ret_undef: if (flags & (A_HINT_NOTIFY|A_HINT_STORE)) a_cannot_vivify(flags); if (flags & A_HINT_EXISTS) sv = &PL_sv_no; else sv = &PL_sv_undef; finish: XPUSHs(sv); RETURN; } #endif /* A_HAS_MULTIDEREF */ /* --- Check functions ----------------------------------------------------- */ static void a_recheck_rv2xv(pTHX_ OP *o, OPCODE type, OP *(*new_pp)(pTHX)) { #define a_recheck_rv2xv(O, T, PP) a_recheck_rv2xv(aTHX_ (O), (T), (PP)) if (o->op_type == type && o->op_ppaddr != new_pp && cUNOPo->op_first->op_type != OP_GV) { dA_MAP_THX; const a_op_info *oi = a_map_fetch(o); if (oi) { a_map_store(o, o->op_ppaddr, oi->next, oi->flags); o->op_ppaddr = new_pp; } } return; } /* ... ck_pad{any,sv} ...................................................... */ /* 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 * 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. */ static OP *(*a_old_ck_padany)(pTHX_ OP *) = 0; static OP *a_ck_padany(pTHX_ OP *o) { UV hint; o = a_old_ck_padany(aTHX_ o); hint = a_hint(); if (hint & A_HINT_DO) a_map_store_root(o, o->op_ppaddr, hint); else a_map_delete(o); return o; } static OP *(*a_old_ck_padsv)(pTHX_ OP *) = 0; static OP *a_ck_padsv(pTHX_ OP *o) { UV hint; o = a_old_ck_padsv(aTHX_ o); hint = a_hint(); if (hint & A_HINT_DO) { a_map_store_root(o, o->op_ppaddr, hint); o->op_ppaddr = a_pp_deref; } else a_map_delete(o); return o; } /* ... ck_deref (aelem,helem,rv2sv) ........................................ */ /* Those ops appear both at the root and inside an expression but there's no * way to distinguish both situations. Worse, we can't even know if we are in a * modifying context, so the expression can't be resolved yet. It will be at the * first invocation of a_pp_deref() for this expression. */ static OP *(*a_old_ck_aelem)(pTHX_ OP *) = 0; static OP *(*a_old_ck_helem)(pTHX_ OP *) = 0; static OP *(*a_old_ck_rv2sv)(pTHX_ OP *) = 0; static OP *a_ck_deref(pTHX_ OP *o) { OP * (*old_ck)(pTHX_ OP *o) = 0; UV hint = a_hint(); switch (o->op_type) { case OP_AELEM: old_ck = a_old_ck_aelem; if ((hint & A_HINT_DO) && !(hint & A_HINT_STRICT)) a_recheck_rv2xv(cUNOPo->op_first, OP_RV2AV, a_pp_rv2av); break; case OP_HELEM: old_ck = a_old_ck_helem; if ((hint & A_HINT_DO) && !(hint & A_HINT_STRICT)) a_recheck_rv2xv(cUNOPo->op_first, OP_RV2HV, a_pp_rv2hv_simple); break; case OP_RV2SV: old_ck = a_old_ck_rv2sv; break; } o = old_ck(aTHX_ o); #if A_HAS_MULTIDEREF if (old_ck == a_old_ck_rv2sv && o->op_flags & OPf_KIDS) { OP *kid = cUNOPo->op_first; if (kid && kid->op_type == OP_GV) { if (hint & A_HINT_DO) a_map_store(kid, kid->op_ppaddr, NULL, hint); else a_map_delete(kid); } } #endif if (hint & A_HINT_DO) { a_map_store_root(o, o->op_ppaddr, hint); o->op_ppaddr = a_pp_deref; } else a_map_delete(o); return o; } /* ... ck_rv2xv (rv2av,rv2hv) .............................................. */ /* Those ops also appear both inisde and at the root, hence the caveats for * a_ck_deref() still apply here. Since a padsv/rv2sv must appear before a * rv2[ah]v, resolution is handled by the first call to a_pp_deref() in the * expression. */ static OP *(*a_old_ck_rv2av)(pTHX_ OP *) = 0; static OP *(*a_old_ck_rv2hv)(pTHX_ OP *) = 0; static OP *a_ck_rv2xv(pTHX_ OP *o) { OP * (*old_ck)(pTHX_ OP *o) = 0; OP * (*new_pp)(pTHX) = 0; UV hint; switch (o->op_type) { case OP_RV2AV: old_ck = a_old_ck_rv2av; new_pp = a_pp_rv2av; break; case OP_RV2HV: old_ck = a_old_ck_rv2hv; new_pp = a_pp_rv2hv_simple; break; } o = old_ck(aTHX_ o); if (cUNOPo->op_first->op_type == OP_GV) return o; hint = a_hint(); if (hint & A_HINT_DO && !(hint & A_HINT_STRICT)) { a_map_store_root(o, o->op_ppaddr, hint); o->op_ppaddr = new_pp; } else a_map_delete(o); return o; } /* ... ck_xslice (aslice,hslice) ........................................... */ /* I think those are only found at the root, but there's nothing that really * prevent them to be inside the expression too. We only need to update the * root so that the rest of the expression will see the right context when * resolving. That's why we don't replace the ppaddr. */ static OP *(*a_old_ck_aslice)(pTHX_ OP *) = 0; static OP *(*a_old_ck_hslice)(pTHX_ OP *) = 0; static OP *a_ck_xslice(pTHX_ OP *o) { OP * (*old_ck)(pTHX_ OP *o) = 0; UV hint = a_hint(); switch (o->op_type) { case OP_ASLICE: old_ck = a_old_ck_aslice; break; case OP_HSLICE: old_ck = a_old_ck_hslice; if (hint & A_HINT_DO) a_recheck_rv2xv(OpSIBLING(cUNOPo->op_first), OP_RV2HV, a_pp_rv2hv); break; } o = old_ck(aTHX_ o); if (hint & A_HINT_DO) { a_map_store_root(o, 0, hint); } else a_map_delete(o); return o; } /* ... ck_root (exists,delete,keys,values) ................................. */ /* Those ops are only found at the root of a dereferencing expression. We can * then resolve at compile time if vivification must take place or not. */ static OP *(*a_old_ck_exists)(pTHX_ OP *) = 0; static OP *(*a_old_ck_delete)(pTHX_ OP *) = 0; static OP *(*a_old_ck_keys) (pTHX_ OP *) = 0; static OP *(*a_old_ck_values)(pTHX_ OP *) = 0; static OP *a_ck_root(pTHX_ OP *o) { OP * (*old_ck)(pTHX_ OP *o) = 0; OP * (*new_pp)(pTHX) = 0; int enabled = 0; UV hint = a_hint(); switch (o->op_type) { case OP_EXISTS: old_ck = a_old_ck_exists; new_pp = a_pp_root_binop; enabled = hint & A_HINT_EXISTS; break; case OP_DELETE: old_ck = a_old_ck_delete; new_pp = a_pp_root_binop; enabled = hint & A_HINT_DELETE; break; case OP_KEYS: old_ck = a_old_ck_keys; new_pp = a_pp_root_unop; enabled = hint & A_HINT_KEYS; break; case OP_VALUES: old_ck = a_old_ck_values; new_pp = a_pp_root_unop; enabled = hint & A_HINT_VALUES; break; } o = old_ck(aTHX_ o); if (hint & A_HINT_DO) { if (enabled) { #if A_HAS_SCALARKEYS_OPT if ((enabled == A_HINT_KEYS) && (o->op_flags & OPf_KIDS)) { OP *kid = cUNOPo->op_first; if (kid->op_type == OP_RV2HV) { dA_MAP_THX; const a_op_info *koi = a_map_fetch(kid); a_map_store(kid, koi ? koi->old_pp : kid->op_ppaddr, NULL, hint | A_HINT_SECOND); if (!koi) kid->op_ppaddr = a_pp_rv2hv; } } #endif a_map_update_flags_topdown(o, A_HINT_SECOND, hint | A_HINT_DEREF); a_map_store_root(o, o->op_ppaddr, hint); o->op_ppaddr = new_pp; } else { a_map_update_flags_topdown(o, 0, 0); } } else a_map_delete(o); return o; } /* --- Our peephole optimizer ---------------------------------------------- */ static void xsh_peep_rec(pTHX_ OP *o, ptable *seen) { for (; o; o = o->op_next) { dA_MAP_THX; const a_op_info *oi = NULL; UV flags = 0; if (xsh_peep_seen(o, seen)) break; switch (o->op_type) { case OP_PADSV: if (o->op_ppaddr != a_pp_deref) { oi = a_map_fetch(o); if (oi && (oi->flags & A_HINT_DO)) { a_map_store(o, o->op_ppaddr, oi->next, oi->flags); o->op_ppaddr = a_pp_deref; } } /* FALLTHROUGH */ case OP_AELEM: case OP_AELEMFAST: case OP_HELEM: case OP_RV2SV: if (o->op_ppaddr != a_pp_deref) break; oi = a_map_fetch(o); if (!oi) break; flags = oi->flags; if (!(flags & A_HINT_DEREF) && (flags & A_HINT_DO) && (o->op_private & OPpDEREF || flags & A_HINT_ROOT)) { /* Decide if the expression must autovivify or not. */ flags = a_map_resolve(o, oi); } if (flags & A_HINT_DEREF) o->op_private = ((o->op_private & ~OPpDEREF) | OPpLVAL_DEFER); else o->op_ppaddr = oi->old_pp; break; case OP_RV2AV: if (o->op_ppaddr != a_pp_rv2av) break; oi = a_map_fetch(o); if (!oi) break; if (!(oi->flags & A_HINT_DEREF)) o->op_ppaddr = oi->old_pp; break; case OP_RV2HV: if (o->op_ppaddr != a_pp_rv2hv && o->op_ppaddr != a_pp_rv2hv_simple) break; oi = a_map_fetch(o); if (!oi) break; if (!(oi->flags & A_HINT_DEREF)) { o->op_ppaddr = oi->old_pp; break; } #if A_HAS_SCALARKEYS_OPT flags = oi->flags; if ((flags & A_HINT_KEYS) && (flags & A_HINT_SECOND)) { U8 want = o->op_flags & OPf_WANT; if (want == OPf_WANT_VOID || want == OPf_WANT_SCALAR) o->op_ppaddr = a_pp_rv2hv_dokeys; else if (oi->old_pp == a_pp_rv2hv || oi->old_pp == a_pp_rv2hv_simple) o->op_ppaddr = oi->old_pp; } #endif break; #if A_HAS_MULTIDEREF case OP_MULTIDEREF: if (o->op_ppaddr != a_pp_multideref) { oi = a_map_fetch(cUNOPo->op_first); if (!oi) break; flags = oi->flags; if (a_do_multideref(o, flags)) { a_map_store_root(o, o->op_ppaddr, flags & ~A_HINT_DEREF); o->op_ppaddr = a_pp_multideref; } } break; #endif default: xsh_peep_maybe_recurse(o, seen); break; } } } /* --- Module setup/teardown ----------------------------------------------- */ static void xsh_user_global_setup(pTHX) { a_op_map = ptable_new(32); #ifdef USE_ITHREADS MUTEX_INIT(&a_op_map_mutex); #endif xsh_ck_replace(OP_PADANY, a_ck_padany, &a_old_ck_padany); xsh_ck_replace(OP_PADSV, a_ck_padsv, &a_old_ck_padsv); xsh_ck_replace(OP_AELEM, a_ck_deref, &a_old_ck_aelem); xsh_ck_replace(OP_HELEM, a_ck_deref, &a_old_ck_helem); xsh_ck_replace(OP_RV2SV, a_ck_deref, &a_old_ck_rv2sv); xsh_ck_replace(OP_RV2AV, a_ck_rv2xv, &a_old_ck_rv2av); xsh_ck_replace(OP_RV2HV, a_ck_rv2xv, &a_old_ck_rv2hv); xsh_ck_replace(OP_ASLICE, a_ck_xslice, &a_old_ck_aslice); xsh_ck_replace(OP_HSLICE, a_ck_xslice, &a_old_ck_hslice); xsh_ck_replace(OP_EXISTS, a_ck_root, &a_old_ck_exists); xsh_ck_replace(OP_DELETE, a_ck_root, &a_old_ck_delete); xsh_ck_replace(OP_KEYS, a_ck_root, &a_old_ck_keys); xsh_ck_replace(OP_VALUES, a_ck_root, &a_old_ck_values); return; } static void xsh_user_local_setup(pTHX) { HV *stash; stash = gv_stashpvn(XSH_PACKAGE, XSH_PACKAGE_LEN, 1); newCONSTSUB(stash, "A_HINT_STRICT", newSVuv(A_HINT_STRICT)); newCONSTSUB(stash, "A_HINT_WARN", newSVuv(A_HINT_WARN)); newCONSTSUB(stash, "A_HINT_FETCH", newSVuv(A_HINT_FETCH)); newCONSTSUB(stash, "A_HINT_STORE", newSVuv(A_HINT_STORE)); newCONSTSUB(stash, "A_HINT_KEYS", newSVuv(A_HINT_KEYS)); newCONSTSUB(stash, "A_HINT_VALUES", newSVuv(A_HINT_VALUES)); newCONSTSUB(stash, "A_HINT_EXISTS", newSVuv(A_HINT_EXISTS)); newCONSTSUB(stash, "A_HINT_DELETE", newSVuv(A_HINT_DELETE)); newCONSTSUB(stash, "A_HINT_MASK", newSVuv(A_HINT_MASK)); newCONSTSUB(stash, "A_THREADSAFE", newSVuv(XSH_THREADSAFE)); newCONSTSUB(stash, "A_FORKSAFE", newSVuv(XSH_FORKSAFE)); return; } static void xsh_user_local_teardown(pTHX) { return; } static void xsh_user_global_teardown(pTHX) { xsh_ck_restore(OP_PADANY, &a_old_ck_padany); xsh_ck_restore(OP_PADSV, &a_old_ck_padsv); xsh_ck_restore(OP_AELEM, &a_old_ck_aelem); xsh_ck_restore(OP_HELEM, &a_old_ck_helem); xsh_ck_restore(OP_RV2SV, &a_old_ck_rv2sv); xsh_ck_restore(OP_RV2AV, &a_old_ck_rv2av); xsh_ck_restore(OP_RV2HV, &a_old_ck_rv2hv); xsh_ck_restore(OP_ASLICE, &a_old_ck_aslice); xsh_ck_restore(OP_HSLICE, &a_old_ck_hslice); xsh_ck_restore(OP_EXISTS, &a_old_ck_exists); xsh_ck_restore(OP_DELETE, &a_old_ck_delete); xsh_ck_restore(OP_KEYS, &a_old_ck_keys); xsh_ck_restore(OP_VALUES, &a_old_ck_values); ptable_map_free(a_op_map); a_op_map = NULL; #ifdef USE_ITHREADS MUTEX_DESTROY(&a_op_map_mutex); #endif return; } /* --- XS ------------------------------------------------------------------ */ MODULE = autovivification PACKAGE = autovivification PROTOTYPES: ENABLE BOOT: { xsh_setup(); } #if XSH_THREADSAFE void CLONE(...) PROTOTYPE: DISABLE PPCODE: xsh_clone(); XSRETURN(0); #endif /* XSH_THREADSAFE */ SV * _tag(SV *hint) PROTOTYPE: $ CODE: RETVAL = xsh_hints_tag(SvOK(hint) ? SvUV(hint) : 0); OUTPUT: RETVAL SV * _detag(SV *tag) PROTOTYPE: $ CODE: if (!SvOK(tag)) XSRETURN_UNDEF; RETVAL = newSVuv(xsh_hints_detag(tag)); OUTPUT: RETVAL autovivification-0.18/Changes000644 000765 000024 00000020635 13177355057 017154 0ustar00vincentstaff000000 000000 Revision history for autovivification 0.18 2017-11-04 15:30 UTC + Fix : [RT #123411] : Compatibility with CV-in-stash optimisation Thanks Father Chrysostomos for reporting and contributing a patch. + Fix : [RT #122956] : strict/warn flags seem to simply do nothing The documentation has been amended to clarify how these two options are supposed to be used. Thanks Christian Walde for reporting. 0.17 2017-07-31 17:15 UTC + Chg : A large chunk of boilerplate XS code, which is also used in other XS modules, has been factored out of the main .xs file to a collection of .h files in the xsh subdirectory. + Fix : The new optimization in perl 5.27.3 for scalar(keys(%$hashref)) is now correcty supported. 0.16 2015-07-01 14:30 UTC + Fix : Broken linkage on Windows. 0.15 2015-05-14 20:35 UTC + Chg : The new environment variable to enable thread tests on older perls is PERL_FORCE_TEST_THREADS. Note that this variable should only be turned on by authors. + Fix : The module has been taught about the new multideref optimization, and will function properly on perl 5.21.11 and above. + Fix : The module will no longer crash or behave erratically when it is loaded by several threads (or Windows emulated processes) ran in parallel. + Fix : Update the Windows ActivePerl + gcc 3.4 workaround for ExtUtils::MakeMaker 7.04. Thanks Christian Walde for reporting and feedback on this issue. + Fix : Be really compatible with the optional OP_PARENT feature. + Tst : $ENV{$Config{ldlibpthname}} is now preserved on all platforms, which will address failures of t/43-peep.t and t/51-threads-teardown.t with unusual compilers (like icc) that link all their compiled objects to their own libraries. 0.14 2014-11-01 22:25 UTC + Fix : [RT #99458] : AnyEvent::Loop hangs if autovivification 0.13 is loaded [RT #99904] : 'no autovivification' breaks Lingua::EN::Inflect from a distance This was a regression in 0.13 which caused the peephole optimizer to loop infinitely on "... while 1" constructs. However, the Lingua::EN::Inflect problem only occured in perl 5.20 and above. Thanks Toshio Ito and Kent Fredric for reporting. 0.13 2014-10-04 16:55 UTC This release contains a change that, while being very likely to be safe, can potentially cause freezes during code compilation. Every release should be carefully tested before being put in production, but this is especially true for this one. + Add : Support for the PERL_OP_PARENT optional feature introduced in perl 5.21.2. + Doc : The CAVEATS section now warns about the global slowdown during compilation caused by this pragma. + Fix : [RT #97703] : Android support t/51-threads-teardown.t will no longer fail on Android. Thanks Brian Fraser for reporting. + Fix : Segfaults in eval in an END block of a Win32 pseudo-fork. + Fix : Segfaults during global destruction of a thread or a pseudo-fork. + Opt : The global slowdown caused by this module has been greatly reduced. Thanks Ævar Arnfjörð Bjarmason for reporting and testing the change. 0.12 2013-09-05 17:20 UTC + Fix : Check functions are now replaced and restored in a thread-safe manner, either by using the wrap_op_checker() function from perl when it is available (starting from perl 5.16) or by taking the OP_REFCNT mutex on older perls. + Tst : Author tests are no longer bundled with this distribution. They are only made available to authors in the git repository. 0.11 2013-02-08 19:25 UTC This is a maintenance release. The code contains no functional change. Satisfied users of version 0.10 can skip this update. + Doc : POD tweaks and clarifications. + Tst : Threads tests will not fail anymore if resources constraints prevent the system from creating all the required threads. + Tst : Author tests overhaul. 0.10 2011-08-24 15:00 UTC + Fix : The pragma no longer vivifies the "autovivification" entry in the hints hash %^H on perl 5.8. 0.09 2011-01-05 18:40 UTC + Fix : [RT #64435] : Hangs with File::Copy in Config.pm. This was actually a regression introduced together with the new peephole optimizer strategy, and that caused the pragma to hang on constructs like "for (;;) { ... }". Thanks Michael Schilli for reporting. 0.08 2011-01-03 21:00 UTC + Fix : Building on Windows. 0.07 2010-12-31 16:20 UTC + Chg : perl 5.8.3 is required. + Doc : Complements and clarifications. + Fix : Segmentation faults and misbehaviours in threaded applications. + Fix : Compatibility with perl 5.13.7. Thanks Andreas J. König for reporting and Andrew Main for providing a fix. + Fix : Broken linkage on Windows with gcc 3.4, which appears in particular when using ActivePerl's default compiler suite. For those setups, the autovivification shared library will now be linked against the perl dll directly (instead of the import library). + Opt : The pragma takes slightly more time at compile-time, but is slightly faster at run-time. + Tst : Lengthy tests have been ported to Test::Leaner, making the whole test suite about 50% faster. + Tst : Threads tests are now only run on perl 5.13.4 and higher. They could segfault randomly because of what seems to be an internal bug of Perl, which has been addressed in 5.13.4. There is also an environment variable that allows you to forcefully run those tests, but it should be set only for author testing and not for end users. 0.06 2010-04-24 17:40 UTC + Add : The A_THREADSAFE and A_FORKSAFE constants. + Fix : [RT #56870] : "no autovivification" vs Regexp::Common. This was a bug in how tied arrays and hashes were handled. Thanks Michael G. Schwern for reporting. + Fix : Scope leaks under perl 5.8-5.10.0. + Fix : Segfaults when first loading the pragma from inside a thread. 0.05 2010-03-05 23:15 UTC + Fix : [RT #55154] : Crashes and assertion failures when deparsing and re-eval-uating some code compiled while autovivification was in use. Thanks Michael G. Schwern for reporting. + Fix : [RT #53647] : "leys" typo in pod. Thanks Hinrik Orn Sigurdsson for reporting. 0.04 2010-01-10 00:30 UTC + Add : Array and hash slices are now handled by the pragma. + Fix : Work around Kwalitee test misfailures. 0.03 2009-06-23 22:20 UTC + Add : Handle old-fashion dereferencing (like $$hashref{key}). + Chg : Aliasing constructs (for ($x{foo}) { ... }) are now covered by the 'store' category (and no longer the 'fetch' one). This is because there's no way to know at compile-time if the alias will be assigned to. + Fix : Quadratic complexity at compile-time. + Fix : Segfaults when dereferencing globals. + Fix : Segfaults on big-endian systems. + Tst : Really test plain arrays and hashes. + Tst : Improved coverage. 0.02 2009-06-17 18:05 UTC + Add : 'fetch' also applies to aliasing ("for ($hashref->{key}) { }"). + Fix : Don't segfault on "keys/values %$hashref", and don't vivify if 'fetch' is set. + Fix : Plain dereferencing shouldn't have a different behaviour when the pragma is in use. + Tst : Improved coverage. 0.01 2009-06-14 20:10 UTC First version, released on an unsuspecting world. autovivification-0.18/lib/000755 000765 000024 00000000000 13177355077 016423 5ustar00vincentstaff000000 000000 autovivification-0.18/Makefile.PL000644 000765 000024 00000007642 13137650610 017623 0ustar00vincentstaff000000 000000 use 5.008_003; use strict; use warnings; use ExtUtils::MakeMaker; use Config; if ($Config{d_cplusplus}) { print STDERR <<'FAILPLUSPLUS'; Configuration aborted: C++ compilers are not supported Your perl has been built with a C++ compiler, which is then handed to XS extensions as if it were a proper C compiler. This extension is written in C, and naturally only supports C compilers, so it cannot be built with your perl. Note that building perl with a C++ compiler is only supposed to be done by core developers in order to check that the perl headers can be included from C++ code. Its use in the wild is not supported by the perl5 porters. If your vendor has built its perl binary with a C++ compiler, please consider reporting this issue to them. This text will be displayed 10 seconds, and then the configuration script will exit. FAILPLUSPLUS sleep 10; exit 0; } my @DEFINES; my %macro; my $is_gcc_34 = 0; print "Checking if this is gcc 3.4 on Windows trying to link against an import library... "; if ($^O eq 'MSWin32' and not grep /^LD[A-Z]*=/, @ARGV) { my ($libperl, $gccversion) = map $_ || '', @Config{qw}; if ($gccversion =~ /^3\.4\.[0-9]+/ and $libperl =~ s/\.lib$//) { $is_gcc_34 = 1; my ($lddlflags, $ldflags) = @Config{qw}; $_ ||= '', s/-L(?:".*?"|\S+)//g for $lddlflags, $ldflags; $libperl = "-l$libperl"; my $libdirs = join ' ', map { s/(?}; $macro{LDDLFLAGS} = "$lddlflags $libdirs $libperl"; $macro{LDFLAGS} = "$ldflags $libdirs $libperl"; eval <<' MY_SECTION'; package MY; sub dynamic_lib { my $self = shift; my $inherited = $self->SUPER::dynamic_lib(@_); $inherited =~ s/"?\$\(PERL_ARCHIVE\)"?//g; return $inherited; } MY_SECTION die $@ if $@; } } print $is_gcc_34 ? "yes\n" : "no\n"; # Threads, Windows and 5.8.x don't seem to be best friends if ($^O eq 'MSWin32' && "$]" < 5.009) { push @DEFINES, '-DXSH_MULTIPLICITY=0'; } # Fork emulation got "fixed" in 5.10.1 if ($^O eq 'MSWin32' && "$]" < 5.010_001) { push @DEFINES, '-DXSH_FORKSAFE=0'; } @DEFINES = (DEFINE => join ' ', @DEFINES) if @DEFINES; %macro = (macro => { %macro }) if %macro; # Beware of the circle my $dist = 'autovivification'; (my $name = $dist) =~ s{-}{::}g; (my $file = $dist) =~ s{-}{/}g; $file = "lib/$file.pm"; my %PREREQ_PM = ( 'XSLoader' => 0, ); my %BUILD_REQUIRES = ( 'Config' => 0, 'Exporter' => 0, 'ExtUtils::MakeMaker' => 0, 'POSIX' => 0, 'Test::More' => 0, %PREREQ_PM, ); my %META = ( configure_requires => { 'ExtUtils::MakeMaker' => 0, }, build_requires => { %BUILD_REQUIRES, }, dynamic_config => 1, resources => { bugtracker => "http://rt.cpan.org/Dist/Display.html?Name=$dist", homepage => "http://search.cpan.org/dist/$dist/", license => 'http://dev.perl.org/licenses/', repository => "http://git.profvince.com/?p=perl%2Fmodules%2F$dist.git", }, ); WriteMakefile( NAME => $name, AUTHOR => 'Vincent Pit ', LICENSE => 'perl', VERSION_FROM => $file, ABSTRACT_FROM => $file, PL_FILES => {}, @DEFINES, BUILD_REQUIRES => \%BUILD_REQUIRES, PREREQ_PM => \%PREREQ_PM, MIN_PERL_VERSION => '5.008003', META_MERGE => \%META, dist => { PREOP => "pod2text -u $file > \$(DISTVNAME)/README", COMPRESS => 'gzip -9f', SUFFIX => 'gz' }, clean => { FILES => "$dist-* *.gcov *.gcda *.gcno cover_db Debian_CPANTS.txt*" }, %macro, ); package MY; sub postamble { return <<'POSTAMBLE'; testdeb: all PERL_DL_NONLAZY=1 PERLDB_OPTS="NonStop=1" $(FULLPERLRUN) -MTAP::Harness -e 'TAP::Harness->new({verbosity => q{$(VERBOSE)}, lib => [ q{$(INST_LIB)}, q{$(INST_ARCHLIB)} ], switches => [ q{-d} ]})->runtests(@ARGV)' $(TEST_FILES) POSTAMBLE } autovivification-0.18/MANIFEST000644 000765 000024 00000002020 13137651237 016771 0ustar00vincentstaff000000 000000 Changes MANIFEST META.json META.yml Makefile.PL README autovivification.xs lib/autovivification.pm samples/bench.pl samples/hash2array.pl t/00-load.t t/09-load-threads.t t/20-hash.t t/22-hash-kv.t t/23-hash-tied.t t/24-hash-numerous.t t/30-array.t t/31-array-fast.t t/32-array-kv.t t/33-array-tied.t t/34-array-numerous.t t/40-scope.t t/41-padsv.t t/42-deparse.t t/43-peep.t t/44-multideref.t t/50-threads.t t/51-threads-teardown.t t/lib/Test/Leaner.pm t/lib/VPIT/TestHelpers.pm t/lib/autovivification/TestCases.pm t/lib/autovivification/TestRequired1.pm t/lib/autovivification/TestRequired2.pm t/lib/autovivification/TestRequired4/a0.pm t/lib/autovivification/TestRequired4/b0.pm t/lib/autovivification/TestRequired4/c0.pm t/lib/autovivification/TestRequired5/a0.pm t/lib/autovivification/TestRequired5/b0.pm t/lib/autovivification/TestRequired5/c0.pm t/lib/autovivification/TestRequired5/d0.pm t/lib/autovivification/TestRequired6.pm xsh/caps.h xsh/debug.h xsh/hints.h xsh/mem.h xsh/ops.h xsh/peep.h xsh/ptable.h xsh/threads.h xsh/util.h autovivification-0.18/META.json000644 000765 000024 00000002743 13177355077 017304 0ustar00vincentstaff000000 000000 { "abstract" : "Lexically disable autovivification.", "author" : [ "Vincent Pit " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.3, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "autovivification", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "Config" : "0", "Exporter" : "0", "ExtUtils::MakeMaker" : "0", "POSIX" : "0", "Test::More" : "0", "XSLoader" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "XSLoader" : "0", "perl" : "5.008003" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "http://rt.cpan.org/Dist/Display.html?Name=autovivification" }, "homepage" : "http://search.cpan.org/dist/autovivification/", "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "http://git.profvince.com/?p=perl%2Fmodules%2Fautovivification.git" } }, "version" : "0.18", "x_serialization_backend" : "JSON::PP version 2.94" } autovivification-0.18/META.yml000644 000765 000024 00000001633 13177355077 017131 0ustar00vincentstaff000000 000000 --- abstract: 'Lexically disable autovivification.' author: - 'Vincent Pit ' build_requires: Config: '0' Exporter: '0' ExtUtils::MakeMaker: '0' POSIX: '0' Test::More: '0' XSLoader: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.3, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: autovivification no_index: directory: - t - inc requires: XSLoader: '0' perl: '5.008003' resources: bugtracker: http://rt.cpan.org/Dist/Display.html?Name=autovivification homepage: http://search.cpan.org/dist/autovivification/ license: http://dev.perl.org/licenses/ repository: http://git.profvince.com/?p=perl%2Fmodules%2Fautovivification.git version: '0.18' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' autovivification-0.18/README000644 000765 000024 00000015771 13177355100 016533 0ustar00vincentstaff000000 000000 NAME autovivification - Lexically disable autovivification. VERSION Version 0.18 SYNOPSIS no autovivification; my $hashref; my $a = $hashref->{key_a}; # $hashref stays undef if (exists $hashref->{option}) { # Still undef ... } delete $hashref->{old}; # Still undef again $hashref->{new} = $value; # Vivifies to { new => $value } DESCRIPTION When an undefined variable is dereferenced, it gets silently upgraded to an array or hash reference (depending of the type of the dereferencing). This behaviour is called *autovivification* and usually does what you mean (e.g. when you store a value) but it may be unnatural or surprising because your variables gets populated behind your back. This is especially true when several levels of dereferencing are involved, in which case all levels are vivified up to the last, or when it happens in intuitively read-only constructs like "exists". This pragma lets you disable autovivification for some constructs and optionally throws a warning or an error when it would have happened. METHODS "unimport" no autovivification; # defaults to qw no autovivification qw; no autovivification warn => @categories; no autovivification strict => @categories; Magically called when "no autovivification @opts" is encountered. Enables the features given in @opts, which can be : * 'fetch' Turns off autovivification for rvalue dereferencing expressions, such as : $value = $arrayref->[$idx] $value = $hashref->{$key} keys %$hashref values %$hashref Starting from perl 5.11, it also covers "keys" and "values" on array references : keys @$arrayref values @$arrayref When the expression would have autovivified, "undef" is returned for a plain fetch, while "keys" and "values" return 0 in scalar context and the empty list in list context. * 'exists' Turns off autovivification for dereferencing expressions that are parts of an "exists", such as : exists $arrayref->[$idx] exists $hashref->{$key} '' is returned when the expression would have autovivified. * 'delete' Turns off autovivification for dereferencing expressions that are parts of a "delete", such as : delete $arrayref->[$idx] delete $hashref->{$key} "undef" is returned when the expression would have autovivified. * 'store' Turns off autovivification for lvalue dereferencing expressions, such as : $arrayref->[$idx] = $value $hashref->{$key} = $value for ($arrayref->[$idx]) { ... } for ($hashref->{$key}) { ... } function($arrayref->[$idx]) function($hashref->{$key}) An exception is thrown if vivification is needed to store the value, which means that effectively you can only assign to levels that are already defined. In the example, this would require $arrayref (resp. $hashref) to already be an array (resp. hash) reference. * 'warn' Emits a warning when an autovivification is avoided for the categories specified in @opts. Note that "no autovivification 'warn'" currently does nothing by itself, in particular it does not make the default categories warn. This behaviour may change in a future version of this pragma. * 'strict' Throws an exception when an autovivification is avoided for the categories specified in @opts. Note that "no autovivification 'strict'" currently does nothing by itself, in particular it does not make the default categories die. This behaviour may change in a future version of this pragma. Each call to "unimport" adds the specified features to the ones already in use in the current lexical scope. When @opts is empty, it defaults to "qw". "import" use autovivification; # default Perl behaviour use autovivification qw; Magically called when "use autovivification @opts" is encountered. Disables the features given in @opts, which can be the same as for "unimport". Each call to "import" removes the specified features to the ones already in use in the current lexical scope. When @opts is empty, it defaults to restoring the original Perl autovivification behaviour. CONSTANTS "A_THREADSAFE" True if and only if the module could have been built with thread-safety features enabled. This constant only has a meaning when your perl is threaded, otherwise it will always be false. "A_FORKSAFE" True if and only if this module could have been built with fork-safety features enabled. This constant will always be true, except on Windows where it is false for perl 5.10.0 and below. CAVEATS Using this pragma will cause a slight global slowdown of any subsequent compilation phase that happens anywere in your code - even outside of the scope of use of "no autovivification" - which may become noticeable if you rely heavily on numerous calls to "eval STRING". The pragma doesn't apply when one dereferences the returned value of an array or hash slice, as in "@array[$id]->{member}" or @hash{$key}->{member}. This syntax is valid Perl, yet it is discouraged as the slice is here useless since the dereferencing enforces scalar context. If warnings are turned on, Perl will complain about one-element slices. Autovivifications that happen in code "eval"'d during the global destruction phase of a spawned thread or pseudo-fork (the processes used internally for the "fork" emulation on Windows) are not reported. DEPENDENCIES perl 5.8.3. A C compiler. This module may happen to build with a C++ compiler as well, but don't rely on it, as no guarantee is made in this regard. XSLoader (standard since perl 5.6.0). SEE ALSO perlref. AUTHOR Vincent Pit, "", . You can contact me by mail or on "irc.perl.org" (vincent). BUGS Please report any bugs or feature requests to "bug-autovivification at rt.cpan.org", or through the web interface at . I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. SUPPORT You can find documentation for this module with the perldoc command. perldoc autovivification ACKNOWLEDGEMENTS Matt S. Trout asked for it. COPYRIGHT & LICENSE Copyright 2009,2010,2011,2012,2013,2014,2015,2017 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. autovivification-0.18/samples/000755 000765 000024 00000000000 13177355077 017321 5ustar00vincentstaff000000 000000 autovivification-0.18/t/000755 000765 000024 00000000000 13177355077 016120 5ustar00vincentstaff000000 000000 autovivification-0.18/xsh/000755 000765 000024 00000000000 13177355077 016457 5ustar00vincentstaff000000 000000 autovivification-0.18/xsh/caps.h000644 000765 000024 00000002733 13137651151 017547 0ustar00vincentstaff000000 000000 #ifndef XSH_CAPS_H #define XSH_CAPS_H 1 #ifdef __cplusplus # error C++ compilers are not supported #endif #define XSH_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S)))))) #define XSH_HAS_PERL_BRANCH(R, V, S) (PERL_REVISION == (R) && PERL_VERSION == (V) && PERL_SUBVERSION >= (S)) #define XSH_HAS_PERL_EXACT(R, V, S) ((PERL_REVISION == (R)) && (PERL_VERSION == (V)) && (PERL_SUBVERSION == (S))) #ifndef XSH_PERL_PATCHLEVEL # ifdef PERL_PATCHNUM # define XSH_PERL_PATCHLEVEL PERL_PATCHNUM # else # define XSH_PERL_PATCHLEVEL 0 # endif #endif #define XSH_HAS_PERL_MAINT(R, V, S, P) (PERL_REVISION == (R) && PERL_VERSION == (V) && (XSH_PERL_PATCHLEVEL >= (P) || (!XSH_PERL_PATCHLEVEL && PERL_SUBVERSION >= (S)))) #ifndef XSH_MULTIPLICITY # if defined(MULTIPLICITY) # define XSH_MULTIPLICITY 1 # else # define XSH_MULTIPLICITY 0 # endif #endif #if XSH_MULTIPLICITY # ifndef PERL_IMPLICIT_CONTEXT # error MULTIPLICITY builds must set PERL_IMPLICIT_CONTEXT # endif # ifndef tTHX # define tTHX PerlInterpreter* # endif #endif #if XSH_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)) # define XSH_THREADSAFE 1 #else # define XSH_THREADSAFE 0 #endif /* Safe unless stated otherwise in Makefile.PL */ #ifndef XSH_FORKSAFE # define XSH_FORKSAFE 1 #endif #endif /* XSH_CAPS_H */ autovivification-0.18/xsh/debug.h000644 000765 000024 00000000733 12616155034 017705 0ustar00vincentstaff000000 000000 #ifndef XSH_DEBUG_H #define XSH_DEBUG_H 1 #include "util.h" /* XSH_PACKAGE, STMT_* */ #ifndef XSH_DEBUG # define XSH_DEBUG 0 #endif #if XSH_DEBUG # define XSH_D(X) STMT_START X STMT_END static void xsh_debug_log(const char *fmt, ...) { va_list va; SV *sv; dTHX; va_start(va, fmt); sv = get_sv(XSH_PACKAGE "::DEBUG", 0); if (sv && SvTRUE(sv)) PerlIO_vprintf(Perl_debug_log, fmt, va); va_end(va); return; } #else # define XSH_D(X) #endif #endif /* XSH_DEBUG_H */ autovivification-0.18/xsh/hints.h000644 000765 000024 00000023705 13137651173 017754 0ustar00vincentstaff000000 000000 #ifndef XSH_HINTS_H #define XSH_HINTS_H 1 #include "caps.h" /* XSH_HAS_PERL(), XSH_THREADSAFE, tTHX */ #include "mem.h" /* XSH_SHARED_*() */ #ifdef XSH_THREADS_H # error threads.h must be loaded at the very end #endif #define XSH_HINTS_KEY XSH_PACKAGE #define XSH_HINTS_KEY_LEN (sizeof(XSH_HINTS_KEY)-1) #ifndef XSH_WORKAROUND_REQUIRE_PROPAGATION # define XSH_WORKAROUND_REQUIRE_PROPAGATION !XSH_HAS_PERL(5, 10, 1) #endif #ifndef XSH_HINTS_ONLY_COMPILE_TIME # define XSH_HINTS_ONLY_COMPILE_TIME 1 #endif #ifdef XSH_HINTS_TYPE_UV # ifdef XSH_HINTS_TYPE_VAL # error hint type can only be set once # endif # undef XSH_HINTS_TYPE_UV # define XSH_HINTS_TYPE_UV 1 # define XSH_HINTS_TYPE_STRUCT UV # define XSH_HINTS_TYPE_COMPACT UV # define XSH_HINTS_NEED_STRUCT 0 # define XSH_HINTS_VAL_STRUCT_REF 0 # define XSH_HINTS_VAL_NONE 0 # define XSH_HINTS_VAL_PACK(T, V) INT2PTR(T, (V)) # define XSH_HINTS_VAL_UNPACK(V) ((XSH_HINTS_TYPE_VAL) PTR2UV(V)) # define XSH_HINTS_VAL_INIT(HV, V) ((HV) = (V)) # undef XSH_HINTS_VAL_CLONE # undef XSH_HINTS_VAL_DEINIT #endif #ifdef XSH_HINTS_TYPE_SV # ifdef XSH_HINTS_TYPE_VAL # error hint type can only be set once # endif # undef XSH_HINTS_TYPE_SV # define XSH_HINTS_TYPE_SV 1 # define XSH_HINTS_TYPE_STRUCT SV * # define XSH_HINTS_TYPE_COMPACT SV # define XSH_HINTS_NEED_STRUCT 0 # define XSH_HINTS_VAL_STRUCT_REF 0 # define XSH_HINTS_VAL_NONE NULL # define XSH_HINTS_VAL_PACK(T, V) (V) # define XSH_HINTS_VAL_UNPACK(V) (V) # define XSH_HINTS_VAL_INIT(HV, V) ((HV) = (((V) != XSH_HINTS_VAL_NONE) ? SvREFCNT_inc(V) : XSH_HINTS_VAL_NONE)) # define XSH_HINTS_VAL_CLONE(N, O) ((N) = xsh_dup_inc((O), ud->params)) # define XSH_HINTS_VAL_DEINIT(V) SvREFCNT_dec(V) #endif #ifdef XSH_HINTS_TYPE_USER # ifdef XSH_HINTS_TYPE_VAL # error hint type can only be set once # endif # undef XSH_HINTS_TYPE_USER # define XSH_HINTS_TYPE_USER 1 # define XSH_HINTS_TYPE_STRUCT xsh_hints_user_t # undef XSH_HINTS_TYPE_COMPACT /* not used */ # define XSH_HINTS_NEED_STRUCT 1 # define XSH_HINTS_VAL_STRUCT_REF 1 # define XSH_HINTS_VAL_NONE NULL # define XSH_HINTS_VAL_PACK(T, V) (V) # define XSH_HINTS_VAL_UNPACK(V) (V) # define XSH_HINTS_VAL_INIT(HV, V) xsh_hints_user_init(aTHX_ (HV), (V)) # define XSH_HINTS_VAL_CLONE(NV, OV) xsh_hints_user_clone(aTHX_ (NV), (OV), ud->params) # define XSH_HINTS_VAL_DEINIT(V) xsh_hints_user_deinit(aTHX_ (V)) #endif #ifndef XSH_HINTS_TYPE_STRUCT # error hint type was not set #endif #if XSH_HINTS_VAL_STRUCT_REF # define XSH_HINTS_TYPE_VAL XSH_HINTS_TYPE_STRUCT * #else # define XSH_HINTS_TYPE_VAL XSH_HINTS_TYPE_STRUCT #endif #if XSH_WORKAROUND_REQUIRE_PROPAGATION # undef XSH_HINTS_NEED_STRUCT # define XSH_HINTS_NEED_STRUCT 1 #endif #if XSH_THREADSAFE && (defined(XSH_HINTS_VAL_CLONE) || XSH_WORKAROUND_REQUIRE_PROPAGATION) # define XSH_HINTS_NEED_CLONE 1 #else # define XSH_HINTS_NEED_CLONE 0 #endif #if XSH_WORKAROUND_REQUIRE_PROPAGATION static UV xsh_require_tag(pTHX) { #define xsh_require_tag() xsh_require_tag(aTHX) const CV *cv, *outside; cv = PL_compcv; if (!cv) { /* If for some reason the pragma is operational at run-time, try to discover * the current cv in use. */ const PERL_SI *si; for (si = PL_curstackinfo; si; si = si->si_prev) { I32 cxix; for (cxix = si->si_cxix; cxix >= 0; --cxix) { const PERL_CONTEXT *cx = si->si_cxstack + cxix; switch (CxTYPE(cx)) { case CXt_SUB: case CXt_FORMAT: /* The propagation workaround is only needed up to 5.10.0 and at that * time format and sub contexts were still identical. And even later the * cv members offsets should have been kept the same. */ cv = cx->blk_sub.cv; goto get_enclosing_cv; case CXt_EVAL: cv = cx->blk_eval.cv; goto get_enclosing_cv; default: break; } } } cv = PL_main_cv; } get_enclosing_cv: for (outside = CvOUTSIDE(cv); outside; outside = CvOUTSIDE(cv)) cv = outside; return PTR2UV(cv); } #endif /* XSH_WORKAROUND_REQUIRE_PROPAGATION */ #if XSH_HINTS_NEED_STRUCT typedef struct { XSH_HINTS_TYPE_STRUCT val; #if XSH_WORKAROUND_REQUIRE_PROPAGATION UV require_tag; #endif } xsh_hints_t; #if XSH_HINTS_VAL_STRUCT_REF # define XSH_HINTS_VAL_GET(H) (&(H)->val) #else # define XSH_HINTS_VAL_GET(H) ((H)->val) #endif #define XSH_HINTS_VAL_SET(H, V) XSH_HINTS_VAL_INIT(XSH_HINTS_VAL_GET(H), (V)) #ifdef XSH_HINTS_VAL_DEINIT # define XSH_HINTS_FREE(H) \ if (H) XSH_HINTS_VAL_DEINIT(XSH_HINTS_VAL_GET(((xsh_hints_t *) (H)))); \ XSH_SHARED_FREE((H), 1, xsh_hints_t) #else # define XSH_HINTS_FREE(H) XSH_SHARED_FREE((H), 1, xsh_hints_t) #endif #else /* XSH_HINTS_NEED_STRUCT */ typedef XSH_HINTS_TYPE_COMPACT xsh_hints_t; #define XSH_HINTS_VAL_GET(H) XSH_HINTS_VAL_UNPACK(H) #define XSH_HINTS_VAL_SET(H, V) STMT_START { XSH_HINTS_TYPE_VAL tmp; XSH_HINTS_VAL_INIT(tmp, (V)); (H) = XSH_HINTS_VAL_PACK(xsh_hints_t *, tmp); } STMT_END #undef XSH_HINTS_FREE #endif /* !XSH_HINTS_NEED_STRUCT */ /* ... Thread safety ....................................................... */ #if XSH_HINTS_NEED_CLONE #ifdef XSH_HINTS_FREE # define PTABLE_NAME ptable_hints # define PTABLE_VAL_FREE(V) XSH_HINTS_FREE(V) #else # define PTABLE_USE_DEFAULT 1 #endif #define PTABLE_NEED_WALK 1 #define PTABLE_NEED_DELETE 0 #include "ptable.h" #if PTABLE_WAS_DEFAULT # define ptable_hints_store(T, K, V) ptable_default_store(aPTBL_ (T), (K), (V)) # define ptable_hints_free(T) ptable_default_free(aPTBL_ (T)) #else # define ptable_hints_store(T, K, V) ptable_hints_store(aPTBL_ (T), (K), (V)) # define ptable_hints_free(T) ptable_hints_free(aPTBL_ (T)) #endif #define XSH_THREADS_HINTS_CONTEXT 1 typedef struct { ptable *tbl; /* It really is a ptable_hints */ tTHX owner; } xsh_hints_cxt_t; static xsh_hints_cxt_t *xsh_hints_get_cxt(pTHX); static void xsh_hints_local_setup(pTHX_ xsh_hints_cxt_t *cxt) { cxt->tbl = ptable_new(4); cxt->owner = aTHX; } static void xsh_hints_local_teardown(pTHX_ xsh_hints_cxt_t *cxt) { ptable_hints_free(cxt->tbl); cxt->owner = NULL; } typedef struct { ptable *tbl; /* It really is a ptable_hints */ CLONE_PARAMS *params; } xsh_ptable_clone_ud; static void xsh_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) { xsh_ptable_clone_ud *ud = ud_; xsh_hints_t *h1 = ent->val; xsh_hints_t *h2; #if XSH_HINTS_NEED_STRUCT XSH_SHARED_ALLOC(h2, 1, xsh_hints_t); # if XSH_WORKAROUND_REQUIRE_PROPAGATION h2->require_tag = PTR2UV(xsh_dup_inc(INT2PTR(SV *, h1->require_tag), ud->params)); # endif #endif /* XSH_HINTS_NEED_STRUCT */ #ifdef XSH_HINTS_VAL_CLONE XSH_HINTS_VAL_CLONE(XSH_HINTS_VAL_GET(h2), XSH_HINTS_VAL_GET(h1)); #endif /* defined(XSH_HINTS_VAL_CLONE) */ ptable_hints_store(ud->tbl, ent->key, h2); } static void xsh_hints_clone(pTHX_ const xsh_hints_cxt_t *old_cxt, xsh_hints_cxt_t *new_cxt, CLONE_PARAMS *params) { xsh_ptable_clone_ud ud; new_cxt->tbl = ptable_new(4); new_cxt->owner = aTHX; ud.tbl = new_cxt->tbl; ud.params = params; ptable_walk(old_cxt->tbl, xsh_ptable_clone, &ud); } #endif /* XSH_HINTS_NEED_CLONE */ /* ... tag hints ........................................................... */ static SV *xsh_hints_tag(pTHX_ XSH_HINTS_TYPE_VAL val) { #define xsh_hints_tag(V) xsh_hints_tag(aTHX_ (V)) xsh_hints_t *h; if (val == XSH_HINTS_VAL_NONE) return newSVuv(0); #if XSH_HINTS_NEED_STRUCT XSH_SHARED_ALLOC(h, 1, xsh_hints_t); # if XSH_WORKAROUND_REQUIRE_PROPAGATION h->require_tag = xsh_require_tag(); # endif #endif /* XSH_HINTS_NEED_STRUCT */ XSH_HINTS_VAL_SET(h, val); #if XSH_HINTS_NEED_CLONE /* We only need for the key to be an unique tag for looking up the value later * Allocated memory provides convenient unique identifiers, so that's why we * use the hint as the key itself. */ { xsh_hints_cxt_t *cxt = xsh_hints_get_cxt(aTHX); XSH_ASSERT(cxt->tbl); ptable_hints_store(cxt->tbl, h, h); } #endif /* !XSH_HINTS_NEED_CLONE */ return newSVuv(PTR2UV(h)); } /* ... detag hints ......................................................... */ #define xsh_hints_2uv(H) \ ((H) \ ? (SvIOK(H) \ ? SvUVX(H) \ : (SvPOK(H) \ ? sv_2uv(SvLEN(H) ? (H) : sv_mortalcopy(H)) \ : 0 \ ) \ ) \ : 0) static XSH_HINTS_TYPE_VAL xsh_hints_detag(pTHX_ SV *hint) { #define xsh_hints_detag(H) xsh_hints_detag(aTHX_ (H)) xsh_hints_t *h; UV hint_uv; hint_uv = xsh_hints_2uv(hint); h = INT2PTR(xsh_hints_t *, hint_uv); if (!h) return XSH_HINTS_VAL_NONE; #if XSH_HINTS_NEED_CLONE { xsh_hints_cxt_t *cxt = xsh_hints_get_cxt(aTHX); XSH_ASSERT(cxt->tbl); h = ptable_fetch(cxt->tbl, h); } #endif /* XSH_HINTS_NEED_CLONE */ #if XSH_WORKAROUND_REQUIRE_PROPAGATION if (xsh_require_tag() != h->require_tag) return XSH_HINTS_VAL_NONE; #endif return XSH_HINTS_VAL_GET(h); } /* ... fetch hints ......................................................... */ #if !defined(cop_hints_fetch_pvn) && XSH_HAS_PERL(5, 9, 5) # define cop_hints_fetch_pvn(COP, PKG, PKGLEN, PKGHASH, FLAGS) \ Perl_refcounted_he_fetch(aTHX_ (COP)->cop_hints_hash, NULL, \ (PKG), (PKGLEN), (FLAGS), (PKGHASH)) #endif #ifdef cop_hints_fetch_pvn static U32 xsh_hints_key_hash = 0; # define xsh_hints_global_setup(my_perl) \ PERL_HASH(xsh_hints_key_hash, XSH_HINTS_KEY, XSH_HINTS_KEY_LEN) #else /* defined(cop_hints_fetch_pvn) */ # define xsh_hints_global_setup(my_perl) #endif /* !defined(cop_hints_fetch_pvn) */ #define xsh_hints_global_teardown(my_perl) static SV *xsh_hints_fetch(pTHX) { #define xsh_hints_fetch() xsh_hints_fetch(aTHX) #if XSH_HINTS_ONLY_COMPILE_TIME if (IN_PERL_RUNTIME) return NULL; #endif #ifdef cop_hints_fetch_pvn return cop_hints_fetch_pvn(PL_curcop, XSH_HINTS_KEY, XSH_HINTS_KEY_LEN, xsh_hints_key_hash, 0); #else { SV **val = hv_fetch(GvHV(PL_hintgv), XSH_HINTS_KEY, XSH_HINTS_KEY_LEN, 0); return val ? *val : NULL; } #endif } #endif /* XSH_HINTS_H */ autovivification-0.18/xsh/mem.h000644 000765 000024 00000011762 13137651226 017404 0ustar00vincentstaff000000 000000 #ifndef XSH_MEM_H #define XSH_MEM_H 1 #include "util.h" /* XSH_ASSERT() */ #ifdef DEBUGGING # ifdef Poison # define XSH_POISON(D, N, T) Poison((D), (N), T) # endif # ifdef PoisonNew # define XSH_POISON_NEW(D, N, T) PoisonNew((D), (N), T) # define XSH_HAS_POISON_NEW 1 # endif # ifdef PoisonFree # define XSH_POISON_FREE(D, N, T) PoisonFree((D), (N), T) # define XSH_HAS_POISON_FREE 1 # endif #endif #ifdef XSH_POISON # ifndef XSH_POISON_NEW # define XSH_POISON_NEW(D, N, T) XSH_POISON(D, N, T) # define XSH_HAS_POISON_NEW 1 # endif # ifndef XSH_POISON_FREE # define XSH_POISON_FREE(D, N, T) XSH_POISON(D, N, T) # define XSH_HAS_POISON_FREE 1 # endif #endif #ifndef XSH_HAS_POISON_NEW # define XSH_HAS_POISON_NEW 0 #endif #ifndef XSH_HAS_POISON_FREE # define XSH_HAS_POISON_FREE 0 #endif /* --- Shared memory ------------------------------------------------------- */ /* Context for PerlMemShared_*() functions */ #ifdef PERL_IMPLICIT_SYS # define pPMS pTHX # define pPMS_ pTHX_ # define aPMS aTHX # define aPMS_ aTHX_ #else # define pPMS void # define pPMS_ # define aPMS # define aPMS_ #endif /* ... xsh_shared_alloc() .................................................. */ #if XSH_HAS_POISON_NEW static void *xsh_shared_alloc(pPMS_ size_t size) { #define xsh_shared_alloc(S) xsh_shared_alloc(aPMS_ (S)) void *p; p = PerlMemShared_malloc(size); XSH_ASSERT(p); XSH_POISON_NEW(p, size, char); return p; } #else /* XSH_HAS_POISON_NEW */ #define xsh_shared_alloc(S) PerlMemShared_malloc(S) #endif /* !XSH_HAS_POISON_NEW */ #define XSH_SHARED_ALLOC(D, N, T) ((D) = xsh_shared_alloc((N) * sizeof(T))) /* ... xsh_shared_calloc() ................................................. */ #define xsh_shared_calloc(C, S) PerlMemShared_calloc((C), (S)) #define XSH_SHARED_CALLOC(D, N, T) ((D) = xsh_shared_calloc((N), sizeof(T))) /* ... xsh_shared_free() ................................................... */ #if XSH_HAS_POISON_FREE static void xsh_shared_free(pPMS_ void *p, size_t size) { #define xsh_shared_free(P, S) xsh_shared_free(aPMS_ (P), (S)) if (p) XSH_POISON_FREE(p, size, char); PerlMemShared_free(p); return; } #else /* XSH_HAS_POISON_FREE */ #define xsh_shared_free(P, S) PerlMemShared_free(P) #endif /* !XSH_HAS_POISON_FREE */ #define XSH_SHARED_FREE(D, N, T) (xsh_shared_free((D), (N) * sizeof(T)), (D) = NULL) /* ... xsh_shared_realloc() ................................................ */ #if XSH_HAS_POISON_NEW && XSH_HAS_POISON_FREE static void *xsh_shared_realloc(pPMS_ void *p, size_t old_size, size_t new_size) { #define xsh_shared_realloc(P, OS, NS) xsh_shared_realloc(aPMS_ (P), (OS), (NS)) void *q; if (!p) return xsh_shared_alloc(new_size); if (!new_size) { xsh_shared_free(p, old_size); return xsh_shared_alloc(1); } if (new_size < old_size) XSH_POISON_FREE(((char *) p) + new_size, old_size - new_size, char); q = PerlMemShared_realloc(p, new_size); XSH_ASSERT(q); if (old_size < new_size) XSH_POISON_NEW(((char *) q) + old_size, new_size - old_size, char); return q; } #else /* XSH_HAS_POISON_NEW && XSH_HAS_POISON_FREE */ #define xsh_shared_realloc(P, OS, NS) PerlMemShared_realloc((P), (NS)) #endif /* !XSH_HAS_POISON_NEW || !XSH_HAS_POISON_FREE */ #define XSH_SHARED_REALLOC(D, OL, NL, T) ((D) = xsh_shared_realloc((D), (OL) * sizeof(T), (NL) * sizeof(T))) /* ... xsh_shared_recalloc() ............................................... */ static void *xsh_shared_recalloc(pPMS_ void *p, size_t old_size, size_t new_size) { #define xsh_shared_recalloc(P, OS, NS) xsh_shared_recalloc(aPMS_ (P), (OS), (NS)) void *q; #ifdef XSH_POISON_FREE if (new_size < old_size) XSH_POISON_FREE(((char *) p) + new_size, old_size - new_size, char); #endif /* XSH_POISON_FREE */ q = PerlMemShared_realloc(p, new_size); XSH_ASSERT(q); if (old_size < new_size) Zero(((char *) q) + old_size, new_size - old_size, char); return q; } #define XSH_SHARED_RECALLOC(D, OL, NL, T) ((D) = xsh_shared_recalloc((D), (OL) * sizeof(T), (NL) * sizeof(T))) /* --- Interpreter-local memory -------------------------------------------- */ #ifndef Newx # define Newx(D, N, T) New(0, (D), (N), T) #endif #ifndef PERL_POISON #if XSH_HAS_POISON_NEW # define XSH_LOCAL_ALLOC(D, N, T) (Newx((D), (N), T), XSH_POISON_NEW((D), (N), T)) #endif #if XSH_HAS_POISON_FREE # define XSH_LOCAL_FREE(D, N, T) (XSH_POISON_FREE((D), (N), T), Safefree(D)) #endif #if XSH_HAS_POISON_NEW && XSH_HAS_POISON_FREE # define XSH_LOCAL_REALLOC(D, OL, NL, T) ((((D) && ((NL) < (OL))) ? XSH_POISON_FREE(((T *) (D)) + (NL), (OL) - (NL), T) : NOOP), Renew((D), (NL), T), (((OL) < (NL)) ? XSH_POISON_NEW(((T *) (D)) + (OL), (NL) - (OL), T) : NOOP)) #endif #endif /* !PERL_POISON */ #ifndef XSH_LOCAL_ALLOC # define XSH_LOCAL_ALLOC(D, N, T) Newx((D), (N), T) #endif #define XSH_LOCAL_CALLOC(D, N, T) Newxz((D), (N), T) #ifndef XSH_LOCAL_FREE # define XSH_LOCAL_FREE(D, N, T) Safefree(D) #endif #ifndef XSH_LOCAL_REALLOC # define XSH_LOCAL_REALLOC(D, OL, NL, T) Renew((D), (NL), T) #endif #endif /* XSH_MEM_H */ autovivification-0.18/xsh/ops.h000644 000765 000024 00000003646 12616155034 017426 0ustar00vincentstaff000000 000000 #ifndef XSH_OPS_H #define XSH_OPS_H 1 #include "caps.h" /* XSH_HAS_PERL() */ #include "util.h" /* NOOP */ #ifdef XSH_THREADS_H # error threads.h must be loaded at the very end #endif #ifndef XSH_THREADS_GLOBAL_SETUP # define XSH_THREADS_GLOBAL_SETUP 1 #endif #ifndef XSH_THREADS_GLOBAL_TEARDOWN # define XSH_THREADS_GLOBAL_TEARDOWN 1 #endif #ifndef OpSIBLING # ifdef OP_SIBLING # define OpSIBLING(O) OP_SIBLING(O) # else # define OpSIBLING(O) ((O)->op_sibling) # endif #endif #ifndef OpMAYBESIB_set # define OpMAYBESIB_set(O, S, P) ((O)->op_sibling = (S)) #endif #ifndef OP_NAME # define OP_NAME(O) (PL_op_name[(O)->op_type]) #endif #ifndef OP_CLASS # define OP_CLASS(O) (PL_opargs[(O)->op_type] & OA_CLASS_MASK) #endif #if defined(OP_CHECK_MUTEX_LOCK) && defined(OP_CHECK_MUTEX_UNLOCK) # define XSH_CHECK_LOCK OP_CHECK_MUTEX_LOCK # define XSH_CHECK_UNLOCK OP_CHECK_MUTEX_UNLOCK #elif XSH_HAS_PERL(5, 9, 3) # define XSH_CHECK_LOCK OP_REFCNT_LOCK # define XSH_CHECK_UNLOCK OP_REFCNT_UNLOCK #else /* Before perl 5.9.3, da_ck_*() calls are already protected by the XSH_LOADED * mutex, which falls back to the OP_REFCNT mutex. Make sure we don't lock it * twice. */ # define XSH_CHECK_LOCK NOOP # define XSH_CHECK_UNLOCK NOOP #endif typedef OP *(*xsh_check_t)(pTHX_ OP *); #ifdef wrap_op_checker # define xsh_ck_replace(T, NC, OCP) wrap_op_checker((T), (NC), (OCP)) #else static void xsh_ck_replace(pTHX_ OPCODE type, xsh_check_t new_ck, xsh_check_t *old_ck_p) { #define xsh_ck_replace(T, NC, OCP) xsh_ck_replace(aTHX_ (T), (NC), (OCP)) XSH_CHECK_LOCK; if (!*old_ck_p) { *old_ck_p = PL_check[type]; PL_check[type] = new_ck; } XSH_CHECK_UNLOCK; } #endif static void xsh_ck_restore(pTHX_ OPCODE type, xsh_check_t *old_ck_p) { #define xsh_ck_restore(T, OCP) xsh_ck_restore(aTHX_ (T), (OCP)) XSH_CHECK_LOCK; if (*old_ck_p) { PL_check[type] = *old_ck_p; *old_ck_p = 0; } XSH_CHECK_UNLOCK; } #endif /* XSH_OPS_H */ autovivification-0.18/xsh/peep.h000644 000765 000024 00000007142 12616155034 017551 0ustar00vincentstaff000000 000000 #ifndef XSH_PEEP_H #define XSH_PEEP_H 1 #include "caps.h" /* XSH_HAS_PERL(), XSH_THREADSAFE */ #include "util.h" /* XSH_ASSERT(), NOOP */ #ifdef XSH_THREADS_H # error threads.h must be loaded at the very end #endif #ifndef XSH_HAS_RPEEP # define XSH_HAS_RPEEP XSH_HAS_PERL(5, 13, 5) #endif #define PTABLE_USE_DEFAULT 1 #define PTABLE_NEED_DELETE 0 #include "ptable.h" #define ptable_seen_store(T, K, V) ptable_default_store(aPTBL_ (T), (K), (V)) #define ptable_seen_clear(T) ptable_default_clear(aPTBL_ (T)) #define ptable_seen_free(T) ptable_default_free(aPTBL_ (T)) #define XSH_THREADS_PEEP_CONTEXT 1 typedef struct { #if XSH_HAS_RPEEP peep_t old_rpeep; #else peep_t old_peep; #endif ptable *seen; } xsh_peep_cxt_t; static xsh_peep_cxt_t *xsh_peep_get_cxt(pTHX); static void xsh_peep_rec(pTHX_ OP *o, ptable *seen); #if XSH_HAS_RPEEP static void xsh_rpeep(pTHX_ OP *o) { ptable *seen; xsh_peep_cxt_t *cxt = xsh_peep_get_cxt(aTHX); cxt->old_rpeep(aTHX_ o); seen = cxt->seen; XSH_ASSERT(seen); ptable_seen_clear(seen); xsh_peep_rec(aTHX_ o, seen); ptable_seen_clear(seen); return; } #define xsh_peep_maybe_recurse(O, S) NOOP #else /* XSH_HAS_RPEEP */ static void xsh_peep(pTHX_ OP *o) { ptable *seen; xsh_peep_cxt_t *cxt = xsh_peep_get_cxt(aTHX); cxt->old_peep(aTHX_ o); /* Will call the rpeep */ seen = cxt->seen; XSH_ASSERT(seen); ptable_seen_clear(seen); xsh_peep_rec(aTHX_ o, seen); ptable_seen_clear(seen); return; } static void xsh_peep_maybe_recurse(pTHX_ OP *o, ptable *seen) { #define xsh_peep_maybe_recurse(O, S) xsh_peep_maybe_recurse(aTHX_ (O), (S)) switch (o->op_type) { case OP_MAPWHILE: case OP_GREPWHILE: case OP_AND: case OP_OR: case OP_ANDASSIGN: case OP_ORASSIGN: case OP_COND_EXPR: case OP_RANGE: #if XSH_HAS_PERL(5, 10, 0) case OP_ONCE: case OP_DOR: case OP_DORASSIGN: #endif xsh_peep_rec(aTHX_ cLOGOPo->op_other, seen); break; case OP_ENTERLOOP: case OP_ENTERITER: xsh_peep_rec(aTHX_ cLOOPo->op_redoop, seen); xsh_peep_rec(aTHX_ cLOOPo->op_nextop, seen); xsh_peep_rec(aTHX_ cLOOPo->op_lastop, seen); break; #if XSH_HAS_PERL(5, 9, 5) case OP_SUBST: xsh_peep_rec(aTHX_ cPMOPo->op_pmstashstartu.op_pmreplstart, seen); break; #else case OP_QR: case OP_MATCH: case OP_SUBST: xsh_peep_rec(aTHX_ cPMOPo->op_pmreplstart, seen); break; #endif } return; } #endif /* !XSH_HAS_RPEEP */ static int xsh_peep_seen(pTHX_ OP *o, ptable *seen) { #define xsh_peep_seen(O, S) xsh_peep_seen(aTHX_ (O), (S)) #if XSH_HAS_RPEEP switch (o->op_type) { case OP_NEXTSTATE: case OP_DBSTATE: case OP_UNSTACK: case OP_STUB: break; default: return 0; } #endif /* XSH_HAS_RPEEP */ if (ptable_fetch(seen, o)) return 1; ptable_seen_store(seen, o, o); return 0; } static void xsh_peep_local_setup(pTHX_ xsh_peep_cxt_t *cxt) { #if XSH_HAS_RPEEP if (PL_rpeepp != xsh_rpeep) { cxt->old_rpeep = PL_rpeepp; PL_rpeepp = xsh_rpeep; } else { cxt->old_rpeep = 0; } #else if (PL_peepp != xsh_peep) { cxt->old_peep = PL_peepp; PL_peepp = xsh_peep; } else { cxt->old_peep = 0; } #endif cxt->seen = ptable_new(32); } static void xsh_peep_local_teardown(pTHX_ xsh_peep_cxt_t *cxt) { ptable_seen_free(cxt->seen); cxt->seen = NULL; #if XSH_HAS_RPEEP if (cxt->old_rpeep) { PL_rpeepp = cxt->old_rpeep; cxt->old_rpeep = 0; } #else if (cxt->old_peep) { PL_peepp = cxt->old_peep; cxt->old_peep = 0; } #endif return; } static void xsh_peep_clone(pTHX_ const xsh_peep_cxt_t *old_cxt, xsh_peep_cxt_t *new_cxt) { new_cxt->seen = ptable_new(32); return; } #endif /* XSH_PEEP_H */ autovivification-0.18/xsh/ptable.h000644 000765 000024 00000025127 13137651160 020072 0ustar00vincentstaff000000 000000 /* This is a pointer table implementation essentially copied from the ptr_table * implementation in perl's sv.c, except that it has been modified to use memory * shared across threads. * Copyright goes to the original authors, bug reports to me. */ /* This header is designed to be included several times with different * definitions for PTABLE_NAME and PTABLE_VAL_ALLOC/FREE(). */ #include "util.h" /* XSH_ASSERT() */ #include "mem.h" /* xPMS, XSH_SHARED_*() */ /* --- Configuration ------------------------------------------------------- */ #ifndef PTABLE_USE_DEFAULT # define PTABLE_USE_DEFAULT 0 #endif #if PTABLE_USE_DEFAULT # if defined(PTABLE_VAL_ALLOC) || defined(PTABLE_VAL_FREE) # error the default ptable is only available when PTABLE_VAL_ALLOC/FREE are unset # endif # undef PTABLE_NAME # define PTABLE_NAME ptable_default # undef PTABLE_VAL_NEED_CONTEXT # define PTABLE_VAL_NEED_CONTEXT 0 #else # ifndef PTABLE_NAME # error PTABLE_NAME must be defined # endif # ifndef PTABLE_VAL_NEED_CONTEXT # define PTABLE_VAL_NEED_CONTEXT 1 # endif #endif #ifndef PTABLE_JOIN # define PTABLE_PASTE(A, B) A ## B # define PTABLE_JOIN(A, B) PTABLE_PASTE(A, B) #endif #ifndef PTABLE_PREFIX # define PTABLE_PREFIX(X) PTABLE_JOIN(PTABLE_NAME, X) #endif #ifndef PTABLE_NEED_SPLICE # define PTABLE_NEED_SPLICE 0 #endif #ifndef PTABLE_NEED_WALK # define PTABLE_NEED_WALK 0 #endif #ifndef PTABLE_NEED_STORE # define PTABLE_NEED_STORE 1 #endif #ifndef PTABLE_NEED_VIVIFY # define PTABLE_NEED_VIVIFY 0 #elif PTABLE_NEED_VIVIFY # undef PTABLE_NEED_VIVIFY # ifndef PTABLE_VAL_ALLOC # error need to define PTABLE_VAL_ALLOC() to use ptable_vivify() # endif # define PTABLE_NEED_VIVIFY 1 #endif #ifndef PTABLE_NEED_DELETE # define PTABLE_NEED_DELETE 1 #endif #ifndef PTABLE_NEED_CLEAR # define PTABLE_NEED_CLEAR 1 #endif #undef PTABLE_NEED_ENT_VIVIFY #if PTABLE_NEED_SPLICE || PTABLE_NEED_STORE || PTABLE_NEED_VIVIFY # define PTABLE_NEED_ENT_VIVIFY 1 #else # define PTABLE_NEED_ENT_VIVIFY 0 #endif #undef PTABLE_NEED_ENT_DETACH #if PTABLE_NEED_SPLICE || PTABLE_NEED_DELETE # define PTABLE_NEED_ENT_DETACH 1 #else # define PTABLE_NEED_ENT_DETACH 0 #endif /* ... Context for ptable_*() functions calling PTABLE_VAL_ALLOC/FREE() .... */ #undef pPTBL #undef pPTBL_ #undef aPTBL #undef aPTBL_ #if PTABLE_VAL_NEED_CONTEXT # define pPTBL pTHX # define pPTBL_ pTHX_ # define aPTBL aTHX # define aPTBL_ aTHX_ #else # define pPTBL pPMS # define pPTBL_ pPMS_ # define aPTBL aPMS # define aPTBL_ aPMS_ #endif /* --- struct ----------------------------------------------------- */ #ifndef ptable_ent typedef struct ptable_ent { struct ptable_ent *next; const void * key; void * val; } ptable_ent; #define ptable_ent ptable_ent #endif /* !ptable_ent */ #ifndef ptable typedef struct ptable { ptable_ent **ary; size_t max; size_t items; } ptable; #define ptable ptable #endif /* !ptable */ /* --- Private interface --------------------------------------------------- */ #ifndef PTABLE_HASH # define PTABLE_HASH(ptr) \ ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17))) #endif #ifndef ptable_bucket # define ptable_bucket(T, K) (PTABLE_HASH(K) & (T)->max) #endif #ifndef ptable_ent_find static ptable_ent *ptable_ent_find(const ptable *t, const void *key) { #define ptable_ent_find ptable_ent_find ptable_ent *ent; const size_t idx = ptable_bucket(t, key); ent = t->ary[idx]; for (; ent; ent = ent->next) { if (ent->key == key) return ent; } return NULL; } #endif /* !ptable_ent_find */ #if PTABLE_NEED_ENT_VIVIFY #ifndef ptable_split static void ptable_split(pPMS_ ptable *t) { #define ptable_split(T) ptable_split(aPMS_ (T)) ptable_ent **ary = t->ary; const size_t old_size = t->max + 1; size_t new_size = old_size * 2; size_t i; XSH_SHARED_RECALLOC(ary, old_size, new_size, ptable_ent *); t->max = --new_size; t->ary = ary; for (i = 0; i < old_size; i++, ary++) { ptable_ent **curentp, **entp, *ent; ent = *ary; if (!ent) continue; entp = ary; curentp = ary + old_size; do { if ((new_size & PTABLE_HASH(ent->key)) != i) { *entp = ent->next; ent->next = *curentp; *curentp = ent; } else { entp = &ent->next; } ent = *entp; } while (ent); } } #endif /* !ptable_split */ #ifndef ptable_ent_vivify static ptable_ent *ptable_ent_vivify(pPMS_ ptable *t, const void *key) { #define ptable_ent_vivify(T, K) ptable_ent_vivify(aPMS_ (T), (K)) ptable_ent *ent; const size_t idx = ptable_bucket(t, key); ent = t->ary[idx]; for (; ent; ent = ent->next) { if (ent->key == key) return ent; } XSH_SHARED_ALLOC(ent, 1, ptable_ent); ent->key = key; ent->val = NULL; ent->next = t->ary[idx]; t->ary[idx] = ent; t->items++; if (ent->next && t->items > t->max) ptable_split(t); return ent; } #endif /* !ptable_ent_vivify */ #endif /* PTABLE_NEED_ENT_VIVIFY */ #if PTABLE_NEED_ENT_DETACH #ifndef ptable_ent_detach static ptable_ent *ptable_ent_detach(ptable *t, const void *key) { #define ptable_ent_detach ptable_ent_detach ptable_ent *prev, *ent; const size_t idx = ptable_bucket(t, key); prev = NULL; ent = t->ary[idx]; for (; ent; prev = ent, ent = ent->next) { if (ent->key == key) { if (prev) prev->next = ent->next; else t->ary[idx] = ent->next; break; } } return ent; } #endif /* !ptable_ent_detach */ #endif /* PTABLE_NEED_ENT_DETACH */ /* --- Public interface ---------------------------------------------------- */ /* ... Common symbols ...................................................... */ #ifndef ptable_new static ptable *ptable_new(pPMS_ size_t init_buckets) { #define ptable_new(B) ptable_new(aPMS_ (B)) ptable *t; if (init_buckets < 4) { init_buckets = 4; } else { init_buckets--; init_buckets |= init_buckets >> 1; init_buckets |= init_buckets >> 2; init_buckets |= init_buckets >> 4; init_buckets |= init_buckets >> 8; init_buckets |= init_buckets >> 16; if (sizeof(init_buckets) > 4) init_buckets |= init_buckets >> 32; init_buckets++; } XSH_ASSERT(init_buckets >= 4 && ((init_buckets & (init_buckets - 1)) == 0)); XSH_SHARED_ALLOC(t, 1, ptable); t->max = init_buckets - 1; t->items = 0; XSH_SHARED_CALLOC(t->ary, t->max + 1, ptable_ent *); return t; } #endif /* !ptable_new */ #ifndef ptable_fetch static void *ptable_fetch(const ptable *t, const void *key) { #define ptable_fetch ptable_fetch const ptable_ent *ent = ptable_ent_find(t, key); return ent ? ent->val : NULL; } #endif /* !ptable_fetch */ #if PTABLE_NEED_SPLICE #ifndef ptable_splice static void *ptable_splice(pPMS_ ptable *t, const void *key, void *new_val) { #define ptable_splice(T, K, V) ptable_splice(aPMS_ (T), (K), (V)) ptable_ent *ent; void *old_val = NULL; if (new_val) { ent = ptable_ent_vivify(t, key); old_val = ent->val; ent->val = new_val; } else { ent = ptable_ent_detach(t, key); if (ent) { old_val = ent->val; XSH_SHARED_FREE(ent, 1, ptable_ent); } } return old_val; } #endif /* !ptable_splice */ #endif /* PTABLE_NEED_SPLICE */ #if PTABLE_NEED_WALK #ifndef ptable_walk static void ptable_walk(pTHX_ ptable *t, void (*cb)(pTHX_ ptable_ent *ent, void *userdata), void *userdata) { #define ptable_walk(T, CB, UD) ptable_walk(aTHX_ (T), (CB), (UD)) if (t && t->items) { register ptable_ent **array = t->ary; size_t i = t->max; do { ptable_ent *entry; for (entry = array[i]; entry; entry = entry->next) if (entry->val) cb(aTHX_ entry, userdata); } while (i--); } } #endif /* !ptable_walk */ #endif /* PTABLE_NEED_WALK */ /* ... Specialized symbols ................................................. */ #if PTABLE_NEED_STORE #if !PTABLE_USE_DEFAULT || !defined(ptable_default_store) static void PTABLE_PREFIX(_store)(pPTBL_ ptable *t, const void *key, void *val){ ptable_ent *ent = ptable_ent_vivify(t, key); #ifdef PTABLE_VAL_FREE PTABLE_VAL_FREE(ent->val); #endif ent->val = val; return; } # if PTABLE_USE_DEFAULT # define ptable_default_store ptable_default_store # endif #endif /* !PTABLE_USE_DEFAULT || !defined(ptable_default_store) */ #endif /* PTABLE_NEED_STORE */ #if PTABLE_NEED_VIVIFY #if !PTABLE_USE_DEFAULT || !defined(ptable_default_vivify) static void *PTABLE_PREFIX(_vivify)(pPTBL_ ptable *t, const void *key) { ptable_ent *ent = ptable_ent_vivify(t, key); if (!ent->val) { PTABLE_VAL_ALLOC(ent->val); } return ent->val; } # if PTABLE_USE_DEFAULT # define ptable_default_vivify ptable_default_vivify # endif #endif /* !PTABLE_USE_DEFAULT || !defined(ptable_default_vivify) */ #endif /* PTABLE_NEED_VIVIFY */ #if PTABLE_NEED_DELETE #if !PTABLE_USE_DEFAULT || !defined(ptable_default_delete) static void PTABLE_PREFIX(_delete)(pPTBL_ ptable *t, const void *key) { ptable_ent *ent = ptable_ent_detach(t, key); #ifdef PTABLE_VAL_FREE if (ent) { PTABLE_VAL_FREE(ent->val); } #endif XSH_SHARED_FREE(ent, 1, ptable_ent); } # if PTABLE_USE_DEFAULT # define ptable_default_delete ptable_default_delete # endif #endif /* !PTABLE_USE_DEFAULT || !defined(ptable_default_delete) */ #endif /* PTABLE_NEED_DELETE */ #if PTABLE_NEED_CLEAR #if !PTABLE_USE_DEFAULT || !defined(ptable_default_clear) static void PTABLE_PREFIX(_clear)(pPTBL_ ptable *t) { if (t && t->items) { register ptable_ent **array = t->ary; size_t idx = t->max; do { ptable_ent *entry = array[idx]; while (entry) { ptable_ent *nentry = entry->next; #ifdef PTABLE_VAL_FREE PTABLE_VAL_FREE(entry->val); #endif XSH_SHARED_FREE(entry, 1, ptable_ent); entry = nentry; } array[idx] = NULL; } while (idx--); t->items = 0; } } # if PTABLE_USE_DEFAULT # define ptable_default_clear ptable_default_clear # endif #endif /* !PTABLE_USE_DEFAULT || !defined(ptable_default_clear) */ #endif /* PTABLE_NEED_CLEAR */ #if !PTABLE_USE_DEFAULT || !defined(ptable_default_free) static void PTABLE_PREFIX(_free)(pPTBL_ ptable *t) { if (!t) return; PTABLE_PREFIX(_clear)(aPTBL_ t); XSH_SHARED_FREE(t->ary, t->max + 1, ptable_ent *); XSH_SHARED_FREE(t, 1, ptable); } # if PTABLE_USE_DEFAULT # define ptable_default_free ptable_default_free # endif #endif /* !PTABLE_USE_DEFAULT || !defined(ptable_default_free) */ /* --- Cleanup ------------------------------------------------------------- */ #undef PTABLE_WAS_DEFAULT #if PTABLE_USE_DEFAULT # define PTABLE_WAS_DEFAULT 1 #else # define PTABLE_WAS_DEFAULT 0 #endif #undef PTABLE_NAME #undef PTABLE_VAL_ALLOC #undef PTABLE_VAL_FREE #undef PTABLE_VAL_NEED_CONTEXT #undef PTABLE_USE_DEFAULT #undef PTABLE_NEED_SPLICE #undef PTABLE_NEED_WALK #undef PTABLE_NEED_STORE #undef PTABLE_NEED_VIVIFY #undef PTABLE_NEED_DELETE #undef PTABLE_NEED_CLEAR #undef PTABLE_NEED_ENT_VIVIFY #undef PTABLE_NEED_ENT_DETACH autovivification-0.18/xsh/threads.h000644 000765 000024 00000025162 13137651223 020254 0ustar00vincentstaff000000 000000 #ifndef XSH_THREADS_H #define XSH_THREADS_H 1 #include "caps.h" /* XSH_HAS_PERL(), XSH_THREADSAFE */ #include "util.h" /* XSH_PACKAGE, dNOOP, NOOP */ #include "mem.h" /* XSH_SHARED_*() */ #ifndef XSH_THREADS_COMPILE_TIME_PROTECTION # define XSH_THREADS_COMPILE_TIME_PROTECTION 0 #endif #ifndef XSH_THREADS_USER_CONTEXT # define XSH_THREADS_USER_CONTEXT 1 #endif #ifndef XSH_THREADS_USER_GLOBAL_SETUP # define XSH_THREADS_USER_GLOBAL_SETUP 1 #endif #ifndef XSH_THREADS_USER_LOCAL_SETUP # define XSH_THREADS_USER_LOCAL_SETUP 1 #endif #ifndef XSH_THREADS_USER_LOCAL_TEARDOWN # define XSH_THREADS_USER_LOCAL_TEARDOWN 1 #endif #ifndef XSH_THREADS_USER_GLOBAL_TEARDOWN # define XSH_THREADS_USER_GLOBAL_TEARDOWN 1 #endif #ifndef XSH_THREADS_PEEP_CONTEXT # define XSH_THREADS_PEEP_CONTEXT 0 #endif #ifndef XSH_THREADS_HINTS_CONTEXT # define XSH_THREADS_HINTS_CONTEXT 0 #endif #ifndef XSH_THREADS_USER_CLONE_NEEDS_DUP # define XSH_THREADS_USER_CLONE_NEEDS_DUP 0 #endif #if XSH_THREADSAFE && (XSH_THREADS_HINTS_CONTEXT || XSH_THREADS_USER_CLONE_NEEDS_DUP) # define XSH_THREADS_CLONE_NEEDS_DUP 1 #else # define XSH_THREADS_CLONE_NEEDS_DUP 0 #endif #if defined(XSH_OPS_H) && (!XSH_THREADS_GLOBAL_SETUP || !XSH_THREADS_GLOBAL_TEARDOWN) # error settting up hook check functions require global setup/teardown #endif #ifndef XSH_THREADS_NEED_TEARDOWN_LATE # define XSH_THREADS_NEED_TEARDOWN_LATE 0 #endif #if XSH_THREADS_NEED_TEARDOWN_LATE && (!XSH_THREADS_USER_LOCAL_TEARDOWN || !XSH_THREADS_USER_GLOBAL_TEARDOWN) # error you need to declare local or global teardown handlers to use the late teardown feature #endif #if XSH_THREADSAFE # ifndef MY_CXT_CLONE # define MY_CXT_CLONE \ dMY_CXT_SV; \ my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1)); \ Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t); \ sv_setuv(my_cxt_sv, PTR2UV(my_cxtp)) # endif #else # undef dMY_CXT # define dMY_CXT dNOOP # undef MY_CXT # define MY_CXT xsh_globaldata # undef START_MY_CXT # define START_MY_CXT static my_cxt_t MY_CXT; # undef MY_CXT_INIT # define MY_CXT_INIT NOOP # undef MY_CXT_CLONE # define MY_CXT_CLONE NOOP #endif #if XSH_THREADSAFE /* We must use preexistent global mutexes or we will never be able to destroy * them. */ # if XSH_HAS_PERL(5, 9, 3) # define XSH_LOADED_LOCK MUTEX_LOCK(&PL_my_ctx_mutex) # define XSH_LOADED_UNLOCK MUTEX_UNLOCK(&PL_my_ctx_mutex) # else # define XSH_LOADED_LOCK OP_REFCNT_LOCK # define XSH_LOADED_UNLOCK OP_REFCNT_UNLOCK # endif #else # define XSH_LOADED_LOCK NOOP # define XSH_LOADED_UNLOCK NOOP #endif static I32 xsh_loaded = 0; #if XSH_THREADSAFE && XSH_THREADS_COMPILE_TIME_PROTECTION #define PTABLE_USE_DEFAULT 1 #include "ptable.h" #define ptable_loaded_store(T, K, V) ptable_default_store(aPTBL_ (T), (K), (V)) #define ptable_loaded_delete(T, K) ptable_default_delete(aPTBL_ (T), (K)) #define ptable_loaded_free(T) ptable_default_free(aPTBL_ (T)) static ptable *xsh_loaded_cxts = NULL; static int xsh_is_loaded(pTHX_ void *cxt) { #define xsh_is_loaded(C) xsh_is_loaded(aTHX_ (C)) int res = 0; XSH_LOADED_LOCK; if (xsh_loaded_cxts && ptable_fetch(xsh_loaded_cxts, cxt)) res = 1; XSH_LOADED_UNLOCK; return res; } static int xsh_set_loaded_locked(pTHX_ void *cxt) { #define xsh_set_loaded_locked(C) xsh_set_loaded_locked(aTHX_ (C)) int global_setup = 0; if (xsh_loaded <= 0) { XSH_ASSERT(xsh_loaded == 0); XSH_ASSERT(!xsh_loaded_cxts); xsh_loaded_cxts = ptable_new(4); global_setup = 1; } ++xsh_loaded; XSH_ASSERT(xsh_loaded_cxts); ptable_loaded_store(xsh_loaded_cxts, cxt, cxt); return global_setup; } static int xsh_clear_loaded_locked(pTHX_ void *cxt) { #define xsh_clear_loaded_locked(C) xsh_clear_loaded_locked(aTHX_ (C)) int global_teardown = 0; if (xsh_loaded > 1) { XSH_ASSERT(xsh_loaded_cxts); ptable_loaded_delete(xsh_loaded_cxts, cxt); --xsh_loaded; } else if (xsh_loaded_cxts) { XSH_ASSERT(xsh_loaded == 1); ptable_loaded_free(xsh_loaded_cxts); xsh_loaded_cxts = NULL; xsh_loaded = 0; global_teardown = 1; } return global_teardown; } #else /* XSH_THREADS_COMPILE_TIME_PROTECTION */ #define xsh_is_loaded_locked(C) (xsh_loaded > 0) #define xsh_set_loaded_locked(C) ((xsh_loaded++ <= 0) ? 1 : 0) #define xsh_clear_loaded_locked(C) ((--xsh_loaded <= 0) ? 1 : 0) #if XSH_THREADSAFE static int xsh_is_loaded(pTHX_ void *cxt) { #define xsh_is_loaded(C) xsh_is_loaded(aTHX_ (C)) int res = 0; XSH_LOADED_LOCK; res = xsh_is_loaded_locked(cxt); XSH_LOADED_UNLOCK; return res; } #else #define xsh_is_loaded(C) xsh_is_loaded_locked(C) #endif #endif /* !XSH_THREADS_COMPILE_TIME_PROTECTION */ #define MY_CXT_KEY XSH_PACKAGE "::_guts" XS_VERSION typedef struct { #if XSH_THREADS_USER_CONTEXT xsh_user_cxt_t cxt_user; #endif #if XSH_THREADS_PEEP_CONTEXT xsh_peep_cxt_t cxt_peep; #endif #if XSH_THREADS_HINTS_CONTEXT xsh_hints_cxt_t cxt_hints; #endif #if XSH_THREADS_CLONE_NEEDS_DUP tTHX owner; #endif #if !(XSH_THREADS_USER_CONTEXT || XSH_THREADS_PEEP_CONTEXT || XSH_THREADS_HINTS_CONTEXT || XSH_THREADS_CLONE_NEEDS_DUP) int dummy; #endif } my_cxt_t; START_MY_CXT #if XSH_THREADS_USER_CONTEXT # define dXSH_CXT dMY_CXT # define XSH_CXT (MY_CXT.cxt_user) #endif #if XSH_THREADS_USER_GLOBAL_SETUP static void xsh_user_global_setup(pTHX); #endif #if XSH_THREADS_USER_LOCAL_SETUP # if XSH_THREADS_USER_CONTEXT static void xsh_user_local_setup(pTHX_ xsh_user_cxt_t *cxt); # else static void xsh_user_local_setup(pTHX); # endif #endif #if XSH_THREADS_USER_LOCAL_TEARDOWN # if XSH_THREADS_USER_CONTEXT static void xsh_user_local_teardown(pTHX_ xsh_user_cxt_t *cxt); # else static void xsh_user_local_teardown(pTHX); # endif #endif #if XSH_THREADS_USER_GLOBAL_TEARDOWN static void xsh_user_global_teardown(pTHX); #endif #if XSH_THREADSAFE && XSH_THREADS_USER_CONTEXT # if XSH_THREADS_USER_CLONE_NEEDS_DUP static void xsh_user_clone(pTHX_ const xsh_user_cxt_t *old_cxt, xsh_user_cxt_t *new_cxt, CLONE_PARAMS *params); # else static void xsh_user_clone(pTHX_ const xsh_user_cxt_t *old_cxt, xsh_user_cxt_t *new_cxt); # endif #endif #if XSH_THREADS_PEEP_CONTEXT static xsh_peep_cxt_t *xsh_peep_get_cxt(pTHX) { dMY_CXT; XSH_ASSERT(xsh_is_loaded(&MY_CXT)); return &MY_CXT.cxt_peep; } #endif #if XSH_THREADS_HINTS_CONTEXT static xsh_hints_cxt_t *xsh_hints_get_cxt(pTHX) { dMY_CXT; XSH_ASSERT(xsh_is_loaded(&MY_CXT)); return &MY_CXT.cxt_hints; } #endif #if XSH_THREADS_NEED_TEARDOWN_LATE typedef void (*xsh_teardown_late_cb)(pTHX_ void *ud); static int xsh_teardown_late_simple_free(pTHX_ SV *sv, MAGIC *mg) { xsh_teardown_late_cb cb; cb = DPTR2FPTR(xsh_teardown_late_cb, mg->mg_ptr); XSH_LOADED_LOCK; if (xsh_loaded == 0) cb(aTHX_ NULL); XSH_LOADED_UNLOCK; return 0; } static MGVTBL xsh_teardown_late_simple_vtbl = { 0, 0, 0, 0, xsh_teardown_late_simple_free #if MGf_COPY , 0 #endif #if MGf_DUP , 0 #endif #if MGf_LOCAL , 0 #endif }; typedef struct { xsh_teardown_late_cb cb; void *ud; } xsh_teardown_late_token; static int xsh_teardown_late_arg_free(pTHX_ SV *sv, MAGIC *mg) { xsh_teardown_late_token *tok; tok = (xsh_teardown_late_token *) mg->mg_ptr; XSH_LOADED_LOCK; if (xsh_loaded == 0) tok->cb(aTHX_ tok->ud); XSH_LOADED_UNLOCK; XSH_SHARED_FREE(tok, 1, xsh_teardown_late_token); return 0; } static MGVTBL xsh_teardown_late_arg_vtbl = { 0, 0, 0, 0, xsh_teardown_late_arg_free #if MGf_COPY , 0 #endif #if MGf_DUP , 0 #endif #if MGf_LOCAL , 0 #endif }; static void xsh_teardown_late_register(pTHX_ xsh_teardown_late_cb cb, void *ud){ #define xsh_teardown_late_register(CB, UD) xsh_teardown_late_register(aTHX_ (CB), (UD)) void *ptr; if (!ud) { ptr = FPTR2DPTR(void *, cb); } else { xsh_teardown_late_token *tok; XSH_SHARED_ALLOC(tok, 1, xsh_teardown_late_token); tok->cb = cb; tok->ud = ud; ptr = tok; } if (!PL_strtab) PL_strtab = newHV(); sv_magicext((SV *) PL_strtab, NULL, PERL_MAGIC_ext, ud ? &xsh_teardown_late_arg_vtbl : &xsh_teardown_late_simple_vtbl, ptr, 0); return; } #endif /* XSH_THREADS_NEED_TEARDOWN_LATE */ static void xsh_teardown(pTHX_ void *root) { dMY_CXT; #if XSH_THREADS_USER_LOCAL_TEARDOWN # if XSH_THREADS_USER_CONTEXT xsh_user_local_teardown(aTHX_ &XSH_CXT); # else xsh_user_local_teardown(aTHX); # endif #endif #if XSH_THREADS_PEEP_CONTEXT xsh_peep_local_teardown(aTHX_ &MY_CXT.cxt_peep); #endif #if XSH_THREADS_HINTS_CONTEXT xsh_hints_local_teardown(aTHX_ &MY_CXT.cxt_hints); #endif XSH_LOADED_LOCK; if (xsh_clear_loaded_locked(&MY_CXT)) { #if XSH_THREADS_USER_GLOBAL_TEARDOWN xsh_user_global_teardown(aTHX); #endif #if XSH_THREADS_HINTS_CONTEXT xsh_hints_global_teardown(aTHX); #endif } XSH_LOADED_UNLOCK; return; } static void xsh_setup(pTHX) { #define xsh_setup() xsh_setup(aTHX) MY_CXT_INIT; /* Takes/release PL_my_ctx_mutex */ XSH_LOADED_LOCK; if (xsh_set_loaded_locked(&MY_CXT)) { #if XSH_THREADS_HINTS_CONTEXT xsh_hints_global_setup(aTHX); #endif #if XSH_THREADS_USER_GLOBAL_SETUP xsh_user_global_setup(aTHX); #endif } XSH_LOADED_UNLOCK; #if XSH_THREADS_CLONE_NEEDS_DUP MY_CXT.owner = aTHX; #endif #if XSH_THREADS_HINTS_CONTEXT xsh_hints_local_setup(aTHX_ &MY_CXT.cxt_hints); #endif #if XSH_THREADS_PEEP_CONTEXT xsh_peep_local_setup(aTHX_ &MY_CXT.cxt_peep); #endif #if XSH_THREADS_USER_LOCAL_SETUP # if XSH_THREADS_USER_CONTEXT xsh_user_local_setup(aTHX_ &XSH_CXT); # else xsh_user_local_setup(aTHX); # endif #endif call_atexit(xsh_teardown, NULL); return; } #if XSH_THREADSAFE static void xsh_clone(pTHX) { #define xsh_clone() xsh_clone(aTHX) const my_cxt_t *old_cxt; my_cxt_t *new_cxt; { dMY_CXT; old_cxt = &MY_CXT; } { int global_setup; MY_CXT_CLONE; new_cxt = &MY_CXT; XSH_LOADED_LOCK; global_setup = xsh_set_loaded_locked(new_cxt); XSH_ASSERT(!global_setup); XSH_LOADED_UNLOCK; #if XSH_THREADS_CLONE_NEEDS_DUP new_cxt->owner = aTHX; #endif } { #if XSH_THREADS_CLONE_NEEDS_DUP XSH_DUP_PARAMS_TYPE params; xsh_dup_params_init(params, old_cxt->owner); #endif #if XSH_THREADS_PEEP_CONTEXT xsh_peep_clone(aTHX_ &old_cxt->cxt_peep, &new_cxt->cxt_peep); #endif #if XSH_THREADS_HINTS_CONTEXT xsh_hints_clone(aTHX_ &old_cxt->cxt_hints, &new_cxt->cxt_hints, xsh_dup_params_ptr(params)); #endif #if XSH_THREADS_USER_CONTEXT # if XSH_THREADS_USER_CLONE_NEEDS_DUP xsh_user_clone(aTHX_ &old_cxt->cxt_user, &new_cxt->cxt_user, xsh_dup_params_ptr(params)); # else xsh_user_clone(aTHX_ &old_cxt->cxt_user, &new_cxt->cxt_user); # endif #endif #if XSH_THREADS_CLONE_NEEDS_DUP xsh_dup_params_deinit(params); #endif } return; } #endif /* XSH_THREADSAFE */ #endif /* XSH_THREADS_H */ autovivification-0.18/xsh/util.h000644 000765 000024 00000003502 13137651262 017574 0ustar00vincentstaff000000 000000 #ifndef XSH_UTIL_H #define XSH_UTIL_H 1 #include "caps.h" /* XSH_HAS_PERL() */ #ifndef XSH_PACKAGE # error XSH_PACKAGE must be defined #endif #define XSH_PACKAGE_LEN (sizeof(XSH_PACKAGE)-1) #ifdef DEBUGGING # if XSH_HAS_PERL(5, 8, 9) || XSH_HAS_PERL(5, 9, 3) # define XSH_ASSERT(C) assert(C) # else # ifdef PERL_DEB # define XSH_DEB(X) PERL_DEB(X) # else # define XSH_DEB(X) (X) # endif # define XSH_ASSERT(C) XSH_DEB( \ ((C) ? ((void) 0) \ : (Perl_croak_nocontext("Assertion %s failed: file \"" __FILE__ \ "\", line %d", STRINGIFY(C), __LINE__), \ (void) 0))) # endif #else # define XSH_ASSERT(C) #endif #ifndef STMT_START # define STMT_START do #endif #ifndef STMT_END # define STMT_END while (0) #endif #ifndef dNOOP # define dNOOP #endif #ifndef NOOP # define NOOP #endif #if XSH_HAS_PERL(5, 13, 2) # define XSH_DUP_PARAMS_TYPE CLONE_PARAMS * # define xsh_dup_params_init(P, O) ((P) = Perl_clone_params_new((O), aTHX)) # define xsh_dup_params_deinit(P) Perl_clone_params_del(P) # define xsh_dup_params_ptr(P) (P) #else # define XSH_DUP_PARAMS_TYPE CLONE_PARAMS # define xsh_dup_params_init(P, O) \ ((P).stashes = newAV()); (P).flags = 0; ((P).proto_perl = (O)) # define xsh_dup_params_deinit(P) SvREFCNT_dec((P).stashes) # define xsh_dup_params_ptr(P) &(P) #endif #define xsh_dup(S, P) sv_dup((S), (P)) #define xsh_dup_inc(S, P) SvREFCNT_inc(xsh_dup((S), (P))) #ifdef USE_ITHREADS # define XSH_LOCK(M) MUTEX_LOCK(M) # define XSH_UNLOCK(M) MUTEX_UNLOCK(M) #else # define XSH_LOCK(M) NOOP # define XSH_UNLOCK(M) NOOP #endif #ifndef PTR2nat # define PTR2nat(p) (PTRV)(p) #endif #ifndef DPTR2FPTR # define DPTR2FPTR(t,p) ((t)PTR2nat(p)) #endif #ifndef FPTR2DPTR # define FPTR2DPTR(t,p) ((t)PTR2nat(p)) #endif #endif /* XSH_UTIL_H */ autovivification-0.18/t/00-load.t000644 000765 000024 00000000270 12416743316 017430 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 1; BEGIN { use_ok( 'autovivification' ); } diag( "Testing autovivification $autovivification::VERSION, Perl $], $^X" ); autovivification-0.18/t/09-load-threads.t000644 000765 000024 00000017162 12556714614 021105 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; my ($module, $thread_safe_var); BEGIN { $module = 'autovivification'; $thread_safe_var = 'autovivification::A_THREADSAFE()'; } sub load_test { my $x; if (defined &autovivification::unimport) { local $@; eval 'BEGIN { autovivification->unimport } my $y = $x->[0]'; $x = $@ if $@; } else { $x = ''; } if (not defined $x) { return 1; } elsif ( (not ref $x and not length $x) or (ref $x eq 'ARRAY' and not @$x )) { return 0; } else { return "$x"; } } # Keep the rest of the file untouched use lib 't/lib'; use VPIT::TestHelpers threads => [ $module, $thread_safe_var ]; my $could_not_create_thread = 'Could not create thread'; use Test::Leaner; sub is_loaded { my ($affirmative, $desc) = @_; my $res = load_test(); my $expected; if ($affirmative) { $expected = 1; $desc = "$desc: module loaded"; } else { $expected = 0; $desc = "$desc: module not loaded"; } unless (is $res, $expected, $desc) { $res = defined $res ? "'$res'" : 'undef'; $expected = "'$expected'"; diag("Test '$desc' failed: got $res, expected $expected"); } return; } BEGIN { local $@; my $code = eval "sub { require $module }"; die $@ if $@; *do_load = $code; } is_loaded 0, 'main body, beginning'; # Test serial loadings SKIP: { my $thr = spawn(sub { my $here = "first serial thread"; is_loaded 0, "$here, beginning"; do_load; is_loaded 1, "$here, after loading"; return; }); skip "$could_not_create_thread (serial 1)" => 2 unless defined $thr; $thr->join; if (my $err = $thr->error) { die $err; } } is_loaded 0, 'main body, in between serial loadings'; SKIP: { my $thr = spawn(sub { my $here = "second serial thread"; is_loaded 0, "$here, beginning"; do_load; is_loaded 1, "$here, after loading"; return; }); skip "$could_not_create_thread (serial 2)" => 2 unless defined $thr; $thr->join; if (my $err = $thr->error) { die $err; } } is_loaded 0, 'main body, after serial loadings'; # Test nested loadings SKIP: { my $parent = spawn(sub { my $here = 'parent thread'; is_loaded 0, "$here, beginning"; SKIP: { my $kid = spawn(sub { my $here = 'child thread'; is_loaded 0, "$here, beginning"; do_load; is_loaded 1, "$here, after loading"; return; }); skip "$could_not_create_thread (nested child)" => 2 unless defined $kid; $kid->join; if (my $err = $kid->error) { die "in child thread: $err\n"; } } is_loaded 0, "$here, after child terminated"; do_load; is_loaded 1, "$here, after loading"; return; }); skip "$could_not_create_thread (nested parent)" => (3 + 2) unless defined $parent; $parent->join; if (my $err = $parent->error) { die $err; } } is_loaded 0, 'main body, after nested loadings'; # Test parallel loadings use threads; use threads::shared; my $sync_points = 7; my @locks_down = (1) x $sync_points; my @locks_up = (0) x $sync_points; share($_) for @locks_down, @locks_up; my $default_peers = 2; sub sync_master { my ($id, $peers) = @_; $peers = $default_peers unless defined $peers; { lock $locks_down[$id]; $locks_down[$id] = 0; cond_broadcast $locks_down[$id]; } LOCK: { lock $locks_up[$id]; my $timeout = time() + 10; until ($locks_up[$id] == $peers) { if (cond_timedwait $locks_up[$id], $timeout) { last LOCK; } else { return 0; } } } return 1; } sub sync_slave { my ($id) = @_; { lock $locks_down[$id]; cond_wait $locks_down[$id] until $locks_down[$id] == 0; } { lock $locks_up[$id]; $locks_up[$id]++; cond_signal $locks_up[$id]; } return 1; } for my $first_thread_ends_first (0, 1) { for my $id (0 .. $sync_points - 1) { { lock $locks_down[$id]; $locks_down[$id] = 1; } { lock $locks_up[$id]; $locks_up[$id] = 0; } } my $thr1_end = 'finishes first'; my $thr2_end = 'finishes last'; ($thr1_end, $thr2_end) = ($thr2_end, $thr1_end) unless $first_thread_ends_first; SKIP: { my $thr1 = spawn(sub { my $here = "first simultaneous thread ($thr1_end)"; sync_slave 0; is_loaded 0, "$here, beginning"; sync_slave 1; do_load; is_loaded 1, "$here, after loading"; sync_slave 2; sync_slave 3; sync_slave 4; is_loaded 1, "$here, still loaded while also loaded in the other thread"; sync_slave 5; sync_slave 6 unless $first_thread_ends_first; is_loaded 1, "$here, end"; return 1; }); skip "$could_not_create_thread (parallel 1)" => (4 * 2) unless defined $thr1; my $thr2 = spawn(sub { my $here = "second simultaneous thread ($thr2_end)"; sync_slave 0; is_loaded 0, "$here, beginning"; sync_slave 1; sync_slave 2; sync_slave 3; is_loaded 0, "$here, loaded in other thread but not here"; do_load; is_loaded 1, "$here, after loading"; sync_slave 4; sync_slave 5; sync_slave 6 if $first_thread_ends_first; is_loaded 1, "$here, end"; return 1; }); sync_master($_) for 0 .. 5; if (defined $thr2) { ($thr2, $thr1) = ($thr1, $thr2) unless $first_thread_ends_first; $thr1->join; if (my $err = $thr1->error) { die $err; } sync_master(6, 1); $thr2->join; if (my $err = $thr1->error) { die $err; } } else { sync_master(6, 1) unless $first_thread_ends_first; $thr1->join; if (my $err = $thr1->error) { die $err; } skip "$could_not_create_thread (parallel 2)" => (4 * 1); } } is_loaded 0, 'main body, after simultaneous threads'; } # Test simple clone SKIP: { my $parent = spawn(sub { my $here = 'simple clone, parent thread'; is_loaded 0, "$here, beginning"; do_load; is_loaded 1, "$here, after loading"; SKIP: { my $kid = spawn(sub { my $here = 'simple clone, child thread'; is_loaded 1, "$here, beginning"; return; }); skip "$could_not_create_thread (simple clone child)" => 1 unless defined $kid; $kid->join; if (my $err = $kid->error) { die "in child thread: $err\n"; } } is_loaded 1, "$here, after child terminated"; return; }); skip "$could_not_create_thread (simple clone parent)" => (3 + 1) unless defined $parent; $parent->join; if (my $err = $parent->error) { die $err; } } is_loaded 0, 'main body, after simple clone'; # Test clone outliving its parent SKIP: { my $kid_done; share($kid_done); my $parent = spawn(sub { my $here = 'outliving clone, parent thread'; is_loaded 0, "$here, beginning"; do_load; is_loaded 1, "$here, after loading"; my $kid_tid; SKIP: { my $kid = spawn(sub { my $here = 'outliving clone, child thread'; is_loaded 1, "$here, beginning"; { lock $kid_done; cond_wait $kid_done until $kid_done; } is_loaded 1, "$here, end"; return 1; }); if (defined $kid) { $kid_tid = $kid->tid; } else { $kid_tid = 0; skip "$could_not_create_thread (outliving clone child)" => 2; } } is_loaded 1, "$here, end"; return $kid_tid; }); skip "$could_not_create_thread (outliving clone parent)" => (3 + 2) unless defined $parent; my $kid_tid = $parent->join; if (my $err = $parent->error) { die $err; } if ($kid_tid) { my $kid = threads->object($kid_tid); if (defined $kid) { if ($kid->is_running) { lock $kid_done; $kid_done = 1; cond_signal $kid_done; } $kid->join; } } } is_loaded 0, 'main body, after outliving clone'; do_load; is_loaded 1, 'main body, loaded at end'; done_testing(); autovivification-0.18/t/20-hash.t000644 000765 000024 00000053544 12517507122 017445 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use lib 't/lib'; use Test::Leaner tests => 9 * 3 * 302; use autovivification::TestCases; while () { 1 while chomp; next unless /#/; testcase_ok($_, '%'); } __DATA__ --- fetch --- $x # $x->{a} # '', undef, { } $x # $x->{a} # '', undef, undef # $x # $x->{a} # '', undef, undef # +fetch $x # $x->{a} # '', undef, { } # +exists $x # $x->{a} # '', undef, { } # +delete $x # $x->{a} # '', undef, { } # +store $x # $x->{a} # '', undef, { } # -fetch $x # $x->{a} # '', undef, { } # +fetch -fetch $x # $x->{a} # '', undef, undef # -fetch +fetch $x # $x->{a} # '', undef, undef # +fetch -exists $x # $x->{a} # qr/^Reference vivification forbidden/, undef, undef # +strict +fetch $x # $x->{a} # '', undef, { } # +strict +exists $x # $x->{a} # '', undef, { } # +strict +delete $x # $x->{a} # '', undef, { } # +strict +store $x # $x->{a}->{b} # '', undef, { a => { } } $x # $x->{a}->{b} # '', undef, undef # $x # $x->{a}->{b} # '', undef, undef # +fetch $x # $x->{a}->{b} # '', undef, { a => { } } # +exists $x # $x->{a}->{b} # '', undef, { a => { } } # +delete $x # $x->{a}->{b} # '', undef, { a => { } } # +store $x # $x->{a}->{b} # qr/^Reference vivification forbidden/, undef, undef # +strict +fetch $x # $x->{a}->{b} # '', undef, { a => { } } # +strict +exists $x # $x->{a}->{b} # '', undef, { a => { } } # +strict +delete $x # $x->{a}->{b} # '', undef, { a => { } } # +strict +store $x->{a} = 1 # $x->{a} # '', 1, { a => 1 } # +fetch $x->{a} = 1 # $x->{b} # '', undef, { a => 1 } # +fetch $x->{a} = 1 # $x->{a} # '', 1, { a => 1 } # +exists $x->{a} = 1 # $x->{b} # '', undef, { a => 1 } # +exists $x->{a} = 1 # $x->{a} # '', 1, { a => 1 } # +delete $x->{a} = 1 # $x->{b} # '', undef, { a => 1 } # +delete $x->{a} = 1 # $x->{a} # '', 1, { a => 1 } # +store $x->{a} = 1 # $x->{b} # '', undef, { a => 1 } # +store $x->{a} = 1 # $x->{a} # '', 1, { a => 1 } # +strict +fetch $x->{a} = 1 # $x->{b} # '', undef, { a => 1 } # +strict +fetch $x->{a} = 1 # $x->{a} # '', 1, { a => 1 } # +strict +exists $x->{a} = 1 # $x->{b} # '', undef, { a => 1 } # +strict +exists $x->{a} = 1 # $x->{a} # '', 1, { a => 1 } # +strict +delete $x->{a} = 1 # $x->{b} # '', undef, { a => 1 } # +strict +delete $x->{a} = 1 # $x->{a} # '', 1, { a => 1 } # +strict +store $x->{a} = 1 # $x->{b} # '', undef, { a => 1 } # +strict +store $x->{a}->{b} = 1 # $x->{a}->{b} # '', 1, { a => { b => 1 } } # +fetch $x->{a}->{b} = 1 # $x->{a}->{d} # '', undef, { a => { b => 1 } } # +fetch $x->{a}->{b} = 1 # $x->{c}->{d} # '', undef, { a => { b => 1 } } # +fetch $x->{a}->{b} = 1 # $x->{a}->{b} # '', 1, { a => { b => 1 } } # +exists $x->{a}->{b} = 1 # $x->{a}->{d} # '', undef, { a => { b => 1 } } # +exists $x->{a}->{b} = 1 # $x->{c}->{d} # '', undef, { a => { b => 1 }, c => { } } # +exists $x->{a}->{b} = 1 # $x->{a}->{b} # '', 1, { a => { b => 1 } } # +delete $x->{a}->{b} = 1 # $x->{a}->{d} # '', undef, { a => { b => 1 } } # +delete $x->{a}->{b} = 1 # $x->{c}->{d} # '', undef, { a => { b => 1 }, c => { } } # +delete $x->{a}->{b} = 1 # $x->{a}->{b} # '', 1, { a => { b => 1 } } # +store $x->{a}->{b} = 1 # $x->{a}->{d} # '', undef, { a => { b => 1 } } # +store $x->{a}->{b} = 1 # $x->{c}->{d} # '', undef, { a => { b => 1 }, c => { } } # +store $x->{a}->{b} = 1 # $x->{a}->{b} # '', 1, { a => { b => 1 } } # +strict +fetch $x->{a}->{b} = 1 # $x->{a}->{d} # '', undef, { a => { b => 1 } } # +strict +fetch $x->{a}->{b} = 1 # $x->{c}->{d} # qr/^Reference vivification forbidden/, undef, { a => { b => 1 } } # +strict +fetch $x->{a}->{b} = 1 # $x->{a}->{b} # '', 1, { a => { b => 1 } } # +strict +exists $x->{a}->{b} = 1 # $x->{a}->{d} # '', undef, { a => { b => 1 } } # +strict +exists $x->{a}->{b} = 1 # $x->{c}->{d} # '', undef, { a => { b => 1 }, c => { } } # +strict +exists $x->{a}->{b} = 1 # $x->{a}->{b} # '', 1, { a => { b => 1 } } # +strict +delete $x->{a}->{b} = 1 # $x->{a}->{d} # '', undef, { a => { b => 1 } } # +strict +delete $x->{a}->{b} = 1 # $x->{c}->{d} # '', undef, { a => { b => 1 }, c => { } } # +strict +delete $x->{a}->{b} = 1 # $x->{a}->{b} # '', 1, { a => { b => 1 } } # +strict +store $x->{a}->{b} = 1 # $x->{a}->{d} # '', undef, { a => { b => 1 } } # +strict +store $x->{a}->{b} = 1 # $x->{c}->{d} # '', undef, { a => { b => 1 }, c => { } } # +strict +store --- aliasing --- $x # 1 for $x->{a}; () # '', undef, { a => undef } $x # 1 for $x->{a}; () # '', undef, { a => undef } # $x # 1 for $x->{a}; () # '', undef, { a => undef } # +fetch $x # 1 for $x->{a}; () # '', undef, { a => undef } # +exists $x # 1 for $x->{a}; () # '', undef, { a => undef } # +delete $x # 1 for $x->{a}; () # qr/^Can't vivify reference/, undef, undef # +store $x # $_ = 1 for $x->{a}; () # '', undef, { a => 1 } $x # $_ = 1 for $x->{a}; () # '', undef, { a => 1 } # $x # $_ = 1 for $x->{a}; () # '', undef, { a => 1 } # +fetch $x # $_ = 1 for $x->{a}; () # '', undef, { a => 1 } # +exists $x # $_ = 1 for $x->{a}; () # '', undef, { a => 1 } # +delete $x # $_ = 1 for $x->{a}; () # qr/^Can't vivify reference/, undef, undef # +store $x->{a} = 1 # 1 for $x->{a}; () # '', undef, { a => 1 } # +fetch $x->{a} = 1 # 1 for $x->{b}; () # '', undef, { a => 1, b => undef } # +fetch $x->{a} = 1 # 1 for $x->{a}; () # '', undef, { a => 1 } # +exists $x->{a} = 1 # 1 for $x->{b}; () # '', undef, { a => 1, b => undef } # +exists $x->{a} = 1 # 1 for $x->{a}; () # '', undef, { a => 1 } # +delete $x->{a} = 1 # 1 for $x->{b}; () # '', undef, { a => 1, b => undef } # +delete $x->{a} = 1 # 1 for $x->{a}; () # '', undef, { a => 1 } # +store $x->{a} = 1 # 1 for $x->{b}; () # '', undef, { a => 1, b => undef } # +store $x # do_nothing($x->{a}); () # '', undef, { } $x # do_nothing($x->{a}); () # '', undef, { } # $x # do_nothing($x->{a}); () # '', undef, { } # +fetch $x # do_nothing($x->{a}); () # '', undef, { } # +exists $x # do_nothing($x->{a}); () # '', undef, { } # +delete $x # do_nothing($x->{a}); () # qr/^Can't vivify reference/, undef, undef # +store $x # set_arg($x->{a}); () # '', undef, { a => 1 } $x # set_arg($x->{a}); () # '', undef, { a => 1 } # $x # set_arg($x->{a}); () # '', undef, { a => 1 } # +fetch $x # set_arg($x->{a}); () # '', undef, { a => 1 } # +exists $x # set_arg($x->{a}); () # '', undef, { a => 1 } # +delete $x # set_arg($x->{a}); () # qr/^Can't vivify reference/, undef, undef # +store --- dereferencing --- $x # no warnings 'uninitialized'; my @a = %$x; () # ($strict ? qr/^Can't use an undefined value as a HASH reference/ : ''), undef, undef $x # no warnings 'uninitialized'; my @a = %$x; () # ($strict ? qr/^Can't use an undefined value as a HASH reference/ : ''), undef, undef # $x # no warnings 'uninitialized'; my @a = %$x; () # ($strict ? qr/^Can't use an undefined value as a HASH reference/ : ''), undef, undef # +fetch $x # no warnings 'uninitialized'; my @a = %$x; () # ($strict ? qr/^Can't use an undefined value as a HASH reference/ : ''), undef, undef # +exists $x # no warnings 'uninitialized'; my @a = %$x; () # ($strict ? qr/^Can't use an undefined value as a HASH reference/ : ''), undef, undef # +delete $x # no warnings 'uninitialized'; my @a = %$x; () # ($strict ? qr/^Can't use an undefined value as a HASH reference/ : ''), undef, undef # +store $x->{a} = 1 # my @a = %$x; () # '', undef, { a => 1 } # +fetch $x->{a} = 1 # my @a = %$x; () # '', undef, { a => 1 } # +exists $x->{a} = 1 # my @a = %$x; () # '', undef, { a => 1 } # +delete $x->{a} = 1 # my @a = %$x; () # '', undef, { a => 1 } # +store --- slice --- $x # my @a = @$x{'a', 'b'}; \@a # '', [ undef, undef ], { } $x # my @a = @$x{'a', 'b'}; \@a # '', [ undef, undef ], undef # $x # my @a = @$x{'a', 'b'}; \@a # '', [ undef, undef ], undef # +fetch $x # my @a = @$x{'a', 'b'}; \@a # '', [ undef, undef ], { } # +exists $x # my @a = @$x{'a', 'b'}; \@a # '', [ undef, undef ], { } # +delete $x # my @a = @$x{'a', 'b'}; \@a # '', [ undef, undef ], { } # +store $x->{b} = 0 # my @a = @$x{'a', 'b'}; \@a # '', [ undef, 0 ], { b => 0 } # +fetch $x # @$x{'a', 'b'} = (1, 2); () # '', undef, { a => 1, b => 2 } $x # @$x{'a', 'b'} = (1, 2); () # '', undef, { a => 1, b => 2 } # $x # @$x{'a', 'b'} = (1, 2); () # '', undef, { a => 1, b => 2 } # +fetch $x # @$x{'a', 'b'} = (1, 2); () # '', undef, { a => 1, b => 2 } # +exists $x # @$x{'a', 'b'} = (1, 2); () # '', undef, { a => 1, b => 2 } # +delete $x # @$x{'a', 'b'} = (1, 2); () # qr/^Can't vivify reference/, undef, undef # +store $x->{a} = 0 # @$x{'a', 'b'} = (1, 2); () # '', undef, { a => 1, b => 2 } # +store $x->{c} = 0 # @$x{'a', 'b'} = (1, 2); () # '', undef, { a => 1, b => 2, c => 0 } # +store $x->{a} = 0, $x->{b} = 0 # @$x{'a', 'b'} = (1, 2); () # '', undef, { a => 1, b => 2 } # +store --- exists --- $x # exists $x->{a} # '', '', { } $x # exists $x->{a} # '', '', undef # $x # exists $x->{a} # '', '', { } # +fetch $x # exists $x->{a} # '', '', undef # +exists $x # exists $x->{a} # '', '', { } # +delete $x # exists $x->{a} # '', '', { } # +store $x # exists $x->{a} # '', '', { } # +strict +fetch $x # exists $x->{a} # qr/^Reference vivification forbidden/, undef, undef # +strict +exists $x # exists $x->{a} # '', '', { } # +strict +delete $x # exists $x->{a} # '', '', { } # +strict +store $x # exists $x->{a}->{b} # '', '', { a => { } } $x # exists $x->{a}->{b} # '', '', undef # $x # exists $x->{a}->{b} # '', '', { a => { } } # +fetch $x # exists $x->{a}->{b} # '', '', undef # +exists $x # exists $x->{a}->{b} # '', '', { a => { } } # +delete $x # exists $x->{a}->{b} # '', '', { a => { } } # +store $x # exists $x->{a}->{b} # '', '', { a => { } } # +strict +fetch $x # exists $x->{a}->{b} # qr/^Reference vivification forbidden/, undef, undef # +strict +exists $x # exists $x->{a}->{b} # '', '', { a => { } } # +strict +delete $x # exists $x->{a}->{b} # '', '', { a => { } } # +strict +store $x->{a} = 1 # exists $x->{a} # '', 1, { a => 1 } # +fetch $x->{a} = 1 # exists $x->{b} # '', '', { a => 1 } # +fetch $x->{a} = 1 # exists $x->{a} # '', 1, { a => 1 } # +exists $x->{a} = 1 # exists $x->{b} # '', '', { a => 1 } # +exists $x->{a} = 1 # exists $x->{a} # '', 1, { a => 1 } # +delete $x->{a} = 1 # exists $x->{b} # '', '', { a => 1 } # +delete $x->{a} = 1 # exists $x->{a} # '', 1, { a => 1 } # +store $x->{a} = 1 # exists $x->{b} # '', '', { a => 1 } # +store $x->{a} = 1 # exists $x->{a} # '', 1, { a => 1 } # +strict +fetch $x->{a} = 1 # exists $x->{b} # '', '', { a => 1 } # +strict +fetch $x->{a} = 1 # exists $x->{a} # '', 1, { a => 1 } # +strict +exists $x->{a} = 1 # exists $x->{b} # '', '', { a => 1 } # +strict +exists $x->{a} = 1 # exists $x->{a} # '', 1, { a => 1 } # +strict +delete $x->{a} = 1 # exists $x->{b} # '', '', { a => 1 } # +strict +delete $x->{a} = 1 # exists $x->{a} # '', 1, { a => 1 } # +strict +store $x->{a} = 1 # exists $x->{b} # '', '', { a => 1 } # +strict +store $x->{a}->{b} = 1 # exists $x->{a}->{b} # '', 1, { a => { b => 1 } } # +fetch $x->{a}->{b} = 1 # exists $x->{a}->{d} # '', '', { a => { b => 1 } } # +fetch $x->{a}->{b} = 1 # exists $x->{c}->{d} # '', '', { a => { b => 1 }, c => { } } # +fetch $x->{a}->{b} = 1 # exists $x->{a}->{b} # '', 1, { a => { b => 1 } } # +exists $x->{a}->{b} = 1 # exists $x->{a}->{d} # '', '', { a => { b => 1 } } # +exists $x->{a}->{b} = 1 # exists $x->{c}->{d} # '', '', { a => { b => 1 } } # +exists $x->{a}->{b} = 1 # exists $x->{a}->{b} # '', 1, { a => { b => 1 } } # +delete $x->{a}->{b} = 1 # exists $x->{a}->{d} # '', '', { a => { b => 1 } } # +delete $x->{a}->{b} = 1 # exists $x->{c}->{d} # '', '', { a => { b => 1 }, c => { } } # +delete $x->{a}->{b} = 1 # exists $x->{a}->{b} # '', 1, { a => { b => 1 } } # +store $x->{a}->{b} = 1 # exists $x->{a}->{d} # '', '', { a => { b => 1 } } # +store $x->{a}->{b} = 1 # exists $x->{c}->{d} # '', '', { a => { b => 1 }, c => { } } # +store $x->{a}->{b} = 1 # exists $x->{a}->{b} # '', 1, { a => { b => 1 } } # +strict +fetch $x->{a}->{b} = 1 # exists $x->{a}->{d} # '', '', { a => { b => 1 } } # +strict +fetch $x->{a}->{b} = 1 # exists $x->{c}->{d} # '', '', { a => { b => 1 }, c => { } } # +strict +fetch $x->{a}->{b} = 1 # exists $x->{a}->{b} # '', 1, { a => { b => 1 } } # +strict +exists $x->{a}->{b} = 1 # exists $x->{a}->{d} # '', '', { a => { b => 1 } } # +strict +exists $x->{a}->{b} = 1 # exists $x->{c}->{d} # qr/^Reference vivification forbidden/, undef, { a => { b => 1 } } # +strict +exists $x->{a}->{b} = 1 # exists $x->{a}->{b} # '', 1, { a => { b => 1 } } # +strict +delete $x->{a}->{b} = 1 # exists $x->{a}->{d} # '', '', { a => { b => 1 } } # +strict +delete $x->{a}->{b} = 1 # exists $x->{c}->{d} # '', '', { a => { b => 1 }, c => { } } # +strict +delete $x->{a}->{b} = 1 # exists $x->{a}->{b} # '', 1, { a => { b => 1 } } # +strict +store $x->{a}->{b} = 1 # exists $x->{a}->{d} # '', '', { a => { b => 1 } } # +strict +store $x->{a}->{b} = 1 # exists $x->{c}->{d} # '', '', { a => { b => 1 }, c => { } } # +strict +store --- delete --- $x # delete $x->{a} # '', undef, { } $x # delete $x->{a} # '', undef, undef # $x # delete $x->{a} # '', undef, { } # +fetch $x # delete $x->{a} # '', undef, { } # +exists $x # delete $x->{a} # '', undef, undef # +delete $x # delete $x->{a} # '', undef, { } # +store $x # delete $x->{a} # '', undef, { } # +strict +fetch $x # delete $x->{a} # '', undef, { } # +strict +exists $x # delete $x->{a} # qr/^Reference vivification forbidden/, undef, undef # +strict +delete $x # delete $x->{a} # '', undef, { } # +strict +store $x # delete $x->{a}->{b} # '', undef, { a => { } } $x # delete $x->{a}->{b} # '', undef, undef # $x # delete $x->{a}->{b} # '', undef, { a => { } } # +fetch $x # delete $x->{a}->{b} # '', undef, { a => { } } # +exists $x # delete $x->{a}->{b} # '', undef, undef # +delete $x # delete $x->{a}->{b} # '', undef, { a => { } } # +store $x # delete $x->{a}->{b} # '', undef, { a => { } } # +strict +fetch $x # delete $x->{a}->{b} # '', undef, { a => { } } # +strict +exists $x # delete $x->{a}->{b} # qr/^Reference vivification forbidden/, undef, undef # +strict +delete $x # delete $x->{a}->{b} # '', undef, { a => { } } # +strict +store $x->{a} = 1 # delete $x->{a} # '', 1, { } # +fetch $x->{a} = 1 # delete $x->{b} # '', undef, { a => 1 } # +fetch $x->{a} = 1 # delete $x->{a} # '', 1, { } # +exists $x->{a} = 1 # delete $x->{b} # '', undef, { a => 1 } # +exists $x->{a} = 1 # delete $x->{a} # '', 1, { } # +delete $x->{a} = 1 # delete $x->{b} # '', undef, { a => 1 } # +delete $x->{a} = 1 # delete $x->{a} # '', 1, { } # +store $x->{a} = 1 # delete $x->{b} # '', undef, { a => 1 } # +store $x->{a} = 1 # delete $x->{a} # '', 1, { } # +strict +fetch $x->{a} = 1 # delete $x->{b} # '', undef, { a => 1 } # +strict +fetch $x->{a} = 1 # delete $x->{a} # '', 1, { } # +strict +exists $x->{a} = 1 # delete $x->{b} # '', undef, { a => 1 } # +strict +exists $x->{a} = 1 # delete $x->{a} # '', 1, { } # +strict +delete $x->{a} = 1 # delete $x->{b} # '', undef, { a => 1 } # +strict +delete $x->{a} = 1 # delete $x->{a} # '', 1, { } # +strict +store $x->{a} = 1 # delete $x->{b} # '', undef, { a => 1 } # +strict +store $x->{a}->{b} = 1 # delete $x->{a}->{b} # '', 1, { a => { } } # +fetch $x->{a}->{b} = 1 # delete $x->{a}->{d} # '', undef, { a => { b => 1 } }# +fetch $x->{a}->{b} = 1 # delete $x->{c}->{d} # '', undef, { a => { b => 1 }, c => { } } # +fetch $x->{a}->{b} = 1 # delete $x->{a}->{b} # '', 1, { a => { } } # +exists $x->{a}->{b} = 1 # delete $x->{a}->{d} # '', undef, { a => { b => 1 } }# +exists $x->{a}->{b} = 1 # delete $x->{c}->{d} # '', undef, { a => { b => 1 }, c => { } } # +exists $x->{a}->{b} = 1 # delete $x->{a}->{b} # '', 1, { a => { } } # +delete $x->{a}->{b} = 1 # delete $x->{a}->{d} # '', undef, { a => { b => 1 } }# +delete $x->{a}->{b} = 1 # delete $x->{c}->{d} # '', undef, { a => { b => 1 } }# +delete $x->{a}->{b} = 1 # delete $x->{a}->{b} # '', 1, { a => { } } # +store $x->{a}->{b} = 1 # delete $x->{a}->{d} # '', undef, { a => { b => 1 } }# +store $x->{a}->{b} = 1 # delete $x->{c}->{d} # '', undef, { a => { b => 1 }, c => { } } # +store $x->{a}->{b} = 1 # delete $x->{a}->{b} # '', 1, { a => { } } # +strict +fetch $x->{a}->{b} = 1 # delete $x->{a}->{d} # '', undef, { a => { b => 1 } } # +strict +fetch $x->{a}->{b} = 1 # delete $x->{c}->{d} # '', undef, { a => { b => 1 }, c => {} }# +strict +fetch $x->{a}->{b} = 1 # delete $x->{a}->{b} # '', 1, { a => { } } # +strict +exists $x->{a}->{b} = 1 # delete $x->{a}->{d} # '', undef, { a => { b => 1 } } # +strict +exists $x->{a}->{b} = 1 # delete $x->{c}->{d} # '', undef, { a => { b => 1 }, c => {} }# +strict +exists $x->{a}->{b} = 1 # delete $x->{a}->{b} # '', 1, { a => { } } # +strict +delete $x->{a}->{b} = 1 # delete $x->{a}->{d} # '', undef, { a => { b => 1 } } # +strict +delete $x->{a}->{b} = 1 # delete $x->{c}->{d} # qr/^Reference vivification forbidden/, undef, { a => { b => 1 } } # +strict +delete $x->{a}->{b} = 1 # delete $x->{a}->{b} # '', 1, { a => { } } # +strict +store $x->{a}->{b} = 1 # delete $x->{a}->{d} # '', undef, { a => { b => 1 } } # +strict +store $x->{a}->{b} = 1 # delete $x->{c}->{d} # '', undef, { a => { b => 1 }, c => {} }# +strict +store --- store --- $x # $x->{a} = 1 # '', 1, { a => 1 } $x # $x->{a} = 1 # '', 1, { a => 1 } # $x # $x->{a} = 1 # '', 1, { a => 1 } # +fetch $x # $x->{a} = 1 # '', 1, { a => 1 } # +exists $x # $x->{a} = 1 # '', 1, { a => 1 } # +delete $x # $x->{a} = 1 # qr/^Can't vivify reference/, undef, undef # +store $x # $x->{a} = 1 # '', 1, { a => 1 } # +strict +fetch $x # $x->{a} = 1 # '', 1, { a => 1 } # +strict +exists $x # $x->{a} = 1 # '', 1, { a => 1 } # +strict +delete $x # $x->{a} = 1 # qr/^Reference vivification forbidden/, undef, undef # +strict +store $x # $x->{a}->{b} = 1 # '', 1, { a => { b => 1 } } $x # $x->{a}->{b} = 1 # '', 1, { a => { b => 1 } } # $x # $x->{a}->{b} = 1 # '', 1, { a => { b => 1 } } # +fetch $x # $x->{a}->{b} = 1 # '', 1, { a => { b => 1 } } # +exists $x # $x->{a}->{b} = 1 # '', 1, { a => { b => 1 } } # +delete $x # $x->{a}->{b} = 1 # qr/^Can't vivify reference/, undef, undef # +store $x # $x->{a}->{b} = 1 # '', 1, { a => { b => 1 } } # +strict +fetch $x # $x->{a}->{b} = 1 # '', 1, { a => { b => 1 } } # +strict +exists $x # $x->{a}->{b} = 1 # '', 1, { a => { b => 1 } } # +strict +delete $x # $x->{a}->{b} = 1 # qr/^Reference vivification forbidden/, undef, undef # +strict +store $x->{a} = 1 # $x->{a} = 2 # '', 2, { a => 2 } # +fetch $x->{a} = 1 # $x->{b} = 2 # '', 2, { a => 1, b => 2 } # +fetch $x->{a} = 1 # $x->{a} = 2 # '', 2, { a => 2 } # +exists $x->{a} = 1 # $x->{b} = 2 # '', 2, { a => 1, b => 2 } # +exists $x->{a} = 1 # $x->{a} = 2 # '', 2, { a => 2 } # +delete $x->{a} = 1 # $x->{b} = 2 # '', 2, { a => 1, b => 2 } # +delete $x->{a} = 1 # $x->{a} = 2 # '', 2, { a => 2 } # +store $x->{a} = 1 # $x->{b} = 2 # '', 2, { a => 1, b => 2 } # +store $x->{a} = 1 # $x->{a} = 2 # '', 2, { a => 2 } # +strict +fetch $x->{a} = 1 # $x->{b} = 2 # '', 2, { a => 1, b => 2 } # +strict +fetch $x->{a} = 1 # $x->{a} = 2 # '', 2, { a => 2 } # +strict +exists $x->{a} = 1 # $x->{b} = 2 # '', 2, { a => 1, b => 2 } # +strict +exists $x->{a} = 1 # $x->{a} = 2 # '', 2, { a => 2 } # +strict +delete $x->{a} = 1 # $x->{b} = 2 # '', 2, { a => 1, b => 2 } # +strict +delete $x->{a} = 1 # $x->{a} = 2 # '', 2, { a => 2 } # +strict +store $x->{a} = 1 # $x->{b} = 2 # '', 2, { a => 1, b => 2 } # +strict +store $x->{a}->{b} = 1 # $x->{a}->{b} = 2 # '', 2, { a => { b => 2 } } # +fetch $x->{a}->{b} = 1 # $x->{a}->{d} = 2 # '', 2, { a => { b => 1, d => 2 } } # +fetch $x->{a}->{b} = 1 # $x->{c}->{d} = 2 # '', 2, { a => { b => 1 }, c => { d => 2 } } # +fetch $x->{a}->{b} = 1 # $x->{a}->{b} = 2 # '', 2, { a => { b => 2 } } # +exists $x->{a}->{b} = 1 # $x->{a}->{d} = 2 # '', 2, { a => { b => 1, d => 2 } } # +exists $x->{a}->{b} = 1 # $x->{c}->{d} = 2 # '', 2, { a => { b => 1 }, c => { d => 2 } } # +exists $x->{a}->{b} = 1 # $x->{a}->{b} = 2 # '', 2, { a => { b => 2 } } # +delete $x->{a}->{b} = 1 # $x->{a}->{d} = 2 # '', 2, { a => { b => 1, d => 2 } } # +delete $x->{a}->{b} = 1 # $x->{c}->{d} = 2 # '', 2, { a => { b => 1 }, c => { d => 2 } } # +delete $x->{a}->{b} = 1 # $x->{a}->{b} = 2 # '', 2, { a => { b => 2 } } # +store $x->{a}->{b} = 1 # $x->{a}->{d} = 2 # '', 2, { a => { b => 1, d => 2 } } # +store $x->{a}->{b} = 1 # $x->{c}->{d} = 2 # qr/^Can't vivify reference/, undef, { a => { b => 1 } } # +store $x->{a}->{b} = 1 # $x->{a}->{b} = 2 # '', 2, { a => { b => 2 } } # +strict +fetch $x->{a}->{b} = 1 # $x->{a}->{d} = 2 # '', 2, { a => { b => 1, d => 2 } } # +strict +fetch $x->{a}->{b} = 1 # $x->{c}->{d} = 2 # '', 2, { a => { b => 1 }, c => { d => 2 } } # +strict +fetch $x->{a}->{b} = 1 # $x->{a}->{b} = 2 # '', 2, { a => { b => 2 } } # +strict +exists $x->{a}->{b} = 1 # $x->{a}->{d} = 2 # '', 2, { a => { b => 1, d => 2 } } # +strict +exists $x->{a}->{b} = 1 # $x->{c}->{d} = 2 # '', 2, { a => { b => 1 }, c => { d => 2 } } # +strict +exists $x->{a}->{b} = 1 # $x->{a}->{b} = 2 # '', 2, { a => { b => 2 } } # +strict +delete $x->{a}->{b} = 1 # $x->{a}->{d} = 2 # '', 2, { a => { b => 1, d => 2 } } # +strict +delete $x->{a}->{b} = 1 # $x->{c}->{d} = 2 # '', 2, { a => { b => 1 }, c => { d => 2 } } # +strict +delete $x->{a}->{b} = 1 # $x->{a}->{b} = 2 # '', 2, { a => { b => 2 } } # +strict +store $x->{a}->{b} = 1 # $x->{a}->{d} = 2 # '', 2, { a => { b => 1, d => 2 } } # +strict +store $x->{a}->{b} = 1 # $x->{c}->{d} = 2 # qr/^Reference vivification forbidden/, undef, { a => { b => 1 } } # +strict +store autovivification-0.18/t/22-hash-kv.t000644 000765 000024 00000007076 12416743316 020071 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use lib 't/lib'; use Test::Leaner; BEGIN { plan tests => 9 * 3 * 64; } use autovivification::TestCases; while () { 1 while chomp; next unless /#/; testcase_ok($_, '%'); } __DATA__ --- keys --- $x # keys %$x # '', 0, { } $x # keys %$x # '', 0, undef # $x # keys %$x # '', 0, undef # +fetch $x # keys %$x # '', 0, { } # +exists $x # keys %$x # '', 0, { } # +delete $x # keys %$x # '', 0, { } # +store $x # keys %$x # qr/^Reference vivification forbidden/, undef, undef # +strict +fetch $x # keys %$x # '', 0, { } # +strict +exists $x # keys %$x # '', 0, { } # +strict +delete $x # keys %$x # '', 0, { } # +strict +store $x # [ keys %$x ] # '', [ ], { } $x # [ keys %$x ] # '', [ ], undef # $x # [ keys %$x ] # '', [ ], undef # +fetch $x # [ keys %$x ] # '', [ ], { } # +exists +delete +store $x->{a} = 1 # [ keys %$x ] # '', [ 'a' ], { a => 1 } $x->{a} = 1 # [ keys %$x ] # '', [ 'a' ], { a => 1 } # $x->{a} = 1 # [ keys %$x ] # '', [ 'a' ], { a => 1 } # +fetch $x->{a} = 1 # [ keys %$x ] # '', [ 'a' ], { a => 1 } # +exists +delete +store $x # keys %{$x->{a}} # '', 0, { a => { } } $x # keys %{$x->{a}} # '', 0, undef # $x # keys %{$x->{a}} # '', 0, undef # +fetch $x # keys %{$x->{a}} # '', 0, { a => { } } # +exists $x # keys %{$x->{a}} # '', 0, { a => { } } # +delete $x # keys %{$x->{a}} # '', 0, { a => { } } # +store $x # keys %{$x->{a}} # qr/^Reference vivification forbidden/, undef, undef # +strict +fetch $x # keys %{$x->{a}} # '', 0, { a => { } } # +strict +exists $x # keys %{$x->{a}} # '', 0, { a => { } } # +strict +delete $x # keys %{$x->{a}} # '', 0, { a => { } } # +strict +store $x # [ keys %{$x->{a}} ] # '', [ ], { a => { } } $x # [ keys %{$x->{a}} ] # '', [ ], undef # $x # [ keys %{$x->{a}} ] # '', [ ], undef # +fetch $x # [ keys %{$x->{a}} ] # '', [ ], { a => { } } # +exists +delete +store --- values --- $x # values %$x # '', 0, { } $x # values %$x # '', 0, undef # $x # values %$x # '', 0, undef # +fetch $x # values %$x # '', 0, { } # +exists $x # values %$x # '', 0, { } # +delete $x # values %$x # '', 0, { } # +store $x # values %$x # qr/^Reference vivification forbidden/, undef, undef # +strict +fetch $x # values %$x # '', 0, { } # +strict +exists $x # values %$x # '', 0, { } # +strict +delete $x # values %$x # '', 0, { } # +strict +store $x # [ values %$x ] # '', [ ], { } $x # [ values %$x ] # '', [ ], undef # $x # [ values %$x ] # '', [ ], undef # +fetch $x # [ values %$x ] # '', [ ], { } # +exists +delete +store $x->{a} = 1 # [ values %$x ] # '', [ 1 ], { a => 1 } $x->{a} = 1 # [ values %$x ] # '', [ 1 ], { a => 1 } # $x->{a} = 1 # [ values %$x ] # '', [ 1 ], { a => 1 } # +fetch $x->{a} = 1 # [ values %$x ] # '', [ 1 ], { a => 1 } # +exists +delete +store $x # values %{$x->{a}} # '', 0, { a => { } } $x # values %{$x->{a}} # '', 0, undef # $x # values %{$x->{a}} # '', 0, undef # +fetch $x # values %{$x->{a}} # '', 0, { a => { } } # +exists $x # values %{$x->{a}} # '', 0, { a => { } } # +delete $x # values %{$x->{a}} # '', 0, { a => { } } # +store $x # values %{$x->{a}} # qr/^Reference vivification forbidden/, undef, undef # +strict +fetch $x # values %{$x->{a}} # '', 0, { a => { } } # +strict +exists $x # values %{$x->{a}} # '', 0, { a => { } } # +strict +delete $x # values %{$x->{a}} # '', 0, { a => { } } # +strict +store $x # [ values %{$x->{a}} ] # '', [ ], { a => { } } $x # [ values %{$x->{a}} ] # '', [ ], undef # $x # [ values %{$x->{a}} ] # '', [ ], undef # +fetch $x # [ values %{$x->{a}} ] # '', [ ], { a => { } } # +exists +delete +store autovivification-0.18/t/23-hash-tied.t000644 000765 000024 00000000737 12416743316 020374 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More; BEGIN { eval 'use Tie::Hash; scalar keys %Tie::StdHash::' or plan skip_all => 'Tie::StdHash required to test tied hashes'; defined and diag "Using Tie::StdHash $_" for $Tie::Hash::VERSION; plan tests => 1; } { tie my %x, 'Tie::StdHash'; tie my %y, 'Tie::StdHash'; $x{key} = 'hlagh'; $y{x} = \%x; my $res = do { no autovivification; $y{x}{key}; }; is $res, 'hlagh', 'nested tied hashes'; } autovivification-0.18/t/24-hash-numerous.t000644 000765 000024 00000005224 12416743316 021321 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use Test::More tests => 2 * 2 * 4; my $n = 100; { my $w; { my $r; no autovivification; $r = $w->{a}{b} for 1 .. $n; } is_deeply $w, undef, 'numerous fetches from an undef lexical'; $w = { a => undef }; { my $r; no autovivification; $r = $w->{a}{b} for 1 .. $n; } is_deeply $w, { a => undef },'numerous fetches from a 1-level hashref lexical'; } { our $w; { my $r; no autovivification; $r = $w->{a}{b} for 1 .. $n; } is_deeply $w, undef, 'numerous fetches from an undef global'; $w = { a => undef }; { my $r; no autovivification; $r = $w->{a}{b} for 1 .. $n; } is_deeply $w, { a => undef },'numerous fetches from a 1-level hashref global'; } { my $x; { my @r; no autovivification; @r = @{$x}{qw} for 1 .. $n; } is_deeply $x, undef, 'numerous slices from an undef lexical'; $x = { a => undef }; { my @r; no autovivification; @r = @{$x->{a}}{qw} for 1 .. $n; } is_deeply $x, { a => undef }, 'numerous slices from a 1-level hashref lexical'; } { our $x; { my @r; no autovivification; @r = @{$x}{qw} for 1 .. $n; } is_deeply $x, undef, 'numerous slices from an undef global'; $x = { a => undef }; { my @r; no autovivification; @r = @{$x->{a}}{qw} for 1 .. $n; } is_deeply $x, { a => undef }, 'numerous slices from a 1-level hashref global'; } { my $y; { my $r; no autovivification; $r = exists $y->{a}{b} for 1 .. $n; } is_deeply $y, undef, 'numerous exists from an undef lexical'; $y = { a => undef }; { my $r; no autovivification; $r = exists $y->{a}{b} for 1 .. $n; } is_deeply $y, { a => undef },'numerous exists from a 1-level hashref lexical'; } { our $y; { my $r; no autovivification; $r = exists $y->{a}{b} for 1 .. $n; } is_deeply $y, undef, 'numerous exists from an undef global'; $y = { a => undef }; { my $r; no autovivification; $r = exists $y->{a}{b} for 1 .. $n; } is_deeply $y, { a => undef },'numerous exists from a 1-level hashref global'; } { my $z; { my $r; no autovivification; $r = delete $z->{a}{b} for 1 .. $n; } is_deeply $z, undef, 'numerous deletes from an undef lexical'; $z = { a => undef }; { my $r; no autovivification; $r = delete $z->{a}{b} for 1 .. $n; } is_deeply $z, { a => undef },'numerous deletes from a 1-level hashref lexical'; } { our $z; { my $r; no autovivification; $r = delete $z->{a}{b} for 1 .. $n; } is_deeply $z, undef, 'numerous deletes from an undef global'; $z = { a => undef }; { my $r; no autovivification; $r = delete $z->{a}{b} for 1 .. $n; } is_deeply $z, { a => undef },'numerous deletes from a 1-level hashref global'; } autovivification-0.18/t/30-array.t000644 000765 000024 00000055540 12416743316 017644 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use lib 't/lib'; use Test::Leaner tests => 9 * 3 * 302; use autovivification::TestCases; while () { 1 while chomp; next unless /#/; testcase_ok($_, '@'); } __DATA__ --- fetch --- $x # $x->[$N[0]] # '', undef, [ ] $x # $x->[$N[0]] # '', undef, undef # $x # $x->[$N[0]] # '', undef, undef # +fetch $x # $x->[$N[0]] # '', undef, [ ] # +exists $x # $x->[$N[0]] # '', undef, [ ] # +delete $x # $x->[$N[0]] # '', undef, [ ] # +store $x # $x->[$N[0]] # '', undef, [ ] # -fetch $x # $x->[$N[0]] # '', undef, [ ] # +fetch -fetch $x # $x->[$N[0]] # '', undef, undef # -fetch +fetch $x # $x->[$N[0]] # '', undef, undef # +fetch -exists $x # $x->[$N[0]] # qr/^Reference vivification forbidden/, undef, undef # +strict +fetch $x # $x->[$N[0]] # '', undef, [ ] # +strict +exists $x # $x->[$N[0]] # '', undef, [ ] # +strict +delete $x # $x->[$N[0]] # '', undef, [ ] # +strict +store $x # $x->[$N[0]]->[$N[1]] # '', undef, [ [ ] ] $x # $x->[$N[0]]->[$N[1]] # '', undef, undef # $x # $x->[$N[0]]->[$N[1]] # '', undef, undef # +fetch $x # $x->[$N[0]]->[$N[1]] # '', undef, [ [ ] ] # +exists $x # $x->[$N[0]]->[$N[1]] # '', undef, [ [ ] ] # +delete $x # $x->[$N[0]]->[$N[1]] # '', undef, [ [ ] ] # +store $x # $x->[$N[0]]->[$N[1]] # qr/^Reference vivification forbidden/, undef, undef # +strict +fetch $x # $x->[$N[0]]->[$N[1]] # '', undef, [ [ ] ] # +strict +exists $x # $x->[$N[0]]->[$N[1]] # '', undef, [ [ ] ] # +strict +delete $x # $x->[$N[0]]->[$N[1]] # '', undef, [ [ ] ] # +strict +store $x->[$N[0]] = 1 # $x->[$N[0]] # '', 1, [ 1 ] # +fetch $x->[$N[0]] = 1 # $x->[$N[1]] # '', undef, [ 1 ] # +fetch $x->[$N[0]] = 1 # $x->[$N[0]] # '', 1, [ 1 ] # +exists $x->[$N[0]] = 1 # $x->[$N[1]] # '', undef, [ 1 ] # +exists $x->[$N[0]] = 1 # $x->[$N[0]] # '', 1, [ 1 ] # +delete $x->[$N[0]] = 1 # $x->[$N[1]] # '', undef, [ 1 ] # +delete $x->[$N[0]] = 1 # $x->[$N[0]] # '', 1, [ 1 ] # +store $x->[$N[0]] = 1 # $x->[$N[1]] # '', undef, [ 1 ] # +store $x->[$N[0]] = 1 # $x->[$N[0]] # '', 1, [ 1 ] # +strict +fetch $x->[$N[0]] = 1 # $x->[$N[1]] # '', undef, [ 1 ] # +strict +fetch $x->[$N[0]] = 1 # $x->[$N[0]] # '', 1, [ 1 ] # +strict +exists $x->[$N[0]] = 1 # $x->[$N[1]] # '', undef, [ 1 ] # +strict +exists $x->[$N[0]] = 1 # $x->[$N[0]] # '', 1, [ 1 ] # +strict +delete $x->[$N[0]] = 1 # $x->[$N[1]] # '', undef, [ 1 ] # +strict +delete $x->[$N[0]] = 1 # $x->[$N[0]] # '', 1, [ 1 ] # +strict +store $x->[$N[0]] = 1 # $x->[$N[1]] # '', undef, [ 1 ] # +strict +store $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[1]] # '', 1, [ [ undef, 1 ] ] # +fetch $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[3]] # '', undef, [ [ undef, 1 ] ] # +fetch $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[2]]->[$N[3]] # '', undef, [ [ undef, 1 ] ] # +fetch $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[1]] # '', 1, [ [ undef, 1 ] ] # +exists $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[3]] # '', undef, [ [ undef, 1 ] ] # +exists $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[2]]->[$N[3]] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +exists $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[1]] # '', 1, [ [ undef, 1 ] ] # +delete $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[3]] # '', undef, [ [ undef, 1 ] ] # +delete $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[2]]->[$N[3]] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +delete $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[1]] # '', 1, [ [ undef, 1 ] ] # +store $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[3]] # '', undef, [ [ undef, 1 ] ] # +store $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[2]]->[$N[3]] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +store $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[1]] # '', 1, [ [ undef, 1 ] ] # +strict +fetch $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[3]] # '', undef, [ [ undef, 1 ] ] # +strict +fetch $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[2]]->[$N[3]] # qr/^Reference vivification forbidden/, undef, [ [ undef, 1 ] ] # +strict +fetch $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[1]] # '', 1, [ [ undef, 1 ] ] # +strict +exists $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[3]] # '', undef, [ [ undef, 1 ] ] # +strict +exists $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[2]]->[$N[3]] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +strict +exists $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[1]] # '', 1, [ [ undef, 1 ] ] # +strict +delete $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[3]] # '', undef, [ [ undef, 1 ] ] # +strict +delete $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[2]]->[$N[3]] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +strict +delete $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[1]] # '', 1, [ [ undef, 1 ] ] # +strict +store $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[3]] # '', undef, [ [ undef, 1 ] ] # +strict +store $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[2]]->[$N[3]] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +strict +store --- aliasing --- $x # 1 for $x->[$N[0]]; () # '', undef, [ undef ] $x # 1 for $x->[$N[0]]; () # '', undef, [ undef ] # $x # 1 for $x->[$N[0]]; () # '', undef, [ undef ] # +fetch $x # 1 for $x->[$N[0]]; () # '', undef, [ undef ] # +exists $x # 1 for $x->[$N[0]]; () # '', undef, [ undef ] # +delete $x # 1 for $x->[$N[0]]; () # qr/^Can't vivify reference/, undef, undef # +store $x # $_ = 1 for $x->[$N[0]]; () # '', undef, [ 1 ] $x # $_ = 1 for $x->[$N[0]]; () # '', undef, [ 1 ] # $x # $_ = 1 for $x->[$N[0]]; () # '', undef, [ 1 ] # +fetch $x # $_ = 1 for $x->[$N[0]]; () # '', undef, [ 1 ] # +exists $x # $_ = 1 for $x->[$N[0]]; () # '', undef, [ 1 ] # +delete $x # $_ = 1 for $x->[$N[0]]; () # qr/^Can't vivify reference/, undef, undef # +store $x->[$N[0]] = 1 # 1 for $x->[$N[0]]; () # '', undef, [ 1 ] # +fetch $x->[$N[0]] = 1 # 1 for $x->[$N[1]]; () # '', undef, [ 1, undef ] # +fetch $x->[$N[0]] = 1 # 1 for $x->[$N[0]]; () # '', undef, [ 1 ] # +exists $x->[$N[0]] = 1 # 1 for $x->[$N[1]]; () # '', undef, [ 1, undef ] # +exists $x->[$N[0]] = 1 # 1 for $x->[$N[0]]; () # '', undef, [ 1 ] # +delete $x->[$N[0]] = 1 # 1 for $x->[$N[1]]; () # '', undef, [ 1, undef ] # +delete $x->[$N[0]] = 1 # 1 for $x->[$N[0]]; () # '', undef, [ 1 ] # +store $x->[$N[0]] = 1 # 1 for $x->[$N[1]]; () # '', undef, [ 1, undef ] # +store $x # do_nothing($x->[$N[0]]); () # '', undef, [ ] $x # do_nothing($x->[$N[0]]); () # '', undef, [ ] # $x # do_nothing($x->[$N[0]]); () # '', undef, [ ] # +fetch $x # do_nothing($x->[$N[0]]); () # '', undef, [ ] # +exists $x # do_nothing($x->[$N[0]]); () # '', undef, [ ] # +delete $x # do_nothing($x->[$N[0]]); () # qr/^Can't vivify reference/, undef, undef # +store $x # set_arg($x->[$N[0]]); () # '', undef, [ 1 ] $x # set_arg($x->[$N[0]]); () # '', undef, [ 1 ] # $x # set_arg($x->[$N[0]]); () # '', undef, [ 1 ] # +fetch $x # set_arg($x->[$N[0]]); () # '', undef, [ 1 ] # +exists $x # set_arg($x->[$N[0]]); () # '', undef, [ 1 ] # +delete $x # set_arg($x->[$N[0]]); () # qr/^Can't vivify reference/, undef, undef # +store --- dereferencing --- $x # no warnings 'uninitialized'; my @a = @$x; () # ($strict ? qr/^Can't use an undefined value as an ARRAY reference/ : ''), undef, undef $x # no warnings 'uninitialized'; my @a = @$x; () # ($strict ? qr/^Can't use an undefined value as an ARRAY reference/ : ''), undef, undef # $x # no warnings 'uninitialized'; my @a = @$x; () # ($strict ? qr/^Can't use an undefined value as an ARRAY reference/ : ''), undef, undef # +fetch $x # no warnings 'uninitialized'; my @a = @$x; () # ($strict ? qr/^Can't use an undefined value as an ARRAY reference/ : ''), undef, undef # +exists $x # no warnings 'uninitialized'; my @a = @$x; () # ($strict ? qr/^Can't use an undefined value as an ARRAY reference/ : ''), undef, undef # +delete $x # no warnings 'uninitialized'; my @a = @$x; () # ($strict ? qr/^Can't use an undefined value as an ARRAY reference/ : ''), undef, undef # +store $x->[$N[0]] = 1 # my @a = @$x; () # '', undef, [ 1 ] # +fetch $x->[$N[0]] = 1 # my @a = @$x; () # '', undef, [ 1 ] # +exists $x->[$N[0]] = 1 # my @a = @$x; () # '', undef, [ 1 ] # +delete $x->[$N[0]] = 1 # my @a = @$x; () # '', undef, [ 1 ] # +store --- slice --- $x # my @a = @$x[$N[0], $N[1]]; \@a # '', [ undef, undef ], [ ] $x # my @a = @$x[$N[0], $N[1]]; \@a # '', [ undef, undef ], undef # $x # my @a = @$x[$N[0], $N[1]]; \@a # '', [ undef, undef ], undef # +fetch $x # my @a = @$x[$N[0], $N[1]]; \@a # '', [ undef, undef ], [ ] # +exists $x # my @a = @$x[$N[0], $N[1]]; \@a # '', [ undef, undef ], [ ] # +delete $x # my @a = @$x[$N[0], $N[1]]; \@a # '', [ undef, undef ], [ ] # +store $x->[$N[1]] = 0 # my @a = @$x[$N[0], $N[1]]; \@a # '', [ undef, 0 ], [ undef, 0 ] # +fetch $x # @$x[$N[0], $N[1]] = (1, 2); () # '', undef, [ 1, 2 ] $x # @$x[$N[0], $N[1]] = (1, 2); () # '', undef, [ 1, 2 ] # $x # @$x[$N[0], $N[1]] = (1, 2); () # '', undef, [ 1, 2 ] # +fetch $x # @$x[$N[0], $N[1]] = (1, 2); () # '', undef, [ 1, 2 ] # +exists $x # @$x[$N[0], $N[1]] = (1, 2); () # '', undef, [ 1, 2 ] # +delete $x # @$x[$N[0], $N[1]] = (1, 2); () # qr/^Can't vivify reference/, undef, undef # +store $x->[$N[0]] = 0 # @$x[$N[0], $N[1]] = (1, 2); () # '', undef, [ 1, 2 ] # +store $x->[$N[2]] = 0 # @$x[$N[0], $N[1]] = (1, 2); () # '', undef, [ 1, 2, 0 ] # +store $x->[$N[0]] = 0, $x->[$N[1]] = 0 # @$x[$N[0], $N[1]] = (1, 2); () # '', undef, [ 1, 2 ] # +store --- exists --- $x # exists $x->[$N[0]] # '', '', [ ] $x # exists $x->[$N[0]] # '', '', undef # $x # exists $x->[$N[0]] # '', '', [ ] # +fetch $x # exists $x->[$N[0]] # '', '', undef # +exists $x # exists $x->[$N[0]] # '', '', [ ] # +delete $x # exists $x->[$N[0]] # '', '', [ ] # +store $x # exists $x->[$N[0]] # '', '', [ ] # +strict +fetch $x # exists $x->[$N[0]] # qr/^Reference vivification forbidden/, undef, undef # +strict +exists $x # exists $x->[$N[0]] # '', '', [ ] # +strict +delete $x # exists $x->[$N[0]] # '', '', [ ] # +strict +store $x # exists $x->[$N[0]]->[$N[1]] # '', '', [ [ ] ] $x # exists $x->[$N[0]]->[$N[1]] # '', '', undef # $x # exists $x->[$N[0]]->[$N[1]] # '', '', [ [ ] ] # +fetch $x # exists $x->[$N[0]]->[$N[1]] # '', '', undef # +exists $x # exists $x->[$N[0]]->[$N[1]] # '', '', [ [ ] ] # +delete $x # exists $x->[$N[0]]->[$N[1]] # '', '', [ [ ] ] # +store $x # exists $x->[$N[0]]->[$N[1]] # '', '', [ [ ] ] # +strict +fetch $x # exists $x->[$N[0]]->[$N[1]] # qr/^Reference vivification forbidden/, undef, undef # +strict +exists $x # exists $x->[$N[0]]->[$N[1]] # '', '', [ [ ] ] # +strict +delete $x # exists $x->[$N[0]]->[$N[1]] # '', '', [ [ ] ] # +strict +store $x->[$N[0]] = 1 # exists $x->[$N[0]] # '', 1, [ 1 ] # +fetch $x->[$N[0]] = 1 # exists $x->[$N[1]] # '', '', [ 1 ] # +fetch $x->[$N[0]] = 1 # exists $x->[$N[0]] # '', 1, [ 1 ] # +exists $x->[$N[0]] = 1 # exists $x->[$N[1]] # '', '', [ 1 ] # +exists $x->[$N[0]] = 1 # exists $x->[$N[0]] # '', 1, [ 1 ] # +delete $x->[$N[0]] = 1 # exists $x->[$N[1]] # '', '', [ 1 ] # +delete $x->[$N[0]] = 1 # exists $x->[$N[0]] # '', 1, [ 1 ] # +store $x->[$N[0]] = 1 # exists $x->[$N[1]] # '', '', [ 1 ] # +store $x->[$N[0]] = 1 # exists $x->[$N[0]] # '', 1, [ 1 ] # +strict +fetch $x->[$N[0]] = 1 # exists $x->[$N[1]] # '', '', [ 1 ] # +strict +fetch $x->[$N[0]] = 1 # exists $x->[$N[0]] # '', 1, [ 1 ] # +strict +exists $x->[$N[0]] = 1 # exists $x->[$N[1]] # '', '', [ 1 ] # +strict +exists $x->[$N[0]] = 1 # exists $x->[$N[0]] # '', 1, [ 1 ] # +strict +delete $x->[$N[0]] = 1 # exists $x->[$N[1]] # '', '', [ 1 ] # +strict +delete $x->[$N[0]] = 1 # exists $x->[$N[0]] # '', 1, [ 1 ] # +strict +store $x->[$N[0]] = 1 # exists $x->[$N[1]] # '', '', [ 1 ] # +strict +store $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[0]]->[$N[1]] # '', 1, [ [ undef, 1 ] ] # +fetch $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[0]]->[$N[3]] # '', '', [ [ undef, 1 ] ] # +fetch $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[2]]->[$N[3]] # '', '', [ [ undef, 1 ], undef, [ ] ] # +fetch $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[0]]->[$N[1]] # '', 1, [ [ undef, 1 ] ] # +exists $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[0]]->[$N[3]] # '', '', [ [ undef, 1 ] ] # +exists $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[2]]->[$N[3]] # '', '', [ [ undef, 1 ] ] # +exists $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[0]]->[$N[1]] # '', 1, [ [ undef, 1 ] ] # +delete $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[0]]->[$N[3]] # '', '', [ [ undef, 1 ] ] # +delete $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[2]]->[$N[3]] # '', '', [ [ undef, 1 ], undef, [ ] ] # +delete $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[0]]->[$N[1]] # '', 1, [ [ undef, 1 ] ] # +store $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[0]]->[$N[3]] # '', '', [ [ undef, 1 ] ] # +store $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[2]]->[$N[3]] # '', '', [ [ undef, 1 ], undef, [ ] ] # +store $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[0]]->[$N[1]] # '', 1, [ [ undef, 1 ] ] # +strict +fetch $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[0]]->[$N[3]] # '', '', [ [ undef, 1 ] ] # +strict +fetch $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[2]]->[$N[3]] # '', '', [ [ undef, 1 ], undef, [ ] ] # +strict +fetch $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[0]]->[$N[1]] # '', 1, [ [ undef, 1 ] ] # +strict +exists $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[0]]->[$N[3]] # '', '', [ [ undef, 1 ] ] # +strict +exists $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[2]]->[$N[3]] # qr/^Reference vivification forbidden/, undef, [ [ undef, 1 ] ] # +strict +exists $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[0]]->[$N[1]] # '', 1, [ [ undef, 1 ] ] # +strict +delete $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[0]]->[$N[3]] # '', '', [ [ undef, 1 ] ] # +strict +delete $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[2]]->[$N[3]] # '', '', [ [ undef, 1 ], undef, [ ] ] # +strict +delete $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[0]]->[$N[1]] # '', 1, [ [ undef, 1 ] ] # +strict +store $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[0]]->[$N[3]] # '', '', [ [ undef, 1 ] ] # +strict +store $x->[$N[0]]->[$N[1]] = 1 # exists $x->[$N[2]]->[$N[3]] # '', '', [ [ undef, 1 ], undef, [ ] ] # +strict +store --- delete --- $x # delete $x->[$N[0]] # '', undef, [ ] $x # delete $x->[$N[0]] # '', undef, undef # $x # delete $x->[$N[0]] # '', undef, [ ] # +fetch $x # delete $x->[$N[0]] # '', undef, [ ] # +exists $x # delete $x->[$N[0]] # '', undef, undef # +delete $x # delete $x->[$N[0]] # '', undef, [ ] # +store $x # delete $x->[$N[0]] # '', undef, [ ] # +strict +fetch $x # delete $x->[$N[0]] # '', undef, [ ] # +strict +exists $x # delete $x->[$N[0]] # qr/^Reference vivification forbidden/, undef, undef # +strict +delete $x # delete $x->[$N[0]] # '', undef, [ ] # +strict +store $x # delete $x->[$N[0]]->[$N[1]] # '', undef, [ [ ] ] $x # delete $x->[$N[0]]->[$N[1]] # '', undef, undef # $x # delete $x->[$N[0]]->[$N[1]] # '', undef, [ [ ] ] # +fetch $x # delete $x->[$N[0]]->[$N[1]] # '', undef, [ [ ] ] # +exists $x # delete $x->[$N[0]]->[$N[1]] # '', undef, undef # +delete $x # delete $x->[$N[0]]->[$N[1]] # '', undef, [ [ ] ] # +store $x # delete $x->[$N[0]]->[$N[1]] # '', undef, [ [ ] ] # +strict +fetch $x # delete $x->[$N[0]]->[$N[1]] # '', undef, [ [ ] ] # +strict +exists $x # delete $x->[$N[0]]->[$N[1]] # qr/^Reference vivification forbidden/, undef, undef # +strict +delete $x # delete $x->[$N[0]]->[$N[1]] # '', undef, [ [ ] ] # +strict +store $x->[$N[0]] = 1 # delete $x->[$N[0]] # '', 1, [ ] # +fetch $x->[$N[0]] = 1 # delete $x->[$N[1]] # '', undef, [ 1 ] # +fetch $x->[$N[0]] = 1 # delete $x->[$N[0]] # '', 1, [ ] # +exists $x->[$N[0]] = 1 # delete $x->[$N[1]] # '', undef, [ 1 ] # +exists $x->[$N[0]] = 1 # delete $x->[$N[0]] # '', 1, [ ] # +delete $x->[$N[0]] = 1 # delete $x->[$N[1]] # '', undef, [ 1 ] # +delete $x->[$N[0]] = 1 # delete $x->[$N[0]] # '', 1, [ ] # +store $x->[$N[0]] = 1 # delete $x->[$N[1]] # '', undef, [ 1 ] # +store $x->[$N[0]] = 1 # delete $x->[$N[0]] # '', 1, [ ] # +strict +fetch $x->[$N[0]] = 1 # delete $x->[$N[1]] # '', undef, [ 1 ] # +strict +fetch $x->[$N[0]] = 1 # delete $x->[$N[0]] # '', 1, [ ] # +strict +exists $x->[$N[0]] = 1 # delete $x->[$N[1]] # '', undef, [ 1 ] # +strict +exists $x->[$N[0]] = 1 # delete $x->[$N[0]] # '', 1, [ ] # +strict +delete $x->[$N[0]] = 1 # delete $x->[$N[1]] # '', undef, [ 1 ] # +strict +delete $x->[$N[0]] = 1 # delete $x->[$N[0]] # '', 1, [ ] # +strict +store $x->[$N[0]] = 1 # delete $x->[$N[1]] # '', undef, [ 1 ] # +strict +store $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[0]]->[$N[1]] # '', 1, [ [ ] ] # +fetch $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[0]]->[$N[3]] # '', undef, [ [ undef, 1 ] ]# +fetch $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[2]]->[$N[3]] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +fetch $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[0]]->[$N[1]] # '', 1, [ [ ] ] # +exists $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[0]]->[$N[3]] # '', undef, [ [ undef, 1 ] ]# +exists $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[2]]->[$N[3]] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +exists $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[0]]->[$N[1]] # '', 1, [ [ ] ] # +delete $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[0]]->[$N[3]] # '', undef, [ [ undef, 1 ] ]# +delete $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[2]]->[$N[3]] # '', undef, [ [ undef, 1 ] ]# +delete $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[0]]->[$N[1]] # '', 1, [ [ ] ] # +store $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[0]]->[$N[3]] # '', undef, [ [ undef, 1 ] ]# +store $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[2]]->[$N[3]] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +store $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[0]]->[$N[1]] # '', 1, [ [ ] ] # +strict +fetch $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[0]]->[$N[3]] # '', undef, [ [ undef, 1 ] ] # +strict +fetch $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[2]]->[$N[3]] # '', undef, [ [ undef, 1 ], undef, [ ] ]# +strict +fetch $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[0]]->[$N[1]] # '', 1, [ [ ] ] # +strict +exists $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[0]]->[$N[3]] # '', undef, [ [ undef, 1 ] ] # +strict +exists $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[2]]->[$N[3]] # '', undef, [ [ undef, 1 ], undef, [ ] ]# +strict +exists $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[0]]->[$N[1]] # '', 1, [ [ ] ] # +strict +delete $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[0]]->[$N[3]] # '', undef, [ [ undef, 1 ] ] # +strict +delete $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[2]]->[$N[3]] # qr/^Reference vivification forbidden/, undef, [ [ undef, 1 ] ] # +strict +delete $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[0]]->[$N[1]] # '', 1, [ [ ] ] # +strict +store $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[0]]->[$N[3]] # '', undef, [ [ undef, 1 ] ] # +strict +store $x->[$N[0]]->[$N[1]] = 1 # delete $x->[$N[2]]->[$N[3]] # '', undef, [ [ undef, 1 ], undef, [ ] ]# +strict +store --- store --- $x # $x->[$N[0]] = 1 # '', 1, [ 1 ] $x # $x->[$N[0]] = 1 # '', 1, [ 1 ] # $x # $x->[$N[0]] = 1 # '', 1, [ 1 ] # +fetch $x # $x->[$N[0]] = 1 # '', 1, [ 1 ] # +exists $x # $x->[$N[0]] = 1 # '', 1, [ 1 ] # +delete $x # $x->[$N[0]] = 1 # qr/^Can't vivify reference/, undef, undef # +store $x # $x->[$N[0]] = 1 # '', 1, [ 1 ] # +strict +fetch $x # $x->[$N[0]] = 1 # '', 1, [ 1 ] # +strict +exists $x # $x->[$N[0]] = 1 # '', 1, [ 1 ] # +strict +delete $x # $x->[$N[0]] = 1 # qr/^Reference vivification forbidden/, undef, undef # +strict +store $x # $x->[$N[0]]->[$N[1]] = 1 # '', 1, [ [ undef, 1 ] ] $x # $x->[$N[0]]->[$N[1]] = 1 # '', 1, [ [ undef, 1 ] ] # $x # $x->[$N[0]]->[$N[1]] = 1 # '', 1, [ [ undef, 1 ] ] # +fetch $x # $x->[$N[0]]->[$N[1]] = 1 # '', 1, [ [ undef, 1 ] ] # +exists $x # $x->[$N[0]]->[$N[1]] = 1 # '', 1, [ [ undef, 1 ] ] # +delete $x # $x->[$N[0]]->[$N[1]] = 1 # qr/^Can't vivify reference/, undef, undef # +store $x # $x->[$N[0]]->[$N[1]] = 1 # '', 1, [ [ undef, 1 ] ] # +strict +fetch $x # $x->[$N[0]]->[$N[1]] = 1 # '', 1, [ [ undef, 1 ] ] # +strict +exists $x # $x->[$N[0]]->[$N[1]] = 1 # '', 1, [ [ undef, 1 ] ] # +strict +delete $x # $x->[$N[0]]->[$N[1]] = 1 # qr/^Reference vivification forbidden/, undef, undef # +strict +store $x->[$N[0]] = 1 # $x->[$N[0]] = 2 # '', 2, [ 2 ] # +fetch $x->[$N[0]] = 1 # $x->[$N[1]] = 2 # '', 2, [ 1, 2 ] # +fetch $x->[$N[0]] = 1 # $x->[$N[0]] = 2 # '', 2, [ 2 ] # +exists $x->[$N[0]] = 1 # $x->[$N[1]] = 2 # '', 2, [ 1, 2 ] # +exists $x->[$N[0]] = 1 # $x->[$N[0]] = 2 # '', 2, [ 2 ] # +delete $x->[$N[0]] = 1 # $x->[$N[1]] = 2 # '', 2, [ 1, 2 ] # +delete $x->[$N[0]] = 1 # $x->[$N[0]] = 2 # '', 2, [ 2 ] # +store $x->[$N[0]] = 1 # $x->[$N[1]] = 2 # '', 2, [ 1, 2 ] # +store $x->[$N[0]] = 1 # $x->[$N[0]] = 2 # '', 2, [ 2 ] # +strict +fetch $x->[$N[0]] = 1 # $x->[$N[1]] = 2 # '', 2, [ 1, 2 ] # +strict +fetch $x->[$N[0]] = 1 # $x->[$N[0]] = 2 # '', 2, [ 2 ] # +strict +exists $x->[$N[0]] = 1 # $x->[$N[1]] = 2 # '', 2, [ 1, 2 ] # +strict +exists $x->[$N[0]] = 1 # $x->[$N[0]] = 2 # '', 2, [ 2 ] # +strict +delete $x->[$N[0]] = 1 # $x->[$N[1]] = 2 # '', 2, [ 1, 2 ] # +strict +delete $x->[$N[0]] = 1 # $x->[$N[0]] = 2 # '', 2, [ 2 ] # +strict +store $x->[$N[0]] = 1 # $x->[$N[1]] = 2 # '', 2, [ 1, 2 ] # +strict +store $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[1]] = 2 # '', 2, [ [ undef, 2 ] ] # +fetch $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[3]] = 2 # '', 2, [ [ undef, 1, undef, 2 ] ] # +fetch $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[2]]->[$N[3]] = 2 # '', 2, [ [ undef, 1 ], undef, [ undef, undef, undef, 2 ] ] # +fetch $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[1]] = 2 # '', 2, [ [ undef, 2 ] ] # +exists $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[3]] = 2 # '', 2, [ [ undef, 1, undef, 2 ] ] # +exists $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[2]]->[$N[3]] = 2 # '', 2, [ [ undef, 1 ], undef, [ undef, undef, undef, 2 ] ] # +exists $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[1]] = 2 # '', 2, [ [ undef, 2 ] ] # +delete $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[3]] = 2 # '', 2, [ [ undef, 1, undef, 2 ] ] # +delete $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[2]]->[$N[3]] = 2 # '', 2, [ [ undef, 1 ], undef, [ undef, undef, undef, 2 ] ] # +delete $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[1]] = 2 # '', 2, [ [ undef, 2 ] ] # +store $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[3]] = 2 # '', 2, [ [ undef, 1, undef, 2 ] ] # +store $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[2]]->[$N[3]] = 2 # qr/^Can't vivify reference/, undef, [ [ undef, 1 ] ] # +store $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[1]] = 2 # '', 2, [ [ undef, 2 ] ] # +strict +fetch $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[3]] = 2 # '', 2, [ [ undef, 1, undef, 2 ] ] # +strict +fetch $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[2]]->[$N[3]] = 2 # '', 2, [ [ undef, 1 ], undef, [ undef, undef, undef, 2 ] ] # +strict +fetch $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[1]] = 2 # '', 2, [ [ undef, 2 ] ] # +strict +exists $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[3]] = 2 # '', 2, [ [ undef, 1, undef, 2 ] ] # +strict +exists $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[2]]->[$N[3]] = 2 # '', 2, [ [ undef, 1 ], undef, [ undef, undef, undef, 2 ] ] # +strict +exists $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[1]] = 2 # '', 2, [ [ undef, 2 ] ] # +strict +delete $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[3]] = 2 # '', 2, [ [ undef, 1, undef, 2 ] ] # +strict +delete $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[2]]->[$N[3]] = 2 # '', 2, [ [ undef, 1 ], undef, [ undef, undef, undef, 2 ] ] # +strict +delete $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[1]] = 2 # '', 2, [ [ undef, 2 ] ] # +strict +store $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[0]]->[$N[3]] = 2 # '', 2, [ [ undef, 1, undef, 2 ] ] # +strict +store $x->[$N[0]]->[$N[1]] = 1 # $x->[$N[2]]->[$N[3]] = 2 # qr/^Reference vivification forbidden/, undef, [ [ undef, 1 ] ] # +strict +store autovivification-0.18/t/31-array-fast.t000644 000765 000024 00000050054 12416743316 020573 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use lib 't/lib'; use Test::Leaner tests => 9 * 3 * 302; use autovivification::TestCases; while () { 1 while chomp; next unless /#/; testcase_ok($_, '@'); } __DATA__ --- fetch --- $x # $x->[0] # '', undef, [ ] $x # $x->[0] # '', undef, undef # $x # $x->[0] # '', undef, undef # +fetch $x # $x->[0] # '', undef, [ ] # +exists $x # $x->[0] # '', undef, [ ] # +delete $x # $x->[0] # '', undef, [ ] # +store $x # $x->[0] # '', undef, [ ] # -fetch $x # $x->[0] # '', undef, [ ] # +fetch -fetch $x # $x->[0] # '', undef, undef # -fetch +fetch $x # $x->[0] # '', undef, undef # +fetch -exists $x # $x->[0] # qr/^Reference vivification forbidden/, undef, undef # +strict +fetch $x # $x->[0] # '', undef, [ ] # +strict +exists $x # $x->[0] # '', undef, [ ] # +strict +delete $x # $x->[0] # '', undef, [ ] # +strict +store $x # $x->[0]->[1] # '', undef, [ [ ] ] $x # $x->[0]->[1] # '', undef, undef # $x # $x->[0]->[1] # '', undef, undef # +fetch $x # $x->[0]->[1] # '', undef, [ [ ] ] # +exists $x # $x->[0]->[1] # '', undef, [ [ ] ] # +delete $x # $x->[0]->[1] # '', undef, [ [ ] ] # +store $x # $x->[0]->[1] # qr/^Reference vivification forbidden/, undef, undef # +strict +fetch $x # $x->[0]->[1] # '', undef, [ [ ] ] # +strict +exists $x # $x->[0]->[1] # '', undef, [ [ ] ] # +strict +delete $x # $x->[0]->[1] # '', undef, [ [ ] ] # +strict +store $x->[0] = 1 # $x->[0] # '', 1, [ 1 ] # +fetch $x->[0] = 1 # $x->[1] # '', undef, [ 1 ] # +fetch $x->[0] = 1 # $x->[0] # '', 1, [ 1 ] # +exists $x->[0] = 1 # $x->[1] # '', undef, [ 1 ] # +exists $x->[0] = 1 # $x->[0] # '', 1, [ 1 ] # +delete $x->[0] = 1 # $x->[1] # '', undef, [ 1 ] # +delete $x->[0] = 1 # $x->[0] # '', 1, [ 1 ] # +store $x->[0] = 1 # $x->[1] # '', undef, [ 1 ] # +store $x->[0] = 1 # $x->[0] # '', 1, [ 1 ] # +strict +fetch $x->[0] = 1 # $x->[1] # '', undef, [ 1 ] # +strict +fetch $x->[0] = 1 # $x->[0] # '', 1, [ 1 ] # +strict +exists $x->[0] = 1 # $x->[1] # '', undef, [ 1 ] # +strict +exists $x->[0] = 1 # $x->[0] # '', 1, [ 1 ] # +strict +delete $x->[0] = 1 # $x->[1] # '', undef, [ 1 ] # +strict +delete $x->[0] = 1 # $x->[0] # '', 1, [ 1 ] # +strict +store $x->[0] = 1 # $x->[1] # '', undef, [ 1 ] # +strict +store $x->[0]->[1] = 1 # $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +fetch $x->[0]->[1] = 1 # $x->[0]->[3] # '', undef, [ [ undef, 1 ] ] # +fetch $x->[0]->[1] = 1 # $x->[2]->[3] # '', undef, [ [ undef, 1 ] ] # +fetch $x->[0]->[1] = 1 # $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +exists $x->[0]->[1] = 1 # $x->[0]->[3] # '', undef, [ [ undef, 1 ] ] # +exists $x->[0]->[1] = 1 # $x->[2]->[3] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +exists $x->[0]->[1] = 1 # $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +delete $x->[0]->[1] = 1 # $x->[0]->[3] # '', undef, [ [ undef, 1 ] ] # +delete $x->[0]->[1] = 1 # $x->[2]->[3] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +delete $x->[0]->[1] = 1 # $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +store $x->[0]->[1] = 1 # $x->[0]->[3] # '', undef, [ [ undef, 1 ] ] # +store $x->[0]->[1] = 1 # $x->[2]->[3] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +store $x->[0]->[1] = 1 # $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +strict +fetch $x->[0]->[1] = 1 # $x->[0]->[3] # '', undef, [ [ undef, 1 ] ] # +strict +fetch $x->[0]->[1] = 1 # $x->[2]->[3] # qr/^Reference vivification forbidden/, undef, [ [ undef, 1 ] ] # +strict +fetch $x->[0]->[1] = 1 # $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +strict +exists $x->[0]->[1] = 1 # $x->[0]->[3] # '', undef, [ [ undef, 1 ] ] # +strict +exists $x->[0]->[1] = 1 # $x->[2]->[3] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +strict +exists $x->[0]->[1] = 1 # $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +strict +delete $x->[0]->[1] = 1 # $x->[0]->[3] # '', undef, [ [ undef, 1 ] ] # +strict +delete $x->[0]->[1] = 1 # $x->[2]->[3] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +strict +delete $x->[0]->[1] = 1 # $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +strict +store $x->[0]->[1] = 1 # $x->[0]->[3] # '', undef, [ [ undef, 1 ] ] # +strict +store $x->[0]->[1] = 1 # $x->[2]->[3] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +strict +store --- aliasing --- $x # 1 for $x->[0]; () # '', undef, [ undef ] $x # 1 for $x->[0]; () # '', undef, [ undef ] # $x # 1 for $x->[0]; () # '', undef, [ undef ] # +fetch $x # 1 for $x->[0]; () # '', undef, [ undef ] # +exists $x # 1 for $x->[0]; () # '', undef, [ undef ] # +delete $x # 1 for $x->[0]; () # qr/^Can't vivify reference/, undef, undef # +store $x # $_ = 1 for $x->[0]; () # '', undef, [ 1 ] $x # $_ = 1 for $x->[0]; () # '', undef, [ 1 ] # $x # $_ = 1 for $x->[0]; () # '', undef, [ 1 ] # +fetch $x # $_ = 1 for $x->[0]; () # '', undef, [ 1 ] # +exists $x # $_ = 1 for $x->[0]; () # '', undef, [ 1 ] # +delete $x # $_ = 1 for $x->[0]; () # qr/^Can't vivify reference/, undef, undef # +store $x->[0] = 1 # 1 for $x->[0]; () # '', undef, [ 1 ] # +fetch $x->[0] = 1 # 1 for $x->[1]; () # '', undef, [ 1, undef ] # +fetch $x->[0] = 1 # 1 for $x->[0]; () # '', undef, [ 1 ] # +exists $x->[0] = 1 # 1 for $x->[1]; () # '', undef, [ 1, undef ] # +exists $x->[0] = 1 # 1 for $x->[0]; () # '', undef, [ 1 ] # +delete $x->[0] = 1 # 1 for $x->[1]; () # '', undef, [ 1, undef ] # +delete $x->[0] = 1 # 1 for $x->[0]; () # '', undef, [ 1 ] # +store $x->[0] = 1 # 1 for $x->[1]; () # '', undef, [ 1, undef ] # +store $x # do_nothing($x->[0]); () # '', undef, [ ] $x # do_nothing($x->[0]); () # '', undef, [ ] # $x # do_nothing($x->[0]); () # '', undef, [ ] # +fetch $x # do_nothing($x->[0]); () # '', undef, [ ] # +exists $x # do_nothing($x->[0]); () # '', undef, [ ] # +delete $x # do_nothing($x->[0]); () # qr/^Can't vivify reference/, undef, undef # +store $x # set_arg($x->[0]); () # '', undef, [ 1 ] $x # set_arg($x->[0]); () # '', undef, [ 1 ] # $x # set_arg($x->[0]); () # '', undef, [ 1 ] # +fetch $x # set_arg($x->[0]); () # '', undef, [ 1 ] # +exists $x # set_arg($x->[0]); () # '', undef, [ 1 ] # +delete $x # set_arg($x->[0]); () # qr/^Can't vivify reference/, undef, undef # +store --- dereferencing --- $x # no warnings 'uninitialized'; my @a = @$x; () # ($strict ? qr/^Can't use an undefined value as an ARRAY reference/ : ''), undef, undef $x # no warnings 'uninitialized'; my @a = @$x; () # ($strict ? qr/^Can't use an undefined value as an ARRAY reference/ : ''), undef, undef # $x # no warnings 'uninitialized'; my @a = @$x; () # ($strict ? qr/^Can't use an undefined value as an ARRAY reference/ : ''), undef, undef # +fetch $x # no warnings 'uninitialized'; my @a = @$x; () # ($strict ? qr/^Can't use an undefined value as an ARRAY reference/ : ''), undef, undef # +exists $x # no warnings 'uninitialized'; my @a = @$x; () # ($strict ? qr/^Can't use an undefined value as an ARRAY reference/ : ''), undef, undef # +delete $x # no warnings 'uninitialized'; my @a = @$x; () # ($strict ? qr/^Can't use an undefined value as an ARRAY reference/ : ''), undef, undef # +store $x->[0] = 1 # my @a = @$x; () # '', undef, [ 1 ] # +fetch $x->[0] = 1 # my @a = @$x; () # '', undef, [ 1 ] # +exists $x->[0] = 1 # my @a = @$x; () # '', undef, [ 1 ] # +delete $x->[0] = 1 # my @a = @$x; () # '', undef, [ 1 ] # +store --- slice --- $x # my @a = @$x[0, 1]; \@a # '', [ undef, undef ], [ ] $x # my @a = @$x[0, 1]; \@a # '', [ undef, undef ], undef # $x # my @a = @$x[0, 1]; \@a # '', [ undef, undef ], undef # +fetch $x # my @a = @$x[0, 1]; \@a # '', [ undef, undef ], [ ] # +exists $x # my @a = @$x[0, 1]; \@a # '', [ undef, undef ], [ ] # +delete $x # my @a = @$x[0, 1]; \@a # '', [ undef, undef ], [ ] # +store $x->[1] = 0 # my @a = @$x[0, 1]; \@a # '', [ undef, 0 ], [ undef, 0 ] # +fetch $x # @$x[0, 1] = (1, 2); () # '', undef, [ 1, 2 ] $x # @$x[0, 1] = (1, 2); () # '', undef, [ 1, 2 ] # $x # @$x[0, 1] = (1, 2); () # '', undef, [ 1, 2 ] # +fetch $x # @$x[0, 1] = (1, 2); () # '', undef, [ 1, 2 ] # +exists $x # @$x[0, 1] = (1, 2); () # '', undef, [ 1, 2 ] # +delete $x # @$x[0, 1] = (1, 2); () # qr/^Can't vivify reference/, undef, undef # +store $x->[0] = 0 # @$x[0, 1] = (1, 2); () # '', undef, [ 1, 2 ] # +store $x->[2] = 0 # @$x[0, 1] = (1, 2); () # '', undef, [ 1, 2, 0 ] # +store $x->[0] = 0, $x->[1] = 0 # @$x[0, 1] = (1, 2); () # '', undef, [ 1, 2 ] # +store --- exists --- $x # exists $x->[0] # '', '', [ ] $x # exists $x->[0] # '', '', undef # $x # exists $x->[0] # '', '', [ ] # +fetch $x # exists $x->[0] # '', '', undef # +exists $x # exists $x->[0] # '', '', [ ] # +delete $x # exists $x->[0] # '', '', [ ] # +store $x # exists $x->[0] # '', '', [ ] # +strict +fetch $x # exists $x->[0] # qr/^Reference vivification forbidden/, undef, undef # +strict +exists $x # exists $x->[0] # '', '', [ ] # +strict +delete $x # exists $x->[0] # '', '', [ ] # +strict +store $x # exists $x->[0]->[1] # '', '', [ [ ] ] $x # exists $x->[0]->[1] # '', '', undef # $x # exists $x->[0]->[1] # '', '', [ [ ] ] # +fetch $x # exists $x->[0]->[1] # '', '', undef # +exists $x # exists $x->[0]->[1] # '', '', [ [ ] ] # +delete $x # exists $x->[0]->[1] # '', '', [ [ ] ] # +store $x # exists $x->[0]->[1] # '', '', [ [ ] ] # +strict +fetch $x # exists $x->[0]->[1] # qr/^Reference vivification forbidden/, undef, undef # +strict +exists $x # exists $x->[0]->[1] # '', '', [ [ ] ] # +strict +delete $x # exists $x->[0]->[1] # '', '', [ [ ] ] # +strict +store $x->[0] = 1 # exists $x->[0] # '', 1, [ 1 ] # +fetch $x->[0] = 1 # exists $x->[1] # '', '', [ 1 ] # +fetch $x->[0] = 1 # exists $x->[0] # '', 1, [ 1 ] # +exists $x->[0] = 1 # exists $x->[1] # '', '', [ 1 ] # +exists $x->[0] = 1 # exists $x->[0] # '', 1, [ 1 ] # +delete $x->[0] = 1 # exists $x->[1] # '', '', [ 1 ] # +delete $x->[0] = 1 # exists $x->[0] # '', 1, [ 1 ] # +store $x->[0] = 1 # exists $x->[1] # '', '', [ 1 ] # +store $x->[0] = 1 # exists $x->[0] # '', 1, [ 1 ] # +strict +fetch $x->[0] = 1 # exists $x->[1] # '', '', [ 1 ] # +strict +fetch $x->[0] = 1 # exists $x->[0] # '', 1, [ 1 ] # +strict +exists $x->[0] = 1 # exists $x->[1] # '', '', [ 1 ] # +strict +exists $x->[0] = 1 # exists $x->[0] # '', 1, [ 1 ] # +strict +delete $x->[0] = 1 # exists $x->[1] # '', '', [ 1 ] # +strict +delete $x->[0] = 1 # exists $x->[0] # '', 1, [ 1 ] # +strict +store $x->[0] = 1 # exists $x->[1] # '', '', [ 1 ] # +strict +store $x->[0]->[1] = 1 # exists $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +fetch $x->[0]->[1] = 1 # exists $x->[0]->[3] # '', '', [ [ undef, 1 ] ] # +fetch $x->[0]->[1] = 1 # exists $x->[2]->[3] # '', '', [ [ undef, 1 ], undef, [ ] ] # +fetch $x->[0]->[1] = 1 # exists $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +exists $x->[0]->[1] = 1 # exists $x->[0]->[3] # '', '', [ [ undef, 1 ] ] # +exists $x->[0]->[1] = 1 # exists $x->[2]->[3] # '', '', [ [ undef, 1 ] ] # +exists $x->[0]->[1] = 1 # exists $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +delete $x->[0]->[1] = 1 # exists $x->[0]->[3] # '', '', [ [ undef, 1 ] ] # +delete $x->[0]->[1] = 1 # exists $x->[2]->[3] # '', '', [ [ undef, 1 ], undef, [ ] ] # +delete $x->[0]->[1] = 1 # exists $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +store $x->[0]->[1] = 1 # exists $x->[0]->[3] # '', '', [ [ undef, 1 ] ] # +store $x->[0]->[1] = 1 # exists $x->[2]->[3] # '', '', [ [ undef, 1 ], undef, [ ] ] # +store $x->[0]->[1] = 1 # exists $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +strict +fetch $x->[0]->[1] = 1 # exists $x->[0]->[3] # '', '', [ [ undef, 1 ] ] # +strict +fetch $x->[0]->[1] = 1 # exists $x->[2]->[3] # '', '', [ [ undef, 1 ], undef, [ ] ] # +strict +fetch $x->[0]->[1] = 1 # exists $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +strict +exists $x->[0]->[1] = 1 # exists $x->[0]->[3] # '', '', [ [ undef, 1 ] ] # +strict +exists $x->[0]->[1] = 1 # exists $x->[2]->[3] # qr/^Reference vivification forbidden/, undef, [ [ undef, 1 ] ] # +strict +exists $x->[0]->[1] = 1 # exists $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +strict +delete $x->[0]->[1] = 1 # exists $x->[0]->[3] # '', '', [ [ undef, 1 ] ] # +strict +delete $x->[0]->[1] = 1 # exists $x->[2]->[3] # '', '', [ [ undef, 1 ], undef, [ ] ] # +strict +delete $x->[0]->[1] = 1 # exists $x->[0]->[1] # '', 1, [ [ undef, 1 ] ] # +strict +store $x->[0]->[1] = 1 # exists $x->[0]->[3] # '', '', [ [ undef, 1 ] ] # +strict +store $x->[0]->[1] = 1 # exists $x->[2]->[3] # '', '', [ [ undef, 1 ], undef, [ ] ] # +strict +store --- delete --- $x # delete $x->[0] # '', undef, [ ] $x # delete $x->[0] # '', undef, undef # $x # delete $x->[0] # '', undef, [ ] # +fetch $x # delete $x->[0] # '', undef, [ ] # +exists $x # delete $x->[0] # '', undef, undef # +delete $x # delete $x->[0] # '', undef, [ ] # +store $x # delete $x->[0] # '', undef, [ ] # +strict +fetch $x # delete $x->[0] # '', undef, [ ] # +strict +exists $x # delete $x->[0] # qr/^Reference vivification forbidden/, undef, undef # +strict +delete $x # delete $x->[0] # '', undef, [ ] # +strict +store $x # delete $x->[0]->[1] # '', undef, [ [ ] ] $x # delete $x->[0]->[1] # '', undef, undef # $x # delete $x->[0]->[1] # '', undef, [ [ ] ] # +fetch $x # delete $x->[0]->[1] # '', undef, [ [ ] ] # +exists $x # delete $x->[0]->[1] # '', undef, undef # +delete $x # delete $x->[0]->[1] # '', undef, [ [ ] ] # +store $x # delete $x->[0]->[1] # '', undef, [ [ ] ] # +strict +fetch $x # delete $x->[0]->[1] # '', undef, [ [ ] ] # +strict +exists $x # delete $x->[0]->[1] # qr/^Reference vivification forbidden/, undef, undef # +strict +delete $x # delete $x->[0]->[1] # '', undef, [ [ ] ] # +strict +store $x->[0] = 1 # delete $x->[0] # '', 1, [ ] # +fetch $x->[0] = 1 # delete $x->[1] # '', undef, [ 1 ] # +fetch $x->[0] = 1 # delete $x->[0] # '', 1, [ ] # +exists $x->[0] = 1 # delete $x->[1] # '', undef, [ 1 ] # +exists $x->[0] = 1 # delete $x->[0] # '', 1, [ ] # +delete $x->[0] = 1 # delete $x->[1] # '', undef, [ 1 ] # +delete $x->[0] = 1 # delete $x->[0] # '', 1, [ ] # +store $x->[0] = 1 # delete $x->[1] # '', undef, [ 1 ] # +store $x->[0] = 1 # delete $x->[0] # '', 1, [ ] # +strict +fetch $x->[0] = 1 # delete $x->[1] # '', undef, [ 1 ] # +strict +fetch $x->[0] = 1 # delete $x->[0] # '', 1, [ ] # +strict +exists $x->[0] = 1 # delete $x->[1] # '', undef, [ 1 ] # +strict +exists $x->[0] = 1 # delete $x->[0] # '', 1, [ ] # +strict +delete $x->[0] = 1 # delete $x->[1] # '', undef, [ 1 ] # +strict +delete $x->[0] = 1 # delete $x->[0] # '', 1, [ ] # +strict +store $x->[0] = 1 # delete $x->[1] # '', undef, [ 1 ] # +strict +store $x->[0]->[1] = 1 # delete $x->[0]->[1] # '', 1, [ [ ] ] # +fetch $x->[0]->[1] = 1 # delete $x->[0]->[3] # '', undef, [ [ undef, 1 ] ]# +fetch $x->[0]->[1] = 1 # delete $x->[2]->[3] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +fetch $x->[0]->[1] = 1 # delete $x->[0]->[1] # '', 1, [ [ ] ] # +exists $x->[0]->[1] = 1 # delete $x->[0]->[3] # '', undef, [ [ undef, 1 ] ]# +exists $x->[0]->[1] = 1 # delete $x->[2]->[3] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +exists $x->[0]->[1] = 1 # delete $x->[0]->[1] # '', 1, [ [ ] ] # +delete $x->[0]->[1] = 1 # delete $x->[0]->[3] # '', undef, [ [ undef, 1 ] ]# +delete $x->[0]->[1] = 1 # delete $x->[2]->[3] # '', undef, [ [ undef, 1 ] ]# +delete $x->[0]->[1] = 1 # delete $x->[0]->[1] # '', 1, [ [ ] ] # +store $x->[0]->[1] = 1 # delete $x->[0]->[3] # '', undef, [ [ undef, 1 ] ]# +store $x->[0]->[1] = 1 # delete $x->[2]->[3] # '', undef, [ [ undef, 1 ], undef, [ ] ] # +store $x->[0]->[1] = 1 # delete $x->[0]->[1] # '', 1, [ [ ] ] # +strict +fetch $x->[0]->[1] = 1 # delete $x->[0]->[3] # '', undef, [ [ undef, 1 ] ] # +strict +fetch $x->[0]->[1] = 1 # delete $x->[2]->[3] # '', undef, [ [ undef, 1 ], undef, [ ] ]# +strict +fetch $x->[0]->[1] = 1 # delete $x->[0]->[1] # '', 1, [ [ ] ] # +strict +exists $x->[0]->[1] = 1 # delete $x->[0]->[3] # '', undef, [ [ undef, 1 ] ] # +strict +exists $x->[0]->[1] = 1 # delete $x->[2]->[3] # '', undef, [ [ undef, 1 ], undef, [ ] ]# +strict +exists $x->[0]->[1] = 1 # delete $x->[0]->[1] # '', 1, [ [ ] ] # +strict +delete $x->[0]->[1] = 1 # delete $x->[0]->[3] # '', undef, [ [ undef, 1 ] ] # +strict +delete $x->[0]->[1] = 1 # delete $x->[2]->[3] # qr/^Reference vivification forbidden/, undef, [ [ undef, 1 ] ] # +strict +delete $x->[0]->[1] = 1 # delete $x->[0]->[1] # '', 1, [ [ ] ] # +strict +store $x->[0]->[1] = 1 # delete $x->[0]->[3] # '', undef, [ [ undef, 1 ] ] # +strict +store $x->[0]->[1] = 1 # delete $x->[2]->[3] # '', undef, [ [ undef, 1 ], undef, [ ] ]# +strict +store --- store --- $x # $x->[0] = 1 # '', 1, [ 1 ] $x # $x->[0] = 1 # '', 1, [ 1 ] # $x # $x->[0] = 1 # '', 1, [ 1 ] # +fetch $x # $x->[0] = 1 # '', 1, [ 1 ] # +exists $x # $x->[0] = 1 # '', 1, [ 1 ] # +delete $x # $x->[0] = 1 # qr/^Can't vivify reference/, undef, undef # +store $x # $x->[0] = 1 # '', 1, [ 1 ] # +strict +fetch $x # $x->[0] = 1 # '', 1, [ 1 ] # +strict +exists $x # $x->[0] = 1 # '', 1, [ 1 ] # +strict +delete $x # $x->[0] = 1 # qr/^Reference vivification forbidden/, undef, undef # +strict +store $x # $x->[0]->[1] = 1 # '', 1, [ [ undef, 1 ] ] $x # $x->[0]->[1] = 1 # '', 1, [ [ undef, 1 ] ] # $x # $x->[0]->[1] = 1 # '', 1, [ [ undef, 1 ] ] # +fetch $x # $x->[0]->[1] = 1 # '', 1, [ [ undef, 1 ] ] # +exists $x # $x->[0]->[1] = 1 # '', 1, [ [ undef, 1 ] ] # +delete $x # $x->[0]->[1] = 1 # qr/^Can't vivify reference/, undef, undef # +store $x # $x->[0]->[1] = 1 # '', 1, [ [ undef, 1 ] ] # +strict +fetch $x # $x->[0]->[1] = 1 # '', 1, [ [ undef, 1 ] ] # +strict +exists $x # $x->[0]->[1] = 1 # '', 1, [ [ undef, 1 ] ] # +strict +delete $x # $x->[0]->[1] = 1 # qr/^Reference vivification forbidden/, undef, undef # +strict +store $x->[0] = 1 # $x->[0] = 2 # '', 2, [ 2 ] # +fetch $x->[0] = 1 # $x->[1] = 2 # '', 2, [ 1, 2 ] # +fetch $x->[0] = 1 # $x->[0] = 2 # '', 2, [ 2 ] # +exists $x->[0] = 1 # $x->[1] = 2 # '', 2, [ 1, 2 ] # +exists $x->[0] = 1 # $x->[0] = 2 # '', 2, [ 2 ] # +delete $x->[0] = 1 # $x->[1] = 2 # '', 2, [ 1, 2 ] # +delete $x->[0] = 1 # $x->[0] = 2 # '', 2, [ 2 ] # +store $x->[0] = 1 # $x->[1] = 2 # '', 2, [ 1, 2 ] # +store $x->[0] = 1 # $x->[0] = 2 # '', 2, [ 2 ] # +strict +fetch $x->[0] = 1 # $x->[1] = 2 # '', 2, [ 1, 2 ] # +strict +fetch $x->[0] = 1 # $x->[0] = 2 # '', 2, [ 2 ] # +strict +exists $x->[0] = 1 # $x->[1] = 2 # '', 2, [ 1, 2 ] # +strict +exists $x->[0] = 1 # $x->[0] = 2 # '', 2, [ 2 ] # +strict +delete $x->[0] = 1 # $x->[1] = 2 # '', 2, [ 1, 2 ] # +strict +delete $x->[0] = 1 # $x->[0] = 2 # '', 2, [ 2 ] # +strict +store $x->[0] = 1 # $x->[1] = 2 # '', 2, [ 1, 2 ] # +strict +store $x->[0]->[1] = 1 # $x->[0]->[1] = 2 # '', 2, [ [ undef, 2 ] ] # +fetch $x->[0]->[1] = 1 # $x->[0]->[3] = 2 # '', 2, [ [ undef, 1, undef, 2 ] ] # +fetch $x->[0]->[1] = 1 # $x->[2]->[3] = 2 # '', 2, [ [ undef, 1 ], undef, [ undef, undef, undef, 2 ] ] # +fetch $x->[0]->[1] = 1 # $x->[0]->[1] = 2 # '', 2, [ [ undef, 2 ] ] # +exists $x->[0]->[1] = 1 # $x->[0]->[3] = 2 # '', 2, [ [ undef, 1, undef, 2 ] ] # +exists $x->[0]->[1] = 1 # $x->[2]->[3] = 2 # '', 2, [ [ undef, 1 ], undef, [ undef, undef, undef, 2 ] ] # +exists $x->[0]->[1] = 1 # $x->[0]->[1] = 2 # '', 2, [ [ undef, 2 ] ] # +delete $x->[0]->[1] = 1 # $x->[0]->[3] = 2 # '', 2, [ [ undef, 1, undef, 2 ] ] # +delete $x->[0]->[1] = 1 # $x->[2]->[3] = 2 # '', 2, [ [ undef, 1 ], undef, [ undef, undef, undef, 2 ] ] # +delete $x->[0]->[1] = 1 # $x->[0]->[1] = 2 # '', 2, [ [ undef, 2 ] ] # +store $x->[0]->[1] = 1 # $x->[0]->[3] = 2 # '', 2, [ [ undef, 1, undef, 2 ] ] # +store $x->[0]->[1] = 1 # $x->[2]->[3] = 2 # qr/^Can't vivify reference/, undef, [ [ undef, 1 ] ] # +store $x->[0]->[1] = 1 # $x->[0]->[1] = 2 # '', 2, [ [ undef, 2 ] ] # +strict +fetch $x->[0]->[1] = 1 # $x->[0]->[3] = 2 # '', 2, [ [ undef, 1, undef, 2 ] ] # +strict +fetch $x->[0]->[1] = 1 # $x->[2]->[3] = 2 # '', 2, [ [ undef, 1 ], undef, [ undef, undef, undef, 2 ] ] # +strict +fetch $x->[0]->[1] = 1 # $x->[0]->[1] = 2 # '', 2, [ [ undef, 2 ] ] # +strict +exists $x->[0]->[1] = 1 # $x->[0]->[3] = 2 # '', 2, [ [ undef, 1, undef, 2 ] ] # +strict +exists $x->[0]->[1] = 1 # $x->[2]->[3] = 2 # '', 2, [ [ undef, 1 ], undef, [ undef, undef, undef, 2 ] ] # +strict +exists $x->[0]->[1] = 1 # $x->[0]->[1] = 2 # '', 2, [ [ undef, 2 ] ] # +strict +delete $x->[0]->[1] = 1 # $x->[0]->[3] = 2 # '', 2, [ [ undef, 1, undef, 2 ] ] # +strict +delete $x->[0]->[1] = 1 # $x->[2]->[3] = 2 # '', 2, [ [ undef, 1 ], undef, [ undef, undef, undef, 2 ] ] # +strict +delete $x->[0]->[1] = 1 # $x->[0]->[1] = 2 # '', 2, [ [ undef, 2 ] ] # +strict +store $x->[0]->[1] = 1 # $x->[0]->[3] = 2 # '', 2, [ [ undef, 1, undef, 2 ] ] # +strict +store $x->[0]->[1] = 1 # $x->[2]->[3] = 2 # qr/^Reference vivification forbidden/, undef, [ [ undef, 1 ] ] # +strict +store autovivification-0.18/t/32-array-kv.t000644 000765 000024 00000006700 12416743316 020256 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use lib 't/lib'; use Test::Leaner; BEGIN { if ("$]" >= 5.011) { plan tests => 9 * 3 * 64 } else { plan skip_all => 'perl 5.11 required for keys/values @array' } } use autovivification::TestCases; while () { 1 while chomp; next unless /#/; testcase_ok($_, '@'); } __DATA__ --- keys --- $x # keys @$x # '', 0, [ ] $x # keys @$x # '', 0, undef # $x # keys @$x # '', 0, undef # +fetch $x # keys @$x # '', 0, [ ] # +exists $x # keys @$x # '', 0, [ ] # +delete $x # keys @$x # '', 0, [ ] # +store $x # keys @$x # qr/^Reference vivification forbidden/, undef, undef # +strict +fetch $x # keys @$x # '', 0, [ ] # +strict +exists $x # keys @$x # '', 0, [ ] # +strict +delete $x # keys @$x # '', 0, [ ] # +strict +store $x # [ keys @$x ] # '', [ ], [ ] $x # [ keys @$x ] # '', [ ], undef # $x # [ keys @$x ] # '', [ ], undef # +fetch $x # [ keys @$x ] # '', [ ], [ ] # +exists +delete +store $x->[0] = 1 # [ keys @$x ] # '', [0], [ 1 ] $x->[0] = 1 # [ keys @$x ] # '', [0], [ 1 ] # $x->[0] = 1 # [ keys @$x ] # '', [0], [ 1 ] # +fetch $x->[0] = 1 # [ keys @$x ] # '', [0], [ 1 ] # +exists +delete +store $x # keys @{$x->[0]} # '', 0, [ [ ] ] $x # keys @{$x->[0]} # '', 0, undef # $x # keys @{$x->[0]} # '', 0, undef # +fetch $x # keys @{$x->[0]} # '', 0, [ [ ] ] # +exists $x # keys @{$x->[0]} # '', 0, [ [ ] ] # +delete $x # keys @{$x->[0]} # '', 0, [ [ ] ] # +store $x # keys @{$x->[0]} # qr/^Reference vivification forbidden/, undef, undef # +strict +fetch $x # keys @{$x->[0]} # '', 0, [ [ ] ] # +strict +exists $x # keys @{$x->[0]} # '', 0, [ [ ] ] # +strict +delete $x # keys @{$x->[0]} # '', 0, [ [ ] ] # +strict +store $x # [ keys @{$x->[0]} ] # '', [ ], [ [ ] ] $x # [ keys @{$x->[0]} ] # '', [ ], undef # $x # [ keys @{$x->[0]} ] # '', [ ], undef # +fetch $x # [ keys @{$x->[0]} ] # '', [ ], [ [ ] ] # +exists +delete +store --- values --- $x # values @$x # '', 0, [ ] $x # values @$x # '', 0, undef # $x # values @$x # '', 0, undef # +fetch $x # values @$x # '', 0, [ ] # +exists $x # values @$x # '', 0, [ ] # +delete $x # values @$x # '', 0, [ ] # +store $x # values @$x # qr/^Reference vivification forbidden/, undef, undef # +strict +fetch $x # values @$x # '', 0, [ ] # +strict +exists $x # values @$x # '', 0, [ ] # +strict +delete $x # values @$x # '', 0, [ ] # +strict +store $x # [ values @$x ] # '', [ ], [ ] $x # [ values @$x ] # '', [ ], undef # $x # [ values @$x ] # '', [ ], undef # +fetch $x # [ values @$x ] # '', [ ], [ ] # +exists +delete +store $x->[0] = 1 # [ values @$x ] # '', [ 1 ], [ 1 ] $x->[0] = 1 # [ values @$x ] # '', [ 1 ], [ 1 ] # $x->[0] = 1 # [ values @$x ] # '', [ 1 ], [ 1 ] # +fetch $x->[0] = 1 # [ values @$x ] # '', [ 1 ], [ 1 ] # +exists +delete +store $x # values @{$x->[0]} # '', 0, [ [ ] ] $x # values @{$x->[0]} # '', 0, undef # $x # values @{$x->[0]} # '', 0, undef # +fetch $x # values @{$x->[0]} # '', 0, [ [ ] ] # +exists $x # values @{$x->[0]} # '', 0, [ [ ] ] # +delete $x # values @{$x->[0]} # '', 0, [ [ ] ] # +store $x # values @{$x->[0]} # qr/^Reference vivification forbidden/, undef, undef # +strict +fetch $x # values @{$x->[0]} # '', 0, [ [ ] ] # +strict +exists $x # values @{$x->[0]} # '', 0, [ [ ] ] # +strict +delete $x # values @{$x->[0]} # '', 0, [ [ ] ] # +strict +store $x # [ values @{$x->[0]} ] # '', [ ], [ [ ] ] $x # [ values @{$x->[0]} ] # '', [ ], undef # $x # [ values @{$x->[0]} ] # '', [ ], undef # +fetch $x # [ values @{$x->[0]} ] # '', [ ], [ [ ] ] # +exists +delete +store autovivification-0.18/t/33-array-tied.t000644 000765 000024 00000000737 12416743316 020570 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More; BEGIN { eval 'use Tie::Array; scalar keys %Tie::StdArray::' or plan skip_all => 'Tie::StdArray required to test tied arrays'; defined and diag "Using Tie::StdArray $_" for $Tie::Array::VERSION; plan tests => 1; } { tie my @a, 'Tie::StdArray'; tie my @b, 'Tie::StdArray'; $a[1] = 'hlagh'; $b[0] = \@a; my $res = do { no autovivification; $b[0][1]; }; is $res, 'hlagh', 'nested tied arrays'; } autovivification-0.18/t/34-array-numerous.t000644 000765 000024 00000005134 12416743316 021515 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use Test::More tests => 2 * 2 * 4; my $n = 100; my $i = 0; { my $w; { my $r; no autovivification; $r = $w->[0][$i] for 1 .. $n; } is_deeply $w, undef, 'numerous fetches from an undef lexical'; $w = [ undef ]; { my $r; no autovivification; $r = $w->[0][$i] for 1 .. $n; } is_deeply $w, [ undef ], 'numerous fetches from a 1-level arrayref lexical'; } { our $w; { my $r; no autovivification; $r = $w->[0][$i] for 1 .. $n; } is_deeply $w, undef, 'numerous fetches from an undef global'; $w = [ undef ]; { my $r; no autovivification; $r = $w->[0][$i] for 1 .. $n; } is_deeply $w, [ undef ], 'numerous fetches from a 1-level arrayref global'; } { my $x; { my @r; no autovivification; @r = @{$x}[0, 1] for 1 .. $n; } is_deeply $x, undef, 'numerous slices from an undef lexical'; $x = [ undef ]; { my @r; no autovivification; @r = @{$x->[0]}[0, 1] for 1 .. $n; } is_deeply $x, [ undef ], 'numerous slices from a 1-level arrayref lexical'; } { our $x; { my @r; no autovivification; @r = @{$x}[0, 1] for 1 .. $n; } is_deeply $x, undef, 'numerous slices from an undef global'; $x = [ undef ]; { my @r; no autovivification; @r = @{$x->[0]}[0, 1] for 1 .. $n; } is_deeply $x, [ undef ], 'numerous slices from a 1-level arrayref global'; } { my $y; { my $r; no autovivification; $r = exists $y->[0][$i] for 1 .. $n; } is_deeply $y, undef, 'numerous exists from an undef lexical'; $y = [ undef ]; { my $r; no autovivification; $r = exists $y->[0][$i] for 1 .. $n; } is_deeply $y, [ undef ], 'numerous exists from a 1-level arrayref lexical'; } { our $y; { my $r; no autovivification; $r = exists $y->[0][$i] for 1 .. $n; } is_deeply $y, undef, 'numerous exists from an undef global'; $y = [ undef ]; { my $r; no autovivification; $r = exists $y->[0][$i] for 1 .. $n; } is_deeply $y, [ undef ], 'numerous exists from a 1-level arrayref global'; } { my $z; { my $r; no autovivification; $r = delete $z->[0][$i] for 1 .. $n; } is_deeply $z, undef, 'numerous deletes from an undef lexical'; $z = [ undef ]; { my $r; no autovivification; $r = delete $z->[0][$i] for 1 .. $n; } is_deeply $z, [ undef ], 'numerous deletes from a 1-level arrayref lexical'; } { our $z; { my $r; no autovivification; $r = delete $z->[0][$i] for 1 .. $n; } is_deeply $z, undef, 'numerous deletes from an undef global'; $z = [ undef ]; { my $r; no autovivification; $r = delete $z->[0][$i] for 1 .. $n; } is_deeply $z, [ undef ], 'numerous deletes from a 1-level arrayref global'; } autovivification-0.18/t/40-scope.t000644 000765 000024 00000003547 12416743316 017640 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use Test::More tests => 12; use lib 't/lib'; { my @w; my $x; my $res = eval { local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ }; no autovivification qw; $x->{a}; }; is @w, 1, 'warned only once'; like $w[0], qr/^warn:Reference was vivified at \Q$0\E line ${\(__LINE__-3)}/, 'warning looks correct'; is_deeply $x, undef, 'didn\'t vivified'; is $res, undef, 'returned undef'; } our $blurp; { local $blurp; eval 'no autovivification; use autovivification::TestRequired1; $blurp->{x}'; is $@, '', 'first require test doesn\'t croak prematurely'; is_deeply $blurp, { r1_main => { }, r1_eval => { } }, 'first require vivified correctly'; } { local $blurp; eval 'no autovivification; use autovivification::TestRequired2; $blurp->{a}'; is $@, '', 'second require test doesn\'t croak prematurely'; my $expect; $expect = { r1_main => { }, r1_eval => { } }; $expect->{r2_eval} = { } if "$]" < 5.009_005; is_deeply $blurp, $expect, 'second require test didn\'t vivify'; } # This test may not fail for the old version when ran in taint mode { my $err = eval <<' SNIP'; use autovivification::TestRequired4::a0; autovivification::TestRequired4::a0::error(); SNIP is $err, '', 'RT #50570'; } # This test must be in the topmost scope BEGIN { eval 'use autovivification::TestRequired5::a0' } my $err = autovivification::TestRequired5::a0::error(); is $err, '', 'identifying requires by their eval context pointer is not enough'; { local $blurp; no autovivification; use autovivification::TestRequired6; autovivification::TestRequired6::bar(); is_deeply $blurp, { }, 'vivified without eval'; $blurp = undef; autovivification::TestRequired6::baz(); is_deeply $blurp, { }, 'vivified with eval'; } autovivification-0.18/t/41-padsv.t000644 000765 000024 00000000666 12416743316 017644 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More tests => 4; my $buf = "abc\ndef\n"; open my $x, '<', \$buf; # Do this one first so that the check functions are set up for the second my $res = eval 'no autovivification; <$x>'; is $@, '', 'padsv 1: no error'; is $res, "abc\n", 'padsv 1: correct returned value'; $res = eval '<$x>'; is $@, '', 'padsv 2: no error'; is $res, "def\n", 'padsv 2: correct returned value'; autovivification-0.18/t/42-deparse.t000644 000765 000024 00000001040 12416743316 020136 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use Test::More; use lib 't/lib'; use VPIT::TestHelpers; load_or_skip_all('B::Deparse', undef, [ ]); plan tests => 2; my $bd = B::Deparse->new; { no autovivification qw; sub blech { my $key = $_[0]->{key} } } { my $undef; eval 'blech($undef)'; like $@, qr/Reference vivification forbidden/, 'Original blech() works'; } { my $code = $bd->coderef2text(\&blech); my $undef; eval "$code; blech(\$undef)"; like $@, qr/Reference vivification forbidden/, 'Deparsed blech() works'; } autovivification-0.18/t/43-peep.t000644 000765 000024 00000011244 12525135666 017460 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use Test::More; use lib 't/lib'; use VPIT::TestHelpers 'run_perl'; plan tests => 11 + 5 * 2 + 5 * 3; { my $desc = 'peephole optimization of conditionals'; my $x; local $@; my $code = eval <<' TESTCASE'; no autovivification; sub { if ($_[0]) { my $z = $x->{a}; return 1; } elsif ($_[1] || $_[2]) { my $z = $x->{b}; return 2; } elsif ($_[3] && $_[4]) { my $z = $x->{c}; return 3; } elsif ($_[5] ? $_[6] : 0) { my $z = $x->{d}; return 4; } else { my $z = $x->{e}; return 5; } return 0; } TESTCASE is $@, '', "$desc compiled fine"; my $ret = $code->(1); is_deeply $x, undef, "$desc : first branch did not autovivify"; is $ret, 1, "$desc : first branch returned 1"; $ret = $code->(0, 1); is_deeply $x, undef, "$desc : second branch did not autovivify"; is $ret, 2, "$desc : second branch returned 2"; $ret = $code->(0, 0, 0, 1, 1); is_deeply $x, undef, "$desc : third branch did not autovivify"; is $ret, 3, "$desc : third branch returned 3"; $ret = $code->(0, 0, 0, 0, 0, 1, 1); is_deeply $x, undef, "$desc : fourth branch did not autovivify"; is $ret, 4, "$desc : fourth branch returned 4"; $ret = $code->(); is_deeply $x, undef, "$desc : fifth branch did not autovivify"; is $ret, 5, "$desc : fifth branch returned 5"; } { my $desc = 'peephole optimization of C-style loops'; my $x; local $@; my $code = eval <<' TESTCASE'; no autovivification; sub { my $ret = 0; for ( my ($z, $i) = ($x->[100], 0) ; do { my $z = $x->[200]; $i < 4 } ; do { my $z = $x->[300]; ++$i } ) { my $z = $x->[$i]; $ret += $i; } return $ret; } TESTCASE is $@, '', "$desc compiled fine"; my $ret = $code->(); is_deeply $x, undef, "$desc did not autovivify"; is $ret, 6, "$desc returned 0+1+2+3"; } { my $desc = 'peephole optimization of range loops'; my $x; local $@; my $code = eval <<' TESTCASE'; no autovivification; sub { my $ret = 0; for ((do { my $z = $x->[100]; 0 }) .. (do { my $z = $x->[200]; 3 })) { my $z = $x->[$_]; $ret += $_; } return $ret; } TESTCASE is $@, '', "$desc compiled fine"; my $ret = $code->(); is_deeply $x, undef, "$desc did not autovivify"; is $ret, 6, "$desc returned 0+1+2+3"; } { my $base_desc = 'peephole optimization of infinite'; my %infinite_tests = ( "$base_desc for loops (RT #64435)" => <<' TESTCASE', no autovivification; my $ret = 0; for (;;) { ++$ret; exit $ret; } exit $ret; TESTCASE "$base_desc while loops" => <<' TESTCASE', no autovivification; my $ret = 0; while (1) { ++$ret; exit $ret; } exit $ret; TESTCASE "$base_desc postfix while (RT #99458)" => <<' TESTCASE', no autovivification; my $ret = 0; ++$ret && exit $ret while 1; exit $ret; TESTCASE "$base_desc until loops" => <<' TESTCASE', no autovivification; my $ret = 0; until (0) { ++$ret; exit $ret; } exit $ret; TESTCASE "$base_desc postfix until" => <<' TESTCASE', no autovivification; my $ret = 0; ++$ret && exit $ret until 0; exit $ret; TESTCASE ); for my $desc (keys %infinite_tests) { my $code = $infinite_tests{$desc}; my $ret = run_perl $code; SKIP: { skip RUN_PERL_FAILED() => 2 unless defined $ret; my $stat = $ret & 255; $ret >>= 8; is $stat, 0, "$desc testcase did not crash"; is $ret, 1, "$desc compiled fine"; } } } { my $desc = 'peephole optimization of map'; my $x; local $@; my $code = eval <<' TESTCASE'; no autovivification; sub { join ':', map { my $z = $x->[$_]; "x${_}y" } @_ } TESTCASE is $@, '', "$desc compiled fine"; my $ret = $code->(1, 2); is_deeply $x, undef, "$desc did not autovivify"; is $ret, 'x1y:x2y', "$desc returned the right value"; } { my $desc = 'peephole optimization of grep'; my $x; local $@; my $code = eval <<' TESTCASE'; no autovivification; sub { join ':', grep { my $z = $x->[$_]; $_ <= 3 } @_ } TESTCASE is $@, '', "$desc compiled fine"; my $ret = $code->(1 .. 5); is_deeply $x, undef, "$desc did not autovivify"; is $ret, '1:2:3', "$desc returned the right value"; } { my $desc = 'peephole optimization of substitutions'; my $x; local $@; my $code = eval <<' TESTCASE'; no autovivification; sub { my $str = $_[0]; $str =~ s{ ([0-9]) }{ my $z = $x->[$1]; 9 - $1; }xge; $str; } TESTCASE is $@, '', "$desc compiled fine"; my $ret = $code->('0123456789'); is_deeply $x, undef, "$desc did not autovivify"; is $ret, '9876543210', "$desc returned the right value"; } autovivification-0.18/t/44-multideref.t000644 000765 000024 00000005013 12525135666 020665 0ustar00vincentstaff000000 000000 #!perl -T use strict; use warnings; use lib 't/lib'; use Test::Leaner tests => 4 * 4 * (8 ** 3) * 2; my $depth = 3; my $magic_val = 123; my @prefixes = ( sub { $_[0] }, sub { "$_[0] = $magic_val" }, sub { "exists $_[0]" }, sub { "delete $_[0]" }, ); my (@vlex, %vlex, $vrlex); our (@vgbl, %vgbl, $vrgbl); my @heads = ( '$vlex', # lexical array/hash '$vgbl', # global array/hash '$vrlex->', # lexical array/hash reference '$vrgbl->', # global array/hash reference ); my $lex; our $gbl; my @derefs = ( '[0]', # array const (aelemfast) '[$lex]', # array lexical '[$gbl]', # array global '[$lex+1]', # array complex '{foo}', # hash const '{$lex}', # hash lexical '{$gbl}', # hash global '{"x$lex"}' # hash complex ); sub reset_vars { (@vlex, %vlex, $vrlex) = (); (@vgbl, %vgbl, $vrgbl) = (); $lex = 1; $gbl = 2; } { package autovivification::TestIterator; sub new { my $class = shift; my (@lists, @max); for my $arg (@_) { next unless defined $arg; my $type = ref $arg; my $list; if ($type eq 'ARRAY') { $list = $arg; } elsif ($type eq '') { $list = [ 1 .. $arg ]; } else { die "Invalid argument of type $type"; } my $max = @$list; die "Empty list" unless $max; push @lists, $list; push @max, $max; } my $len = @_; bless { len => $len, max => \@max, lists => \@lists, idx => [ (0) x $len ], }, $class; } sub next { my $self = shift; my ($len, $max, $idx) = @$self{qw}; my $i; ++$idx->[0]; for ($i = 0; $i < $len; ++$i) { if ($idx->[$i] == $max->[$i]) { $idx->[$i] = 0; ++$idx->[$i + 1] unless $i == $len - 1; } else { last; } } return $i < $len; } sub items { my $self = shift; my ($len, $lists, $idx) = @$self{qw}; return map $lists->[$_]->[$idx->[$_]], 0 .. ($len - 1); } } my $iterator = autovivification::TestIterator->new( \@prefixes, \@heads, (\@derefs) x $depth, ); do { my ($prefix, @elems) = $iterator->items; my $code = $prefix->(join '', @elems); my $exp = ($code =~ /^\s*exists/) ? !1 : (($code =~ /=\s*$magic_val/) ? $magic_val : undef); reset_vars(); my ($res, $err) = do { local $SIG{__WARN__} = sub { die @_ }; local $@; my $r = eval <<" CODE"; no autovivification; $code CODE ($r, $@) }; is $err, '', "$code: no exception"; is $res, $exp, "$code: value"; } while ($iterator->next); autovivification-0.18/t/50-threads.t000644 000765 000024 00000003076 12556714750 020164 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use lib 't/lib'; use VPIT::TestHelpers ( threads => [ 'autovivification' => 'autovivification::A_THREADSAFE()' ], ); use Test::Leaner; my $threads = 10; my $runs = 2; { no autovivification; sub try { my $tid = threads->tid(); for my $run (1 .. $runs) { { my $x; my $y = $x->{foo}; is $x, undef, "fetch does not autovivify at thread $tid run $run"; } { my $x; my $y = exists $x->{foo}; is $x, undef, "exists does not autovivify at thread $tid run $run"; } { my $x; my $y = delete $x->{foo}; is $x, undef, "delete does not autovivify at thread $tid run $run"; } SKIP: { skip 'Hints aren\'t propagated into eval STRING below perl 5.10' => 3 * 2 unless "$]" >= 5.010; { my $x; eval 'my $y = $x->{foo}'; is $@, '', "fetch in eval does not croak at thread $tid run $run"; is $x, undef, "fetch in eval does not autovivify at thread $tid run $run"; } { my $x; eval 'my $y = exists $x->{foo}'; is $@, '', "exists in eval does not croak at thread $tid run $run"; is $x, undef, "exists in eval does not autovivify at thread $tid run $run"; } { my $x; eval 'my $y = delete $x->{foo}'; is $@, '', "delete in eval does not croak at thread $tid run $run"; is $x, undef, "delete in eval does not autovivify at thread $tid run $run"; } } } } } my @threads = map spawn(\&try), 1 .. $threads; $_->join for @threads; pass 'done'; done_testing; autovivification-0.18/t/51-threads-teardown.t000644 000765 000024 00000002470 12525135666 022002 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use lib 't/lib'; use VPIT::TestHelpers ( threads => [ 'autovivification' => 'autovivification::A_THREADSAFE()' ], 'run_perl', ); use Test::Leaner tests => 2; SKIP: { skip 'Fails on 5.8.2 and lower' => 1 if "$]" <= 5.008_002; my $status = run_perl <<' RUN'; my $code = 1 + 2 + 4; use threads; $code -= threads->create(sub { eval q{no autovivification; my $x; my $y = $x->{foo}; $x}; return defined($x) ? 0 : 1; })->join; $code -= defined(eval q{my $x; my $y = $x->{foo}; $x}) ? 2 : 0; $code -= defined(eval q{no autovivification; my $x; my $y = $x->{foo}; $x}) ? 0 : 4; exit $code; RUN skip RUN_PERL_FAILED() => 1 unless defined $status; is $status, 0, 'loading the pragma in a thread and using it outside doesn\'t segfault'; } SKIP: { my $status = run_perl <<' RUN'; use threads; BEGIN { require autovivification; } sub X::DESTROY { eval 'no autovivification; my $x; my $y = $x->{foo}{bar}; use autovivification; my $z = $x->{a}{b}{c};'; exit 1 if $@; } threads->create(sub { my $x = bless { }, 'X'; $x->{self} = $x; return; })->join; exit $code; RUN skip RUN_PERL_FAILED() => 1 unless defined $status; is $status, 0, 'autovivification can be loaded in eval STRING during global destruction at the end of a thread'; } autovivification-0.18/t/lib/000755 000765 000024 00000000000 13177355077 016666 5ustar00vincentstaff000000 000000 autovivification-0.18/t/lib/autovivification/000755 000765 000024 00000000000 13177355077 022251 5ustar00vincentstaff000000 000000 autovivification-0.18/t/lib/Test/000755 000765 000024 00000000000 13177355077 017605 5ustar00vincentstaff000000 000000 autovivification-0.18/t/lib/VPIT/000755 000765 000024 00000000000 13177355077 017450 5ustar00vincentstaff000000 000000 autovivification-0.18/t/lib/VPIT/TestHelpers.pm000644 000765 000024 00000035652 13177347534 022262 0ustar00vincentstaff000000 000000 package VPIT::TestHelpers; use strict; use warnings; use Config (); =head1 NAME VPIT::TestHelpers =head1 SYNTAX use VPIT::TestHelpers ( feature1 => \@feature1_args, feature2 => \@feature2_args, ); =cut sub export_to_pkg { my ($subs, $pkg) = @_; while (my ($name, $code) = each %$subs) { no strict 'refs'; *{$pkg.'::'.$name} = $code; } return 1; } sub sanitize_prefix { my $prefix = shift; if (defined $prefix) { if (length $prefix and $prefix !~ /_$/) { $prefix .= '_'; } } else { $prefix = ''; } return $prefix; } my %default_exports = ( load_or_skip => \&load_or_skip, load_or_skip_all => \&load_or_skip_all, skip_all => \&skip_all, ); my %features = ( threads => \&init_threads, usleep => \&init_usleep, run_perl => \&init_run_perl, capture => \&init_capture, ); sub import { shift; my @opts = @_; my %exports = %default_exports; for (my $i = 0; $i <= $#opts; ++$i) { my $feature = $opts[$i]; next unless defined $feature; my $args; if ($i < $#opts and defined $opts[$i+1] and ref $opts[$i+1] eq 'ARRAY') { ++$i; $args = $opts[$i]; } else { $args = [ ]; } my $handler = $features{$feature}; die "Unknown feature '$feature'" unless defined $handler; my %syms = $handler->(@$args); $exports{$_} = $syms{$_} for sort keys %syms; } export_to_pkg \%exports => scalar caller; } my $test_sub = sub { my $sub = shift; my $stash; if ($INC{'Test/Leaner.pm'}) { $stash = \%Test::Leaner::; } else { require Test::More; $stash = \%Test::More::; } my $glob = $stash->{$sub}; return ref \$glob eq 'GLOB' ? *$glob{CODE} : ref $glob eq 'CODE' ? $glob : undef; }; sub skip { $test_sub->('skip')->(@_) } sub skip_all { $test_sub->('plan')->(skip_all => $_[0]) } sub diag { my $diag = $test_sub->('diag'); $diag->($_) for @_; } our $TODO; local $TODO; sub load { my ($pkg, $ver, $imports) = @_; my $spec = $ver && $ver !~ /^[0._]*$/ ? "$pkg $ver" : $pkg; my $err; local $@; if (eval "use $spec (); 1") { $ver = do { no strict 'refs'; ${"${pkg}::VERSION"} }; $ver = 'undef' unless defined $ver; if ($imports) { my @imports = @$imports; my $caller = (caller 1)[0]; local $@; my $res = eval <<"IMPORTER"; package $caller; BEGIN { \$pkg->import(\@imports) } 1; IMPORTER $err = "Could not import '@imports' from $pkg $ver: $@" unless $res; } } else { (my $file = "$pkg.pm") =~ s{::}{/}g; delete $INC{$file}; $err = "Could not load $spec"; } if ($err) { return wantarray ? (0, $err) : 0; } else { diag "Using $pkg $ver"; return 1; } } sub load_or_skip { my ($pkg, $ver, $imports, $tests) = @_; die 'You must specify how many tests to skip' unless defined $tests; my ($loaded, $err) = load($pkg, $ver, $imports); skip $err => $tests unless $loaded; return $loaded; } sub load_or_skip_all { my ($pkg, $ver, $imports) = @_; my ($loaded, $err) = load($pkg, $ver, $imports); skip_all $err unless $loaded; return $loaded; } =head1 FEATURES =head2 C =over 4 =item * Import : use VPIT::TestHelpers run_perl => [ $p ] where : =over 8 =item - C<$p> is prefixed to the constants exported by this feature (defaults to C<''>). =back =item * Dependencies : =over 8 =item - L =back =item * Exports : =over 8 =item - C =item - C =item - C (possibly prefixed by C<$p>) =back =back =cut sub fresh_perl_env (&) { my $handler = shift; my ($SystemRoot, $PATH) = @ENV{qw}; my $ld_name = $Config::Config{ldlibpthname}; my $ldlibpth = $ENV{$ld_name}; local %ENV; $ENV{$ld_name} = $ldlibpth if defined $ldlibpth; $ENV{SystemRoot} = $SystemRoot if $^O eq 'MSWin32' and defined $SystemRoot; $ENV{PATH} = $PATH if $^O eq 'cygwin' and defined $PATH; my $perl = $^X; unless (-e $perl and -x $perl) { $perl = $Config::Config{perlpath}; unless (-e $perl and -x $perl) { return undef; } } return $handler->($perl, '-T', map("-I$_", @INC)); } sub init_run_perl { my $p = sanitize_prefix(shift); # This is only required for run_perl_file(), so it is not needed for the # threads feature which only calls run_perl() - don't forget to update its # requirements if this ever changes. require File::Spec; return ( run_perl => \&run_perl, run_perl_file => \&run_perl_file, "${p}RUN_PERL_FAILED" => sub () { 'Could not execute perl subprocess' }, ); } sub run_perl { my $code = shift; if ($code =~ /"/) { die 'Double quotes in evaluated code are not portable'; } fresh_perl_env { my ($perl, @perl_args) = @_; system { $perl } $perl, @perl_args, '-e', $code; }; } sub run_perl_file { my $file = shift; $file = File::Spec->rel2abs($file); unless (-e $file and -r _) { die 'Could not run perl file'; } fresh_perl_env { my ($perl, @perl_args) = @_; system { $perl } $perl, @perl_args, $file; }; } =head2 C =over 4 =item * Import : use VPIT::TestHelpers capture => [ $p ]; where : =over 8 =item - C<$p> is prefixed to the constants exported by this feature (defaults to C<''>). =back =item * Dependencies : =over 8 =item - Neither VMS nor OS/2 =item - L =item - L =item - L =item - On MSWin32 : L =back =item * Exports : =over 8 =item - C =item - C (possibly prefixed by C<$p>) =item - C =item - C (possibly prefixed by C<$p>) =back =back =cut sub init_capture { my $p = sanitize_prefix(shift); skip_all 'Cannot capture output on VMS' if $^O eq 'VMS'; skip_all 'Cannot capture output on OS/2' if $^O eq 'os2'; load_or_skip_all 'IO::Handle', '0', [ ]; load_or_skip_all 'IO::Select', '0', [ ]; load_or_skip_all 'IPC::Open3', '0', [ ]; if ($^O eq 'MSWin32') { load_or_skip_all 'Socket', '0', [ ]; } return ( capture => \&capture, "${p}CAPTURE_FAILED" => \&capture_failed_msg, capture_perl => \&capture_perl, "${p}CAPTURE_PERL_FAILED" => \&capture_perl_failed_msg, ); } # Inspired from IPC::Cmd sub capture { my @cmd = @_; my $want = wantarray; my $fail = sub { my $err = $!; my $ext_err = $^O eq 'MSWin32' ? $^E : undef; my $syscall = shift; my $args = join ', ', @_; my $msg = "$syscall($args) failed: "; if (defined $err) { no warnings 'numeric'; my ($err_code, $err_str) = (int $err, "$err"); $msg .= "$err_str ($err_code)"; } if (defined $ext_err) { no warnings 'numeric'; my ($ext_err_code, $ext_err_str) = (int $ext_err, "$ext_err"); $msg .= ", $ext_err_str ($ext_err_code)"; } die "$msg\n"; }; my ($status, $content_out, $content_err); local $@; my $ok = eval { my ($pid, $out, $err); if ($^O eq 'MSWin32') { my $pipe = sub { socketpair $_[0], $_[1], &Socket::AF_UNIX, &Socket::SOCK_STREAM, &Socket::PF_UNSPEC or $fail->(qw); shutdown $_[0], 1 or $fail->(qw); shutdown $_[1], 0 or $fail->(qw); return 1; }; local (*IN_R, *IN_W); local (*OUT_R, *OUT_W); local (*ERR_R, *ERR_W); $pipe->(*IN_R, *IN_W); $pipe->(*OUT_R, *OUT_W); $pipe->(*ERR_R, *ERR_W); $pid = IPC::Open3::open3('>&IN_R', '<&OUT_W', '<&ERR_W', @cmd); close *IN_W or $fail->(qw); $out = *OUT_R; $err = *ERR_R; } else { my $in = IO::Handle->new; $out = IO::Handle->new; $out->autoflush(1); $err = IO::Handle->new; $err->autoflush(1); $pid = IPC::Open3::open3($in, $out, $err, @cmd); close $in; } # Forward signals to the child (except SIGKILL) my %sig_handlers; foreach my $s (keys %SIG) { $sig_handlers{$s} = sub { kill "$s" => $pid; $SIG{$s} = $sig_handlers{$s}; }; } local $SIG{$_} = $sig_handlers{$_} for keys %SIG; unless ($want) { close $out or $fail->(qw); close $err or $fail->(qw); waitpid $pid, 0; $status = $?; return 1; } my $sel = IO::Select->new(); $sel->add($out, $err); my $fd_out = fileno $out; my $fd_err = fileno $err; my %contents; $contents{$fd_out} = ''; $contents{$fd_err} = ''; while (my @ready = $sel->can_read) { for my $fh (@ready) { my $buf; my $bytes_read = sysread $fh, $buf, 4096; if (not defined $bytes_read) { $fail->('sysread', 'fd(' . fileno($fh) . ')'); } elsif ($bytes_read) { $contents{fileno($fh)} .= $buf; } else { $sel->remove($fh); close $fh or $fail->('close', 'fd(' . fileno($fh) . ')'); last unless $sel->count; } } } waitpid $pid, 0; $status = $?; if ($^O eq 'MSWin32') { # Manual CRLF translation that couldn't be done with sysread. s/\x0D\x0A/\n/g for values %contents; } $content_out = $contents{$fd_out}; $content_err = $contents{$fd_err}; 1; }; if ("$]" < 5.014 and $ok and ($status >> 8) == 255 and defined $content_err and $content_err =~ /^open3/) { # Before perl commit 8960aa87 (between 5.12 and 5.14), exceptions in open3 # could be reported to STDERR instead of being propagated, so work around # this. $ok = 0; $@ = $content_err; } if ($ok) { return ($status, $content_out, $content_err); } else { my $err = $@; chomp $err; return (undef, $err); } } sub capture_failed_msg { my $details = shift; my $msg = 'Could not capture command output'; $msg .= " ($details)" if defined $details; return $msg; } sub capture_perl { my $code = shift; if ($code =~ /"/) { die 'Double quotes in evaluated code are not portable'; } fresh_perl_env { my @perl = @_; capture @perl, '-e', $code; }; } sub capture_perl_failed_msg { my $details = shift; my $msg = 'Could not capture perl output'; $msg .= " ($details)" if defined $details; return $msg; } =head2 C =over 4 =item * Import : use VPIT::TestHelpers threads => [ $pkg, $threadsafe_var, $force_var ]; where : =over 8 =item - C<$pkg> is the target package name that will be exercised by this test ; =item - C<$threadsafe_var> is the name of an optional variable in C<$pkg> that evaluates to true if and only if the module claims to be thread safe (not checked if either C<$threadsafe_var> or C<$pkg> is C) ; =item - C<$force_var> is the name of the environment variable that can be used to force the thread tests (defaults to C). =back =item * Dependencies : =over 8 =item - C 5.13.4 =item - L =item - L 1.67 =item - L 1.14 =back =item * Exports : =over 8 =item - C =back =item * Notes : =over 8 =item - C<< exit => 'threads_only' >> is passed to C<< threads->import >>. =back =back =cut sub init_threads { my ($pkg, $threadsafe_var, $force_var) = @_; skip_all 'This perl wasn\'t built to support threads' unless $Config::Config{useithreads}; if (defined $pkg and defined $threadsafe_var) { my $threadsafe; # run_perl() doesn't actually require anything my $stat = run_perl("require POSIX; require $pkg; exit($threadsafe_var ? POSIX::EXIT_SUCCESS() : POSIX::EXIT_FAILURE())"); if (defined $stat) { require POSIX; my $res = $stat >> 8; if ($res == POSIX::EXIT_SUCCESS()) { $threadsafe = 1; } elsif ($res == POSIX::EXIT_FAILURE()) { $threadsafe = !1; } } if (not defined $threadsafe) { skip_all "Could not detect if $pkg is thread safe or not"; } elsif (not $threadsafe) { skip_all "This $pkg is not thread safe"; } } $force_var = 'PERL_FORCE_TEST_THREADS' unless defined $force_var; my $force = $ENV{$force_var} ? 1 : !1; skip_all 'perl 5.13.4 required to test thread safety' unless $force or "$]" >= 5.013_004; unless ($INC{'threads.pm'}) { my $test_module; if ($INC{'Test/Leaner.pm'}) { $test_module = 'Test::Leaner'; } elsif ($INC{'Test/More.pm'}) { $test_module = 'Test::More'; } die "$test_module was loaded too soon" if defined $test_module; } load_or_skip_all 'threads', $force ? '0' : '1.67', [ exit => 'threads_only', ]; load_or_skip_all 'threads::shared', $force ? '0' : '1.14', [ ]; diag "Threads testing forced by \$ENV{$force_var}" if $force; return spawn => \&spawn; } sub spawn { local $@; my @diag; my $thread = eval { local $SIG{__WARN__} = sub { push @diag, "Thread creation warning: @_" }; threads->create(@_); }; push @diag, "Thread creation error: $@" if $@; diag @diag; return $thread ? $thread : (); } =head2 C =over 4 =item * Import : use VPIT::TestHelpers 'usleep' => [ @impls ]; where : =over 8 =item - C<@impls> is the list of desired implementations (which may be C<'Time::HiRes'>, C<'select'> or C<'sleep'>), in the order they should be checked. When the list is empty, it defaults to all of them. =back =item * Dependencies : none =item * Exports : =over 8 =item - C =back =back =cut sub init_usleep { my (@impls) = @_; my %impls = ( 'Time::HiRes' => sub { if (do { local $@; eval { require Time::HiRes; 1 } }) { defined and diag "Using usleep() from Time::HiRes $_" for $Time::HiRes::VERSION; return \&Time::HiRes::usleep; } else { return undef; } }, 'select' => sub { if ($Config::Config{d_select}) { diag 'Using select()-based fallback usleep()'; return sub ($) { my $s = $_[0]; my $r = 0; while ($s > 0) { my ($found, $t) = select(undef, undef, undef, $s / 1e6); last unless defined $t; $t = int($t * 1e6); $s -= $t; $r += $t; } return $r; }; } else { return undef; } }, 'sleep' => sub { diag 'Using sleep()-based fallback usleep()'; return sub ($) { my $ms = int $_[0]; my $s = int($ms / 1e6) + ($ms % 1e6 == 0 ? 0 : 1); my $t = sleep $s; return $t * 1e6; }; }, ); @impls = qw unless @impls; my $usleep; for my $impl (@impls) { next unless defined $impl and $impls{$impl}; $usleep = $impls{$impl}->(); last if defined $usleep; } skip_all "Could not find a suitable usleep() implementation among: @impls" unless $usleep; return usleep => $usleep; } =head1 CLASSES =head2 C Syntax : { my $guard = VPIT::TestHelpers::Guard->new($coderef); ... } # $codref called here =cut package VPIT::TestHelpers::Guard; sub new { my ($class, $code) = @_; bless { code => $code }, $class; } sub DESTROY { $_[0]->{code}->() } =head1 AUTHOR Vincent Pit, C<< >>, L. =head1 COPYRIGHT & LICENSE Copyright 2012,2013,2014,2015 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; autovivification-0.18/t/lib/Test/Leaner.pm000644 000765 000024 00000045374 12416743316 021356 0ustar00vincentstaff000000 000000 package Test::Leaner; use 5.006; use strict; use warnings; =head1 NAME Test::Leaner - A slimmer Test::More for when you favor performance over completeness. =head1 VERSION Version 0.05 =cut our $VERSION = '0.05'; =head1 SYNOPSIS use Test::Leaner tests => 10_000; for (1 .. 10_000) { ... is $one, 1, "checking situation $_"; } =head1 DESCRIPTION When profiling some L-based test script that contained about 10 000 unit tests, I realized that 60% of the time was spent in L itself, even though every single test actually involved a costly C. This module aims to be a partial replacement to L in those situations where you want to run a large number of simple tests. Its functions behave the same as their L counterparts, except for the following differences : =over 4 =item * Stringification isn't forced on the test operands. However, L honors C<'bool'> overloading, L and L honor C<'eq'> overloading (and just that one), L honors C<'ne'> overloading, and L honors whichever overloading category corresponds to the specified operator. =item * L, L, L, L, L, L, L, L and L are all guaranteed to return the truth value of the test. =item * C (the sub C in package C) is not aliased to L. =item * L and L don't special case regular expressions that are passed as C<'/.../'> strings. A string regexp argument is always treated as the source of the regexp, making C and C equivalent to each other and to C (and likewise for C). =item * L throws an exception if the given operator isn't a valid Perl binary operator (except C<'='> and variants). It also tests in scalar context, so C<'..'> will be treated as the flip-flop operator and not the range operator. =item * L doesn't guard for memory cycles. If the two first arguments present parallel memory cycles, the test may result in an infinite loop. =item * The tests don't output any kind of default diagnostic in case of failure ; the rationale being that if you have a large number of tests and a lot of them are failing, then you don't want to be flooded by diagnostics. Moreover, this allows a much faster variant of L. =item * C, C, C, C, C, C, C, C blocks and C are not implemented. =back =cut use Exporter (); my $main_process; BEGIN { $main_process = $$; if ("$]" >= 5.008 and $INC{'threads.pm'}) { my $use_ithreads = do { require Config; no warnings 'once'; $Config::Config{useithreads}; }; if ($use_ithreads) { require threads::shared; *THREADSAFE = sub () { 1 }; } } unless (defined &Test::Leaner::THREADSAFE) { *THREADSAFE = sub () { 0 } } } my ($TAP_STREAM, $DIAG_STREAM); my ($plan, $test, $failed, $no_diag, $done_testing); our @EXPORT = qw< plan skip done_testing pass fail ok is isnt like unlike cmp_ok is_deeply diag note BAIL_OUT >; =head1 ENVIRONMENT =head2 C If this environment variable is set, L will replace its functions by those from L. Moreover, the symbols that are imported when you C will be those from L, but you can still only import the symbols originally defined in L (hence the functions from L that are not implemented in L will not be imported). If your version of L is too old and doesn't have some symbols (like L or L), they will be replaced in L by croaking stubs. This may be useful if your L-based test script fails and you want extra diagnostics. =cut sub _handle_import_args { my @imports; my $i = 0; while ($i <= $#_) { my $item = $_[$i]; my $splice; if (defined $item) { if ($item eq 'import') { push @imports, @{ $_[$i+1] }; $splice = 2; } elsif ($item eq 'no_diag') { lock $plan if THREADSAFE; $no_diag = 1; $splice = 1; } } if ($splice) { splice @_, $i, $splice; } else { ++$i; } } return @imports; } if ($ENV{PERL_TEST_LEANER_USES_TEST_MORE}) { require Test::More; my $leaner_stash = \%Test::Leaner::; my $more_stash = \%Test::More::; my %stubbed; for (@EXPORT) { my $replacement = exists $more_stash->{$_} ? *{$more_stash->{$_}}{CODE} : undef; unless (defined $replacement) { $stubbed{$_}++; $replacement = sub { @_ = ("$_ is not implemented in this version of Test::More"); goto &croak; }; } no warnings 'redefine'; $leaner_stash->{$_} = $replacement; } my $import = sub { my $class = shift; my @imports = &_handle_import_args; if (@imports == grep /^!/, @imports) { # All imports are negated, or @imports is empty my %negated; /^!(.*)/ and ++$negated{$1} for @imports; push @imports, grep !$negated{$_}, @EXPORT; } my @test_more_imports; for (@imports) { if ($stubbed{$_}) { my $pkg = caller; no strict 'refs'; *{$pkg."::$_"} = $leaner_stash->{$_}; } elsif (/^!/ or !exists $more_stash->{$_} or exists $leaner_stash->{$_}) { push @test_more_imports, $_; } else { # Croak for symbols in Test::More but not in Test::Leaner Exporter::import($class, $_); } } my $test_more_import = 'Test::More'->can('import'); return unless $test_more_import; @_ = ( 'Test::More', @_, import => \@test_more_imports, ); { lock $plan if THREADSAFE; push @_, 'no_diag' if $no_diag; } goto $test_more_import; }; no warnings 'redefine'; *import = $import; return 1; } sub NO_PLAN () { -1 } sub SKIP_ALL () { -2 } BEGIN { if (THREADSAFE) { threads::shared::share($_) for $plan, $test, $failed, $no_diag, $done_testing; } lock $plan if THREADSAFE; $plan = undef; $test = 0; $failed = 0; } sub carp { my $level = 1 + ($Test::Builder::Level || 0); my @caller; do { @caller = caller $level--; } while (!@caller and $level >= 0); my ($file, $line) = @caller[1, 2]; warn @_, " at $file line $line.\n"; } sub croak { my $level = 1 + ($Test::Builder::Level || 0); my @caller; do { @caller = caller $level--; } while (!@caller and $level >= 0); my ($file, $line) = @caller[1, 2]; die @_, " at $file line $line.\n"; } sub _sanitize_comment { $_[0] =~ s/\n+\z//; $_[0] =~ s/#/\\#/g; $_[0] =~ s/\n/\n# /g; } =head1 FUNCTIONS The following functions from L are implemented and exported by default. =head2 C plan tests => $count; plan 'no_plan'; plan skip_all => $reason; See L. =cut sub plan { my ($key, $value) = @_; return unless $key; lock $plan if THREADSAFE; croak("You tried to plan twice") if defined $plan; my $plan_str; if ($key eq 'no_plan') { croak("no_plan takes no arguments") if $value; $plan = NO_PLAN; } elsif ($key eq 'tests') { croak("Got an undefined number of tests") unless defined $value; croak("You said to run 0 tests") unless $value; croak("Number of tests must be a positive integer. You gave it '$value'") unless $value =~ /^\+?[0-9]+$/; $plan = $value; $plan_str = "1..$value"; } elsif ($key eq 'skip_all') { $plan = SKIP_ALL; $plan_str = '1..0 # SKIP'; if (defined $value) { _sanitize_comment($value); $plan_str .= " $value" if length $value; } } else { my @args = grep defined, $key, $value; croak("plan() doesn't understand @args"); } if (defined $plan_str) { local $\; print $TAP_STREAM "$plan_str\n"; } exit 0 if $plan == SKIP_ALL; return 1; } sub import { my $class = shift; my @imports = &_handle_import_args; if (@_) { local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1; &plan; } @_ = ($class, @imports); goto &Exporter::import; } =head2 C skip $reason => $count; See L. =cut sub skip { my ($reason, $count) = @_; lock $plan if THREADSAFE; if (not defined $count) { carp("skip() needs to know \$how_many tests are in the block") unless defined $plan and $plan == NO_PLAN; $count = 1; } elsif ($count =~ /[^0-9]/) { carp('skip() was passed a non-numeric number of tests. Did you get the arguments backwards?'); $count = 1; } for (1 .. $count) { ++$test; my $skip_str = "ok $test # skip"; if (defined $reason) { _sanitize_comment($reason); $skip_str .= " $reason" if length $reason; } local $\; print $TAP_STREAM "$skip_str\n"; } no warnings 'exiting'; last SKIP; } =head2 C done_testing; done_testing $count; See L. =cut sub done_testing { my ($count) = @_; lock $plan if THREADSAFE; $count = $test unless defined $count; croak("Number of tests must be a positive integer. You gave it '$count'") unless $count =~ /^\+?[0-9]+$/; if (not defined $plan or $plan == NO_PLAN) { $plan = $count; # $plan can't be NO_PLAN anymore $done_testing = 1; local $\; print $TAP_STREAM "1..$plan\n"; } else { if ($done_testing) { @_ = ('done_testing() was already called'); goto &fail; } elsif ($plan != $count) { @_ = ("planned to run $plan tests but done_testing() expects $count"); goto &fail; } } return 1; } =head2 C ok $ok; ok $ok, $desc; See L. =cut sub ok ($;$) { my ($ok, $desc) = @_; lock $plan if THREADSAFE; ++$test; my $test_str = "ok $test"; $ok or do { $test_str = "not $test_str"; ++$failed; }; if (defined $desc) { _sanitize_comment($desc); $test_str .= " - $desc" if length $desc; } local $\; print $TAP_STREAM "$test_str\n"; return $ok; } =head2 C pass; pass $desc; See L. =cut sub pass (;$) { unshift @_, 1; goto &ok; } =head2 C fail; fail $desc; See L. =cut sub fail (;$) { unshift @_, 0; goto &ok; } =head2 C is $got, $expected; is $got, $expected, $desc; See L. =cut sub is ($$;$) { my ($got, $expected, $desc) = @_; no warnings 'uninitialized'; @_ = ( (not(defined $got xor defined $expected) and $got eq $expected), $desc, ); goto &ok; } =head2 C isnt $got, $expected; isnt $got, $expected, $desc; See L. =cut sub isnt ($$;$) { my ($got, $expected, $desc) = @_; no warnings 'uninitialized'; @_ = ( ((defined $got xor defined $expected) or $got ne $expected), $desc, ); goto &ok; } my %binops = ( 'or' => 'or', 'xor' => 'xor', 'and' => 'and', '||' => 'hor', ('//' => 'dor') x ("$]" >= 5.010), '&&' => 'hand', '|' => 'bor', '^' => 'bxor', '&' => 'band', 'lt' => 'lt', 'le' => 'le', 'gt' => 'gt', 'ge' => 'ge', 'eq' => 'eq', 'ne' => 'ne', 'cmp' => 'cmp', '<' => 'nlt', '<=' => 'nle', '>' => 'ngt', '>=' => 'nge', '==' => 'neq', '!=' => 'nne', '<=>' => 'ncmp', '=~' => 'like', '!~' => 'unlike', ('~~' => 'smartmatch') x ("$]" >= 5.010), '+' => 'add', '-' => 'substract', '*' => 'multiply', '/' => 'divide', '%' => 'modulo', '<<' => 'lshift', '>>' => 'rshift', '.' => 'concat', '..' => 'flipflop', '...' => 'altflipflop', ',' => 'comma', '=>' => 'fatcomma', ); my %binop_handlers; sub _create_binop_handler { my ($op) = @_; my $name = $binops{$op}; croak("Operator $op not supported") unless defined $name; { local $@; eval <<"IS_BINOP"; sub is_$name (\$\$;\$) { my (\$got, \$expected, \$desc) = \@_; \@_ = (scalar(\$got $op \$expected), \$desc); goto &ok; } IS_BINOP die $@ if $@; } $binop_handlers{$op} = do { no strict 'refs'; \&{__PACKAGE__."::is_$name"}; } } =head2 C like $got, $regexp_expected; like $got, $regexp_expected, $desc; See L. =head2 C unlike $got, $regexp_expected; unlike $got, $regexp_expected, $desc; See L. =cut { no warnings 'once'; *like = _create_binop_handler('=~'); *unlike = _create_binop_handler('!~'); } =head2 C cmp_ok $got, $op, $expected; cmp_ok $got, $op, $expected, $desc; See L. =cut sub cmp_ok ($$$;$) { my ($got, $op, $expected, $desc) = @_; my $handler = $binop_handlers{$op}; unless ($handler) { local $Test::More::Level = ($Test::More::Level || 0) + 1; $handler = _create_binop_handler($op); } @_ = ($got, $expected, $desc); goto $handler; } =head2 C is_deeply $got, $expected; is_deeply $got, $expected, $desc; See L. =cut BEGIN { local $@; if (eval { require Scalar::Util; 1 }) { *_reftype = \&Scalar::Util::reftype; } else { # Stolen from Scalar::Util::PP require B; my %tmap = qw< B::NULL SCALAR B::HV HASH B::AV ARRAY B::CV CODE B::IO IO B::GV GLOB B::REGEXP REGEXP >; *_reftype = sub ($) { my $r = shift; return undef unless length ref $r; my $t = ref B::svref_2object($r); return exists $tmap{$t} ? $tmap{$t} : length ref $$r ? 'REF' : 'SCALAR' } } } sub _deep_ref_check { my ($x, $y, $ry) = @_; no warnings qw; if ($ry eq 'ARRAY') { return 0 unless $#$x == $#$y; my ($ex, $ey); for (0 .. $#$y) { $ex = $x->[$_]; $ey = $y->[$_]; # Inline the beginning of _deep_check return 0 if defined $ex xor defined $ey; next if not(ref $ex xor ref $ey) and $ex eq $ey; $ry = _reftype($ey); return 0 if _reftype($ex) ne $ry; return 0 unless $ry and _deep_ref_check($ex, $ey, $ry); } return 1; } elsif ($ry eq 'HASH') { return 0 unless keys(%$x) == keys(%$y); my ($ex, $ey); for (keys %$y) { return 0 unless exists $x->{$_}; $ex = $x->{$_}; $ey = $y->{$_}; # Inline the beginning of _deep_check return 0 if defined $ex xor defined $ey; next if not(ref $ex xor ref $ey) and $ex eq $ey; $ry = _reftype($ey); return 0 if _reftype($ex) ne $ry; return 0 unless $ry and _deep_ref_check($ex, $ey, $ry); } return 1; } elsif ($ry eq 'SCALAR' or $ry eq 'REF') { return _deep_check($$x, $$y); } return 0; } sub _deep_check { my ($x, $y) = @_; no warnings qw; return 0 if defined $x xor defined $y; # Try object identity/eq overloading first. It also covers the case where # $x and $y are both undefined. # If either $x or $y is overloaded but none has eq overloading, the test will # break at that point. return 1 if not(ref $x xor ref $y) and $x eq $y; # Test::More::is_deeply happily breaks encapsulation if the objects aren't # overloaded. my $ry = _reftype($y); return 0 if _reftype($x) ne $ry; # Shortcut if $x and $y are both not references and failed the previous # $x eq $y test. return 0 unless $ry; # We know that $x and $y are both references of type $ry, without overloading. _deep_ref_check($x, $y, $ry); } sub is_deeply { @_ = ( &_deep_check, $_[2], ); goto &ok; } sub _diag_fh { my $fh = shift; return unless @_; lock $plan if THREADSAFE; return if $no_diag; my $msg = join '', map { defined($_) ? $_ : 'undef' } @_; _sanitize_comment($msg); return unless length $msg; local $\; print $fh "# $msg\n"; return 0; }; =head2 C diag @lines; See L. =cut sub diag { unshift @_, $DIAG_STREAM; goto &_diag_fh; } =head2 C note @lines; See L. =cut sub note { unshift @_, $TAP_STREAM; goto &_diag_fh; } =head2 C BAIL_OUT; BAIL_OUT $desc; See L. =cut sub BAIL_OUT { my ($desc) = @_; lock $plan if THREADSAFE; my $bail_out_str = 'Bail out!'; if (defined $desc) { _sanitize_comment($desc); $bail_out_str .= " $desc" if length $desc; # Two spaces } local $\; print $TAP_STREAM "$bail_out_str\n"; exit 255; } END { if ($main_process == $$ and not $?) { lock $plan if THREADSAFE; if (defined $plan) { if ($failed) { $? = $failed <= 254 ? $failed : 254; } elsif ($plan >= 0) { $? = $test == $plan ? 0 : 255; } if ($plan == NO_PLAN) { local $\; print $TAP_STREAM "1..$test\n"; } } } } =pod L also provides some functions of its own, which are never exported. =head2 C my $tap_fh = tap_stream; tap_stream $fh; Read/write accessor for the filehandle to which the tests are outputted. On write, it also turns autoflush on onto C<$fh>. Note that it can only be used as a write accessor before you start any thread, as L cannot reliably share filehandles. Defaults to C. =cut sub tap_stream (;*) { if (@_) { $TAP_STREAM = $_[0]; my $fh = select $TAP_STREAM; $|++; select $fh; } return $TAP_STREAM; } tap_stream *STDOUT; =head2 C my $diag_fh = diag_stream; diag_stream $fh; Read/write accessor for the filehandle to which the diagnostics are printed. On write, it also turns autoflush on onto C<$fh>. Just like L, it can only be used as a write accessor before you start any thread, as L cannot reliably share filehandles. Defaults to C. =cut sub diag_stream (;*) { if (@_) { $DIAG_STREAM = $_[0]; my $fh = select $DIAG_STREAM; $|++; select $fh; } return $DIAG_STREAM; } diag_stream *STDERR; =head2 C This constant evaluates to true if and only if L is thread-safe, i.e. when this version of C is at least 5.8, has been compiled with C defined, and L has been loaded B L. In that case, it also needs a working L. =head1 DEPENDENCIES L 5.6. L, L. =head1 AUTHOR Vincent Pit, C<< >>, L. You can contact me by mail or on C (vincent). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Test::Leaner =head1 COPYRIGHT & LICENSE Copyright 2010,2011,2013 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Except for the fallback implementation of the internal C<_reftype> function, which has been taken from L and is Copyright 1997-2007 Graham Barr, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; # End of Test::Leaner autovivification-0.18/t/lib/autovivification/TestCases.pm000644 000765 000024 00000005665 12517714724 024514 0ustar00vincentstaff000000 000000 package autovivification::TestCases; use strict; use warnings; use Test::Leaner; sub import { no strict 'refs'; *{caller().'::testcase_ok'} = \&testcase_ok; } sub in_strict { (caller 0)[8] & (eval { strict::bits(@_) } || 0) }; sub do_nothing { } sub set_arg { $_[0] = 1 } sub generate { my ($var, $init, $code, $exp, $use, $opts, $global) = @_; my $decl = $global ? "our $var; local $var;" : "my $var;"; my $test = $var =~ /^[@%]/ ? "\\$var" : $var; my $desc = join('; ', map { my $x = $_; $x=~ s,;\s*$,,; $x } grep /\S/, $decl, $init, $code) . " <$opts>"; return </\$$var/g; push @base, \@oldderef; my @nonref = @{$base[0]}; $nonref[0] = $sigil . $name; for ($nonref[1], $nonref[2]) { s/\@\Q$var\E([\[\{])/\@$name$1/g; s/\Q$sigil$var\E/$nonref[0]/g; s/\Q$var\E\->/$var/g; } my $simple = $nonref[2] !~ /->/; my $plain_deref = $nonref[2] =~ /\Q$nonref[0]\E/; my $empty = { '@' => '[ ]', '%' => '{ }' }->{$sigil}; if (($simple and ( $nonref[3] =~ m!qr/\^Reference vivification forbidden.*?/! or $nonref[3] =~ m!qr/\^Can't vivify reference.*?/!)) or ($plain_deref and $nonref[3] =~ m!qr/\^Can't use an undefined value as a.*?/!)) { $nonref[1] = ''; $nonref[2] = 1; $nonref[3] = "'', 1, $empty"; } $nonref[3] =~ s/,\s*undef\s*$/, $empty/; push @base, \@nonref; } my @testcases = map { my ($var, $init, $code, $exp, $use) = @$_; [ $var, $init, $code, $exp, $use, $opts, 0 ], [ $var, "use strict; $init", $code, $exp, $use, $opts, 1 ], [ $var, "no strict; $init", $code, $exp, $use, $opts, 1 ], } @base; for (@testcases) { my ($testcase, $desc) = generate(@$_); my @N = (0 .. 9); eval $testcase; diag "== This testcase failed to compile ==\n$testcase\n## Reason: $@" if $@; } } 1; autovivification-0.18/t/lib/autovivification/TestRequired1.pm000644 000765 000024 00000000214 12416743316 025275 0ustar00vincentstaff000000 000000 package autovivification::TestRequired1; my $x = $main::blurp->{r1_main}->{vivify}; eval 'my $y = $main::blurp->{r1_eval}->{vivify}'; 1; autovivification-0.18/t/lib/autovivification/TestRequired2.pm000644 000765 000024 00000000427 12416743316 025304 0ustar00vincentstaff000000 000000 package autovivification::TestRequired2; no autovivification; BEGIN { delete $INC{'autovivification/TestRequired1.pm'}; } use lib 't/lib'; use autovivification::TestRequired1; my $x = $main::blurp->{r2_main}->{vivify}; eval 'my $y = $main::blurp->{r2_eval}->{vivify}'; 1; autovivification-0.18/t/lib/autovivification/TestRequired4/000755 000765 000024 00000000000 13177355077 024755 5ustar00vincentstaff000000 000000 autovivification-0.18/t/lib/autovivification/TestRequired5/000755 000765 000024 00000000000 13177355077 024756 5ustar00vincentstaff000000 000000 autovivification-0.18/t/lib/autovivification/TestRequired6.pm000644 000765 000024 00000000237 12416743316 025307 0ustar00vincentstaff000000 000000 package autovivification::TestRequired6; sub new { bless {} } sub bar { exists $main::blurp->{bar}; } sub baz { eval q[exists $main::blurp->{baz}]; } 1; autovivification-0.18/t/lib/autovivification/TestRequired5/a0.pm000644 000765 000024 00000000317 12416743316 025605 0ustar00vincentstaff000000 000000 package autovivification::TestRequired5::a0; no autovivification qw; use autovivification::TestRequired5::b0; sub error { local $@; autovivification::TestRequired5::b0->get; return $@; } 1; autovivification-0.18/t/lib/autovivification/TestRequired5/b0.pm000644 000765 000024 00000000161 12416743316 025603 0ustar00vincentstaff000000 000000 package autovivification::TestRequired5::b0; sub get { eval 'require autovivification::TestRequired5::c0'; } 1; autovivification-0.18/t/lib/autovivification/TestRequired5/c0.pm000644 000765 000024 00000000135 12416743316 025605 0ustar00vincentstaff000000 000000 package autovivification::TestRequired5::c0; require autovivification::TestRequired5::d0; 1; autovivification-0.18/t/lib/autovivification/TestRequired5/d0.pm000644 000765 000024 00000000112 12416743316 025601 0ustar00vincentstaff000000 000000 package autovivification::TestRequired5::d0; my $x; my $y = $x->{foo}; 1; autovivification-0.18/t/lib/autovivification/TestRequired4/a0.pm000644 000765 000024 00000000317 12416743316 025604 0ustar00vincentstaff000000 000000 package autovivification::TestRequired4::a0; no autovivification qw; use autovivification::TestRequired4::b0; sub error { local $@; autovivification::TestRequired4::b0->get; return $@; } 1; autovivification-0.18/t/lib/autovivification/TestRequired4/b0.pm000644 000765 000024 00000000161 12416743316 025602 0ustar00vincentstaff000000 000000 package autovivification::TestRequired4::b0; sub get { eval 'require autovivification::TestRequired4::c0'; } 1; autovivification-0.18/t/lib/autovivification/TestRequired4/c0.pm000644 000765 000024 00000000112 12416743316 025577 0ustar00vincentstaff000000 000000 package autovivification::TestRequired4::c0; my $x; my $y = $x->{foo}; 1; autovivification-0.18/samples/bench.pl000644 000765 000024 00000003736 12416743316 020736 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use Benchmark qw<:hireswallclock cmpthese>; use blib; my $count = -1; my @tests; { my %h = (); push @tests, [ 'Fetch a non-existing key from a hash', { av => sub { $h{a} }, noav => sub { no autovivification; $h{a} }, } ]; } { my %h = (a => 1); push @tests, [ 'Fetch an existing key from a hash', { av => sub { $h{a} }, noav => sub { no autovivification; $h{a} }, } ]; } { my $x = { }; push @tests, [ 'Fetch a non-existing key from a hash reference', { av => sub { $x->{a} }, noav => sub { no autovivification; $x->{a} }, noav_manual => sub { defined $x ? $x->{a} : undef }, } ]; } { my $x = { a => 1 }; push @tests, [ 'Fetch an existing key from a hash reference', { av => sub { $x->{a} }, noav => sub { no autovivification; $x->{a} }, noav_manual => sub { defined $x ? $x->{a} : undef }, } ]; } { my $x = { a => { b => { c => { d => 1 } } } }; push @tests, [ 'Fetch a 4-levels deep existing key from a hash reference', { av => sub { $x->{a}{b}{c}{d} }, noav => sub { no autovivification; $x->{a}{b}{c}{d} }, noav_manual => sub { my $z; defined $x ? ($z = $x->{a}, defined $z ? ($z = $z->{b}, defined $z ? ($z = $z->{c}, defined $z ? $z->{d} : undef) : undef) : undef) : undef }, } ]; } { my $x = { }; $x->{$_} = undef for 100 .. 199; $x->{$_} = { $_ => 1 } for 200 .. 299; my $n = 0; no warnings 'void'; push @tests, [ 'Fetch 2-levels deep existing or non-existing keys from a hash reference', { inc => sub { $n = ($n+1) % 300 }, av => sub { $x->{$n}{$n}; $n = ($n+1) % 300 }, noav => sub { no autovivification; $x->{$n}{$n}; $n = ($n+1) % 300 }, noav_manual => sub { my $z; defined $x ? ($z = $x->{a}, (defined $z ? $z->{b} : undef)) : undef; $n = ($n + 1) % 300 }, } ]; } for my $t (@tests) { printf "--- %s ---\n", $t->[0]; cmpthese $count, $t->[1]; print "\n"; } autovivification-0.18/samples/hash2array.pl000644 000765 000024 00000004426 12416743316 021720 0ustar00vincentstaff000000 000000 #!perl use strict; use warnings; use Fatal qw; use Text::Balanced qw; open my $hash_t, '<', 't/20-hash.t'; open my $array_t, '>', 't/30-array.t'; open my $array_fast_t, '>', 't/31-array-fast.t'; sub num { my ($char) = $_[0] =~ /['"]?([a-z])['"]?/; return ord($char) - ord('a') } sub hash2array { my ($h) = @_; return $h unless $h and ref $h eq 'HASH'; my @array; for (keys %$h) { $array[num($_)] = hash2array($h->{$_}); } return \@array; } sub dump_array { my ($a) = @_; return 'undef' unless defined $a; if (ref $a) { die "Invalid argument" unless ref $a eq 'ARRAY'; return '[ ' . join(', ', map dump_array($_), @$a) . ' ]'; } else { $a = "'\Q$a\E'" if $a !~ /^\s*\d/; return $a; } } sub extract ($$) { extract_bracketed $_[0], $_[1], qr/.*?(?) { if (/^__DATA__$/) { $in_data = 1; print $array_t $_; print $array_fast_t $_; } elsif (!$in_data) { s{'%'}{'\@'}; print $array_t $_; print $array_fast_t $_; } else { print $array_t convert_testcase($_, 0); print $array_fast_t convert_testcase($_, 1); } } close $hash_t; close $array_t; close $array_fast_t; open my $hash_kv_t, '<', 't/22-hash-kv.t'; open my $array_kv_t, '>', 't/32-array-kv.t'; $in_data = 0; while (<$hash_kv_t>) { if (/^__DATA__$/) { $in_data = 1; } elsif (!$in_data) { s{'%'}{'\@'}; if (/\bplan\s*[\s\(]\s*tests\b/) { s/\s*;?\s*$//; s/^(\s*)//; $_ = qq($1if ("\$]" >= 5.011) { $_ } else { plan skip_all => 'perl 5.11 required for keys/values \@array' }\n); } } else { $_ = convert_testcase($_, 1); } print $array_kv_t $_; } autovivification-0.18/lib/autovivification.pm000644 000765 000024 00000016740 13177354535 022352 0ustar00vincentstaff000000 000000 package autovivification; use 5.008_003; use strict; use warnings; =head1 NAME autovivification - Lexically disable autovivification. =head1 VERSION Version 0.18 =cut our $VERSION; BEGIN { $VERSION = '0.18'; } =head1 SYNOPSIS no autovivification; my $hashref; my $a = $hashref->{key_a}; # $hashref stays undef if (exists $hashref->{option}) { # Still undef ... } delete $hashref->{old}; # Still undef again $hashref->{new} = $value; # Vivifies to { new => $value } =head1 DESCRIPTION When an undefined variable is dereferenced, it gets silently upgraded to an array or hash reference (depending of the type of the dereferencing). This behaviour is called I and usually does what you mean (e.g. when you store a value) but it may be unnatural or surprising because your variables gets populated behind your back. This is especially true when several levels of dereferencing are involved, in which case all levels are vivified up to the last, or when it happens in intuitively read-only constructs like C. This pragma lets you disable autovivification for some constructs and optionally throws a warning or an error when it would have happened. =cut BEGIN { require XSLoader; XSLoader::load(__PACKAGE__, $VERSION); } =head1 METHODS =head2 C no autovivification; # defaults to qw no autovivification qw; no autovivification warn => @categories; no autovivification strict => @categories; Magically called when C is encountered. Enables the features given in C<@opts>, which can be : =over 4 =item * C<'fetch'> Turns off autovivification for rvalue dereferencing expressions, such as : $value = $arrayref->[$idx] $value = $hashref->{$key} keys %$hashref values %$hashref Starting from perl C<5.11>, it also covers C and C on array references : keys @$arrayref values @$arrayref When the expression would have autovivified, C is returned for a plain fetch, while C and C return C<0> in scalar context and the empty list in list context. =item * C<'exists'> Turns off autovivification for dereferencing expressions that are parts of an C, such as : exists $arrayref->[$idx] exists $hashref->{$key} C<''> is returned when the expression would have autovivified. =item * C<'delete'> Turns off autovivification for dereferencing expressions that are parts of a C, such as : delete $arrayref->[$idx] delete $hashref->{$key} C is returned when the expression would have autovivified. =item * C<'store'> Turns off autovivification for lvalue dereferencing expressions, such as : $arrayref->[$idx] = $value $hashref->{$key} = $value for ($arrayref->[$idx]) { ... } for ($hashref->{$key}) { ... } function($arrayref->[$idx]) function($hashref->{$key}) An exception is thrown if vivification is needed to store the value, which means that effectively you can only assign to levels that are already defined. In the example, this would require C<$arrayref> (resp. C<$hashref>) to already be an array (resp. hash) reference. =item * C<'warn'> Emits a warning when an autovivification is avoided for the categories specified in C<@opts>. Note that C currently does nothing by itself, in particular it does not make the default categories warn. This behaviour may change in a future version of this pragma. =item * C<'strict'> Throws an exception when an autovivification is avoided for the categories specified in C<@opts>. Note that C currently does nothing by itself, in particular it does not make the default categories die. This behaviour may change in a future version of this pragma. =back Each call to C B the specified features to the ones already in use in the current lexical scope. When C<@opts> is empty, it defaults to C<< qw >>. =cut my %bits = ( strict => A_HINT_STRICT, warn => A_HINT_WARN, fetch => A_HINT_FETCH|A_HINT_KEYS|A_HINT_VALUES, store => A_HINT_STORE, exists => A_HINT_EXISTS, delete => A_HINT_DELETE, ); sub unimport { shift; my $hint = _detag($^H{+(__PACKAGE__)}) || 0; @_ = qw unless @_; $hint |= $bits{$_} for grep exists $bits{$_}, @_; $^H |= 0x00020000; $^H{+(__PACKAGE__)} = _tag($hint); (); } =head2 C use autovivification; # default Perl behaviour use autovivification qw; Magically called when C is encountered. Disables the features given in C<@opts>, which can be the same as for L. Each call to C B the specified features to the ones already in use in the current lexical scope. When C<@opts> is empty, it defaults to restoring the original Perl autovivification behaviour. =cut sub import { shift; my $hint = 0; if (@_) { $hint = _detag($^H{+(__PACKAGE__)}) || 0; $hint &= ~$bits{$_} for grep exists $bits{$_}, @_; } $^H |= 0x00020000; $^H{+(__PACKAGE__)} = _tag($hint); (); } =head1 CONSTANTS =head2 C True if and only if the module could have been built with thread-safety features enabled. This constant only has a meaning when your perl is threaded, otherwise it will always be false. =head2 C True if and only if this module could have been built with fork-safety features enabled. This constant will always be true, except on Windows where it is false for perl 5.10.0 and below. =head1 CAVEATS Using this pragma will cause a slight global slowdown of any subsequent compilation phase that happens anywere in your code - even outside of the scope of use of C - which may become noticeable if you rely heavily on numerous calls to C. The pragma doesn't apply when one dereferences the returned value of an array or hash slice, as in C<< @array[$id]->{member} >> or C<< @hash{$key}->{member} >>. This syntax is valid Perl, yet it is discouraged as the slice is here useless since the dereferencing enforces scalar context. If warnings are turned on, Perl will complain about one-element slices. Autovivifications that happen in code C'd during the global destruction phase of a spawned thread or pseudo-fork (the processes used internally for the C emulation on Windows) are not reported. =head1 DEPENDENCIES L 5.8.3. A C compiler. This module may happen to build with a C++ compiler as well, but don't rely on it, as no guarantee is made in this regard. L (standard since perl 5.6.0). =head1 SEE ALSO L. =head1 AUTHOR Vincent Pit, C<< >>, L. You can contact me by mail or on C (vincent). =head1 BUGS Please report any bugs or feature requests to C, or through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc autovivification =head1 ACKNOWLEDGEMENTS Matt S. Trout asked for it. =head1 COPYRIGHT & LICENSE Copyright 2009,2010,2011,2012,2013,2014,2015,2017 Vincent Pit, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; # End of autovivification