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