source: trunk/third/perl/hv.c @ 14545

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