File Coverage

hv.c
Criterion Covered Total %
statement 1098 1249 87.9
branch 1063 1440 73.8
condition n/a
subroutine n/a
total 2161 2689 80.4


line stmt bran cond sub time code
1           /* hv.c
2           *
3           * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4           * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5           *
6           * You may distribute under the terms of either the GNU General Public
7           * License or the Artistic License, as specified in the README file.
8           *
9           */
10            
11           /*
12           * I sit beside the fire and think
13           * of all that I have seen.
14           * --Bilbo
15           *
16           * [p.278 of _The Lord of the Rings_, II/iii: "The Ring Goes South"]
17           */
18            
19           /*
20           =head1 Hash Manipulation Functions
21            
22           A HV structure represents a Perl hash. It consists mainly of an array
23           of pointers, each of which points to a linked list of HE structures. The
24           array is indexed by the hash function of the key, so each linked list
25           represents all the hash entries with the same hash value. Each HE contains
26           a pointer to the actual value, plus a pointer to a HEK structure which
27           holds the key and hash value.
28            
29           =cut
30            
31           */
32            
33           #include "EXTERN.h"
34           #define PERL_IN_HV_C
35           #define PERL_HASH_INTERNAL_ACCESS
36           #include "perl.h"
37            
38           #define DO_HSPLIT(xhv) ((xhv)->xhv_keys > (xhv)->xhv_max) /* HvTOTALKEYS(hv) > HvMAX(hv) */
39           #define HV_FILL_THRESHOLD 31
40            
41           static const char S_strtab_error[]
42           = "Cannot modify shared string table in hv_%s";
43            
44           #ifdef PURIFY
45            
46           #define new_HE() (HE*)safemalloc(sizeof(HE))
47           #define del_HE(p) safefree((char*)p)
48            
49           #else
50            
51           STATIC HE*
52 516333226         S_new_he(pTHX)
53           {
54           dVAR;
55           HE* he;
56           void ** const root = &PL_body_roots[HE_SVSLOT];
57            
58 516333226 100       if (!*root)
59 1042555         Perl_more_bodies(aTHX_ HE_SVSLOT, sizeof(HE), PERL_ARENA_SIZE);
60 516333226         he = (HE*) *root;
61           assert(he);
62 516333226         *root = HeNEXT(he);
63 516333226         return he;
64           }
65            
66           #define new_HE() new_he()
67           #define del_HE(p) \
68           STMT_START { \
69           HeNEXT(p) = (HE*)(PL_body_roots[HE_SVSLOT]); \
70           PL_body_roots[HE_SVSLOT] = p; \
71           } STMT_END
72            
73            
74            
75           #endif
76            
77           STATIC HEK *
78 0         S_save_hek_flags(const char *str, I32 len, U32 hash, int flags)
79           {
80 0         const int flags_masked = flags & HVhek_MASK;
81           char *k;
82           HEK *hek;
83            
84           PERL_ARGS_ASSERT_SAVE_HEK_FLAGS;
85            
86 0         Newx(k, HEK_BASESIZE + len + 2, char);
87           hek = (HEK*)k;
88 0         Copy(str, HEK_KEY(hek), len, char);
89 0         HEK_KEY(hek)[len] = 0;
90 0         HEK_LEN(hek) = len;
91 0         HEK_HASH(hek) = hash;
92 0         HEK_FLAGS(hek) = (unsigned char)flags_masked | HVhek_UNSHARED;
93            
94 0 0       if (flags & HVhek_FREEKEY)
95 0         Safefree(str);
96 0         return hek;
97           }
98            
99           /* free the pool of temporary HE/HEK pairs returned by hv_fetch_ent
100           * for tied hashes */
101            
102           void
103 0         Perl_free_tied_hv_pool(pTHX)
104           {
105           dVAR;
106 0         HE *he = PL_hv_fetch_ent_mh;
107 0 0       while (he) {
108           HE * const ohe = he;
109 0         Safefree(HeKEY_hek(he));
110 0         he = HeNEXT(he);
111 0         del_HE(ohe);
112           }
113 0         PL_hv_fetch_ent_mh = NULL;
114 0         }
115            
116           #if defined(USE_ITHREADS)
117           HEK *
118           Perl_hek_dup(pTHX_ HEK *source, CLONE_PARAMS* param)
119           {
120           HEK *shared;
121            
122           PERL_ARGS_ASSERT_HEK_DUP;
123           PERL_UNUSED_ARG(param);
124            
125           if (!source)
126           return NULL;
127            
128           shared = (HEK*)ptr_table_fetch(PL_ptr_table, source);
129           if (shared) {
130           /* We already shared this hash key. */
131           (void)share_hek_hek(shared);
132           }
133           else {
134           shared
135           = share_hek_flags(HEK_KEY(source), HEK_LEN(source),
136           HEK_HASH(source), HEK_FLAGS(source));
137           ptr_table_store(PL_ptr_table, source, shared);
138           }
139           return shared;
140           }
141            
142           HE *
143           Perl_he_dup(pTHX_ const HE *e, bool shared, CLONE_PARAMS* param)
144           {
145           HE *ret;
146            
147           PERL_ARGS_ASSERT_HE_DUP;
148            
149           if (!e)
150           return NULL;
151           /* look for it in the table first */
152           ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
153           if (ret)
154           return ret;
155            
156           /* create anew and remember what it is */
157           ret = new_HE();
158           ptr_table_store(PL_ptr_table, e, ret);
159            
160           HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
161           if (HeKLEN(e) == HEf_SVKEY) {
162           char *k;
163           Newx(k, HEK_BASESIZE + sizeof(const SV *), char);
164           HeKEY_hek(ret) = (HEK*)k;
165           HeKEY_sv(ret) = sv_dup_inc(HeKEY_sv(e), param);
166           }
167           else if (shared) {
168           /* This is hek_dup inlined, which seems to be important for speed
169           reasons. */
170           HEK * const source = HeKEY_hek(e);
171           HEK *shared = (HEK*)ptr_table_fetch(PL_ptr_table, source);
172            
173           if (shared) {
174           /* We already shared this hash key. */
175           (void)share_hek_hek(shared);
176           }
177           else {
178           shared
179           = share_hek_flags(HEK_KEY(source), HEK_LEN(source),
180           HEK_HASH(source), HEK_FLAGS(source));
181           ptr_table_store(PL_ptr_table, source, shared);
182           }
183           HeKEY_hek(ret) = shared;
184           }
185           else
186           HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
187           HeKFLAGS(e));
188           HeVAL(ret) = sv_dup_inc(HeVAL(e), param);
189           return ret;
190           }
191           #endif /* USE_ITHREADS */
192            
193           static void
194 242         S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
195           const char *msg)
196           {
197 242         SV * const sv = sv_newmortal();
198            
199           PERL_ARGS_ASSERT_HV_NOTALLOWED;
200            
201 242 50       if (!(flags & HVhek_FREEKEY)) {
202 242         sv_setpvn(sv, key, klen);
203           }
204           else {
205           /* Need to free saved eventually assign to mortal SV */
206           /* XXX is this line an error ???: SV *sv = sv_newmortal(); */
207 0         sv_usepvn(sv, (char *) key, klen);
208           }
209 242 50       if (flags & HVhek_UTF8) {
210 0         SvUTF8_on(sv);
211           }
212 242         Perl_croak(aTHX_ msg, SVfARG(sv));
213           }
214            
215           /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
216           * contains an SV* */
217            
218           /*
219           =for apidoc hv_store
220            
221           Stores an SV in a hash. The hash key is specified as C and the
222           absolute value of C is the length of the key. If C is
223           negative the key is assumed to be in UTF-8-encoded Unicode. The
224           C parameter is the precomputed hash value; if it is zero then
225           Perl will compute it.
226            
227           The return value will be
228           NULL if the operation failed or if the value did not need to be actually
229           stored within the hash (as in the case of tied hashes). Otherwise it can
230           be dereferenced to get the original C. Note that the caller is
231           responsible for suitably incrementing the reference count of C before
232           the call, and decrementing it if the function returned NULL. Effectively
233           a successful hv_store takes ownership of one reference to C. This is
234           usually what you want; a newly created SV has a reference count of one, so
235           if all your code does is create SVs then store them in a hash, hv_store
236           will own the only reference to the new SV, and your code doesn't need to do
237           anything further to tidy up. hv_store is not implemented as a call to
238           hv_store_ent, and does not create a temporary SV for the key, so if your
239           key data is not already in SV form then use hv_store in preference to
240           hv_store_ent.
241            
242           See L for more
243           information on how to use this function on tied hashes.
244            
245           =for apidoc hv_store_ent
246            
247           Stores C in a hash. The hash key is specified as C. The C
248           parameter is the precomputed hash value; if it is zero then Perl will
249           compute it. The return value is the new hash entry so created. It will be
250           NULL if the operation failed or if the value did not need to be actually
251           stored within the hash (as in the case of tied hashes). Otherwise the
252           contents of the return value can be accessed using the C macros
253           described here. Note that the caller is responsible for suitably
254           incrementing the reference count of C before the call, and
255           decrementing it if the function returned NULL. Effectively a successful
256           hv_store_ent takes ownership of one reference to C. This is
257           usually what you want; a newly created SV has a reference count of one, so
258           if all your code does is create SVs then store them in a hash, hv_store
259           will own the only reference to the new SV, and your code doesn't need to do
260           anything further to tidy up. Note that hv_store_ent only reads the C;
261           unlike C it does not take ownership of it, so maintaining the correct
262           reference count on C is entirely the caller's responsibility. hv_store
263           is not implemented as a call to hv_store_ent, and does not create a temporary
264           SV for the key, so if your key data is not already in SV form then use
265           hv_store in preference to hv_store_ent.
266            
267           See L for more
268           information on how to use this function on tied hashes.
269            
270           =for apidoc hv_exists
271            
272           Returns a boolean indicating whether the specified hash key exists. The
273           absolute value of C is the length of the key. If C is
274           negative the key is assumed to be in UTF-8-encoded Unicode.
275            
276           =for apidoc hv_fetch
277            
278           Returns the SV which corresponds to the specified key in the hash.
279           The absolute value of C is the length of the key. If C is
280           negative the key is assumed to be in UTF-8-encoded Unicode. If
281           C is set then the fetch will be part of a store. This means that if
282           there is no value in the hash associated with the given key, then one is
283           created and a pointer to it is returned. The C it points to can be
284           assigned to. But always check that the
285           return value is non-null before dereferencing it to an C.
286            
287           See L for more
288           information on how to use this function on tied hashes.
289            
290           =for apidoc hv_exists_ent
291            
292           Returns a boolean indicating whether
293           the specified hash key exists. C
294           can be a valid precomputed hash value, or 0 to ask for it to be
295           computed.
296            
297           =cut
298           */
299            
300           /* returns an HE * structure with the all fields set */
301           /* note that hent_val will be a mortal sv for MAGICAL hashes */
302           /*
303           =for apidoc hv_fetch_ent
304            
305           Returns the hash entry which corresponds to the specified key in the hash.
306           C must be a valid precomputed hash number for the given C, or 0
307           if you want the function to compute it. IF C is set then the fetch
308           will be part of a store. Make sure the return value is non-null before
309           accessing it. The return value when C is a tied hash is a pointer to a
310           static location, so be sure to make a copy of the structure if you need to
311           store it somewhere.
312            
313           See L for more
314           information on how to use this function on tied hashes.
315            
316           =cut
317           */
318            
319           /* Common code for hv_delete()/hv_exists()/hv_fetch()/hv_store() */
320           void *
321 3735448943         Perl_hv_common_key_len(pTHX_ HV *hv, const char *key, I32 klen_i32,
322           const int action, SV *val, const U32 hash)
323           {
324           STRLEN klen;
325           int flags;
326            
327           PERL_ARGS_ASSERT_HV_COMMON_KEY_LEN;
328            
329 3735448943 100       if (klen_i32 < 0) {
330 152512         klen = -klen_i32;
331           flags = HVhek_UTF8;
332           } else {
333 3735296431         klen = klen_i32;
334           flags = 0;
335           }
336 3735448943         return hv_common(hv, NULL, key, klen, flags, action, val, hash);
337           }
338            
339           void *
340 5167276153         Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
341           int flags, int action, SV *val, U32 hash)
342           {
343           dVAR;
344           XPVHV* xhv;
345           HE *entry;
346           HE **oentry;
347           SV *sv;
348           bool is_utf8;
349           int masked_flags;
350 5167276153         const int return_svp = action & HV_FETCH_JUST_SV;
351            
352 5167276153 100       if (!hv)
353           return NULL;
354 5167275157 50       if (SvTYPE(hv) == (svtype)SVTYPEMASK)
355           return NULL;
356            
357           assert(SvTYPE(hv) == SVt_PVHV);
358            
359 5167275157 100       if (SvSMAGICAL(hv) && SvGMAGICAL(hv) && !(action & HV_DISABLE_UVAR_XKEY)) {
    100        
360           MAGIC* mg;
361 80714 50       if ((mg = mg_find((const SV *)hv, PERL_MAGIC_uvar))) {
362 80714         struct ufuncs * const uf = (struct ufuncs *)mg->mg_ptr;
363 80714 100       if (uf->uf_set == NULL) {
364 80682         SV* obj = mg->mg_obj;
365            
366 80682 50       if (!keysv) {
367 0 0       keysv = newSVpvn_flags(key, klen, SVs_TEMP |
368           ((flags & HVhek_UTF8)
369           ? SVf_UTF8 : 0));
370           }
371          
372 80682         mg->mg_obj = keysv; /* pass key */
373 80682         uf->uf_index = action; /* pass action */
374 80682         magic_getuvar(MUTABLE_SV(hv), mg);
375 80682         keysv = mg->mg_obj; /* may have changed */
376 80682         mg->mg_obj = obj;
377            
378           /* If the key may have changed, then we need to invalidate
379           any passed-in computed hash value. */
380           hash = 0;
381           }
382           }
383           }
384 5167275157 100       if (keysv) {
385 1370499898 50       if (flags & HVhek_FREEKEY)
386 0         Safefree(key);
387 1370499898 100       key = SvPV_const(keysv, klen);
388 1370499898         is_utf8 = (SvUTF8(keysv) != 0);
389 1370499898 100       if (SvIsCOW_shared_hash(keysv)) {
    100        
390 982262392         flags = HVhek_KEYCANONICAL | (is_utf8 ? HVhek_UTF8 : 0);
391           } else {
392 388237506         flags = is_utf8 ? HVhek_UTF8 : 0;
393           }
394           } else {
395 3796775259         is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
396           }
397            
398 5167275157 100       if (action & HV_DELETE) {
399 20758347         return (void *) hv_delete_common(hv, keysv, key, klen,
400           flags, action, hash);
401           }
402            
403 5146516810         xhv = (XPVHV*)SvANY(hv);
404 5146516810 100       if (SvMAGICAL(hv)) {
405 669669244 100       if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS))) {
    100        
406 659528400 100       if (mg_find((const SV *)hv, PERL_MAGIC_tied)
407 659140809 50       || SvGMAGICAL((const SV *)hv))
408           {
409           /* FIXME should be able to skimp on the HE/HEK here when
410           HV_FETCH_JUST_SV is true. */
411 387591 100       if (!keysv) {
412 44 50       keysv = newSVpvn_utf8(key, klen, is_utf8);
413           } else {
414 387547         keysv = newSVsv(keysv);
415           }
416 387591         sv = sv_newmortal();
417 387591         mg_copy(MUTABLE_SV(hv), sv, (char *)keysv, HEf_SVKEY);
418            
419           /* grab a fake HE/HEK pair from the pool or make a new one */
420 387591         entry = PL_hv_fetch_ent_mh;
421 387591 100       if (entry)
422 358362         PL_hv_fetch_ent_mh = HeNEXT(entry);
423           else {
424           char *k;
425 29229         entry = new_HE();
426 29229         Newx(k, HEK_BASESIZE + sizeof(const SV *), char);
427 29229         HeKEY_hek(entry) = (HEK*)k;
428           }
429 387591         HeNEXT(entry) = NULL;
430 387591         HeSVKEY_set(entry, keysv);
431 387591         HeVAL(entry) = sv;
432 387591         sv_upgrade(sv, SVt_PVLV);
433 387591         LvTYPE(sv) = 'T';
434           /* so we can free entry when freeing sv */
435 387591         LvTARG(sv) = MUTABLE_SV(entry);
436            
437           /* XXX remove at some point? */
438 387591 50       if (flags & HVhek_FREEKEY)
439 0         Safefree(key);
440            
441 387591 100       if (return_svp) {
442 34 50       return entry ? (void *) &HeVAL(entry) : NULL;
443           }
444           return (void *) entry;
445           }
446           #ifdef ENV_IS_CASELESS
447           else if (mg_find((const SV *)hv, PERL_MAGIC_env)) {
448           U32 i;
449           for (i = 0; i < klen; ++i)
450           if (isLOWER(key[i])) {
451           /* Would be nice if we had a routine to do the
452           copy and upercase in a single pass through. */
453           const char * const nkey = strupr(savepvn(key,klen));
454           /* Note that this fetch is for nkey (the uppercased
455           key) whereas the store is for key (the original) */
456           void *result = hv_common(hv, NULL, nkey, klen,
457           HVhek_FREEKEY, /* free nkey */
458           0 /* non-LVAL fetch */
459           | HV_DISABLE_UVAR_XKEY
460           | return_svp,
461           NULL /* no value */,
462           0 /* compute hash */);
463           if (!result && (action & HV_FETCH_LVALUE)) {
464           /* This call will free key if necessary.
465           Do it this way to encourage compiler to tail
466           call optimise. */
467           result = hv_common(hv, keysv, key, klen, flags,
468           HV_FETCH_ISSTORE
469           | HV_DISABLE_UVAR_XKEY
470           | return_svp,
471           newSV(0), hash);
472           } else {
473           if (flags & HVhek_FREEKEY)
474           Safefree(key);
475           }
476           return result;
477           }
478           }
479           #endif
480           } /* ISFETCH */
481 10140844 100       else if (SvRMAGICAL(hv) && (action & HV_FETCH_ISEXISTS)) {
    100        
482 3139418 100       if (mg_find((const SV *)hv, PERL_MAGIC_tied)
483 3050712 50       || SvGMAGICAL((const SV *)hv)) {
484           /* I don't understand why hv_exists_ent has svret and sv,
485           whereas hv_exists only had one. */
486 88706         SV * const svret = sv_newmortal();
487 88706         sv = sv_newmortal();
488            
489 88706 50       if (keysv || is_utf8) {
    0        
490 88706 50       if (!keysv) {
491 0         keysv = newSVpvn_utf8(key, klen, TRUE);
492           } else {
493 88706         keysv = newSVsv(keysv);
494           }
495 88706         mg_copy(MUTABLE_SV(hv), sv, (char *)sv_2mortal(keysv), HEf_SVKEY);
496           } else {
497 0         mg_copy(MUTABLE_SV(hv), sv, key, klen);
498           }
499 88706 50       if (flags & HVhek_FREEKEY)
500 0         Safefree(key);
501 88706         magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
502           /* This cast somewhat evil, but I'm merely using NULL/
503           not NULL to return the boolean exists.
504           And I know hv is not NULL. */
505 88706 50       return SvTRUE(svret) ? (void *)hv : NULL;
    50        
    0        
    100        
    50        
    50        
    100        
    50        
    50        
    100        
    50        
    100        
    50        
    50        
    100        
    50        
    0        
    100        
    0        
506           }
507           #ifdef ENV_IS_CASELESS
508           else if (mg_find((const SV *)hv, PERL_MAGIC_env)) {
509           /* XXX This code isn't UTF8 clean. */
510           char * const keysave = (char * const)key;
511           /* Will need to free this, so set FREEKEY flag. */
512           key = savepvn(key,klen);
513           key = (const char*)strupr((char*)key);
514           is_utf8 = FALSE;
515           hash = 0;
516           keysv = 0;
517            
518           if (flags & HVhek_FREEKEY) {
519           Safefree(keysave);
520           }
521           flags |= HVhek_FREEKEY;
522           }
523           #endif
524           } /* ISEXISTS */
525 7001426 100       else if (action & HV_FETCH_ISSTORE) {
526           bool needs_copy;
527           bool needs_store;
528           hv_magic_check (hv, &needs_copy, &needs_store);
529 6960950 100       if (needs_copy) {
530 6189062         const bool save_taint = TAINT_get;
531 6189062 100       if (keysv || is_utf8) {
    50        
532 3358952 50       if (!keysv) {
533 0         keysv = newSVpvn_utf8(key, klen, TRUE);
534           }
535 3358952 100       if (TAINTING_get)
536 7294 50       TAINT_set(SvTAINTED(keysv));
    0        
537 3358952         keysv = sv_2mortal(newSVsv(keysv));
538 3358952         mg_copy(MUTABLE_SV(hv), val, (char*)keysv, HEf_SVKEY);
539           } else {
540 2830110         mg_copy(MUTABLE_SV(hv), val, key, klen);
541           }
542            
543 6189062 100       TAINT_IF(save_taint);
544           #ifdef NO_TAINT_SUPPORT
545           PERL_UNUSED_VAR(save_taint);
546           #endif
547 6189062 100       if (!needs_store) {
548 52 50       if (flags & HVhek_FREEKEY)
549 0         Safefree(key);
550           return NULL;
551           }
552           #ifdef ENV_IS_CASELESS
553           else if (mg_find((const SV *)hv, PERL_MAGIC_env)) {
554           /* XXX This code isn't UTF8 clean. */
555           const char *keysave = key;
556           /* Will need to free this, so set FREEKEY flag. */
557           key = savepvn(key,klen);
558           key = (const char*)strupr((char*)key);
559           is_utf8 = FALSE;
560           hash = 0;
561           keysv = 0;
562            
563           if (flags & HVhek_FREEKEY) {
564           Safefree(keysave);
565           }
566           flags |= HVhek_FREEKEY;
567           }
568           #endif
569           }
570           } /* ISSTORE */
571           } /* SvMAGICAL */
572            
573 5146040461 100       if (!HvARRAY(hv)) {
574 130994191 100       if ((action & (HV_FETCH_LVALUE | HV_FETCH_ISSTORE))
575           #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
576           || (SvRMAGICAL((const SV *)hv)
577           && mg_find((const SV *)hv, PERL_MAGIC_env))
578           #endif
579           ) {
580           char *array;
581 101942635         Newxz(array,
582           PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
583           char);
584 101942635         HvARRAY(hv) = (HE**)array;
585           }
586           #ifdef DYNAMIC_ENV_FETCH
587           else if (action & HV_FETCH_ISEXISTS) {
588           /* for an %ENV exists, if we do an insert it's by a recursive
589           store call, so avoid creating HvARRAY(hv) right now. */
590           }
591           #endif
592           else {
593           /* XXX remove at some point? */
594 29051556 50       if (flags & HVhek_FREEKEY)
595 0         Safefree(key);
596            
597           return NULL;
598           }
599           }
600            
601 5116988905 100       if (is_utf8 && !(flags & HVhek_KEYCANONICAL)) {
    100        
602           char * const keysave = (char *)key;
603 1533420         key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
604 1533420 100       if (is_utf8)
605 1411274         flags |= HVhek_UTF8;
606           else
607 122146         flags &= ~HVhek_UTF8;
608 1533420 100       if (key != keysave) {
609 122146 50       if (flags & HVhek_FREEKEY)
610 0         Safefree(keysave);
611 122146         flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
612           /* If the caller calculated a hash, it was on the sequence of
613           octets that are the UTF-8 form. We've now changed the sequence
614           of octets stored to that of the equivalent byte representation,
615           so the hash we need is different. */
616           hash = 0;
617           }
618           }
619            
620 5116988905 100       if (!hash) {
621 4491402563 100       if (keysv && (SvIsCOW_shared_hash(keysv)))
    100        
    100        
622 361659333         hash = SvSHARED_HASH(keysv);
623           else
624 4129743230         PERL_HASH(hash, key, klen);
625           }
626            
627 5116988905         masked_flags = (flags & HVhek_MASK);
628            
629           #ifdef DYNAMIC_ENV_FETCH
630           if (!HvARRAY(hv)) entry = NULL;
631           else
632           #endif
633           {
634 5116988905         entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)];
635           }
636 7223932332 100       for (; entry; entry = HeNEXT(entry)) {
637 5544798422 100       if (HeHASH(entry) != hash) /* strings can't be equal */
638 2106942339         continue;
639 3437856083 100       if (HeKLEN(entry) != (I32)klen)
640 8         continue;
641 3437856075 100       if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
    100        
642 608         continue;
643 3437855467 100       if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
644 472         continue;
645            
646 3437854995 100       if (action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE)) {
647 1766248462 100       if (HeKFLAGS(entry) != masked_flags) {
648           /* We match if HVhek_UTF8 bit in our flags and hash key's
649           match. But if entry was set previously with HVhek_WASUTF8
650           and key now doesn't (or vice versa) then we should change
651           the key's flag, as this is assignment. */
652 9818 50       if (HvSHAREKEYS(hv)) {
653           /* Need to swap the key we have for a key with the flags we
654           need. As keys are shared we can't just write to the
655           flag, so we share the new one, unshare the old one. */
656 9818         HEK * const new_hek = share_hek_flags(key, klen, hash,
657           masked_flags);
658 9818         unshare_hek (HeKEY_hek(entry));
659 9818         HeKEY_hek(entry) = new_hek;
660           }
661 0 0       else if (hv == PL_strtab) {
662           /* PL_strtab is usually the only hash without HvSHAREKEYS,
663           so putting this test here is cheap */
664 0 0       if (flags & HVhek_FREEKEY)
665 0         Safefree(key);
666 0 0       Perl_croak(aTHX_ S_strtab_error,
667 0         action & HV_FETCH_LVALUE ? "fetch" : "store");
668           }
669           else
670 0         HeKFLAGS(entry) = masked_flags;
671 9818 100       if (masked_flags & HVhek_ENABLEHVKFLAGS)
672 6292         HvHASKFLAGS_on(hv);
673           }
674 1766248462 100       if (HeVAL(entry) == &PL_sv_placeholder) {
675           /* yes, can store into placeholder slot */
676 20556 100       if (action & HV_FETCH_LVALUE) {
677 10276 50       if (SvMAGICAL(hv)) {
678           /* This preserves behaviour with the old hv_fetch
679           implementation which at this point would bail out
680           with a break; (at "if we find a placeholder, we
681           pretend we haven't found anything")
682            
683           That break mean that if a placeholder were found, it
684           caused a call into hv_store, which in turn would
685           check magic, and if there is no magic end up pretty
686           much back at this point (in hv_store's code). */
687           break;
688           }
689           /* LVAL fetch which actually needs a store. */
690 0         val = newSV(0);
691 0         HvPLACEHOLDERS(hv)--;
692           } else {
693           /* store */
694 10280 50       if (val != &PL_sv_placeholder)
695 10280         HvPLACEHOLDERS(hv)--;
696           }
697 10280         HeVAL(entry) = val;
698 1766227906 100       } else if (action & HV_FETCH_ISSTORE) {
699 513487         SvREFCNT_dec(HeVAL(entry));
700 513487         HeVAL(entry) = val;
701           }
702 1671606533 100       } else if (HeVAL(entry) == &PL_sv_placeholder) {
703           /* if we find a placeholder, we pretend we haven't found
704           anything */
705           break;
706           }
707 3437844683 100       if (flags & HVhek_FREEKEY)
708 100364         Safefree(key);
709 3437844683 100       if (return_svp) {
710 2438132873 50       return entry ? (void *) &HeVAL(entry) : NULL;
711           }
712           return entry;
713           }
714           #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
715           if (!(action & HV_FETCH_ISSTORE)
716           && SvRMAGICAL((const SV *)hv)
717           && mg_find((const SV *)hv, PERL_MAGIC_env)) {
718           unsigned long len;
719           const char * const env = PerlEnv_ENVgetenv_len(key,&len);
720           if (env) {
721           sv = newSVpvn(env,len);
722           SvTAINTED_on(sv);
723           return hv_common(hv, keysv, key, klen, flags,
724           HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp,
725           sv, hash);
726           }
727           }
728           #endif
729            
730 1679144222 100       if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) {
    100        
    100        
731 242         hv_notallowed(flags, key, klen,
732           "Attempt to access disallowed key '%"SVf"' in"
733           " a restricted hash");
734           }
735 1679143980 100       if (!(action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE))) {
736           /* Not doing some form of store, so return failure. */
737 1166548589 100       if (flags & HVhek_FREEKEY)
738 15878         Safefree(key);
739           return NULL;
740           }
741 512595391 100       if (action & HV_FETCH_LVALUE) {
742 153706366 100       val = action & HV_FETCH_EMPTY_HE ? NULL : newSV(0);
743 153706366 100       if (SvMAGICAL(hv)) {
744           /* At this point the old hv_fetch code would call to hv_store,
745           which in turn might do some tied magic. So we need to make that
746           magic check happen. */
747           /* gonna assign to this, so it better be there */
748           /* If a fetch-as-store fails on the fetch, then the action is to
749           recurse once into "hv_store". If we didn't do this, then that
750           recursive call would call the key conversion routine again.
751           However, as we replace the original key with the converted
752           key, this would result in a double conversion, which would show
753           up as a bug if the conversion routine is not idempotent.
754           Hence the use of HV_DISABLE_UVAR_XKEY. */
755 4880048         return hv_common(hv, keysv, key, klen, flags,
756           HV_FETCH_ISSTORE|HV_DISABLE_UVAR_XKEY|return_svp,
757           val, hash);
758           /* XXX Surely that could leak if the fetch-was-store fails?
759           Just like the hv_fetch. */
760           }
761           }
762            
763           /* Welcome to hv_store... */
764            
765 507715343 50       if (!HvARRAY(hv)) {
766           /* Not sure if we can get here. I think the only case of oentry being
767           NULL is for %ENV with dynamic env fetch. But that should disappear
768           with magic in the previous code. */
769           char *array;
770 0         Newxz(array,
771           PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
772           char);
773 0         HvARRAY(hv) = (HE**)array;
774           }
775            
776 507715343         oentry = &(HvARRAY(hv))[hash & (I32) xhv->xhv_max];
777            
778 507715343         entry = new_HE();
779           /* share_hek_flags will do the free for us. This might be considered
780           bad API design. */
781 507715343 50       if (HvSHAREKEYS(hv))
782 507715343         HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
783 0 0       else if (hv == PL_strtab) {
784           /* PL_strtab is usually the only hash without HvSHAREKEYS, so putting
785           this test here is cheap */
786 0 0       if (flags & HVhek_FREEKEY)
787 0         Safefree(key);
788 0 0       Perl_croak(aTHX_ S_strtab_error,
789 0         action & HV_FETCH_LVALUE ? "fetch" : "store");
790           }
791           else /* gotta do the real thing */
792 0         HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
793 507715343         HeVAL(entry) = val;
794            
795 507715343 100       if (!*oentry && SvOOK(hv)) {
    100        
796           /* initial entry, and aux struct present. */
797 24044302         struct xpvhv_aux *const aux = HvAUX(hv);
798 24044302 100       if (aux->xhv_fill_lazy)
799 21686         ++aux->xhv_fill_lazy;
800           }
801            
802           #ifdef PERL_HASH_RANDOMIZE_KEYS
803           /* This logic semi-randomizes the insert order in a bucket.
804           * Either we insert into the top, or the slot below the top,
805           * making it harder to see if there is a collision. We also
806           * reset the iterator randomizer if there is one.
807           */
808 507715343 100       if ( *oentry && PL_HASH_RAND_BITS_ENABLED) {
    100        
809 136363816         PL_hash_rand_bits++;
810 136363816         PL_hash_rand_bits= ROTL_UV(PL_hash_rand_bits,1);
811 136363816 100       if ( PL_hash_rand_bits & 1 ) {
812 68147155         HeNEXT(entry) = HeNEXT(*oentry);
813 68147155         HeNEXT(*oentry) = entry;
814           } else {
815 68216661         HeNEXT(entry) = *oentry;
816 68216661         *oentry = entry;
817           }
818           } else
819           #endif
820           {
821 371351527         HeNEXT(entry) = *oentry;
822 371351527         *oentry = entry;
823           }
824           #ifdef PERL_HASH_RANDOMIZE_KEYS
825 507715343 100       if (SvOOK(hv)) {
826           /* Currently this makes various tests warn in annoying ways.
827           * So Silenced for now. - Yves | bogus end of comment =>* /
828           if (HvAUX(hv)->xhv_riter != -1) {
829           Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
830           "[TESTING] Inserting into a hash during each() traversal results in undefined behavior"
831           pTHX__FORMAT
832           pTHX__VALUE);
833           }
834           */
835 41127067 100       if (PL_HASH_RAND_BITS_ENABLED) {
836 41126667 100       if (PL_HASH_RAND_BITS_ENABLED == 1)
837 41125667         PL_hash_rand_bits += (PTRV)entry + 1; /* we don't bother to use ptr_hash here */
838 41126667         PL_hash_rand_bits= ROTL_UV(PL_hash_rand_bits,1);
839           }
840 41127067         HvAUX(hv)->xhv_rand= (U32)PL_hash_rand_bits;
841           }
842           #endif
843            
844 507715343 100       if (val == &PL_sv_placeholder)
845 10260         HvPLACEHOLDERS(hv)++;
846 507715343 100       if (masked_flags & HVhek_ENABLEHVKFLAGS)
847 605974         HvHASKFLAGS_on(hv);
848            
849 507715343         xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
850 507715343 100       if ( DO_HSPLIT(xhv) ) {
851 9209010         const STRLEN oldsize = xhv->xhv_max + 1;
852 9209010 100       const U32 items = (U32)HvPLACEHOLDERS_get(hv);
853            
854 9209010 50       if (items /* hash has placeholders */
855 0 0       && !SvREADONLY(hv) /* but is not a restricted hash */) {
856           /* If this hash previously was a "restricted hash" and had
857           placeholders, but the "restricted" flag has been turned off,
858           then the placeholders no longer serve any useful purpose.
859           However, they have the downsides of taking up RAM, and adding
860           extra steps when finding used values. It's safe to clear them
861           at this point, even though Storable rebuilds restricted hashes by
862           putting in all the placeholders (first) before turning on the
863           readonly flag, because Storable always pre-splits the hash.
864           If we're lucky, then we may clear sufficient placeholders to
865           avoid needing to split the hash at all. */
866 0         clear_placeholders(hv, items);
867 0 0       if (DO_HSPLIT(xhv))
868 0         hsplit(hv, oldsize, oldsize * 2);
869           } else
870 9209010         hsplit(hv, oldsize, oldsize * 2);
871           }
872            
873 507715343 100       if (return_svp) {
874 2765846504 50       return entry ? (void *) &HeVAL(entry) : NULL;
875           }
876           return (void *) entry;
877           }
878            
879           STATIC void
880           S_hv_magic_check(HV *hv, bool *needs_copy, bool *needs_store)
881           {
882 10036538         const MAGIC *mg = SvMAGIC(hv);
883            
884           PERL_ARGS_ASSERT_HV_MAGIC_CHECK;
885            
886           *needs_copy = FALSE;
887           *needs_store = TRUE;
888 20075882 100       while (mg) {
    100        
889 10040934 100       if (isUPPER(mg->mg_type)) {
    100        
890           *needs_copy = TRUE;
891 9210584 100       if (mg->mg_type == PERL_MAGIC_tied) {
    100        
892           *needs_store = FALSE;
893           return; /* We've set all there is to set. */
894           }
895           }
896 10039344         mg = mg->mg_moremagic;
897           }
898           }
899            
900           /*
901           =for apidoc hv_scalar
902            
903           Evaluates the hash in scalar context and returns the result. Handles magic when the hash is tied.
904            
905           =cut
906           */
907            
908           SV *
909 111315         Perl_hv_scalar(pTHX_ HV *hv)
910           {
911           SV *sv;
912            
913           PERL_ARGS_ASSERT_HV_SCALAR;
914            
915 111315 100       if (SvRMAGICAL(hv)) {
916 82         MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_tied);
917 82 100       if (mg)
918 40         return magic_scalarpack(hv, mg);
919           }
920            
921 111275         sv = sv_newmortal();
922 111275 100       if (HvTOTALKEYS((const HV *)hv))
923 161141         Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
924 161141         (long)HvFILL(hv), (long)HvMAX(hv) + 1);
925           else
926 59381         sv_setiv(sv, 0);
927          
928           return sv;
929           }
930            
931           /*
932           =for apidoc hv_delete
933            
934           Deletes a key/value pair in the hash. The value's SV is removed from
935           the hash, made mortal, and returned to the caller. The absolute
936           value of C is the length of the key. If C is negative the
937           key is assumed to be in UTF-8-encoded Unicode. The C value
938           will normally be zero; if set to G_DISCARD then NULL will be returned.
939           NULL will also be returned if the key is not found.
940            
941           =for apidoc hv_delete_ent
942            
943           Deletes a key/value pair in the hash. The value SV is removed from the hash,
944           made mortal, and returned to the caller. The C value will normally be
945           zero; if set to G_DISCARD then NULL will be returned. NULL will also be
946           returned if the key is not found. C can be a valid precomputed hash
947           value, or 0 to ask for it to be computed.
948            
949           =cut
950           */
951            
952           STATIC SV *
953 20758347         S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
954           int k_flags, I32 d_flags, U32 hash)
955           {
956           dVAR;
957           XPVHV* xhv;
958           HE *entry;
959           HE **oentry;
960           HE *const *first_entry;
961 20758347         bool is_utf8 = (k_flags & HVhek_UTF8) ? TRUE : FALSE;
962           int masked_flags;
963            
964 20758347 100       if (SvRMAGICAL(hv)) {
965           bool needs_copy;
966           bool needs_store;
967           hv_magic_check (hv, &needs_copy, &needs_store);
968            
969 3075588 100       if (needs_copy) {
970           SV *sv;
971 3021522         entry = (HE *) hv_common(hv, keysv, key, klen,
972           k_flags & ~HVhek_FREEKEY,
973           HV_FETCH_LVALUE|HV_DISABLE_UVAR_XKEY,
974           NULL, hash);
975 3021522 50       sv = entry ? HeVAL(entry) : NULL;
976 3021522 50       if (sv) {
977 3021522 50       if (SvMAGICAL(sv)) {
978 3021522         mg_clear(sv);
979           }
980 3021514 100       if (!needs_store) {
981 1530 50       if (mg_find(sv, PERL_MAGIC_tiedelem)) {
982           /* No longer an element */
983 1530         sv_unmagic(sv, PERL_MAGIC_tiedelem);
984 1530         return sv;
985           }
986           return NULL; /* element cannot be deleted */
987           }
988           #ifdef ENV_IS_CASELESS
989           else if (mg_find((const SV *)hv, PERL_MAGIC_env)) {
990           /* XXX This code isn't UTF8 clean. */
991           keysv = newSVpvn_flags(key, klen, SVs_TEMP);
992           if (k_flags & HVhek_FREEKEY) {
993           Safefree(key);
994           }
995           key = strupr(SvPVX(keysv));
996           is_utf8 = 0;
997           k_flags = 0;
998           hash = 0;
999           }
1000           #endif
1001           }
1002           }
1003           }
1004 20756809         xhv = (XPVHV*)SvANY(hv);
1005 20756809 100       if (!HvARRAY(hv))
1006           return NULL;
1007            
1008 20727201 100       if (is_utf8 && !(k_flags & HVhek_KEYCANONICAL)) {
    50        
1009           const char * const keysave = key;
1010 1416         key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
1011            
1012 1416 100       if (is_utf8)
1013 1380         k_flags |= HVhek_UTF8;
1014           else
1015 36         k_flags &= ~HVhek_UTF8;
1016 1416 100       if (key != keysave) {
1017 36 50       if (k_flags & HVhek_FREEKEY) {
1018           /* This shouldn't happen if our caller does what we expect,
1019           but strictly the API allows it. */
1020 0         Safefree(keysave);
1021           }
1022 36         k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
1023           }
1024 1416         HvHASKFLAGS_on(MUTABLE_SV(hv));
1025           }
1026            
1027 20727201 50       if (!hash) {
1028 20727201 100       if (keysv && (SvIsCOW_shared_hash(keysv)))
    100        
    100        
1029 344978         hash = SvSHARED_HASH(keysv);
1030           else
1031 20382223         PERL_HASH(hash, key, klen);
1032           }
1033            
1034 20727201         masked_flags = (k_flags & HVhek_MASK);
1035            
1036 20727201         first_entry = oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)];
1037 20727201         entry = *oentry;
1038 25822011 100       for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
1039           SV *sv;
1040           U8 mro_changes = 0; /* 1 = isa; 2 = package moved */
1041           GV *gv = NULL;
1042           HV *stash = NULL;
1043            
1044 21103893 100       if (HeHASH(entry) != hash) /* strings can't be equal */
1045 5094788         continue;
1046 16009105 50       if (HeKLEN(entry) != (I32)klen)
1047 0         continue;
1048 16009105 100       if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
    100        
1049 22         continue;
1050 16009083 50       if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
1051 0         continue;
1052            
1053 16009083 50       if (hv == PL_strtab) {
1054 0 0       if (k_flags & HVhek_FREEKEY)
1055 0         Safefree(key);
1056 0         Perl_croak(aTHX_ S_strtab_error, "delete");
1057           }
1058            
1059           /* if placeholder is here, it's already been deleted.... */
1060 16009083 100       if (HeVAL(entry) == &PL_sv_placeholder) {
1061 4 50       if (k_flags & HVhek_FREEKEY)
1062 0         Safefree(key);
1063           return NULL;
1064           }
1065 16009079 100       if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
    50        
    50        
1066 0         hv_notallowed(k_flags, key, klen,
1067           "Attempt to delete readonly key '%"SVf"' from"
1068           " a restricted hash");
1069           }
1070 16009079 100       if (k_flags & HVhek_FREEKEY)
1071 36         Safefree(key);
1072            
1073           /* If this is a stash and the key ends with ::, then someone is
1074           * deleting a package.
1075           */
1076 16009079 50       if (HeVAL(entry) && HvENAME_get(hv)) {
    100        
    100        
    100        
    100        
    100        
    50        
    50        
1077 6120185         gv = (GV *)HeVAL(entry);
1078 6120185 100       if (keysv) key = SvPV(keysv, klen);
    50        
1079 6120185 100       if ((
1080 9124230 100       (klen > 1 && key[klen-2] == ':' && key[klen-1] == ':')
    50        
1081 6120037 100       ||
1082 3027163 50       (klen == 1 && key[0] == ':')
1083           )
1084 148 100       && (klen != 6 || hv!=PL_defstash || memNE(key,"main::",6))
    50        
    100        
1085 146 50       && SvTYPE(gv) == SVt_PVGV && (stash = GvHV((GV *)gv))
    50        
1086 146 50       && HvENAME_get(stash)) {
    50        
    50        
    100        
    100        
    50        
    50        
1087           /* A previous version of this code checked that the
1088           * GV was still in the symbol table by fetching the
1089           * GV with its name. That is not necessary (and
1090           * sometimes incorrect), as HvENAME cannot be set
1091           * on hv if it is not in the symtab. */
1092           mro_changes = 2;
1093           /* Hang on to it for a bit. */
1094 146         SvREFCNT_inc_simple_void_NN(
1095           sv_2mortal((SV *)gv)
1096           );
1097           }
1098 6120039 100       else if (klen == 3 && strnEQ(key, "ISA", 3))
    100        
1099           mro_changes = 1;
1100           }
1101            
1102 16009079 100       sv = d_flags & G_DISCARD ? HeVAL(entry) : sv_2mortal(HeVAL(entry));
1103 16009079         HeVAL(entry) = &PL_sv_placeholder;
1104 16009079 50       if (sv) {
1105           /* deletion of method from stash */
1106 16009079 100       if (isGV(sv) && isGV_with_GP(sv) && GvCVu(sv)
    50        
    50        
    100        
    100        
1107 61662 50       && HvENAME_get(hv))
    50        
    100        
    50        
    50        
    50        
    50        
1108 61658         mro_method_changed_in(hv);
1109           }
1110            
1111           /*
1112           * If a restricted hash, rather than really deleting the entry, put
1113           * a placeholder there. This marks the key as being "approved", so
1114           * we can still access via not-really-existing key without raising
1115           * an error.
1116           */
1117 16009079 100       if (SvREADONLY(hv))
1118           /* We'll be saving this slot, so the number of allocated keys
1119           * doesn't go down, but the number placeholders goes up */
1120 10264         HvPLACEHOLDERS(hv)++;
1121           else {
1122 15998815         *oentry = HeNEXT(entry);
1123 15998815 100       if(!*first_entry && SvOOK(hv)) {
    100        
1124           /* removed last entry, and aux struct present. */
1125 3481457         struct xpvhv_aux *const aux = HvAUX(hv);
1126 3481457 100       if (aux->xhv_fill_lazy)
1127 1188         --aux->xhv_fill_lazy;
1128           }
1129 15998815 100       if (SvOOK(hv) && entry == HvAUX(hv)->xhv_eiter /* HvEITER(hv) */)
    100        
1130 10         HvLAZYDEL_on(hv);
1131           else {
1132 15998806 100       if (SvOOK(hv) && HvLAZYDEL(hv) &&
    50        
1133 2         entry == HeNEXT(HvAUX(hv)->xhv_eiter))
1134 2         HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry);
1135 15998805         hv_free_ent(hv, entry);
1136           }
1137 15998815         xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
1138 15998815 100       if (xhv->xhv_keys == 0)
1139 1695590         HvHASKFLAGS_off(hv);
1140           }
1141            
1142 16009079 100       if (d_flags & G_DISCARD) {
1143 13093709         SvREFCNT_dec(sv);
1144           sv = NULL;
1145           }
1146            
1147 16009079 100       if (mro_changes == 1) mro_isa_changed_in(hv);
1148 16009075 100       else if (mro_changes == 2)
1149 146         mro_package_moved(NULL, stash, gv, 1);
1150            
1151           return sv;
1152           }
1153 4718118 50       if (SvREADONLY(hv)) {
1154 0         hv_notallowed(k_flags, key, klen,
1155           "Attempt to delete disallowed key '%"SVf"' from"
1156           " a restricted hash");
1157           }
1158            
1159 4718118 50       if (k_flags & HVhek_FREEKEY)
1160 10432079         Safefree(key);
1161           return NULL;
1162           }
1163            
1164           STATIC void
1165 9248142         S_hsplit(pTHX_ HV *hv, STRLEN const oldsize, STRLEN newsize)
1166           {
1167           dVAR;
1168           STRLEN i = 0;
1169 9248142         char *a = (char*) HvARRAY(hv);
1170           HE **aep;
1171            
1172           PERL_ARGS_ASSERT_HSPLIT;
1173            
1174           /*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n",
1175           (void*)hv, (int) oldsize);*/
1176            
1177 9248142         PL_nomemok = TRUE;
1178 9248142 100       Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize)
1179           + (SvOOK(hv) ? sizeof(struct xpvhv_aux) : 0), char);
1180 9248142 50       if (!a) {
1181 0         PL_nomemok = FALSE;
1182 0         return;
1183           }
1184           #ifdef PERL_HASH_RANDOMIZE_KEYS
1185           /* the idea of this is that we create a "random" value by hashing the address of
1186           * the array, we then use the low bit to decide if we insert at the top, or insert
1187           * second from top. After each such insert we rotate the hashed value. So we can
1188           * use the same hashed value over and over, and in normal build environments use
1189           * very few ops to do so. ROTL32() should produce a single machine operation. */
1190 9248142 100       if (PL_HASH_RAND_BITS_ENABLED) {
1191 9248098 100       if (PL_HASH_RAND_BITS_ENABLED == 1)
1192 13829002         PL_hash_rand_bits += ptr_hash((PTRV)a);
1193 9248098         PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,1);
1194           }
1195           #endif
1196            
1197 9248142 100       if (SvOOK(hv)) {
1198 1378273         struct xpvhv_aux *const dest
1199 1378273         = (struct xpvhv_aux*) &a[newsize * sizeof(HE*)];
1200 1378273         Move(&a[oldsize * sizeof(HE*)], dest, 1, struct xpvhv_aux);
1201           /* we reset the iterator's xhv_rand as well, so they get a totally new ordering */
1202           #ifdef PERL_HASH_RANDOMIZE_KEYS
1203 1378273         dest->xhv_rand = (U32)PL_hash_rand_bits;
1204           #endif
1205           /* For now, just reset the lazy fill counter.
1206           It would be possible to update the counter in the code below
1207           instead. */
1208 1378273         dest->xhv_fill_lazy = 0;
1209           }
1210            
1211 9248142         PL_nomemok = FALSE;
1212 9248142         Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1213 9248142         HvMAX(hv) = --newsize;
1214 9248142         HvARRAY(hv) = (HE**) a;
1215            
1216 9248142 50       if (!HvTOTALKEYS(hv)) /* skip rest if no entries */
1217           return;
1218            
1219           aep = (HE**)a;
1220           do {
1221 272205918         HE **oentry = aep + i;
1222 272205918         HE *entry = aep[i];
1223            
1224 272205918 100       if (!entry) /* non-existent */
1225 187297003         continue;
1226           do {
1227 267638057         U32 j = (HeHASH(entry) & newsize);
1228 267638057 100       if (j != (U32)i) {
1229 131706227         *oentry = HeNEXT(entry);
1230           #ifdef PERL_HASH_RANDOMIZE_KEYS
1231           /* if the target cell is empty or PL_HASH_RAND_BITS_ENABLED is false
1232           * insert to top, otherwise rotate the bucket rand 1 bit,
1233           * and use the new low bit to decide if we insert at top,
1234           * or next from top. IOW, we only rotate on a collision.*/
1235 131706227 100       if (aep[j] && PL_HASH_RAND_BITS_ENABLED) {
    100        
1236 27293725         PL_hash_rand_bits+= ROTL_UV(HeHASH(entry), 17);
1237 27293725         PL_hash_rand_bits= ROTL_UV(PL_hash_rand_bits,1);
1238 27293725 100       if (PL_hash_rand_bits & 1) {
1239 13639114         HeNEXT(entry)= HeNEXT(aep[j]);
1240 13639114         HeNEXT(aep[j])= entry;
1241           } else {
1242           /* Note, this is structured in such a way as the optimizer
1243           * should eliminate the duplicated code here and below without
1244           * us needing to explicitly use a goto. */
1245 13654611         HeNEXT(entry) = aep[j];
1246 13654611         aep[j] = entry;
1247           }
1248           } else
1249           #endif
1250           {
1251           /* see comment above about duplicated code */
1252 104412502         HeNEXT(entry) = aep[j];
1253 104412502         aep[j] = entry;
1254           }
1255           }
1256           else {
1257 135931830         oentry = &HeNEXT(entry);
1258           }
1259 267638057         entry = *oentry;
1260 267638057 100       } while (entry);
1261 272205918 100       } while (i++ < oldsize);
1262           }
1263            
1264           void
1265 89155932         Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1266           {
1267           dVAR;
1268 89155932         XPVHV* xhv = (XPVHV*)SvANY(hv);
1269 89155932         const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1270           I32 newsize;
1271           char *a;
1272            
1273           PERL_ARGS_ASSERT_HV_KSPLIT;
1274            
1275 89155932         newsize = (I32) newmax; /* possible truncation here */
1276 89155932 50       if (newsize != newmax || newmax <= oldsize)
    100        
1277           return;
1278 2690592 100       while ((newsize & (1 + ~newsize)) != newsize) {
1279 1695050         newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1280           }
1281 995542 100       if (newsize < newmax)
1282 923550         newsize *= 2;
1283 995542 50       if (newsize < newmax)
1284           return; /* overflow detection */
1285            
1286 995542         a = (char *) HvARRAY(hv);
1287 995542 100       if (a) {
1288 8         hsplit(hv, oldsize, newsize);
1289           } else {
1290 995534         Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1291 995534         xhv->xhv_max = --newsize;
1292 45075733         HvARRAY(hv) = (HE **) a;
1293           }
1294           }
1295            
1296           /* IMO this should also handle cases where hv_max is smaller than hv_keys
1297           * as tied hashes could play silly buggers and mess us around. We will
1298           * do the right thing during hv_store() afterwards, but still - Yves */
1299           #define HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys) STMT_START {\
1300           /* Can we use fewer buckets? (hv_max is always 2^n-1) */ \
1301           if (hv_max < PERL_HASH_DEFAULT_HvMAX) { \
1302           hv_max = PERL_HASH_DEFAULT_HvMAX; \
1303           } else { \
1304           while (hv_max > PERL_HASH_DEFAULT_HvMAX && hv_max + 1 >= hv_keys * 2) \
1305           hv_max = hv_max / 2; \
1306           } \
1307           HvMAX(hv) = hv_max; \
1308           } STMT_END
1309            
1310            
1311           HV *
1312 497252         Perl_newHVhv(pTHX_ HV *ohv)
1313           {
1314           dVAR;
1315 497252         HV * const hv = newHV();
1316           STRLEN hv_max;
1317            
1318 497252 50       if (!ohv || (!HvTOTALKEYS(ohv) && !SvMAGICAL((const SV *)ohv)))
    50        
    0        
1319           return hv;
1320 497252         hv_max = HvMAX(ohv);
1321            
1322 497252 100       if (!SvMAGICAL((const SV *)ohv)) {
1323           /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1324           STRLEN i;
1325 497250         const bool shared = !!HvSHAREKEYS(ohv);
1326 497250         HE **ents, ** const oents = (HE **)HvARRAY(ohv);
1327           char *a;
1328 497250         Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1329           ents = (HE**)a;
1330            
1331           /* In each bucket... */
1332 4975618 100       for (i = 0; i <= hv_max; i++) {
1333           HE *prev = NULL;
1334 4478368         HE *oent = oents[i];
1335            
1336 4478368 100       if (!oent) {
1337 3022782         ents[i] = NULL;
1338 3022782         continue;
1339           }
1340            
1341           /* Copy the linked list of entries. */
1342 2487315 100       for (; oent; oent = HeNEXT(oent)) {
1343 1720644         const U32 hash = HeHASH(oent);
1344 1720644         const char * const key = HeKEY(oent);
1345 1720644         const STRLEN len = HeKLEN(oent);
1346 1720644         const int flags = HeKFLAGS(oent);
1347 1720644         HE * const ent = new_HE();
1348 1720644         SV *const val = HeVAL(oent);
1349            
1350 1720644 50       HeVAL(ent) = SvIMMORTAL(val) ? val : newSVsv(val);
    50        
    0        
    0        
    0        
1351           HeKEY_hek(ent)
1352 3441288         = shared ? share_hek_flags(key, len, hash, flags)
1353 2534708 50       : save_hek_flags(key, len, hash, flags);
1354 1720644 100       if (prev)
1355 265058         HeNEXT(prev) = ent;
1356           else
1357 1455586         ents[i] = ent;
1358           prev = ent;
1359 1720644         HeNEXT(ent) = NULL;
1360           }
1361           }
1362            
1363 497250         HvMAX(hv) = hv_max;
1364 497250         HvTOTALKEYS(hv) = HvTOTALKEYS(ohv);
1365 497250         HvARRAY(hv) = ents;
1366           } /* not magical */
1367           else {
1368           /* Iterate over ohv, copying keys and values one at a time. */
1369           HE *entry;
1370 2 50       const I32 riter = HvRITER_get(ohv);
1371 2 50       HE * const eiter = HvEITER_get(ohv);
1372 2         STRLEN hv_keys = HvTOTALKEYS(ohv);
1373            
1374 2 50       HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys);
    50        
    0        
1375            
1376 2         hv_iterinit(ohv);
1377 5 100       while ((entry = hv_iternext_flags(ohv, 0))) {
1378 2         SV *val = hv_iterval(ohv,entry);
1379 2 50       SV * const keysv = HeSVKEY(entry);
    50        
1380 2 50       val = SvIMMORTAL(val) ? val : newSVsv(val);
    0        
    0        
    0        
    0        
1381 2 50       if (keysv)
1382 0         (void)hv_store_ent(hv, keysv, val, 0);
1383           else
1384 2         (void)hv_store_flags(hv, HeKEY(entry), HeKLEN(entry), val,
1385           HeHASH(entry), HeKFLAGS(entry));
1386           }
1387 2         HvRITER_set(ohv, riter);
1388 260866         HvEITER_set(ohv, eiter);
1389           }
1390            
1391           return hv;
1392           }
1393            
1394           /*
1395           =for apidoc Am|HV *|hv_copy_hints_hv|HV *ohv
1396            
1397           A specialised version of L for copying C<%^H>. I must be
1398           a pointer to a hash (which may have C<%^H> magic, but should be generally
1399           non-magical), or C (interpreted as an empty hash). The content
1400           of I is copied to a new hash, which has the C<%^H>-specific magic
1401           added to it. A pointer to the new hash is returned.
1402            
1403           =cut
1404           */
1405            
1406           HV *
1407 1076168         Perl_hv_copy_hints_hv(pTHX_ HV *const ohv)
1408           {
1409 1076168         HV * const hv = newHV();
1410            
1411 1076168 50       if (ohv) {
1412 1076168         STRLEN hv_max = HvMAX(ohv);
1413 1076168         STRLEN hv_keys = HvTOTALKEYS(ohv);
1414           HE *entry;
1415 1076168 100       const I32 riter = HvRITER_get(ohv);
1416 1076168 100       HE * const eiter = HvEITER_get(ohv);
1417            
1418 1076168         ENTER;
1419 1076168         SAVEFREESV(hv);
1420            
1421 1076217 50       HV_SET_MAX_ADJUSTED_FOR_KEYS(hv,hv_max,hv_keys);
    100        
    100        
1422            
1423 1076168         hv_iterinit(ohv);
1424 8253428 100       while ((entry = hv_iternext_flags(ohv, 0))) {
1425 6639360         SV *const sv = newSVsv(hv_iterval(ohv,entry));
1426 6639356 50       SV *heksv = HeSVKEY(entry);
    100        
1427 6639356 100       if (!heksv && sv) heksv = newSVhek(HeKEY_hek(entry));
1428 6639356 50       if (sv) sv_magic(sv, NULL, PERL_MAGIC_hintselem,
1429           (char *)heksv, HEf_SVKEY);
1430 6639356 50       if (heksv == HeSVKEY(entry))
    100        
    100        
1431 6         (void)hv_store_ent(hv, heksv, sv, 0);
1432           else {
1433 6639350         (void)hv_common(hv, heksv, HeKEY(entry), HeKLEN(entry),
1434           HeKFLAGS(entry), HV_FETCH_ISSTORE|HV_FETCH_JUST_SV, sv, HeHASH(entry));
1435 6639353         SvREFCNT_dec_NN(heksv);
1436           }
1437           }
1438 1076162         HvRITER_set(ohv, riter);
1439 1076162         HvEITER_set(ohv, eiter);
1440            
1441 1076162         SvREFCNT_inc_simple_void_NN(hv);
1442 1076162         LEAVE;
1443           }
1444 1076162         hv_magic(hv, NULL, PERL_MAGIC_hints);
1445 1076162         return hv;
1446           }
1447           #undef HV_SET_MAX_ADJUSTED_FOR_KEYS
1448            
1449           /* like hv_free_ent, but returns the SV rather than freeing it */
1450           STATIC SV*
1451 446804367         S_hv_free_ent_ret(pTHX_ HV *hv, HE *entry)
1452           {
1453           dVAR;
1454           SV *val;
1455            
1456           PERL_ARGS_ASSERT_HV_FREE_ENT_RET;
1457            
1458 446804367         val = HeVAL(entry);
1459 446804367 100       if (HeKLEN(entry) == HEf_SVKEY) {
1460 24         SvREFCNT_dec(HeKEY_sv(entry));
1461 24         Safefree(HeKEY_hek(entry));
1462           }
1463 446804343 50       else if (HvSHAREKEYS(hv))
1464 446804343         unshare_hek(HeKEY_hek(entry));
1465           else
1466 0         Safefree(HeKEY_hek(entry));
1467 446804367         del_HE(entry);
1468 446804367         return val;
1469           }
1470            
1471            
1472           void
1473 17381789         Perl_hv_free_ent(pTHX_ HV *hv, HE *entry)
1474           {
1475           dVAR;
1476           SV *val;
1477            
1478           PERL_ARGS_ASSERT_HV_FREE_ENT;
1479            
1480 17381789 50       if (!entry)
1481 17381789         return;
1482 17381789         val = hv_free_ent_ret(hv, entry);
1483 17381789         SvREFCNT_dec(val);
1484           }
1485            
1486            
1487           void
1488 0         Perl_hv_delayfree_ent(pTHX_ HV *hv, HE *entry)
1489           {
1490           dVAR;
1491            
1492           PERL_ARGS_ASSERT_HV_DELAYFREE_ENT;
1493            
1494 0 0       if (!entry)
1495 0         return;
1496           /* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent */
1497 0         sv_2mortal(SvREFCNT_inc(HeVAL(entry))); /* free between statements */
1498 0 0       if (HeKLEN(entry) == HEf_SVKEY) {
1499 0         sv_2mortal(SvREFCNT_inc(HeKEY_sv(entry)));
1500           }
1501 0         hv_free_ent(hv, entry);
1502           }
1503            
1504           /*
1505           =for apidoc hv_clear
1506            
1507           Frees the all the elements of a hash, leaving it empty.
1508           The XS equivalent of C<%hash = ()>. See also L.
1509            
1510           If any destructors are triggered as a result, the hv itself may
1511           be freed.
1512            
1513           =cut
1514           */
1515            
1516           void
1517 16881540         Perl_hv_clear(pTHX_ HV *hv)
1518           {
1519           dVAR;
1520           XPVHV* xhv;
1521 16881540 50       if (!hv)
1522 16881536         return;
1523            
1524           DEBUG_A(Perl_hv_assert(aTHX_ hv));
1525            
1526 16881540         xhv = (XPVHV*)SvANY(hv);
1527            
1528 16881540         ENTER;
1529 16881540         SAVEFREESV(SvREFCNT_inc_simple_NN(hv));
1530 16881540 100       if (SvREADONLY(hv) && HvARRAY(hv) != NULL) {
    50        
1531           /* restricted hash: convert all keys to placeholders */
1532           STRLEN i;
1533 34 100       for (i = 0; i <= xhv->xhv_max; i++) {
1534 32         HE *entry = (HvARRAY(hv))[i];
1535 44 100       for (; entry; entry = HeNEXT(entry)) {
1536           /* not already placeholder */
1537 12 100       if (HeVAL(entry) != &PL_sv_placeholder) {
1538 4 50       if (HeVAL(entry)) {
1539 4 50       if (SvREADONLY(HeVAL(entry))) {
1540 0         SV* const keysv = hv_iterkeysv(entry);
1541 0         Perl_croak_nocontext(
1542           "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1543           (void*)keysv);
1544           }
1545 4         SvREFCNT_dec_NN(HeVAL(entry));
1546           }
1547 4         HeVAL(entry) = &PL_sv_placeholder;
1548 4         HvPLACEHOLDERS(hv)++;
1549           }
1550           }
1551           }
1552           }
1553           else {
1554 16881536         hfreeentries(hv);
1555 16881536         HvPLACEHOLDERS_set(hv, 0);
1556            
1557 16881536 100       if (SvRMAGICAL(hv))
1558 595783         mg_clear(MUTABLE_SV(hv));
1559            
1560 16881532         HvHASKFLAGS_off(hv);
1561           }
1562 16881536 100       if (SvOOK(hv)) {
1563 700514 50       if(HvENAME_get(hv))
    100        
    50        
    50        
    100        
    50        
    50        
1564 62         mro_isa_changed_in(hv);
1565 700514         HvEITER_set(hv, NULL);
1566           }
1567 16881536         LEAVE;
1568           }
1569            
1570           /*
1571           =for apidoc hv_clear_placeholders
1572            
1573           Clears any placeholders from a hash. If a restricted hash has any of its keys
1574           marked as readonly and the key is subsequently deleted, the key is not actually
1575           deleted but is marked by assigning it a value of &PL_sv_placeholder. This tags
1576           it so it will be ignored by future operations such as iterating over the hash,
1577           but will still allow the hash to have a value reassigned to the key at some
1578           future point. This function clears any such placeholder keys from the hash.
1579           See Hash::Util::lock_keys() for an example of its use.
1580            
1581           =cut
1582           */
1583            
1584           void
1585 230         Perl_hv_clear_placeholders(pTHX_ HV *hv)
1586           {
1587           dVAR;
1588 230 50       const U32 items = (U32)HvPLACEHOLDERS_get(hv);
1589            
1590           PERL_ARGS_ASSERT_HV_CLEAR_PLACEHOLDERS;
1591            
1592 230 50       if (items)
1593 0         clear_placeholders(hv, items);
1594 230         }
1595            
1596           static void
1597 173942         S_clear_placeholders(pTHX_ HV *hv, U32 items)
1598           {
1599           dVAR;
1600           I32 i;
1601            
1602           PERL_ARGS_ASSERT_CLEAR_PLACEHOLDERS;
1603            
1604 173942 50       if (items == 0)
1605           return;
1606            
1607 173942         i = HvMAX(hv);
1608           do {
1609           /* Loop down the linked list heads */
1610 1377790         HE **oentry = &(HvARRAY(hv))[i];
1611           HE *entry;
1612            
1613 3625635 100       while ((entry = *oentry)) {
1614 1732892 100       if (HeVAL(entry) == &PL_sv_placeholder) {
1615 1382950         *oentry = HeNEXT(entry);
1616 1382950 50       if (entry == HvEITER_get(hv))
    50        
1617 0         HvLAZYDEL_on(hv);
1618           else {
1619 1382950 50       if (SvOOK(hv) && HvLAZYDEL(hv) &&
    0        
1620 0         entry == HeNEXT(HvAUX(hv)->xhv_eiter))
1621 0         HeNEXT(HvAUX(hv)->xhv_eiter) = HeNEXT(entry);
1622 1382950         hv_free_ent(hv, entry);
1623           }
1624            
1625 1382950 100       if (--items == 0) {
1626           /* Finished. */
1627 173942 50       HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS_get(hv);
1628 173942 50       if (HvUSEDKEYS(hv) == 0)
    50        
1629 0         HvHASKFLAGS_off(hv);
1630 173942         HvPLACEHOLDERS_set(hv, 0);
1631 173942         return;
1632           }
1633           } else {
1634 954446         oentry = &HeNEXT(entry);
1635           }
1636           }
1637 1203848 50       } while (--i >= 0);
1638           /* You can't get here, hence assertion should always fail. */
1639           assert (items == 0);
1640           assert (0);
1641           }
1642            
1643           STATIC void
1644 128932480         S_hfreeentries(pTHX_ HV *hv)
1645           {
1646 128932480         STRLEN index = 0;
1647 128932480         XPVHV * const xhv = (XPVHV*)SvANY(hv);
1648           SV *sv;
1649            
1650           PERL_ARGS_ASSERT_HFREEENTRIES;
1651            
1652 214599825 100       while ((sv = Perl_hfree_next_entry(aTHX_ hv, &index))||xhv->xhv_keys) {
    50        
1653 21260664         SvREFCNT_dec(sv);
1654           }
1655 128932480         }
1656            
1657            
1658           /* hfree_next_entry()
1659           * For use only by S_hfreeentries() and sv_clear().
1660           * Delete the next available HE from hv and return the associated SV.
1661           * Returns null on empty hash. Nevertheless null is not a reliable
1662           * indicator that the hash is empty, as the deleted entry may have a
1663           * null value.
1664           * indexp is a pointer to the current index into HvARRAY. The index should
1665           * initially be set to 0. hfree_next_entry() may update it. */
1666            
1667           SV*
1668 660096313         Perl_hfree_next_entry(pTHX_ HV *hv, STRLEN *indexp)
1669           {
1670           struct xpvhv_aux *iter;
1671           HE *entry;
1672           HE ** array;
1673           #ifdef DEBUGGING
1674           STRLEN orig_index = *indexp;
1675           #endif
1676            
1677           PERL_ARGS_ASSERT_HFREE_NEXT_ENTRY;
1678            
1679 660096313 100       if (SvOOK(hv) && ((iter = HvAUX(hv)))) {
    50        
1680 106802096 100       if ((entry = iter->xhv_eiter)) {
1681           /* the iterator may get resurrected after each
1682           * destructor call, so check each time */
1683 142 50       if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
    100        
1684 20         HvLAZYDEL_off(hv);
1685 20         hv_free_ent(hv, entry);
1686           /* warning: at this point HvARRAY may have been
1687           * re-allocated, HvMAX changed etc */
1688           }
1689 142         iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
1690 142         iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
1691           #ifdef PERL_HASH_RANDOMIZE_KEYS
1692 142         iter->xhv_last_rand = iter->xhv_rand;
1693           #endif
1694           }
1695           /* Reset any cached HvFILL() to "unknown". It's unlikely that anyone
1696           will actually call HvFILL() on a hash under destruction, so it
1697           seems pointless attempting to track the number of keys remaining.
1698           But if they do, we want to reset it again. */
1699 106802096 100       if (iter->xhv_fill_lazy)
1700 15182         iter->xhv_fill_lazy = 0;
1701           }
1702            
1703 660096313 100       if (!((XPVHV*)SvANY(hv))->xhv_keys)
1704           return NULL;
1705            
1706 429422578         array = HvARRAY(hv);
1707           assert(array);
1708 1575527158 100       while ( ! ((entry = array[*indexp])) ) {
1709 716682002 100       if ((*indexp)++ >= HvMAX(hv))
1710 214825741         *indexp = 0;
1711           assert(*indexp != orig_index);
1712           }
1713 429422578         array[*indexp] = HeNEXT(entry);
1714 429422578         ((XPVHV*) SvANY(hv))->xhv_keys--;
1715            
1716 429422578 100       if ( PL_phase != PERL_PHASE_DESTRUCT && HvENAME(hv)
    100        
    100        
    100        
    50        
    100        
    50        
    50        
1717 2342 50       && HeVAL(entry) && isGV(HeVAL(entry))
    50        
1718 2342 100       && GvHV(HeVAL(entry)) && HvENAME(GvHV(HeVAL(entry)))
    100        
    50        
    50        
    100        
    100        
    50        
    50        
1719           ) {
1720           STRLEN klen;
1721 368 50       const char * const key = HePV(entry,klen);
    0        
1722 368 50       if ((klen > 1 && key[klen-1]==':' && key[klen-2]==':')
    50        
    50        
1723 0 0       || (klen == 1 && key[0] == ':')) {
    0        
1724 368         mro_package_moved(
1725           NULL, GvHV(HeVAL(entry)),
1726           (GV *)HeVAL(entry), 0
1727           );
1728           }
1729           }
1730 544851755         return hv_free_ent_ret(hv, entry);
1731           }
1732            
1733            
1734           /*
1735           =for apidoc hv_undef
1736            
1737           Undefines the hash. The XS equivalent of C.
1738            
1739           As well as freeing all the elements of the hash (like hv_clear()), this
1740           also frees any auxiliary data and storage associated with the hash.
1741            
1742           If any destructors are triggered as a result, the hv itself may
1743           be freed.
1744            
1745           See also L.
1746            
1747           =cut
1748           */
1749            
1750           void
1751 112050944         Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags)
1752           {
1753           dVAR;
1754           XPVHV* xhv;
1755           const char *name;
1756 112050944         const bool save = !!SvREFCNT(hv);
1757            
1758 112050944 50       if (!hv)
1759 112050944         return;
1760           DEBUG_A(Perl_hv_assert(aTHX_ hv));
1761 112050944         xhv = (XPVHV*)SvANY(hv);
1762            
1763           /* The name must be deleted before the call to hfreeeeentries so that
1764           CVs are anonymised properly. But the effective name must be pre-
1765           served until after that call (and only deleted afterwards if the
1766           call originated from sv_clear). For stashes with one name that is
1767           both the canonical name and the effective name, hv_name_set has to
1768           allocate an array for storing the effective name. We can skip that
1769           during global destruction, as it does not matter where the CVs point
1770           if they will be freed anyway. */
1771           /* note that the code following prior to hfreeentries is duplicated
1772           * in sv_clear(), and changes here should be done there too */
1773 112050944 100       if (PL_phase != PERL_PHASE_DESTRUCT && (name = HvNAME(hv))) {
    100        
    100        
    100        
    100        
    50        
    100        
    100        
1774 314 50       if (PL_stashcache) {
1775           DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for '%"
1776           HEKf"'\n", HvNAME_HEK(hv)));
1777 314 50       (void)hv_delete(PL_stashcache, name,
    50        
    100        
    50        
    50        
    100        
    100        
    50        
    50        
    100        
    50        
    50        
    100        
    50        
    50        
    100        
    50        
    50        
    100        
1778           HEK_UTF8(HvNAME_HEK(hv)) ? -HvNAMELEN_get(hv) : HvNAMELEN_get(hv),
1779           G_DISCARD
1780           );
1781           }
1782 314         hv_name_set(hv, NULL, 0, 0);
1783           }
1784 112050944 100       if (save) {
1785 2780130         ENTER;
1786 2780130         SAVEFREESV(SvREFCNT_inc_simple_NN(hv));
1787           }
1788 112050944         hfreeentries(hv);
1789 112050944 100       if (SvOOK(hv)) {
1790 16876529         struct xpvhv_aux * const aux = HvAUX(hv);
1791           struct mro_meta *meta;
1792            
1793 16876529 50       if ((name = HvENAME_get(hv))) {
    100        
    100        
    50        
    100        
    50        
    100        
1794 422 100       if (PL_phase != PERL_PHASE_DESTRUCT)
1795 418         mro_isa_changed_in(hv);
1796 422 50       if (PL_stashcache) {
1797           DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for effective name '%"
1798           HEKf"'\n", HvENAME_HEK(hv)));
1799 422 50       (void)hv_delete(
    50        
    50        
    100        
    50        
    50        
    50        
    50        
    100        
    50        
    100        
    50        
    50        
    50        
    50        
    50        
    0        
    50        
    50        
    50        
    50        
    100        
    50        
1800           PL_stashcache, name,
1801           HEK_UTF8(HvENAME_HEK(hv)) ? -HvENAMELEN_get(hv) : HvENAMELEN_get(hv),
1802           G_DISCARD
1803           );
1804           }
1805           }
1806            
1807           /* If this call originated from sv_clear, then we must check for
1808           * effective names that need freeing, as well as the usual name. */
1809 16876529 50       name = HvNAME(hv);
    100        
    100        
    100        
    50        
    100        
1810 16876529 100       if (flags & HV_NAME_SETALL ? !!aux->xhv_name_u.xhvnameu_name : !!name) {
    100        
1811 836 100       if (name && PL_stashcache) {
    50        
1812           DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for name '%"
1813           HEKf"'\n", HvNAME_HEK(hv)));
1814 22 50       (void)hv_delete(PL_stashcache, name, (HEK_UTF8(HvNAME_HEK(hv)) ? -HvNAMELEN_get(hv) : HvNAMELEN_get(hv)), G_DISCARD);
    50        
    100        
    50        
    50        
    100        
    100        
    50        
    50        
    50        
    50        
    0        
    50        
    50        
    50        
    100        
    50        
    50        
    100        
1815           }
1816 836         hv_name_set(hv, NULL, 0, flags);
1817           }
1818 16876529 100       if((meta = aux->xhv_mro_meta)) {
1819 860 50       if (meta->mro_linear_all) {
1820 0         SvREFCNT_dec_NN(meta->mro_linear_all);
1821           /* mro_linear_current is just acting as a shortcut pointer,
1822           hence the else. */
1823           }
1824           else
1825           /* Only the current MRO is stored, so this owns the data.
1826           */
1827 860         SvREFCNT_dec(meta->mro_linear_current);
1828 860         SvREFCNT_dec(meta->mro_nextmethod);
1829 860         SvREFCNT_dec(meta->isa);
1830 860         SvREFCNT_dec(meta->super);
1831 860         Safefree(meta);
1832 860         aux->xhv_mro_meta = NULL;
1833           }
1834 16876529 100       if (!aux->xhv_name_u.xhvnameu_name && ! aux->xhv_backreferences)
    100        
1835 16876491         SvFLAGS(hv) &= ~SVf_OOK;
1836           }
1837 112050944 100       if (!SvOOK(hv)) {
1838 112050906         Safefree(HvARRAY(hv));
1839 112050906         xhv->xhv_max = PERL_HASH_DEFAULT_HvMAX; /* HvMAX(hv) = 7 (it's a normal hash) */
1840 112050906         HvARRAY(hv) = 0;
1841           }
1842           /* if we're freeing the HV, the SvMAGIC field has been reused for
1843           * other purposes, and so there can't be any placeholder magic */
1844 112050944 100       if (SvREFCNT(hv))
1845 2780130         HvPLACEHOLDERS_set(hv, 0);
1846            
1847 112050944 100       if (SvRMAGICAL(hv))
1848 4         mg_clear(MUTABLE_SV(hv));
1849 112050944 100       if (save) LEAVE;
1850           }
1851            
1852           /*
1853           =for apidoc hv_fill
1854            
1855           Returns the number of hash buckets that happen to be in use. This function is
1856           wrapped by the macro C.
1857            
1858           Previously this value was always stored in the HV structure, which created an
1859           overhead on every hash (and pretty much every object) for something that was
1860           rarely used. Now we calculate it on demand the first time that it is needed,
1861           and cache it if that calculation is going to be costly to repeat. The cached
1862           value is updated by insertions and deletions, but (currently) discarded if
1863           the hash is split.
1864            
1865           =cut
1866           */
1867            
1868           STRLEN
1869 109227         Perl_hv_fill(pTHX_ HV *const hv)
1870           {
1871           STRLEN count = 0;
1872 109227         HE **ents = HvARRAY(hv);
1873 109227 100       struct xpvhv_aux *aux = SvOOK(hv) ? HvAUX(hv) : NULL;
1874            
1875           PERL_ARGS_ASSERT_HV_FILL;
1876            
1877           /* No keys implies no buckets used.
1878           One key can only possibly mean one bucket used. */
1879 109227 100       if (HvTOTALKEYS(hv) < 2)
1880 1124         return HvTOTALKEYS(hv);
1881            
1882           #ifndef DEBUGGING
1883 108103 100       if (aux && aux->xhv_fill_lazy)
    100        
1884 51238         return aux->xhv_fill_lazy;
1885           #endif
1886            
1887 56865 50       if (ents) {
1888 56865         HE *const *const last = ents + HvMAX(hv);
1889 56865         count = last + 1 - ents;
1890            
1891           do {
1892 9408208 100       if (!*ents)
1893 4982208         --count;
1894 9408208 100       } while (++ents <= last);
1895           }
1896 56865 100       if (aux) {
1897           #ifdef DEBUGGING
1898           if (aux->xhv_fill_lazy)
1899           assert(aux->xhv_fill_lazy == count);
1900           #endif
1901 38996         aux->xhv_fill_lazy = count;
1902 17869 100       } else if (HvMAX(hv) >= HV_FILL_THRESHOLD) {
1903 11125         aux = hv_auxinit(hv);
1904 62696         aux->xhv_fill_lazy = count;
1905           }
1906           return count;
1907           }
1908            
1909           /* hash a pointer to a U32 - Used in the hash traversal randomization
1910           * and bucket order randomization code
1911           *
1912           * this code was derived from Sereal, which was derived from autobox.
1913           */
1914            
1915           PERL_STATIC_INLINE U32 S_ptr_hash(PTRV u) {
1916           #if PTRSIZE == 8
1917           /*
1918           * This is one of Thomas Wang's hash functions for 64-bit integers from:
1919           * http://www.concentric.net/~Ttwang/tech/inthash.htm
1920           */
1921 29311986         u = (~u) + (u << 18);
1922 29311986         u = u ^ (u >> 31);
1923 29311986         u = u * 21;
1924 29311986         u = u ^ (u >> 11);
1925 29311986         u = u + (u << 6);
1926 29311986         u = u ^ (u >> 22);
1927           #else
1928           /*
1929           * This is one of Bob Jenkins' hash functions for 32-bit integers
1930           * from: http://burtleburtle.net/bob/hash/integer.html
1931           */
1932           u = (u + 0x7ed55d16) + (u << 12);
1933           u = (u ^ 0xc761c23c) ^ (u >> 19);
1934           u = (u + 0x165667b1) + (u << 5);
1935           u = (u + 0xd3a2646c) ^ (u << 9);
1936           u = (u + 0xfd7046c5) + (u << 3);
1937           u = (u ^ 0xb55a4f09) ^ (u >> 16);
1938           #endif
1939 29311986         return (U32)u;
1940           }
1941            
1942            
1943           static struct xpvhv_aux*
1944 20064292         S_hv_auxinit(pTHX_ HV *hv) {
1945           struct xpvhv_aux *iter;
1946           char *array;
1947            
1948           PERL_ARGS_ASSERT_HV_AUXINIT;
1949            
1950 20064292 50       if (!SvOOK(hv)) {
1951 20064292 100       if (!HvARRAY(hv)) {
1952 2274333         Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1953           + sizeof(struct xpvhv_aux), char);
1954           } else {
1955 17789959         array = (char *) HvARRAY(hv);
1956 17789959         Renew(array, PERL_HV_ARRAY_ALLOC_BYTES(HvMAX(hv) + 1)
1957           + sizeof(struct xpvhv_aux), char);
1958           }
1959 20064292         HvARRAY(hv) = (HE**)array;
1960 20064292         SvOOK_on(hv);
1961 20064292         iter = HvAUX(hv);
1962           #ifdef PERL_HASH_RANDOMIZE_KEYS
1963 20064292 100       if (PL_HASH_RAND_BITS_ENABLED) {
1964           /* mix in some new state to PL_hash_rand_bits to "randomize" the traversal order*/
1965 20064208 100       if (PL_HASH_RAND_BITS_ENABLED == 1)
1966 30048667         PL_hash_rand_bits += ptr_hash((PTRV)array);
1967 20064208         PL_hash_rand_bits = ROTL_UV(PL_hash_rand_bits,1);
1968           }
1969 20064292         iter->xhv_rand = (U32)PL_hash_rand_bits;
1970           #endif
1971           } else {
1972 0         iter = HvAUX(hv);
1973           }
1974            
1975 20064292         iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
1976 20064292         iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
1977           #ifdef PERL_HASH_RANDOMIZE_KEYS
1978 20064292         iter->xhv_last_rand = iter->xhv_rand;
1979           #endif
1980 20064292         iter->xhv_fill_lazy = 0;
1981 20064292         iter->xhv_name_u.xhvnameu_name = 0;
1982 20064292         iter->xhv_name_count = 0;
1983 20064292         iter->xhv_backreferences = 0;
1984 20064292         iter->xhv_mro_meta = NULL;
1985 20064292         return iter;
1986           }
1987            
1988           /*
1989           =for apidoc hv_iterinit
1990            
1991           Prepares a starting point to traverse a hash table. Returns the number of
1992           keys in the hash (i.e. the same as C). The return value is
1993           currently only meaningful for hashes without tie magic.
1994            
1995           NOTE: Before version 5.004_65, C used to return the number of
1996           hash buckets that happen to be in use. If you still need that esoteric
1997           value, you can get it through the macro C.
1998            
1999            
2000           =cut
2001           */
2002            
2003           I32
2004 29854094         Perl_hv_iterinit(pTHX_ HV *hv)
2005           {
2006           PERL_ARGS_ASSERT_HV_ITERINIT;
2007            
2008           /* FIXME: Are we not NULL, or do we croak? Place bets now! */
2009            
2010 29854094 50       if (!hv)
2011 0         Perl_croak(aTHX_ "Bad hash");
2012            
2013 29854094 100       if (SvOOK(hv)) {
2014 11425676         struct xpvhv_aux * const iter = HvAUX(hv);
2015 11425676         HE * const entry = iter->xhv_eiter; /* HvEITER(hv) */
2016 11425676 100       if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
    100        
2017 8         HvLAZYDEL_off(hv);
2018 8         hv_free_ent(hv, entry);
2019           }
2020 11425676         iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2021 11425676         iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2022           #ifdef PERL_HASH_RANDOMIZE_KEYS
2023 11425676         iter->xhv_last_rand = iter->xhv_rand;
2024           #endif
2025           } else {
2026 18428418         hv_auxinit(hv);
2027           }
2028            
2029           /* used to be xhv->xhv_fill before 5.004_65 */
2030 29854094         return HvTOTALKEYS(hv);
2031           }
2032            
2033           I32 *
2034 0         Perl_hv_riter_p(pTHX_ HV *hv) {
2035           struct xpvhv_aux *iter;
2036            
2037           PERL_ARGS_ASSERT_HV_RITER_P;
2038            
2039 0 0       if (!hv)
2040 0         Perl_croak(aTHX_ "Bad hash");
2041            
2042 0 0       iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2043 0         return &(iter->xhv_riter);
2044           }
2045            
2046           HE **
2047 2         Perl_hv_eiter_p(pTHX_ HV *hv) {
2048           struct xpvhv_aux *iter;
2049            
2050           PERL_ARGS_ASSERT_HV_EITER_P;
2051            
2052 2 50       if (!hv)
2053 0         Perl_croak(aTHX_ "Bad hash");
2054            
2055 2 50       iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2056 2         return &(iter->xhv_eiter);
2057           }
2058            
2059           void
2060 15784077         Perl_hv_riter_set(pTHX_ HV *hv, I32 riter) {
2061           struct xpvhv_aux *iter;
2062            
2063           PERL_ARGS_ASSERT_HV_RITER_SET;
2064            
2065 15784077 50       if (!hv)
2066 0         Perl_croak(aTHX_ "Bad hash");
2067            
2068 15784077 50       if (SvOOK(hv)) {
2069 15784077         iter = HvAUX(hv);
2070           } else {
2071 0 0       if (riter == -1)
2072 15784077         return;
2073            
2074 0         iter = hv_auxinit(hv);
2075           }
2076 15784077         iter->xhv_riter = riter;
2077           }
2078            
2079           void
2080 0         Perl_hv_rand_set(pTHX_ HV *hv, U32 new_xhv_rand) {
2081           struct xpvhv_aux *iter;
2082            
2083           PERL_ARGS_ASSERT_HV_RAND_SET;
2084            
2085           #ifdef PERL_HASH_RANDOMIZE_KEYS
2086 0 0       if (!hv)
2087 0         Perl_croak(aTHX_ "Bad hash");
2088            
2089 0 0       if (SvOOK(hv)) {
2090 0         iter = HvAUX(hv);
2091           } else {
2092 0         iter = hv_auxinit(hv);
2093           }
2094 0         iter->xhv_rand = new_xhv_rand;
2095           #else
2096           Perl_croak(aTHX_ "This Perl has not been built with support for randomized hash key traversal but something called Perl_hv_rand_set().");
2097           #endif
2098 0         }
2099            
2100           void
2101 16504911         Perl_hv_eiter_set(pTHX_ HV *hv, HE *eiter) {
2102           struct xpvhv_aux *iter;
2103            
2104           PERL_ARGS_ASSERT_HV_EITER_SET;
2105            
2106 16504911 50       if (!hv)
2107 0         Perl_croak(aTHX_ "Bad hash");
2108            
2109 16504911 100       if (SvOOK(hv)) {
2110 16484639         iter = HvAUX(hv);
2111           } else {
2112           /* 0 is the default so don't go malloc()ing a new structure just to
2113           hold 0. */
2114 20272 50       if (!eiter)
2115 16504911         return;
2116            
2117 0         iter = hv_auxinit(hv);
2118           }
2119 16484639         iter->xhv_eiter = eiter;
2120           }
2121            
2122           void
2123 1626451         Perl_hv_name_set(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2124           {
2125           dVAR;
2126           struct xpvhv_aux *iter;
2127           U32 hash;
2128           HEK **spot;
2129            
2130           PERL_ARGS_ASSERT_HV_NAME_SET;
2131            
2132 1626451 50       if (len > I32_MAX)
2133 0         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2134            
2135 1626451 100       if (SvOOK(hv)) {
2136 26120         iter = HvAUX(hv);
2137 26120 100       if (iter->xhv_name_u.xhvnameu_name) {
2138 1774 100       if(iter->xhv_name_count) {
2139 1356 100       if(flags & HV_NAME_SETALL) {
2140 820         HEK ** const name = HvAUX(hv)->xhv_name_u.xhvnameu_names;
2141 1230 50       HEK **hekp = name + (
2142 820         iter->xhv_name_count < 0
2143 820         ? -iter->xhv_name_count
2144 0         : iter->xhv_name_count
2145           );
2146 1656 100       while(hekp-- > name+1)
2147 426         unshare_hek_or_pvn(*hekp, 0, 0, 0);
2148           /* The first elem may be null. */
2149 820 100       if(*name) unshare_hek_or_pvn(*name, 0, 0, 0);
2150 820         Safefree(name);
2151 820         spot = &iter->xhv_name_u.xhvnameu_name;
2152 820         iter->xhv_name_count = 0;
2153           }
2154           else {
2155 536 100       if(iter->xhv_name_count > 0) {
2156           /* shift some things over */
2157 72 50       Renew(
2158           iter->xhv_name_u.xhvnameu_names, iter->xhv_name_count + 1, HEK *
2159           );
2160 48         spot = iter->xhv_name_u.xhvnameu_names;
2161 48         spot[iter->xhv_name_count] = spot[1];
2162 48         spot[1] = spot[0];
2163 48         iter->xhv_name_count = -(iter->xhv_name_count + 1);
2164           }
2165 488 100       else if(*(spot = iter->xhv_name_u.xhvnameu_names)) {
2166 444         unshare_hek_or_pvn(*spot, 0, 0, 0);
2167           }
2168           }
2169           }
2170 418 100       else if (flags & HV_NAME_SETALL) {
2171 4         unshare_hek_or_pvn(iter->xhv_name_u.xhvnameu_name, 0, 0, 0);
2172 4         spot = &iter->xhv_name_u.xhvnameu_name;
2173           }
2174           else {
2175 414         HEK * const existing_name = iter->xhv_name_u.xhvnameu_name;
2176 414         Newx(iter->xhv_name_u.xhvnameu_names, 2, HEK *);
2177 414         iter->xhv_name_count = -2;
2178 414         spot = iter->xhv_name_u.xhvnameu_names;
2179 414         spot[1] = existing_name;
2180           }
2181           }
2182 24346         else { spot = &iter->xhv_name_u.xhvnameu_name; iter->xhv_name_count = 0; }
2183           } else {
2184 1600331 50       if (name == 0)
2185 1626451         return;
2186            
2187 1600331         iter = hv_auxinit(hv);
2188 1600331         spot = &iter->xhv_name_u.xhvnameu_name;
2189           }
2190 1626451         PERL_HASH(hash, name, len);
2191 1626451 100       *spot = name ? share_hek(name, flags & SVf_UTF8 ? -(I32)len : (I32)len, hash) : NULL;
    100        
2192           }
2193            
2194           /*
2195           This is basically sv_eq_flags() in sv.c, but we avoid the magic
2196           and bytes checking.
2197           */
2198            
2199           STATIC I32
2200 430         hek_eq_pvn_flags(pTHX_ const HEK *hek, const char* pv, const I32 pvlen, const U32 flags) {
2201 430 100       if ( (HEK_UTF8(hek) ? 1 : 0) != (flags & SVf_UTF8 ? 1 : 0) ) {
2202 2 50       if (flags & SVf_UTF8)
2203 0         return (bytes_cmp_utf8(
2204           (const U8*)HEK_KEY(hek), HEK_LEN(hek),
2205           (const U8*)pv, pvlen) == 0);
2206           else
2207 2         return (bytes_cmp_utf8(
2208           (const U8*)pv, pvlen,
2209           (const U8*)HEK_KEY(hek), HEK_LEN(hek)) == 0);
2210           }
2211           else
2212 857 100       return HEK_LEN(hek) == pvlen && ((HEK_KEY(hek) == pv)
    50        
2213 314 100       || memEQ(HEK_KEY(hek), pv, pvlen));
2214           }
2215            
2216           /*
2217           =for apidoc hv_ename_add
2218            
2219           Adds a name to a stash's internal list of effective names. See
2220           C.
2221            
2222           This is called when a stash is assigned to a new location in the symbol
2223           table.
2224            
2225           =cut
2226           */
2227            
2228           void
2229 704         Perl_hv_ename_add(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2230           {
2231           dVAR;
2232 704 50       struct xpvhv_aux *aux = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2233           U32 hash;
2234            
2235           PERL_ARGS_ASSERT_HV_ENAME_ADD;
2236            
2237 704 50       if (len > I32_MAX)
2238 0         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2239            
2240 704         PERL_HASH(hash, name, len);
2241            
2242 704 100       if (aux->xhv_name_count) {
2243 24         HEK ** const xhv_name = aux->xhv_name_u.xhvnameu_names;
2244 24         I32 count = aux->xhv_name_count;
2245 24 100       HEK **hekp = xhv_name + (count < 0 ? -count : count);
2246 66 100       while (hekp-- > xhv_name)
2247 36 100       if (
2248 85 100       (HEK_UTF8(*hekp) || (flags & SVf_UTF8))
    50        
    100        
2249 10         ? hek_eq_pvn_flags(aTHX_ *hekp, name, (I32)len, flags)
2250 32 100       : (HEK_LEN(*hekp) == (I32)len && memEQ(HEK_KEY(*hekp), name, len))
2251           ) {
2252 6 50       if (hekp == xhv_name && count < 0)
2253 6         aux->xhv_name_count = -count;
2254           return;
2255           }
2256 18 100       if (count < 0) aux->xhv_name_count--, count = -count;
2257 6         else aux->xhv_name_count++;
2258 27 50       Renew(aux->xhv_name_u.xhvnameu_names, count + 1, HEK *);
2259 18 100       (aux->xhv_name_u.xhvnameu_names)[count] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
2260           }
2261           else {
2262 680         HEK *existing_name = aux->xhv_name_u.xhvnameu_name;
2263 680 50       if (
2264 1768 100       existing_name && (
    100        
    100        
2265 748 50       (HEK_UTF8(existing_name) || (flags & SVf_UTF8))
2266 272         ? hek_eq_pvn_flags(aTHX_ existing_name, name, (I32)len, flags)
2267 547 100       : (HEK_LEN(existing_name) == (I32)len && memEQ(HEK_KEY(existing_name), name, len))
2268           )
2269           ) return;
2270 526         Newx(aux->xhv_name_u.xhvnameu_names, 2, HEK *);
2271 526 50       aux->xhv_name_count = existing_name ? 2 : -2;
2272 526         *aux->xhv_name_u.xhvnameu_names = existing_name;
2273 615 100       (aux->xhv_name_u.xhvnameu_names)[1] = share_hek(name, (flags & SVf_UTF8 ? -(I32)len : (I32)len), hash);
2274           }
2275           }
2276            
2277           /*
2278           =for apidoc hv_ename_delete
2279            
2280           Removes a name from a stash's internal list of effective names. If this is
2281           the name returned by C, then another name in the list will take
2282           its place (C will use it).
2283            
2284           This is called when a stash is deleted from the symbol table.
2285            
2286           =cut
2287           */
2288            
2289           void
2290 532         Perl_hv_ename_delete(pTHX_ HV *hv, const char *name, U32 len, U32 flags)
2291           {
2292           dVAR;
2293           struct xpvhv_aux *aux;
2294            
2295           PERL_ARGS_ASSERT_HV_ENAME_DELETE;
2296            
2297 532 50       if (len > I32_MAX)
2298 0         Perl_croak(aTHX_ "panic: hv name too long (%"UVuf")", (UV) len);
2299            
2300 532 50       if (!SvOOK(hv)) return;
2301            
2302 532         aux = HvAUX(hv);
2303 532 50       if (!aux->xhv_name_u.xhvnameu_name) return;
2304            
2305 532 100       if (aux->xhv_name_count) {
2306 112         HEK ** const namep = aux->xhv_name_u.xhvnameu_names;
2307 112         I32 const count = aux->xhv_name_count;
2308 112 100       HEK **victim = namep + (count < 0 ? -count : count);
2309 208 100       while (victim-- > namep + 1)
2310 112 100       if (
2311 265 100       (HEK_UTF8(*victim) || (flags & SVf_UTF8))
    50        
    100        
2312 30         ? hek_eq_pvn_flags(aTHX_ *victim, name, (I32)len, flags)
2313 113 100       : (HEK_LEN(*victim) == (I32)len && memEQ(HEK_KEY(*victim), name, len))
2314           ) {
2315 72         unshare_hek_or_pvn(*victim, 0, 0, 0);
2316 72 100       if (count < 0) ++aux->xhv_name_count;
2317 24         else --aux->xhv_name_count;
2318 72 100       if (
2319 72         (aux->xhv_name_count == 1 || aux->xhv_name_count == -1)
2320 70 50       && !*namep
2321           ) { /* if there are none left */
2322 0         Safefree(namep);
2323 0         aux->xhv_name_u.xhvnameu_names = NULL;
2324 0         aux->xhv_name_count = 0;
2325           }
2326           else {
2327           /* Move the last one back to fill the empty slot. It
2328           does not matter what order they are in. */
2329 72 100       *victim = *(namep + (count < 0 ? -count : count) - 1);
2330           }
2331           return;
2332           }
2333 40 50       if (
2334 93 50       count > 0 && (HEK_UTF8(*namep) || (flags & SVf_UTF8))
    100        
    50        
    50        
2335 14         ? hek_eq_pvn_flags(aTHX_ *namep, name, (I32)len, flags)
2336 39 50       : (HEK_LEN(*namep) == (I32)len && memEQ(HEK_KEY(*namep), name, len))
2337           ) {
2338 40         aux->xhv_name_count = -count;
2339           }
2340           }
2341 420 50       else if(
2342 998 100       (HEK_UTF8(aux->xhv_name_u.xhvnameu_name) || (flags & SVf_UTF8))
    50        
    50        
2343 104         ? hek_eq_pvn_flags(aTHX_ aux->xhv_name_u.xhvnameu_name, name, (I32)len, flags)
2344 474 50       : (HEK_LEN(aux->xhv_name_u.xhvnameu_name) == (I32)len &&
2345 316         memEQ(HEK_KEY(aux->xhv_name_u.xhvnameu_name), name, len))
2346           ) {
2347 420         HEK * const namehek = aux->xhv_name_u.xhvnameu_name;
2348 420         Newx(aux->xhv_name_u.xhvnameu_names, 1, HEK *);
2349 420         *aux->xhv_name_u.xhvnameu_names = namehek;
2350 476         aux->xhv_name_count = -1;
2351           }
2352           }
2353            
2354           AV **
2355 127159123         Perl_hv_backreferences_p(pTHX_ HV *hv) {
2356 127159123 100       struct xpvhv_aux * const iter = SvOOK(hv) ? HvAUX(hv) : hv_auxinit(hv);
2357            
2358           PERL_ARGS_ASSERT_HV_BACKREFERENCES_P;
2359           PERL_UNUSED_CONTEXT;
2360            
2361 127159123         return &(iter->xhv_backreferences);
2362           }
2363            
2364           void
2365 114578395         Perl_hv_kill_backrefs(pTHX_ HV *hv) {
2366           AV *av;
2367            
2368           PERL_ARGS_ASSERT_HV_KILL_BACKREFS;
2369            
2370 114578395 100       if (!SvOOK(hv))
2371 114578395         return;
2372            
2373 16964155         av = HvAUX(hv)->xhv_backreferences;
2374            
2375 16964155 100       if (av) {
2376 674         HvAUX(hv)->xhv_backreferences = 0;
2377 674         Perl_sv_kill_backrefs(aTHX_ MUTABLE_SV(hv), av);
2378 674 100       if (SvTYPE(av) == SVt_PVAV)
2379 508         SvREFCNT_dec_NN(av);
2380           }
2381           }
2382            
2383           /*
2384           hv_iternext is implemented as a macro in hv.h
2385            
2386           =for apidoc hv_iternext
2387            
2388           Returns entries from a hash iterator. See C.
2389            
2390           You may call C or C on the hash entry that the
2391           iterator currently points to, without losing your place or invalidating your
2392           iterator. Note that in this case the current entry is deleted from the hash
2393           with your iterator holding the last reference to it. Your iterator is flagged
2394           to free the entry on the next call to C, so you must not discard
2395           your iterator immediately else the entry will leak - call C to
2396           trigger the resource deallocation.
2397            
2398           =for apidoc hv_iternext_flags
2399            
2400           Returns entries from a hash iterator. See C and C.
2401           The C value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
2402           set the placeholders keys (for restricted hashes) will be returned in addition
2403           to normal keys. By default placeholders are automatically skipped over.
2404           Currently a placeholder is implemented with a value that is
2405           C<&PL_sv_placeholder>. Note that the implementation of placeholders and
2406           restricted hashes may change, and the implementation currently is
2407           insufficiently abstracted for any change to be tidy.
2408            
2409           =cut
2410           */
2411            
2412           HE *
2413 167645009         Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
2414           {
2415           dVAR;
2416           XPVHV* xhv;
2417           HE *entry;
2418           HE *oldentry;
2419           MAGIC* mg;
2420           struct xpvhv_aux *iter;
2421            
2422           PERL_ARGS_ASSERT_HV_ITERNEXT_FLAGS;
2423            
2424 167645009 50       if (!hv)
2425 0         Perl_croak(aTHX_ "Bad hash");
2426            
2427 167645009         xhv = (XPVHV*)SvANY(hv);
2428            
2429 167645009 100       if (!SvOOK(hv)) {
2430           /* Too many things (well, pp_each at least) merrily assume that you can
2431           call hv_iternext without calling hv_iterinit, so we'll have to deal
2432           with it. */
2433 19148         hv_iterinit(hv);
2434           }
2435 167645009         iter = HvAUX(hv);
2436            
2437 167645009         oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2438 167645009 100       if (SvMAGICAL(hv) && SvRMAGICAL(hv)) {
    100        
2439 14321652 100       if ( ( mg = mg_find((const SV *)hv, PERL_MAGIC_tied) ) ) {
2440 2021198         SV * const key = sv_newmortal();
2441 2021198 100       if (entry) {
2442 2017962 50       sv_setsv(key, HeSVKEY_force(entry));
    50        
2443 2017962 50       SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
    50        
2444 2017962         HeSVKEY_set(entry, NULL);
2445           }
2446           else {
2447           char *k;
2448           HEK *hek;
2449            
2450           /* one HE per MAGICAL hash */
2451 3236         iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
2452 3236         HvLAZYDEL_on(hv); /* make sure entry gets freed */
2453           Zero(entry, 1, HE);
2454 3236         Newxz(k, HEK_BASESIZE + sizeof(const SV *), char);
2455           hek = (HEK*)k;
2456 3236         HeKEY_hek(entry) = hek;
2457 3236         HeKLEN(entry) = HEf_SVKEY;
2458           }
2459 2021198         magic_nextpack(MUTABLE_SV(hv),mg,key);
2460 2021194 100       if (SvOK(key)) {
    50        
    50        
2461           /* force key to stay around until next time */
2462 2017982         HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
2463 2017982         return entry; /* beware, hent_val is not set */
2464           }
2465 3212         SvREFCNT_dec(HeVAL(entry));
2466 3212         Safefree(HeKEY_hek(entry));
2467 3212         del_HE(entry);
2468 3212         iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
2469 3212         HvLAZYDEL_off(hv);
2470 3212         return NULL;
2471           }
2472           }
2473           #if defined(DYNAMIC_ENV_FETCH) && !defined(__riscos__) /* set up %ENV for iteration */
2474           if (!entry && SvRMAGICAL((const SV *)hv)
2475           && mg_find((const SV *)hv, PERL_MAGIC_env)) {
2476           prime_env_iter();
2477           #ifdef VMS
2478           /* The prime_env_iter() on VMS just loaded up new hash values
2479           * so the iteration count needs to be reset back to the beginning
2480           */
2481           hv_iterinit(hv);
2482           iter = HvAUX(hv);
2483           oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
2484           #endif
2485           }
2486           #endif
2487            
2488           /* hv_iterinit now ensures this. */
2489           assert (HvARRAY(hv));
2490            
2491           /* At start of hash, entry is NULL. */
2492 165623811 100       if (entry)
2493           {
2494 136541115         entry = HeNEXT(entry);
2495 136541115 100       if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2496           /*
2497           * Skip past any placeholders -- don't want to include them in
2498           * any iteration.
2499           */
2500 93646173 100       while (entry && HeVAL(entry) == &PL_sv_placeholder) {
    50        
2501 0         entry = HeNEXT(entry);
2502           }
2503           }
2504           }
2505            
2506           #ifdef PERL_HASH_RANDOMIZE_KEYS
2507 165623811 100       if (iter->xhv_last_rand != iter->xhv_rand) {
2508 4114 100       if (iter->xhv_riter != -1) {
2509 34         Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
2510           "Use of each() on hash after insertion without resetting hash iterator results in undefined behavior"
2511           pTHX__FORMAT
2512           pTHX__VALUE);
2513           }
2514 4114         iter->xhv_last_rand = iter->xhv_rand;
2515           }
2516           #endif
2517            
2518           /* Skip the entire loop if the hash is empty. */
2519 260486262 100       if ((flags & HV_ITERNEXT_WANTPLACEHOLDERS)
    100        
    100        
2520 177434250         ? HvTOTALKEYS(hv) : HvUSEDKEYS(hv)) {
2521 442032410 100       while (!entry) {
2522           /* OK. Come to the end of the current list. Grab the next one. */
2523            
2524 290783190         iter->xhv_riter++; /* HvRITER(hv)++ */
2525 290783190 100       if (iter->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
2526           /* There is no next one. End of the hash. */
2527 11306571         iter->xhv_riter = -1; /* HvRITER(hv) = -1 */
2528           #ifdef PERL_HASH_RANDOMIZE_KEYS
2529 11306571         iter->xhv_last_rand = iter->xhv_rand; /* reset xhv_last_rand so we can detect inserts during traversal */
2530           #endif
2531 11306571         break;
2532           }
2533 279476619         entry = (HvARRAY(hv))[ PERL_HASH_ITER_BUCKET(iter) & xhv->xhv_max ];
2534            
2535 279476619 100       if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
2536           /* If we have an entry, but it's a placeholder, don't count it.
2537           Try the next. */
2538 227679764 100       while (entry && HeVAL(entry) == &PL_sv_placeholder)
    100        
2539 54         entry = HeNEXT(entry);
2540           }
2541           /* Will loop again if this linked list starts NULL
2542           (for HV_ITERNEXT_WANTPLACEHOLDERS)
2543           or if we run through it and find only placeholders. */
2544           }
2545           }
2546           else {
2547 3068020         iter->xhv_riter = -1;
2548           #ifdef PERL_HASH_RANDOMIZE_KEYS
2549 3068020         iter->xhv_last_rand = iter->xhv_rand;
2550           #endif
2551           }
2552            
2553 165623811 100       if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
    100        
2554 4         HvLAZYDEL_off(hv);
2555 4         hv_free_ent(hv, oldentry);
2556           }
2557            
2558 165623811         iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
2559 166634408         return entry;
2560           }
2561            
2562           /*
2563           =for apidoc hv_iterkey
2564            
2565           Returns the key from the current position of the hash iterator. See
2566           C.
2567            
2568           =cut
2569           */
2570            
2571           char *
2572 867338         Perl_hv_iterkey(pTHX_ HE *entry, I32 *retlen)
2573           {
2574           PERL_ARGS_ASSERT_HV_ITERKEY;
2575            
2576 867338 50       if (HeKLEN(entry) == HEf_SVKEY) {
2577           STRLEN len;
2578 0 0       char * const p = SvPV(HeKEY_sv(entry), len);
2579 0         *retlen = len;
2580 0         return p;
2581           }
2582           else {
2583 867338         *retlen = HeKLEN(entry);
2584 867338         return HeKEY(entry);
2585           }
2586           }
2587            
2588           /* unlike hv_iterval(), this always returns a mortal copy of the key */
2589           /*
2590           =for apidoc hv_iterkeysv
2591            
2592           Returns the key as an C from the current position of the hash
2593           iterator. The return value will always be a mortal copy of the key. Also
2594           see C.
2595            
2596           =cut
2597           */
2598            
2599           SV *
2600 84786295         Perl_hv_iterkeysv(pTHX_ HE *entry)
2601           {
2602           PERL_ARGS_ASSERT_HV_ITERKEYSV;
2603            
2604 84786295         return sv_2mortal(newSVhek(HeKEY_hek(entry)));
2605           }
2606            
2607           /*
2608           =for apidoc hv_iterval
2609            
2610           Returns the value from the current position of the hash iterator. See
2611           C.
2612            
2613           =cut
2614           */
2615            
2616           SV *
2617 74213257         Perl_hv_iterval(pTHX_ HV *hv, HE *entry)
2618           {
2619           PERL_ARGS_ASSERT_HV_ITERVAL;
2620            
2621 74213257 100       if (SvRMAGICAL(hv)) {
2622 9643056 100       if (mg_find((const SV *)hv, PERL_MAGIC_tied)) {
2623 1913406         SV* const sv = sv_newmortal();
2624 1913406 50       if (HeKLEN(entry) == HEf_SVKEY)
2625 1913406         mg_copy(MUTABLE_SV(hv), sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
2626           else
2627 0         mg_copy(MUTABLE_SV(hv), sv, HeKEY(entry), HeKLEN(entry));
2628           return sv;
2629           }
2630           }
2631 73256554         return HeVAL(entry);
2632           }
2633            
2634           /*
2635           =for apidoc hv_iternextsv
2636            
2637           Performs an C, C, and C in one
2638           operation.
2639            
2640           =cut
2641           */
2642            
2643           SV *
2644 6534         Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
2645           {
2646 6534         HE * const he = hv_iternext_flags(hv, 0);
2647            
2648           PERL_ARGS_ASSERT_HV_ITERNEXTSV;
2649            
2650 6534 100       if (!he)
2651           return NULL;
2652 6014         *key = hv_iterkey(he, retlen);
2653 6274         return hv_iterval(hv, he);
2654           }
2655            
2656           /*
2657            
2658           Now a macro in hv.h
2659            
2660           =for apidoc hv_magic
2661            
2662           Adds magic to a hash. See C.
2663            
2664           =cut
2665           */
2666            
2667           /* possibly free a shared string if no one has access to it
2668           * len and hash must both be valid for str.
2669           */
2670           void
2671 0         Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
2672           {
2673 0         unshare_hek_or_pvn (NULL, str, len, hash);
2674 0         }
2675            
2676            
2677           void
2678 992224976         Perl_unshare_hek(pTHX_ HEK *hek)
2679           {
2680           assert(hek);
2681 992224976         unshare_hek_or_pvn(hek, NULL, 0, 0);
2682 992224976         }
2683            
2684           /* possibly free a shared string if no one has access to it
2685           hek if non-NULL takes priority over the other 3, else str, len and hash
2686           are used. If so, len and hash must both be valid for str.
2687           */
2688           STATIC void
2689 992238132         S_unshare_hek_or_pvn(pTHX_ const HEK *hek, const char *str, I32 len, U32 hash)
2690           {
2691           dVAR;
2692           XPVHV* xhv;
2693           HE *entry;
2694           HE **oentry;
2695 992238132         bool is_utf8 = FALSE;
2696           int k_flags = 0;
2697           const char * const save = str;
2698           struct shared_he *he = NULL;
2699            
2700 992238132 50       if (hek) {
2701           /* Find the shared he which is just before us in memory. */
2702 992238132         he = (struct shared_he *)(((char *)hek)
2703           - STRUCT_OFFSET(struct shared_he,
2704           shared_he_hek));
2705            
2706           /* Assert that the caller passed us a genuine (or at least consistent)
2707           shared hek */
2708           assert (he->shared_he_he.hent_hek == hek);
2709            
2710 992238132 100       if (he->shared_he_he.he_valu.hent_refcount - 1) {
2711 938911576         --he->shared_he_he.he_valu.hent_refcount;
2712 1460891942         return;
2713           }
2714            
2715 53326556         hash = HEK_HASH(hek);
2716 0 0       } else if (len < 0) {
2717 0         STRLEN tmplen = -len;
2718 0         is_utf8 = TRUE;
2719           /* See the note in hv_fetch(). --jhi */
2720 0         str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2721 0         len = tmplen;
2722 0 0       if (is_utf8)
2723           k_flags = HVhek_UTF8;
2724 0 0       if (str != save)
2725 0         k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2726           }
2727            
2728           /* what follows was the moral equivalent of:
2729           if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
2730           if (--*Svp == NULL)
2731           hv_delete(PL_strtab, str, len, G_DISCARD, hash);
2732           } */
2733 53326556         xhv = (XPVHV*)SvANY(PL_strtab);
2734           /* assert(xhv_array != 0) */
2735 53326556         oentry = &(HvARRAY(PL_strtab))[hash & (I32) HvMAX(PL_strtab)];
2736 53326556 50       if (he) {
2737 53326556         const HE *const he_he = &(he->shared_he_he);
2738 57494397 50       for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2739 57494397 100       if (entry == he_he)
2740           break;
2741           }
2742           } else {
2743 0         const int flags_masked = k_flags & HVhek_MASK;
2744 0 0       for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
2745 0 0       if (HeHASH(entry) != hash) /* strings can't be equal */
2746 0         continue;
2747 0 0       if (HeKLEN(entry) != len)
2748 0         continue;
2749 0 0       if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
    0        
2750 0         continue;
2751 0 0       if (HeKFLAGS(entry) != flags_masked)
2752 0         continue;
2753           break;
2754           }
2755           }
2756            
2757 53326556 50       if (entry) {
2758 53326556 50       if (--entry->he_valu.hent_refcount == 0) {
2759 53326556         *oentry = HeNEXT(entry);
2760 53326556         Safefree(entry);
2761 53326556         xhv->xhv_keys--; /* HvTOTALKEYS(hv)-- */
2762           }
2763           }
2764            
2765 53326556 50       if (!entry)
2766 0 0       Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
    0        
2767           "Attempt to free nonexistent shared string '%s'%s"
2768           pTHX__FORMAT,
2769           hek ? HEK_KEY(hek) : str,
2770 0         ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
2771 53326556 50       if (k_flags & HVhek_FREEKEY)
2772 0         Safefree(str);
2773           }
2774            
2775           /* get a (constant) string ptr from the global string table
2776           * string will get added if it is not already there.
2777           * len and hash must both be valid for str.
2778           */
2779           HEK *
2780 135095081         Perl_share_hek(pTHX_ const char *str, I32 len, U32 hash)
2781           {
2782 135095081         bool is_utf8 = FALSE;
2783           int flags = 0;
2784           const char * const save = str;
2785            
2786           PERL_ARGS_ASSERT_SHARE_HEK;
2787            
2788 135095081 100       if (len < 0) {
2789 8870         STRLEN tmplen = -len;
2790 8870         is_utf8 = TRUE;
2791           /* See the note in hv_fetch(). --jhi */
2792 8870         str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2793 8870         len = tmplen;
2794           /* If we were able to downgrade here, then than means that we were passed
2795           in a key which only had chars 0-255, but was utf8 encoded. */
2796 8870 100       if (is_utf8)
2797           flags = HVhek_UTF8;
2798           /* If we found we were able to downgrade the string to bytes, then
2799           we should flag that it needs upgrading on keys or each. Also flag
2800           that we need share_hek_flags to free the string. */
2801 8870 100       if (str != save) {
2802           dVAR;
2803 2134         PERL_HASH(hash, str, len);
2804 2134         flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2805           }
2806           }
2807            
2808 135095081         return share_hek_flags (str, len, hash, flags);
2809           }
2810            
2811           STATIC HEK *
2812 644778342         S_share_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
2813           {
2814           dVAR;
2815           HE *entry;
2816 644778342         const int flags_masked = flags & HVhek_MASK;
2817 644778342         const U32 hindex = hash & (I32) HvMAX(PL_strtab);
2818 644778342         XPVHV * const xhv = (XPVHV*)SvANY(PL_strtab);
2819            
2820           PERL_ARGS_ASSERT_SHARE_HEK_FLAGS;
2821            
2822           /* what follows is the moral equivalent of:
2823            
2824           if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2825           hv_store(PL_strtab, str, len, NULL, hash);
2826            
2827           Can't rehash the shared string table, so not sure if it's worth
2828           counting the number of entries in the linked list
2829           */
2830            
2831           /* assert(xhv_array != 0) */
2832 644778342         entry = (HvARRAY(PL_strtab))[hindex];
2833 971367863 100       for (;entry; entry = HeNEXT(entry)) {
2834 868039212 100       if (HeHASH(entry) != hash) /* strings can't be equal */
2835 318716680         continue;
2836 549322532 100       if (HeKLEN(entry) != len)
2837 2131         continue;
2838 549320401 100       if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
    100        
2839 1160         continue;
2840 549319241 100       if (HeKFLAGS(entry) != flags_masked)
2841 7869550         continue;
2842           break;
2843           }
2844            
2845 644778342 100       if (!entry) {
2846           /* What used to be head of the list.
2847           If this is NULL, then we're the first entry for this slot, which
2848           means we need to increate fill. */
2849           struct shared_he *new_entry;
2850           HEK *hek;
2851           char *k;
2852 103328651         HE **const head = &HvARRAY(PL_strtab)[hindex];
2853 103328651         HE *const next = *head;
2854            
2855           /* We don't actually store a HE from the arena and a regular HEK.
2856           Instead we allocate one chunk of memory big enough for both,
2857           and put the HEK straight after the HE. This way we can find the
2858           HE directly from the HEK.
2859           */
2860            
2861 103328651         Newx(k, STRUCT_OFFSET(struct shared_he,
2862           shared_he_hek.hek_key[0]) + len + 2, char);
2863           new_entry = (struct shared_he *)k;
2864 103328651         entry = &(new_entry->shared_he_he);
2865 103328651         hek = &(new_entry->shared_he_hek);
2866            
2867 103328651         Copy(str, HEK_KEY(hek), len, char);
2868 103328651         HEK_KEY(hek)[len] = 0;
2869 103328651         HEK_LEN(hek) = len;
2870 103328651         HEK_HASH(hek) = hash;
2871 103328651         HEK_FLAGS(hek) = (unsigned char)flags_masked;
2872            
2873           /* Still "point" to the HEK, so that other code need not know what
2874           we're up to. */
2875 103328651         HeKEY_hek(entry) = hek;
2876 103328651         entry->he_valu.hent_refcount = 0;
2877 103328651         HeNEXT(entry) = next;
2878 103328651         *head = entry;
2879            
2880 103328651         xhv->xhv_keys++; /* HvTOTALKEYS(hv)++ */
2881 103328651 100       if (!next) { /* initial entry? */
2882 50724316 100       } else if ( DO_HSPLIT(xhv) ) {
2883 39124         const STRLEN oldsize = xhv->xhv_max + 1;
2884 39124         hsplit(PL_strtab, oldsize, oldsize * 2);
2885           }
2886           }
2887            
2888 644778342         ++entry->he_valu.hent_refcount;
2889            
2890 644778342 100       if (flags & HVhek_FREEKEY)
2891 8038         Safefree(str);
2892            
2893 644778342         return HeKEY_hek(entry);
2894           }
2895            
2896           SSize_t *
2897 30808         Perl_hv_placeholders_p(pTHX_ HV *hv)
2898           {
2899           dVAR;
2900 30808         MAGIC *mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2901            
2902           PERL_ARGS_ASSERT_HV_PLACEHOLDERS_P;
2903            
2904 30808 100       if (!mg) {
2905 450         mg = sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, 0);
2906            
2907 450 50       if (!mg) {
2908 0         Perl_die(aTHX_ "panic: hv_placeholders_p");
2909           }
2910           }
2911 30808         return &(mg->mg_len);
2912           }
2913            
2914            
2915           I32
2916 12624945         Perl_hv_placeholders_get(pTHX_ const HV *hv)
2917           {
2918           dVAR;
2919 12624945         MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2920            
2921           PERL_ARGS_ASSERT_HV_PLACEHOLDERS_GET;
2922            
2923 12624945 100       return mg ? mg->mg_len : 0;
2924           }
2925            
2926           void
2927 19835608         Perl_hv_placeholders_set(pTHX_ HV *hv, I32 ph)
2928           {
2929           dVAR;
2930 19835608         MAGIC * const mg = mg_find((const SV *)hv, PERL_MAGIC_rhash);
2931            
2932           PERL_ARGS_ASSERT_HV_PLACEHOLDERS_SET;
2933            
2934 19835608 50       if (mg) {
2935 0         mg->mg_len = ph;
2936 19835608 50       } else if (ph) {
2937 0 0       if (!sv_magicext(MUTABLE_SV(hv), 0, PERL_MAGIC_rhash, 0, 0, ph))
2938 0         Perl_die(aTHX_ "panic: hv_placeholders_set");
2939           }
2940           /* else we don't need to add magic to record 0 placeholders. */
2941 19835608         }
2942            
2943           STATIC SV *
2944 22255048         S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
2945           {
2946           dVAR;
2947           SV *value;
2948            
2949           PERL_ARGS_ASSERT_REFCOUNTED_HE_VALUE;
2950            
2951 22255048         switch(he->refcounted_he_data[0] & HVrhek_typemask) {
2952           case HVrhek_undef:
2953 284         value = newSV(0);
2954 284         break;
2955           case HVrhek_delete:
2956           value = &PL_sv_placeholder;
2957           break;
2958           case HVrhek_IV:
2959 1792864         value = newSViv(he->refcounted_he_val.refcounted_he_u_iv);
2960 1792864         break;
2961           case HVrhek_UV:
2962 14         value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv);
2963 14         break;
2964           case HVrhek_PV:
2965           case HVrhek_PV_UTF8:
2966           /* Create a string SV that directly points to the bytes in our
2967           structure. */
2968 3800894         value = newSV_type(SVt_PV);
2969 3800894         SvPV_set(value, (char *) he->refcounted_he_data + 1);
2970 3800894         SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len);
2971           /* This stops anything trying to free it */
2972 3800894         SvLEN_set(value, 0);
2973 3800894         SvPOK_on(value);
2974 3800894         SvREADONLY_on(value);
2975 3800894 100       if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8)
2976 618         SvUTF8_on(value);
2977           break;
2978           default:
2979 0         Perl_croak(aTHX_ "panic: refcounted_he_value bad flags %"UVxf,
2980 0         (UV)he->refcounted_he_data[0]);
2981           }
2982 22255048         return value;
2983           }
2984            
2985           /*
2986           =for apidoc m|HV *|refcounted_he_chain_2hv|const struct refcounted_he *c|U32 flags
2987            
2988           Generates and returns a C representing the content of a
2989           C chain.
2990           I is currently unused and must be zero.
2991            
2992           =cut
2993           */
2994           HV *
2995 1917860         Perl_refcounted_he_chain_2hv(pTHX_ const struct refcounted_he *chain, U32 flags)
2996           {
2997           dVAR;
2998           HV *hv;
2999           U32 placeholders, max;
3000            
3001 1917860 50       if (flags)
3002 0         Perl_croak(aTHX_ "panic: refcounted_he_chain_2hv bad flags %"UVxf,
3003           (UV)flags);
3004            
3005           /* We could chase the chain once to get an idea of the number of keys,
3006           and call ksplit. But for now we'll make a potentially inefficient
3007           hash with only 8 entries in its array. */
3008 1917860         hv = newHV();
3009 1917860         max = HvMAX(hv);
3010 1917860 50       if (!HvARRAY(hv)) {
3011           char *array;
3012 1917860         Newxz(array, PERL_HV_ARRAY_ALLOC_BYTES(max + 1), char);
3013 1917860         HvARRAY(hv) = (HE**)array;
3014           }
3015            
3016           placeholders = 0;
3017 10012152 100       while (chain) {
3018           #ifdef USE_ITHREADS
3019           U32 hash = chain->refcounted_he_hash;
3020           #else
3021 8094292         U32 hash = HEK_HASH(chain->refcounted_he_hek);
3022           #endif
3023 8094292         HE **oentry = &((HvARRAY(hv))[hash & max]);
3024 8094292         HE *entry = *oentry;
3025           SV *value;
3026            
3027 13148298 100       for (; entry; entry = HeNEXT(entry)) {
3028 6283524 100       if (HeHASH(entry) == hash) {
3029           /* We might have a duplicate key here. If so, entry is older
3030           than the key we've already put in the hash, so if they are
3031           the same, skip adding entry. */
3032           #ifdef USE_ITHREADS
3033           const STRLEN klen = HeKLEN(entry);
3034           const char *const key = HeKEY(entry);
3035           if (klen == chain->refcounted_he_keylen
3036           && (!!HeKUTF8(entry)
3037           == !!(chain->refcounted_he_data[0] & HVhek_UTF8))
3038           && memEQ(key, REF_HE_KEY(chain), klen))
3039           goto next_please;
3040           #else
3041 1229558 100       if (HeKEY_hek(entry) == chain->refcounted_he_hek)
3042           goto next_please;
3043 369046 50       if (HeKLEN(entry) == HEK_LEN(chain->refcounted_he_hek)
3044 369046 100       && HeKUTF8(entry) == HEK_UTF8(chain->refcounted_he_hek)
3045 369006 50       && memEQ(HeKEY(entry), HEK_KEY(chain->refcounted_he_hek),
3046           HeKLEN(entry)))
3047           goto next_please;
3048           #endif
3049           }
3050           }
3051           assert (!entry);
3052 6864774         entry = new_HE();
3053            
3054           #ifdef USE_ITHREADS
3055           HeKEY_hek(entry)
3056           = share_hek_flags(REF_HE_KEY(chain),
3057           chain->refcounted_he_keylen,
3058           chain->refcounted_he_hash,
3059           (chain->refcounted_he_data[0]
3060           & (HVhek_UTF8|HVhek_WASUTF8)));
3061           #else
3062 6864774         HeKEY_hek(entry) = share_hek_hek(chain->refcounted_he_hek);
3063           #endif
3064 6864774         value = refcounted_he_value(chain);
3065 6864774 100       if (value == &PL_sv_placeholder)
3066 1382950         placeholders++;
3067 6864774         HeVAL(entry) = value;
3068            
3069           /* Link it into the chain. */
3070 6864774         HeNEXT(entry) = *oentry;
3071 6864774         *oentry = entry;
3072            
3073 6864774         HvTOTALKEYS(hv)++;
3074            
3075           next_please:
3076 8094292         chain = chain->refcounted_he_next;
3077           }
3078            
3079 1917860 100       if (placeholders) {
3080 173942         clear_placeholders(hv, placeholders);
3081 173942         HvTOTALKEYS(hv) -= placeholders;
3082           }
3083            
3084           /* We could check in the loop to see if we encounter any keys with key
3085           flags, but it's probably not worth it, as this per-hash flag is only
3086           really meant as an optimisation for things like Storable. */
3087 1917860         HvHASKFLAGS_on(hv);
3088           DEBUG_A(Perl_hv_assert(aTHX_ hv));
3089            
3090 1917860         return hv;
3091           }
3092            
3093           /*
3094           =for apidoc m|SV *|refcounted_he_fetch_pvn|const struct refcounted_he *chain|const char *keypv|STRLEN keylen|U32 hash|U32 flags
3095            
3096           Search along a C chain for an entry with the key specified
3097           by I and I. If I has the C
3098           bit set, the key octets are interpreted as UTF-8, otherwise they
3099           are interpreted as Latin-1. I is a precomputed hash of the key
3100           string, or zero if it has not been precomputed. Returns a mortal scalar
3101           representing the value associated with the key, or C<&PL_sv_placeholder>
3102           if there is no value associated with the key.
3103            
3104           =cut
3105           */
3106            
3107           SV *
3108 15444236         Perl_refcounted_he_fetch_pvn(pTHX_ const struct refcounted_he *chain,
3109           const char *keypv, STRLEN keylen, U32 hash, U32 flags)
3110           {
3111           dVAR;
3112           U8 utf8_flag;
3113           PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PVN;
3114            
3115 15444236 50       if (flags & ~(REFCOUNTED_HE_KEY_UTF8|REFCOUNTED_HE_EXISTS))
3116 0         Perl_croak(aTHX_ "panic: refcounted_he_fetch_pvn bad flags %"UVxf,
3117           (UV)flags);
3118 15444236 100       if (!chain)
3119           return &PL_sv_placeholder;
3120 15444112 100       if (flags & REFCOUNTED_HE_KEY_UTF8) {
3121           /* For searching purposes, canonicalise to Latin-1 where possible. */
3122 22         const char *keyend = keypv + keylen, *p;
3123           STRLEN nonascii_count = 0;
3124 118 100       for (p = keypv; p != keyend; p++) {
3125 102 100       if (! UTF8_IS_INVARIANT(*p)) {
3126 18 100       if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, keyend)) {
    50        
    50        
3127           goto canonicalised_key;
3128           }
3129 12         nonascii_count++;
3130 12         p++;
3131           }
3132           }
3133 16 100       if (nonascii_count) {
3134           char *q;
3135 12         const char *p = keypv, *keyend = keypv + keylen;
3136 12         keylen -= nonascii_count;
3137 12         Newx(q, keylen, char);
3138 12         SAVEFREEPV(q);
3139           keypv = q;
3140 72 100       for (; p != keyend; p++, q++) {
3141 60         U8 c = (U8)*p;
3142 60 100       if (UTF8_IS_INVARIANT(c)) {
3143 48         *q = (char) c;
3144           }
3145           else {
3146 12         p++;
3147 12         *q = (char) TWO_BYTE_UTF8_TO_NATIVE(c, *p);
3148           }
3149           }
3150           }
3151 16         flags &= ~REFCOUNTED_HE_KEY_UTF8;
3152           canonicalised_key: ;
3153           }
3154 15444112         utf8_flag = (flags & REFCOUNTED_HE_KEY_UTF8) ? HVhek_UTF8 : 0;
3155 15444112 50       if (!hash)
3156 15444112         PERL_HASH(hash, keypv, keylen);
3157            
3158 8928516 100       for (; chain; chain = chain->refcounted_he_next) {
3159 16600046 100       if (
3160           #ifdef USE_ITHREADS
3161           hash == chain->refcounted_he_hash &&
3162           keylen == chain->refcounted_he_keylen &&
3163           memEQ(REF_HE_KEY(chain), keypv, keylen) &&
3164           utf8_flag == (chain->refcounted_he_data[0] & HVhek_UTF8)
3165           #else
3166 23693613 50       hash == HEK_HASH(chain->refcounted_he_hek) &&
3167 23090385 50       keylen == (STRLEN)HEK_LEN(chain->refcounted_he_hek) &&
3168 23090385 100       memEQ(HEK_KEY(chain->refcounted_he_hek), keypv, keylen) &&
3169 15393590         utf8_flag == (HEK_FLAGS(chain->refcounted_he_hek) & HVhek_UTF8)
3170           #endif
3171           ) {
3172 15393586 100       if (flags & REFCOUNTED_HE_EXISTS)
3173 4968         return (chain->refcounted_he_data[0] & HVrhek_typemask)
3174           == HVrhek_delete
3175 3312 100       ? NULL : &PL_sv_yes;
3176 15390274         return sv_2mortal(refcounted_he_value(chain));
3177           }
3178           }
3179 7747381 50       return flags & REFCOUNTED_HE_EXISTS ? NULL : &PL_sv_placeholder;
3180           }
3181            
3182           /*
3183           =for apidoc m|SV *|refcounted_he_fetch_pv|const struct refcounted_he *chain|const char *key|U32 hash|U32 flags
3184            
3185           Like L, but takes a nul-terminated string
3186           instead of a string/length pair.
3187            
3188           =cut
3189           */
3190            
3191           SV *
3192 6         Perl_refcounted_he_fetch_pv(pTHX_ const struct refcounted_he *chain,
3193           const char *key, U32 hash, U32 flags)
3194           {
3195           PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_PV;
3196 6         return refcounted_he_fetch_pvn(chain, key, strlen(key), hash, flags);
3197           }
3198            
3199           /*
3200           =for apidoc m|SV *|refcounted_he_fetch_sv|const struct refcounted_he *chain|SV *key|U32 hash|U32 flags
3201            
3202           Like L, but takes a Perl scalar instead of a
3203           string/length pair.
3204            
3205           =cut
3206           */
3207            
3208           SV *
3209 106         Perl_refcounted_he_fetch_sv(pTHX_ const struct refcounted_he *chain,
3210           SV *key, U32 hash, U32 flags)
3211           {
3212           const char *keypv;
3213           STRLEN keylen;
3214           PERL_ARGS_ASSERT_REFCOUNTED_HE_FETCH_SV;
3215 106 50       if (flags & REFCOUNTED_HE_KEY_UTF8)
3216 0         Perl_croak(aTHX_ "panic: refcounted_he_fetch_sv bad flags %"UVxf,
3217           (UV)flags);
3218 106 50       keypv = SvPV_const(key, keylen);
3219 106 100       if (SvUTF8(key))
3220 2         flags |= REFCOUNTED_HE_KEY_UTF8;
3221 106 50       if (!hash && SvIsCOW_shared_hash(key))
    100        
    50        
3222 0         hash = SvSHARED_HASH(key);
3223 106         return refcounted_he_fetch_pvn(chain, keypv, keylen, hash, flags);
3224           }
3225            
3226           /*
3227           =for apidoc m|struct refcounted_he *|refcounted_he_new_pvn|struct refcounted_he *parent|const char *keypv|STRLEN keylen|U32 hash|SV *value|U32 flags
3228            
3229           Creates a new C. This consists of a single key/value
3230           pair and a reference to an existing C chain (which may
3231           be empty), and thus forms a longer chain. When using the longer chain,
3232           the new key/value pair takes precedence over any entry for the same key
3233           further along the chain.
3234            
3235           The new key is specified by I and I. If I has
3236           the C bit set, the key octets are interpreted
3237           as UTF-8, otherwise they are interpreted as Latin-1. I is
3238           a precomputed hash of the key string, or zero if it has not been
3239           precomputed.
3240            
3241           I is the scalar value to store for this key. I is copied
3242           by this function, which thus does not take ownership of any reference
3243           to it, and later changes to the scalar will not be reflected in the
3244           value visible in the C. Complex types of scalar will not
3245           be stored with referential integrity, but will be coerced to strings.
3246           I may be either null or C<&PL_sv_placeholder> to indicate that no
3247           value is to be associated with the key; this, as with any non-null value,
3248           takes precedence over the existence of a value for the key further along
3249           the chain.
3250            
3251           I points to the rest of the C chain to be
3252           attached to the new C. This function takes ownership
3253           of one reference to I, and returns one reference to the new
3254           C.
3255            
3256           =cut
3257           */
3258            
3259           struct refcounted_he *
3260 237456         Perl_refcounted_he_new_pvn(pTHX_ struct refcounted_he *parent,
3261           const char *keypv, STRLEN keylen, U32 hash, SV *value, U32 flags)
3262           {
3263           dVAR;
3264 237456         STRLEN value_len = 0;
3265           const char *value_p = NULL;
3266           bool is_pv;
3267           char value_type;
3268           char hekflags;
3269           STRLEN key_offset = 1;
3270           struct refcounted_he *he;
3271           PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PVN;
3272            
3273 237456 100       if (!value || value == &PL_sv_placeholder) {
    50        
3274           value_type = HVrhek_delete;
3275 205442 100       } else if (SvPOK(value)) {
3276           value_type = HVrhek_PV;
3277 85240 100       } else if (SvIOK(value)) {
3278 83312 100       value_type = SvUOK((const SV *)value) ? HVrhek_UV : HVrhek_IV;
3279 1928 100       } else if (!SvOK(value)) {
    50        
    50        
3280           value_type = HVrhek_undef;
3281           } else {
3282           value_type = HVrhek_PV;
3283           }
3284 237456         is_pv = value_type == HVrhek_PV;
3285 237456 100       if (is_pv) {
3286           /* Do it this way so that the SvUTF8() test is after the SvPV, in case
3287           the value is overloaded, and doesn't yet have the UTF-8flag set. */
3288 122112 100       value_p = SvPV_const(value, value_len);
3289 122112 100       if (SvUTF8(value))
3290           value_type = HVrhek_PV_UTF8;
3291 122112         key_offset = value_len + 2;
3292           }
3293           hekflags = value_type;
3294            
3295 237456 100       if (flags & REFCOUNTED_HE_KEY_UTF8) {
3296           /* Canonicalise to Latin-1 where possible. */
3297 18         const char *keyend = keypv + keylen, *p;
3298           STRLEN nonascii_count = 0;
3299 84 100       for (p = keypv; p != keyend; p++) {
3300 74 100       if (! UTF8_IS_INVARIANT(*p)) {
3301 16 100       if (! UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, keyend)) {
    50        
    50        
3302           goto canonicalised_key;
3303           }
3304 8         nonascii_count++;
3305 8         p++;
3306           }
3307           }
3308 10 100       if (nonascii_count) {
3309           char *q;
3310 8         const char *p = keypv, *keyend = keypv + keylen;
3311 8         keylen -= nonascii_count;
3312 8         Newx(q, keylen, char);
3313 8         SAVEFREEPV(q);
3314           keypv = q;
3315 48 100       for (; p != keyend; p++, q++) {
3316 40         U8 c = (U8)*p;
3317 40 100       if (UTF8_IS_INVARIANT(c)) {
3318 32         *q = (char) c;
3319           }
3320           else {
3321 8         p++;
3322 8         *q = (char) TWO_BYTE_UTF8_TO_NATIVE(c, *p);
3323           }
3324           }
3325           }
3326 10         flags &= ~REFCOUNTED_HE_KEY_UTF8;
3327           canonicalised_key: ;
3328           }
3329 237456 100       if (flags & REFCOUNTED_HE_KEY_UTF8)
3330 8         hekflags |= HVhek_UTF8;
3331 237456 100       if (!hash)
3332 236720         PERL_HASH(hash, keypv, keylen);
3333            
3334           #ifdef USE_ITHREADS
3335           he = (struct refcounted_he*)
3336           PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3337           + keylen
3338           + key_offset);
3339           #else
3340 237456         he = (struct refcounted_he*)
3341 237456         PerlMemShared_malloc(sizeof(struct refcounted_he) - 1
3342           + key_offset);
3343           #endif
3344            
3345 237456         he->refcounted_he_next = parent;
3346            
3347 237456 100       if (is_pv) {
3348 122112         Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char);
3349 122112         he->refcounted_he_val.refcounted_he_u_len = value_len;
3350 115344 100       } else if (value_type == HVrhek_IV) {
3351 83308         he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value);
3352 32036 100       } else if (value_type == HVrhek_UV) {
3353 4         he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value);
3354           }
3355            
3356           #ifdef USE_ITHREADS
3357           he->refcounted_he_hash = hash;
3358           he->refcounted_he_keylen = keylen;
3359           Copy(keypv, he->refcounted_he_data + key_offset, keylen, char);
3360           #else
3361 237456         he->refcounted_he_hek = share_hek_flags(keypv, keylen, hash, hekflags);
3362           #endif
3363            
3364 237456         he->refcounted_he_data[0] = hekflags;
3365 237456         he->refcounted_he_refcnt = 1;
3366            
3367 237456         return he;
3368           }
3369            
3370           /*
3371           =for apidoc m|struct refcounted_he *|refcounted_he_new_pv|struct refcounted_he *parent|const char *key|U32 hash|SV *value|U32 flags
3372            
3373           Like L, but takes a nul-terminated string instead
3374           of a string/length pair.
3375            
3376           =cut
3377           */
3378            
3379           struct refcounted_he *
3380 4         Perl_refcounted_he_new_pv(pTHX_ struct refcounted_he *parent,
3381           const char *key, U32 hash, SV *value, U32 flags)
3382           {
3383           PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_PV;
3384 4         return refcounted_he_new_pvn(parent, key, strlen(key), hash, value, flags);
3385           }
3386            
3387           /*
3388           =for apidoc m|struct refcounted_he *|refcounted_he_new_sv|struct refcounted_he *parent|SV *key|U32 hash|SV *value|U32 flags
3389            
3390           Like L, but takes a Perl scalar instead of a
3391           string/length pair.
3392            
3393           =cut
3394           */
3395            
3396           struct refcounted_he *
3397 145010         Perl_refcounted_he_new_sv(pTHX_ struct refcounted_he *parent,
3398           SV *key, U32 hash, SV *value, U32 flags)
3399           {
3400           const char *keypv;
3401           STRLEN keylen;
3402           PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_SV;
3403 145010 50       if (flags & REFCOUNTED_HE_KEY_UTF8)
3404 0         Perl_croak(aTHX_ "panic: refcounted_he_new_sv bad flags %"UVxf,
3405           (UV)flags);
3406 145010 50       keypv = SvPV_const(key, keylen);
3407 145010 100       if (SvUTF8(key))
3408 4         flags |= REFCOUNTED_HE_KEY_UTF8;
3409 145010 50       if (!hash && SvIsCOW_shared_hash(key))
    100        
    50        
3410 736         hash = SvSHARED_HASH(key);
3411 145010         return refcounted_he_new_pvn(parent, keypv, keylen, hash, value, flags);
3412           }
3413            
3414           /*
3415           =for apidoc m|void|refcounted_he_free|struct refcounted_he *he
3416            
3417           Decrements the reference count of a C by one. If the
3418           reference count reaches zero the structure's memory is freed, which
3419           (recursively) causes a reduction of its parent C's
3420           reference count. It is safe to pass a null pointer to this function:
3421           no action occurs in this case.
3422            
3423           =cut
3424           */
3425            
3426           void
3427 76095932         Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
3428           dVAR;
3429           PERL_UNUSED_CONTEXT;
3430            
3431 113061102 100       while (he) {
3432           struct refcounted_he *copy;
3433           U32 new_count;
3434            
3435           HINTS_REFCNT_LOCK;
3436 1724316         new_count = --he->refcounted_he_refcnt;
3437           HINTS_REFCNT_UNLOCK;
3438          
3439 1724316 100       if (new_count) {
3440 76095932         return;
3441           }
3442            
3443           #ifndef USE_ITHREADS
3444 12204         unshare_hek_or_pvn (he->refcounted_he_hek, 0, 0, 0);
3445           #endif
3446           copy = he;
3447 12204         he = he->refcounted_he_next;
3448 12204         PerlMemShared_free(copy);
3449           }
3450           }
3451            
3452           /*
3453           =for apidoc m|struct refcounted_he *|refcounted_he_inc|struct refcounted_he *he
3454            
3455           Increment the reference count of a C. The pointer to the
3456           C is also returned. It is safe to pass a null pointer
3457           to this function: no action occurs and a null pointer is returned.
3458            
3459           =cut
3460           */
3461            
3462           struct refcounted_he *
3463 150078523         Perl_refcounted_he_inc(pTHX_ struct refcounted_he *he)
3464           {
3465           dVAR;
3466 150078523 100       if (he) {
3467           HINTS_REFCNT_LOCK;
3468 2545032         he->refcounted_he_refcnt++;
3469           HINTS_REFCNT_UNLOCK;
3470           }
3471 150078523         return he;
3472           }
3473            
3474           /*
3475           =for apidoc cop_fetch_label
3476            
3477           Returns the label attached to a cop.
3478           The flags pointer may be set to C or 0.
3479            
3480           =cut
3481           */
3482            
3483           /* pp_entereval is aware that labels are stored with a key ':' at the top of
3484           the linked list. */
3485           const char *
3486 89148059         Perl_cop_fetch_label(pTHX_ COP *const cop, STRLEN *len, U32 *flags) {
3487 89148059         struct refcounted_he *const chain = cop->cop_hints_hash;
3488            
3489           PERL_ARGS_ASSERT_COP_FETCH_LABEL;
3490            
3491 89148059 100       if (!chain)
3492           return NULL;
3493           #ifdef USE_ITHREADS
3494           if (chain->refcounted_he_keylen != 1)
3495           return NULL;
3496           if (*REF_HE_KEY(chain) != ':')
3497           return NULL;
3498           #else
3499 2157478 100       if ((STRLEN)HEK_LEN(chain->refcounted_he_hek) != 1)
3500           return NULL;
3501 438784 100       if (*HEK_KEY(chain->refcounted_he_hek) != ':')
3502           return NULL;
3503           #endif
3504           /* Stop anyone trying to really mess us up by adding their own value for
3505           ':' into %^H */
3506 657387 50       if ((chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV
3507 438738         && (chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV_UTF8)
3508           return NULL;
3509            
3510 438738 100       if (len)
3511 338042         *len = chain->refcounted_he_val.refcounted_he_u_len;
3512 438738 100       if (flags) {
3513 338042 100       *flags = ((chain->refcounted_he_data[0] & HVrhek_typemask)
3514           == HVrhek_PV_UTF8) ? SVf_UTF8 : 0;
3515           }
3516 46025521         return chain->refcounted_he_data + 1;
3517           }
3518            
3519           /*
3520           =for apidoc cop_store_label
3521            
3522           Save a label into a C. You need to set flags to C
3523           for a utf-8 label.
3524            
3525           =cut
3526           */
3527            
3528           void
3529 92402         Perl_cop_store_label(pTHX_ COP *const cop, const char *label, STRLEN len,
3530           U32 flags)
3531           {
3532           SV *labelsv;
3533           PERL_ARGS_ASSERT_COP_STORE_LABEL;
3534            
3535 92402 50       if (flags & ~(SVf_UTF8))
3536 0         Perl_croak(aTHX_ "panic: cop_store_label illegal flag bits 0x%" UVxf,
3537           (UV)flags);
3538 92402         labelsv = newSVpvn_flags(label, len, SVs_TEMP);
3539 92402 100       if (flags & SVf_UTF8)
3540 358         SvUTF8_on(labelsv);
3541           cop->cop_hints_hash
3542 92402         = refcounted_he_new_pvs(cop->cop_hints_hash, ":", labelsv, 0);
3543 92402         }
3544            
3545           /*
3546           =for apidoc hv_assert
3547            
3548           Check that a hash is in an internally consistent state.
3549            
3550           =cut
3551           */
3552            
3553           #ifdef DEBUGGING
3554            
3555           void
3556           Perl_hv_assert(pTHX_ HV *hv)
3557           {
3558           dVAR;
3559           HE* entry;
3560           int withflags = 0;
3561           int placeholders = 0;
3562           int real = 0;
3563           int bad = 0;
3564           const I32 riter = HvRITER_get(hv);
3565           HE *eiter = HvEITER_get(hv);
3566            
3567           PERL_ARGS_ASSERT_HV_ASSERT;
3568            
3569           (void)hv_iterinit(hv);
3570            
3571           while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))) {
3572           /* sanity check the values */
3573           if (HeVAL(entry) == &PL_sv_placeholder)
3574           placeholders++;
3575           else
3576           real++;
3577           /* sanity check the keys */
3578           if (HeSVKEY(entry)) {
3579           NOOP; /* Don't know what to check on SV keys. */
3580           } else if (HeKUTF8(entry)) {
3581           withflags++;
3582           if (HeKWASUTF8(entry)) {
3583           PerlIO_printf(Perl_debug_log,
3584           "hash key has both WASUTF8 and UTF8: '%.*s'\n",
3585           (int) HeKLEN(entry), HeKEY(entry));
3586           bad = 1;
3587           }
3588           } else if (HeKWASUTF8(entry))
3589           withflags++;
3590           }
3591           if (!SvTIED_mg((const SV *)hv, PERL_MAGIC_tied)) {
3592           static const char bad_count[] = "Count %d %s(s), but hash reports %d\n";
3593           const int nhashkeys = HvUSEDKEYS(hv);
3594           const int nhashplaceholders = HvPLACEHOLDERS_get(hv);
3595            
3596           if (nhashkeys != real) {
3597           PerlIO_printf(Perl_debug_log, bad_count, real, "keys", nhashkeys );
3598           bad = 1;
3599           }
3600           if (nhashplaceholders != placeholders) {
3601           PerlIO_printf(Perl_debug_log, bad_count, placeholders, "placeholder", nhashplaceholders );
3602           bad = 1;
3603           }
3604           }
3605           if (withflags && ! HvHASKFLAGS(hv)) {
3606           PerlIO_printf(Perl_debug_log,
3607           "Hash has HASKFLAGS off but I count %d key(s) with flags\n",
3608           withflags);
3609           bad = 1;
3610           }
3611           if (bad) {
3612           sv_dump(MUTABLE_SV(hv));
3613           }
3614           HvRITER_set(hv, riter); /* Restore hash iterator state */
3615           HvEITER_set(hv, eiter);
3616           }
3617            
3618           #endif
3619            
3620           /*
3621           * Local variables:
3622           * c-indentation-style: bsd
3623           * c-basic-offset: 4
3624           * indent-tabs-mode: nil
3625           * End:
3626           *
3627           * ex: set ts=8 sts=4 sw=4 et:
3628           */