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