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