Retract the mergesort code, way too incompatible licensing
[perl.git] / hv.c
1 /*    hv.c
2  *
3  *    Copyright (c) 1991-2000, Larry Wall
4  *
5  *    You may distribute under the terms of either the GNU General Public
6  *    License or the Artistic License, as specified in the README file.
7  *
8  */
9
10 /*
11  * "I sit beside the fire and think of all that I have seen."  --Bilbo
12  */
13
14 #include "EXTERN.h"
15 #define PERL_IN_HV_C
16 #include "perl.h"
17
18 STATIC HE*
19 S_new_he(pTHX)
20 {
21     HE* he;
22     LOCK_SV_MUTEX;
23     if (!PL_he_root)
24         more_he();
25     he = PL_he_root;
26     PL_he_root = HeNEXT(he);
27     UNLOCK_SV_MUTEX;
28     return he;
29 }
30
31 STATIC void
32 S_del_he(pTHX_ HE *p)
33 {
34     LOCK_SV_MUTEX;
35     HeNEXT(p) = (HE*)PL_he_root;
36     PL_he_root = p;
37     UNLOCK_SV_MUTEX;
38 }
39
40 STATIC void
41 S_more_he(pTHX)
42 {
43     register HE* he;
44     register HE* heend;
45     XPV *ptr;
46     New(54, ptr, 1008/sizeof(XPV), XPV);
47     ptr->xpv_pv = (char*)PL_he_arenaroot;
48     PL_he_arenaroot = ptr;
49
50     he = (HE*)ptr;
51     heend = &he[1008 / sizeof(HE) - 1];
52     PL_he_root = ++he;
53     while (he < heend) {
54         HeNEXT(he) = (HE*)(he + 1);
55         he++;
56     }
57     HeNEXT(he) = 0;
58 }
59
60 #ifdef PURIFY
61
62 #define new_HE() (HE*)safemalloc(sizeof(HE))
63 #define del_HE(p) safefree((char*)p)
64
65 #else
66
67 #define new_HE() new_he()
68 #define del_HE(p) del_he(p)
69
70 #endif
71
72 STATIC HEK *
73 S_save_hek(pTHX_ const char *str, I32 len, U32 hash)
74 {
75     char *k;
76     register HEK *hek;
77     
78     New(54, k, HEK_BASESIZE + len + 1, char);
79     hek = (HEK*)k;
80     Copy(str, HEK_KEY(hek), len, char);
81     *(HEK_KEY(hek) + len) = '\0';
82     HEK_LEN(hek) = len;
83     HEK_HASH(hek) = hash;
84     return hek;
85 }
86
87 void
88 Perl_unshare_hek(pTHX_ HEK *hek)
89 {
90     unsharepvn(HEK_KEY(hek),HEK_LEN(hek),HEK_HASH(hek));
91 }
92
93 #if defined(USE_ITHREADS)
94 HE *
95 Perl_he_dup(pTHX_ HE *e, bool shared)
96 {
97     HE *ret;
98
99     if (!e)
100         return Nullhe;
101     /* look for it in the table first */
102     ret = (HE*)ptr_table_fetch(PL_ptr_table, e);
103     if (ret)
104         return ret;
105
106     /* create anew and remember what it is */
107     ret = new_HE();
108     ptr_table_store(PL_ptr_table, e, ret);
109
110     HeNEXT(ret) = he_dup(HeNEXT(e),shared);
111     if (HeKLEN(e) == HEf_SVKEY)
112         HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e)));
113     else if (shared)
114         HeKEY_hek(ret) = share_hek(HeKEY(e), HeKLEN(e), HeHASH(e));
115     else
116         HeKEY_hek(ret) = save_hek(HeKEY(e), HeKLEN(e), HeHASH(e));
117     HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e)));
118     return ret;
119 }
120 #endif  /* USE_ITHREADS */
121
122 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
123  * contains an SV* */
124
125 /*
126 =for apidoc hv_fetch
127
128 Returns the SV which corresponds to the specified key in the hash.  The
129 C<klen> is the length of the key.  If C<lval> is set then the fetch will be
130 part of a store.  Check that the return value is non-null before
131 dereferencing it to a C<SV*>. 
132
133 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
134 information on how to use this function on tied hashes.
135
136 =cut
137 */
138
139 SV**
140 Perl_hv_fetch(pTHX_ HV *hv, const char *key, U32 klen, I32 lval)
141 {
142     register XPVHV* xhv;
143     register U32 hash;
144     register HE *entry;
145     SV *sv;
146
147     if (!hv)
148         return 0;
149
150     if (SvRMAGICAL(hv)) {
151         if (mg_find((SV*)hv,'P')) {
152             dTHR;
153             sv = sv_newmortal();
154             mg_copy((SV*)hv, sv, key, klen);
155             PL_hv_fetch_sv = sv;
156             return &PL_hv_fetch_sv;
157         }
158 #ifdef ENV_IS_CASELESS
159         else if (mg_find((SV*)hv,'E')) {
160             U32 i;
161             for (i = 0; i < klen; ++i)
162                 if (isLOWER(key[i])) {
163                     char *nkey = strupr(SvPVX(sv_2mortal(newSVpvn(key,klen))));
164                     SV **ret = hv_fetch(hv, nkey, klen, 0);
165                     if (!ret && lval)
166                         ret = hv_store(hv, key, klen, NEWSV(61,0), 0);
167                     return ret;
168                 }
169         }
170 #endif
171     }
172
173     xhv = (XPVHV*)SvANY(hv);
174     if (!xhv->xhv_array) {
175         if (lval 
176 #ifdef DYNAMIC_ENV_FETCH  /* if it's an %ENV lookup, we may get it on the fly */
177                  || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME))
178 #endif
179                                                                   )
180             Newz(503, xhv->xhv_array,
181                  PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
182         else
183             return 0;
184     }
185
186     PERL_HASH(hash, key, klen);
187
188     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
189     for (; entry; entry = HeNEXT(entry)) {
190         if (HeHASH(entry) != hash)              /* strings can't be equal */
191             continue;
192         if (HeKLEN(entry) != klen)
193             continue;
194         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
195             continue;
196         return &HeVAL(entry);
197     }
198 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
199     if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
200         unsigned long len;
201         char *env = PerlEnv_ENVgetenv_len(key,&len);
202         if (env) {
203             sv = newSVpvn(env,len);
204             SvTAINTED_on(sv);
205             return hv_store(hv,key,klen,sv,hash);
206         }
207     }
208 #endif
209     if (lval) {         /* gonna assign to this, so it better be there */
210         sv = NEWSV(61,0);
211         return hv_store(hv,key,klen,sv,hash);
212     }
213     return 0;
214 }
215
216 /* returns a HE * structure with the all fields set */
217 /* note that hent_val will be a mortal sv for MAGICAL hashes */
218 /*
219 =for apidoc hv_fetch_ent
220
221 Returns the hash entry which corresponds to the specified key in the hash.
222 C<hash> must be a valid precomputed hash number for the given C<key>, or 0
223 if you want the function to compute it.  IF C<lval> is set then the fetch
224 will be part of a store.  Make sure the return value is non-null before
225 accessing it.  The return value when C<tb> is a tied hash is a pointer to a
226 static location, so be sure to make a copy of the structure if you need to
227 store it somewhere. 
228
229 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
230 information on how to use this function on tied hashes.
231
232 =cut
233 */
234
235 HE *
236 Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash)
237 {
238     register XPVHV* xhv;
239     register char *key;
240     STRLEN klen;
241     register HE *entry;
242     SV *sv;
243
244     if (!hv)
245         return 0;
246
247     if (SvRMAGICAL(hv)) {
248         if (mg_find((SV*)hv,'P')) {
249             dTHR;
250             sv = sv_newmortal();
251             keysv = sv_2mortal(newSVsv(keysv));
252             mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
253             if (!HeKEY_hek(&PL_hv_fetch_ent_mh)) {
254                 char *k;
255                 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
256                 HeKEY_hek(&PL_hv_fetch_ent_mh) = (HEK*)k;
257             }
258             HeSVKEY_set(&PL_hv_fetch_ent_mh, keysv);
259             HeVAL(&PL_hv_fetch_ent_mh) = sv;
260             return &PL_hv_fetch_ent_mh;
261         }
262 #ifdef ENV_IS_CASELESS
263         else if (mg_find((SV*)hv,'E')) {
264             U32 i;
265             key = SvPV(keysv, klen);
266             for (i = 0; i < klen; ++i)
267                 if (isLOWER(key[i])) {
268                     SV *nkeysv = sv_2mortal(newSVpvn(key,klen));
269                     (void)strupr(SvPVX(nkeysv));
270                     entry = hv_fetch_ent(hv, nkeysv, 0, 0);
271                     if (!entry && lval)
272                         entry = hv_store_ent(hv, keysv, NEWSV(61,0), hash);
273                     return entry;
274                 }
275         }
276 #endif
277     }
278
279     xhv = (XPVHV*)SvANY(hv);
280     if (!xhv->xhv_array) {
281         if (lval 
282 #ifdef DYNAMIC_ENV_FETCH  /* if it's an %ENV lookup, we may get it on the fly */
283                  || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME))
284 #endif
285                                                                   )
286             Newz(503, xhv->xhv_array,
287                  PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
288         else
289             return 0;
290     }
291
292     key = SvPV(keysv, klen);
293     
294     if (!hash)
295         PERL_HASH(hash, key, klen);
296
297     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
298     for (; entry; entry = HeNEXT(entry)) {
299         if (HeHASH(entry) != hash)              /* strings can't be equal */
300             continue;
301         if (HeKLEN(entry) != klen)
302             continue;
303         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
304             continue;
305         return entry;
306     }
307 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
308     if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
309         unsigned long len;
310         char *env = PerlEnv_ENVgetenv_len(key,&len);
311         if (env) {
312             sv = newSVpvn(env,len);
313             SvTAINTED_on(sv);
314             return hv_store_ent(hv,keysv,sv,hash);
315         }
316     }
317 #endif
318     if (lval) {         /* gonna assign to this, so it better be there */
319         sv = NEWSV(61,0);
320         return hv_store_ent(hv,keysv,sv,hash);
321     }
322     return 0;
323 }
324
325 STATIC void
326 S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store)
327 {
328     MAGIC *mg = SvMAGIC(hv);
329     *needs_copy = FALSE;
330     *needs_store = TRUE;
331     while (mg) {
332         if (isUPPER(mg->mg_type)) {
333             *needs_copy = TRUE;
334             switch (mg->mg_type) {
335             case 'P':
336             case 'S':
337                 *needs_store = FALSE;
338             }
339         }
340         mg = mg->mg_moremagic;
341     }
342 }
343
344 /*
345 =for apidoc hv_store
346
347 Stores an SV in a hash.  The hash key is specified as C<key> and C<klen> is
348 the length of the key.  The C<hash> parameter is the precomputed hash
349 value; if it is zero then Perl will compute it.  The return value will be
350 NULL if the operation failed or if the value did not need to be actually
351 stored within the hash (as in the case of tied hashes).  Otherwise it can
352 be dereferenced to get the original C<SV*>.  Note that the caller is
353 responsible for suitably incrementing the reference count of C<val> before
354 the call, and decrementing it if the function returned NULL.  
355
356 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
357 information on how to use this function on tied hashes.
358
359 =cut
360 */
361
362 SV**
363 Perl_hv_store(pTHX_ HV *hv, const char *key, U32 klen, SV *val, register U32 hash)
364 {
365     register XPVHV* xhv;
366     register I32 i;
367     register HE *entry;
368     register HE **oentry;
369
370     if (!hv)
371         return 0;
372
373     xhv = (XPVHV*)SvANY(hv);
374     if (SvMAGICAL(hv)) {
375         bool needs_copy;
376         bool needs_store;
377         hv_magic_check (hv, &needs_copy, &needs_store);
378         if (needs_copy) {
379             mg_copy((SV*)hv, val, key, klen);
380             if (!xhv->xhv_array && !needs_store)
381                 return 0;
382 #ifdef ENV_IS_CASELESS
383             else if (mg_find((SV*)hv,'E')) {
384                 SV *sv = sv_2mortal(newSVpvn(key,klen));
385                 key = strupr(SvPVX(sv));
386                 hash = 0;
387             }
388 #endif
389         }
390     }
391     if (!hash)
392         PERL_HASH(hash, key, klen);
393
394     if (!xhv->xhv_array)
395         Newz(505, xhv->xhv_array,
396              PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
397
398     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
399     i = 1;
400
401     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
402         if (HeHASH(entry) != hash)              /* strings can't be equal */
403             continue;
404         if (HeKLEN(entry) != klen)
405             continue;
406         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
407             continue;
408         SvREFCNT_dec(HeVAL(entry));
409         HeVAL(entry) = val;
410         return &HeVAL(entry);
411     }
412
413     entry = new_HE();
414     if (HvSHAREKEYS(hv))
415         HeKEY_hek(entry) = share_hek(key, klen, hash);
416     else                                       /* gotta do the real thing */
417         HeKEY_hek(entry) = save_hek(key, klen, hash);
418     HeVAL(entry) = val;
419     HeNEXT(entry) = *oentry;
420     *oentry = entry;
421
422     xhv->xhv_keys++;
423     if (i) {                            /* initial entry? */
424         ++xhv->xhv_fill;
425         if (xhv->xhv_keys > xhv->xhv_max)
426             hsplit(hv);
427     }
428
429     return &HeVAL(entry);
430 }
431
432 /*
433 =for apidoc hv_store_ent
434
435 Stores C<val> in a hash.  The hash key is specified as C<key>.  The C<hash>
436 parameter is the precomputed hash value; if it is zero then Perl will
437 compute it.  The return value is the new hash entry so created.  It will be
438 NULL if the operation failed or if the value did not need to be actually
439 stored within the hash (as in the case of tied hashes).  Otherwise the
440 contents of the return value can be accessed using the C<He???> macros
441 described here.  Note that the caller is responsible for suitably
442 incrementing the reference count of C<val> before the call, and
443 decrementing it if the function returned NULL. 
444
445 See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more
446 information on how to use this function on tied hashes.
447
448 =cut
449 */
450
451 HE *
452 Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, register U32 hash)
453 {
454     register XPVHV* xhv;
455     register char *key;
456     STRLEN klen;
457     register I32 i;
458     register HE *entry;
459     register HE **oentry;
460
461     if (!hv)
462         return 0;
463
464     xhv = (XPVHV*)SvANY(hv);
465     if (SvMAGICAL(hv)) {
466         dTHR;
467         bool needs_copy;
468         bool needs_store;
469         hv_magic_check (hv, &needs_copy, &needs_store);
470         if (needs_copy) {
471             bool save_taint = PL_tainted;
472             if (PL_tainting)
473                 PL_tainted = SvTAINTED(keysv);
474             keysv = sv_2mortal(newSVsv(keysv));
475             mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
476             TAINT_IF(save_taint);
477             if (!xhv->xhv_array && !needs_store)
478                 return Nullhe;
479 #ifdef ENV_IS_CASELESS
480             else if (mg_find((SV*)hv,'E')) {
481                 key = SvPV(keysv, klen);
482                 keysv = sv_2mortal(newSVpvn(key,klen));
483                 (void)strupr(SvPVX(keysv));
484                 hash = 0;
485             }
486 #endif
487         }
488     }
489
490     key = SvPV(keysv, klen);
491
492     if (!hash)
493         PERL_HASH(hash, key, klen);
494
495     if (!xhv->xhv_array)
496         Newz(505, xhv->xhv_array,
497              PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
498
499     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
500     i = 1;
501
502     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
503         if (HeHASH(entry) != hash)              /* strings can't be equal */
504             continue;
505         if (HeKLEN(entry) != klen)
506             continue;
507         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
508             continue;
509         SvREFCNT_dec(HeVAL(entry));
510         HeVAL(entry) = val;
511         return entry;
512     }
513
514     entry = new_HE();
515     if (HvSHAREKEYS(hv))
516         HeKEY_hek(entry) = share_hek(key, klen, hash);
517     else                                       /* gotta do the real thing */
518         HeKEY_hek(entry) = save_hek(key, klen, hash);
519     HeVAL(entry) = val;
520     HeNEXT(entry) = *oentry;
521     *oentry = entry;
522
523     xhv->xhv_keys++;
524     if (i) {                            /* initial entry? */
525         ++xhv->xhv_fill;
526         if (xhv->xhv_keys > xhv->xhv_max)
527             hsplit(hv);
528     }
529
530     return entry;
531 }
532
533 /*
534 =for apidoc hv_delete
535
536 Deletes a key/value pair in the hash.  The value SV is removed from the
537 hash and returned to the caller.  The C<klen> is the length of the key. 
538 The C<flags> value will normally be zero; if set to G_DISCARD then NULL
539 will be returned.
540
541 =cut
542 */
543
544 SV *
545 Perl_hv_delete(pTHX_ HV *hv, const char *key, U32 klen, I32 flags)
546 {
547     register XPVHV* xhv;
548     register I32 i;
549     register U32 hash;
550     register HE *entry;
551     register HE **oentry;
552     SV **svp;
553     SV *sv;
554
555     if (!hv)
556         return Nullsv;
557     if (SvRMAGICAL(hv)) {
558         bool needs_copy;
559         bool needs_store;
560         hv_magic_check (hv, &needs_copy, &needs_store);
561
562         if (needs_copy && (svp = hv_fetch(hv, key, klen, TRUE))) {
563             sv = *svp;
564             mg_clear(sv);
565             if (!needs_store) {
566                 if (mg_find(sv, 'p')) {
567                     sv_unmagic(sv, 'p');        /* No longer an element */
568                     return sv;
569                 }
570                 return Nullsv;          /* element cannot be deleted */
571             }
572 #ifdef ENV_IS_CASELESS
573             else if (mg_find((SV*)hv,'E')) {
574                 sv = sv_2mortal(newSVpvn(key,klen));
575                 key = strupr(SvPVX(sv));
576             }
577 #endif
578         }
579     }
580     xhv = (XPVHV*)SvANY(hv);
581     if (!xhv->xhv_array)
582         return Nullsv;
583
584     PERL_HASH(hash, key, klen);
585
586     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
587     entry = *oentry;
588     i = 1;
589     for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
590         if (HeHASH(entry) != hash)              /* strings can't be equal */
591             continue;
592         if (HeKLEN(entry) != klen)
593             continue;
594         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
595             continue;
596         *oentry = HeNEXT(entry);
597         if (i && !*oentry)
598             xhv->xhv_fill--;
599         if (flags & G_DISCARD)
600             sv = Nullsv;
601         else {
602             sv = sv_2mortal(HeVAL(entry));
603             HeVAL(entry) = &PL_sv_undef;
604         }
605         if (entry == xhv->xhv_eiter)
606             HvLAZYDEL_on(hv);
607         else
608             hv_free_ent(hv, entry);
609         --xhv->xhv_keys;
610         return sv;
611     }
612     return Nullsv;
613 }
614
615 /*
616 =for apidoc hv_delete_ent
617
618 Deletes a key/value pair in the hash.  The value SV is removed from the
619 hash and returned to the caller.  The C<flags> value will normally be zero;
620 if set to G_DISCARD then NULL will be returned.  C<hash> can be a valid
621 precomputed hash value, or 0 to ask for it to be computed.
622
623 =cut
624 */
625
626 SV *
627 Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash)
628 {
629     register XPVHV* xhv;
630     register I32 i;
631     register char *key;
632     STRLEN klen;
633     register HE *entry;
634     register HE **oentry;
635     SV *sv;
636     
637     if (!hv)
638         return Nullsv;
639     if (SvRMAGICAL(hv)) {
640         bool needs_copy;
641         bool needs_store;
642         hv_magic_check (hv, &needs_copy, &needs_store);
643
644         if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
645             sv = HeVAL(entry);
646             mg_clear(sv);
647             if (!needs_store) {
648                 if (mg_find(sv, 'p')) {
649                     sv_unmagic(sv, 'p');        /* No longer an element */
650                     return sv;
651                 }               
652                 return Nullsv;          /* element cannot be deleted */
653             }
654 #ifdef ENV_IS_CASELESS
655             else if (mg_find((SV*)hv,'E')) {
656                 key = SvPV(keysv, klen);
657                 keysv = sv_2mortal(newSVpvn(key,klen));
658                 (void)strupr(SvPVX(keysv));
659                 hash = 0; 
660             }
661 #endif
662         }
663     }
664     xhv = (XPVHV*)SvANY(hv);
665     if (!xhv->xhv_array)
666         return Nullsv;
667
668     key = SvPV(keysv, klen);
669     
670     if (!hash)
671         PERL_HASH(hash, key, klen);
672
673     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
674     entry = *oentry;
675     i = 1;
676     for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
677         if (HeHASH(entry) != hash)              /* strings can't be equal */
678             continue;
679         if (HeKLEN(entry) != klen)
680             continue;
681         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
682             continue;
683         *oentry = HeNEXT(entry);
684         if (i && !*oentry)
685             xhv->xhv_fill--;
686         if (flags & G_DISCARD)
687             sv = Nullsv;
688         else {
689             sv = sv_2mortal(HeVAL(entry));
690             HeVAL(entry) = &PL_sv_undef;
691         }
692         if (entry == xhv->xhv_eiter)
693             HvLAZYDEL_on(hv);
694         else
695             hv_free_ent(hv, entry);
696         --xhv->xhv_keys;
697         return sv;
698     }
699     return Nullsv;
700 }
701
702 /*
703 =for apidoc hv_exists
704
705 Returns a boolean indicating whether the specified hash key exists.  The
706 C<klen> is the length of the key.
707
708 =cut
709 */
710
711 bool
712 Perl_hv_exists(pTHX_ HV *hv, const char *key, U32 klen)
713 {
714     register XPVHV* xhv;
715     register U32 hash;
716     register HE *entry;
717     SV *sv;
718
719     if (!hv)
720         return 0;
721
722     if (SvRMAGICAL(hv)) {
723         if (mg_find((SV*)hv,'P')) {
724             dTHR;
725             sv = sv_newmortal();
726             mg_copy((SV*)hv, sv, key, klen); 
727             magic_existspack(sv, mg_find(sv, 'p'));
728             return SvTRUE(sv);
729         }
730 #ifdef ENV_IS_CASELESS
731         else if (mg_find((SV*)hv,'E')) {
732             sv = sv_2mortal(newSVpvn(key,klen));
733             key = strupr(SvPVX(sv));
734         }
735 #endif
736     }
737
738     xhv = (XPVHV*)SvANY(hv);
739 #ifndef DYNAMIC_ENV_FETCH
740     if (!xhv->xhv_array)
741         return 0; 
742 #endif
743
744     PERL_HASH(hash, key, klen);
745
746 #ifdef DYNAMIC_ENV_FETCH
747     if (!xhv->xhv_array) entry = Null(HE*);
748     else
749 #endif
750     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
751     for (; entry; entry = HeNEXT(entry)) {
752         if (HeHASH(entry) != hash)              /* strings can't be equal */
753             continue;
754         if (HeKLEN(entry) != klen)
755             continue;
756         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
757             continue;
758         return TRUE;
759     }
760 #ifdef DYNAMIC_ENV_FETCH  /* is it out there? */
761     if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME)) {
762         unsigned long len;
763         char *env = PerlEnv_ENVgetenv_len(key,&len);
764         if (env) {
765             sv = newSVpvn(env,len);
766             SvTAINTED_on(sv);
767             (void)hv_store(hv,key,klen,sv,hash);
768             return TRUE;
769         }
770     }
771 #endif
772     return FALSE;
773 }
774
775
776 /*
777 =for apidoc hv_exists_ent
778
779 Returns a boolean indicating whether the specified hash key exists. C<hash>
780 can be a valid precomputed hash value, or 0 to ask for it to be
781 computed.
782
783 =cut
784 */
785
786 bool
787 Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash)
788 {
789     register XPVHV* xhv;
790     register char *key;
791     STRLEN klen;
792     register HE *entry;
793     SV *sv;
794
795     if (!hv)
796         return 0;
797
798     if (SvRMAGICAL(hv)) {
799         if (mg_find((SV*)hv,'P')) {
800             dTHR;               /* just for SvTRUE */
801             sv = sv_newmortal();
802             keysv = sv_2mortal(newSVsv(keysv));
803             mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY); 
804             magic_existspack(sv, mg_find(sv, 'p'));
805             return SvTRUE(sv);
806         }
807 #ifdef ENV_IS_CASELESS
808         else if (mg_find((SV*)hv,'E')) {
809             key = SvPV(keysv, klen);
810             keysv = sv_2mortal(newSVpvn(key,klen));
811             (void)strupr(SvPVX(keysv));
812             hash = 0; 
813         }
814 #endif
815     }
816
817     xhv = (XPVHV*)SvANY(hv);
818 #ifndef DYNAMIC_ENV_FETCH
819     if (!xhv->xhv_array)
820         return 0; 
821 #endif
822
823     key = SvPV(keysv, klen);
824     if (!hash)
825         PERL_HASH(hash, key, klen);
826
827 #ifdef DYNAMIC_ENV_FETCH
828     if (!xhv->xhv_array) entry = Null(HE*);
829     else
830 #endif
831     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
832     for (; entry; entry = HeNEXT(entry)) {
833         if (HeHASH(entry) != hash)              /* strings can't be equal */
834             continue;
835         if (HeKLEN(entry) != klen)
836             continue;
837         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
838             continue;
839         return TRUE;
840     }
841 #ifdef DYNAMIC_ENV_FETCH  /* is it out there? */
842     if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME)) {
843         unsigned long len;
844         char *env = PerlEnv_ENVgetenv_len(key,&len);
845         if (env) {
846             sv = newSVpvn(env,len);
847             SvTAINTED_on(sv);
848             (void)hv_store_ent(hv,keysv,sv,hash);
849             return TRUE;
850         }
851     }
852 #endif
853     return FALSE;
854 }
855
856 STATIC void
857 S_hsplit(pTHX_ HV *hv)
858 {
859     register XPVHV* xhv = (XPVHV*)SvANY(hv);
860     I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
861     register I32 newsize = oldsize * 2;
862     register I32 i;
863     register char *a = xhv->xhv_array;
864     register HE **aep;
865     register HE **bep;
866     register HE *entry;
867     register HE **oentry;
868
869     PL_nomemok = TRUE;
870 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
871     Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
872     if (!a) {
873       PL_nomemok = FALSE;
874       return;
875     }
876 #else
877 #define MALLOC_OVERHEAD 16
878     New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
879     if (!a) {
880       PL_nomemok = FALSE;
881       return;
882     }
883     Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char);
884     if (oldsize >= 64) {
885         offer_nice_chunk(xhv->xhv_array, PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
886     }
887     else
888         Safefree(xhv->xhv_array);
889 #endif
890
891     PL_nomemok = FALSE;
892     Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char);     /* zero 2nd half*/
893     xhv->xhv_max = --newsize;
894     xhv->xhv_array = a;
895     aep = (HE**)a;
896
897     for (i=0; i<oldsize; i++,aep++) {
898         if (!*aep)                              /* non-existent */
899             continue;
900         bep = aep+oldsize;
901         for (oentry = aep, entry = *aep; entry; entry = *oentry) {
902             if ((HeHASH(entry) & newsize) != i) {
903                 *oentry = HeNEXT(entry);
904                 HeNEXT(entry) = *bep;
905                 if (!*bep)
906                     xhv->xhv_fill++;
907                 *bep = entry;
908                 continue;
909             }
910             else
911                 oentry = &HeNEXT(entry);
912         }
913         if (!*aep)                              /* everything moved */
914             xhv->xhv_fill--;
915     }
916 }
917
918 void
919 Perl_hv_ksplit(pTHX_ HV *hv, IV newmax)
920 {
921     register XPVHV* xhv = (XPVHV*)SvANY(hv);
922     I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
923     register I32 newsize;
924     register I32 i;
925     register I32 j;
926     register char *a;
927     register HE **aep;
928     register HE *entry;
929     register HE **oentry;
930
931     newsize = (I32) newmax;                     /* possible truncation here */
932     if (newsize != newmax || newmax <= oldsize)
933         return;
934     while ((newsize & (1 + ~newsize)) != newsize) {
935         newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
936     }
937     if (newsize < newmax)
938         newsize *= 2;
939     if (newsize < newmax)
940         return;                                 /* overflow detection */
941
942     a = xhv->xhv_array;
943     if (a) {
944         PL_nomemok = TRUE;
945 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
946         Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
947         if (!a) {
948           PL_nomemok = FALSE;
949           return;
950         }
951 #else
952         New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
953         if (!a) {
954           PL_nomemok = FALSE;
955           return;
956         }
957         Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char);
958         if (oldsize >= 64) {
959             offer_nice_chunk(xhv->xhv_array, PERL_HV_ARRAY_ALLOC_BYTES(oldsize));
960         }
961         else
962             Safefree(xhv->xhv_array);
963 #endif
964         PL_nomemok = FALSE;
965         Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
966     }
967     else {
968         Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char);
969     }
970     xhv->xhv_max = --newsize;
971     xhv->xhv_array = a;
972     if (!xhv->xhv_fill)                         /* skip rest if no entries */
973         return;
974
975     aep = (HE**)a;
976     for (i=0; i<oldsize; i++,aep++) {
977         if (!*aep)                              /* non-existent */
978             continue;
979         for (oentry = aep, entry = *aep; entry; entry = *oentry) {
980             if ((j = (HeHASH(entry) & newsize)) != i) {
981                 j -= i;
982                 *oentry = HeNEXT(entry);
983                 if (!(HeNEXT(entry) = aep[j]))
984                     xhv->xhv_fill++;
985                 aep[j] = entry;
986                 continue;
987             }
988             else
989                 oentry = &HeNEXT(entry);
990         }
991         if (!*aep)                              /* everything moved */
992             xhv->xhv_fill--;
993     }
994 }
995
996 /*
997 =for apidoc newHV
998
999 Creates a new HV.  The reference count is set to 1.
1000
1001 =cut
1002 */
1003
1004 HV *
1005 Perl_newHV(pTHX)
1006 {
1007     register HV *hv;
1008     register XPVHV* xhv;
1009
1010     hv = (HV*)NEWSV(502,0);
1011     sv_upgrade((SV *)hv, SVt_PVHV);
1012     xhv = (XPVHV*)SvANY(hv);
1013     SvPOK_off(hv);
1014     SvNOK_off(hv);
1015 #ifndef NODEFAULT_SHAREKEYS    
1016     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
1017 #endif    
1018     xhv->xhv_max = 7;           /* start with 8 buckets */
1019     xhv->xhv_fill = 0;
1020     xhv->xhv_pmroot = 0;
1021     (void)hv_iterinit(hv);      /* so each() will start off right */
1022     return hv;
1023 }
1024
1025 HV *
1026 Perl_newHVhv(pTHX_ HV *ohv)
1027 {
1028     register HV *hv;
1029     STRLEN hv_max = ohv ? HvMAX(ohv) : 0;
1030     STRLEN hv_fill = ohv ? HvFILL(ohv) : 0;
1031
1032     hv = newHV();
1033     while (hv_max && hv_max + 1 >= hv_fill * 2)
1034         hv_max = hv_max / 2;    /* Is always 2^n-1 */
1035     HvMAX(hv) = hv_max;
1036     if (!hv_fill)
1037         return hv;
1038
1039 #if 0
1040     if (! SvTIED_mg((SV*)ohv, 'P')) {
1041         /* Quick way ???*/
1042     } 
1043     else 
1044 #endif
1045     {
1046         HE *entry;
1047         I32 hv_riter = HvRITER(ohv);    /* current root of iterator */
1048         HE *hv_eiter = HvEITER(ohv);    /* current entry of iterator */
1049         
1050         /* Slow way */
1051         hv_iterinit(ohv);
1052         while ((entry = hv_iternext(ohv))) {
1053             hv_store(hv, HeKEY(entry), HeKLEN(entry), 
1054                      SvREFCNT_inc(HeVAL(entry)), HeHASH(entry));
1055         }
1056         HvRITER(ohv) = hv_riter;
1057         HvEITER(ohv) = hv_eiter;
1058     }
1059     
1060     return hv;
1061 }
1062
1063 void
1064 Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry)
1065 {
1066     SV *val;
1067
1068     if (!entry)
1069         return;
1070     val = HeVAL(entry);
1071     if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
1072         PL_sub_generation++;    /* may be deletion of method from stash */
1073     SvREFCNT_dec(val);
1074     if (HeKLEN(entry) == HEf_SVKEY) {
1075         SvREFCNT_dec(HeKEY_sv(entry));
1076         Safefree(HeKEY_hek(entry));
1077     }
1078     else if (HvSHAREKEYS(hv))
1079         unshare_hek(HeKEY_hek(entry));
1080     else
1081         Safefree(HeKEY_hek(entry));
1082     del_HE(entry);
1083 }
1084
1085 void
1086 Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry)
1087 {
1088     if (!entry)
1089         return;
1090     if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
1091         PL_sub_generation++;    /* may be deletion of method from stash */
1092     sv_2mortal(HeVAL(entry));   /* free between statements */
1093     if (HeKLEN(entry) == HEf_SVKEY) {
1094         sv_2mortal(HeKEY_sv(entry));
1095         Safefree(HeKEY_hek(entry));
1096     }
1097     else if (HvSHAREKEYS(hv))
1098         unshare_hek(HeKEY_hek(entry));
1099     else
1100         Safefree(HeKEY_hek(entry));
1101     del_HE(entry);
1102 }
1103
1104 /*
1105 =for apidoc hv_clear
1106
1107 Clears a hash, making it empty.
1108
1109 =cut
1110 */
1111
1112 void
1113 Perl_hv_clear(pTHX_ HV *hv)
1114 {
1115     register XPVHV* xhv;
1116     if (!hv)
1117         return;
1118     xhv = (XPVHV*)SvANY(hv);
1119     hfreeentries(hv);
1120     xhv->xhv_fill = 0;
1121     xhv->xhv_keys = 0;
1122     if (xhv->xhv_array)
1123         (void)memzero(xhv->xhv_array, (xhv->xhv_max + 1) * sizeof(HE*));
1124
1125     if (SvRMAGICAL(hv))
1126         mg_clear((SV*)hv); 
1127 }
1128
1129 STATIC void
1130 S_hfreeentries(pTHX_ HV *hv)
1131 {
1132     register HE **array;
1133     register HE *entry;
1134     register HE *oentry = Null(HE*);
1135     I32 riter;
1136     I32 max;
1137
1138     if (!hv)
1139         return;
1140     if (!HvARRAY(hv))
1141         return;
1142
1143     riter = 0;
1144     max = HvMAX(hv);
1145     array = HvARRAY(hv);
1146     entry = array[0];
1147     for (;;) {
1148         if (entry) {
1149             oentry = entry;
1150             entry = HeNEXT(entry);
1151             hv_free_ent(hv, oentry);
1152         }
1153         if (!entry) {
1154             if (++riter > max)
1155                 break;
1156             entry = array[riter];
1157         } 
1158     }
1159     (void)hv_iterinit(hv);
1160 }
1161
1162 /*
1163 =for apidoc hv_undef
1164
1165 Undefines the hash.
1166
1167 =cut
1168 */
1169
1170 void
1171 Perl_hv_undef(pTHX_ HV *hv)
1172 {
1173     register XPVHV* xhv;
1174     if (!hv)
1175         return;
1176     xhv = (XPVHV*)SvANY(hv);
1177     hfreeentries(hv);
1178     Safefree(xhv->xhv_array);
1179     if (HvNAME(hv)) {
1180         Safefree(HvNAME(hv));
1181         HvNAME(hv) = 0;
1182     }
1183     xhv->xhv_array = 0;
1184     xhv->xhv_max = 7;           /* it's a normal hash */
1185     xhv->xhv_fill = 0;
1186     xhv->xhv_keys = 0;
1187
1188     if (SvRMAGICAL(hv))
1189         mg_clear((SV*)hv); 
1190 }
1191
1192 /*
1193 =for apidoc hv_iterinit
1194
1195 Prepares a starting point to traverse a hash table.  Returns the number of
1196 keys in the hash (i.e. the same as C<HvKEYS(tb)>).  The return value is
1197 currently only meaningful for hashes without tie magic. 
1198
1199 NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of
1200 hash buckets that happen to be in use.  If you still need that esoteric
1201 value, you can get it through the macro C<HvFILL(tb)>.
1202
1203 =cut
1204 */
1205
1206 I32
1207 Perl_hv_iterinit(pTHX_ HV *hv)
1208 {
1209     register XPVHV* xhv;
1210     HE *entry;
1211
1212     if (!hv)
1213         Perl_croak(aTHX_ "Bad hash");
1214     xhv = (XPVHV*)SvANY(hv);
1215     entry = xhv->xhv_eiter;
1216     if (entry && HvLAZYDEL(hv)) {       /* was deleted earlier? */
1217         HvLAZYDEL_off(hv);
1218         hv_free_ent(hv, entry);
1219     }
1220     xhv->xhv_riter = -1;
1221     xhv->xhv_eiter = Null(HE*);
1222     return xhv->xhv_keys;       /* used to be xhv->xhv_fill before 5.004_65 */
1223 }
1224
1225 /*
1226 =for apidoc hv_iternext
1227
1228 Returns entries from a hash iterator.  See C<hv_iterinit>.
1229
1230 =cut
1231 */
1232
1233 HE *
1234 Perl_hv_iternext(pTHX_ HV *hv)
1235 {
1236     register XPVHV* xhv;
1237     register HE *entry;
1238     HE *oldentry;
1239     MAGIC* mg;
1240
1241     if (!hv)
1242         Perl_croak(aTHX_ "Bad hash");
1243     xhv = (XPVHV*)SvANY(hv);
1244     oldentry = entry = xhv->xhv_eiter;
1245
1246     if ((mg = SvTIED_mg((SV*)hv, 'P'))) {
1247         SV *key = sv_newmortal();
1248         if (entry) {
1249             sv_setsv(key, HeSVKEY_force(entry));
1250             SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
1251         }
1252         else {
1253             char *k;
1254             HEK *hek;
1255
1256             xhv->xhv_eiter = entry = new_HE();  /* one HE per MAGICAL hash */
1257             Zero(entry, 1, HE);
1258             Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1259             hek = (HEK*)k;
1260             HeKEY_hek(entry) = hek;
1261             HeKLEN(entry) = HEf_SVKEY;
1262         }
1263         magic_nextpack((SV*) hv,mg,key);
1264         if (SvOK(key)) {
1265             /* force key to stay around until next time */
1266             HeSVKEY_set(entry, SvREFCNT_inc(key));
1267             return entry;               /* beware, hent_val is not set */
1268         }
1269         if (HeVAL(entry))
1270             SvREFCNT_dec(HeVAL(entry));
1271         Safefree(HeKEY_hek(entry));
1272         del_HE(entry);
1273         xhv->xhv_eiter = Null(HE*);
1274         return Null(HE*);
1275     }
1276 #ifdef DYNAMIC_ENV_FETCH  /* set up %ENV for iteration */
1277     if (!entry && HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME))
1278         prime_env_iter();
1279 #endif
1280
1281     if (!xhv->xhv_array)
1282         Newz(506, xhv->xhv_array,
1283              PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
1284     if (entry)
1285         entry = HeNEXT(entry);
1286     while (!entry) {
1287         ++xhv->xhv_riter;
1288         if (xhv->xhv_riter > xhv->xhv_max) {
1289             xhv->xhv_riter = -1;
1290             break;
1291         }
1292         entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
1293     }
1294
1295     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
1296         HvLAZYDEL_off(hv);
1297         hv_free_ent(hv, oldentry);
1298     }
1299
1300     xhv->xhv_eiter = entry;
1301     return entry;
1302 }
1303
1304 /*
1305 =for apidoc hv_iterkey
1306
1307 Returns the key from the current position of the hash iterator.  See
1308 C<hv_iterinit>.
1309
1310 =cut
1311 */
1312
1313 char *
1314 Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen)
1315 {
1316     if (HeKLEN(entry) == HEf_SVKEY) {
1317         STRLEN len;
1318         char *p = SvPV(HeKEY_sv(entry), len);
1319         *retlen = len;
1320         return p;
1321     }
1322     else {
1323         *retlen = HeKLEN(entry);
1324         return HeKEY(entry);
1325     }
1326 }
1327
1328 /* unlike hv_iterval(), this always returns a mortal copy of the key */
1329 /*
1330 =for apidoc hv_iterkeysv
1331
1332 Returns the key as an C<SV*> from the current position of the hash
1333 iterator.  The return value will always be a mortal copy of the key.  Also
1334 see C<hv_iterinit>.
1335
1336 =cut
1337 */
1338
1339 SV *
1340 Perl_hv_iterkeysv(pTHX_ register HE *entry)
1341 {
1342     if (HeKLEN(entry) == HEf_SVKEY)
1343         return sv_mortalcopy(HeKEY_sv(entry));
1344     else
1345         return sv_2mortal(newSVpvn((HeKLEN(entry) ? HeKEY(entry) : ""),
1346                                   HeKLEN(entry)));
1347 }
1348
1349 /*
1350 =for apidoc hv_iterval
1351
1352 Returns the value from the current position of the hash iterator.  See
1353 C<hv_iterkey>.
1354
1355 =cut
1356 */
1357
1358 SV *
1359 Perl_hv_iterval(pTHX_ HV *hv, register HE *entry)
1360 {
1361     if (SvRMAGICAL(hv)) {
1362         if (mg_find((SV*)hv,'P')) {
1363             SV* sv = sv_newmortal();
1364             if (HeKLEN(entry) == HEf_SVKEY)
1365                 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
1366             else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
1367             return sv;
1368         }
1369     }
1370     return HeVAL(entry);
1371 }
1372
1373 /*
1374 =for apidoc hv_iternextsv
1375
1376 Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one
1377 operation.
1378
1379 =cut
1380 */
1381
1382 SV *
1383 Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen)
1384 {
1385     HE *he;
1386     if ( (he = hv_iternext(hv)) == NULL)
1387         return NULL;
1388     *key = hv_iterkey(he, retlen);
1389     return hv_iterval(hv, he);
1390 }
1391
1392 /*
1393 =for apidoc hv_magic
1394
1395 Adds magic to a hash.  See C<sv_magic>.
1396
1397 =cut
1398 */
1399
1400 void
1401 Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how)
1402 {
1403     sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
1404 }
1405
1406 char*   
1407 Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash)
1408 {
1409     return HEK_KEY(share_hek(sv, len, hash));
1410 }
1411
1412 /* possibly free a shared string if no one has access to it
1413  * len and hash must both be valid for str.
1414  */
1415 void
1416 Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash)
1417 {
1418     register XPVHV* xhv;
1419     register HE *entry;
1420     register HE **oentry;
1421     register I32 i = 1;
1422     I32 found = 0;
1423     
1424     /* what follows is the moral equivalent of:
1425     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
1426         if (--*Svp == Nullsv)
1427             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
1428     } */
1429     xhv = (XPVHV*)SvANY(PL_strtab);
1430     /* assert(xhv_array != 0) */
1431     LOCK_STRTAB_MUTEX;
1432     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1433     for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
1434         if (HeHASH(entry) != hash)              /* strings can't be equal */
1435             continue;
1436         if (HeKLEN(entry) != len)
1437             continue;
1438         if (memNE(HeKEY(entry),str,len))        /* is this it? */
1439             continue;
1440         found = 1;
1441         if (--HeVAL(entry) == Nullsv) {
1442             *oentry = HeNEXT(entry);
1443             if (i && !*oentry)
1444                 xhv->xhv_fill--;
1445             Safefree(HeKEY_hek(entry));
1446             del_HE(entry);
1447             --xhv->xhv_keys;
1448         }
1449         break;
1450     }
1451     UNLOCK_STRTAB_MUTEX;
1452     
1453     {
1454         dTHR;
1455         if (!found && ckWARN_d(WARN_INTERNAL))
1456             Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string");    
1457     }
1458 }
1459
1460 /* get a (constant) string ptr from the global string table
1461  * string will get added if it is not already there.
1462  * len and hash must both be valid for str.
1463  */
1464 HEK *
1465 Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash)
1466 {
1467     register XPVHV* xhv;
1468     register HE *entry;
1469     register HE **oentry;
1470     register I32 i = 1;
1471     I32 found = 0;
1472
1473     /* what follows is the moral equivalent of:
1474        
1475     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
1476         hv_store(PL_strtab, str, len, Nullsv, hash);
1477     */
1478     xhv = (XPVHV*)SvANY(PL_strtab);
1479     /* assert(xhv_array != 0) */
1480     LOCK_STRTAB_MUTEX;
1481     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1482     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
1483         if (HeHASH(entry) != hash)              /* strings can't be equal */
1484             continue;
1485         if (HeKLEN(entry) != len)
1486             continue;
1487         if (memNE(HeKEY(entry),str,len))        /* is this it? */
1488             continue;
1489         found = 1;
1490         break;
1491     }
1492     if (!found) {
1493         entry = new_HE();
1494         HeKEY_hek(entry) = save_hek(str, len, hash);
1495         HeVAL(entry) = Nullsv;
1496         HeNEXT(entry) = *oentry;
1497         *oentry = entry;
1498         xhv->xhv_keys++;
1499         if (i) {                                /* initial entry? */
1500             ++xhv->xhv_fill;
1501             if (xhv->xhv_keys > xhv->xhv_max)
1502                 hsplit(PL_strtab);
1503         }
1504     }
1505
1506     ++HeVAL(entry);                             /* use value slot as REFCNT */
1507     UNLOCK_STRTAB_MUTEX;
1508     return HeKEY_hek(entry);
1509 }
1510
1511
1512