X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=hv.c;h=02a0955ed3e744e8debe06744b55ff68ca579cc3;hb=5319f5cda006254c54e21c2a144c8f88da330a7f;hp=d9f640bb7ef96d6ab4abad9597dffb6b777d0cae;hpb=19692e8d256164f96817d6df6ecee26c3cda4ae9;p=p5sagit%2Fp5-mst-13.2.git diff --git a/hv.c b/hv.c index d9f640b..02a0955 100644 --- a/hv.c +++ b/hv.c @@ -121,10 +121,10 @@ Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param) #endif /* USE_ITHREADS */ static void -Perl_hv_notallowed(pTHX_ int flags, const char *key, I32 klen, - const char *msg) +S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen, + const char *msg) { - SV *sv = sv_newmortal(); + SV *sv = sv_newmortal(), *esv = sv_newmortal(); if (!(flags & HVhek_FREEKEY)) { sv_setpvn(sv, key, klen); } @@ -136,7 +136,8 @@ Perl_hv_notallowed(pTHX_ int flags, const char *key, I32 klen, if (flags & HVhek_UTF8) { SvUTF8_on(sv); } - Perl_croak(aTHX_ msg, sv); + Perl_sv_setpvf(aTHX_ esv, "Attempt to %s a restricted hash", msg); + Perl_croak(aTHX_ SvPVX(esv), sv); } /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot @@ -298,16 +299,16 @@ S_hv_fetch_flags(pTHX_ HV *hv, const char *key, I32 klen, I32 lval, int flags) if (env) { sv = newSVpvn(env,len); SvTAINTED_on(sv); - if (key != keysave) + if (flags & HVhek_FREEKEY) Safefree(key); return hv_store(hv,key,klen,sv,hash); } } #endif if (!entry && SvREADONLY(hv)) { - Perl_hv_notallowed(aTHX_ flags, key, klen, - "Attempt to access disallowed key '%"SVf"' in a fixed hash" - ); + S_hv_notallowed(aTHX_ flags, key, klen, + "access disallowed key '%"SVf"' in" + ); } if (lval) { /* gonna assign to this, so it better be there */ sv = NEWSV(61,0); @@ -458,9 +459,9 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash) } #endif if (!entry && SvREADONLY(hv)) { - Perl_hv_notallowed(aTHX_ flags, key, klen, - "Attempt to access disallowed key '%"SVf"' in a fixed hash" - ); + S_hv_notallowed(aTHX_ flags, key, klen, + "access disallowed key '%"SVf"' in" + ); } if (flags & HVhek_FREEKEY) Safefree(key); @@ -515,6 +516,11 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash) const char *keysave = key; int flags = 0; + if (klen < 0) { + klen = -klen; + is_utf8 = TRUE; + } + if (is_utf8) { STRLEN tmplen = klen; /* Just casting the &klen to (STRLEN) won't work well @@ -535,7 +541,7 @@ Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash) } SV** -S_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val, +Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val, register U32 hash, int flags) { register XPVHV* xhv; @@ -596,7 +602,13 @@ S_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val, xhv->xhv_placeholders--; /* yes, can store into placeholder slot */ else SvREFCNT_dec(HeVAL(entry)); - HeVAL(entry) = val; + if (flags & HVhek_PLACEHOLD) { + /* We have been requested to insert a placeholder. Currently + only Storable is allowed to do this. */ + xhv->xhv_placeholders++; + HeVAL(entry) = &PL_sv_undef; + } else + HeVAL(entry) = val; if (HeKFLAGS(entry) != flags) { /* We match if HVhek_UTF8 bit in our flags and hash key's match. @@ -621,9 +633,9 @@ S_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val, } if (SvREADONLY(hv)) { - Perl_hv_notallowed(aTHX_ flags, key, klen, - "Attempt to access disallowed key '%"SVf"' to a fixed hash" - ); + S_hv_notallowed(aTHX_ flags, key, klen, + "access disallowed key '%"SVf"' to" + ); } entry = new_HE(); @@ -633,7 +645,13 @@ S_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val, HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags); else /* gotta do the real thing */ HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags); - HeVAL(entry) = val; + if (flags & HVhek_PLACEHOLD) { + /* We have been requested to insert a placeholder. Currently + only Storable is allowed to do this. */ + xhv->xhv_placeholders++; + HeVAL(entry) = &PL_sv_undef; + } else + HeVAL(entry) = val; HeNEXT(entry) = *oentry; *oentry = entry; @@ -768,9 +786,9 @@ Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash) } if (SvREADONLY(hv)) { - Perl_hv_notallowed(aTHX_ flags, key, klen, - "Attempt to access disallowed key '%"SVf"' to a fixed hash" - ); + S_hv_notallowed(aTHX_ flags, key, klen, + "access disallowed key '%"SVf"' to" + ); } entry = new_HE(); @@ -903,9 +921,9 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags) } } else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) { - Perl_hv_notallowed(aTHX_ k_flags, key, klen, - "Attempt to delete readonly key '%"SVf"' from a fixed hash" - ); + S_hv_notallowed(aTHX_ k_flags, key, klen, + "delete readonly key '%"SVf"' from" + ); } if (flags & G_DISCARD) @@ -941,9 +959,9 @@ Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen, I32 flags) return sv; } if (SvREADONLY(hv)) { - Perl_hv_notallowed(aTHX_ k_flags, key, klen, - "Attempt to access disallowed key '%"SVf"' from a fixed hash" - ); + S_hv_notallowed(aTHX_ k_flags, key, klen, + "access disallowed key '%"SVf"' from" + ); } if (k_flags & HVhek_FREEKEY) @@ -1059,9 +1077,9 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash) return Nullsv; } else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) { - Perl_hv_notallowed(aTHX_ k_flags, key, klen, - "Attempt to delete readonly key '%"SVf"' from a fixed hash" - ); + S_hv_notallowed(aTHX_ k_flags, key, klen, + "delete readonly key '%"SVf"' from" + ); } if (flags & G_DISCARD) @@ -1097,9 +1115,9 @@ Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash) return sv; } if (SvREADONLY(hv)) { - Perl_hv_notallowed(aTHX_ k_flags, key, klen, - "Attempt to delete disallowed key '%"SVf"' from a fixed hash" - ); + S_hv_notallowed(aTHX_ k_flags, key, klen, + "delete disallowed key '%"SVf"' from" + ); } if (k_flags & HVhek_FREEKEY) @@ -1550,7 +1568,7 @@ Perl_newHVhv(pTHX_ HV *ohv) HvMAX(hv) = hv_max; hv_iterinit(ohv); - while ((entry = hv_iternext(ohv))) { + while ((entry = hv_iternext_flags(ohv, 0))) { hv_store_flags(hv, HeKEY(entry), HeKLEN(entry), newSVsv(HeVAL(entry)), HeHASH(entry), HeKFLAGS(entry)); @@ -1619,7 +1637,7 @@ Perl_hv_clear(pTHX_ HV *hv) return; if(SvREADONLY(hv)) { - Perl_croak(aTHX_ "Attempt to clear a fixed hash"); + Perl_croak(aTHX_ "Attempt to clear a restricted hash"); } xhv = (XPVHV*)SvANY(hv); @@ -1712,6 +1730,7 @@ NOTE: Before version 5.004_65, C used to return the number of hash buckets that happen to be in use. If you still need that esoteric value, you can get it through the macro C. + =cut */ @@ -1734,18 +1753,47 @@ Perl_hv_iterinit(pTHX_ HV *hv) /* used to be xhv->xhv_fill before 5.004_65 */ return XHvTOTALKEYS(xhv); } - /* =for apidoc hv_iternext Returns entries from a hash iterator. See C. +You may call C or C on the hash entry that the +iterator currently points to, without losing your place or invalidating your +iterator. Note that in this case the current entry is deleted from the hash +with your iterator holding the last reference to it. Your iterator is flagged +to free the entry on the next call to C, so you must not discard +your iterator immediately else the entry will leak - call C to +trigger the resource deallocation. + =cut */ HE * Perl_hv_iternext(pTHX_ HV *hv) { + return hv_iternext_flags(hv, 0); +} + +/* +=for apidoc hv_iternext_flags + +Returns entries from a hash iterator. See C and C. +The C value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is +set the placeholders keys (for restricted hashes) will be returned in addition +to normal keys. By default placeholders are automatically skipped over. +Currently a placeholder is implemented with a value that is literally +<&Perl_sv_undef> (a regular C value is a normal read-write SV for which +C is false). Note that the implementation of placeholders and +restricted hashes may change, and the implementation currently is +insufficiently abstracted for any change to be tidy. + +=cut +*/ + +HE * +Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) +{ register XPVHV* xhv; register HE *entry; HE *oldentry; @@ -1799,12 +1847,14 @@ Perl_hv_iternext(pTHX_ HV *hv) if (entry) { entry = HeNEXT(entry); - /* - * Skip past any placeholders -- don't want to include them in - * any iteration. - */ - while (entry && HeVAL(entry) == &PL_sv_undef) { - entry = HeNEXT(entry); + if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) { + /* + * Skip past any placeholders -- don't want to include them in + * any iteration. + */ + while (entry && HeVAL(entry) == &PL_sv_undef) { + entry = HeNEXT(entry); + } } } while (!entry) { @@ -1816,10 +1866,11 @@ Perl_hv_iternext(pTHX_ HV *hv) /* entry = (HvARRAY(hv))[HvRITER(hv)]; */ entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter]; - /* if we have an entry, but it's a placeholder, don't count it */ - if (entry && HeVAL(entry) == &PL_sv_undef) - entry = 0; - + if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) { + /* if we have an entry, but it's a placeholder, don't count it */ + if (entry && HeVAL(entry) == &PL_sv_undef) + entry = 0; + } } if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */ @@ -1879,9 +1930,9 @@ Perl_hv_iterkeysv(pTHX_ register HE *entry) Andreas would like keys he put in as utf8 to come back as utf8 */ STRLEN utf8_len = HEK_LEN(hek); - U8 *as_utf8 = bytes_to_utf8 (HEK_KEY(hek), &utf8_len); + U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len); - sv = newSVpvn (as_utf8, utf8_len); + sv = newSVpvn ((char*)as_utf8, utf8_len); SvUTF8_on (sv); } else { sv = newSVpvn_share(HEK_KEY(hek), @@ -1930,7 +1981,7 @@ SV * Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen) { HE *he; - if ( (he = hv_iternext(hv)) == NULL) + if ( (he = hv_iternext_flags(hv, 0)) == NULL) return NULL; *key = hv_iterkey(he, retlen); return hv_iterval(hv, he);