1 /* hv.c
2 *
3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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 of all that I have seen." --Bilbo
13 */
14
15 /*
16 =head1 Hash Manipulation Functions
17
18 A HV structure represents a Perl hash. It consists mainly of an array
19 of pointers, each of which points to a linked list of HE structures. The
20 array is indexed by the hash function of the key, so each linked list
21 represents all the hash entries with the same hash value. Each HE contains
22 a pointer to the actual value, plus a pointer to a HEK structure which
23 holds the key and hash value.
24
25 =cut
26
27 */
28
29 #include "EXTERN.h"
30 #define PERL_IN_HV_C
31 #define PERL_HASH_INTERNAL_ACCESS
32 #include "perl.h"
33
34 #define HV_MAX_LENGTH_BEFORE_SPLIT 14
35
36 STATIC void
S_more_he(pTHX)37 S_more_he(pTHX)
38 {
39 register HE* he;
40 register HE* heend;
41 XPV *ptr;
42 Newx(ptr, PERL_ARENA_SIZE/sizeof(XPV), XPV);
43 ptr->xpv_pv = (char*)PL_he_arenaroot;
44 PL_he_arenaroot = ptr;
45
46 he = (HE*)ptr;
47 heend = &he[PERL_ARENA_SIZE / sizeof(HE) - 1];
48 PL_he_root = ++he;
49 while (he < heend) {
50 HeNEXT(he) = (HE*)(he + 1);
51 he++;
52 }
53 HeNEXT(he) = 0;
54 }
55
56 STATIC HE*
S_new_he(pTHX)57 S_new_he(pTHX)
58 {
59 HE* he;
60 LOCK_SV_MUTEX;
61 if (!PL_he_root)
62 S_more_he(aTHX);
63 he = PL_he_root;
64 PL_he_root = HeNEXT(he);
65 UNLOCK_SV_MUTEX;
66 return he;
67 }
68
69 STATIC void
S_del_he(pTHX_ HE * p)70 S_del_he(pTHX_ HE *p)
71 {
72 LOCK_SV_MUTEX;
73 HeNEXT(p) = (HE*)PL_he_root;
74 PL_he_root = p;
75 UNLOCK_SV_MUTEX;
76 }
77
78 #ifdef PURIFY
79
80 #define new_HE() (HE*)safemalloc(sizeof(HE))
81 #define del_HE(p) safefree((char*)p)
82
83 #else
84
85 #define new_HE() new_he()
86 #define del_HE(p) del_he(p)
87
88 #endif
89
90 STATIC HEK *
S_save_hek_flags(pTHX_ const char * str,I32 len,U32 hash,int flags)91 S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags)
92 {
93 const int flags_masked = flags & HVhek_MASK;
94 char *k;
95 register HEK *hek;
96
97 Newx(k, HEK_BASESIZE + len + 2, char);
98 hek = (HEK*)k;
99 Copy(str, HEK_KEY(hek), len, char);
100 HEK_KEY(hek)[len] = 0;
101 HEK_LEN(hek) = len;
102 HEK_HASH(hek) = hash;
103 HEK_FLAGS(hek) = (unsigned char)flags_masked;
104
105 if (flags & HVhek_FREEKEY)
106 Safefree(str);
107 return hek;
108 }
109
110 /* free the pool of temporary HE/HEK pairs returned by hv_fetch_ent
111 * for tied hashes */
112
113 void
Perl_free_tied_hv_pool(pTHX)114 Perl_free_tied_hv_pool(pTHX)
115 {
116 HE *he = PL_hv_fetch_ent_mh;
117 while (he) {
118 HE * const ohe = he;
119 Safefree(HeKEY_hek(he));
120 he = HeNEXT(he);
121 del_HE(ohe);
122 }
123 PL_hv_fetch_ent_mh = Nullhe;
124 }
125
126 #if defined(USE_ITHREADS)
127 HE *
Perl_he_dup(pTHX_ HE * e,bool shared,CLONE_PARAMS * param)128 Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param)
129 {
130 HE *ret;
131
132 if (!e)
133 return Nullhe;
134 /* look for it in the table first */
135 ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
136 if (ret)
137 return ret;
138
139 /* create anew and remember what it is */
140 ret = new_HE();
141 ptr_table_store(PL_ptr_table, e, ret);
142
143 HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
144 if (HeKLEN(e) == HEf_SVKEY) {
145 char *k;
146 Newx(k, HEK_BASESIZE + sizeof(SV*), char);
147 HeKEY_hek(ret) = (HEK*)k;
148 HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param));
149 }
150 else if (shared)
151 HeKEY_hek(ret) = share_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
152 HeKFLAGS(e));
153 else
154 HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
155 HeKFLAGS(e));
156 HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e), param));
157 return ret;
158 }
159 #endif /* USE_ITHREADS */
160
161 static void
S_hv_notallowed(pTHX_ int flags,const char * key,I32 klen,const char * msg)162 S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen,
163 const char *msg)
164 {
165 SV *sv = sv_newmortal();
166 if (!(flags & HVhek_FREEKEY)) {
167 sv_setpvn(sv, key, klen);
168 }
169 else {
170 /* Need to free saved eventually assign to mortal SV */
171 /* XXX is this line an error ???: SV *sv = sv_newmortal(); */
172 sv_usepvn(sv, (char *) key, klen);
173 }
174 if (flags & HVhek_UTF8) {
175 SvUTF8_on(sv);
176 }
177 Perl_croak(aTHX_ msg, sv);
178 }
179
180 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
181 * contains an SV* */
182
183 #define HV_FETCH_ISSTORE 0x01
184 #define HV_FETCH_ISEXISTS 0x02
185 #define HV_FETCH_LVALUE 0x04
186 #define HV_FETCH_JUST_SV 0x08
187
188 /*
189 =for apidoc hv_store
190
191 Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is
192 the length of the key. The C<hash> parameter is the precomputed hash
193 value; if it is zero then Perl will compute it. The return value will be
194 NULL if the operation failed or if the value did not need to be actually
195 stored within the hash (as in the case of tied hashes). Otherwise it can
196 be dereferenced to get the original C<SV*>. Note that the caller is
197 responsible for suitably incrementing the reference count of C<val> before
198 the call, and decrementing it if the function returned NULL. Effectively
199 a successful hv_store takes ownership of one reference to C<val>. This is
200 usually what you want; a newly created SV has a reference count of one, so
201 if all your code does is create SVs then store them in a hash, hv_store
202 will own the only reference to the new SV, and your code doesn't need to do
203 anything further to tidy up. hv_store is not implemented as a call to
204 hv_store_ent, and does not create a temporary SV for the key, so if your
205 key data is not already in SV form then use hv_store in preference to
206 hv_store_ent.
207
208 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
209 information on how to use this function on tied hashes.
210
211 =cut
212 */
213
214 SV**
Perl_hv_store(pTHX_ HV * hv,const char * key,I32 klen_i32,SV * val,U32 hash)215 Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen_i32, SV *val, U32 hash)
216 {
217 HE *hek;
218 STRLEN klen;
219 int flags;
220
221 if (klen_i32 < 0) {
222 klen = -klen_i32;
223 flags = HVhek_UTF8;
224 } else {
225 klen = klen_i32;
226 flags = 0;
227 }
228 hek = hv_fetch_common (hv, NULL, key, klen, flags,
229 (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
230 return hek ? &HeVAL(hek) : NULL;
231 }
232
233 SV**
Perl_hv_store_flags(pTHX_ HV * hv,const char * key,I32 klen,SV * val,register U32 hash,int flags)234 Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val,
235 register U32 hash, int flags)
236 {
237 HE * const hek = hv_fetch_common (hv, NULL, key, klen, flags,
238 (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash);
239 return hek ? &HeVAL(hek) : NULL;
240 }
241
242 /*
243 =for apidoc hv_store_ent
244
245 Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash>
246 parameter is the precomputed hash value; if it is zero then Perl will
247 compute it. The return value is the new hash entry so created. It will be
248 NULL if the operation failed or if the value did not need to be actually
249 stored within the hash (as in the case of tied hashes). Otherwise the
250 contents of the return value can be accessed using the C<He?> macros
251 described here. Note that the caller is responsible for suitably
252 incrementing the reference count of C<val> before the call, and
253 decrementing it if the function returned NULL. Effectively a successful
254 hv_store_ent takes ownership of one reference to C<val>. This is
255 usually what you want; a newly created SV has a reference count of one, so
256 if all your code does is create SVs then store them in a hash, hv_store
257 will own the only reference to the new SV, and your code doesn't need to do
258 anything further to tidy up. Note that hv_store_ent only reads the C<key>;
259 unlike C<val> it does not take ownership of it, so maintaining the correct
260 reference count on C<key> is entirely the caller's responsibility. hv_store
261 is not implemented as a call to hv_store_ent, and does not create a temporary
262 SV for the key, so if your key data is not already in SV form then use
263 hv_store in preference to hv_store_ent.
264
265 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
266 information on how to use this function on tied hashes.
267
268 =cut
269 */
270
271 HE *
Perl_hv_store_ent(pTHX_ HV * hv,SV * keysv,SV * val,U32 hash)272 Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash)
273 {
274 return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISSTORE, val, hash);
275 }
276
277 /*
278 =for apidoc hv_exists
279
280 Returns a boolean indicating whether the specified hash key exists. The
281 C<klen> is the length of the key.
282
283 =cut
284 */
285
286 bool
Perl_hv_exists(pTHX_ HV * hv,const char * key,I32 klen_i32)287 Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen_i32)
288 {
289 STRLEN klen;
290 int flags;
291
292 if (klen_i32 < 0) {
293 klen = -klen_i32;
294 flags = HVhek_UTF8;
295 } else {
296 klen = klen_i32;
297 flags = 0;
298 }
299 return hv_fetch_common(hv, NULL, key, klen, flags, HV_FETCH_ISEXISTS, 0, 0)
300 ? TRUE : FALSE;
301 }
302
303 /*
304 =for apidoc hv_fetch
305
306 Returns the SV which corresponds to the specified key in the hash. The
307 C<klen> is the length of the key. If C<lval> is set then the fetch will be
308 part of a store. Check that the return value is non-null before
309 dereferencing it to an C<SV*>.
310
311 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
312 information on how to use this function on tied hashes.
313
314 =cut
315 */
316
317 SV**
Perl_hv_fetch(pTHX_ HV * hv,const char * key,I32 klen_i32,I32 lval)318 Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval)
319 {
320 HE *hek;
321 STRLEN klen;
322 int flags;
323
324 if (klen_i32 < 0) {
325 klen = -klen_i32;
326 flags = HVhek_UTF8;
327 } else {
328 klen = klen_i32;
329 flags = 0;
330 }
331 hek = hv_fetch_common (hv, NULL, key, klen, flags,
332 HV_FETCH_JUST_SV | (lval ? HV_FETCH_LVALUE : 0),
333 Nullsv, 0);
334 return hek ? &HeVAL(hek) : NULL;
335 }
336
337 /*
338 =for apidoc hv_exists_ent
339
340 Returns a boolean indicating whether the specified hash key exists. C<hash>
341 can be a valid precomputed hash value, or 0 to ask for it to be
342 computed.
343
344 =cut
345 */
346
347 bool
Perl_hv_exists_ent(pTHX_ HV * hv,SV * keysv,U32 hash)348 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
349 {
350 return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISEXISTS, 0, hash)
351 ? TRUE : FALSE;
352 }
353
354 /* returns an HE * structure with the all fields set */
355 /* note that hent_val will be a mortal sv for MAGICAL hashes */
356 /*
357 =for apidoc hv_fetch_ent
358
359 Returns the hash entry which corresponds to the specified key in the hash.
360 C<hash> must be a valid precomputed hash number for the given C<key>, or 0
361 if you want the function to compute it. IF C<lval> is set then the fetch
362 will be part of a store. Make sure the return value is non-null before
363 accessing it. The return value when C<tb> is a tied hash is a pointer to a
364 static location, so be sure to make a copy of the structure if you need to
365 store it somewhere.
366
367 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
368 information on how to use this function on tied hashes.
369
370 =cut
371 */
372
373 HE *
Perl_hv_fetch_ent(pTHX_ HV * hv,SV * keysv,I32 lval,register U32 hash)374 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
375 {
376 return hv_fetch_common(hv, keysv, NULL, 0, 0,
377 (lval ? HV_FETCH_LVALUE : 0), Nullsv, hash);
378 }
379
380 STATIC HE *
S_hv_fetch_common(pTHX_ HV * hv,SV * keysv,const char * key,STRLEN klen,int flags,int action,SV * val,register U32 hash)381 S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
382 int flags, int action, SV *val, register U32 hash)
383 {
384 XPVHV* xhv;
385 HE *entry;
386 HE **oentry;
387 SV *sv;
388 bool is_utf8;
389 int masked_flags;
390
391 if (!hv)
392 return 0;
393
394 if (keysv) {
395 if (flags & HVhek_FREEKEY)
396 Safefree(key);
397 key = SvPV_const(keysv, klen);
398 flags = 0;
399 is_utf8 = (SvUTF8(keysv) != 0);
400 } else {
401 is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE);
402 }
403
404 xhv = (XPVHV*)SvANY(hv);
405 if (SvMAGICAL(hv)) {
406 if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS)))
407 {
408 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
409 sv = sv_newmortal();
410
411 /* XXX should be able to skimp on the HE/HEK here when
412 HV_FETCH_JUST_SV is true. */
413
414 if (!keysv) {
415 keysv = newSVpvn(key, klen);
416 if (is_utf8) {
417 SvUTF8_on(keysv);
418 }
419 } else {
420 keysv = newSVsv(keysv);
421 }
422 mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY);
423
424 /* grab a fake HE/HEK pair from the pool or make a new one */
425 entry = PL_hv_fetch_ent_mh;
426 if (entry)
427 PL_hv_fetch_ent_mh = HeNEXT(entry);
428 else {
429 char *k;
430 entry = new_HE();
431 Newx(k, HEK_BASESIZE + sizeof(SV*), char);
432 HeKEY_hek(entry) = (HEK*)k;
433 }
434 HeNEXT(entry) = Nullhe;
435 HeSVKEY_set(entry, keysv);
436 HeVAL(entry) = sv;
437 sv_upgrade(sv, SVt_PVLV);
438 LvTYPE(sv) = 'T';
439 /* so we can free entry when freeing sv */
440 LvTARG(sv) = (SV*)entry;
441
442 /* XXX remove at some point? */
443 if (flags & HVhek_FREEKEY)
444 Safefree(key);
445
446 return entry;
447 }
448 #ifdef ENV_IS_CASELESS
449 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
450 U32 i;
451 for (i = 0; i < klen; ++i)
452 if (isLOWER(key[i])) {
453 /* Would be nice if we had a routine to do the
454 copy and upercase in a single pass through. */
455 const char *nkey = strupr(savepvn(key,klen));
456 /* Note that this fetch is for nkey (the uppercased
457 key) whereas the store is for key (the original) */
458 entry = hv_fetch_common(hv, Nullsv, nkey, klen,
459 HVhek_FREEKEY, /* free nkey */
460 0 /* non-LVAL fetch */,
461 Nullsv /* no value */,
462 0 /* compute hash */);
463 if (!entry && (action & HV_FETCH_LVALUE)) {
464 /* This call will free key if necessary.
465 Do it this way to encourage compiler to tail
466 call optimise. */
467 entry = hv_fetch_common(hv, keysv, key, klen,
468 flags, HV_FETCH_ISSTORE,
469 NEWSV(61,0), hash);
470 } else {
471 if (flags & HVhek_FREEKEY)
472 Safefree(key);
473 }
474 return entry;
475 }
476 }
477 #endif
478 } /* ISFETCH */
479 else if (SvRMAGICAL(hv) && (action & HV_FETCH_ISEXISTS)) {
480 if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((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(key, klen);
489 SvUTF8_on(keysv);
490 } else {
491 keysv = newSVsv(keysv);
492 }
493 mg_copy((SV*)hv, sv, (char *)sv_2mortal(keysv), HEf_SVKEY);
494 } else {
495 mg_copy((SV*)hv, sv, key, klen);
496 }
497 if (flags & HVhek_FREEKEY)
498 Safefree(key);
499 magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem));
500 /* This cast somewhat evil, but I'm merely using NULL/
501 not NULL to return the boolean exists.
502 And I know hv is not NULL. */
503 return SvTRUE(svret) ? (HE *)hv : NULL;
504 }
505 #ifdef ENV_IS_CASELESS
506 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
507 /* XXX This code isn't UTF8 clean. */
508 char * const keysave = (char * const)key;
509 /* Will need to free this, so set FREEKEY flag. */
510 key = savepvn(key,klen);
511 key = (const char*)strupr((char*)key);
512 is_utf8 = 0;
513 hash = 0;
514 keysv = 0;
515
516 if (flags & HVhek_FREEKEY) {
517 Safefree(keysave);
518 }
519 flags |= HVhek_FREEKEY;
520 }
521 #endif
522 } /* ISEXISTS */
523 else if (action & HV_FETCH_ISSTORE) {
524 bool needs_copy;
525 bool needs_store;
526 hv_magic_check (hv, &needs_copy, &needs_store);
527 if (needs_copy) {
528 const bool save_taint = PL_tainted;
529 if (keysv || is_utf8) {
530 if (!keysv) {
531 keysv = newSVpvn(key, klen);
532 SvUTF8_on(keysv);
533 }
534 if (PL_tainting)
535 PL_tainted = SvTAINTED(keysv);
536 keysv = sv_2mortal(newSVsv(keysv));
537 mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
538 } else {
539 mg_copy((SV*)hv, val, key, klen);
540 }
541
542 TAINT_IF(save_taint);
543 if (!xhv->xhv_array /* !HvARRAY(hv) */ && !needs_store) {
544 if (flags & HVhek_FREEKEY)
545 Safefree(key);
546 return Nullhe;
547 }
548 #ifdef ENV_IS_CASELESS
549 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
550 /* XXX This code isn't UTF8 clean. */
551 const char *keysave = key;
552 /* Will need to free this, so set FREEKEY flag. */
553 key = savepvn(key,klen);
554 key = (const char*)strupr((char*)key);
555 is_utf8 = 0;
556 hash = 0;
557 keysv = 0;
558
559 if (flags & HVhek_FREEKEY) {
560 Safefree(keysave);
561 }
562 flags |= HVhek_FREEKEY;
563 }
564 #endif
565 }
566 } /* ISSTORE */
567 } /* SvMAGICAL */
568
569 if (!xhv->xhv_array /* !HvARRAY(hv) */) {
570 if ((action & (HV_FETCH_LVALUE | HV_FETCH_ISSTORE))
571 #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
572 || (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env))
573 #endif
574 ) {
575 char *array;
576 Newxz(array,
577 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
578 char);
579 HvARRAY(hv) = (HE**)array;
580 }
581 #ifdef DYNAMIC_ENV_FETCH
582 else if (action & HV_FETCH_ISEXISTS) {
583 /* for an %ENV exists, if we do an insert it's by a recursive
584 store call, so avoid creating HvARRAY(hv) right now. */
585 }
586 #endif
587 else {
588 /* XXX remove at some point? */
589 if (flags & HVhek_FREEKEY)
590 Safefree(key);
591
592 return 0;
593 }
594 }
595
596 if (is_utf8) {
597 char * const keysave = (char * const)key;
598 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
599 if (is_utf8)
600 flags |= HVhek_UTF8;
601 else
602 flags &= ~HVhek_UTF8;
603 if (key != keysave) {
604 if (flags & HVhek_FREEKEY)
605 Safefree(keysave);
606 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
607 }
608 }
609
610 if (HvREHASH(hv)) {
611 PERL_HASH_INTERNAL(hash, key, klen);
612 /* We don't have a pointer to the hv, so we have to replicate the
613 flag into every HEK, so that hv_iterkeysv can see it. */
614 /* And yes, you do need this even though you are not "storing" because
615 you can flip the flags below if doing an lval lookup. (And that
616 was put in to give the semantics Andreas was expecting.) */
617 flags |= HVhek_REHASH;
618 } else if (!hash) {
619 /* Not enough shared hash key scalars around to make this worthwhile
620 (about 4% slowdown in perlbench with this in)
621 if (keysv && (SvIsCOW_shared_hash(keysv))) {
622 hash = SvSHARED_HASH(keysv);
623 } else
624 */
625 {
626 PERL_HASH(hash, key, klen);
627 }
628 }
629
630 masked_flags = (flags & HVhek_MASK);
631
632 #ifdef DYNAMIC_ENV_FETCH
633 if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*);
634 else
635 #endif
636 {
637 /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
638 entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
639 }
640 for (; entry; entry = HeNEXT(entry)) {
641 if (!HeKEY_hek(entry))
642 continue;
643 if (HeHASH(entry) != hash) /* strings can't be equal */
644 continue;
645 if (HeKLEN(entry) != (I32)klen)
646 continue;
647 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
648 continue;
649 if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
650 continue;
651
652 if (action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE)) {
653 if (HeKFLAGS(entry) != masked_flags) {
654 /* We match if HVhek_UTF8 bit in our flags and hash key's
655 match. But if entry was set previously with HVhek_WASUTF8
656 and key now doesn't (or vice versa) then we should change
657 the key's flag, as this is assignment. */
658 if (HvSHAREKEYS(hv)) {
659 /* Need to swap the key we have for a key with the flags we
660 need. As keys are shared we can't just write to the
661 flag, so we share the new one, unshare the old one. */
662 HEK *new_hek = share_hek_flags(key, klen, hash,
663 masked_flags);
664 unshare_hek (HeKEY_hek(entry));
665 HeKEY_hek(entry) = new_hek;
666 }
667 else
668 HeKFLAGS(entry) = masked_flags;
669 if (masked_flags & HVhek_ENABLEHVKFLAGS)
670 HvHASKFLAGS_on(hv);
671 }
672 if (HeVAL(entry) == &PL_sv_placeholder) {
673 /* yes, can store into placeholder slot */
674 if (action & HV_FETCH_LVALUE) {
675 if (SvMAGICAL(hv)) {
676 /* This preserves behaviour with the old hv_fetch
677 implementation which at this point would bail out
678 with a break; (at "if we find a placeholder, we
679 pretend we haven't found anything")
680
681 That break mean that if a placeholder were found, it
682 caused a call into hv_store, which in turn would
683 check magic, and if there is no magic end up pretty
684 much back at this point (in hv_store's code). */
685 break;
686 }
687 /* LVAL fetch which actaully needs a store. */
688 val = NEWSV(61,0);
689 xhv->xhv_placeholders--;
690 } else {
691 /* store */
692 if (val != &PL_sv_placeholder)
693 xhv->xhv_placeholders--;
694 }
695 HeVAL(entry) = val;
696 } else if (action & HV_FETCH_ISSTORE) {
697 SvREFCNT_dec(HeVAL(entry));
698 HeVAL(entry) = val;
699 }
700 } else if (HeVAL(entry) == &PL_sv_placeholder) {
701 /* if we find a placeholder, we pretend we haven't found
702 anything */
703 break;
704 }
705 if (flags & HVhek_FREEKEY)
706 Safefree(key);
707 return entry;
708 }
709 #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
710 if (!(action & HV_FETCH_ISSTORE)
711 && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
712 unsigned long len;
713 const char * const env = PerlEnv_ENVgetenv_len(key,&len);
714 if (env) {
715 sv = newSVpvn(env,len);
716 SvTAINTED_on(sv);
717 return hv_fetch_common(hv,keysv,key,klen,flags,HV_FETCH_ISSTORE,sv,
718 hash);
719 }
720 }
721 #endif
722
723 if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) {
724 S_hv_notallowed(aTHX_ flags, key, klen,
725 "Attempt to access disallowed key '%"SVf"' in"
726 " a restricted hash");
727 }
728 if (!(action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE))) {
729 /* Not doing some form of store, so return failure. */
730 if (flags & HVhek_FREEKEY)
731 Safefree(key);
732 return 0;
733 }
734 if (action & HV_FETCH_LVALUE) {
735 val = NEWSV(61,0);
736 if (SvMAGICAL(hv)) {
737 /* At this point the old hv_fetch code would call to hv_store,
738 which in turn might do some tied magic. So we need to make that
739 magic check happen. */
740 /* gonna assign to this, so it better be there */
741 return hv_fetch_common(hv, keysv, key, klen, flags,
742 HV_FETCH_ISSTORE, val, hash);
743 /* XXX Surely that could leak if the fetch-was-store fails?
744 Just like the hv_fetch. */
745 }
746 }
747
748 /* Welcome to hv_store... */
749
750 if (!xhv->xhv_array) {
751 /* Not sure if we can get here. I think the only case of oentry being
752 NULL is for %ENV with dynamic env fetch. But that should disappear
753 with magic in the previous code. */
754 char *array;
755 Newxz(array,
756 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
757 char);
758 HvARRAY(hv) = (HE**)array;
759 }
760
761 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
762
763 entry = new_HE();
764 /* share_hek_flags will do the free for us. This might be considered
765 bad API design. */
766 if (HvSHAREKEYS(hv))
767 HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags);
768 else /* gotta do the real thing */
769 HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags);
770 HeVAL(entry) = val;
771 HeNEXT(entry) = *oentry;
772 *oentry = entry;
773
774 if (val == &PL_sv_placeholder)
775 xhv->xhv_placeholders++;
776 if (masked_flags & HVhek_ENABLEHVKFLAGS)
777 HvHASKFLAGS_on(hv);
778
779 {
780 const HE *counter = HeNEXT(entry);
781
782 xhv->xhv_keys++; /* HvKEYS(hv)++ */
783 if (!counter) { /* initial entry? */
784 xhv->xhv_fill++; /* HvFILL(hv)++ */
785 } else if (xhv->xhv_keys > (IV)xhv->xhv_max) {
786 hsplit(hv);
787 } else if(!HvREHASH(hv)) {
788 U32 n_links = 1;
789
790 while ((counter = HeNEXT(counter)))
791 n_links++;
792
793 if (n_links > HV_MAX_LENGTH_BEFORE_SPLIT) {
794 /* Use only the old HvKEYS(hv) > HvMAX(hv) condition to limit
795 bucket splits on a rehashed hash, as we're not going to
796 split it again, and if someone is lucky (evil) enough to
797 get all the keys in one list they could exhaust our memory
798 as we repeatedly double the number of buckets on every
799 entry. Linear search feels a less worse thing to do. */
800 hsplit(hv);
801 }
802 }
803 }
804
805 return entry;
806 }
807
808 STATIC void
S_hv_magic_check(pTHX_ HV * hv,bool * needs_copy,bool * needs_store)809 S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
810 {
811 const MAGIC *mg = SvMAGIC(hv);
812 *needs_copy = FALSE;
813 *needs_store = TRUE;
814 while (mg) {
815 if (isUPPER(mg->mg_type)) {
816 *needs_copy = TRUE;
817 if (mg->mg_type == PERL_MAGIC_tied) {
818 *needs_store = FALSE;
819 return; /* We've set all there is to set. */
820 }
821 }
822 mg = mg->mg_moremagic;
823 }
824 }
825
826 /*
827 =for apidoc hv_scalar
828
829 Evaluates the hash in scalar context and returns the result. Handles magic when the hash is tied.
830
831 =cut
832 */
833
834 SV *
Perl_hv_scalar(pTHX_ HV * hv)835 Perl_hv_scalar(pTHX_ HV *hv)
836 {
837 SV *sv;
838
839 if (SvRMAGICAL(hv)) {
840 MAGIC * const mg = mg_find((SV*)hv, PERL_MAGIC_tied);
841 if (mg)
842 return magic_scalarpack(hv, mg);
843 }
844
845 sv = sv_newmortal();
846 if (HvFILL((HV*)hv))
847 Perl_sv_setpvf(aTHX_ sv, "%ld/%ld",
848 (long)HvFILL(hv), (long)HvMAX(hv) + 1);
849 else
850 sv_setiv(sv, 0);
851
852 return sv;
853 }
854
855 /*
856 =for apidoc hv_delete
857
858 Deletes a key/value pair in the hash. The value SV is removed from the
859 hash and returned to the caller. The C<klen> is the length of the key.
860 The C<flags> value will normally be zero; if set to G_DISCARD then NULL
861 will be returned.
862
863 =cut
864 */
865
866 SV *
Perl_hv_delete(pTHX_ HV * hv,const char * key,I32 klen_i32,I32 flags)867 Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 flags)
868 {
869 STRLEN klen;
870 int k_flags = 0;
871
872 if (klen_i32 < 0) {
873 klen = -klen_i32;
874 k_flags |= HVhek_UTF8;
875 } else {
876 klen = klen_i32;
877 }
878 return hv_delete_common(hv, NULL, key, klen, k_flags, flags, 0);
879 }
880
881 /*
882 =for apidoc hv_delete_ent
883
884 Deletes a key/value pair in the hash. The value SV is removed from the
885 hash and returned to the caller. The C<flags> value will normally be zero;
886 if set to G_DISCARD then NULL will be returned. C<hash> can be a valid
887 precomputed hash value, or 0 to ask for it to be computed.
888
889 =cut
890 */
891
892 SV *
Perl_hv_delete_ent(pTHX_ HV * hv,SV * keysv,I32 flags,U32 hash)893 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
894 {
895 return hv_delete_common(hv, keysv, NULL, 0, 0, flags, hash);
896 }
897
898 STATIC SV *
S_hv_delete_common(pTHX_ HV * hv,SV * keysv,const char * key,STRLEN klen,int k_flags,I32 d_flags,U32 hash)899 S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen,
900 int k_flags, I32 d_flags, U32 hash)
901 {
902 register XPVHV* xhv;
903 register HE *entry;
904 register HE **oentry;
905 HE *const *first_entry;
906 SV *sv;
907 bool is_utf8;
908 int masked_flags;
909
910 if (!hv)
911 return Nullsv;
912
913 if (keysv) {
914 if (k_flags & HVhek_FREEKEY)
915 Safefree(key);
916 key = SvPV_const(keysv, klen);
917 k_flags = 0;
918 is_utf8 = (SvUTF8(keysv) != 0);
919 } else {
920 is_utf8 = ((k_flags & HVhek_UTF8) ? TRUE : FALSE);
921 }
922
923 if (SvRMAGICAL(hv)) {
924 bool needs_copy;
925 bool needs_store;
926 hv_magic_check (hv, &needs_copy, &needs_store);
927
928 if (needs_copy) {
929 entry = hv_fetch_common(hv, keysv, key, klen,
930 k_flags & ~HVhek_FREEKEY, HV_FETCH_LVALUE,
931 Nullsv, hash);
932 sv = entry ? HeVAL(entry) : NULL;
933 if (sv) {
934 if (SvMAGICAL(sv)) {
935 mg_clear(sv);
936 }
937 if (!needs_store) {
938 if (mg_find(sv, PERL_MAGIC_tiedelem)) {
939 /* No longer an element */
940 sv_unmagic(sv, PERL_MAGIC_tiedelem);
941 return sv;
942 }
943 return Nullsv; /* element cannot be deleted */
944 }
945 #ifdef ENV_IS_CASELESS
946 else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
947 /* XXX This code isn't UTF8 clean. */
948 keysv = sv_2mortal(newSVpvn(key,klen));
949 if (k_flags & HVhek_FREEKEY) {
950 Safefree(key);
951 }
952 key = strupr(SvPVX(keysv));
953 is_utf8 = 0;
954 k_flags = 0;
955 hash = 0;
956 }
957 #endif
958 }
959 }
960 }
961 xhv = (XPVHV*)SvANY(hv);
962 if (!xhv->xhv_array /* !HvARRAY(hv) */)
963 return Nullsv;
964
965 if (is_utf8) {
966 const char *keysave = key;
967 key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8);
968
969 if (is_utf8)
970 k_flags |= HVhek_UTF8;
971 else
972 k_flags &= ~HVhek_UTF8;
973 if (key != keysave) {
974 if (k_flags & HVhek_FREEKEY) {
975 /* This shouldn't happen if our caller does what we expect,
976 but strictly the API allows it. */
977 Safefree(keysave);
978 }
979 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
980 }
981 HvHASKFLAGS_on((SV*)hv);
982 }
983
984 if (HvREHASH(hv)) {
985 PERL_HASH_INTERNAL(hash, key, klen);
986 } else if (!hash) {
987 /* Not enough shared hash key scalars around to make this worthwhile
988 (about 4% slowdown in perlbench with this in)
989 if (keysv && (SvIsCOW_shared_hash(keysv))) {
990 hash = SvSHARED_HASH(keysv);
991 } else
992 */
993 {
994 PERL_HASH(hash, key, klen);
995 }
996 }
997
998 masked_flags = (k_flags & HVhek_MASK);
999
1000 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1001 first_entry = oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1002 entry = *oentry;
1003 for (; entry; oentry = &HeNEXT(entry), entry = *oentry) {
1004 if (HeHASH(entry) != hash) /* strings can't be equal */
1005 continue;
1006 if (HeKLEN(entry) != (I32)klen)
1007 continue;
1008 if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */
1009 continue;
1010 if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8)
1011 continue;
1012
1013 /* if placeholder is here, it's already been deleted.... */
1014 if (HeVAL(entry) == &PL_sv_placeholder)
1015 {
1016 if (k_flags & HVhek_FREEKEY)
1017 Safefree(key);
1018 return Nullsv;
1019 }
1020 else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1021 S_hv_notallowed(aTHX_ k_flags, key, klen,
1022 "Attempt to delete readonly key '%"SVf"' from"
1023 " a restricted hash");
1024 }
1025 if (k_flags & HVhek_FREEKEY)
1026 Safefree(key);
1027
1028 if (d_flags & G_DISCARD)
1029 sv = Nullsv;
1030 else {
1031 sv = sv_2mortal(HeVAL(entry));
1032 HeVAL(entry) = &PL_sv_placeholder;
1033 }
1034
1035 /*
1036 * If a restricted hash, rather than really deleting the entry, put
1037 * a placeholder there. This marks the key as being "approved", so
1038 * we can still access via not-really-existing key without raising
1039 * an error.
1040 */
1041 if (SvREADONLY(hv)) {
1042 SvREFCNT_dec(HeVAL(entry));
1043 HeVAL(entry) = &PL_sv_placeholder;
1044 /* We'll be saving this slot, so the number of allocated keys
1045 * doesn't go down, but the number placeholders goes up */
1046 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
1047 } else {
1048 *oentry = HeNEXT(entry);
1049 if(!*first_entry) {
1050 xhv->xhv_fill--; /* HvFILL(hv)-- */
1051 }
1052 if (entry == xhv->xhv_eiter /* HvEITER(hv) */)
1053 HvLAZYDEL_on(hv);
1054 else
1055 hv_free_ent(hv, entry);
1056 xhv->xhv_keys--; /* HvKEYS(hv)-- */
1057 if (xhv->xhv_keys == 0)
1058 HvHASKFLAGS_off(hv);
1059 }
1060 return sv;
1061 }
1062 if (SvREADONLY(hv)) {
1063 S_hv_notallowed(aTHX_ k_flags, key, klen,
1064 "Attempt to delete disallowed key '%"SVf"' from"
1065 " a restricted hash");
1066 }
1067
1068 if (k_flags & HVhek_FREEKEY)
1069 Safefree(key);
1070 return Nullsv;
1071 }
1072
1073 STATIC void
S_hsplit(pTHX_ HV * hv)1074 S_hsplit(pTHX_ HV *hv)
1075 {
1076 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1077 const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1078 register I32 newsize = oldsize * 2;
1079 register I32 i;
1080 register char *a = xhv->xhv_array; /* HvARRAY(hv) */
1081 register HE **aep;
1082 register HE **oentry;
1083 int longest_chain = 0;
1084 int was_shared;
1085
1086 /*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n",
1087 hv, (int) oldsize);*/
1088
1089 if (HvPLACEHOLDERS_get(hv) && !SvREADONLY(hv)) {
1090 /* Can make this clear any placeholders first for non-restricted hashes,
1091 even though Storable rebuilds restricted hashes by putting in all the
1092 placeholders (first) before turning on the readonly flag, because
1093 Storable always pre-splits the hash. */
1094 hv_clear_placeholders(hv);
1095 }
1096
1097 PL_nomemok = TRUE;
1098 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1099 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1100 if (!a) {
1101 PL_nomemok = FALSE;
1102 return;
1103 }
1104 #else
1105 Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1106 if (!a) {
1107 PL_nomemok = FALSE;
1108 return;
1109 }
1110 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1111 if (oldsize >= 64) {
1112 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1113 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1114 }
1115 else
1116 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1117 #endif
1118
1119 PL_nomemok = FALSE;
1120 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1121 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1122 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1123 aep = (HE**)a;
1124
1125 for (i=0; i<oldsize; i++,aep++) {
1126 int left_length = 0;
1127 int right_length = 0;
1128 register HE *entry;
1129 register HE **bep;
1130
1131 if (!*aep) /* non-existent */
1132 continue;
1133 bep = aep+oldsize;
1134 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1135 if ((HeHASH(entry) & newsize) != (U32)i) {
1136 *oentry = HeNEXT(entry);
1137 HeNEXT(entry) = *bep;
1138 if (!*bep)
1139 xhv->xhv_fill++; /* HvFILL(hv)++ */
1140 *bep = entry;
1141 right_length++;
1142 continue;
1143 }
1144 else {
1145 oentry = &HeNEXT(entry);
1146 left_length++;
1147 }
1148 }
1149 if (!*aep) /* everything moved */
1150 xhv->xhv_fill--; /* HvFILL(hv)-- */
1151 /* I think we don't actually need to keep track of the longest length,
1152 merely flag if anything is too long. But for the moment while
1153 developing this code I'll track it. */
1154 if (left_length > longest_chain)
1155 longest_chain = left_length;
1156 if (right_length > longest_chain)
1157 longest_chain = right_length;
1158 }
1159
1160
1161 /* Pick your policy for "hashing isn't working" here: */
1162 if (longest_chain <= HV_MAX_LENGTH_BEFORE_SPLIT /* split worked? */
1163 || HvREHASH(hv)) {
1164 return;
1165 }
1166
1167 if (hv == PL_strtab) {
1168 /* Urg. Someone is doing something nasty to the string table.
1169 Can't win. */
1170 return;
1171 }
1172
1173 /* Awooga. Awooga. Pathological data. */
1174 /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", hv,
1175 longest_chain, HvTOTALKEYS(hv), HvFILL(hv), 1+HvMAX(hv));*/
1176
1177 ++newsize;
1178 Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1179 was_shared = HvSHAREKEYS(hv);
1180
1181 xhv->xhv_fill = 0;
1182 HvSHAREKEYS_off(hv);
1183 HvREHASH_on(hv);
1184
1185 aep = (HE **) xhv->xhv_array;
1186
1187 for (i=0; i<newsize; i++,aep++) {
1188 register HE *entry = *aep;
1189 while (entry) {
1190 /* We're going to trash this HE's next pointer when we chain it
1191 into the new hash below, so store where we go next. */
1192 HE * const next = HeNEXT(entry);
1193 UV hash;
1194 HE **bep;
1195
1196 /* Rehash it */
1197 PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry));
1198
1199 if (was_shared) {
1200 /* Unshare it. */
1201 HEK * const new_hek
1202 = save_hek_flags(HeKEY(entry), HeKLEN(entry),
1203 hash, HeKFLAGS(entry));
1204 unshare_hek (HeKEY_hek(entry));
1205 HeKEY_hek(entry) = new_hek;
1206 } else {
1207 /* Not shared, so simply write the new hash in. */
1208 HeHASH(entry) = hash;
1209 }
1210 /*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/
1211 HEK_REHASH_on(HeKEY_hek(entry));
1212 /*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/
1213
1214 /* Copy oentry to the correct new chain. */
1215 bep = ((HE**)a) + (hash & (I32) xhv->xhv_max);
1216 if (!*bep)
1217 xhv->xhv_fill++; /* HvFILL(hv)++ */
1218 HeNEXT(entry) = *bep;
1219 *bep = entry;
1220
1221 entry = next;
1222 }
1223 }
1224 Safefree (xhv->xhv_array);
1225 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1226 }
1227
1228 void
Perl_hv_ksplit(pTHX_ HV * hv,IV newmax)1229 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
1230 {
1231 register XPVHV* xhv = (XPVHV*)SvANY(hv);
1232 const I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */
1233 register I32 newsize;
1234 register I32 i;
1235 register char *a;
1236 register HE **aep;
1237 register HE *entry;
1238 register HE **oentry;
1239
1240 newsize = (I32) newmax; /* possible truncation here */
1241 if (newsize != newmax || newmax <= oldsize)
1242 return;
1243 while ((newsize & (1 + ~newsize)) != newsize) {
1244 newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
1245 }
1246 if (newsize < newmax)
1247 newsize *= 2;
1248 if (newsize < newmax)
1249 return; /* overflow detection */
1250
1251 a = xhv->xhv_array; /* HvARRAY(hv) */
1252 if (a) {
1253 PL_nomemok = TRUE;
1254 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
1255 Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1256 if (!a) {
1257 PL_nomemok = FALSE;
1258 return;
1259 }
1260 #else
1261 Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1262 if (!a) {
1263 PL_nomemok = FALSE;
1264 return;
1265 }
1266 Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char);
1267 if (oldsize >= 64) {
1268 offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */,
1269 PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
1270 }
1271 else
1272 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1273 #endif
1274 PL_nomemok = FALSE;
1275 Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
1276 }
1277 else {
1278 Newxz(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
1279 }
1280 xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */
1281 xhv->xhv_array = a; /* HvARRAY(hv) = a */
1282 if (!xhv->xhv_fill /* !HvFILL(hv) */) /* skip rest if no entries */
1283 return;
1284
1285 aep = (HE**)a;
1286 for (i=0; i<oldsize; i++,aep++) {
1287 if (!*aep) /* non-existent */
1288 continue;
1289 for (oentry = aep, entry = *aep; entry; entry = *oentry) {
1290 register I32 j;
1291 if ((j = (HeHASH(entry) & newsize)) != i) {
1292 j -= i;
1293 *oentry = HeNEXT(entry);
1294 if (!(HeNEXT(entry) = aep[j]))
1295 xhv->xhv_fill++; /* HvFILL(hv)++ */
1296 aep[j] = entry;
1297 continue;
1298 }
1299 else
1300 oentry = &HeNEXT(entry);
1301 }
1302 if (!*aep) /* everything moved */
1303 xhv->xhv_fill--; /* HvFILL(hv)-- */
1304 }
1305 }
1306
1307 /*
1308 =for apidoc newHV
1309
1310 Creates a new HV. The reference count is set to 1.
1311
1312 =cut
1313 */
1314
1315 HV *
Perl_newHV(pTHX)1316 Perl_newHV(pTHX)
1317 {
1318 register XPVHV* xhv;
1319 HV * const hv = (HV*)NEWSV(502,0);
1320
1321 sv_upgrade((SV *)hv, SVt_PVHV);
1322 xhv = (XPVHV*)SvANY(hv);
1323 SvPOK_off(hv);
1324 SvNOK_off(hv);
1325 #ifndef NODEFAULT_SHAREKEYS
1326 HvSHAREKEYS_on(hv); /* key-sharing on by default */
1327 #endif
1328
1329 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (start with 8 buckets) */
1330 xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */
1331 xhv->xhv_pmroot = 0; /* HvPMROOT(hv) = 0 */
1332 (void)hv_iterinit(hv); /* so each() will start off right */
1333 return hv;
1334 }
1335
1336 HV *
Perl_newHVhv(pTHX_ HV * ohv)1337 Perl_newHVhv(pTHX_ HV *ohv)
1338 {
1339 HV * const hv = newHV();
1340 STRLEN hv_max, hv_fill;
1341
1342 if (!ohv || (hv_fill = HvFILL(ohv)) == 0)
1343 return hv;
1344 hv_max = HvMAX(ohv);
1345
1346 if (!SvMAGICAL((SV *)ohv)) {
1347 /* It's an ordinary hash, so copy it fast. AMS 20010804 */
1348 STRLEN i;
1349 const bool shared = !!HvSHAREKEYS(ohv);
1350 HE **ents, ** const oents = (HE **)HvARRAY(ohv);
1351 char *a;
1352 Newx(a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char);
1353 ents = (HE**)a;
1354
1355 /* In each bucket... */
1356 for (i = 0; i <= hv_max; i++) {
1357 HE *prev = NULL, *ent = NULL;
1358 HE *oent = oents[i];
1359
1360 if (!oent) {
1361 ents[i] = NULL;
1362 continue;
1363 }
1364
1365 /* Copy the linked list of entries. */
1366 for (; oent; oent = HeNEXT(oent)) {
1367 const U32 hash = HeHASH(oent);
1368 const char * const key = HeKEY(oent);
1369 const STRLEN len = HeKLEN(oent);
1370 const int flags = HeKFLAGS(oent);
1371
1372 ent = new_HE();
1373 HeVAL(ent) = newSVsv(HeVAL(oent));
1374 HeKEY_hek(ent)
1375 = shared ? share_hek_flags(key, len, hash, flags)
1376 : save_hek_flags(key, len, hash, flags);
1377 if (prev)
1378 HeNEXT(prev) = ent;
1379 else
1380 ents[i] = ent;
1381 prev = ent;
1382 HeNEXT(ent) = NULL;
1383 }
1384 }
1385
1386 HvMAX(hv) = hv_max;
1387 HvFILL(hv) = hv_fill;
1388 HvTOTALKEYS(hv) = HvTOTALKEYS(ohv);
1389 HvARRAY(hv) = ents;
1390 } /* not magical */
1391 else {
1392 /* Iterate over ohv, copying keys and values one at a time. */
1393 HE *entry;
1394 const I32 riter = HvRITER_get(ohv);
1395 HE * const eiter = HvEITER_get(ohv);
1396
1397 /* Can we use fewer buckets? (hv_max is always 2^n-1) */
1398 while (hv_max && hv_max + 1 >= hv_fill * 2)
1399 hv_max = hv_max / 2;
1400 HvMAX(hv) = hv_max;
1401
1402 hv_iterinit(ohv);
1403 while ((entry = hv_iternext_flags(ohv, 0))) {
1404 hv_store_flags(hv, HeKEY(entry), HeKLEN(entry),
1405 newSVsv(HeVAL(entry)), HeHASH(entry),
1406 HeKFLAGS(entry));
1407 }
1408 HvRITER_set(ohv, riter);
1409 HvEITER_set(ohv, eiter);
1410 }
1411
1412 return hv;
1413 }
1414
1415 void
Perl_hv_free_ent(pTHX_ HV * hv,register HE * entry)1416 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1417 {
1418 SV *val;
1419
1420 if (!entry)
1421 return;
1422 val = HeVAL(entry);
1423 if (val && isGV(val) && GvCVu(val) && HvNAME_get(hv))
1424 PL_sub_generation++; /* may be deletion of method from stash */
1425 SvREFCNT_dec(val);
1426 if (HeKLEN(entry) == HEf_SVKEY) {
1427 SvREFCNT_dec(HeKEY_sv(entry));
1428 Safefree(HeKEY_hek(entry));
1429 }
1430 else if (HvSHAREKEYS(hv))
1431 unshare_hek(HeKEY_hek(entry));
1432 else
1433 Safefree(HeKEY_hek(entry));
1434 del_HE(entry);
1435 }
1436
1437 void
Perl_hv_delayfree_ent(pTHX_ HV * hv,register HE * entry)1438 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1439 {
1440 if (!entry)
1441 return;
1442 /* SvREFCNT_inc to counter the SvREFCNT_dec in hv_free_ent */
1443 sv_2mortal(SvREFCNT_inc(HeVAL(entry))); /* free between statements */
1444 if (HeKLEN(entry) == HEf_SVKEY) {
1445 sv_2mortal(SvREFCNT_inc(HeKEY_sv(entry)));
1446 }
1447 hv_free_ent(hv, entry);
1448 }
1449
1450 /*
1451 =for apidoc hv_clear
1452
1453 Clears a hash, making it empty.
1454
1455 =cut
1456 */
1457
1458 void
Perl_hv_clear(pTHX_ HV * hv)1459 Perl_hv_clear(pTHX_ HV *hv)
1460 {
1461 register XPVHV* xhv;
1462 if (!hv)
1463 return;
1464
1465 xhv = (XPVHV*)SvANY(hv);
1466
1467 if (SvREADONLY(hv) && xhv->xhv_array != NULL) {
1468 /* restricted hash: convert all keys to placeholders */
1469 STRLEN i;
1470 for (i = 0; i <= xhv->xhv_max; i++) {
1471 HE *entry = ((HE**)xhv->xhv_array)[i];
1472 for (; entry; entry = HeNEXT(entry)) {
1473 /* not already placeholder */
1474 if (HeVAL(entry) != &PL_sv_placeholder) {
1475 if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) {
1476 SV* keysv = hv_iterkeysv(entry);
1477 Perl_croak(aTHX_
1478 "Attempt to delete readonly key '%"SVf"' from a restricted hash",
1479 keysv);
1480 }
1481 SvREFCNT_dec(HeVAL(entry));
1482 HeVAL(entry) = &PL_sv_placeholder;
1483 xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */
1484 }
1485 }
1486 }
1487 goto reset;
1488 }
1489
1490 hfreeentries(hv);
1491 xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1492 if (xhv->xhv_array /* HvARRAY(hv) */)
1493 (void)memzero(xhv->xhv_array /* HvARRAY(hv) */,
1494 (xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*));
1495
1496 if (SvRMAGICAL(hv))
1497 mg_clear((SV*)hv);
1498
1499 HvHASKFLAGS_off(hv);
1500 HvREHASH_off(hv);
1501 reset:
1502 HvEITER_set(hv, NULL);
1503 }
1504
1505 /*
1506 =for apidoc hv_clear_placeholders
1507
1508 Clears any placeholders from a hash. If a restricted hash has any of its keys
1509 marked as readonly and the key is subsequently deleted, the key is not actually
1510 deleted but is marked by assigning it a value of &PL_sv_placeholder. This tags
1511 it so it will be ignored by future operations such as iterating over the hash,
1512 but will still allow the hash to have a value reassigned to the key at some
1513 future point. This function clears any such placeholder keys from the hash.
1514 See Hash::Util::lock_keys() for an example of its use.
1515
1516 =cut
1517 */
1518
1519 void
Perl_hv_clear_placeholders(pTHX_ HV * hv)1520 Perl_hv_clear_placeholders(pTHX_ HV *hv)
1521 {
1522 I32 items = (I32)HvPLACEHOLDERS_get(hv);
1523 I32 i;
1524
1525 if (items == 0)
1526 return;
1527
1528 i = HvMAX(hv);
1529 do {
1530 /* Loop down the linked list heads */
1531 bool first = 1;
1532 HE **oentry = &(HvARRAY(hv))[i];
1533 HE *entry = *oentry;
1534
1535 if (!entry)
1536 continue;
1537
1538 for (; entry; entry = *oentry) {
1539 if (HeVAL(entry) == &PL_sv_placeholder) {
1540 *oentry = HeNEXT(entry);
1541 if (first && !*oentry)
1542 HvFILL(hv)--; /* This linked list is now empty. */
1543 if (entry == HvEITER_get(hv))
1544 HvLAZYDEL_on(hv);
1545 else
1546 hv_free_ent(hv, entry);
1547
1548 if (--items == 0) {
1549 /* Finished. */
1550 HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS_get(hv);
1551 if (HvKEYS(hv) == 0)
1552 HvHASKFLAGS_off(hv);
1553 HvPLACEHOLDERS_set(hv, 0);
1554 return;
1555 }
1556 } else {
1557 oentry = &HeNEXT(entry);
1558 first = 0;
1559 }
1560 }
1561 } while (--i >= 0);
1562 /* You can't get here, hence assertion should always fail. */
1563 assert (items == 0);
1564 assert (0);
1565 }
1566
1567 STATIC void
S_hfreeentries(pTHX_ HV * hv)1568 S_hfreeentries(pTHX_ HV *hv)
1569 {
1570 register HE **array;
1571 register HE *entry;
1572 I32 riter;
1573 I32 max;
1574
1575
1576 if (!HvARRAY(hv))
1577 return;
1578
1579 riter = 0;
1580 max = HvMAX(hv);
1581 array = HvARRAY(hv);
1582 /* make everyone else think the array is empty, so that the destructors
1583 * called for freed entries can't recusively mess with us */
1584 HvARRAY(hv) = Null(HE**);
1585 HvFILL(hv) = 0;
1586 ((XPVHV*) SvANY(hv))->xhv_keys = 0;
1587
1588 entry = array[0];
1589 for (;;) {
1590 if (entry) {
1591 register HE * const oentry = entry;
1592 entry = HeNEXT(entry);
1593 hv_free_ent(hv, oentry);
1594 }
1595 if (!entry) {
1596 if (++riter > max)
1597 break;
1598 entry = array[riter];
1599 }
1600 }
1601 HvARRAY(hv) = array;
1602 (void)hv_iterinit(hv);
1603 }
1604
1605 /*
1606 =for apidoc hv_undef
1607
1608 Undefines the hash.
1609
1610 =cut
1611 */
1612
1613 void
Perl_hv_undef(pTHX_ HV * hv)1614 Perl_hv_undef(pTHX_ HV *hv)
1615 {
1616 register XPVHV* xhv;
1617 const char *name;
1618 if (!hv)
1619 return;
1620 xhv = (XPVHV*)SvANY(hv);
1621 hfreeentries(hv);
1622 Safefree(xhv->xhv_array /* HvARRAY(hv) */);
1623 if ((name = HvNAME_get(hv))) {
1624 /* FIXME - strlen HvNAME */
1625 if(PL_stashcache)
1626 hv_delete(PL_stashcache, name, strlen(name), G_DISCARD);
1627 hv_name_set(hv, Nullch, 0, 0);
1628 }
1629 xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */
1630 xhv->xhv_array = 0; /* HvARRAY(hv) = 0 */
1631 xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */
1632
1633 if (SvRMAGICAL(hv))
1634 mg_clear((SV*)hv);
1635 }
1636
1637 /*
1638 =for apidoc hv_iterinit
1639
1640 Prepares a starting point to traverse a hash table. Returns the number of
1641 keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is
1642 currently only meaningful for hashes without tie magic.
1643
1644 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1645 hash buckets that happen to be in use. If you still need that esoteric
1646 value, you can get it through the macro C<HvFILL(tb)>.
1647
1648
1649 =cut
1650 */
1651
1652 I32
Perl_hv_iterinit(pTHX_ HV * hv)1653 Perl_hv_iterinit(pTHX_ HV *hv)
1654 {
1655 register XPVHV* xhv;
1656 HE *entry;
1657
1658 if (!hv)
1659 Perl_croak(aTHX_ "Bad hash");
1660 xhv = (XPVHV*)SvANY(hv);
1661 entry = xhv->xhv_eiter; /* HvEITER(hv) */
1662 if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1663 HvLAZYDEL_off(hv);
1664 hv_free_ent(hv, entry);
1665 }
1666 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1667 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1668 /* used to be xhv->xhv_fill before 5.004_65 */
1669 return HvTOTALKEYS(hv);
1670 }
1671 /*
1672 =for apidoc hv_iternext
1673
1674 Returns entries from a hash iterator. See C<hv_iterinit>.
1675
1676 You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the
1677 iterator currently points to, without losing your place or invalidating your
1678 iterator. Note that in this case the current entry is deleted from the hash
1679 with your iterator holding the last reference to it. Your iterator is flagged
1680 to free the entry on the next call to C<hv_iternext>, so you must not discard
1681 your iterator immediately else the entry will leak - call C<hv_iternext> to
1682 trigger the resource deallocation.
1683
1684 =cut
1685 */
1686
1687 HE *
Perl_hv_iternext(pTHX_ HV * hv)1688 Perl_hv_iternext(pTHX_ HV *hv)
1689 {
1690 return hv_iternext_flags(hv, 0);
1691 }
1692
1693 /*
1694 =for apidoc hv_iternext_flags
1695
1696 Returns entries from a hash iterator. See C<hv_iterinit> and C<hv_iternext>.
1697 The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is
1698 set the placeholders keys (for restricted hashes) will be returned in addition
1699 to normal keys. By default placeholders are automatically skipped over.
1700 Currently a placeholder is implemented with a value that is
1701 C<&Perl_sv_placeholder>. Note that the implementation of placeholders and
1702 restricted hashes may change, and the implementation currently is
1703 insufficiently abstracted for any change to be tidy.
1704
1705 =cut
1706 */
1707
1708 HE *
Perl_hv_iternext_flags(pTHX_ HV * hv,I32 flags)1709 Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags)
1710 {
1711 register XPVHV* xhv;
1712 register HE *entry;
1713 HE *oldentry;
1714 MAGIC* mg;
1715
1716 if (!hv)
1717 Perl_croak(aTHX_ "Bad hash");
1718 xhv = (XPVHV*)SvANY(hv);
1719 oldentry = entry = xhv->xhv_eiter; /* HvEITER(hv) */
1720
1721 if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) {
1722 SV *key = sv_newmortal();
1723 if (entry) {
1724 sv_setsv(key, HeSVKEY_force(entry));
1725 SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
1726 }
1727 else {
1728 char *k;
1729 HEK *hek;
1730
1731 /* one HE per MAGICAL hash */
1732 xhv->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
1733 Zero(entry, 1, HE);
1734 Newxz(k, HEK_BASESIZE + sizeof(SV*), char);
1735 hek = (HEK*)k;
1736 HeKEY_hek(entry) = hek;
1737 HeKLEN(entry) = HEf_SVKEY;
1738 }
1739 magic_nextpack((SV*) hv,mg,key);
1740 if (SvOK(key)) {
1741 /* force key to stay around until next time */
1742 HeSVKEY_set(entry, SvREFCNT_inc(key));
1743 return entry; /* beware, hent_val is not set */
1744 }
1745 if (HeVAL(entry))
1746 SvREFCNT_dec(HeVAL(entry));
1747 Safefree(HeKEY_hek(entry));
1748 del_HE(entry);
1749 xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */
1750 return Null(HE*);
1751 }
1752 #ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */
1753 if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) {
1754 prime_env_iter();
1755 #ifdef VMS
1756 /* The prime_env_iter() on VMS just loaded up new hash values
1757 * so the iteration count needs to be reset back to the beginning
1758 */
1759 hv_iterinit(hv);
1760 oldentry = entry = xhv->xhv_eiter; /* HvEITER(hv) */
1761 #endif
1762 }
1763 #endif
1764
1765 if (!xhv->xhv_array /* !HvARRAY(hv) */)
1766 Newz(506, xhv->xhv_array /* HvARRAY(hv) */,
1767 PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */),
1768 char);
1769 /* At start of hash, entry is NULL. */
1770 if (entry)
1771 {
1772 entry = HeNEXT(entry);
1773 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1774 /*
1775 * Skip past any placeholders -- don't want to include them in
1776 * any iteration.
1777 */
1778 while (entry && HeVAL(entry) == &PL_sv_placeholder) {
1779 entry = HeNEXT(entry);
1780 }
1781 }
1782 }
1783 while (!entry) {
1784 /* OK. Come to the end of the current list. Grab the next one. */
1785
1786 xhv->xhv_riter++; /* HvRITER(hv)++ */
1787 if (xhv->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) {
1788 /* There is no next one. End of the hash. */
1789 xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */
1790 break;
1791 }
1792 /* entry = (HvARRAY(hv))[HvRITER(hv)]; */
1793 entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
1794
1795 if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) {
1796 /* If we have an entry, but it's a placeholder, don't count it.
1797 Try the next. */
1798 while (entry && HeVAL(entry) == &PL_sv_placeholder)
1799 entry = HeNEXT(entry);
1800 }
1801 /* Will loop again if this linked list starts NULL
1802 (for HV_ITERNEXT_WANTPLACEHOLDERS)
1803 or if we run through it and find only placeholders. */
1804 }
1805
1806 if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
1807 HvLAZYDEL_off(hv);
1808 hv_free_ent(hv, oldentry);
1809 }
1810
1811 /*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
1812 PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", hv, entry);*/
1813
1814 xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */
1815 return entry;
1816 }
1817
1818 /*
1819 =for apidoc hv_iterkey
1820
1821 Returns the key from the current position of the hash iterator. See
1822 C<hv_iterinit>.
1823
1824 =cut
1825 */
1826
1827 char *
Perl_hv_iterkey(pTHX_ register HE * entry,I32 * retlen)1828 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
1829 {
1830 if (HeKLEN(entry) == HEf_SVKEY) {
1831 STRLEN len;
1832 char *p = SvPV(HeKEY_sv(entry), len);
1833 *retlen = len;
1834 return p;
1835 }
1836 else {
1837 *retlen = HeKLEN(entry);
1838 return HeKEY(entry);
1839 }
1840 }
1841
1842 /* unlike hv_iterval(), this always returns a mortal copy of the key */
1843 /*
1844 =for apidoc hv_iterkeysv
1845
1846 Returns the key as an C<SV*> from the current position of the hash
1847 iterator. The return value will always be a mortal copy of the key. Also
1848 see C<hv_iterinit>.
1849
1850 =cut
1851 */
1852
1853 SV *
Perl_hv_iterkeysv(pTHX_ register HE * entry)1854 Perl_hv_iterkeysv(pTHX_ register HE *entry)
1855 {
1856 return sv_2mortal(newSVhek(HeKEY_hek(entry)));
1857 }
1858
1859 /*
1860 =for apidoc hv_iterval
1861
1862 Returns the value from the current position of the hash iterator. See
1863 C<hv_iterkey>.
1864
1865 =cut
1866 */
1867
1868 SV *
Perl_hv_iterval(pTHX_ HV * hv,register HE * entry)1869 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
1870 {
1871 if (SvRMAGICAL(hv)) {
1872 if (mg_find((SV*)hv, PERL_MAGIC_tied)) {
1873 SV* sv = sv_newmortal();
1874 if (HeKLEN(entry) == HEf_SVKEY)
1875 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
1876 else
1877 mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
1878 return sv;
1879 }
1880 }
1881 return HeVAL(entry);
1882 }
1883
1884 /*
1885 =for apidoc hv_iternextsv
1886
1887 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
1888 operation.
1889
1890 =cut
1891 */
1892
1893 SV *
Perl_hv_iternextsv(pTHX_ HV * hv,char ** key,I32 * retlen)1894 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
1895 {
1896 HE *he;
1897 if ( (he = hv_iternext_flags(hv, 0)) == NULL)
1898 return NULL;
1899 *key = hv_iterkey(he, retlen);
1900 return hv_iterval(hv, he);
1901 }
1902
1903 /*
1904 =for apidoc hv_magic
1905
1906 Adds magic to a hash. See C<sv_magic>.
1907
1908 =cut
1909 */
1910
1911 void
Perl_hv_magic(pTHX_ HV * hv,GV * gv,int how)1912 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
1913 {
1914 sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
1915 }
1916
1917 #if 0 /* use the macro from hv.h instead */
1918
1919 char*
1920 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
1921 {
1922 return HEK_KEY(share_hek(sv, len, hash));
1923 }
1924
1925 #endif
1926
1927 /* possibly free a shared string if no one has access to it
1928 * len and hash must both be valid for str.
1929 */
1930 void
Perl_unsharepvn(pTHX_ const char * str,I32 len,U32 hash)1931 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
1932 {
1933 unshare_hek_or_pvn (NULL, str, len, hash);
1934 }
1935
1936
1937 void
Perl_unshare_hek(pTHX_ HEK * hek)1938 Perl_unshare_hek(pTHX_ HEK *hek)
1939 {
1940 unshare_hek_or_pvn(hek, NULL, 0, 0);
1941 }
1942
1943 /* possibly free a shared string if no one has access to it
1944 hek if non-NULL takes priority over the other 3, else str, len and hash
1945 are used. If so, len and hash must both be valid for str.
1946 */
1947 STATIC void
S_unshare_hek_or_pvn(pTHX_ HEK * hek,const char * str,I32 len,U32 hash)1948 S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash)
1949 {
1950 register XPVHV* xhv;
1951 register HE *entry;
1952 register HE **oentry;
1953 HE **first;
1954 bool found = 0;
1955 bool is_utf8 = FALSE;
1956 int k_flags = 0;
1957 const char * const save = str;
1958
1959 if (hek) {
1960 hash = HEK_HASH(hek);
1961 } else if (len < 0) {
1962 STRLEN tmplen = -len;
1963 is_utf8 = TRUE;
1964 /* See the note in hv_fetch(). --jhi */
1965 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
1966 len = tmplen;
1967 if (is_utf8)
1968 k_flags = HVhek_UTF8;
1969 if (str != save)
1970 k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
1971 }
1972
1973 /* what follows is the moral equivalent of:
1974 if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
1975 if (--*Svp == Nullsv)
1976 hv_delete(PL_strtab, str, len, G_DISCARD, hash);
1977 } */
1978 xhv = (XPVHV*)SvANY(PL_strtab);
1979 /* assert(xhv_array != 0) */
1980 LOCK_STRTAB_MUTEX;
1981 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
1982 first = oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1983 if (hek) {
1984 for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
1985 if (HeKEY_hek(entry) != hek)
1986 continue;
1987 found = 1;
1988 break;
1989 }
1990 } else {
1991 const int flags_masked = k_flags & HVhek_MASK;
1992 for (entry = *oentry; entry; oentry = &HeNEXT(entry), entry = *oentry) {
1993 if (HeHASH(entry) != hash) /* strings can't be equal */
1994 continue;
1995 if (HeKLEN(entry) != len)
1996 continue;
1997 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
1998 continue;
1999 if (HeKFLAGS(entry) != flags_masked)
2000 continue;
2001 found = 1;
2002 break;
2003 }
2004 }
2005
2006 if (found) {
2007 if (--HeVAL(entry) == Nullsv) {
2008 *oentry = HeNEXT(entry);
2009 if (!*first) {
2010 /* There are now no entries in our slot. */
2011 xhv->xhv_fill--; /* HvFILL(hv)-- */
2012 }
2013 Safefree(HeKEY_hek(entry));
2014 del_HE(entry);
2015 xhv->xhv_keys--; /* HvKEYS(hv)-- */
2016 }
2017 }
2018
2019 UNLOCK_STRTAB_MUTEX;
2020 if (!found && ckWARN_d(WARN_INTERNAL))
2021 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
2022 "Attempt to free non-existent shared string '%s'%s"
2023 pTHX__FORMAT,
2024 hek ? HEK_KEY(hek) : str,
2025 ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
2026 if (k_flags & HVhek_FREEKEY)
2027 Safefree(str);
2028 }
2029
2030 /* get a (constant) string ptr from the global string table
2031 * string will get added if it is not already there.
2032 * len and hash must both be valid for str.
2033 */
2034 HEK *
Perl_share_hek(pTHX_ const char * str,I32 len,register U32 hash)2035 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
2036 {
2037 bool is_utf8 = FALSE;
2038 int flags = 0;
2039 const char * const save = str;
2040
2041 if (len < 0) {
2042 STRLEN tmplen = -len;
2043 is_utf8 = TRUE;
2044 /* See the note in hv_fetch(). --jhi */
2045 str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8);
2046 len = tmplen;
2047 /* If we were able to downgrade here, then than means that we were passed
2048 in a key which only had chars 0-255, but was utf8 encoded. */
2049 if (is_utf8)
2050 flags = HVhek_UTF8;
2051 /* If we found we were able to downgrade the string to bytes, then
2052 we should flag that it needs upgrading on keys or each. Also flag
2053 that we need share_hek_flags to free the string. */
2054 if (str != save)
2055 flags |= HVhek_WASUTF8 | HVhek_FREEKEY;
2056 }
2057
2058 return share_hek_flags (str, len, hash, flags);
2059 }
2060
2061 STATIC HEK *
S_share_hek_flags(pTHX_ const char * str,I32 len,register U32 hash,int flags)2062 S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags)
2063 {
2064 register XPVHV* xhv;
2065 register HE *entry;
2066 register HE **oentry;
2067 I32 found = 0;
2068 const int flags_masked = flags & HVhek_MASK;
2069
2070 /* what follows is the moral equivalent of:
2071
2072 if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
2073 hv_store(PL_strtab, str, len, Nullsv, hash);
2074
2075 Can't rehash the shared string table, so not sure if it's worth
2076 counting the number of entries in the linked list
2077 */
2078 xhv = (XPVHV*)SvANY(PL_strtab);
2079 /* assert(xhv_array != 0) */
2080 LOCK_STRTAB_MUTEX;
2081 /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */
2082 oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
2083 for (entry = *oentry; entry; entry = HeNEXT(entry)) {
2084 if (HeHASH(entry) != hash) /* strings can't be equal */
2085 continue;
2086 if (HeKLEN(entry) != len)
2087 continue;
2088 if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */
2089 continue;
2090 if (HeKFLAGS(entry) != flags_masked)
2091 continue;
2092 found = 1;
2093 break;
2094 }
2095 if (!found) {
2096 /* What used to be head of the list.
2097 If this is NULL, then we're the first entry for this slot, which
2098 means we need to increate fill. */
2099 const HE *old_first = *oentry;
2100 entry = new_HE();
2101 HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags_masked);
2102 HeVAL(entry) = Nullsv;
2103 HeNEXT(entry) = *oentry;
2104 *oentry = entry;
2105 xhv->xhv_keys++; /* HvKEYS(hv)++ */
2106 if (!old_first) { /* initial entry? */
2107 xhv->xhv_fill++; /* HvFILL(hv)++ */
2108 } else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) {
2109 hsplit(PL_strtab);
2110 }
2111 }
2112
2113 ++HeVAL(entry); /* use value slot as REFCNT */
2114 UNLOCK_STRTAB_MUTEX;
2115
2116 if (flags & HVhek_FREEKEY)
2117 Safefree(str);
2118
2119 return HeKEY_hek(entry);
2120 }
2121
2122 /*
2123 * Local variables:
2124 * c-indentation-style: bsd
2125 * c-basic-offset: 4
2126 * indent-tabs-mode: t
2127 * End:
2128 *
2129 * ex: set ts=8 sts=4 sw=4 noet:
2130 */
2131