This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
fix ExtUtils-ParseXS/t/*.t that needed '.' in @INC
[perl5.git] / hv.c
diff --git a/hv.c b/hv.c
index 338b17e..85e42d1 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -80,7 +80,8 @@ S_save_hek_flags(const char *str, I32 len, U32 hash, int flags)
     HEK *hek;
 
     PERL_ARGS_ASSERT_SAVE_HEK_FLAGS;
-    Newx(k, HEK_BASESIZE + len + 1, char);
+
+    Newx(k, HEK_BASESIZE + len + 2, char);
     hek = (HEK*)k;
     Copy(str, HEK_KEY(hek), len, char);
     HEK_KEY(hek)[len] = 0;
@@ -389,7 +390,7 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
            flags = is_utf8 ? HVhek_UTF8 : 0;
        }
     } else {
-       is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
+       is_utf8 = cBOOL(flags & HVhek_UTF8);
     }
 
     if (action & HV_DELETE) {
@@ -765,7 +766,7 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
 
     if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) {
        hv_notallowed(flags, key, klen,
-                       "Attempt to access disallowed key '%"SVf"' in"
+                       "Attempt to access disallowed key '%" SVf "' in"
                        " a restricted hash");
     }
     if (!(action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE))) {
@@ -989,7 +990,7 @@ Perl_hv_bucket_ratio(pTHX_ HV *hv)
     }
 
     sv = sv_newmortal();
-    if (HvUSEDKEYS((const HV *)hv))
+    if (HvUSEDKEYS((HV *)hv))
         Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
                 (long)HvFILL(hv), (long)HvMAX(hv) + 1);
     else
@@ -1028,7 +1029,7 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
     HE *entry;
     HE **oentry;
     HE **first_entry;
-    bool is_utf8 = (k_flags & HVhek_UTF8) ? TRUE : FALSE;
+    bool is_utf8 = cBOOL(k_flags & HVhek_UTF8);
     int masked_flags;
     HEK *keysv_hek = NULL;
     U8 mro_changes = 0; /* 1 = isa; 2 = package moved */
@@ -1167,7 +1168,7 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
        }
        if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
            hv_notallowed(k_flags, key, klen,
-                           "Attempt to delete readonly key '%"SVf"' from"
+                           "Attempt to delete readonly key '%" SVf "' from"
                            " a restricted hash");
        }
         if (k_flags & HVhek_FREEKEY)
@@ -1316,7 +1317,7 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
   not_found:
     if (SvREADONLY(hv)) {
        hv_notallowed(k_flags, key, klen,
-                       "Attempt to delete disallowed key '%"SVf"' from"
+                       "Attempt to delete disallowed key '%" SVf "' from"
                        " a restricted hash");
     }
 
@@ -1696,6 +1697,8 @@ void
 Perl_hv_clear(pTHX_ HV *hv)
 {
     dVAR;
+    SSize_t orig_ix;
+
     XPVHV* xhv;
     if (!hv)
        return;
@@ -1704,8 +1707,10 @@ Perl_hv_clear(pTHX_ HV *hv)
 
     xhv = (XPVHV*)SvANY(hv);
 
-    ENTER;
-    SAVEFREESV(SvREFCNT_inc_simple_NN(hv));
+    /* avoid hv being freed when calling destructors below */
+    EXTEND_MORTAL(1);
+    PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(hv);
+    orig_ix = PL_tmps_ix;
     if (SvREADONLY(hv) && HvARRAY(hv) != NULL) {
        /* restricted hash: convert all keys to placeholders */
        STRLEN i;
@@ -1718,7 +1723,7 @@ Perl_hv_clear(pTHX_ HV *hv)
                        if (SvREADONLY(HeVAL(entry))) {
                            SV* const keysv = hv_iterkeysv(entry);
                            Perl_croak_nocontext(
-                               "Attempt to delete readonly key '%"SVf"' from a restricted hash",
+                               "Attempt to delete readonly key '%" SVf "' from a restricted hash",
                                (void*)keysv);
                        }
                        SvREFCNT_dec_NN(HeVAL(entry));
@@ -1743,7 +1748,12 @@ Perl_hv_clear(pTHX_ HV *hv)
             mro_isa_changed_in(hv);
        HvEITER_set(hv, NULL);
     }
-    LEAVE;
+    /* disarm hv's premature free guard */
+    if (LIKELY(PL_tmps_ix == orig_ix))
+        PL_tmps_ix--;
+    else
+        PL_tmps_stack[orig_ix] = &PL_sv_undef;
+    SvREFCNT_dec_NN(hv);
 }
 
 /*
@@ -1926,10 +1936,11 @@ Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags)
 {
     XPVHV* xhv;
     bool save;
+    SSize_t orig_ix;
 
     if (!hv)
        return;
-    save = !!SvREFCNT(hv);
+    save = cBOOL(SvREFCNT(hv));
     DEBUG_A(Perl_hv_assert(aTHX_ hv));
     xhv = (XPVHV*)SvANY(hv);
 
@@ -1946,14 +1957,16 @@ Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags)
     if (PL_phase != PERL_PHASE_DESTRUCT && HvNAME(hv)) {
         if (PL_stashcache) {
             DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for '%"
-                             HEKf"'\n", HEKfARG(HvNAME_HEK(hv))));
+                             HEKf "'\n", HEKfARG(HvNAME_HEK(hv))));
            (void)hv_deletehek(PL_stashcache, HvNAME_HEK(hv), G_DISCARD);
         }
        hv_name_set(hv, NULL, 0, 0);
     }
     if (save) {
-       ENTER;
-       SAVEFREESV(SvREFCNT_inc_simple_NN(hv));
+        /* avoid hv being freed when calling destructors below */
+        EXTEND_MORTAL(1);
+        PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(hv);
+        orig_ix = PL_tmps_ix;
     }
     hfreeentries(hv);
     if (SvOOK(hv)) {
@@ -1965,7 +1978,7 @@ Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags)
            mro_isa_changed_in(hv);
         if (PL_stashcache) {
             DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for effective name '%"
-                             HEKf"'\n", HEKfARG(HvENAME_HEK(hv))));
+                             HEKf "'\n", HEKfARG(HvENAME_HEK(hv))));
            (void)hv_deletehek(PL_stashcache, HvENAME_HEK(hv), G_DISCARD);
         }
       }
@@ -1976,7 +1989,7 @@ Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags)
       if (flags & HV_NAME_SETALL ? !!HvAUX(hv)->xhv_name_u.xhvnameu_name : !!name) {
         if (name && PL_stashcache) {
             DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for name '%"
-                             HEKf"'\n", HEKfARG(HvNAME_HEK(hv))));
+                             HEKf "'\n", HEKfARG(HvNAME_HEK(hv))));
            (void)hv_deletehek(PL_stashcache, HvNAME_HEK(hv), G_DISCARD);
         }
        hv_name_set(hv, NULL, 0, flags);
@@ -2012,7 +2025,15 @@ Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags)
 
     if (SvRMAGICAL(hv))
        mg_clear(MUTABLE_SV(hv));
-    if (save) LEAVE;
+
+    if (save) {
+        /* disarm hv's premature free guard */
+        if (LIKELY(PL_tmps_ix == orig_ix))
+            PL_tmps_ix--;
+        else
+            PL_tmps_stack[orig_ix] = &PL_sv_undef;
+        SvREFCNT_dec_NN(hv);
+    }
 }
 
 /*
@@ -2037,6 +2058,7 @@ Perl_hv_fill(pTHX_ HV *const hv)
     STRLEN count = 0;
     HE **ents = HvARRAY(hv);
 
+    PERL_UNUSED_CONTEXT;
     PERL_ARGS_ASSERT_HV_FILL;
 
     /* No keys implies no buckets used.
@@ -2150,8 +2172,8 @@ S_hv_auxinit(pTHX_ HV *hv) {
 =for apidoc hv_iterinit
 
 Prepares a starting point to traverse a hash table.  Returns the number of
-keys in the hash (i.e. the same as C<HvUSEDKEYS(hv)>).  The return value is
-currently only meaningful for hashes without tie magic.
+keys in the hash, including placeholders (i.e. the same as C<HvTOTALKEYS(hv)>).
+The return value is currently only meaningful for hashes without tie magic.
 
 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
 hash buckets that happen to be in use.  If you still need that esoteric
@@ -2272,7 +2294,7 @@ Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
     PERL_ARGS_ASSERT_HV_NAME_SET;
 
     if (len > I32_MAX)
-       Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
+       Perl_croak(aTHX_ "panic: hv name too long (%" UVuf ")", (UV) len);
 
     if (SvOOK(hv)) {
        iter = HvAUX(hv);
@@ -2379,7 +2401,7 @@ Perl_hv_ename_add(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
     PERL_ARGS_ASSERT_HV_ENAME_ADD;
 
     if (len > I32_MAX)
-       Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
+       Perl_croak(aTHX_ "panic: hv name too long (%" UVuf ")", (UV) len);
 
     PERL_HASH(hash, name, len);
 
@@ -2441,7 +2463,7 @@ Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
     PERL_ARGS_ASSERT_HV_ENAME_DELETE;
 
     if (len > I32_MAX)
-       Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
+       Perl_croak(aTHX_ "panic: hv name too long (%" UVuf ")", (UV) len);
 
     if (!SvOOK(hv)) return;
 
@@ -3121,7 +3143,7 @@ S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
            SvUTF8_on(value);
        break;
     default:
-       Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %"UVxf,
+       Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %" UVxf,
                   (UV)he->refcounted_he_data[0]);
     }
     return value;
@@ -3144,7 +3166,7 @@ Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain, U32 flags)
     U32 placeholders, max;
 
     if (flags)
-       Perl_croak(aTHX_ "panic: refcounted_he_chain_2hv bad flags %"UVxf,
+       Perl_croak(aTHX_ "panic: refcounted_he_chain_2hv bad flags %" UVxf,
            (UV)flags);
 
     /* We could chase the chain once to get an idea of the number of keys,
@@ -3258,7 +3280,7 @@ Perl_refcounted_he_fetch_pvn(pTHX_ const struct refcounted_he *chain,
     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PVN;
 
     if (flags & ~(REFCOUNTED_HE_KEY_UTF8|REFCOUNTED_HE_EXISTS))
-       Perl_croak(aTHX_ "panic: refcounted_he_fetch_pvn bad flags %"UVxf,
+       Perl_croak(aTHX_ "panic: refcounted_he_fetch_pvn bad flags %" UVxf,
            (UV)flags);
     if (!chain)
        goto ret;
@@ -3359,7 +3381,7 @@ Perl_refcounted_he_fetch_sv(pTHX_ const struct refcounted_he *chain,
     STRLEN keylen;
     PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_SV;
     if (flags & REFCOUNTED_HE_KEY_UTF8)
-       Perl_croak(aTHX_ "panic: refcounted_he_fetch_sv bad flags %"UVxf,
+       Perl_croak(aTHX_ "panic: refcounted_he_fetch_sv bad flags %" UVxf,
            (UV)flags);
     keypv = SvPV_const(key, keylen);
     if (SvUTF8(key))
@@ -3547,7 +3569,7 @@ Perl_refcounted_he_new_sv(pTHX_ struct refcounted_he *parent,
     STRLEN keylen;
     PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_SV;
     if (flags & REFCOUNTED_HE_KEY_UTF8)
-       Perl_croak(aTHX_ "panic: refcounted_he_new_sv bad flags %"UVxf,
+       Perl_croak(aTHX_ "panic: refcounted_he_new_sv bad flags %" UVxf,
            (UV)flags);
     keypv = SvPV_const(key, keylen);
     if (SvUTF8(key))
Unnamed repository; edit this file 'description' to name the repository.