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