X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=autovivification.xs;h=14189ce31e6c6c0ab63c9e9faa0823acbe51b735;hb=0180a2a0145e8f56b355b156b66ad1c188dc7214;hp=e038c73130bb25d40902274004a8de83bd831584;hpb=dd3a6d85ebe187448b6c808f9c0e173c01b5c1ad;p=perl%2Fmodules%2Fautovivification.git

diff --git a/autovivification.xs b/autovivification.xs
index e038c73..14189ce 100644
--- a/autovivification.xs
+++ b/autovivification.xs
@@ -41,6 +41,55 @@
 # endif
 #endif
 
+#ifdef DEBUGGING
+# define A_ASSERT(C) assert(C)
+#else
+# define A_ASSERT(C)
+#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 */
@@ -114,9 +163,9 @@
 # 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. */
+/* Before perl 5.9.3, a_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
@@ -188,13 +237,13 @@ static int a_set_loaded_locked(pTHX_ void *cxt) {
  int global_setup = 0;
 
  if (a_loaded <= 0) {
-  assert(a_loaded == 0);
-  assert(!a_loaded_cxts);
+  A_ASSERT(a_loaded == 0);
+  A_ASSERT(!a_loaded_cxts);
   a_loaded_cxts = ptable_new();
   global_setup  = 1;
  }
  ++a_loaded;
- assert(a_loaded_cxts);
+ A_ASSERT(a_loaded_cxts);
  ptable_loaded_store(a_loaded_cxts, cxt, cxt);
 
  return global_setup;
@@ -205,11 +254,11 @@ static int a_clear_loaded_locked(pTHX_ void *cxt) {
  int global_teardown = 0;
 
  if (a_loaded > 1) {
-  assert(a_loaded_cxts);
+  A_ASSERT(a_loaded_cxts);
   ptable_loaded_delete(a_loaded_cxts, cxt);
   --a_loaded;
  } else if (a_loaded_cxts) {
-  assert(a_loaded == 1);
+  A_ASSERT(a_loaded == 1);
   ptable_loaded_free(a_loaded_cxts);
   a_loaded_cxts   = NULL;
   a_loaded        = 0;
@@ -491,6 +540,7 @@ typedef struct {
 /* 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;
 
@@ -875,7 +925,7 @@ static OP *a_pp_root_binop(pTHX) {
 static UV a_do_multideref(const OP *o, UV flags) {
  UV isexdel, other_flags;
 
- assert(o->op_type == OP_MULTIDEREF);
+ A_ASSERT(o->op_type == OP_MULTIDEREF);
 
  other_flags = flags & ~A_HINT_DO;
 
@@ -978,7 +1028,7 @@ static OP *a_pp_multideref(pTHX) {
  {
   dA_MAP_THX;
   const a_op_info *oi = a_map_fetch(PL_op);
-  assert(oi);
+  A_ASSERT(oi);
   flags = a_do_multideref(PL_op, oi->flags);
   if (!flags)
    return oi->old_pp(aTHX);
@@ -1001,7 +1051,7 @@ static OP *a_pp_multideref(pTHX) {
     goto do_AV_aelem;
    case MDEREF_AV_gvav_aelem: /* $pkg[...] */
     sv = UNOP_AUX_item_sv(++items);
-    assert(isGV_with_GP(sv));
+    A_ASSERT(isGV_with_GP(sv));
     sv = (SV *) GvAVn((GV *) sv);
     if (a_undef(sv))
      goto ret_undef;
@@ -1013,7 +1063,7 @@ static OP *a_pp_multideref(pTHX) {
     goto do_AV_rv2av_aelem;
    case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */
     sv = UNOP_AUX_item_sv(++items);
-    assert(isGV_with_GP(sv));
+    A_ASSERT(isGV_with_GP(sv));
     sv = GvSVn((GV *) sv);
     if (a_undef(sv))
      goto ret_undef;
@@ -1025,13 +1075,13 @@ static OP *a_pp_multideref(pTHX) {
     if (a_undef(sv))
      goto ret_undef;
 do_AV_vivify_rv2av_aelem:
-    sv = Perl_vivify_ref(aTHX_ sv, OPpDEREF_AV);
+    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);
+     A_ASSERT(SvTYPE(sv) == SVt_PVAV);
      switch (actions & MDEREF_INDEX_MASK) {
       case MDEREF_INDEX_none:
        goto finish;
@@ -1043,7 +1093,7 @@ do_AV_aelem:
        goto check_elem;
       case MDEREF_INDEX_gvsv:
        esv = UNOP_AUX_item_sv(++items);
-       assert(isGV_with_GP(esv));
+       A_ASSERT(isGV_with_GP(esv));
        esv = GvSVn((GV *) esv);
 check_elem:
        if (UNLIKELY(SvROK(esv) && !SvGAMAGIC(esv) && ckWARN(WARN_MISC)))
@@ -1080,7 +1130,7 @@ check_elem:
     goto do_HV_helem;
    case MDEREF_HV_gvhv_helem: /* $pkg{...} */
     sv = UNOP_AUX_item_sv(++items);
-    assert(isGV_with_GP(sv));
+    A_ASSERT(isGV_with_GP(sv));
     sv = (SV *) GvHVn((GV *) sv);
     if (a_undef(sv))
      goto ret_undef;
@@ -1092,7 +1142,7 @@ check_elem:
     goto do_HV_rv2hv_helem;
    case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */
     sv = UNOP_AUX_item_sv(++items);
-    assert(isGV_with_GP(sv));
+    A_ASSERT(isGV_with_GP(sv));
     sv = GvSVn((GV *) sv);
     if (a_undef(sv))
      goto ret_undef;
@@ -1104,13 +1154,13 @@ check_elem:
     if (a_undef(sv))
      goto ret_undef;
 do_HV_vivify_rv2hv_helem:
-    sv = Perl_vivify_ref(aTHX_ sv, OPpDEREF_HV);
+    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);
+     A_ASSERT(SvTYPE(sv) == SVt_PVHV);
      switch (actions & MDEREF_INDEX_MASK) {
       case MDEREF_INDEX_none:
        goto finish;
@@ -1122,7 +1172,7 @@ do_HV_helem:
        break;
       case MDEREF_INDEX_gvsv:
        key = UNOP_AUX_item_sv(++items);
-       assert(isGV_with_GP(key));
+       A_ASSERT(isGV_with_GP(key));
        key = GvSVn((GV *) key);
        break;
      }
@@ -1134,7 +1184,7 @@ do_HV_helem:
         break;
        case A_HINT_STORE:
         sv = a_do_pp_hfetch_lv(sv, key);
-	break;
+        break;
        case A_HINT_EXISTS:
         sv = a_do_pp_hexists(sv, key);
         break;
@@ -1258,14 +1308,19 @@ static OP *a_ck_deref(pTHX_ OP *o) {
  }
  o = old_ck(aTHX_ o);
 
- if (hint & A_HINT_DO) {
 #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 (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
@@ -1524,7 +1579,7 @@ static void a_peep(pTHX_ OP *o) {
  ptable *seen;
  dMY_CXT;
 
- assert(a_is_loaded(&MY_CXT));
+ A_ASSERT(a_is_loaded(&MY_CXT));
 
  MY_CXT.old_peep(aTHX_ o);
 
@@ -1564,6 +1619,10 @@ static void a_teardown(pTHX_ void *root) {
 
   ptable_map_free(a_op_map);
   a_op_map = NULL;
+
+#ifdef USE_ITHREADS
+  MUTEX_DESTROY(&a_op_map_mutex);
+#endif
  }
 
  A_LOADED_UNLOCK;
@@ -1598,6 +1657,7 @@ static void a_setup(pTHX) {
   PERL_HASH(a_hash, __PACKAGE__, __PACKAGE_LEN__);
 
   a_op_map = ptable_new();
+
 #ifdef USE_ITHREADS
   MUTEX_INIT(&a_op_map_mutex);
 #endif
@@ -1707,7 +1767,7 @@ PPCODE:
    int global_setup;
    A_LOADED_LOCK;
    global_setup = a_set_loaded_locked(&MY_CXT);
-   assert(!global_setup);
+   A_ASSERT(!global_setup);
    A_LOADED_UNLOCK;
   }
  }