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