autovivification-0.16/000755 000765 000024 00000000000 12544767601 015650 5ustar00vincentstaff000000 000000 autovivification-0.16/autovivification.xs000644 000765 000024 00000124464 12544645653 021624 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" #define __PACKAGE__ "autovivification" #define __PACKAGE_LEN__ (sizeof(__PACKAGE__)-1) /* --- Compatibility wrappers ---------------------------------------------- */ #ifndef HvNAME_get # define HvNAME_get(H) HvNAME(H) #endif #ifndef HvNAMELEN_get # define HvNAMELEN_get(H) strlen(HvNAME_get(H)) #endif #define A_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S)))))) #ifndef A_WORKAROUND_REQUIRE_PROPAGATION # define A_WORKAROUND_REQUIRE_PROPAGATION !A_HAS_PERL(5, 10, 1) #endif #ifndef A_HAS_RPEEP # define A_HAS_RPEEP A_HAS_PERL(5, 13, 5) #endif #ifndef A_HAS_MULTIDEREF # define A_HAS_MULTIDEREF A_HAS_PERL(5, 21, 7) #endif #ifndef OpSIBLING # ifdef OP_SIBLING # define OpSIBLING(O) OP_SIBLING(O) # else # define OpSIBLING(O) ((O)->op_sibling) # endif #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 */ /* ... Thread safety and multiplicity ...................................... */ /* Always safe when the workaround isn't needed */ #if !A_WORKAROUND_REQUIRE_PROPAGATION # undef A_FORKSAFE # define A_FORKSAFE 1 /* Otherwise, safe unless Makefile.PL says it's Win32 */ #elif !defined(A_FORKSAFE) # define A_FORKSAFE 1 #endif #ifndef A_MULTIPLICITY # if defined(MULTIPLICITY) # define A_MULTIPLICITY 1 # else # define A_MULTIPLICITY 0 # endif #endif #if A_MULTIPLICITY # ifndef PERL_IMPLICIT_CONTEXT # error MULTIPLICITY builds must set PERL_IMPLICIT_CONTEXT # endif #endif #ifndef tTHX # define tTHX PerlInterpreter* #endif #if A_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 A_THREADSAFE 1 # 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 # define A_THREADSAFE 0 # undef dMY_CXT # define dMY_CXT dNOOP # undef MY_CXT # define MY_CXT a_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 A_THREADSAFE /* We must use preexistent global mutexes or we will never be able to destroy * them. */ # if A_HAS_PERL(5, 9, 3) # define A_LOADED_LOCK MUTEX_LOCK(&PL_my_ctx_mutex) # define A_LOADED_UNLOCK MUTEX_UNLOCK(&PL_my_ctx_mutex) # else # define A_LOADED_LOCK OP_REFCNT_LOCK # define A_LOADED_UNLOCK OP_REFCNT_UNLOCK # endif #else # define A_LOADED_LOCK NOOP # define A_LOADED_UNLOCK NOOP #endif #if defined(OP_CHECK_MUTEX_LOCK) && defined(OP_CHECK_MUTEX_UNLOCK) # define A_CHECK_LOCK OP_CHECK_MUTEX_LOCK # define A_CHECK_UNLOCK OP_CHECK_MUTEX_UNLOCK #elif A_HAS_PERL(5, 9, 3) # define A_CHECK_LOCK OP_REFCNT_LOCK # define A_CHECK_UNLOCK OP_REFCNT_UNLOCK #else /* Before perl 5.9.3, indirect_ck_*() calls are already protected by the * A_LOADED mutex, which falls back to the OP_REFCNT mutex. Make sure we don't * lock it twice. */ # define A_CHECK_LOCK NOOP # define A_CHECK_UNLOCK NOOP #endif typedef OP *(*a_ck_t)(pTHX_ OP *); #ifdef wrap_op_checker # define a_ck_replace(T, NC, OCP) wrap_op_checker((T), (NC), (OCP)) #else static void a_ck_replace(pTHX_ OPCODE type, a_ck_t new_ck, a_ck_t *old_ck_p) { #define a_ck_replace(T, NC, OCP) a_ck_replace(aTHX_ (T), (NC), (OCP)) A_CHECK_LOCK; if (!*old_ck_p) { *old_ck_p = PL_check[type]; PL_check[type] = new_ck; } A_CHECK_UNLOCK; } #endif static void a_ck_restore(pTHX_ OPCODE type, a_ck_t *old_ck_p) { #define a_ck_restore(T, OCP) a_ck_restore(aTHX_ (T), (OCP)) A_CHECK_LOCK; if (*old_ck_p) { PL_check[type] = *old_ck_p; *old_ck_p = 0; } A_CHECK_UNLOCK; } /* --- Helpers ------------------------------------------------------------- */ /* ... Check if the module is loaded ....................................... */ static I32 a_loaded = 0; #if A_THREADSAFE #define PTABLE_NAME ptable_loaded #define PTABLE_NEED_DELETE 1 #define PTABLE_NEED_WALK 0 #include "ptable.h" #define ptable_loaded_store(T, K, V) ptable_loaded_store(aPTBLMS_ (T), (K), (V)) #define ptable_loaded_delete(T, K) ptable_loaded_delete(aPTBLMS_ (T), (K)) #define ptable_loaded_free(T) ptable_loaded_free(aPTBLMS_ (T)) static ptable *a_loaded_cxts = NULL; static int a_is_loaded(pTHX_ void *cxt) { #define a_is_loaded(C) a_is_loaded(aTHX_ (C)) int res = 0; A_LOADED_LOCK; if (a_loaded_cxts && ptable_fetch(a_loaded_cxts, cxt)) res = 1; A_LOADED_UNLOCK; return res; } static int a_set_loaded_locked(pTHX_ void *cxt) { #define a_set_loaded_locked(C) a_set_loaded_locked(aTHX_ (C)) int global_setup = 0; if (a_loaded <= 0) { assert(a_loaded == 0); assert(!a_loaded_cxts); a_loaded_cxts = ptable_new(); global_setup = 1; } ++a_loaded; assert(a_loaded_cxts); ptable_loaded_store(a_loaded_cxts, cxt, cxt); return global_setup; } static int a_clear_loaded_locked(pTHX_ void *cxt) { #define a_clear_loaded_locked(C) a_clear_loaded_locked(aTHX_ (C)) int global_teardown = 0; if (a_loaded > 1) { assert(a_loaded_cxts); ptable_loaded_delete(a_loaded_cxts, cxt); --a_loaded; } else if (a_loaded_cxts) { assert(a_loaded == 1); ptable_loaded_free(a_loaded_cxts); a_loaded_cxts = NULL; a_loaded = 0; global_teardown = 1; } return global_teardown; } #else #define a_is_loaded(C) (a_loaded > 0) #define a_set_loaded_locked(C) ((a_loaded++ <= 0) ? 1 : 0) #define a_clear_loaded_locked(C) ((--a_loaded <= 0) ? 1 : 0) #endif /* ... Thread-safe hints ................................................... */ #if A_WORKAROUND_REQUIRE_PROPAGATION typedef struct { U32 bits; IV require_tag; } a_hint_t; #define A_HINT_FREE(H) PerlMemShared_free(H) #if A_THREADSAFE #define PTABLE_NAME ptable_hints #define PTABLE_VAL_FREE(V) A_HINT_FREE(V) #define PTABLE_NEED_DELETE 0 #define PTABLE_NEED_WALK 1 #define pPTBL pTHX #define pPTBL_ pTHX_ #define aPTBL aTHX #define aPTBL_ aTHX_ #include "ptable.h" #define ptable_hints_store(T, K, V) ptable_hints_store(aTHX_ (T), (K), (V)) #define ptable_hints_free(T) ptable_hints_free(aTHX_ (T)) #endif /* A_THREADSAFE */ #endif /* A_WORKAROUND_REQUIRE_PROPAGATION */ #define PTABLE_NAME ptable_seen #define PTABLE_NEED_DELETE 0 #define PTABLE_NEED_WALK 0 #include "ptable.h" /* PerlMemShared_free() needs the [ap]PTBLMS_? default values */ #define ptable_seen_store(T, K, V) ptable_seen_store(aPTBLMS_ (T), (K), (V)) #define ptable_seen_clear(T) ptable_seen_clear(aPTBLMS_ (T)) #define ptable_seen_free(T) ptable_seen_free(aPTBLMS_ (T)) #define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION typedef struct { peep_t old_peep; /* This is actually the rpeep past 5.13.5 */ ptable *seen; /* It really is a ptable_seen */ #if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION ptable *tbl; /* It really is a ptable_hints */ tTHX owner; #endif /* A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION */ } my_cxt_t; START_MY_CXT #if A_WORKAROUND_REQUIRE_PROPAGATION #if A_THREADSAFE typedef struct { ptable *tbl; #if A_HAS_PERL(5, 13, 2) CLONE_PARAMS *params; #else CLONE_PARAMS params; #endif } a_ptable_clone_ud; #if A_HAS_PERL(5, 13, 2) # define a_ptable_clone_ud_init(U, T, O) \ (U).tbl = (T); \ (U).params = Perl_clone_params_new((O), aTHX) # define a_ptable_clone_ud_deinit(U) Perl_clone_params_del((U).params) # define a_dup_inc(S, U) SvREFCNT_inc(sv_dup((S), (U)->params)) #else # define a_ptable_clone_ud_init(U, T, O) \ (U).tbl = (T); \ (U).params.stashes = newAV(); \ (U).params.flags = 0; \ (U).params.proto_perl = (O) # define a_ptable_clone_ud_deinit(U) SvREFCNT_dec((U).params.stashes) # define a_dup_inc(S, U) SvREFCNT_inc(sv_dup((S), &((U)->params))) #endif static void a_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) { a_ptable_clone_ud *ud = ud_; a_hint_t *h1 = ent->val; a_hint_t *h2; h2 = PerlMemShared_malloc(sizeof *h2); h2->bits = h1->bits; h2->require_tag = PTR2IV(a_dup_inc(INT2PTR(SV *, h1->require_tag), ud)); ptable_hints_store(ud->tbl, ent->key, h2); } #endif /* A_THREADSAFE */ static IV a_require_tag(pTHX) { #define a_require_tag() a_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 PTR2IV(cv); } static SV *a_tag(pTHX_ UV bits) { #define a_tag(B) a_tag(aTHX_ (B)) a_hint_t *h; #if A_THREADSAFE dMY_CXT; if (!MY_CXT.tbl) return newSViv(0); #endif /* A_THREADSAFE */ h = PerlMemShared_malloc(sizeof *h); h->bits = bits; h->require_tag = a_require_tag(); #if A_THREADSAFE /* 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. */ ptable_hints_store(MY_CXT.tbl, h, h); #endif /* A_THREADSAFE */ return newSViv(PTR2IV(h)); } static UV a_detag(pTHX_ const SV *hint) { #define a_detag(H) a_detag(aTHX_ (H)) a_hint_t *h; #if A_THREADSAFE dMY_CXT; if (!MY_CXT.tbl) return 0; #endif /* A_THREADSAFE */ if (!(hint && SvIOK(hint))) return 0; h = INT2PTR(a_hint_t *, SvIVX(hint)); #if A_THREADSAFE h = ptable_fetch(MY_CXT.tbl, h); #endif /* A_THREADSAFE */ if (a_require_tag() != h->require_tag) return 0; return h->bits; } #else /* A_WORKAROUND_REQUIRE_PROPAGATION */ #define a_tag(B) newSVuv(B) /* PVs fetched from the hints chain have their SvLEN set to zero, so get the UV * from a copy. */ #define a_detag(H) \ ((H) \ ? (SvIOK(H) \ ? SvUVX(H) \ : (SvPOK(H) \ ? sv_2uv(SvLEN(H) ? (H) : sv_mortalcopy(H)) \ : 0 \ ) \ ) \ : 0) #endif /* !A_WORKAROUND_REQUIRE_PROPAGATION */ /* 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_EXISTS 16 #define A_HINT_DELETE 32 #define A_HINT_NOTIFY (A_HINT_STRICT|A_HINT_WARN) #define A_HINT_DO (A_HINT_FETCH|A_HINT_STORE|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 64 #define A_HINT_DEREF 128 static VOL U32 a_hash = 0; static UV a_hint(pTHX) { #define a_hint() a_hint(aTHX) SV *hint; #ifdef cop_hints_fetch_pvn hint = cop_hints_fetch_pvn(PL_curcop, __PACKAGE__, __PACKAGE_LEN__, a_hash, 0); #elif A_HAS_PERL(5, 9, 5) hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, NULL, __PACKAGE__, __PACKAGE_LEN__, 0, a_hash); #else SV **val = hv_fetch(GvHV(PL_hintgv), __PACKAGE__, __PACKAGE_LEN__, 0); if (!val) return 0; hint = *val; #endif return a_detag(hint); } /* ... 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) PerlMemShared_free(V) #define PTABLE_NEED_DELETE 1 #define PTABLE_NEED_WALK 0 #include "ptable.h" /* PerlMemShared_free() needs the [ap]PTBLMS_? default values */ #define ptable_map_store(T, K, V) ptable_map_store(aPTBLMS_ (T), (K), (V)) #define ptable_map_delete(T, K) ptable_map_delete(aPTBLMS_ (T), (K)) #define ptable_map_free(T) ptable_map_free(aPTBLMS_ (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; #define A_LOCK(M) MUTEX_LOCK(M) #define A_UNLOCK(M) MUTEX_UNLOCK(M) static const a_op_info *a_map_fetch(const OP *o, a_op_info *oi) { const a_op_info *val; A_LOCK(&a_op_map_mutex); val = ptable_fetch(a_op_map, o); if (val) { *oi = *val; val = oi; } A_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_LOCK(M) NOOP #define A_UNLOCK(M) NOOP #define a_map_fetch(O) ptable_fetch(a_op_map, (O)) #endif /* !USE_ITHREADS */ static const a_op_info *a_map_store_locked(pPTBLMS_ const OP *o, OP *(*old_pp)(pTHX), void *next, UV flags) { #define a_map_store_locked(O, PP, N, F) a_map_store_locked(aPTBLMS_ (O), (PP), (N), (F)) a_op_info *oi; if (!(oi = ptable_fetch(a_op_map, o))) { oi = PerlMemShared_malloc(sizeof *oi); 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(pPTBLMS_ const OP *o, OP *(*old_pp)(pTHX), void *next, UV flags) { #define a_map_store(O, PP, N, F) a_map_store(aPTBLMS_ (O), (PP), (N), (F)) A_LOCK(&a_op_map_mutex); a_map_store_locked(o, old_pp, next, flags); A_UNLOCK(&a_op_map_mutex); } static void a_map_delete(pTHX_ const OP *o) { #define a_map_delete(O) a_map_delete(aTHX_ (O)) A_LOCK(&a_op_map_mutex); ptable_map_delete(a_op_map, o); A_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(pPTBLMS_ const OP *root, OP *(*old_pp)(pTHX), UV flags) { #define a_map_store_root(R, PP, F) a_map_store_root(aPTBLMS_ (R), (PP), (F)) const a_op_info *roi; a_op_info *oi; const OP *o = root; A_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; } } A_UNLOCK(&a_op_map_mutex); return; } static void a_map_update_flags_topdown(const OP *root, UV flags) { a_op_info *oi; const OP *o = root; A_LOCK(&a_op_map_mutex); flags &= ~A_HINT_ROOT; do { if ((oi = ptable_fetch(a_op_map, o))) oi->flags = (oi->flags & A_HINT_ROOT) | flags; if (!(o->op_flags & OPf_KIDS)) break; o = a_map_descend(o); } while (o); A_UNLOCK(&a_op_map_mutex); return; } #define a_map_cancel(R) a_map_update_flags_topdown((R), 0) static void a_map_update_flags_bottomup(const OP *o, UV flags, UV rflags) { a_op_info *oi; A_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; A_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) flags = (A_HINT_FETCH|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); } /* ... 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; 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); 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); 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); 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; 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); 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); 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); 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; 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); 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; bool enabled = FALSE; 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_FETCH; break; case OP_VALUES: old_ck = a_old_ck_values; new_pp = a_pp_root_unop; enabled = hint & A_HINT_FETCH; break; } o = old_ck(aTHX_ o); if (hint & A_HINT_DO) { if (enabled) { a_map_update_flags_topdown(o, hint | A_HINT_DEREF); a_map_store_root(o, o->op_ppaddr, hint); o->op_ppaddr = new_pp; } else { a_map_cancel(o); } } else a_map_delete(o); return o; } /* ... Our peephole optimizer .............................................. */ static void a_peep_rec(pTHX_ OP *o, ptable *seen); static void a_peep_rec(pTHX_ OP *o, ptable *seen) { #define a_peep_rec(O) a_peep_rec(aTHX_ (O), seen) for (; o; o = o->op_next) { dA_MAP_THX; const a_op_info *oi = NULL; UV flags = 0; #if !A_HAS_RPEEP if (ptable_fetch(seen, o)) break; ptable_seen_store(seen, o, o); #endif switch (o->op_type) { #if A_HAS_RPEEP case OP_NEXTSTATE: case OP_DBSTATE: case OP_STUB: case OP_UNSTACK: if (ptable_fetch(seen, o)) return; ptable_seen_store(seen, o, o); break; #endif 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: case OP_RV2HV: if ( o->op_ppaddr != a_pp_rv2av && 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_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 #if !A_HAS_RPEEP 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 A_HAS_PERL(5, 10, 0) case OP_ONCE: case OP_DOR: case OP_DORASSIGN: # endif a_peep_rec(cLOGOPo->op_other); break; case OP_ENTERLOOP: case OP_ENTERITER: a_peep_rec(cLOOPo->op_redoop); a_peep_rec(cLOOPo->op_nextop); a_peep_rec(cLOOPo->op_lastop); break; # if A_HAS_PERL(5, 9, 5) case OP_SUBST: a_peep_rec(cPMOPo->op_pmstashstartu.op_pmreplstart); break; # else case OP_QR: case OP_MATCH: case OP_SUBST: a_peep_rec(cPMOPo->op_pmreplstart); break; # endif #endif /* !A_HAS_RPEEP */ default: break; } } } static void a_peep(pTHX_ OP *o) { ptable *seen; dMY_CXT; assert(a_is_loaded(&MY_CXT)); MY_CXT.old_peep(aTHX_ o); seen = MY_CXT.seen; if (seen) { ptable_seen_clear(seen); a_peep_rec(o); ptable_seen_clear(seen); } } /* --- Module setup/teardown ----------------------------------------------- */ static void a_teardown(pTHX_ void *root) { dMY_CXT; A_LOADED_LOCK; if (a_clear_loaded_locked(&MY_CXT)) { a_ck_restore(OP_PADANY, &a_old_ck_padany); a_ck_restore(OP_PADSV, &a_old_ck_padsv); a_ck_restore(OP_AELEM, &a_old_ck_aelem); a_ck_restore(OP_HELEM, &a_old_ck_helem); a_ck_restore(OP_RV2SV, &a_old_ck_rv2sv); a_ck_restore(OP_RV2AV, &a_old_ck_rv2av); a_ck_restore(OP_RV2HV, &a_old_ck_rv2hv); a_ck_restore(OP_ASLICE, &a_old_ck_aslice); a_ck_restore(OP_HSLICE, &a_old_ck_hslice); a_ck_restore(OP_EXISTS, &a_old_ck_exists); a_ck_restore(OP_DELETE, &a_old_ck_delete); a_ck_restore(OP_KEYS, &a_old_ck_keys); a_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 } A_LOADED_UNLOCK; if (MY_CXT.old_peep) { #if A_HAS_RPEEP PL_rpeepp = MY_CXT.old_peep; #else PL_peepp = MY_CXT.old_peep; #endif MY_CXT.old_peep = 0; } ptable_seen_free(MY_CXT.seen); MY_CXT.seen = NULL; #if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION ptable_hints_free(MY_CXT.tbl); MY_CXT.tbl = NULL; #endif /* A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION */ return; } static void a_setup(pTHX) { #define a_setup() a_setup(aTHX) MY_CXT_INIT; /* Takes/release PL_my_ctx_mutex */ A_LOADED_LOCK; if (a_set_loaded_locked(&MY_CXT)) { PERL_HASH(a_hash, __PACKAGE__, __PACKAGE_LEN__); a_op_map = ptable_new(); #ifdef USE_ITHREADS MUTEX_INIT(&a_op_map_mutex); #endif a_ck_replace(OP_PADANY, a_ck_padany, &a_old_ck_padany); a_ck_replace(OP_PADSV, a_ck_padsv, &a_old_ck_padsv); a_ck_replace(OP_AELEM, a_ck_deref, &a_old_ck_aelem); a_ck_replace(OP_HELEM, a_ck_deref, &a_old_ck_helem); a_ck_replace(OP_RV2SV, a_ck_deref, &a_old_ck_rv2sv); a_ck_replace(OP_RV2AV, a_ck_rv2xv, &a_old_ck_rv2av); a_ck_replace(OP_RV2HV, a_ck_rv2xv, &a_old_ck_rv2hv); a_ck_replace(OP_ASLICE, a_ck_xslice, &a_old_ck_aslice); a_ck_replace(OP_HSLICE, a_ck_xslice, &a_old_ck_hslice); a_ck_replace(OP_EXISTS, a_ck_root, &a_old_ck_exists); a_ck_replace(OP_DELETE, a_ck_root, &a_old_ck_delete); a_ck_replace(OP_KEYS, a_ck_root, &a_old_ck_keys); a_ck_replace(OP_VALUES, a_ck_root, &a_old_ck_values); } A_LOADED_UNLOCK; { HV *stash; stash = gv_stashpvn(__PACKAGE__, __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_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(A_THREADSAFE)); newCONSTSUB(stash, "A_FORKSAFE", newSVuv(A_FORKSAFE)); } #if A_HAS_RPEEP if (PL_rpeepp != a_peep) { MY_CXT.old_peep = PL_rpeepp; PL_rpeepp = a_peep; } #else if (PL_peepp != a_peep) { MY_CXT.old_peep = PL_peepp; PL_peepp = a_peep; } #endif else { MY_CXT.old_peep = 0; } MY_CXT.seen = ptable_new(); #if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION MY_CXT.tbl = ptable_new(); MY_CXT.owner = aTHX; #endif /* A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION */ call_atexit(a_teardown, NULL); return; } /* --- XS ------------------------------------------------------------------ */ MODULE = autovivification PACKAGE = autovivification PROTOTYPES: ENABLE BOOT: { a_setup(); } #if A_THREADSAFE void CLONE(...) PROTOTYPE: DISABLE PREINIT: #if A_WORKAROUND_REQUIRE_PROPAGATION ptable *t; #endif PPCODE: #if A_WORKAROUND_REQUIRE_PROPAGATION { a_ptable_clone_ud ud; dMY_CXT; t = ptable_new(); a_ptable_clone_ud_init(ud, t, MY_CXT.owner); ptable_walk(MY_CXT.tbl, a_ptable_clone, &ud); a_ptable_clone_ud_deinit(ud); } #endif { MY_CXT_CLONE; #if A_WORKAROUND_REQUIRE_PROPAGATION MY_CXT.tbl = t; MY_CXT.owner = aTHX; #endif MY_CXT.seen = ptable_new(); { int global_setup; A_LOADED_LOCK; global_setup = a_set_loaded_locked(&MY_CXT); assert(!global_setup); A_LOADED_UNLOCK; } } XSRETURN(0); #endif /* A_THREADSAFE */ SV * _tag(SV *hint) PROTOTYPE: $ CODE: RETVAL = a_tag(SvOK(hint) ? SvUV(hint) : 0); OUTPUT: RETVAL SV * _detag(SV *tag) PROTOTYPE: $ CODE: if (!SvOK(tag)) XSRETURN_UNDEF; RETVAL = newSVuv(a_detag(tag)); OUTPUT: RETVAL autovivification-0.16/Changes000644 000765 000024 00000017134 12544767370 017154 0ustar00vincentstaff000000 000000 Revision history for autovivification 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.16/lib/000755 000765 000024 00000000000 12544767601 016416 5ustar00vincentstaff000000 000000 autovivification-0.16/Makefile.PL000644 000765 000024 00000006124 12525135666 017624 0ustar00vincentstaff000000 000000 use 5.008_003; use strict; use warnings; use ExtUtils::MakeMaker; use Config; 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, '-DA_MULTIPLICITY=0'; } # Fork emulation got "fixed" in 5.10.1 if ($^O eq 'MSWin32' && "$]" < 5.010_001) { push @DEFINES, '-DA_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.16/MANIFEST000644 000765 000024 00000001661 12525135666 017004 0ustar00vincentstaff000000 000000 Changes MANIFEST META.json META.yml Makefile.PL README autovivification.xs lib/autovivification.pm ptable.h 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 autovivification-0.16/META.json000644 000765 000024 00000002753 12544767601 017300 0ustar00vincentstaff000000 000000 { "abstract" : "Lexically disable autovivification.", "author" : [ "Vincent Pit " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150005", "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.16", "x_serialization_backend" : "JSON::PP version 2.27300" } autovivification-0.16/META.yml000644 000765 000024 00000001636 12544767601 017127 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.0401, CPAN::Meta::Converter version 2.150005' 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.16' x_serialization_backend: 'CPAN::Meta::YAML version 0.016' autovivification-0.16/ptable.h000644 000765 000024 00000013612 12525135666 017272 0ustar00vincentstaff000000 000000 /* This file is part of the autovivification Perl module. * See http://search.cpan.org/dist/autovivification/ */ /* 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_FREE(). */ #undef VOID2 #ifdef __cplusplus # define VOID2(T, P) static_cast(P) #else # define VOID2(T, P) (P) #endif #undef pPTBLMS #undef pPTBLMS_ #undef aPTBLMS #undef aPTBLMS_ /* Context for PerlMemShared_* functions */ #ifdef PERL_IMPLICIT_SYS # define pPTBLMS pTHX # define pPTBLMS_ pTHX_ # define aPTBLMS aTHX # define aPTBLMS_ aTHX_ #else # define pPTBLMS void # define pPTBLMS_ # define aPTBLMS # define aPTBLMS_ #endif #ifndef pPTBL # define pPTBL pPTBLMS #endif #ifndef pPTBL_ # define pPTBL_ pPTBLMS_ #endif #ifndef aPTBL # define aPTBL aPTBLMS #endif #ifndef aPTBL_ # define aPTBL_ aPTBLMS_ #endif #ifndef PTABLE_NAME # define PTABLE_NAME ptable #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_DELETE # define PTABLE_NEED_DELETE 1 #endif #ifndef PTABLE_NEED_WALK # define PTABLE_NEED_WALK 1 #endif #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 */ #ifndef ptable_new static ptable *ptable_new(pPTBLMS) { #define ptable_new() ptable_new(aPTBLMS) ptable *t = VOID2(ptable *, PerlMemShared_malloc(sizeof *t)); t->max = 63; t->items = 0; t->ary = VOID2(ptable_ent **, PerlMemShared_calloc(t->max + 1, sizeof *t->ary)); return t; } #endif /* !ptable_new */ #ifndef PTABLE_HASH # define PTABLE_HASH(ptr) \ ((PTR2UV(ptr) >> 3) ^ (PTR2UV(ptr) >> (3 + 7)) ^ (PTR2UV(ptr) >> (3 + 17))) #endif #ifndef ptable_find static ptable_ent *ptable_find(const ptable * const t, const void * const key) { #define ptable_find ptable_find ptable_ent *ent; const UV hash = PTABLE_HASH(key); ent = t->ary[hash & t->max]; for (; ent; ent = ent->next) { if (ent->key == key) return ent; } return NULL; } #endif /* !ptable_find */ #ifndef ptable_fetch static void *ptable_fetch(const ptable * const t, const void * const key) { #define ptable_fetch ptable_fetch const ptable_ent *const ent = ptable_find(t, key); return ent ? ent->val : NULL; } #endif /* !ptable_fetch */ #ifndef ptable_split static void ptable_split(pPTBLMS_ ptable * const t) { #define ptable_split(T) ptable_split(aPTBLMS_ (T)) ptable_ent **ary = t->ary; const size_t oldsize = t->max + 1; size_t newsize = oldsize * 2; size_t i; ary = VOID2(ptable_ent **, PerlMemShared_realloc(ary, newsize * sizeof(*ary))); Zero(&ary[oldsize], newsize - oldsize, sizeof(*ary)); t->max = --newsize; t->ary = ary; for (i = 0; i < oldsize; i++, ary++) { ptable_ent **curentp, **entp, *ent; if (!*ary) continue; curentp = ary + oldsize; for (entp = ary, ent = *ary; ent; ent = *entp) { if ((newsize & PTABLE_HASH(ent->key)) != i) { *entp = ent->next; ent->next = *curentp; *curentp = ent; continue; } else entp = &ent->next; } } } #endif /* !ptable_split */ static void PTABLE_PREFIX(_store)(pPTBL_ ptable * const t, const void * const key, void * const val) { ptable_ent *ent = ptable_find(t, key); if (ent) { #ifdef PTABLE_VAL_FREE void *oldval = ent->val; PTABLE_VAL_FREE(oldval); #endif ent->val = val; } else if (val) { const size_t i = PTABLE_HASH(key) & t->max; ent = VOID2(ptable_ent *, PerlMemShared_malloc(sizeof *ent)); ent->key = key; ent->val = val; ent->next = t->ary[i]; t->ary[i] = ent; t->items++; if (ent->next && t->items > t->max) ptable_split(t); } } #if PTABLE_NEED_DELETE static void PTABLE_PREFIX(_delete)(pPTBL_ ptable * const t, const void * const key) { ptable_ent *prev, *ent; const size_t i = PTABLE_HASH(key) & t->max; prev = NULL; ent = t->ary[i]; for (; ent; prev = ent, ent = ent->next) { if (ent->key == key) break; } if (ent) { if (prev) prev->next = ent->next; else t->ary[i] = ent->next; #ifdef PTABLE_VAL_FREE PTABLE_VAL_FREE(ent->val); #endif PerlMemShared_free(ent); } } #endif /* PTABLE_NEED_DELETE */ #if PTABLE_NEED_WALK && !defined(ptable_walk) static void ptable_walk(pTHX_ ptable * const 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 ** const 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_NEED_WALK && !defined(ptable_walk) */ static void PTABLE_PREFIX(_clear)(pPTBL_ ptable * const t) { if (t && t->items) { register ptable_ent ** const array = t->ary; size_t i = t->max; do { ptable_ent *entry = array[i]; while (entry) { ptable_ent * const nentry = entry->next; #ifdef PTABLE_VAL_FREE PTABLE_VAL_FREE(entry->val); #endif PerlMemShared_free(entry); entry = nentry; } array[i] = NULL; } while (i--); t->items = 0; } } static void PTABLE_PREFIX(_free)(pPTBL_ ptable * const t) { if (!t) return; PTABLE_PREFIX(_clear)(aPTBL_ t); PerlMemShared_free(t->ary); PerlMemShared_free(t); } #undef pPTBL #undef pPTBL_ #undef aPTBL #undef aPTBL_ #undef PTABLE_NAME #undef PTABLE_VAL_FREE #undef PTABLE_NEED_DELETE #undef PTABLE_NEED_WALK autovivification-0.16/README000644 000765 000024 00000015057 12544767601 016540 0ustar00vincentstaff000000 000000 NAME autovivification - Lexically disable autovivification. VERSION Version 0.16 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'; no autovivification 'strict'; 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. * 'strict' Throws an exception when an autovivification is avoided. 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 Tests code coverage report is available at . ACKNOWLEDGEMENTS Matt S. Trout asked for it. COPYRIGHT & LICENSE Copyright 2009,2010,2011,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. autovivification-0.16/samples/000755 000765 000024 00000000000 12544767601 017314 5ustar00vincentstaff000000 000000 autovivification-0.16/t/000755 000765 000024 00000000000 12544767601 016113 5ustar00vincentstaff000000 000000 autovivification-0.16/t/00-load.t000644 000765 000024 00000000270 12416743316 017426 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.16/t/09-load-threads.t000644 000765 000024 00000017367 12525135666 021112 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 ( tests => 1 + (2 + 2 * 2) + 6 + (2 * 4 + 1) * 2 + (4 + 1) + (6 + 1) + 1 ); 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 $locks_up[$id]; cond_wait $locks_up[$id] until $locks_up[$id] == $peers; } } 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]; } } 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; }); 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; }); 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_tid; share($kid_tid); my $kid_done; share($kid_done); my $parent = spawn(sub { my $here = 'outliving clone, parent thread'; is_loaded 0, "$here, beginning"; my $no_kid; do_load; is_loaded 1, "$here, after loading"; SKIP: { my $kid = spawn(sub { my $here = 'outliving clone, child thread'; is_loaded 1, "$here, beginning"; { lock $kid_tid; $kid_tid = threads->tid(); cond_signal $kid_tid; } is_loaded 1, "$here, kid tid was communicated"; { lock $kid_done; cond_wait $kid_done until $kid_done; } is_loaded 1, "$here, end"; return; }); unless (defined $kid) { $no_kid = 1; skip "$could_not_create_thread (outliving clone child)" => 3; } } is_loaded 1, "$here, end"; return $no_kid; }); skip "$could_not_create_thread (outliving clone parent)" => (3 + 3) unless defined $parent; my $no_kid = $parent->join; if (my $err = $parent->error) { die $err; } unless ($no_kid) { my $tid = do { lock $kid_tid; cond_wait $kid_tid until defined $kid_tid; $kid_tid; }; my $kid = threads->object($tid); if (defined $kid) { { 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'; autovivification-0.16/t/20-hash.t000644 000765 000024 00000053544 12517507122 017443 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.16/t/22-hash-kv.t000644 000765 000024 00000007076 12416743316 020067 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.16/t/23-hash-tied.t000644 000765 000024 00000000737 12416743316 020372 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.16/t/24-hash-numerous.t000644 000765 000024 00000005224 12416743316 021317 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.16/t/30-array.t000644 000765 000024 00000055540 12416743316 017642 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.16/t/31-array-fast.t000644 000765 000024 00000050054 12416743316 020571 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.16/t/32-array-kv.t000644 000765 000024 00000006700 12416743316 020254 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.16/t/33-array-tied.t000644 000765 000024 00000000737 12416743316 020566 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.16/t/34-array-numerous.t000644 000765 000024 00000005134 12416743316 021513 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.16/t/40-scope.t000644 000765 000024 00000003547 12416743316 017636 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.16/t/41-padsv.t000644 000765 000024 00000000666 12416743316 017642 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.16/t/42-deparse.t000644 000765 000024 00000001040 12416743316 020134 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.16/t/43-peep.t000644 000765 000024 00000011244 12525135666 017456 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.16/t/44-multideref.t000644 000765 000024 00000005013 12525135666 020663 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.16/t/50-threads.t000644 000765 000024 00000003152 12525135666 020154 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(scalar(@threads) * $runs * 3 * (1 + 2) + 1); autovivification-0.16/t/51-threads-teardown.t000644 000765 000024 00000002470 12525135666 022000 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.16/t/lib/000755 000765 000024 00000000000 12544767601 016661 5ustar00vincentstaff000000 000000 autovivification-0.16/t/lib/autovivification/000755 000765 000024 00000000000 12544767601 022244 5ustar00vincentstaff000000 000000 autovivification-0.16/t/lib/Test/000755 000765 000024 00000000000 12544767601 017600 5ustar00vincentstaff000000 000000 autovivification-0.16/t/lib/VPIT/000755 000765 000024 00000000000 12544767601 017443 5ustar00vincentstaff000000 000000 autovivification-0.16/t/lib/VPIT/TestHelpers.pm000644 000765 000024 00000034144 12544646722 022251 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 $glob ? *$glob{CODE} : 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 : none =item * Exports : =over 8 =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); return ( run_perl => \&run_perl, "${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; }; } =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 =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; 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', [ ]; 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.16/t/lib/Test/Leaner.pm000644 000765 000024 00000045374 12416743316 021354 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.16/t/lib/autovivification/TestCases.pm000644 000765 000024 00000005665 12517714724 024512 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.16/t/lib/autovivification/TestRequired1.pm000644 000765 000024 00000000214 12416743316 025273 0ustar00vincentstaff000000 000000 package autovivification::TestRequired1; my $x = $main::blurp->{r1_main}->{vivify}; eval 'my $y = $main::blurp->{r1_eval}->{vivify}'; 1; autovivification-0.16/t/lib/autovivification/TestRequired2.pm000644 000765 000024 00000000427 12416743316 025302 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.16/t/lib/autovivification/TestRequired4/000755 000765 000024 00000000000 12544767601 024750 5ustar00vincentstaff000000 000000 autovivification-0.16/t/lib/autovivification/TestRequired5/000755 000765 000024 00000000000 12544767601 024751 5ustar00vincentstaff000000 000000 autovivification-0.16/t/lib/autovivification/TestRequired6.pm000644 000765 000024 00000000237 12416743316 025305 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.16/t/lib/autovivification/TestRequired5/a0.pm000644 000765 000024 00000000317 12416743316 025603 0ustar00vincentstaff000000 000000 package autovivification::TestRequired5::a0; no autovivification qw; use autovivification::TestRequired5::b0; sub error { local $@; autovivification::TestRequired5::b0->get; return $@; } 1; autovivification-0.16/t/lib/autovivification/TestRequired5/b0.pm000644 000765 000024 00000000161 12416743316 025601 0ustar00vincentstaff000000 000000 package autovivification::TestRequired5::b0; sub get { eval 'require autovivification::TestRequired5::c0'; } 1; autovivification-0.16/t/lib/autovivification/TestRequired5/c0.pm000644 000765 000024 00000000135 12416743316 025603 0ustar00vincentstaff000000 000000 package autovivification::TestRequired5::c0; require autovivification::TestRequired5::d0; 1; autovivification-0.16/t/lib/autovivification/TestRequired5/d0.pm000644 000765 000024 00000000112 12416743316 025577 0ustar00vincentstaff000000 000000 package autovivification::TestRequired5::d0; my $x; my $y = $x->{foo}; 1; autovivification-0.16/t/lib/autovivification/TestRequired4/a0.pm000644 000765 000024 00000000317 12416743316 025602 0ustar00vincentstaff000000 000000 package autovivification::TestRequired4::a0; no autovivification qw; use autovivification::TestRequired4::b0; sub error { local $@; autovivification::TestRequired4::b0->get; return $@; } 1; autovivification-0.16/t/lib/autovivification/TestRequired4/b0.pm000644 000765 000024 00000000161 12416743316 025600 0ustar00vincentstaff000000 000000 package autovivification::TestRequired4::b0; sub get { eval 'require autovivification::TestRequired4::c0'; } 1; autovivification-0.16/t/lib/autovivification/TestRequired4/c0.pm000644 000765 000024 00000000112 12416743316 025575 0ustar00vincentstaff000000 000000 package autovivification::TestRequired4::c0; my $x; my $y = $x->{foo}; 1; autovivification-0.16/samples/bench.pl000644 000765 000024 00000003736 12416743316 020734 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.16/samples/hash2array.pl000644 000765 000024 00000004426 12416743316 021716 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.16/lib/autovivification.pm000644 000765 000024 00000016055 12544767475 022357 0ustar00vincentstaff000000 000000 package autovivification; use 5.008_003; use strict; use warnings; =head1 NAME autovivification - Lexically disable autovivification. =head1 VERSION Version 0.16 =cut our $VERSION; BEGIN { $VERSION = '0.16'; } =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'; no autovivification 'strict'; 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. =item * C<'strict'> Throws an exception when an autovivification is avoided. =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, 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 Tests code coverage report is available at L. =head1 ACKNOWLEDGEMENTS Matt S. Trout asked for it. =head1 COPYRIGHT & LICENSE Copyright 2009,2010,2011,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; # End of autovivification