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