This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
0f71f0191ec7798607e4df3a05aa063e9c43a814
[perl5.git] / hv.c
1 /*    hv.c
2  *
3  *    Copyright (c) 1991-1999, 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 #include "perl.h"
16
17 static void hv_magic_check (HV *hv, bool *needs_copy, bool *needs_store);
18 #ifndef PERL_OBJECT
19 static void hsplit (HV *hv);
20 static void hfreeentries (HV *hv);
21 static void more_he (void);
22 static HEK *save_hek (const char *str, I32 len, U32 hash);
23 #endif
24
25 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
26 #  define ARRAY_ALLOC_BYTES(size) ( (size)*sizeof(HE*) )
27 #else
28 #  define MALLOC_OVERHEAD 16
29 #  define ARRAY_ALLOC_BYTES(size) ( ((size) < 64)       \
30                                 ? (size)*sizeof(HE*)    \
31                                 : (size)*sizeof(HE*)*2 - MALLOC_OVERHEAD )
32 #endif
33
34 STATIC HE*
35 new_he(void)
36 {
37     HE* he;
38     LOCK_SV_MUTEX;
39     if (!PL_he_root)
40         more_he();
41     he = PL_he_root;
42     PL_he_root = HeNEXT(he);
43     UNLOCK_SV_MUTEX;
44     return he;
45 }
46
47 STATIC void
48 del_he(HE *p)
49 {
50     LOCK_SV_MUTEX;
51     HeNEXT(p) = (HE*)PL_he_root;
52     PL_he_root = p;
53     UNLOCK_SV_MUTEX;
54 }
55
56 STATIC void
57 more_he(void)
58 {
59     register HE* he;
60     register HE* heend;
61     New(54, PL_he_root, 1008/sizeof(HE), HE);
62     he = PL_he_root;
63     heend = &he[1008 / sizeof(HE) - 1];
64     while (he < heend) {
65         HeNEXT(he) = (HE*)(he + 1);
66         he++;
67     }
68     HeNEXT(he) = 0;
69 }
70
71 STATIC HEK *
72 save_hek(const char *str, I32 len, U32 hash)
73 {
74     char *k;
75     register HEK *hek;
76     
77     New(54, k, HEK_BASESIZE + len + 1, char);
78     hek = (HEK*)k;
79     Copy(str, HEK_KEY(hek), len, char);
80     *(HEK_KEY(hek) + len) = '\0';
81     HEK_LEN(hek) = len;
82     HEK_HASH(hek) = hash;
83     return hek;
84 }
85
86 void
87 unshare_hek(HEK *hek)
88 {
89     unsharepvn(HEK_KEY(hek),HEK_LEN(hek),HEK_HASH(hek));
90 }
91
92 /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
93  * contains an SV* */
94
95 SV**
96 hv_fetch(HV *hv, const char *key, U32 klen, I32 lval)
97 {
98     register XPVHV* xhv;
99     register U32 hash;
100     register HE *entry;
101     SV *sv;
102
103     if (!hv)
104         return 0;
105
106     if (SvRMAGICAL(hv)) {
107         if (mg_find((SV*)hv,'P')) {
108             dTHR;
109             sv = sv_newmortal();
110             mg_copy((SV*)hv, sv, key, klen);
111             PL_hv_fetch_sv = sv;
112             return &PL_hv_fetch_sv;
113         }
114 #ifdef ENV_IS_CASELESS
115         else if (mg_find((SV*)hv,'E')) {
116             U32 i;
117             for (i = 0; i < klen; ++i)
118                 if (isLOWER(key[i])) {
119                     char *nkey = strupr(SvPVX(sv_2mortal(newSVpvn(key,klen))));
120                     SV **ret = hv_fetch(hv, nkey, klen, 0);
121                     if (!ret && lval)
122                         ret = hv_store(hv, key, klen, NEWSV(61,0), 0);
123                     return ret;
124                 }
125         }
126 #endif
127     }
128
129     xhv = (XPVHV*)SvANY(hv);
130     if (!xhv->xhv_array) {
131         if (lval 
132 #ifdef DYNAMIC_ENV_FETCH  /* if it's an %ENV lookup, we may get it on the fly */
133                  || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME))
134 #endif
135                                                                   )
136             Newz(503,xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
137         else
138             return 0;
139     }
140
141     PERL_HASH(hash, key, klen);
142
143     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
144     for (; entry; entry = HeNEXT(entry)) {
145         if (HeHASH(entry) != hash)              /* strings can't be equal */
146             continue;
147         if (HeKLEN(entry) != klen)
148             continue;
149         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
150             continue;
151         return &HeVAL(entry);
152     }
153 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
154     if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
155         unsigned long len;
156         char *env = PerlEnv_ENVgetenv_len(key,&len);
157         if (env) {
158             sv = newSVpvn(env,len);
159             SvTAINTED_on(sv);
160             return hv_store(hv,key,klen,sv,hash);
161         }
162     }
163 #endif
164     if (lval) {         /* gonna assign to this, so it better be there */
165         sv = NEWSV(61,0);
166         return hv_store(hv,key,klen,sv,hash);
167     }
168     return 0;
169 }
170
171 /* returns a HE * structure with the all fields set */
172 /* note that hent_val will be a mortal sv for MAGICAL hashes */
173 HE *
174 hv_fetch_ent(HV *hv, SV *keysv, I32 lval, register U32 hash)
175 {
176     register XPVHV* xhv;
177     register char *key;
178     STRLEN klen;
179     register HE *entry;
180     SV *sv;
181
182     if (!hv)
183         return 0;
184
185     if (SvRMAGICAL(hv)) {
186         if (mg_find((SV*)hv,'P')) {
187             dTHR;
188             sv = sv_newmortal();
189             keysv = sv_2mortal(newSVsv(keysv));
190             mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
191             if (!HeKEY_hek(&PL_hv_fetch_ent_mh)) {
192                 char *k;
193                 New(54, k, HEK_BASESIZE + sizeof(SV*), char);
194                 HeKEY_hek(&PL_hv_fetch_ent_mh) = (HEK*)k;
195             }
196             HeSVKEY_set(&PL_hv_fetch_ent_mh, keysv);
197             HeVAL(&PL_hv_fetch_ent_mh) = sv;
198             return &PL_hv_fetch_ent_mh;
199         }
200 #ifdef ENV_IS_CASELESS
201         else if (mg_find((SV*)hv,'E')) {
202             U32 i;
203             key = SvPV(keysv, klen);
204             for (i = 0; i < klen; ++i)
205                 if (isLOWER(key[i])) {
206                     SV *nkeysv = sv_2mortal(newSVpvn(key,klen));
207                     (void)strupr(SvPVX(nkeysv));
208                     entry = hv_fetch_ent(hv, nkeysv, 0, 0);
209                     if (!entry && lval)
210                         entry = hv_store_ent(hv, keysv, NEWSV(61,0), hash);
211                     return entry;
212                 }
213         }
214 #endif
215     }
216
217     xhv = (XPVHV*)SvANY(hv);
218     if (!xhv->xhv_array) {
219         if (lval 
220 #ifdef DYNAMIC_ENV_FETCH  /* if it's an %ENV lookup, we may get it on the fly */
221                  || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME))
222 #endif
223                                                                   )
224             Newz(503,xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
225         else
226             return 0;
227     }
228
229     key = SvPV(keysv, klen);
230     
231     if (!hash)
232         PERL_HASH(hash, key, klen);
233
234     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
235     for (; entry; entry = HeNEXT(entry)) {
236         if (HeHASH(entry) != hash)              /* strings can't be equal */
237             continue;
238         if (HeKLEN(entry) != klen)
239             continue;
240         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
241             continue;
242         return entry;
243     }
244 #ifdef DYNAMIC_ENV_FETCH  /* %ENV lookup?  If so, try to fetch the value now */
245     if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
246         unsigned long len;
247         char *env = PerlEnv_ENVgetenv_len(key,&len);
248         if (env) {
249             sv = newSVpvn(env,len);
250             SvTAINTED_on(sv);
251             return hv_store_ent(hv,keysv,sv,hash);
252         }
253     }
254 #endif
255     if (lval) {         /* gonna assign to this, so it better be there */
256         sv = NEWSV(61,0);
257         return hv_store_ent(hv,keysv,sv,hash);
258     }
259     return 0;
260 }
261
262 static void
263 hv_magic_check (HV *hv, bool *needs_copy, bool *needs_store)
264 {
265     MAGIC *mg = SvMAGIC(hv);
266     *needs_copy = FALSE;
267     *needs_store = TRUE;
268     while (mg) {
269         if (isUPPER(mg->mg_type)) {
270             *needs_copy = TRUE;
271             switch (mg->mg_type) {
272             case 'P':
273             case 'S':
274                 *needs_store = FALSE;
275             }
276         }
277         mg = mg->mg_moremagic;
278     }
279 }
280
281 SV**
282 hv_store(HV *hv, const char *key, U32 klen, SV *val, register U32 hash)
283 {
284     register XPVHV* xhv;
285     register I32 i;
286     register HE *entry;
287     register HE **oentry;
288
289     if (!hv)
290         return 0;
291
292     xhv = (XPVHV*)SvANY(hv);
293     if (SvMAGICAL(hv)) {
294         bool needs_copy;
295         bool needs_store;
296         hv_magic_check (hv, &needs_copy, &needs_store);
297         if (needs_copy) {
298             mg_copy((SV*)hv, val, key, klen);
299             if (!xhv->xhv_array && !needs_store)
300                 return 0;
301 #ifdef ENV_IS_CASELESS
302             else if (mg_find((SV*)hv,'E')) {
303                 SV *sv = sv_2mortal(newSVpvn(key,klen));
304                 key = strupr(SvPVX(sv));
305                 hash = 0;
306             }
307 #endif
308         }
309     }
310     if (!hash)
311         PERL_HASH(hash, key, klen);
312
313     if (!xhv->xhv_array)
314         Newz(505, xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
315
316     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
317     i = 1;
318
319     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
320         if (HeHASH(entry) != hash)              /* strings can't be equal */
321             continue;
322         if (HeKLEN(entry) != klen)
323             continue;
324         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
325             continue;
326         SvREFCNT_dec(HeVAL(entry));
327         HeVAL(entry) = val;
328         return &HeVAL(entry);
329     }
330
331     entry = new_he();
332     if (HvSHAREKEYS(hv))
333         HeKEY_hek(entry) = share_hek(key, klen, hash);
334     else                                       /* gotta do the real thing */
335         HeKEY_hek(entry) = save_hek(key, klen, hash);
336     HeVAL(entry) = val;
337     HeNEXT(entry) = *oentry;
338     *oentry = entry;
339
340     xhv->xhv_keys++;
341     if (i) {                            /* initial entry? */
342         ++xhv->xhv_fill;
343         if (xhv->xhv_keys > xhv->xhv_max)
344             hsplit(hv);
345     }
346
347     return &HeVAL(entry);
348 }
349
350 HE *
351 hv_store_ent(HV *hv, SV *keysv, SV *val, register U32 hash)
352 {
353     register XPVHV* xhv;
354     register char *key;
355     STRLEN klen;
356     register I32 i;
357     register HE *entry;
358     register HE **oentry;
359
360     if (!hv)
361         return 0;
362
363     xhv = (XPVHV*)SvANY(hv);
364     if (SvMAGICAL(hv)) {
365         dTHR;
366         bool needs_copy;
367         bool needs_store;
368         hv_magic_check (hv, &needs_copy, &needs_store);
369         if (needs_copy) {
370             bool save_taint = PL_tainted;
371             if (PL_tainting)
372                 PL_tainted = SvTAINTED(keysv);
373             keysv = sv_2mortal(newSVsv(keysv));
374             mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
375             TAINT_IF(save_taint);
376             if (!xhv->xhv_array && !needs_store)
377                 return Nullhe;
378 #ifdef ENV_IS_CASELESS
379             else if (mg_find((SV*)hv,'E')) {
380                 key = SvPV(keysv, klen);
381                 keysv = sv_2mortal(newSVpvn(key,klen));
382                 (void)strupr(SvPVX(keysv));
383                 hash = 0;
384             }
385 #endif
386         }
387     }
388
389     key = SvPV(keysv, klen);
390
391     if (!hash)
392         PERL_HASH(hash, key, klen);
393
394     if (!xhv->xhv_array)
395         Newz(505, xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
396
397     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
398     i = 1;
399
400     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
401         if (HeHASH(entry) != hash)              /* strings can't be equal */
402             continue;
403         if (HeKLEN(entry) != klen)
404             continue;
405         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
406             continue;
407         SvREFCNT_dec(HeVAL(entry));
408         HeVAL(entry) = val;
409         return entry;
410     }
411
412     entry = new_he();
413     if (HvSHAREKEYS(hv))
414         HeKEY_hek(entry) = share_hek(key, klen, hash);
415     else                                       /* gotta do the real thing */
416         HeKEY_hek(entry) = save_hek(key, klen, hash);
417     HeVAL(entry) = val;
418     HeNEXT(entry) = *oentry;
419     *oentry = entry;
420
421     xhv->xhv_keys++;
422     if (i) {                            /* initial entry? */
423         ++xhv->xhv_fill;
424         if (xhv->xhv_keys > xhv->xhv_max)
425             hsplit(hv);
426     }
427
428     return entry;
429 }
430
431 SV *
432 hv_delete(HV *hv, const char *key, U32 klen, I32 flags)
433 {
434     register XPVHV* xhv;
435     register I32 i;
436     register U32 hash;
437     register HE *entry;
438     register HE **oentry;
439     SV **svp;
440     SV *sv;
441
442     if (!hv)
443         return Nullsv;
444     if (SvRMAGICAL(hv)) {
445         bool needs_copy;
446         bool needs_store;
447         hv_magic_check (hv, &needs_copy, &needs_store);
448
449         if (needs_copy && (svp = hv_fetch(hv, key, klen, TRUE))) {
450             sv = *svp;
451             mg_clear(sv);
452             if (!needs_store) {
453                 if (mg_find(sv, 'p')) {
454                     sv_unmagic(sv, 'p');        /* No longer an element */
455                     return sv;
456                 }
457                 return Nullsv;          /* element cannot be deleted */
458             }
459 #ifdef ENV_IS_CASELESS
460             else if (mg_find((SV*)hv,'E')) {
461                 sv = sv_2mortal(newSVpvn(key,klen));
462                 key = strupr(SvPVX(sv));
463             }
464 #endif
465         }
466     }
467     xhv = (XPVHV*)SvANY(hv);
468     if (!xhv->xhv_array)
469         return Nullsv;
470
471     PERL_HASH(hash, key, klen);
472
473     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
474     entry = *oentry;
475     i = 1;
476     for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
477         if (HeHASH(entry) != hash)              /* strings can't be equal */
478             continue;
479         if (HeKLEN(entry) != klen)
480             continue;
481         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
482             continue;
483         *oentry = HeNEXT(entry);
484         if (i && !*oentry)
485             xhv->xhv_fill--;
486         if (flags & G_DISCARD)
487             sv = Nullsv;
488         else
489             sv = sv_mortalcopy(HeVAL(entry));
490         if (entry == xhv->xhv_eiter)
491             HvLAZYDEL_on(hv);
492         else
493             hv_free_ent(hv, entry);
494         --xhv->xhv_keys;
495         return sv;
496     }
497     return Nullsv;
498 }
499
500 SV *
501 hv_delete_ent(HV *hv, SV *keysv, I32 flags, U32 hash)
502 {
503     register XPVHV* xhv;
504     register I32 i;
505     register char *key;
506     STRLEN klen;
507     register HE *entry;
508     register HE **oentry;
509     SV *sv;
510     
511     if (!hv)
512         return Nullsv;
513     if (SvRMAGICAL(hv)) {
514         bool needs_copy;
515         bool needs_store;
516         hv_magic_check (hv, &needs_copy, &needs_store);
517
518         if (needs_copy && (entry = hv_fetch_ent(hv, keysv, TRUE, hash))) {
519             sv = HeVAL(entry);
520             mg_clear(sv);
521             if (!needs_store) {
522                 if (mg_find(sv, 'p')) {
523                     sv_unmagic(sv, 'p');        /* No longer an element */
524                     return sv;
525                 }               
526                 return Nullsv;          /* element cannot be deleted */
527             }
528 #ifdef ENV_IS_CASELESS
529             else if (mg_find((SV*)hv,'E')) {
530                 key = SvPV(keysv, klen);
531                 keysv = sv_2mortal(newSVpvn(key,klen));
532                 (void)strupr(SvPVX(keysv));
533                 hash = 0; 
534             }
535 #endif
536         }
537     }
538     xhv = (XPVHV*)SvANY(hv);
539     if (!xhv->xhv_array)
540         return Nullsv;
541
542     key = SvPV(keysv, klen);
543     
544     if (!hash)
545         PERL_HASH(hash, key, klen);
546
547     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
548     entry = *oentry;
549     i = 1;
550     for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
551         if (HeHASH(entry) != hash)              /* strings can't be equal */
552             continue;
553         if (HeKLEN(entry) != klen)
554             continue;
555         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
556             continue;
557         *oentry = HeNEXT(entry);
558         if (i && !*oentry)
559             xhv->xhv_fill--;
560         if (flags & G_DISCARD)
561             sv = Nullsv;
562         else
563             sv = sv_mortalcopy(HeVAL(entry));
564         if (entry == xhv->xhv_eiter)
565             HvLAZYDEL_on(hv);
566         else
567             hv_free_ent(hv, entry);
568         --xhv->xhv_keys;
569         return sv;
570     }
571     return Nullsv;
572 }
573
574 bool
575 hv_exists(HV *hv, const char *key, U32 klen)
576 {
577     register XPVHV* xhv;
578     register U32 hash;
579     register HE *entry;
580     SV *sv;
581
582     if (!hv)
583         return 0;
584
585     if (SvRMAGICAL(hv)) {
586         if (mg_find((SV*)hv,'P')) {
587             dTHR;
588             sv = sv_newmortal();
589             mg_copy((SV*)hv, sv, key, klen); 
590             magic_existspack(sv, mg_find(sv, 'p'));
591             return SvTRUE(sv);
592         }
593 #ifdef ENV_IS_CASELESS
594         else if (mg_find((SV*)hv,'E')) {
595             sv = sv_2mortal(newSVpvn(key,klen));
596             key = strupr(SvPVX(sv));
597         }
598 #endif
599     }
600
601     xhv = (XPVHV*)SvANY(hv);
602 #ifndef DYNAMIC_ENV_FETCH
603     if (!xhv->xhv_array)
604         return 0; 
605 #endif
606
607     PERL_HASH(hash, key, klen);
608
609 #ifdef DYNAMIC_ENV_FETCH
610     if (!xhv->xhv_array) entry = Null(HE*);
611     else
612 #endif
613     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
614     for (; entry; entry = HeNEXT(entry)) {
615         if (HeHASH(entry) != hash)              /* strings can't be equal */
616             continue;
617         if (HeKLEN(entry) != klen)
618             continue;
619         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
620             continue;
621         return TRUE;
622     }
623 #ifdef DYNAMIC_ENV_FETCH  /* is it out there? */
624     if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME)) {
625         unsigned long len;
626         char *env = PerlEnv_ENVgetenv_len(key,&len);
627         if (env) {
628             sv = newSVpvn(env,len);
629             SvTAINTED_on(sv);
630             (void)hv_store(hv,key,klen,sv,hash);
631             return TRUE;
632         }
633     }
634 #endif
635     return FALSE;
636 }
637
638
639 bool
640 hv_exists_ent(HV *hv, SV *keysv, U32 hash)
641 {
642     register XPVHV* xhv;
643     register char *key;
644     STRLEN klen;
645     register HE *entry;
646     SV *sv;
647
648     if (!hv)
649         return 0;
650
651     if (SvRMAGICAL(hv)) {
652         if (mg_find((SV*)hv,'P')) {
653             dTHR;               /* just for SvTRUE */
654             sv = sv_newmortal();
655             keysv = sv_2mortal(newSVsv(keysv));
656             mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY); 
657             magic_existspack(sv, mg_find(sv, 'p'));
658             return SvTRUE(sv);
659         }
660 #ifdef ENV_IS_CASELESS
661         else if (mg_find((SV*)hv,'E')) {
662             key = SvPV(keysv, klen);
663             keysv = sv_2mortal(newSVpvn(key,klen));
664             (void)strupr(SvPVX(keysv));
665             hash = 0; 
666         }
667 #endif
668     }
669
670     xhv = (XPVHV*)SvANY(hv);
671 #ifndef DYNAMIC_ENV_FETCH
672     if (!xhv->xhv_array)
673         return 0; 
674 #endif
675
676     key = SvPV(keysv, klen);
677     if (!hash)
678         PERL_HASH(hash, key, klen);
679
680 #ifdef DYNAMIC_ENV_FETCH
681     if (!xhv->xhv_array) entry = Null(HE*);
682     else
683 #endif
684     entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
685     for (; entry; entry = HeNEXT(entry)) {
686         if (HeHASH(entry) != hash)              /* strings can't be equal */
687             continue;
688         if (HeKLEN(entry) != klen)
689             continue;
690         if (memNE(HeKEY(entry),key,klen))       /* is this it? */
691             continue;
692         return TRUE;
693     }
694 #ifdef DYNAMIC_ENV_FETCH  /* is it out there? */
695     if (HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME)) {
696         unsigned long len;
697         char *env = PerlEnv_ENVgetenv_len(key,&len);
698         if (env) {
699             sv = newSVpvn(env,len);
700             SvTAINTED_on(sv);
701             (void)hv_store_ent(hv,keysv,sv,hash);
702             return TRUE;
703         }
704     }
705 #endif
706     return FALSE;
707 }
708
709 STATIC void
710 hsplit(HV *hv)
711 {
712     register XPVHV* xhv = (XPVHV*)SvANY(hv);
713     I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
714     register I32 newsize = oldsize * 2;
715     register I32 i;
716     register char *a = xhv->xhv_array;
717     register HE **aep;
718     register HE **bep;
719     register HE *entry;
720     register HE **oentry;
721
722     PL_nomemok = TRUE;
723 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
724     Renew(a, ARRAY_ALLOC_BYTES(newsize), char);
725     if (!a) {
726       PL_nomemok = FALSE;
727       return;
728     }
729 #else
730 #define MALLOC_OVERHEAD 16
731     New(2, a, ARRAY_ALLOC_BYTES(newsize), char);
732     if (!a) {
733       PL_nomemok = FALSE;
734       return;
735     }
736     Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char);
737     if (oldsize >= 64) {
738         offer_nice_chunk(xhv->xhv_array, ARRAY_ALLOC_BYTES(oldsize));
739     }
740     else
741         Safefree(xhv->xhv_array);
742 #endif
743
744     PL_nomemok = FALSE;
745     Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char);     /* zero 2nd half*/
746     xhv->xhv_max = --newsize;
747     xhv->xhv_array = a;
748     aep = (HE**)a;
749
750     for (i=0; i<oldsize; i++,aep++) {
751         if (!*aep)                              /* non-existent */
752             continue;
753         bep = aep+oldsize;
754         for (oentry = aep, entry = *aep; entry; entry = *oentry) {
755             if ((HeHASH(entry) & newsize) != i) {
756                 *oentry = HeNEXT(entry);
757                 HeNEXT(entry) = *bep;
758                 if (!*bep)
759                     xhv->xhv_fill++;
760                 *bep = entry;
761                 continue;
762             }
763             else
764                 oentry = &HeNEXT(entry);
765         }
766         if (!*aep)                              /* everything moved */
767             xhv->xhv_fill--;
768     }
769 }
770
771 void
772 hv_ksplit(HV *hv, IV newmax)
773 {
774     register XPVHV* xhv = (XPVHV*)SvANY(hv);
775     I32 oldsize = (I32) xhv->xhv_max + 1; /* sic(k) */
776     register I32 newsize;
777     register I32 i;
778     register I32 j;
779     register char *a;
780     register HE **aep;
781     register HE *entry;
782     register HE **oentry;
783
784     newsize = (I32) newmax;                     /* possible truncation here */
785     if (newsize != newmax || newmax <= oldsize)
786         return;
787     while ((newsize & (1 + ~newsize)) != newsize) {
788         newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */
789     }
790     if (newsize < newmax)
791         newsize *= 2;
792     if (newsize < newmax)
793         return;                                 /* overflow detection */
794
795     a = xhv->xhv_array;
796     if (a) {
797         PL_nomemok = TRUE;
798 #if defined(STRANGE_MALLOC) || defined(MYMALLOC)
799         Renew(a, ARRAY_ALLOC_BYTES(newsize), char);
800         if (!a) {
801           PL_nomemok = FALSE;
802           return;
803         }
804 #else
805         New(2, a, ARRAY_ALLOC_BYTES(newsize), char);
806         if (!a) {
807           PL_nomemok = FALSE;
808           return;
809         }
810         Copy(xhv->xhv_array, a, oldsize * sizeof(HE*), char);
811         if (oldsize >= 64) {
812             offer_nice_chunk(xhv->xhv_array, ARRAY_ALLOC_BYTES(oldsize));
813         }
814         else
815             Safefree(xhv->xhv_array);
816 #endif
817         PL_nomemok = FALSE;
818         Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/
819     }
820     else {
821         Newz(0, a, ARRAY_ALLOC_BYTES(newsize), char);
822     }
823     xhv->xhv_max = --newsize;
824     xhv->xhv_array = a;
825     if (!xhv->xhv_fill)                         /* skip rest if no entries */
826         return;
827
828     aep = (HE**)a;
829     for (i=0; i<oldsize; i++,aep++) {
830         if (!*aep)                              /* non-existent */
831             continue;
832         for (oentry = aep, entry = *aep; entry; entry = *oentry) {
833             if ((j = (HeHASH(entry) & newsize)) != i) {
834                 j -= i;
835                 *oentry = HeNEXT(entry);
836                 if (!(HeNEXT(entry) = aep[j]))
837                     xhv->xhv_fill++;
838                 aep[j] = entry;
839                 continue;
840             }
841             else
842                 oentry = &HeNEXT(entry);
843         }
844         if (!*aep)                              /* everything moved */
845             xhv->xhv_fill--;
846     }
847 }
848
849 HV *
850 newHV(void)
851 {
852     register HV *hv;
853     register XPVHV* xhv;
854
855     hv = (HV*)NEWSV(502,0);
856     sv_upgrade((SV *)hv, SVt_PVHV);
857     xhv = (XPVHV*)SvANY(hv);
858     SvPOK_off(hv);
859     SvNOK_off(hv);
860 #ifndef NODEFAULT_SHAREKEYS    
861     HvSHAREKEYS_on(hv);         /* key-sharing on by default */
862 #endif    
863     xhv->xhv_max = 7;           /* start with 8 buckets */
864     xhv->xhv_fill = 0;
865     xhv->xhv_pmroot = 0;
866     (void)hv_iterinit(hv);      /* so each() will start off right */
867     return hv;
868 }
869
870 HV *
871 newHVhv(HV *ohv)
872 {
873     register HV *hv;
874     STRLEN hv_max = ohv ? HvMAX(ohv) : 0;
875     STRLEN hv_fill = ohv ? HvFILL(ohv) : 0;
876
877     hv = newHV();
878     while (hv_max && hv_max + 1 >= hv_fill * 2)
879         hv_max = hv_max / 2;    /* Is always 2^n-1 */
880     HvMAX(hv) = hv_max;
881     if (!hv_fill)
882         return hv;
883
884 #if 0
885     if (! SvTIED_mg((SV*)ohv, 'P')) {
886         /* Quick way ???*/
887     } 
888     else 
889 #endif
890     {
891         HE *entry;
892         I32 hv_riter = HvRITER(ohv);    /* current root of iterator */
893         HE *hv_eiter = HvEITER(ohv);    /* current entry of iterator */
894         
895         /* Slow way */
896         hv_iterinit(ohv);
897         while (entry = hv_iternext(ohv)) {
898             hv_store(hv, HeKEY(entry), HeKLEN(entry), 
899                      SvREFCNT_inc(HeVAL(entry)), HeHASH(entry));
900         }
901         HvRITER(ohv) = hv_riter;
902         HvEITER(ohv) = hv_eiter;
903     }
904     
905     return hv;
906 }
907
908 void
909 hv_free_ent(HV *hv, register HE *entry)
910 {
911     SV *val;
912
913     if (!entry)
914         return;
915     val = HeVAL(entry);
916     if (val && isGV(val) && GvCVu(val) && HvNAME(hv))
917         PL_sub_generation++;    /* may be deletion of method from stash */
918     SvREFCNT_dec(val);
919     if (HeKLEN(entry) == HEf_SVKEY) {
920         SvREFCNT_dec(HeKEY_sv(entry));
921         Safefree(HeKEY_hek(entry));
922     }
923     else if (HvSHAREKEYS(hv))
924         unshare_hek(HeKEY_hek(entry));
925     else
926         Safefree(HeKEY_hek(entry));
927     del_he(entry);
928 }
929
930 void
931 hv_delayfree_ent(HV *hv, register HE *entry)
932 {
933     if (!entry)
934         return;
935     if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
936         PL_sub_generation++;    /* may be deletion of method from stash */
937     sv_2mortal(HeVAL(entry));   /* free between statements */
938     if (HeKLEN(entry) == HEf_SVKEY) {
939         sv_2mortal(HeKEY_sv(entry));
940         Safefree(HeKEY_hek(entry));
941     }
942     else if (HvSHAREKEYS(hv))
943         unshare_hek(HeKEY_hek(entry));
944     else
945         Safefree(HeKEY_hek(entry));
946     del_he(entry);
947 }
948
949 void
950 hv_clear(HV *hv)
951 {
952     register XPVHV* xhv;
953     if (!hv)
954         return;
955     xhv = (XPVHV*)SvANY(hv);
956     hfreeentries(hv);
957     xhv->xhv_fill = 0;
958     xhv->xhv_keys = 0;
959     if (xhv->xhv_array)
960         (void)memzero(xhv->xhv_array, (xhv->xhv_max + 1) * sizeof(HE*));
961
962     if (SvRMAGICAL(hv))
963         mg_clear((SV*)hv); 
964 }
965
966 STATIC void
967 hfreeentries(HV *hv)
968 {
969     register HE **array;
970     register HE *entry;
971     register HE *oentry = Null(HE*);
972     I32 riter;
973     I32 max;
974
975     if (!hv)
976         return;
977     if (!HvARRAY(hv))
978         return;
979
980     riter = 0;
981     max = HvMAX(hv);
982     array = HvARRAY(hv);
983     entry = array[0];
984     for (;;) {
985         if (entry) {
986             oentry = entry;
987             entry = HeNEXT(entry);
988             hv_free_ent(hv, oentry);
989         }
990         if (!entry) {
991             if (++riter > max)
992                 break;
993             entry = array[riter];
994         } 
995     }
996     (void)hv_iterinit(hv);
997 }
998
999 void
1000 hv_undef(HV *hv)
1001 {
1002     register XPVHV* xhv;
1003     if (!hv)
1004         return;
1005     xhv = (XPVHV*)SvANY(hv);
1006     hfreeentries(hv);
1007     Safefree(xhv->xhv_array);
1008     if (HvNAME(hv)) {
1009         Safefree(HvNAME(hv));
1010         HvNAME(hv) = 0;
1011     }
1012     xhv->xhv_array = 0;
1013     xhv->xhv_max = 7;           /* it's a normal hash */
1014     xhv->xhv_fill = 0;
1015     xhv->xhv_keys = 0;
1016
1017     if (SvRMAGICAL(hv))
1018         mg_clear((SV*)hv); 
1019 }
1020
1021 I32
1022 hv_iterinit(HV *hv)
1023 {
1024     register XPVHV* xhv;
1025     HE *entry;
1026
1027     if (!hv)
1028         croak("Bad hash");
1029     xhv = (XPVHV*)SvANY(hv);
1030     entry = xhv->xhv_eiter;
1031     if (entry && HvLAZYDEL(hv)) {       /* was deleted earlier? */
1032         HvLAZYDEL_off(hv);
1033         hv_free_ent(hv, entry);
1034     }
1035     xhv->xhv_riter = -1;
1036     xhv->xhv_eiter = Null(HE*);
1037     return xhv->xhv_keys;       /* used to be xhv->xhv_fill before 5.004_65 */
1038 }
1039
1040 HE *
1041 hv_iternext(HV *hv)
1042 {
1043     register XPVHV* xhv;
1044     register HE *entry;
1045     HE *oldentry;
1046     MAGIC* mg;
1047
1048     if (!hv)
1049         croak("Bad hash");
1050     xhv = (XPVHV*)SvANY(hv);
1051     oldentry = entry = xhv->xhv_eiter;
1052
1053     if (mg = SvTIED_mg((SV*)hv, 'P')) {
1054         SV *key = sv_newmortal();
1055         if (entry) {
1056             sv_setsv(key, HeSVKEY_force(entry));
1057             SvREFCNT_dec(HeSVKEY(entry));       /* get rid of previous key */
1058         }
1059         else {
1060             char *k;
1061             HEK *hek;
1062
1063             xhv->xhv_eiter = entry = new_he();  /* one HE per MAGICAL hash */
1064             Zero(entry, 1, HE);
1065             Newz(54, k, HEK_BASESIZE + sizeof(SV*), char);
1066             hek = (HEK*)k;
1067             HeKEY_hek(entry) = hek;
1068             HeKLEN(entry) = HEf_SVKEY;
1069         }
1070         magic_nextpack((SV*) hv,mg,key);
1071         if (SvOK(key)) {
1072             /* force key to stay around until next time */
1073             HeSVKEY_set(entry, SvREFCNT_inc(key));
1074             return entry;               /* beware, hent_val is not set */
1075         }
1076         if (HeVAL(entry))
1077             SvREFCNT_dec(HeVAL(entry));
1078         Safefree(HeKEY_hek(entry));
1079         del_he(entry);
1080         xhv->xhv_eiter = Null(HE*);
1081         return Null(HE*);
1082     }
1083 #ifdef DYNAMIC_ENV_FETCH  /* set up %ENV for iteration */
1084     if (!entry && HvNAME(hv) && strEQ(HvNAME(hv), ENV_HV_NAME))
1085         prime_env_iter();
1086 #endif
1087
1088     if (!xhv->xhv_array)
1089         Newz(506,xhv->xhv_array, ARRAY_ALLOC_BYTES(xhv->xhv_max + 1), char);
1090     if (entry)
1091         entry = HeNEXT(entry);
1092     while (!entry) {
1093         ++xhv->xhv_riter;
1094         if (xhv->xhv_riter > xhv->xhv_max) {
1095             xhv->xhv_riter = -1;
1096             break;
1097         }
1098         entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
1099     }
1100
1101     if (oldentry && HvLAZYDEL(hv)) {            /* was deleted earlier? */
1102         HvLAZYDEL_off(hv);
1103         hv_free_ent(hv, oldentry);
1104     }
1105
1106     xhv->xhv_eiter = entry;
1107     return entry;
1108 }
1109
1110 char *
1111 hv_iterkey(register HE *entry, I32 *retlen)
1112 {
1113     if (HeKLEN(entry) == HEf_SVKEY) {
1114         STRLEN len;
1115         char *p = SvPV(HeKEY_sv(entry), len);
1116         *retlen = len;
1117         return p;
1118     }
1119     else {
1120         *retlen = HeKLEN(entry);
1121         return HeKEY(entry);
1122     }
1123 }
1124
1125 /* unlike hv_iterval(), this always returns a mortal copy of the key */
1126 SV *
1127 hv_iterkeysv(register HE *entry)
1128 {
1129     if (HeKLEN(entry) == HEf_SVKEY)
1130         return sv_mortalcopy(HeKEY_sv(entry));
1131     else
1132         return sv_2mortal(newSVpvn((HeKLEN(entry) ? HeKEY(entry) : ""),
1133                                   HeKLEN(entry)));
1134 }
1135
1136 SV *
1137 hv_iterval(HV *hv, register HE *entry)
1138 {
1139     if (SvRMAGICAL(hv)) {
1140         if (mg_find((SV*)hv,'P')) {
1141             SV* sv = sv_newmortal();
1142             if (HeKLEN(entry) == HEf_SVKEY)
1143                 mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY);
1144             else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
1145             return sv;
1146         }
1147     }
1148     return HeVAL(entry);
1149 }
1150
1151 SV *
1152 hv_iternextsv(HV *hv, char **key, I32 *retlen)
1153 {
1154     HE *he;
1155     if ( (he = hv_iternext(hv)) == NULL)
1156         return NULL;
1157     *key = hv_iterkey(he, retlen);
1158     return hv_iterval(hv, he);
1159 }
1160
1161 void
1162 hv_magic(HV *hv, GV *gv, int how)
1163 {
1164     sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
1165 }
1166
1167 char*   
1168 sharepvn(const char *sv, I32 len, U32 hash)
1169 {
1170     return HEK_KEY(share_hek(sv, len, hash));
1171 }
1172
1173 /* possibly free a shared string if no one has access to it
1174  * len and hash must both be valid for str.
1175  */
1176 void
1177 unsharepvn(const char *str, I32 len, U32 hash)
1178 {
1179     register XPVHV* xhv;
1180     register HE *entry;
1181     register HE **oentry;
1182     register I32 i = 1;
1183     I32 found = 0;
1184     
1185     /* what follows is the moral equivalent of:
1186     if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) {
1187         if (--*Svp == Nullsv)
1188             hv_delete(PL_strtab, str, len, G_DISCARD, hash);
1189     } */
1190     xhv = (XPVHV*)SvANY(PL_strtab);
1191     /* assert(xhv_array != 0) */
1192     LOCK_STRTAB_MUTEX;
1193     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1194     for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
1195         if (HeHASH(entry) != hash)              /* strings can't be equal */
1196             continue;
1197         if (HeKLEN(entry) != len)
1198             continue;
1199         if (memNE(HeKEY(entry),str,len))        /* is this it? */
1200             continue;
1201         found = 1;
1202         if (--HeVAL(entry) == Nullsv) {
1203             *oentry = HeNEXT(entry);
1204             if (i && !*oentry)
1205                 xhv->xhv_fill--;
1206             Safefree(HeKEY_hek(entry));
1207             del_he(entry);
1208             --xhv->xhv_keys;
1209         }
1210         break;
1211     }
1212     UNLOCK_STRTAB_MUTEX;
1213     
1214     if (!found)
1215         warn("Attempt to free non-existent shared string");    
1216 }
1217
1218 /* get a (constant) string ptr from the global string table
1219  * string will get added if it is not already there.
1220  * len and hash must both be valid for str.
1221  */
1222 HEK *
1223 share_hek(const char *str, I32 len, register U32 hash)
1224 {
1225     register XPVHV* xhv;
1226     register HE *entry;
1227     register HE **oentry;
1228     register I32 i = 1;
1229     I32 found = 0;
1230
1231     /* what follows is the moral equivalent of:
1232        
1233     if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE)))
1234         hv_store(PL_strtab, str, len, Nullsv, hash);
1235     */
1236     xhv = (XPVHV*)SvANY(PL_strtab);
1237     /* assert(xhv_array != 0) */
1238     LOCK_STRTAB_MUTEX;
1239     oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
1240     for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
1241         if (HeHASH(entry) != hash)              /* strings can't be equal */
1242             continue;
1243         if (HeKLEN(entry) != len)
1244             continue;
1245         if (memNE(HeKEY(entry),str,len))        /* is this it? */
1246             continue;
1247         found = 1;
1248         break;
1249     }
1250     if (!found) {
1251         entry = new_he();
1252         HeKEY_hek(entry) = save_hek(str, len, hash);
1253         HeVAL(entry) = Nullsv;
1254         HeNEXT(entry) = *oentry;
1255         *oentry = entry;
1256         xhv->xhv_keys++;
1257         if (i) {                                /* initial entry? */
1258             ++xhv->xhv_fill;
1259             if (xhv->xhv_keys > xhv->xhv_max)
1260                 hsplit(PL_strtab);
1261         }
1262     }
1263
1264     ++HeVAL(entry);                             /* use value slot as REFCNT */
1265     UNLOCK_STRTAB_MUTEX;
1266     return HeKEY_hek(entry);
1267 }
1268
1269
1270