X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=hv.c;h=158b0b652b032c97ba4f1530dc871024f8ce7f63;hb=7c04078ea21d9035bc412dbd7b8edf35773a2c43;hp=da1f48786979af672df447d9cbd1f30e664d78aa;hpb=b2c64049f4c2cbaedee1ae9b13dab8adb5b210b3;p=p5sagit%2Fp5-mst-13.2.git diff --git a/hv.c b/hv.c index da1f487..158b0b6 100644 --- a/hv.c +++ b/hv.c @@ -80,6 +80,7 @@ S_more_he(pTHX) STATIC HEK * S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags) { + int flags_masked = flags & HVhek_MASK; char *k; register HEK *hek; @@ -89,7 +90,10 @@ S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags) HEK_KEY(hek)[len] = 0; HEK_LEN(hek) = len; HEK_HASH(hek) = hash; - HEK_FLAGS(hek) = (unsigned char)flags; + HEK_FLAGS(hek) = (unsigned char)flags_masked; + + if (flags & HVhek_FREEKEY) + Safefree(str); return hek; } @@ -168,6 +172,126 @@ S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen, /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot * contains an SV* */ +#define HV_FETCH_ISSTORE 0x01 +#define HV_FETCH_ISEXISTS 0x02 +#define HV_FETCH_LVALUE 0x04 +#define HV_FETCH_JUST_SV 0x08 + +/* +=for apidoc hv_store + +Stores an SV in a hash. The hash key is specified as C and C is +the length of the key. The C parameter is the precomputed hash +value; if it is zero then Perl will compute it. The return value will be +NULL if the operation failed or if the value did not need to be actually +stored within the hash (as in the case of tied hashes). Otherwise it can +be dereferenced to get the original C. Note that the caller is +responsible for suitably incrementing the reference count of C before +the call, and decrementing it if the function returned NULL. Effectively +a successful hv_store takes ownership of one reference to C. This is +usually what you want; a newly created SV has a reference count of one, so +if all your code does is create SVs then store them in a hash, hv_store +will own the only reference to the new SV, and your code doesn't need to do +anything further to tidy up. hv_store is not implemented as a call to +hv_store_ent, and does not create a temporary SV for the key, so if your +key data is not already in SV form then use hv_store in preference to +hv_store_ent. + +See L for more +information on how to use this function on tied hashes. + +=cut +*/ + +SV** +Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen_i32, SV *val, U32 hash) +{ + HE *hek; + STRLEN klen; + int flags; + + if (klen_i32 < 0) { + klen = -klen_i32; + flags = HVhek_UTF8; + } else { + klen = klen_i32; + flags = 0; + } + hek = hv_fetch_common (hv, NULL, key, klen, flags, + (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, 0); + return hek ? &HeVAL(hek) : NULL; +} + +SV** +Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val, + register U32 hash, int flags) +{ + HE *hek = hv_fetch_common (hv, NULL, key, klen, flags, + (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash); + return hek ? &HeVAL(hek) : NULL; +} + +/* +=for apidoc hv_store_ent + +Stores C in a hash. The hash key is specified as C. The C +parameter is the precomputed hash value; if it is zero then Perl will +compute it. The return value is the new hash entry so created. It will be +NULL if the operation failed or if the value did not need to be actually +stored within the hash (as in the case of tied hashes). Otherwise the +contents of the return value can be accessed using the C macros +described here. Note that the caller is responsible for suitably +incrementing the reference count of C before the call, and +decrementing it if the function returned NULL. Effectively a successful +hv_store_ent takes ownership of one reference to C. This is +usually what you want; a newly created SV has a reference count of one, so +if all your code does is create SVs then store them in a hash, hv_store +will own the only reference to the new SV, and your code doesn't need to do +anything further to tidy up. Note that hv_store_ent only reads the C; +unlike C it does not take ownership of it, so maintaining the correct +reference count on C is entirely the caller's responsibility. hv_store +is not implemented as a call to hv_store_ent, and does not create a temporary +SV for the key, so if your key data is not already in SV form then use +hv_store in preference to hv_store_ent. + +See L for more +information on how to use this function on tied hashes. + +=cut +*/ + +HE * +Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash) +{ + return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISSTORE, val, hash); +} + +/* +=for apidoc hv_exists + +Returns a boolean indicating whether the specified hash key exists. The +C is the length of the key. + +=cut +*/ + +bool +Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen_i32) +{ + STRLEN klen; + int flags; + + if (klen_i32 < 0) { + klen = -klen_i32; + flags = HVhek_UTF8; + } else { + klen = klen_i32; + flags = 0; + } + return hv_fetch_common(hv, NULL, key, klen, flags, HV_FETCH_ISEXISTS, 0, 0) + ? TRUE : FALSE; +} + /* =for apidoc hv_fetch @@ -182,11 +306,6 @@ information on how to use this function on tied hashes. =cut */ -#define HV_FETCH_ISSTORE 0x01 -#define HV_FETCH_ISEXISTS 0x02 -#define HV_FETCH_LVALUE 0x04 -#define HV_FETCH_JUST_SV 0x08 - SV** Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval) { @@ -207,6 +326,23 @@ Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval) return hek ? &HeVAL(hek) : NULL; } +/* +=for apidoc hv_exists_ent + +Returns a boolean indicating whether the specified hash key exists. C +can be a valid precomputed hash value, or 0 to ask for it to be +computed. + +=cut +*/ + +bool +Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash) +{ + return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISEXISTS, 0, hash) + ? TRUE : FALSE; +} + /* returns an HE * structure with the all fields set */ /* note that hent_val will be a mortal sv for MAGICAL hashes */ /* @@ -249,6 +385,8 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, return 0; if (keysv) { + if (flags & HVhek_FREEKEY) + Safefree(key); key = SvPV(keysv, klen); flags = 0; is_utf8 = (SvUTF8(keysv) != 0); @@ -305,25 +443,28 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, U32 i; for (i = 0; i < klen; ++i) if (isLOWER(key[i])) { - const char *keysave = key; - /* Will need to free this, so set FREEKEY flag - on call to hv_fetch_common. */ - key = savepvn(key,klen); - key = (const char*)strupr((char*)key); - - if (flags & HVhek_FREEKEY) - Safefree(keysave); - - /* This isn't strictly the same as the old hv_fetch - magic, which made a call to hv_fetch, followed - by a call to hv_store if that failed and lvalue - was true. - Which I believe could have been done by simply - passing the lvalue through to the first hv_fetch. - So I will do that here. */ - return hv_fetch_common(hv, Nullsv, key, klen, - HVhek_FREEKEY, - action, Nullsv, 0); + /* Would be nice if we had a routine to do the + copy and upercase in a single pass through. */ + char *nkey = strupr(savepvn(key,klen)); + /* Note that this fetch is for nkey (the uppercased + key) whereas the store is for key (the original) */ + entry = hv_fetch_common(hv, Nullsv, nkey, klen, + HVhek_FREEKEY, /* free nkey */ + 0 /* non-LVAL fetch */, + Nullsv /* no value */, + 0 /* compute hash */); + if (!entry && (action & HV_FETCH_LVALUE)) { + /* This call will free key if necessary. + Do it this way to encourage compiler to tail + call optimise. */ + entry = hv_fetch_common(hv, keysv, key, klen, + flags, HV_FETCH_ISSTORE, + NEWSV(61,0), hash); + } else { + if (flags & HVhek_FREEKEY) + Safefree(key); + } + return entry; } } #endif @@ -479,9 +620,8 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, else #endif { - /* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */ - oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; - entry = *oentry; + /* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */ + entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; } for (; entry; ++n_links, entry = HeNEXT(entry)) { if (HeHASH(entry) != hash) /* strings can't be equal */ @@ -551,13 +691,14 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, return entry; } #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */ - if (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) { + if (!(action & HV_FETCH_ISSTORE) + && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) { unsigned long len; char *env = PerlEnv_ENVgetenv_len(key,&len); if (env) { sv = newSVpvn(env,len); SvTAINTED_on(sv); - return hv_fetch_common(hv,keysv,key,keylen,HV_FETCH_ISSTORE,sv, + return hv_fetch_common(hv,keysv,key,klen,flags,HV_FETCH_ISSTORE,sv, hash); } } @@ -590,16 +731,17 @@ S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, /* Welcome to hv_store... */ - if (!oentry) { + if (!xhv->xhv_array) { /* Not sure if we can get here. I think the only case of oentry being NULL is for %ENV with dynamic env fetch. But that should disappear with magic in the previous code. */ Newz(503, xhv->xhv_array /* HvARRAY(hv) */, PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */), char); - oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; } + oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; + entry = new_HE(); /* share_hek_flags will do the free for us. This might be considered bad API design. */ @@ -653,92 +795,32 @@ S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store) } /* -=for apidoc hv_store - -Stores an SV in a hash. The hash key is specified as C and C is -the length of the key. The C parameter is the precomputed hash -value; if it is zero then Perl will compute it. The return value will be -NULL if the operation failed or if the value did not need to be actually -stored within the hash (as in the case of tied hashes). Otherwise it can -be dereferenced to get the original C. Note that the caller is -responsible for suitably incrementing the reference count of C before -the call, and decrementing it if the function returned NULL. Effectively -a successful hv_store takes ownership of one reference to C. This is -usually what you want; a newly created SV has a reference count of one, so -if all your code does is create SVs then store them in a hash, hv_store -will own the only reference to the new SV, and your code doesn't need to do -anything further to tidy up. hv_store is not implemented as a call to -hv_store_ent, and does not create a temporary SV for the key, so if your -key data is not already in SV form then use hv_store in preference to -hv_store_ent. - -See L for more -information on how to use this function on tied hashes. - -=cut -*/ - -SV** -Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen_i32, SV *val, U32 hash) -{ - HE *hek; - STRLEN klen; - int flags; - - if (klen_i32 < 0) { - klen = -klen_i32; - flags = HVhek_UTF8; - } else { - klen = klen_i32; - flags = 0; - } - hek = hv_fetch_common (hv, NULL, key, klen, flags, - (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, 0); - return hek ? &HeVAL(hek) : NULL; -} - -SV** -Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val, - register U32 hash, int flags) -{ - HE *hek = hv_fetch_common (hv, NULL, key, klen, flags, - (HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash); - return hek ? &HeVAL(hek) : NULL; -} - -/* -=for apidoc hv_store_ent - -Stores C in a hash. The hash key is specified as C. The C -parameter is the precomputed hash value; if it is zero then Perl will -compute it. The return value is the new hash entry so created. It will be -NULL if the operation failed or if the value did not need to be actually -stored within the hash (as in the case of tied hashes). Otherwise the -contents of the return value can be accessed using the C macros -described here. Note that the caller is responsible for suitably -incrementing the reference count of C before the call, and -decrementing it if the function returned NULL. Effectively a successful -hv_store_ent takes ownership of one reference to C. This is -usually what you want; a newly created SV has a reference count of one, so -if all your code does is create SVs then store them in a hash, hv_store -will own the only reference to the new SV, and your code doesn't need to do -anything further to tidy up. Note that hv_store_ent only reads the C; -unlike C it does not take ownership of it, so maintaining the correct -reference count on C is entirely the caller's responsibility. hv_store -is not implemented as a call to hv_store_ent, and does not create a temporary -SV for the key, so if your key data is not already in SV form then use -hv_store in preference to hv_store_ent. +=for apidoc hv_scalar -See L for more -information on how to use this function on tied hashes. +Evaluates the hash in scalar context and returns the result. Handles magic when the hash is tied. =cut */ -HE * -Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash) +SV * +Perl_hv_scalar(pTHX_ HV *hv) { - return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISSTORE, val, hash); + MAGIC *mg; + SV *sv; + + if ((SvRMAGICAL(hv) && (mg = mg_find((SV*)hv, PERL_MAGIC_tied)))) { + sv = magic_scalarpack(hv, mg); + return sv; + } + + sv = sv_newmortal(); + if (HvFILL((HV*)hv)) + Perl_sv_setpvf(aTHX_ sv, "%ld/%ld", + (long)HvFILL(hv), (long)HvMAX(hv) + 1); + else + sv_setiv(sv, 0); + + return sv; } /* @@ -800,6 +882,8 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, return Nullsv; if (keysv) { + if (k_flags & HVhek_FREEKEY) + Safefree(key); key = SvPV(keysv, klen); k_flags = 0; is_utf8 = (SvUTF8(keysv) != 0); @@ -829,22 +913,20 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } return Nullsv; /* element cannot be deleted */ } - } #ifdef ENV_IS_CASELESS - else if (mg_find((SV*)hv, PERL_MAGIC_env)) { - /* XXX This code isn't UTF8 clean. */ - keysv = sv_2mortal(newSVpvn(key,klen)); - key = strupr(SvPVX(keysv)); - - if (k_flags & HVhek_FREEKEY) { - Safefree(keysave); + else if (mg_find((SV*)hv, PERL_MAGIC_env)) { + /* XXX This code isn't UTF8 clean. */ + keysv = sv_2mortal(newSVpvn(key,klen)); + if (k_flags & HVhek_FREEKEY) { + Safefree(key); + } + key = strupr(SvPVX(keysv)); + is_utf8 = 0; + k_flags = 0; + hash = 0; } - - is_utf8 = 0; - k_flags = 0; - hash = 0; - } #endif + } } } xhv = (XPVHV*)SvANY(hv); @@ -878,7 +960,6 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, } else { PERL_HASH(hash, key, klen); } - PERL_HASH(hash, key, klen); } masked_flags = (k_flags & HVhek_MASK); @@ -968,49 +1049,6 @@ S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, return Nullsv; } -/* -=for apidoc hv_exists - -Returns a boolean indicating whether the specified hash key exists. The -C is the length of the key. - -=cut -*/ - -bool -Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen_i32) -{ - STRLEN klen; - int flags; - - if (klen_i32 < 0) { - klen = -klen_i32; - flags = HVhek_UTF8; - } else { - klen = klen_i32; - flags = 0; - } - return hv_fetch_common(hv, NULL, key, klen, flags, HV_FETCH_ISEXISTS, 0, 0) - ? TRUE : FALSE; -} - -/* -=for apidoc hv_exists_ent - -Returns a boolean indicating whether the specified hash key exists. C -can be a valid precomputed hash value, or 0 to ask for it to be -computed. - -=cut -*/ - -bool -Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash) -{ - return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISEXISTS, 0, hash) - ? TRUE : FALSE; -} - STATIC void S_hsplit(pTHX_ HV *hv) { @@ -1422,7 +1460,7 @@ Perl_hv_clear(pTHX_ HV *hv) } } } - return; + goto reset; } hfreeentries(hv); @@ -1436,6 +1474,8 @@ Perl_hv_clear(pTHX_ HV *hv) HvHASKFLAGS_off(hv); HvREHASH_off(hv); + reset: + HvEITER(hv) = NULL; } /* @@ -2046,7 +2086,7 @@ S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags) } if (!found) { entry = new_HE(); - HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags); + HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags_masked); HeVAL(entry) = Nullsv; HeNEXT(entry) = *oentry; *oentry = entry;