/* hv.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
HE* he;
HE* heend;
- he = (HE*) Perl_get_arena(aTHX_ PERL_ARENA_SIZE);
+ he = (HE*) Perl_get_arena(aTHX_ PERL_ARENA_SIZE, HE_SVSLOT);
heend = &he[PERL_ARENA_SIZE / sizeof(HE) - 1];
PL_body_roots[HE_SVSLOT] = he;
HE* he;
void ** const root = &PL_body_roots[HE_SVSLOT];
- LOCK_SV_MUTEX;
if (!*root)
S_more_he(aTHX);
he = (HE*) *root;
assert(he);
*root = HeNEXT(he);
- UNLOCK_SV_MUTEX;
return he;
}
#define new_HE() new_he()
#define del_HE(p) \
STMT_START { \
- LOCK_SV_MUTEX; \
HeNEXT(p) = (HE*)(PL_body_roots[HE_SVSLOT]); \
PL_body_roots[HE_SVSLOT] = p; \
- UNLOCK_SV_MUTEX; \
} STMT_END
if (flags & HVhek_UTF8) {
SvUTF8_on(sv);
}
- Perl_croak(aTHX_ msg, sv);
+ Perl_croak(aTHX_ msg, SVfARG(sv));
}
/* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
xhv = (XPVHV*)SvANY(hv);
if (SvMAGICAL(hv)) {
if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS))) {
- MAGIC *regdata = NULL;
- if (( regdata = mg_find((SV*)hv, PERL_MAGIC_regdata_names)) ||
- mg_find((SV*)hv, PERL_MAGIC_tied) ||
- SvGMAGICAL((SV*)hv))
+ if ( mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv))
{
/* XXX should be able to skimp on the HE/HEK here when
HV_FETCH_JUST_SV is true. */
} else {
keysv = newSVsv(keysv);
}
- if (regdata) {
- sv = Perl_reg_named_buff_sv(aTHX_ keysv);
- if (!sv)
- sv = sv_newmortal();
- } else {
- sv = sv_newmortal();
- mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY);
- }
+ sv = sv_newmortal();
+ mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY);
/* grab a fake HE/HEK pair from the pool or make a new one */
entry = PL_hv_fetch_ent_mh;
int was_shared;
/*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n",
- hv, (int) oldsize);*/
+ (void*)hv, (int) oldsize);*/
if (HvPLACEHOLDERS_get(hv) && !SvREADONLY(hv)) {
/* Can make this clear any placeholders first for non-restricted hashes,
}
/* Awooga. Awooga. Pathological data. */
- /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", hv,
+ /*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", (void*)hv,
longest_chain, HvTOTALKEYS(hv), HvFILL(hv), 1+HvMAX(hv));*/
++newsize;
Perl_newHV(pTHX)
{
register XPVHV* xhv;
- HV * const hv = (HV*)newSV(0);
-
- sv_upgrade((SV *)hv, SVt_PVHV);
+ HV * const hv = (HV*)newSV_type(SVt_PVHV);
xhv = (XPVHV*)SvANY(hv);
- SvPOK_off(hv);
- SvNOK_off(hv);
+ assert(!SvOK(hv));
#ifndef NODEFAULT_SHAREKEYS
HvSHAREKEYS_on(hv); /* key-sharing on by default */
#endif
S_hfreeentries(pTHX_ HV *hv)
{
/* This is the array that we're going to restore */
- HE **orig_array;
+ HE **const orig_array = HvARRAY(hv);
HEK *name;
int attempts = 100;
- if (!HvARRAY(hv))
+ if (!orig_array)
return;
if (SvOOK(hv)) {
name = NULL;
}
- orig_array = HvARRAY(hv);
/* orig_array remains unchanged throughout the loop. If after freeing all
the entries it turns out that one of the little blighters has triggered
an action that has caused HvARRAY to be re-allocated, then we set
} else {
hv_auxinit(hv);
}
- if ( SvRMAGICAL(hv) ) {
- MAGIC *mg = mg_find((SV*)hv, PERL_MAGIC_regdata_names);
- if ( mg ) {
- if (PL_curpm) {
- const REGEXP * const rx = PM_GETRE(PL_curpm);
- if (rx && rx->paren_names) {
- (void)hv_iterinit(rx->paren_names);
- }
- }
- }
- }
+
/* used to be xhv->xhv_fill before 5.004_65 */
return HvTOTALKEYS(hv);
}
oldentry = entry = iter->xhv_eiter; /* HvEITER(hv) */
if (SvMAGICAL(hv) && SvRMAGICAL(hv)) {
- if ( ( mg = mg_find((SV*)hv, PERL_MAGIC_regdata_names) ) ) {
- SV * key;
- SV *val = NULL;
- REGEXP * rx;
- if (!PL_curpm)
- return NULL;
- rx = PM_GETRE(PL_curpm);
- if (rx && rx->paren_names) {
- hv = rx->paren_names;
- } else {
- return NULL;
- }
-
- key = sv_newmortal();
- if (entry) {
- sv_setsv(key, HeSVKEY_force(entry));
- SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
- }
- else {
- char *k;
- HEK *hek;
-
- /* one HE per MAGICAL hash */
- iter->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */
- Zero(entry, 1, HE);
- Newxz(k, HEK_BASESIZE + sizeof(SV*), char);
- hek = (HEK*)k;
- HeKEY_hek(entry) = hek;
- HeKLEN(entry) = HEf_SVKEY;
- }
- {
- while (!val) {
- HE *temphe = hv_iternext_flags(hv,flags);
- if (temphe) {
- IV i;
- IV parno = 0;
- SV* sv_dat = HeVAL(temphe);
- I32 *nums = (I32*)SvPVX(sv_dat);
- for ( i = 0; i < SvIVX(sv_dat); i++ ) {
- if ((I32)(rx->lastcloseparen) >= nums[i] &&
- rx->startp[nums[i]] != -1 &&
- rx->endp[nums[i]] != -1)
- {
- parno = nums[i];
- break;
- }
- }
- if (parno) {
- GV *gv_paren;
- STRLEN len;
- SV *sv = sv_newmortal();
- const char* pvkey = HePV(temphe, len);
-
- Perl_sv_setpvf(aTHX_ sv, "%"IVdf,(IV)parno);
- gv_paren = Perl_gv_fetchsv(aTHX_ sv, GV_ADD, SVt_PVGV);
- Perl_sv_setpvn(aTHX_ key, pvkey, len);
- val = GvSVn(gv_paren);
- }
- } else {
- break;
- }
- }
- }
- if (val && SvOK(key)) {
- /* force key to stay around until next time */
- HeSVKEY_set(entry, SvREFCNT_inc_simple_NN(key));
- HeVAL(entry) = SvREFCNT_inc_simple_NN(val);
- return entry; /* beware, hent_val is not set */
- }
- if (HeVAL(entry))
- SvREFCNT_dec(HeVAL(entry));
- Safefree(HeKEY_hek(entry));
- del_HE(entry);
- iter->xhv_eiter = NULL; /* HvEITER(hv) = NULL */
- return NULL;
- }
- else if ( ( mg = mg_find((SV*)hv, PERL_MAGIC_tied) ) ) {
+ if ( ( mg = mg_find((SV*)hv, PERL_MAGIC_tied) ) ) {
SV * const key = sv_newmortal();
if (entry) {
sv_setsv(key, HeSVKEY_force(entry));
}
/*if (HvREHASH(hv) && entry && !HeKREHASH(entry))
- PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", hv, entry);*/
+ PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", (void*)hv, (void*)entry);*/
iter->xhv_eiter = entry; /* HvEITER(hv) = entry */
return entry;
void
Perl_unshare_hek(pTHX_ HEK *hek)
{
+ assert(hek);
unshare_hek_or_pvn(hek, NULL, 0, 0);
}
/* else we don't need to add magic to record 0 placeholders. */
}
-SV *
+STATIC SV *
S_refcounted_he_value(pTHX_ const struct refcounted_he *he)
{
dVAR;
value = &PL_sv_placeholder;
break;
case HVrhek_IV:
- value = (he->refcounted_he_data[0] & HVrhek_UV)
- ? newSVuv(he->refcounted_he_val.refcounted_he_u_iv)
- : newSViv(he->refcounted_he_val.refcounted_he_u_uv);
+ value = newSViv(he->refcounted_he_val.refcounted_he_u_iv);
+ break;
+ case HVrhek_UV:
+ value = newSVuv(he->refcounted_he_val.refcounted_he_u_uv);
break;
case HVrhek_PV:
+ case HVrhek_PV_UTF8:
/* Create a string SV that directly points to the bytes in our
structure. */
- value = newSV(0);
- sv_upgrade(value, SVt_PV);
+ value = newSV_type(SVt_PV);
SvPV_set(value, (char *) he->refcounted_he_data + 1);
SvCUR_set(value, he->refcounted_he_val.refcounted_he_u_len);
/* This stops anything trying to free it */
SvLEN_set(value, 0);
SvPOK_on(value);
SvREADONLY_on(value);
- if (he->refcounted_he_data[0] & HVrhek_UTF8)
+ if ((he->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV_UTF8)
SvUTF8_on(value);
break;
default:
return value;
}
-#ifdef USE_ITHREADS
-/* A big expression to find the key offset */
-#define REF_HE_KEY(chain) \
- ((((chain->refcounted_he_data[0] & HVrhek_typemask) == HVrhek_PV) \
- ? chain->refcounted_he_val.refcounted_he_u_len + 1 : 0) \
- + 1 + chain->refcounted_he_data)
-#endif
-
/*
=for apidoc refcounted_he_chain_2hv
-Generates an returns a C<HV *> by walking up the tree starting at the passed
+Generates and returns a C<HV *> by walking up the tree starting at the passed
in C<struct refcounted_he *>.
=cut
value_len = 0;
key_offset = 1;
}
- flags = value_type;
#ifdef USE_ITHREADS
he = (struct refcounted_he*)
if (value_type == HVrhek_PV) {
Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char);
he->refcounted_he_val.refcounted_he_u_len = value_len;
- if (SvUTF8(value)) {
- flags |= HVrhek_UTF8;
- }
+ /* Do it this way so that the SvUTF8() test is after the SvPV, in case
+ the value is overloaded, and doesn't yet have the UTF-8flag set. */
+ if (SvUTF8(value))
+ value_type = HVrhek_PV_UTF8;
} else if (value_type == HVrhek_IV) {
if (SvUOK(value)) {
he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value);
- flags |= HVrhek_UV;
+ value_type = HVrhek_UV;
} else {
he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value);
}
}
+ flags = value_type;
if (is_utf8) {
/* Hash keys are always stored normalised to (yes) ISO-8859-1.
void
Perl_refcounted_he_free(pTHX_ struct refcounted_he *he) {
+ dVAR;
PERL_UNUSED_CONTEXT;
while (he) {
withflags++;
if (HeKWASUTF8(entry)) {
PerlIO_printf(Perl_debug_log,
- "hash key has both WASUFT8 and UTF8: '%.*s'\n",
+ "hash key has both WASUTF8 and UTF8: '%.*s'\n",
(int) HeKLEN(entry), HeKEY(entry));
bad = 1;
}
https://perl5.git.perl.org / perl5.git / blobdiff