1 |
root |
1.1 |
/* hv.c |
2 |
|
|
* |
3 |
|
|
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, |
4 |
|
|
* 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others |
5 |
|
|
* |
6 |
|
|
* You may distribute under the terms of either the GNU General Public |
7 |
|
|
* License or the Artistic License, as specified in the README file. |
8 |
|
|
* |
9 |
|
|
*/ |
10 |
|
|
|
11 |
|
|
/* |
12 |
|
|
* "I sit beside the fire and think of all that I have seen." --Bilbo |
13 |
|
|
*/ |
14 |
|
|
|
15 |
|
|
/* |
16 |
|
|
=head1 Hash Manipulation Functions |
17 |
|
|
|
18 |
|
|
A HV structure represents a Perl hash. It consists mainly of an array |
19 |
|
|
of pointers, each of which points to a linked list of HE structures. The |
20 |
|
|
array is indexed by the hash function of the key, so each linked list |
21 |
|
|
represents all the hash entries with the same hash value. Each HE contains |
22 |
|
|
a pointer to the actual value, plus a pointer to a HEK structure which |
23 |
|
|
holds the key and hash value. |
24 |
|
|
|
25 |
|
|
=cut |
26 |
|
|
|
27 |
|
|
*/ |
28 |
|
|
|
29 |
|
|
#include "EXTERN.h" |
30 |
|
|
#define PERL_IN_HV_C |
31 |
|
|
#define PERL_HASH_INTERNAL_ACCESS |
32 |
|
|
#include "perl.h" |
33 |
|
|
|
34 |
|
|
#define HV_MAX_LENGTH_BEFORE_SPLIT 14 |
35 |
|
|
|
36 |
|
|
STATIC HE* |
37 |
|
|
S_new_he(pTHX) |
38 |
|
|
{ |
39 |
|
|
HE* he; |
40 |
|
|
LOCK_SV_MUTEX; |
41 |
|
|
if (!PL_he_root) |
42 |
|
|
more_he(); |
43 |
|
|
he = PL_he_root; |
44 |
|
|
PL_he_root = HeNEXT(he); |
45 |
|
|
UNLOCK_SV_MUTEX; |
46 |
|
|
return he; |
47 |
|
|
} |
48 |
|
|
|
49 |
|
|
STATIC void |
50 |
|
|
S_del_he(pTHX_ HE *p) |
51 |
|
|
{ |
52 |
|
|
LOCK_SV_MUTEX; |
53 |
|
|
HeNEXT(p) = (HE*)PL_he_root; |
54 |
|
|
PL_he_root = p; |
55 |
|
|
UNLOCK_SV_MUTEX; |
56 |
|
|
} |
57 |
|
|
|
58 |
|
|
STATIC void |
59 |
|
|
S_more_he(pTHX) |
60 |
|
|
{ |
61 |
|
|
register HE* he; |
62 |
|
|
register HE* heend; |
63 |
|
|
XPV *ptr; |
64 |
|
|
New(54, ptr, PERL_ARENA_SIZE/sizeof(XPV), XPV); |
65 |
|
|
ptr->xpv_pv = (char*)PL_he_arenaroot; |
66 |
|
|
PL_he_arenaroot = ptr; |
67 |
|
|
|
68 |
|
|
he = (HE*)ptr; |
69 |
|
|
heend = &he[PERL_ARENA_SIZE / sizeof(HE) - 1]; |
70 |
|
|
PL_he_root = ++he; |
71 |
|
|
while (he < heend) { |
72 |
|
|
HeNEXT(he) = (HE*)(he + 1); |
73 |
|
|
he++; |
74 |
|
|
} |
75 |
|
|
HeNEXT(he) = 0; |
76 |
|
|
} |
77 |
|
|
|
78 |
|
|
#ifdef PURIFY |
79 |
|
|
|
80 |
|
|
#define new_HE() (HE*)safemalloc(sizeof(HE)) |
81 |
|
|
#define del_HE(p) safefree((char*)p) |
82 |
|
|
|
83 |
|
|
#else |
84 |
|
|
|
85 |
|
|
#define new_HE() new_he() |
86 |
|
|
#define del_HE(p) del_he(p) |
87 |
|
|
|
88 |
|
|
#endif |
89 |
|
|
|
90 |
|
|
STATIC HEK * |
91 |
|
|
S_save_hek_flags(pTHX_ const char *str, I32 len, U32 hash, int flags) |
92 |
|
|
{ |
93 |
|
|
int flags_masked = flags & HVhek_MASK; |
94 |
|
|
char *k; |
95 |
|
|
register HEK *hek; |
96 |
|
|
|
97 |
|
|
New(54, k, HEK_BASESIZE + len + 2, char); |
98 |
|
|
hek = (HEK*)k; |
99 |
|
|
Copy(str, HEK_KEY(hek), len, char); |
100 |
|
|
HEK_KEY(hek)[len] = 0; |
101 |
|
|
HEK_LEN(hek) = len; |
102 |
|
|
HEK_HASH(hek) = hash; |
103 |
|
|
HEK_FLAGS(hek) = (unsigned char)flags_masked; |
104 |
|
|
|
105 |
|
|
if (flags & HVhek_FREEKEY) |
106 |
|
|
Safefree(str); |
107 |
|
|
return hek; |
108 |
|
|
} |
109 |
|
|
|
110 |
|
|
/* free the pool of temporary HE/HEK pairs retunrned by hv_fetch_ent |
111 |
|
|
* for tied hashes */ |
112 |
|
|
|
113 |
|
|
void |
114 |
|
|
Perl_free_tied_hv_pool(pTHX) |
115 |
|
|
{ |
116 |
|
|
HE *ohe; |
117 |
|
|
HE *he = PL_hv_fetch_ent_mh; |
118 |
|
|
while (he) { |
119 |
|
|
Safefree(HeKEY_hek(he)); |
120 |
|
|
ohe = he; |
121 |
|
|
he = HeNEXT(he); |
122 |
|
|
del_HE(ohe); |
123 |
|
|
} |
124 |
|
|
PL_hv_fetch_ent_mh = Nullhe; |
125 |
|
|
} |
126 |
|
|
|
127 |
|
|
#if defined(USE_ITHREADS) |
128 |
|
|
HE * |
129 |
|
|
Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param) |
130 |
|
|
{ |
131 |
|
|
HE *ret; |
132 |
|
|
|
133 |
|
|
if (!e) |
134 |
|
|
return Nullhe; |
135 |
|
|
/* look for it in the table first */ |
136 |
|
|
ret = (HE*)ptr_table_fetch(PL_ptr_table, e); |
137 |
|
|
if (ret) |
138 |
|
|
return ret; |
139 |
|
|
|
140 |
|
|
/* create anew and remember what it is */ |
141 |
|
|
ret = new_HE(); |
142 |
|
|
ptr_table_store(PL_ptr_table, e, ret); |
143 |
|
|
|
144 |
|
|
HeNEXT(ret) = he_dup(HeNEXT(e),shared, param); |
145 |
|
|
if (HeKLEN(e) == HEf_SVKEY) { |
146 |
|
|
char *k; |
147 |
|
|
New(54, k, HEK_BASESIZE + sizeof(SV*), char); |
148 |
|
|
HeKEY_hek(ret) = (HEK*)k; |
149 |
|
|
HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param)); |
150 |
|
|
} |
151 |
|
|
else if (shared) |
152 |
|
|
HeKEY_hek(ret) = share_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e), |
153 |
|
|
HeKFLAGS(e)); |
154 |
|
|
else |
155 |
|
|
HeKEY_hek(ret) = save_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e), |
156 |
|
|
HeKFLAGS(e)); |
157 |
|
|
HeVAL(ret) = SvREFCNT_inc(sv_dup(HeVAL(e), param)); |
158 |
|
|
return ret; |
159 |
|
|
} |
160 |
|
|
#endif /* USE_ITHREADS */ |
161 |
|
|
|
162 |
|
|
static void |
163 |
|
|
S_hv_notallowed(pTHX_ int flags, const char *key, I32 klen, |
164 |
|
|
const char *msg) |
165 |
|
|
{ |
166 |
|
|
SV *sv = sv_newmortal(), *esv = sv_newmortal(); |
167 |
|
|
if (!(flags & HVhek_FREEKEY)) { |
168 |
|
|
sv_setpvn(sv, key, klen); |
169 |
|
|
} |
170 |
|
|
else { |
171 |
|
|
/* Need to free saved eventually assign to mortal SV */ |
172 |
|
|
/* XXX is this line an error ???: SV *sv = sv_newmortal(); */ |
173 |
|
|
sv_usepvn(sv, (char *) key, klen); |
174 |
|
|
} |
175 |
|
|
if (flags & HVhek_UTF8) { |
176 |
|
|
SvUTF8_on(sv); |
177 |
|
|
} |
178 |
|
|
Perl_sv_setpvf(aTHX_ esv, "Attempt to %s a restricted hash", msg); |
179 |
|
|
Perl_croak(aTHX_ SvPVX(esv), sv); |
180 |
|
|
} |
181 |
|
|
|
182 |
|
|
/* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot |
183 |
|
|
* contains an SV* */ |
184 |
|
|
|
185 |
|
|
#define HV_FETCH_ISSTORE 0x01 |
186 |
|
|
#define HV_FETCH_ISEXISTS 0x02 |
187 |
|
|
#define HV_FETCH_LVALUE 0x04 |
188 |
|
|
#define HV_FETCH_JUST_SV 0x08 |
189 |
|
|
|
190 |
|
|
/* |
191 |
|
|
=for apidoc hv_store |
192 |
|
|
|
193 |
|
|
Stores an SV in a hash. The hash key is specified as C<key> and C<klen> is |
194 |
|
|
the length of the key. The C<hash> parameter is the precomputed hash |
195 |
|
|
value; if it is zero then Perl will compute it. The return value will be |
196 |
|
|
NULL if the operation failed or if the value did not need to be actually |
197 |
|
|
stored within the hash (as in the case of tied hashes). Otherwise it can |
198 |
|
|
be dereferenced to get the original C<SV*>. Note that the caller is |
199 |
|
|
responsible for suitably incrementing the reference count of C<val> before |
200 |
|
|
the call, and decrementing it if the function returned NULL. Effectively |
201 |
|
|
a successful hv_store takes ownership of one reference to C<val>. This is |
202 |
|
|
usually what you want; a newly created SV has a reference count of one, so |
203 |
|
|
if all your code does is create SVs then store them in a hash, hv_store |
204 |
|
|
will own the only reference to the new SV, and your code doesn't need to do |
205 |
|
|
anything further to tidy up. hv_store is not implemented as a call to |
206 |
|
|
hv_store_ent, and does not create a temporary SV for the key, so if your |
207 |
|
|
key data is not already in SV form then use hv_store in preference to |
208 |
|
|
hv_store_ent. |
209 |
|
|
|
210 |
|
|
See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more |
211 |
|
|
information on how to use this function on tied hashes. |
212 |
|
|
|
213 |
|
|
=cut |
214 |
|
|
*/ |
215 |
|
|
|
216 |
|
|
SV** |
217 |
|
|
Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen_i32, SV *val, U32 hash) |
218 |
|
|
{ |
219 |
|
|
HE *hek; |
220 |
|
|
STRLEN klen; |
221 |
|
|
int flags; |
222 |
|
|
|
223 |
|
|
if (klen_i32 < 0) { |
224 |
|
|
klen = -klen_i32; |
225 |
|
|
flags = HVhek_UTF8; |
226 |
|
|
} else { |
227 |
|
|
klen = klen_i32; |
228 |
|
|
flags = 0; |
229 |
|
|
} |
230 |
|
|
hek = hv_fetch_common (hv, NULL, key, klen, flags, |
231 |
|
|
(HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash); |
232 |
|
|
return hek ? &HeVAL(hek) : NULL; |
233 |
|
|
} |
234 |
|
|
|
235 |
|
|
SV** |
236 |
|
|
Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val, |
237 |
|
|
register U32 hash, int flags) |
238 |
|
|
{ |
239 |
|
|
HE *hek = hv_fetch_common (hv, NULL, key, klen, flags, |
240 |
|
|
(HV_FETCH_ISSTORE|HV_FETCH_JUST_SV), val, hash); |
241 |
|
|
return hek ? &HeVAL(hek) : NULL; |
242 |
|
|
} |
243 |
|
|
|
244 |
|
|
/* |
245 |
|
|
=for apidoc hv_store_ent |
246 |
|
|
|
247 |
|
|
Stores C<val> in a hash. The hash key is specified as C<key>. The C<hash> |
248 |
|
|
parameter is the precomputed hash value; if it is zero then Perl will |
249 |
|
|
compute it. The return value is the new hash entry so created. It will be |
250 |
|
|
NULL if the operation failed or if the value did not need to be actually |
251 |
|
|
stored within the hash (as in the case of tied hashes). Otherwise the |
252 |
|
|
contents of the return value can be accessed using the C<He?> macros |
253 |
|
|
described here. Note that the caller is responsible for suitably |
254 |
|
|
incrementing the reference count of C<val> before the call, and |
255 |
|
|
decrementing it if the function returned NULL. Effectively a successful |
256 |
|
|
hv_store_ent takes ownership of one reference to C<val>. This is |
257 |
|
|
usually what you want; a newly created SV has a reference count of one, so |
258 |
|
|
if all your code does is create SVs then store them in a hash, hv_store |
259 |
|
|
will own the only reference to the new SV, and your code doesn't need to do |
260 |
|
|
anything further to tidy up. Note that hv_store_ent only reads the C<key>; |
261 |
|
|
unlike C<val> it does not take ownership of it, so maintaining the correct |
262 |
|
|
reference count on C<key> is entirely the caller's responsibility. hv_store |
263 |
|
|
is not implemented as a call to hv_store_ent, and does not create a temporary |
264 |
|
|
SV for the key, so if your key data is not already in SV form then use |
265 |
|
|
hv_store in preference to hv_store_ent. |
266 |
|
|
|
267 |
|
|
See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more |
268 |
|
|
information on how to use this function on tied hashes. |
269 |
|
|
|
270 |
|
|
=cut |
271 |
|
|
*/ |
272 |
|
|
|
273 |
|
|
HE * |
274 |
|
|
Perl_hv_store_ent(pTHX_ HV *hv, SV *keysv, SV *val, U32 hash) |
275 |
|
|
{ |
276 |
|
|
return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISSTORE, val, hash); |
277 |
|
|
} |
278 |
|
|
|
279 |
|
|
/* |
280 |
|
|
=for apidoc hv_exists |
281 |
|
|
|
282 |
|
|
Returns a boolean indicating whether the specified hash key exists. The |
283 |
|
|
C<klen> is the length of the key. |
284 |
|
|
|
285 |
|
|
=cut |
286 |
|
|
*/ |
287 |
|
|
|
288 |
|
|
bool |
289 |
|
|
Perl_hv_exists(pTHX_ HV *hv, const char *key, I32 klen_i32) |
290 |
|
|
{ |
291 |
|
|
STRLEN klen; |
292 |
|
|
int flags; |
293 |
|
|
|
294 |
|
|
if (klen_i32 < 0) { |
295 |
|
|
klen = -klen_i32; |
296 |
|
|
flags = HVhek_UTF8; |
297 |
|
|
} else { |
298 |
|
|
klen = klen_i32; |
299 |
|
|
flags = 0; |
300 |
|
|
} |
301 |
|
|
return hv_fetch_common(hv, NULL, key, klen, flags, HV_FETCH_ISEXISTS, 0, 0) |
302 |
|
|
? TRUE : FALSE; |
303 |
|
|
} |
304 |
|
|
|
305 |
|
|
/* |
306 |
|
|
=for apidoc hv_fetch |
307 |
|
|
|
308 |
|
|
Returns the SV which corresponds to the specified key in the hash. The |
309 |
|
|
C<klen> is the length of the key. If C<lval> is set then the fetch will be |
310 |
|
|
part of a store. Check that the return value is non-null before |
311 |
|
|
dereferencing it to an C<SV*>. |
312 |
|
|
|
313 |
|
|
See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more |
314 |
|
|
information on how to use this function on tied hashes. |
315 |
|
|
|
316 |
|
|
=cut |
317 |
|
|
*/ |
318 |
|
|
|
319 |
|
|
SV** |
320 |
|
|
Perl_hv_fetch(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 lval) |
321 |
|
|
{ |
322 |
|
|
HE *hek; |
323 |
|
|
STRLEN klen; |
324 |
|
|
int flags; |
325 |
|
|
|
326 |
|
|
if (klen_i32 < 0) { |
327 |
|
|
klen = -klen_i32; |
328 |
|
|
flags = HVhek_UTF8; |
329 |
|
|
} else { |
330 |
|
|
klen = klen_i32; |
331 |
|
|
flags = 0; |
332 |
|
|
} |
333 |
|
|
hek = hv_fetch_common (hv, NULL, key, klen, flags, |
334 |
|
|
HV_FETCH_JUST_SV | (lval ? HV_FETCH_LVALUE : 0), |
335 |
|
|
Nullsv, 0); |
336 |
|
|
return hek ? &HeVAL(hek) : NULL; |
337 |
|
|
} |
338 |
|
|
|
339 |
|
|
/* |
340 |
|
|
=for apidoc hv_exists_ent |
341 |
|
|
|
342 |
|
|
Returns a boolean indicating whether the specified hash key exists. C<hash> |
343 |
|
|
can be a valid precomputed hash value, or 0 to ask for it to be |
344 |
|
|
computed. |
345 |
|
|
|
346 |
|
|
=cut |
347 |
|
|
*/ |
348 |
|
|
|
349 |
|
|
bool |
350 |
|
|
Perl_hv_exists_ent(pTHX_ HV *hv, SV *keysv, U32 hash) |
351 |
|
|
{ |
352 |
|
|
return hv_fetch_common(hv, keysv, NULL, 0, 0, HV_FETCH_ISEXISTS, 0, hash) |
353 |
|
|
? TRUE : FALSE; |
354 |
|
|
} |
355 |
|
|
|
356 |
|
|
/* returns an HE * structure with the all fields set */ |
357 |
|
|
/* note that hent_val will be a mortal sv for MAGICAL hashes */ |
358 |
|
|
/* |
359 |
|
|
=for apidoc hv_fetch_ent |
360 |
|
|
|
361 |
|
|
Returns the hash entry which corresponds to the specified key in the hash. |
362 |
|
|
C<hash> must be a valid precomputed hash number for the given C<key>, or 0 |
363 |
|
|
if you want the function to compute it. IF C<lval> is set then the fetch |
364 |
|
|
will be part of a store. Make sure the return value is non-null before |
365 |
|
|
accessing it. The return value when C<tb> is a tied hash is a pointer to a |
366 |
|
|
static location, so be sure to make a copy of the structure if you need to |
367 |
|
|
store it somewhere. |
368 |
|
|
|
369 |
|
|
See L<perlguts/"Understanding the Magic of Tied Hashes and Arrays"> for more |
370 |
|
|
information on how to use this function on tied hashes. |
371 |
|
|
|
372 |
|
|
=cut |
373 |
|
|
*/ |
374 |
|
|
|
375 |
|
|
HE * |
376 |
|
|
Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keysv, I32 lval, register U32 hash) |
377 |
|
|
{ |
378 |
|
|
return hv_fetch_common(hv, keysv, NULL, 0, 0, |
379 |
|
|
(lval ? HV_FETCH_LVALUE : 0), Nullsv, hash); |
380 |
|
|
} |
381 |
|
|
|
382 |
|
|
STATIC HE * |
383 |
|
|
S_hv_fetch_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, |
384 |
|
|
int flags, int action, SV *val, register U32 hash) |
385 |
|
|
{ |
386 |
|
|
XPVHV* xhv; |
387 |
|
|
U32 n_links; |
388 |
|
|
HE *entry; |
389 |
|
|
HE **oentry; |
390 |
|
|
SV *sv; |
391 |
|
|
bool is_utf8; |
392 |
|
|
int masked_flags; |
393 |
|
|
|
394 |
|
|
if (!hv) |
395 |
|
|
return 0; |
396 |
|
|
|
397 |
|
|
if (keysv) { |
398 |
|
|
if (flags & HVhek_FREEKEY) |
399 |
|
|
Safefree(key); |
400 |
|
|
key = SvPV(keysv, klen); |
401 |
|
|
flags = 0; |
402 |
|
|
is_utf8 = (SvUTF8(keysv) != 0); |
403 |
|
|
} else { |
404 |
|
|
is_utf8 = ((flags & HVhek_UTF8) ? TRUE : FALSE); |
405 |
|
|
} |
406 |
|
|
|
407 |
|
|
xhv = (XPVHV*)SvANY(hv); |
408 |
|
|
if (SvMAGICAL(hv)) { |
409 |
|
|
if (SvRMAGICAL(hv) && !(action & (HV_FETCH_ISSTORE|HV_FETCH_ISEXISTS))) |
410 |
|
|
{ |
411 |
|
|
if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) { |
412 |
|
|
sv = sv_newmortal(); |
413 |
|
|
|
414 |
|
|
/* XXX should be able to skimp on the HE/HEK here when |
415 |
|
|
HV_FETCH_JUST_SV is true. */ |
416 |
|
|
|
417 |
|
|
if (!keysv) { |
418 |
|
|
keysv = newSVpvn(key, klen); |
419 |
|
|
if (is_utf8) { |
420 |
|
|
SvUTF8_on(keysv); |
421 |
|
|
} |
422 |
|
|
} else { |
423 |
|
|
keysv = newSVsv(keysv); |
424 |
|
|
} |
425 |
|
|
mg_copy((SV*)hv, sv, (char *)keysv, HEf_SVKEY); |
426 |
|
|
|
427 |
|
|
/* grab a fake HE/HEK pair from the pool or make a new one */ |
428 |
|
|
entry = PL_hv_fetch_ent_mh; |
429 |
|
|
if (entry) |
430 |
|
|
PL_hv_fetch_ent_mh = HeNEXT(entry); |
431 |
|
|
else { |
432 |
|
|
char *k; |
433 |
|
|
entry = new_HE(); |
434 |
|
|
New(54, k, HEK_BASESIZE + sizeof(SV*), char); |
435 |
|
|
HeKEY_hek(entry) = (HEK*)k; |
436 |
|
|
} |
437 |
|
|
HeNEXT(entry) = Nullhe; |
438 |
|
|
HeSVKEY_set(entry, keysv); |
439 |
|
|
HeVAL(entry) = sv; |
440 |
|
|
sv_upgrade(sv, SVt_PVLV); |
441 |
|
|
LvTYPE(sv) = 'T'; |
442 |
|
|
/* so we can free entry when freeing sv */ |
443 |
|
|
LvTARG(sv) = (SV*)entry; |
444 |
|
|
|
445 |
|
|
/* XXX remove at some point? */ |
446 |
|
|
if (flags & HVhek_FREEKEY) |
447 |
|
|
Safefree(key); |
448 |
|
|
|
449 |
|
|
return entry; |
450 |
|
|
} |
451 |
|
|
#ifdef ENV_IS_CASELESS |
452 |
|
|
else if (mg_find((SV*)hv, PERL_MAGIC_env)) { |
453 |
|
|
U32 i; |
454 |
|
|
for (i = 0; i < klen; ++i) |
455 |
|
|
if (isLOWER(key[i])) { |
456 |
|
|
/* Would be nice if we had a routine to do the |
457 |
|
|
copy and upercase in a single pass through. */ |
458 |
|
|
char *nkey = strupr(savepvn(key,klen)); |
459 |
|
|
/* Note that this fetch is for nkey (the uppercased |
460 |
|
|
key) whereas the store is for key (the original) */ |
461 |
|
|
entry = hv_fetch_common(hv, Nullsv, nkey, klen, |
462 |
|
|
HVhek_FREEKEY, /* free nkey */ |
463 |
|
|
0 /* non-LVAL fetch */, |
464 |
|
|
Nullsv /* no value */, |
465 |
|
|
0 /* compute hash */); |
466 |
|
|
if (!entry && (action & HV_FETCH_LVALUE)) { |
467 |
|
|
/* This call will free key if necessary. |
468 |
|
|
Do it this way to encourage compiler to tail |
469 |
|
|
call optimise. */ |
470 |
|
|
entry = hv_fetch_common(hv, keysv, key, klen, |
471 |
|
|
flags, HV_FETCH_ISSTORE, |
472 |
|
|
NEWSV(61,0), hash); |
473 |
|
|
} else { |
474 |
|
|
if (flags & HVhek_FREEKEY) |
475 |
|
|
Safefree(key); |
476 |
|
|
} |
477 |
|
|
return entry; |
478 |
|
|
} |
479 |
|
|
} |
480 |
|
|
#endif |
481 |
|
|
} /* ISFETCH */ |
482 |
|
|
else if (SvRMAGICAL(hv) && (action & HV_FETCH_ISEXISTS)) { |
483 |
|
|
if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) { |
484 |
|
|
SV* svret; |
485 |
|
|
/* I don't understand why hv_exists_ent has svret and sv, |
486 |
|
|
whereas hv_exists only had one. */ |
487 |
|
|
svret = sv_newmortal(); |
488 |
|
|
sv = sv_newmortal(); |
489 |
|
|
|
490 |
|
|
if (keysv || is_utf8) { |
491 |
|
|
if (!keysv) { |
492 |
|
|
keysv = newSVpvn(key, klen); |
493 |
|
|
SvUTF8_on(keysv); |
494 |
|
|
} else { |
495 |
|
|
keysv = newSVsv(keysv); |
496 |
|
|
} |
497 |
|
|
mg_copy((SV*)hv, sv, (char *)sv_2mortal(keysv), HEf_SVKEY); |
498 |
|
|
} else { |
499 |
|
|
mg_copy((SV*)hv, sv, key, klen); |
500 |
|
|
} |
501 |
|
|
if (flags & HVhek_FREEKEY) |
502 |
|
|
Safefree(key); |
503 |
|
|
magic_existspack(svret, mg_find(sv, PERL_MAGIC_tiedelem)); |
504 |
|
|
/* This cast somewhat evil, but I'm merely using NULL/ |
505 |
|
|
not NULL to return the boolean exists. |
506 |
|
|
And I know hv is not NULL. */ |
507 |
|
|
return SvTRUE(svret) ? (HE *)hv : NULL; |
508 |
|
|
} |
509 |
|
|
#ifdef ENV_IS_CASELESS |
510 |
|
|
else if (mg_find((SV*)hv, PERL_MAGIC_env)) { |
511 |
|
|
/* XXX This code isn't UTF8 clean. */ |
512 |
|
|
const char *keysave = key; |
513 |
|
|
/* Will need to free this, so set FREEKEY flag. */ |
514 |
|
|
key = savepvn(key,klen); |
515 |
|
|
key = (const char*)strupr((char*)key); |
516 |
|
|
is_utf8 = 0; |
517 |
|
|
hash = 0; |
518 |
|
|
keysv = 0; |
519 |
|
|
|
520 |
|
|
if (flags & HVhek_FREEKEY) { |
521 |
|
|
Safefree(keysave); |
522 |
|
|
} |
523 |
|
|
flags |= HVhek_FREEKEY; |
524 |
|
|
} |
525 |
|
|
#endif |
526 |
|
|
} /* ISEXISTS */ |
527 |
|
|
else if (action & HV_FETCH_ISSTORE) { |
528 |
|
|
bool needs_copy; |
529 |
|
|
bool needs_store; |
530 |
|
|
hv_magic_check (hv, &needs_copy, &needs_store); |
531 |
|
|
if (needs_copy) { |
532 |
|
|
bool save_taint = PL_tainted; |
533 |
|
|
if (keysv || is_utf8) { |
534 |
|
|
if (!keysv) { |
535 |
|
|
keysv = newSVpvn(key, klen); |
536 |
|
|
SvUTF8_on(keysv); |
537 |
|
|
} |
538 |
|
|
if (PL_tainting) |
539 |
|
|
PL_tainted = SvTAINTED(keysv); |
540 |
|
|
keysv = sv_2mortal(newSVsv(keysv)); |
541 |
|
|
mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY); |
542 |
|
|
} else { |
543 |
|
|
mg_copy((SV*)hv, val, key, klen); |
544 |
|
|
} |
545 |
|
|
|
546 |
|
|
TAINT_IF(save_taint); |
547 |
|
|
if (!xhv->xhv_array /* !HvARRAY(hv) */ && !needs_store) { |
548 |
|
|
if (flags & HVhek_FREEKEY) |
549 |
|
|
Safefree(key); |
550 |
|
|
return Nullhe; |
551 |
|
|
} |
552 |
|
|
#ifdef ENV_IS_CASELESS |
553 |
|
|
else if (mg_find((SV*)hv, PERL_MAGIC_env)) { |
554 |
|
|
/* XXX This code isn't UTF8 clean. */ |
555 |
|
|
const char *keysave = key; |
556 |
|
|
/* Will need to free this, so set FREEKEY flag. */ |
557 |
|
|
key = savepvn(key,klen); |
558 |
|
|
key = (const char*)strupr((char*)key); |
559 |
|
|
is_utf8 = 0; |
560 |
|
|
hash = 0; |
561 |
|
|
keysv = 0; |
562 |
|
|
|
563 |
|
|
if (flags & HVhek_FREEKEY) { |
564 |
|
|
Safefree(keysave); |
565 |
|
|
} |
566 |
|
|
flags |= HVhek_FREEKEY; |
567 |
|
|
} |
568 |
|
|
#endif |
569 |
|
|
} |
570 |
|
|
} /* ISSTORE */ |
571 |
|
|
} /* SvMAGICAL */ |
572 |
|
|
|
573 |
|
|
if (!xhv->xhv_array /* !HvARRAY(hv) */) { |
574 |
|
|
if ((action & (HV_FETCH_LVALUE | HV_FETCH_ISSTORE)) |
575 |
|
|
#ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */ |
576 |
|
|
|| (SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) |
577 |
|
|
#endif |
578 |
|
|
) |
579 |
|
|
Newz(503, xhv->xhv_array /* HvARRAY(hv) */, |
580 |
|
|
PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */), |
581 |
|
|
char); |
582 |
|
|
#ifdef DYNAMIC_ENV_FETCH |
583 |
|
|
else if (action & HV_FETCH_ISEXISTS) { |
584 |
|
|
/* for an %ENV exists, if we do an insert it's by a recursive |
585 |
|
|
store call, so avoid creating HvARRAY(hv) right now. */ |
586 |
|
|
} |
587 |
|
|
#endif |
588 |
|
|
else { |
589 |
|
|
/* XXX remove at some point? */ |
590 |
|
|
if (flags & HVhek_FREEKEY) |
591 |
|
|
Safefree(key); |
592 |
|
|
|
593 |
|
|
return 0; |
594 |
|
|
} |
595 |
|
|
} |
596 |
|
|
|
597 |
|
|
if (is_utf8) { |
598 |
|
|
const char *keysave = key; |
599 |
|
|
key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8); |
600 |
|
|
if (is_utf8) |
601 |
|
|
flags |= HVhek_UTF8; |
602 |
|
|
else |
603 |
|
|
flags &= ~HVhek_UTF8; |
604 |
|
|
if (key != keysave) { |
605 |
|
|
if (flags & HVhek_FREEKEY) |
606 |
|
|
Safefree(keysave); |
607 |
|
|
flags |= HVhek_WASUTF8 | HVhek_FREEKEY; |
608 |
|
|
} |
609 |
|
|
} |
610 |
|
|
|
611 |
|
|
if (HvREHASH(hv)) { |
612 |
|
|
PERL_HASH_INTERNAL(hash, key, klen); |
613 |
|
|
/* We don't have a pointer to the hv, so we have to replicate the |
614 |
|
|
flag into every HEK, so that hv_iterkeysv can see it. */ |
615 |
|
|
/* And yes, you do need this even though you are not "storing" because |
616 |
|
|
you can flip the flags below if doing an lval lookup. (And that |
617 |
|
|
was put in to give the semantics Andreas was expecting.) */ |
618 |
|
|
flags |= HVhek_REHASH; |
619 |
|
|
} else if (!hash) { |
620 |
|
|
/* Not enough shared hash key scalars around to make this worthwhile |
621 |
|
|
(about 4% slowdown in perlbench with this in) |
622 |
|
|
if (keysv && (SvIsCOW_shared_hash(keysv))) { |
623 |
|
|
hash = SvUVX(keysv); |
624 |
|
|
} else |
625 |
|
|
*/ |
626 |
|
|
{ |
627 |
|
|
PERL_HASH(hash, key, klen); |
628 |
|
|
} |
629 |
|
|
} |
630 |
|
|
|
631 |
|
|
masked_flags = (flags & HVhek_MASK); |
632 |
|
|
n_links = 0; |
633 |
|
|
|
634 |
|
|
#ifdef DYNAMIC_ENV_FETCH |
635 |
|
|
if (!xhv->xhv_array /* !HvARRAY(hv) */) entry = Null(HE*); |
636 |
|
|
else |
637 |
|
|
#endif |
638 |
|
|
{ |
639 |
|
|
/* entry = (HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */ |
640 |
|
|
entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; |
641 |
|
|
} |
642 |
|
|
for (; entry; ++n_links, entry = HeNEXT(entry)) { |
643 |
|
|
if (!HeKEY_hek(entry)) |
644 |
|
|
continue; |
645 |
|
|
if (HeHASH(entry) != hash) /* strings can't be equal */ |
646 |
|
|
continue; |
647 |
|
|
if (HeKLEN(entry) != (I32)klen) |
648 |
|
|
continue; |
649 |
|
|
if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ |
650 |
|
|
continue; |
651 |
|
|
if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8) |
652 |
|
|
continue; |
653 |
|
|
|
654 |
|
|
if (action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE)) { |
655 |
|
|
if (HeKFLAGS(entry) != masked_flags) { |
656 |
|
|
/* We match if HVhek_UTF8 bit in our flags and hash key's |
657 |
|
|
match. But if entry was set previously with HVhek_WASUTF8 |
658 |
|
|
and key now doesn't (or vice versa) then we should change |
659 |
|
|
the key's flag, as this is assignment. */ |
660 |
|
|
if (HvSHAREKEYS(hv)) { |
661 |
|
|
/* Need to swap the key we have for a key with the flags we |
662 |
|
|
need. As keys are shared we can't just write to the |
663 |
|
|
flag, so we share the new one, unshare the old one. */ |
664 |
|
|
HEK *new_hek = share_hek_flags(key, klen, hash, |
665 |
|
|
masked_flags); |
666 |
|
|
unshare_hek (HeKEY_hek(entry)); |
667 |
|
|
HeKEY_hek(entry) = new_hek; |
668 |
|
|
} |
669 |
|
|
else |
670 |
|
|
HeKFLAGS(entry) = masked_flags; |
671 |
|
|
if (masked_flags & HVhek_ENABLEHVKFLAGS) |
672 |
|
|
HvHASKFLAGS_on(hv); |
673 |
|
|
} |
674 |
|
|
if (HeVAL(entry) == &PL_sv_placeholder) { |
675 |
|
|
/* yes, can store into placeholder slot */ |
676 |
|
|
if (action & HV_FETCH_LVALUE) { |
677 |
|
|
if (SvMAGICAL(hv)) { |
678 |
|
|
/* This preserves behaviour with the old hv_fetch |
679 |
|
|
implementation which at this point would bail out |
680 |
|
|
with a break; (at "if we find a placeholder, we |
681 |
|
|
pretend we haven't found anything") |
682 |
|
|
|
683 |
|
|
That break mean that if a placeholder were found, it |
684 |
|
|
caused a call into hv_store, which in turn would |
685 |
|
|
check magic, and if there is no magic end up pretty |
686 |
|
|
much back at this point (in hv_store's code). */ |
687 |
|
|
break; |
688 |
|
|
} |
689 |
|
|
/* LVAL fetch which actaully needs a store. */ |
690 |
|
|
val = NEWSV(61,0); |
691 |
|
|
xhv->xhv_placeholders--; |
692 |
|
|
} else { |
693 |
|
|
/* store */ |
694 |
|
|
if (val != &PL_sv_placeholder) |
695 |
|
|
xhv->xhv_placeholders--; |
696 |
|
|
} |
697 |
|
|
HeVAL(entry) = val; |
698 |
|
|
} else if (action & HV_FETCH_ISSTORE) { |
699 |
|
|
SvREFCNT_dec(HeVAL(entry)); |
700 |
|
|
HeVAL(entry) = val; |
701 |
|
|
} |
702 |
|
|
} else if (HeVAL(entry) == &PL_sv_placeholder) { |
703 |
|
|
/* if we find a placeholder, we pretend we haven't found |
704 |
|
|
anything */ |
705 |
|
|
break; |
706 |
|
|
} |
707 |
|
|
if (flags & HVhek_FREEKEY) |
708 |
|
|
Safefree(key); |
709 |
|
|
return entry; |
710 |
|
|
} |
711 |
|
|
#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */ |
712 |
|
|
if (!(action & HV_FETCH_ISSTORE) |
713 |
|
|
&& SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) { |
714 |
|
|
unsigned long len; |
715 |
|
|
char *env = PerlEnv_ENVgetenv_len(key,&len); |
716 |
|
|
if (env) { |
717 |
|
|
sv = newSVpvn(env,len); |
718 |
|
|
SvTAINTED_on(sv); |
719 |
|
|
return hv_fetch_common(hv,keysv,key,klen,flags,HV_FETCH_ISSTORE,sv, |
720 |
|
|
hash); |
721 |
|
|
} |
722 |
|
|
} |
723 |
|
|
#endif |
724 |
|
|
|
725 |
|
|
if (!entry && SvREADONLY(hv) && !(action & HV_FETCH_ISEXISTS)) { |
726 |
|
|
S_hv_notallowed(aTHX_ flags, key, klen, |
727 |
|
|
"access disallowed key '%"SVf"' in" |
728 |
|
|
); |
729 |
|
|
} |
730 |
|
|
if (!(action & (HV_FETCH_LVALUE|HV_FETCH_ISSTORE))) { |
731 |
|
|
/* Not doing some form of store, so return failure. */ |
732 |
|
|
if (flags & HVhek_FREEKEY) |
733 |
|
|
Safefree(key); |
734 |
|
|
return 0; |
735 |
|
|
} |
736 |
|
|
if (action & HV_FETCH_LVALUE) { |
737 |
|
|
val = NEWSV(61,0); |
738 |
|
|
if (SvMAGICAL(hv)) { |
739 |
|
|
/* At this point the old hv_fetch code would call to hv_store, |
740 |
|
|
which in turn might do some tied magic. So we need to make that |
741 |
|
|
magic check happen. */ |
742 |
|
|
/* gonna assign to this, so it better be there */ |
743 |
|
|
return hv_fetch_common(hv, keysv, key, klen, flags, |
744 |
|
|
HV_FETCH_ISSTORE, val, hash); |
745 |
|
|
/* XXX Surely that could leak if the fetch-was-store fails? |
746 |
|
|
Just like the hv_fetch. */ |
747 |
|
|
} |
748 |
|
|
} |
749 |
|
|
|
750 |
|
|
/* Welcome to hv_store... */ |
751 |
|
|
|
752 |
|
|
if (!xhv->xhv_array) { |
753 |
|
|
/* Not sure if we can get here. I think the only case of oentry being |
754 |
|
|
NULL is for %ENV with dynamic env fetch. But that should disappear |
755 |
|
|
with magic in the previous code. */ |
756 |
|
|
Newz(503, xhv->xhv_array /* HvARRAY(hv) */, |
757 |
|
|
PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */), |
758 |
|
|
char); |
759 |
|
|
} |
760 |
|
|
|
761 |
|
|
oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; |
762 |
|
|
|
763 |
|
|
entry = new_HE(); |
764 |
|
|
/* share_hek_flags will do the free for us. This might be considered |
765 |
|
|
bad API design. */ |
766 |
|
|
if (HvSHAREKEYS(hv)) |
767 |
|
|
HeKEY_hek(entry) = share_hek_flags(key, klen, hash, flags); |
768 |
|
|
else /* gotta do the real thing */ |
769 |
|
|
HeKEY_hek(entry) = save_hek_flags(key, klen, hash, flags); |
770 |
|
|
HeVAL(entry) = val; |
771 |
|
|
HeNEXT(entry) = *oentry; |
772 |
|
|
*oentry = entry; |
773 |
|
|
|
774 |
|
|
if (val == &PL_sv_placeholder) |
775 |
|
|
xhv->xhv_placeholders++; |
776 |
|
|
if (masked_flags & HVhek_ENABLEHVKFLAGS) |
777 |
|
|
HvHASKFLAGS_on(hv); |
778 |
|
|
|
779 |
|
|
xhv->xhv_keys++; /* HvKEYS(hv)++ */ |
780 |
|
|
if (!n_links) { /* initial entry? */ |
781 |
|
|
xhv->xhv_fill++; /* HvFILL(hv)++ */ |
782 |
|
|
} else if ((xhv->xhv_keys > (IV)xhv->xhv_max) |
783 |
|
|
|| ((n_links > HV_MAX_LENGTH_BEFORE_SPLIT) && !HvREHASH(hv))) { |
784 |
|
|
/* Use only the old HvKEYS(hv) > HvMAX(hv) condition to limit bucket |
785 |
|
|
splits on a rehashed hash, as we're not going to split it again, |
786 |
|
|
and if someone is lucky (evil) enough to get all the keys in one |
787 |
|
|
list they could exhaust our memory as we repeatedly double the |
788 |
|
|
number of buckets on every entry. Linear search feels a less worse |
789 |
|
|
thing to do. */ |
790 |
|
|
hsplit(hv); |
791 |
|
|
} |
792 |
|
|
|
793 |
|
|
return entry; |
794 |
|
|
} |
795 |
|
|
|
796 |
|
|
STATIC void |
797 |
|
|
S_hv_magic_check(pTHX_ HV *hv, bool *needs_copy, bool *needs_store) |
798 |
|
|
{ |
799 |
|
|
MAGIC *mg = SvMAGIC(hv); |
800 |
|
|
*needs_copy = FALSE; |
801 |
|
|
*needs_store = TRUE; |
802 |
|
|
while (mg) { |
803 |
|
|
if (isUPPER(mg->mg_type)) { |
804 |
|
|
*needs_copy = TRUE; |
805 |
|
|
switch (mg->mg_type) { |
806 |
|
|
case PERL_MAGIC_tied: |
807 |
|
|
case PERL_MAGIC_sig: |
808 |
|
|
*needs_store = FALSE; |
809 |
|
|
} |
810 |
|
|
} |
811 |
|
|
mg = mg->mg_moremagic; |
812 |
|
|
} |
813 |
|
|
} |
814 |
|
|
|
815 |
|
|
/* |
816 |
|
|
=for apidoc hv_scalar |
817 |
|
|
|
818 |
|
|
Evaluates the hash in scalar context and returns the result. Handles magic when the hash is tied. |
819 |
|
|
|
820 |
|
|
=cut |
821 |
|
|
*/ |
822 |
|
|
|
823 |
|
|
SV * |
824 |
|
|
Perl_hv_scalar(pTHX_ HV *hv) |
825 |
|
|
{ |
826 |
|
|
MAGIC *mg; |
827 |
|
|
SV *sv; |
828 |
|
|
|
829 |
|
|
if ((SvRMAGICAL(hv) && (mg = mg_find((SV*)hv, PERL_MAGIC_tied)))) { |
830 |
|
|
sv = magic_scalarpack(hv, mg); |
831 |
|
|
return sv; |
832 |
|
|
} |
833 |
|
|
|
834 |
|
|
sv = sv_newmortal(); |
835 |
|
|
if (HvFILL((HV*)hv)) |
836 |
|
|
Perl_sv_setpvf(aTHX_ sv, "%ld/%ld", |
837 |
|
|
(long)HvFILL(hv), (long)HvMAX(hv) + 1); |
838 |
|
|
else |
839 |
|
|
sv_setiv(sv, 0); |
840 |
|
|
|
841 |
|
|
return sv; |
842 |
|
|
} |
843 |
|
|
|
844 |
|
|
/* |
845 |
|
|
=for apidoc hv_delete |
846 |
|
|
|
847 |
|
|
Deletes a key/value pair in the hash. The value SV is removed from the |
848 |
|
|
hash and returned to the caller. The C<klen> is the length of the key. |
849 |
|
|
The C<flags> value will normally be zero; if set to G_DISCARD then NULL |
850 |
|
|
will be returned. |
851 |
|
|
|
852 |
|
|
=cut |
853 |
|
|
*/ |
854 |
|
|
|
855 |
|
|
SV * |
856 |
|
|
Perl_hv_delete(pTHX_ HV *hv, const char *key, I32 klen_i32, I32 flags) |
857 |
|
|
{ |
858 |
|
|
STRLEN klen; |
859 |
|
|
int k_flags = 0; |
860 |
|
|
|
861 |
|
|
if (klen_i32 < 0) { |
862 |
|
|
klen = -klen_i32; |
863 |
|
|
k_flags |= HVhek_UTF8; |
864 |
|
|
} else { |
865 |
|
|
klen = klen_i32; |
866 |
|
|
} |
867 |
|
|
return hv_delete_common(hv, NULL, key, klen, k_flags, flags, 0); |
868 |
|
|
} |
869 |
|
|
|
870 |
|
|
/* |
871 |
|
|
=for apidoc hv_delete_ent |
872 |
|
|
|
873 |
|
|
Deletes a key/value pair in the hash. The value SV is removed from the |
874 |
|
|
hash and returned to the caller. The C<flags> value will normally be zero; |
875 |
|
|
if set to G_DISCARD then NULL will be returned. C<hash> can be a valid |
876 |
|
|
precomputed hash value, or 0 to ask for it to be computed. |
877 |
|
|
|
878 |
|
|
=cut |
879 |
|
|
*/ |
880 |
|
|
|
881 |
|
|
SV * |
882 |
|
|
Perl_hv_delete_ent(pTHX_ HV *hv, SV *keysv, I32 flags, U32 hash) |
883 |
|
|
{ |
884 |
|
|
return hv_delete_common(hv, keysv, NULL, 0, 0, flags, hash); |
885 |
|
|
} |
886 |
|
|
|
887 |
|
|
STATIC SV * |
888 |
|
|
S_hv_delete_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, |
889 |
|
|
int k_flags, I32 d_flags, U32 hash) |
890 |
|
|
{ |
891 |
|
|
register XPVHV* xhv; |
892 |
|
|
register I32 i; |
893 |
|
|
register HE *entry; |
894 |
|
|
register HE **oentry; |
895 |
|
|
SV *sv; |
896 |
|
|
bool is_utf8; |
897 |
|
|
int masked_flags; |
898 |
|
|
|
899 |
|
|
if (!hv) |
900 |
|
|
return Nullsv; |
901 |
|
|
|
902 |
|
|
if (keysv) { |
903 |
|
|
if (k_flags & HVhek_FREEKEY) |
904 |
|
|
Safefree(key); |
905 |
|
|
key = SvPV(keysv, klen); |
906 |
|
|
k_flags = 0; |
907 |
|
|
is_utf8 = (SvUTF8(keysv) != 0); |
908 |
|
|
} else { |
909 |
|
|
is_utf8 = ((k_flags & HVhek_UTF8) ? TRUE : FALSE); |
910 |
|
|
} |
911 |
|
|
|
912 |
|
|
if (SvRMAGICAL(hv)) { |
913 |
|
|
bool needs_copy; |
914 |
|
|
bool needs_store; |
915 |
|
|
hv_magic_check (hv, &needs_copy, &needs_store); |
916 |
|
|
|
917 |
|
|
if (needs_copy) { |
918 |
|
|
entry = hv_fetch_common(hv, keysv, key, klen, |
919 |
|
|
k_flags & ~HVhek_FREEKEY, HV_FETCH_LVALUE, |
920 |
|
|
Nullsv, hash); |
921 |
|
|
sv = entry ? HeVAL(entry) : NULL; |
922 |
|
|
if (sv) { |
923 |
|
|
if (SvMAGICAL(sv)) { |
924 |
|
|
mg_clear(sv); |
925 |
|
|
} |
926 |
|
|
if (!needs_store) { |
927 |
|
|
if (mg_find(sv, PERL_MAGIC_tiedelem)) { |
928 |
|
|
/* No longer an element */ |
929 |
|
|
sv_unmagic(sv, PERL_MAGIC_tiedelem); |
930 |
|
|
return sv; |
931 |
|
|
} |
932 |
|
|
return Nullsv; /* element cannot be deleted */ |
933 |
|
|
} |
934 |
|
|
#ifdef ENV_IS_CASELESS |
935 |
|
|
else if (mg_find((SV*)hv, PERL_MAGIC_env)) { |
936 |
|
|
/* XXX This code isn't UTF8 clean. */ |
937 |
|
|
keysv = sv_2mortal(newSVpvn(key,klen)); |
938 |
|
|
if (k_flags & HVhek_FREEKEY) { |
939 |
|
|
Safefree(key); |
940 |
|
|
} |
941 |
|
|
key = strupr(SvPVX(keysv)); |
942 |
|
|
is_utf8 = 0; |
943 |
|
|
k_flags = 0; |
944 |
|
|
hash = 0; |
945 |
|
|
} |
946 |
|
|
#endif |
947 |
|
|
} |
948 |
|
|
} |
949 |
|
|
} |
950 |
|
|
xhv = (XPVHV*)SvANY(hv); |
951 |
|
|
if (!xhv->xhv_array /* !HvARRAY(hv) */) |
952 |
|
|
return Nullsv; |
953 |
|
|
|
954 |
|
|
if (is_utf8) { |
955 |
|
|
const char *keysave = key; |
956 |
|
|
key = (char*)bytes_from_utf8((U8*)key, &klen, &is_utf8); |
957 |
|
|
|
958 |
|
|
if (is_utf8) |
959 |
|
|
k_flags |= HVhek_UTF8; |
960 |
|
|
else |
961 |
|
|
k_flags &= ~HVhek_UTF8; |
962 |
|
|
if (key != keysave) { |
963 |
|
|
if (k_flags & HVhek_FREEKEY) { |
964 |
|
|
/* This shouldn't happen if our caller does what we expect, |
965 |
|
|
but strictly the API allows it. */ |
966 |
|
|
Safefree(keysave); |
967 |
|
|
} |
968 |
|
|
k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY; |
969 |
|
|
} |
970 |
|
|
HvHASKFLAGS_on((SV*)hv); |
971 |
|
|
} |
972 |
|
|
|
973 |
|
|
if (HvREHASH(hv)) { |
974 |
|
|
PERL_HASH_INTERNAL(hash, key, klen); |
975 |
|
|
} else if (!hash) { |
976 |
|
|
/* Not enough shared hash key scalars around to make this worthwhile |
977 |
|
|
(about 4% slowdown in perlbench with this in) |
978 |
|
|
if (keysv && (SvIsCOW_shared_hash(keysv))) { |
979 |
|
|
hash = SvUVX(keysv); |
980 |
|
|
} else |
981 |
|
|
*/ |
982 |
|
|
{ |
983 |
|
|
PERL_HASH(hash, key, klen); |
984 |
|
|
} |
985 |
|
|
} |
986 |
|
|
|
987 |
|
|
masked_flags = (k_flags & HVhek_MASK); |
988 |
|
|
|
989 |
|
|
/* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */ |
990 |
|
|
oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; |
991 |
|
|
entry = *oentry; |
992 |
|
|
i = 1; |
993 |
|
|
for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) { |
994 |
|
|
if (HeHASH(entry) != hash) /* strings can't be equal */ |
995 |
|
|
continue; |
996 |
|
|
if (HeKLEN(entry) != (I32)klen) |
997 |
|
|
continue; |
998 |
|
|
if (HeKEY(entry) != key && memNE(HeKEY(entry),key,klen)) /* is this it? */ |
999 |
|
|
continue; |
1000 |
|
|
if ((HeKFLAGS(entry) ^ masked_flags) & HVhek_UTF8) |
1001 |
|
|
continue; |
1002 |
|
|
|
1003 |
|
|
/* if placeholder is here, it's already been deleted.... */ |
1004 |
|
|
if (HeVAL(entry) == &PL_sv_placeholder) |
1005 |
|
|
{ |
1006 |
|
|
if (k_flags & HVhek_FREEKEY) |
1007 |
|
|
Safefree(key); |
1008 |
|
|
return Nullsv; |
1009 |
|
|
} |
1010 |
|
|
else if (SvREADONLY(hv) && HeVAL(entry) && SvREADONLY(HeVAL(entry))) { |
1011 |
|
|
S_hv_notallowed(aTHX_ k_flags, key, klen, |
1012 |
|
|
"delete readonly key '%"SVf"' from" |
1013 |
|
|
); |
1014 |
|
|
} |
1015 |
|
|
if (k_flags & HVhek_FREEKEY) |
1016 |
|
|
Safefree(key); |
1017 |
|
|
|
1018 |
|
|
if (d_flags & G_DISCARD) |
1019 |
|
|
sv = Nullsv; |
1020 |
|
|
else { |
1021 |
|
|
sv = sv_2mortal(HeVAL(entry)); |
1022 |
|
|
HeVAL(entry) = &PL_sv_placeholder; |
1023 |
|
|
} |
1024 |
|
|
|
1025 |
|
|
/* |
1026 |
|
|
* If a restricted hash, rather than really deleting the entry, put |
1027 |
|
|
* a placeholder there. This marks the key as being "approved", so |
1028 |
|
|
* we can still access via not-really-existing key without raising |
1029 |
|
|
* an error. |
1030 |
|
|
*/ |
1031 |
|
|
if (SvREADONLY(hv)) { |
1032 |
|
|
SvREFCNT_dec(HeVAL(entry)); |
1033 |
|
|
HeVAL(entry) = &PL_sv_placeholder; |
1034 |
|
|
/* We'll be saving this slot, so the number of allocated keys |
1035 |
|
|
* doesn't go down, but the number placeholders goes up */ |
1036 |
|
|
xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */ |
1037 |
|
|
} else { |
1038 |
|
|
*oentry = HeNEXT(entry); |
1039 |
|
|
if (i && !*oentry) |
1040 |
|
|
xhv->xhv_fill--; /* HvFILL(hv)-- */ |
1041 |
|
|
if (entry == xhv->xhv_eiter /* HvEITER(hv) */) |
1042 |
|
|
HvLAZYDEL_on(hv); |
1043 |
|
|
else |
1044 |
|
|
hv_free_ent(hv, entry); |
1045 |
|
|
xhv->xhv_keys--; /* HvKEYS(hv)-- */ |
1046 |
|
|
if (xhv->xhv_keys == 0) |
1047 |
|
|
HvHASKFLAGS_off(hv); |
1048 |
|
|
} |
1049 |
|
|
return sv; |
1050 |
|
|
} |
1051 |
|
|
if (SvREADONLY(hv)) { |
1052 |
|
|
S_hv_notallowed(aTHX_ k_flags, key, klen, |
1053 |
|
|
"delete disallowed key '%"SVf"' from" |
1054 |
|
|
); |
1055 |
|
|
} |
1056 |
|
|
|
1057 |
|
|
if (k_flags & HVhek_FREEKEY) |
1058 |
|
|
Safefree(key); |
1059 |
|
|
return Nullsv; |
1060 |
|
|
} |
1061 |
|
|
|
1062 |
|
|
STATIC void |
1063 |
|
|
S_hsplit(pTHX_ HV *hv) |
1064 |
|
|
{ |
1065 |
|
|
register XPVHV* xhv = (XPVHV*)SvANY(hv); |
1066 |
|
|
I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */ |
1067 |
|
|
register I32 newsize = oldsize * 2; |
1068 |
|
|
register I32 i; |
1069 |
|
|
register char *a = xhv->xhv_array; /* HvARRAY(hv) */ |
1070 |
|
|
register HE **aep; |
1071 |
|
|
register HE **bep; |
1072 |
|
|
register HE *entry; |
1073 |
|
|
register HE **oentry; |
1074 |
|
|
int longest_chain = 0; |
1075 |
|
|
int was_shared; |
1076 |
|
|
|
1077 |
|
|
/*PerlIO_printf(PerlIO_stderr(), "hsplit called for %p which had %d\n", |
1078 |
|
|
hv, (int) oldsize);*/ |
1079 |
|
|
|
1080 |
|
|
if (HvPLACEHOLDERS(hv) && !SvREADONLY(hv)) { |
1081 |
|
|
/* Can make this clear any placeholders first for non-restricted hashes, |
1082 |
|
|
even though Storable rebuilds restricted hashes by putting in all the |
1083 |
|
|
placeholders (first) before turning on the readonly flag, because |
1084 |
|
|
Storable always pre-splits the hash. */ |
1085 |
|
|
hv_clear_placeholders(hv); |
1086 |
|
|
} |
1087 |
|
|
|
1088 |
|
|
PL_nomemok = TRUE; |
1089 |
|
|
#if defined(STRANGE_MALLOC) || defined(MYMALLOC) |
1090 |
|
|
Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char); |
1091 |
|
|
if (!a) { |
1092 |
|
|
PL_nomemok = FALSE; |
1093 |
|
|
return; |
1094 |
|
|
} |
1095 |
|
|
#else |
1096 |
|
|
New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char); |
1097 |
|
|
if (!a) { |
1098 |
|
|
PL_nomemok = FALSE; |
1099 |
|
|
return; |
1100 |
|
|
} |
1101 |
|
|
Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char); |
1102 |
|
|
if (oldsize >= 64) { |
1103 |
|
|
offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */, |
1104 |
|
|
PERL_HV_ARRAY_ALLOC_BYTES(oldsize)); |
1105 |
|
|
} |
1106 |
|
|
else |
1107 |
|
|
Safefree(xhv->xhv_array /* HvARRAY(hv) */); |
1108 |
|
|
#endif |
1109 |
|
|
|
1110 |
|
|
PL_nomemok = FALSE; |
1111 |
|
|
Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/ |
1112 |
|
|
xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */ |
1113 |
|
|
xhv->xhv_array = a; /* HvARRAY(hv) = a */ |
1114 |
|
|
aep = (HE**)a; |
1115 |
|
|
|
1116 |
|
|
for (i=0; i<oldsize; i++,aep++) { |
1117 |
|
|
int left_length = 0; |
1118 |
|
|
int right_length = 0; |
1119 |
|
|
|
1120 |
|
|
if (!*aep) /* non-existent */ |
1121 |
|
|
continue; |
1122 |
|
|
bep = aep+oldsize; |
1123 |
|
|
for (oentry = aep, entry = *aep; entry; entry = *oentry) { |
1124 |
|
|
if ((HeHASH(entry) & newsize) != (U32)i) { |
1125 |
|
|
*oentry = HeNEXT(entry); |
1126 |
|
|
HeNEXT(entry) = *bep; |
1127 |
|
|
if (!*bep) |
1128 |
|
|
xhv->xhv_fill++; /* HvFILL(hv)++ */ |
1129 |
|
|
*bep = entry; |
1130 |
|
|
right_length++; |
1131 |
|
|
continue; |
1132 |
|
|
} |
1133 |
|
|
else { |
1134 |
|
|
oentry = &HeNEXT(entry); |
1135 |
|
|
left_length++; |
1136 |
|
|
} |
1137 |
|
|
} |
1138 |
|
|
if (!*aep) /* everything moved */ |
1139 |
|
|
xhv->xhv_fill--; /* HvFILL(hv)-- */ |
1140 |
|
|
/* I think we don't actually need to keep track of the longest length, |
1141 |
|
|
merely flag if anything is too long. But for the moment while |
1142 |
|
|
developing this code I'll track it. */ |
1143 |
|
|
if (left_length > longest_chain) |
1144 |
|
|
longest_chain = left_length; |
1145 |
|
|
if (right_length > longest_chain) |
1146 |
|
|
longest_chain = right_length; |
1147 |
|
|
} |
1148 |
|
|
|
1149 |
|
|
|
1150 |
|
|
/* Pick your policy for "hashing isn't working" here: */ |
1151 |
|
|
if (longest_chain <= HV_MAX_LENGTH_BEFORE_SPLIT /* split worked? */ |
1152 |
|
|
|| HvREHASH(hv)) { |
1153 |
|
|
return; |
1154 |
|
|
} |
1155 |
|
|
|
1156 |
|
|
if (hv == PL_strtab) { |
1157 |
|
|
/* Urg. Someone is doing something nasty to the string table. |
1158 |
|
|
Can't win. */ |
1159 |
|
|
return; |
1160 |
|
|
} |
1161 |
|
|
|
1162 |
|
|
/* Awooga. Awooga. Pathological data. */ |
1163 |
|
|
/*PerlIO_printf(PerlIO_stderr(), "%p %d of %d with %d/%d buckets\n", hv, |
1164 |
|
|
longest_chain, HvTOTALKEYS(hv), HvFILL(hv), 1+HvMAX(hv));*/ |
1165 |
|
|
|
1166 |
|
|
++newsize; |
1167 |
|
|
Newz(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char); |
1168 |
|
|
was_shared = HvSHAREKEYS(hv); |
1169 |
|
|
|
1170 |
|
|
xhv->xhv_fill = 0; |
1171 |
|
|
HvSHAREKEYS_off(hv); |
1172 |
|
|
HvREHASH_on(hv); |
1173 |
|
|
|
1174 |
|
|
aep = (HE **) xhv->xhv_array; |
1175 |
|
|
|
1176 |
|
|
for (i=0; i<newsize; i++,aep++) { |
1177 |
|
|
entry = *aep; |
1178 |
|
|
while (entry) { |
1179 |
|
|
/* We're going to trash this HE's next pointer when we chain it |
1180 |
|
|
into the new hash below, so store where we go next. */ |
1181 |
|
|
HE *next = HeNEXT(entry); |
1182 |
|
|
UV hash; |
1183 |
|
|
|
1184 |
|
|
/* Rehash it */ |
1185 |
|
|
PERL_HASH_INTERNAL(hash, HeKEY(entry), HeKLEN(entry)); |
1186 |
|
|
|
1187 |
|
|
if (was_shared) { |
1188 |
|
|
/* Unshare it. */ |
1189 |
|
|
HEK *new_hek |
1190 |
|
|
= save_hek_flags(HeKEY(entry), HeKLEN(entry), |
1191 |
|
|
hash, HeKFLAGS(entry)); |
1192 |
|
|
unshare_hek (HeKEY_hek(entry)); |
1193 |
|
|
HeKEY_hek(entry) = new_hek; |
1194 |
|
|
} else { |
1195 |
|
|
/* Not shared, so simply write the new hash in. */ |
1196 |
|
|
HeHASH(entry) = hash; |
1197 |
|
|
} |
1198 |
|
|
/*PerlIO_printf(PerlIO_stderr(), "%d ", HeKFLAGS(entry));*/ |
1199 |
|
|
HEK_REHASH_on(HeKEY_hek(entry)); |
1200 |
|
|
/*PerlIO_printf(PerlIO_stderr(), "%d\n", HeKFLAGS(entry));*/ |
1201 |
|
|
|
1202 |
|
|
/* Copy oentry to the correct new chain. */ |
1203 |
|
|
bep = ((HE**)a) + (hash & (I32) xhv->xhv_max); |
1204 |
|
|
if (!*bep) |
1205 |
|
|
xhv->xhv_fill++; /* HvFILL(hv)++ */ |
1206 |
|
|
HeNEXT(entry) = *bep; |
1207 |
|
|
*bep = entry; |
1208 |
|
|
|
1209 |
|
|
entry = next; |
1210 |
|
|
} |
1211 |
|
|
} |
1212 |
|
|
Safefree (xhv->xhv_array); |
1213 |
|
|
xhv->xhv_array = a; /* HvARRAY(hv) = a */ |
1214 |
|
|
} |
1215 |
|
|
|
1216 |
|
|
void |
1217 |
|
|
Perl_hv_ksplit(pTHX_ HV *hv, IV newmax) |
1218 |
|
|
{ |
1219 |
|
|
register XPVHV* xhv = (XPVHV*)SvANY(hv); |
1220 |
|
|
I32 oldsize = (I32) xhv->xhv_max+1; /* HvMAX(hv)+1 (sick) */ |
1221 |
|
|
register I32 newsize; |
1222 |
|
|
register I32 i; |
1223 |
|
|
register I32 j; |
1224 |
|
|
register char *a; |
1225 |
|
|
register HE **aep; |
1226 |
|
|
register HE *entry; |
1227 |
|
|
register HE **oentry; |
1228 |
|
|
|
1229 |
|
|
newsize = (I32) newmax; /* possible truncation here */ |
1230 |
|
|
if (newsize != newmax || newmax <= oldsize) |
1231 |
|
|
return; |
1232 |
|
|
while ((newsize & (1 + ~newsize)) != newsize) { |
1233 |
|
|
newsize &= ~(newsize & (1 + ~newsize)); /* get proper power of 2 */ |
1234 |
|
|
} |
1235 |
|
|
if (newsize < newmax) |
1236 |
|
|
newsize *= 2; |
1237 |
|
|
if (newsize < newmax) |
1238 |
|
|
return; /* overflow detection */ |
1239 |
|
|
|
1240 |
|
|
a = xhv->xhv_array; /* HvARRAY(hv) */ |
1241 |
|
|
if (a) { |
1242 |
|
|
PL_nomemok = TRUE; |
1243 |
|
|
#if defined(STRANGE_MALLOC) || defined(MYMALLOC) |
1244 |
|
|
Renew(a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char); |
1245 |
|
|
if (!a) { |
1246 |
|
|
PL_nomemok = FALSE; |
1247 |
|
|
return; |
1248 |
|
|
} |
1249 |
|
|
#else |
1250 |
|
|
New(2, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char); |
1251 |
|
|
if (!a) { |
1252 |
|
|
PL_nomemok = FALSE; |
1253 |
|
|
return; |
1254 |
|
|
} |
1255 |
|
|
Copy(xhv->xhv_array /* HvARRAY(hv) */, a, oldsize * sizeof(HE*), char); |
1256 |
|
|
if (oldsize >= 64) { |
1257 |
|
|
offer_nice_chunk(xhv->xhv_array /* HvARRAY(hv) */, |
1258 |
|
|
PERL_HV_ARRAY_ALLOC_BYTES(oldsize)); |
1259 |
|
|
} |
1260 |
|
|
else |
1261 |
|
|
Safefree(xhv->xhv_array /* HvARRAY(hv) */); |
1262 |
|
|
#endif |
1263 |
|
|
PL_nomemok = FALSE; |
1264 |
|
|
Zero(&a[oldsize * sizeof(HE*)], (newsize-oldsize) * sizeof(HE*), char); /* zero 2nd half*/ |
1265 |
|
|
} |
1266 |
|
|
else { |
1267 |
|
|
Newz(0, a, PERL_HV_ARRAY_ALLOC_BYTES(newsize), char); |
1268 |
|
|
} |
1269 |
|
|
xhv->xhv_max = --newsize; /* HvMAX(hv) = --newsize */ |
1270 |
|
|
xhv->xhv_array = a; /* HvARRAY(hv) = a */ |
1271 |
|
|
if (!xhv->xhv_fill /* !HvFILL(hv) */) /* skip rest if no entries */ |
1272 |
|
|
return; |
1273 |
|
|
|
1274 |
|
|
aep = (HE**)a; |
1275 |
|
|
for (i=0; i<oldsize; i++,aep++) { |
1276 |
|
|
if (!*aep) /* non-existent */ |
1277 |
|
|
continue; |
1278 |
|
|
for (oentry = aep, entry = *aep; entry; entry = *oentry) { |
1279 |
|
|
if ((j = (HeHASH(entry) & newsize)) != i) { |
1280 |
|
|
j -= i; |
1281 |
|
|
*oentry = HeNEXT(entry); |
1282 |
|
|
if (!(HeNEXT(entry) = aep[j])) |
1283 |
|
|
xhv->xhv_fill++; /* HvFILL(hv)++ */ |
1284 |
|
|
aep[j] = entry; |
1285 |
|
|
continue; |
1286 |
|
|
} |
1287 |
|
|
else |
1288 |
|
|
oentry = &HeNEXT(entry); |
1289 |
|
|
} |
1290 |
|
|
if (!*aep) /* everything moved */ |
1291 |
|
|
xhv->xhv_fill--; /* HvFILL(hv)-- */ |
1292 |
|
|
} |
1293 |
|
|
} |
1294 |
|
|
|
1295 |
|
|
/* |
1296 |
|
|
=for apidoc newHV |
1297 |
|
|
|
1298 |
|
|
Creates a new HV. The reference count is set to 1. |
1299 |
|
|
|
1300 |
|
|
=cut |
1301 |
|
|
*/ |
1302 |
|
|
|
1303 |
|
|
HV * |
1304 |
|
|
Perl_newHV(pTHX) |
1305 |
|
|
{ |
1306 |
|
|
register HV *hv; |
1307 |
|
|
register XPVHV* xhv; |
1308 |
|
|
|
1309 |
|
|
hv = (HV*)NEWSV(502,0); |
1310 |
|
|
sv_upgrade((SV *)hv, SVt_PVHV); |
1311 |
|
|
xhv = (XPVHV*)SvANY(hv); |
1312 |
|
|
SvPOK_off(hv); |
1313 |
|
|
SvNOK_off(hv); |
1314 |
|
|
#ifndef NODEFAULT_SHAREKEYS |
1315 |
|
|
HvSHAREKEYS_on(hv); /* key-sharing on by default */ |
1316 |
|
|
#endif |
1317 |
|
|
|
1318 |
|
|
xhv->xhv_max = 7; /* HvMAX(hv) = 7 (start with 8 buckets) */ |
1319 |
|
|
xhv->xhv_fill = 0; /* HvFILL(hv) = 0 */ |
1320 |
|
|
xhv->xhv_pmroot = 0; /* HvPMROOT(hv) = 0 */ |
1321 |
|
|
(void)hv_iterinit(hv); /* so each() will start off right */ |
1322 |
|
|
return hv; |
1323 |
|
|
} |
1324 |
|
|
|
1325 |
|
|
HV * |
1326 |
|
|
Perl_newHVhv(pTHX_ HV *ohv) |
1327 |
|
|
{ |
1328 |
|
|
HV *hv = newHV(); |
1329 |
|
|
STRLEN hv_max, hv_fill; |
1330 |
|
|
|
1331 |
|
|
if (!ohv || (hv_fill = HvFILL(ohv)) == 0) |
1332 |
|
|
return hv; |
1333 |
|
|
hv_max = HvMAX(ohv); |
1334 |
|
|
|
1335 |
|
|
if (!SvMAGICAL((SV *)ohv)) { |
1336 |
|
|
/* It's an ordinary hash, so copy it fast. AMS 20010804 */ |
1337 |
|
|
STRLEN i; |
1338 |
|
|
bool shared = !!HvSHAREKEYS(ohv); |
1339 |
|
|
HE **ents, **oents = (HE **)HvARRAY(ohv); |
1340 |
|
|
char *a; |
1341 |
|
|
New(0, a, PERL_HV_ARRAY_ALLOC_BYTES(hv_max+1), char); |
1342 |
|
|
ents = (HE**)a; |
1343 |
|
|
|
1344 |
|
|
/* In each bucket... */ |
1345 |
|
|
for (i = 0; i <= hv_max; i++) { |
1346 |
|
|
HE *prev = NULL, *ent = NULL, *oent = oents[i]; |
1347 |
|
|
|
1348 |
|
|
if (!oent) { |
1349 |
|
|
ents[i] = NULL; |
1350 |
|
|
continue; |
1351 |
|
|
} |
1352 |
|
|
|
1353 |
|
|
/* Copy the linked list of entries. */ |
1354 |
|
|
for (oent = oents[i]; oent; oent = HeNEXT(oent)) { |
1355 |
|
|
U32 hash = HeHASH(oent); |
1356 |
|
|
char *key = HeKEY(oent); |
1357 |
|
|
STRLEN len = HeKLEN(oent); |
1358 |
|
|
int flags = HeKFLAGS(oent); |
1359 |
|
|
|
1360 |
|
|
ent = new_HE(); |
1361 |
|
|
HeVAL(ent) = newSVsv(HeVAL(oent)); |
1362 |
|
|
HeKEY_hek(ent) |
1363 |
|
|
= shared ? share_hek_flags(key, len, hash, flags) |
1364 |
|
|
: save_hek_flags(key, len, hash, flags); |
1365 |
|
|
if (prev) |
1366 |
|
|
HeNEXT(prev) = ent; |
1367 |
|
|
else |
1368 |
|
|
ents[i] = ent; |
1369 |
|
|
prev = ent; |
1370 |
|
|
HeNEXT(ent) = NULL; |
1371 |
|
|
} |
1372 |
|
|
} |
1373 |
|
|
|
1374 |
|
|
HvMAX(hv) = hv_max; |
1375 |
|
|
HvFILL(hv) = hv_fill; |
1376 |
|
|
HvTOTALKEYS(hv) = HvTOTALKEYS(ohv); |
1377 |
|
|
HvARRAY(hv) = ents; |
1378 |
|
|
} |
1379 |
|
|
else { |
1380 |
|
|
/* Iterate over ohv, copying keys and values one at a time. */ |
1381 |
|
|
HE *entry; |
1382 |
|
|
I32 riter = HvRITER(ohv); |
1383 |
|
|
HE *eiter = HvEITER(ohv); |
1384 |
|
|
|
1385 |
|
|
/* Can we use fewer buckets? (hv_max is always 2^n-1) */ |
1386 |
|
|
while (hv_max && hv_max + 1 >= hv_fill * 2) |
1387 |
|
|
hv_max = hv_max / 2; |
1388 |
|
|
HvMAX(hv) = hv_max; |
1389 |
|
|
|
1390 |
|
|
hv_iterinit(ohv); |
1391 |
|
|
while ((entry = hv_iternext_flags(ohv, 0))) { |
1392 |
|
|
hv_store_flags(hv, HeKEY(entry), HeKLEN(entry), |
1393 |
|
|
newSVsv(HeVAL(entry)), HeHASH(entry), |
1394 |
|
|
HeKFLAGS(entry)); |
1395 |
|
|
} |
1396 |
|
|
HvRITER(ohv) = riter; |
1397 |
|
|
HvEITER(ohv) = eiter; |
1398 |
|
|
} |
1399 |
|
|
|
1400 |
|
|
return hv; |
1401 |
|
|
} |
1402 |
|
|
|
1403 |
|
|
void |
1404 |
|
|
Perl_hv_free_ent(pTHX_ HV *hv, register HE *entry) |
1405 |
|
|
{ |
1406 |
|
|
SV *val; |
1407 |
|
|
|
1408 |
|
|
if (!entry) |
1409 |
|
|
return; |
1410 |
|
|
val = HeVAL(entry); |
1411 |
|
|
if (val && isGV(val) && GvCVu(val) && HvNAME(hv)) |
1412 |
|
|
PL_sub_generation++; /* may be deletion of method from stash */ |
1413 |
|
|
SvREFCNT_dec(val); |
1414 |
|
|
if (HeKLEN(entry) == HEf_SVKEY) { |
1415 |
|
|
SvREFCNT_dec(HeKEY_sv(entry)); |
1416 |
|
|
Safefree(HeKEY_hek(entry)); |
1417 |
|
|
} |
1418 |
|
|
else if (HvSHAREKEYS(hv)) |
1419 |
|
|
unshare_hek(HeKEY_hek(entry)); |
1420 |
|
|
else |
1421 |
|
|
Safefree(HeKEY_hek(entry)); |
1422 |
|
|
del_HE(entry); |
1423 |
|
|
} |
1424 |
|
|
|
1425 |
|
|
void |
1426 |
|
|
Perl_hv_delayfree_ent(pTHX_ HV *hv, register HE *entry) |
1427 |
|
|
{ |
1428 |
|
|
if (!entry) |
1429 |
|
|
return; |
1430 |
|
|
if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv)) |
1431 |
|
|
PL_sub_generation++; /* may be deletion of method from stash */ |
1432 |
|
|
sv_2mortal(HeVAL(entry)); /* free between statements */ |
1433 |
|
|
if (HeKLEN(entry) == HEf_SVKEY) { |
1434 |
|
|
sv_2mortal(HeKEY_sv(entry)); |
1435 |
|
|
Safefree(HeKEY_hek(entry)); |
1436 |
|
|
} |
1437 |
|
|
else if (HvSHAREKEYS(hv)) |
1438 |
|
|
unshare_hek(HeKEY_hek(entry)); |
1439 |
|
|
else |
1440 |
|
|
Safefree(HeKEY_hek(entry)); |
1441 |
|
|
del_HE(entry); |
1442 |
|
|
} |
1443 |
|
|
|
1444 |
|
|
/* |
1445 |
|
|
=for apidoc hv_clear |
1446 |
|
|
|
1447 |
|
|
Clears a hash, making it empty. |
1448 |
|
|
|
1449 |
|
|
=cut |
1450 |
|
|
*/ |
1451 |
|
|
|
1452 |
|
|
void |
1453 |
|
|
Perl_hv_clear(pTHX_ HV *hv) |
1454 |
|
|
{ |
1455 |
|
|
register XPVHV* xhv; |
1456 |
|
|
if (!hv) |
1457 |
|
|
return; |
1458 |
|
|
|
1459 |
|
|
xhv = (XPVHV*)SvANY(hv); |
1460 |
|
|
|
1461 |
|
|
if (SvREADONLY(hv) && xhv->xhv_array != NULL) { |
1462 |
|
|
/* restricted hash: convert all keys to placeholders */ |
1463 |
|
|
I32 i; |
1464 |
|
|
HE* entry; |
1465 |
|
|
for (i = 0; i <= (I32) xhv->xhv_max; i++) { |
1466 |
|
|
entry = ((HE**)xhv->xhv_array)[i]; |
1467 |
|
|
for (; entry; entry = HeNEXT(entry)) { |
1468 |
|
|
/* not already placeholder */ |
1469 |
|
|
if (HeVAL(entry) != &PL_sv_placeholder) { |
1470 |
|
|
if (HeVAL(entry) && SvREADONLY(HeVAL(entry))) { |
1471 |
|
|
SV* keysv = hv_iterkeysv(entry); |
1472 |
|
|
Perl_croak(aTHX_ |
1473 |
|
|
"Attempt to delete readonly key '%"SVf"' from a restricted hash", |
1474 |
|
|
keysv); |
1475 |
|
|
} |
1476 |
|
|
SvREFCNT_dec(HeVAL(entry)); |
1477 |
|
|
HeVAL(entry) = &PL_sv_placeholder; |
1478 |
|
|
xhv->xhv_placeholders++; /* HvPLACEHOLDERS(hv)++ */ |
1479 |
|
|
} |
1480 |
|
|
} |
1481 |
|
|
} |
1482 |
|
|
goto reset; |
1483 |
|
|
} |
1484 |
|
|
|
1485 |
|
|
hfreeentries(hv); |
1486 |
|
|
xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */ |
1487 |
|
|
if (xhv->xhv_array /* HvARRAY(hv) */) |
1488 |
|
|
(void)memzero(xhv->xhv_array /* HvARRAY(hv) */, |
1489 |
|
|
(xhv->xhv_max+1 /* HvMAX(hv)+1 */) * sizeof(HE*)); |
1490 |
|
|
|
1491 |
|
|
if (SvRMAGICAL(hv)) |
1492 |
|
|
mg_clear((SV*)hv); |
1493 |
|
|
|
1494 |
|
|
HvHASKFLAGS_off(hv); |
1495 |
|
|
HvREHASH_off(hv); |
1496 |
|
|
reset: |
1497 |
|
|
HvEITER(hv) = NULL; |
1498 |
|
|
} |
1499 |
|
|
|
1500 |
|
|
/* |
1501 |
|
|
=for apidoc hv_clear_placeholders |
1502 |
|
|
|
1503 |
|
|
Clears any placeholders from a hash. If a restricted hash has any of its keys |
1504 |
|
|
marked as readonly and the key is subsequently deleted, the key is not actually |
1505 |
|
|
deleted but is marked by assigning it a value of &PL_sv_placeholder. This tags |
1506 |
|
|
it so it will be ignored by future operations such as iterating over the hash, |
1507 |
|
|
but will still allow the hash to have a value reassigned to the key at some |
1508 |
|
|
future point. This function clears any such placeholder keys from the hash. |
1509 |
|
|
See Hash::Util::lock_keys() for an example of its use. |
1510 |
|
|
|
1511 |
|
|
=cut |
1512 |
|
|
*/ |
1513 |
|
|
|
1514 |
|
|
void |
1515 |
|
|
Perl_hv_clear_placeholders(pTHX_ HV *hv) |
1516 |
|
|
{ |
1517 |
|
|
I32 items = (I32)HvPLACEHOLDERS(hv); |
1518 |
|
|
I32 i = HvMAX(hv); |
1519 |
|
|
|
1520 |
|
|
if (items == 0) |
1521 |
|
|
return; |
1522 |
|
|
|
1523 |
|
|
do { |
1524 |
|
|
/* Loop down the linked list heads */ |
1525 |
|
|
int first = 1; |
1526 |
|
|
HE **oentry = &(HvARRAY(hv))[i]; |
1527 |
|
|
HE *entry = *oentry; |
1528 |
|
|
|
1529 |
|
|
if (!entry) |
1530 |
|
|
continue; |
1531 |
|
|
|
1532 |
|
|
for (; entry; entry = *oentry) { |
1533 |
|
|
if (HeVAL(entry) == &PL_sv_placeholder) { |
1534 |
|
|
*oentry = HeNEXT(entry); |
1535 |
|
|
if (first && !*oentry) |
1536 |
|
|
HvFILL(hv)--; /* This linked list is now empty. */ |
1537 |
|
|
if (HvEITER(hv)) |
1538 |
|
|
HvLAZYDEL_on(hv); |
1539 |
|
|
else |
1540 |
|
|
hv_free_ent(hv, entry); |
1541 |
|
|
|
1542 |
|
|
if (--items == 0) { |
1543 |
|
|
/* Finished. */ |
1544 |
|
|
HvTOTALKEYS(hv) -= (IV)HvPLACEHOLDERS(hv); |
1545 |
|
|
if (HvKEYS(hv) == 0) |
1546 |
|
|
HvHASKFLAGS_off(hv); |
1547 |
|
|
HvPLACEHOLDERS(hv) = 0; |
1548 |
|
|
return; |
1549 |
|
|
} |
1550 |
|
|
} else { |
1551 |
|
|
oentry = &HeNEXT(entry); |
1552 |
|
|
first = 0; |
1553 |
|
|
} |
1554 |
|
|
} |
1555 |
|
|
} while (--i >= 0); |
1556 |
|
|
/* You can't get here, hence assertion should always fail. */ |
1557 |
|
|
assert (items == 0); |
1558 |
|
|
assert (0); |
1559 |
|
|
} |
1560 |
|
|
|
1561 |
|
|
STATIC void |
1562 |
|
|
S_hfreeentries(pTHX_ HV *hv) |
1563 |
|
|
{ |
1564 |
|
|
register HE **array; |
1565 |
|
|
register HE *entry; |
1566 |
|
|
register HE *oentry = Null(HE*); |
1567 |
|
|
I32 riter; |
1568 |
|
|
I32 max; |
1569 |
|
|
|
1570 |
|
|
if (!hv) |
1571 |
|
|
return; |
1572 |
|
|
if (!HvARRAY(hv)) |
1573 |
|
|
return; |
1574 |
|
|
|
1575 |
|
|
riter = 0; |
1576 |
|
|
max = HvMAX(hv); |
1577 |
|
|
array = HvARRAY(hv); |
1578 |
|
|
/* make everyone else think the array is empty, so that the destructors |
1579 |
|
|
* called for freed entries can't recusively mess with us */ |
1580 |
|
|
HvARRAY(hv) = Null(HE**); |
1581 |
|
|
HvFILL(hv) = 0; |
1582 |
|
|
((XPVHV*) SvANY(hv))->xhv_keys = 0; |
1583 |
|
|
|
1584 |
|
|
entry = array[0]; |
1585 |
|
|
for (;;) { |
1586 |
|
|
if (entry) { |
1587 |
|
|
oentry = entry; |
1588 |
|
|
entry = HeNEXT(entry); |
1589 |
|
|
hv_free_ent(hv, oentry); |
1590 |
|
|
} |
1591 |
|
|
if (!entry) { |
1592 |
|
|
if (++riter > max) |
1593 |
|
|
break; |
1594 |
|
|
entry = array[riter]; |
1595 |
|
|
} |
1596 |
|
|
} |
1597 |
|
|
HvARRAY(hv) = array; |
1598 |
|
|
(void)hv_iterinit(hv); |
1599 |
|
|
} |
1600 |
|
|
|
1601 |
|
|
/* |
1602 |
|
|
=for apidoc hv_undef |
1603 |
|
|
|
1604 |
|
|
Undefines the hash. |
1605 |
|
|
|
1606 |
|
|
=cut |
1607 |
|
|
*/ |
1608 |
|
|
|
1609 |
|
|
void |
1610 |
|
|
Perl_hv_undef(pTHX_ HV *hv) |
1611 |
|
|
{ |
1612 |
|
|
register XPVHV* xhv; |
1613 |
|
|
if (!hv) |
1614 |
|
|
return; |
1615 |
|
|
xhv = (XPVHV*)SvANY(hv); |
1616 |
|
|
hfreeentries(hv); |
1617 |
|
|
Safefree(xhv->xhv_array /* HvARRAY(hv) */); |
1618 |
|
|
if (HvNAME(hv)) { |
1619 |
|
|
if(PL_stashcache) |
1620 |
|
|
hv_delete(PL_stashcache, HvNAME(hv), strlen(HvNAME(hv)), G_DISCARD); |
1621 |
|
|
Safefree(HvNAME(hv)); |
1622 |
|
|
HvNAME(hv) = 0; |
1623 |
|
|
} |
1624 |
|
|
xhv->xhv_max = 7; /* HvMAX(hv) = 7 (it's a normal hash) */ |
1625 |
|
|
xhv->xhv_array = 0; /* HvARRAY(hv) = 0 */ |
1626 |
|
|
xhv->xhv_placeholders = 0; /* HvPLACEHOLDERS(hv) = 0 */ |
1627 |
|
|
|
1628 |
|
|
if (SvRMAGICAL(hv)) |
1629 |
|
|
mg_clear((SV*)hv); |
1630 |
|
|
} |
1631 |
|
|
|
1632 |
|
|
/* |
1633 |
|
|
=for apidoc hv_iterinit |
1634 |
|
|
|
1635 |
|
|
Prepares a starting point to traverse a hash table. Returns the number of |
1636 |
|
|
keys in the hash (i.e. the same as C<HvKEYS(tb)>). The return value is |
1637 |
|
|
currently only meaningful for hashes without tie magic. |
1638 |
|
|
|
1639 |
|
|
NOTE: Before version 5.004_65, C<hv_iterinit> used to return the number of |
1640 |
|
|
hash buckets that happen to be in use. If you still need that esoteric |
1641 |
|
|
value, you can get it through the macro C<HvFILL(tb)>. |
1642 |
|
|
|
1643 |
|
|
|
1644 |
|
|
=cut |
1645 |
|
|
*/ |
1646 |
|
|
|
1647 |
|
|
I32 |
1648 |
|
|
Perl_hv_iterinit(pTHX_ HV *hv) |
1649 |
|
|
{ |
1650 |
|
|
register XPVHV* xhv; |
1651 |
|
|
HE *entry; |
1652 |
|
|
|
1653 |
|
|
if (!hv) |
1654 |
|
|
Perl_croak(aTHX_ "Bad hash"); |
1655 |
|
|
xhv = (XPVHV*)SvANY(hv); |
1656 |
|
|
entry = xhv->xhv_eiter; /* HvEITER(hv) */ |
1657 |
|
|
if (entry && HvLAZYDEL(hv)) { /* was deleted earlier? */ |
1658 |
|
|
HvLAZYDEL_off(hv); |
1659 |
|
|
hv_free_ent(hv, entry); |
1660 |
|
|
} |
1661 |
|
|
xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */ |
1662 |
|
|
xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */ |
1663 |
|
|
/* used to be xhv->xhv_fill before 5.004_65 */ |
1664 |
|
|
return XHvTOTALKEYS(xhv); |
1665 |
|
|
} |
1666 |
|
|
/* |
1667 |
|
|
=for apidoc hv_iternext |
1668 |
|
|
|
1669 |
|
|
Returns entries from a hash iterator. See C<hv_iterinit>. |
1670 |
|
|
|
1671 |
|
|
You may call C<hv_delete> or C<hv_delete_ent> on the hash entry that the |
1672 |
|
|
iterator currently points to, without losing your place or invalidating your |
1673 |
|
|
iterator. Note that in this case the current entry is deleted from the hash |
1674 |
|
|
with your iterator holding the last reference to it. Your iterator is flagged |
1675 |
|
|
to free the entry on the next call to C<hv_iternext>, so you must not discard |
1676 |
|
|
your iterator immediately else the entry will leak - call C<hv_iternext> to |
1677 |
|
|
trigger the resource deallocation. |
1678 |
|
|
|
1679 |
|
|
=cut |
1680 |
|
|
*/ |
1681 |
|
|
|
1682 |
|
|
HE * |
1683 |
|
|
Perl_hv_iternext(pTHX_ HV *hv) |
1684 |
|
|
{ |
1685 |
|
|
return hv_iternext_flags(hv, 0); |
1686 |
|
|
} |
1687 |
|
|
|
1688 |
|
|
/* |
1689 |
|
|
=for apidoc hv_iternext_flags |
1690 |
|
|
|
1691 |
|
|
Returns entries from a hash iterator. See C<hv_iterinit> and C<hv_iternext>. |
1692 |
|
|
The C<flags> value will normally be zero; if HV_ITERNEXT_WANTPLACEHOLDERS is |
1693 |
|
|
set the placeholders keys (for restricted hashes) will be returned in addition |
1694 |
|
|
to normal keys. By default placeholders are automatically skipped over. |
1695 |
|
|
Currently a placeholder is implemented with a value that is |
1696 |
|
|
C<&Perl_sv_placeholder>. Note that the implementation of placeholders and |
1697 |
|
|
restricted hashes may change, and the implementation currently is |
1698 |
|
|
insufficiently abstracted for any change to be tidy. |
1699 |
|
|
|
1700 |
|
|
=cut |
1701 |
|
|
*/ |
1702 |
|
|
|
1703 |
|
|
HE * |
1704 |
|
|
Perl_hv_iternext_flags(pTHX_ HV *hv, I32 flags) |
1705 |
|
|
{ |
1706 |
|
|
register XPVHV* xhv; |
1707 |
|
|
register HE *entry; |
1708 |
|
|
HE *oldentry; |
1709 |
|
|
MAGIC* mg; |
1710 |
|
|
|
1711 |
|
|
if (!hv) |
1712 |
|
|
Perl_croak(aTHX_ "Bad hash"); |
1713 |
|
|
xhv = (XPVHV*)SvANY(hv); |
1714 |
|
|
oldentry = entry = xhv->xhv_eiter; /* HvEITER(hv) */ |
1715 |
|
|
|
1716 |
|
|
if ((mg = SvTIED_mg((SV*)hv, PERL_MAGIC_tied))) { |
1717 |
|
|
SV *key = sv_newmortal(); |
1718 |
|
|
if (entry) { |
1719 |
|
|
sv_setsv(key, HeSVKEY_force(entry)); |
1720 |
|
|
SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */ |
1721 |
|
|
} |
1722 |
|
|
else { |
1723 |
|
|
char *k; |
1724 |
|
|
HEK *hek; |
1725 |
|
|
|
1726 |
|
|
/* one HE per MAGICAL hash */ |
1727 |
|
|
xhv->xhv_eiter = entry = new_HE(); /* HvEITER(hv) = new_HE() */ |
1728 |
|
|
Zero(entry, 1, HE); |
1729 |
|
|
Newz(54, k, HEK_BASESIZE + sizeof(SV*), char); |
1730 |
|
|
hek = (HEK*)k; |
1731 |
|
|
HeKEY_hek(entry) = hek; |
1732 |
|
|
HeKLEN(entry) = HEf_SVKEY; |
1733 |
|
|
} |
1734 |
|
|
magic_nextpack((SV*) hv,mg,key); |
1735 |
|
|
if (SvOK(key)) { |
1736 |
|
|
/* force key to stay around until next time */ |
1737 |
|
|
HeSVKEY_set(entry, SvREFCNT_inc(key)); |
1738 |
|
|
return entry; /* beware, hent_val is not set */ |
1739 |
|
|
} |
1740 |
|
|
if (HeVAL(entry)) |
1741 |
|
|
SvREFCNT_dec(HeVAL(entry)); |
1742 |
|
|
Safefree(HeKEY_hek(entry)); |
1743 |
|
|
del_HE(entry); |
1744 |
|
|
xhv->xhv_eiter = Null(HE*); /* HvEITER(hv) = Null(HE*) */ |
1745 |
|
|
return Null(HE*); |
1746 |
|
|
} |
1747 |
|
|
#ifdef DYNAMIC_ENV_FETCH /* set up %ENV for iteration */ |
1748 |
|
|
if (!entry && SvRMAGICAL((SV*)hv) && mg_find((SV*)hv, PERL_MAGIC_env)) |
1749 |
|
|
prime_env_iter(); |
1750 |
|
|
#endif |
1751 |
|
|
|
1752 |
|
|
if (!xhv->xhv_array /* !HvARRAY(hv) */) |
1753 |
|
|
Newz(506, xhv->xhv_array /* HvARRAY(hv) */, |
1754 |
|
|
PERL_HV_ARRAY_ALLOC_BYTES(xhv->xhv_max+1 /* HvMAX(hv)+1 */), |
1755 |
|
|
char); |
1756 |
|
|
/* At start of hash, entry is NULL. */ |
1757 |
|
|
if (entry) |
1758 |
|
|
{ |
1759 |
|
|
entry = HeNEXT(entry); |
1760 |
|
|
if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) { |
1761 |
|
|
/* |
1762 |
|
|
* Skip past any placeholders -- don't want to include them in |
1763 |
|
|
* any iteration. |
1764 |
|
|
*/ |
1765 |
|
|
while (entry && HeVAL(entry) == &PL_sv_placeholder) { |
1766 |
|
|
entry = HeNEXT(entry); |
1767 |
|
|
} |
1768 |
|
|
} |
1769 |
|
|
} |
1770 |
|
|
while (!entry) { |
1771 |
|
|
/* OK. Come to the end of the current list. Grab the next one. */ |
1772 |
|
|
|
1773 |
|
|
xhv->xhv_riter++; /* HvRITER(hv)++ */ |
1774 |
|
|
if (xhv->xhv_riter > (I32)xhv->xhv_max /* HvRITER(hv) > HvMAX(hv) */) { |
1775 |
|
|
/* There is no next one. End of the hash. */ |
1776 |
|
|
xhv->xhv_riter = -1; /* HvRITER(hv) = -1 */ |
1777 |
|
|
break; |
1778 |
|
|
} |
1779 |
|
|
/* entry = (HvARRAY(hv))[HvRITER(hv)]; */ |
1780 |
|
|
entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter]; |
1781 |
|
|
|
1782 |
|
|
if (!(flags & HV_ITERNEXT_WANTPLACEHOLDERS)) { |
1783 |
|
|
/* If we have an entry, but it's a placeholder, don't count it. |
1784 |
|
|
Try the next. */ |
1785 |
|
|
while (entry && HeVAL(entry) == &PL_sv_placeholder) |
1786 |
|
|
entry = HeNEXT(entry); |
1787 |
|
|
} |
1788 |
|
|
/* Will loop again if this linked list starts NULL |
1789 |
|
|
(for HV_ITERNEXT_WANTPLACEHOLDERS) |
1790 |
|
|
or if we run through it and find only placeholders. */ |
1791 |
|
|
} |
1792 |
|
|
|
1793 |
|
|
if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */ |
1794 |
|
|
HvLAZYDEL_off(hv); |
1795 |
|
|
hv_free_ent(hv, oldentry); |
1796 |
|
|
} |
1797 |
|
|
|
1798 |
|
|
/*if (HvREHASH(hv) && entry && !HeKREHASH(entry)) |
1799 |
|
|
PerlIO_printf(PerlIO_stderr(), "Awooga %p %p\n", hv, entry);*/ |
1800 |
|
|
|
1801 |
|
|
xhv->xhv_eiter = entry; /* HvEITER(hv) = entry */ |
1802 |
|
|
return entry; |
1803 |
|
|
} |
1804 |
|
|
|
1805 |
|
|
/* |
1806 |
|
|
=for apidoc hv_iterkey |
1807 |
|
|
|
1808 |
|
|
Returns the key from the current position of the hash iterator. See |
1809 |
|
|
C<hv_iterinit>. |
1810 |
|
|
|
1811 |
|
|
=cut |
1812 |
|
|
*/ |
1813 |
|
|
|
1814 |
|
|
char * |
1815 |
|
|
Perl_hv_iterkey(pTHX_ register HE *entry, I32 *retlen) |
1816 |
|
|
{ |
1817 |
|
|
if (HeKLEN(entry) == HEf_SVKEY) { |
1818 |
|
|
STRLEN len; |
1819 |
|
|
char *p = SvPV(HeKEY_sv(entry), len); |
1820 |
|
|
*retlen = len; |
1821 |
|
|
return p; |
1822 |
|
|
} |
1823 |
|
|
else { |
1824 |
|
|
*retlen = HeKLEN(entry); |
1825 |
|
|
return HeKEY(entry); |
1826 |
|
|
} |
1827 |
|
|
} |
1828 |
|
|
|
1829 |
|
|
/* unlike hv_iterval(), this always returns a mortal copy of the key */ |
1830 |
|
|
/* |
1831 |
|
|
=for apidoc hv_iterkeysv |
1832 |
|
|
|
1833 |
|
|
Returns the key as an C<SV*> from the current position of the hash |
1834 |
|
|
iterator. The return value will always be a mortal copy of the key. Also |
1835 |
|
|
see C<hv_iterinit>. |
1836 |
|
|
|
1837 |
|
|
=cut |
1838 |
|
|
*/ |
1839 |
|
|
|
1840 |
|
|
SV * |
1841 |
|
|
Perl_hv_iterkeysv(pTHX_ register HE *entry) |
1842 |
|
|
{ |
1843 |
|
|
if (HeKLEN(entry) != HEf_SVKEY) { |
1844 |
|
|
HEK *hek = HeKEY_hek(entry); |
1845 |
|
|
int flags = HEK_FLAGS(hek); |
1846 |
|
|
SV *sv; |
1847 |
|
|
|
1848 |
|
|
if (flags & HVhek_WASUTF8) { |
1849 |
|
|
/* Trouble :-) |
1850 |
|
|
Andreas would like keys he put in as utf8 to come back as utf8 |
1851 |
|
|
*/ |
1852 |
|
|
STRLEN utf8_len = HEK_LEN(hek); |
1853 |
|
|
U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len); |
1854 |
|
|
|
1855 |
|
|
sv = newSVpvn ((char*)as_utf8, utf8_len); |
1856 |
|
|
SvUTF8_on (sv); |
1857 |
|
|
Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */ |
1858 |
|
|
} else if (flags & HVhek_REHASH) { |
1859 |
|
|
/* We don't have a pointer to the hv, so we have to replicate the |
1860 |
|
|
flag into every HEK. This hv is using custom a hasing |
1861 |
|
|
algorithm. Hence we can't return a shared string scalar, as |
1862 |
|
|
that would contain the (wrong) hash value, and might get passed |
1863 |
|
|
into an hv routine with a regular hash */ |
1864 |
|
|
|
1865 |
|
|
sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek)); |
1866 |
|
|
if (HEK_UTF8(hek)) |
1867 |
|
|
SvUTF8_on (sv); |
1868 |
|
|
} else { |
1869 |
|
|
sv = newSVpvn_share(HEK_KEY(hek), |
1870 |
|
|
(HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)), |
1871 |
|
|
HEK_HASH(hek)); |
1872 |
|
|
} |
1873 |
|
|
return sv_2mortal(sv); |
1874 |
|
|
} |
1875 |
|
|
return sv_mortalcopy(HeKEY_sv(entry)); |
1876 |
|
|
} |
1877 |
|
|
|
1878 |
|
|
/* |
1879 |
|
|
=for apidoc hv_iterval |
1880 |
|
|
|
1881 |
|
|
Returns the value from the current position of the hash iterator. See |
1882 |
|
|
C<hv_iterkey>. |
1883 |
|
|
|
1884 |
|
|
=cut |
1885 |
|
|
*/ |
1886 |
|
|
|
1887 |
|
|
SV * |
1888 |
|
|
Perl_hv_iterval(pTHX_ HV *hv, register HE *entry) |
1889 |
|
|
{ |
1890 |
|
|
if (SvRMAGICAL(hv)) { |
1891 |
|
|
if (mg_find((SV*)hv, PERL_MAGIC_tied)) { |
1892 |
|
|
SV* sv = sv_newmortal(); |
1893 |
|
|
if (HeKLEN(entry) == HEf_SVKEY) |
1894 |
|
|
mg_copy((SV*)hv, sv, (char*)HeKEY_sv(entry), HEf_SVKEY); |
1895 |
|
|
else mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry)); |
1896 |
|
|
return sv; |
1897 |
|
|
} |
1898 |
|
|
} |
1899 |
|
|
return HeVAL(entry); |
1900 |
|
|
} |
1901 |
|
|
|
1902 |
|
|
/* |
1903 |
|
|
=for apidoc hv_iternextsv |
1904 |
|
|
|
1905 |
|
|
Performs an C<hv_iternext>, C<hv_iterkey>, and C<hv_iterval> in one |
1906 |
|
|
operation. |
1907 |
|
|
|
1908 |
|
|
=cut |
1909 |
|
|
*/ |
1910 |
|
|
|
1911 |
|
|
SV * |
1912 |
|
|
Perl_hv_iternextsv(pTHX_ HV *hv, char **key, I32 *retlen) |
1913 |
|
|
{ |
1914 |
|
|
HE *he; |
1915 |
|
|
if ( (he = hv_iternext_flags(hv, 0)) == NULL) |
1916 |
|
|
return NULL; |
1917 |
|
|
*key = hv_iterkey(he, retlen); |
1918 |
|
|
return hv_iterval(hv, he); |
1919 |
|
|
} |
1920 |
|
|
|
1921 |
|
|
/* |
1922 |
|
|
=for apidoc hv_magic |
1923 |
|
|
|
1924 |
|
|
Adds magic to a hash. See C<sv_magic>. |
1925 |
|
|
|
1926 |
|
|
=cut |
1927 |
|
|
*/ |
1928 |
|
|
|
1929 |
|
|
void |
1930 |
|
|
Perl_hv_magic(pTHX_ HV *hv, GV *gv, int how) |
1931 |
|
|
{ |
1932 |
|
|
sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0); |
1933 |
|
|
} |
1934 |
|
|
|
1935 |
|
|
#if 0 /* use the macro from hv.h instead */ |
1936 |
|
|
|
1937 |
|
|
char* |
1938 |
|
|
Perl_sharepvn(pTHX_ const char *sv, I32 len, U32 hash) |
1939 |
|
|
{ |
1940 |
|
|
return HEK_KEY(share_hek(sv, len, hash)); |
1941 |
|
|
} |
1942 |
|
|
|
1943 |
|
|
#endif |
1944 |
|
|
|
1945 |
|
|
/* possibly free a shared string if no one has access to it |
1946 |
|
|
* len and hash must both be valid for str. |
1947 |
|
|
*/ |
1948 |
|
|
void |
1949 |
|
|
Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash) |
1950 |
|
|
{ |
1951 |
|
|
unshare_hek_or_pvn (NULL, str, len, hash); |
1952 |
|
|
} |
1953 |
|
|
|
1954 |
|
|
|
1955 |
|
|
void |
1956 |
|
|
Perl_unshare_hek(pTHX_ HEK *hek) |
1957 |
|
|
{ |
1958 |
|
|
unshare_hek_or_pvn(hek, NULL, 0, 0); |
1959 |
|
|
} |
1960 |
|
|
|
1961 |
|
|
/* possibly free a shared string if no one has access to it |
1962 |
|
|
hek if non-NULL takes priority over the other 3, else str, len and hash |
1963 |
|
|
are used. If so, len and hash must both be valid for str. |
1964 |
|
|
*/ |
1965 |
|
|
STATIC void |
1966 |
|
|
S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash) |
1967 |
|
|
{ |
1968 |
|
|
register XPVHV* xhv; |
1969 |
|
|
register HE *entry; |
1970 |
|
|
register HE **oentry; |
1971 |
|
|
register I32 i = 1; |
1972 |
|
|
I32 found = 0; |
1973 |
|
|
bool is_utf8 = FALSE; |
1974 |
|
|
int k_flags = 0; |
1975 |
|
|
const char *save = str; |
1976 |
|
|
|
1977 |
|
|
if (hek) { |
1978 |
|
|
hash = HEK_HASH(hek); |
1979 |
|
|
} else if (len < 0) { |
1980 |
|
|
STRLEN tmplen = -len; |
1981 |
|
|
is_utf8 = TRUE; |
1982 |
|
|
/* See the note in hv_fetch(). --jhi */ |
1983 |
|
|
str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8); |
1984 |
|
|
len = tmplen; |
1985 |
|
|
if (is_utf8) |
1986 |
|
|
k_flags = HVhek_UTF8; |
1987 |
|
|
if (str != save) |
1988 |
|
|
k_flags |= HVhek_WASUTF8 | HVhek_FREEKEY; |
1989 |
|
|
} |
1990 |
|
|
|
1991 |
|
|
/* what follows is the moral equivalent of: |
1992 |
|
|
if ((Svp = hv_fetch(PL_strtab, tmpsv, FALSE, hash))) { |
1993 |
|
|
if (--*Svp == Nullsv) |
1994 |
|
|
hv_delete(PL_strtab, str, len, G_DISCARD, hash); |
1995 |
|
|
} */ |
1996 |
|
|
xhv = (XPVHV*)SvANY(PL_strtab); |
1997 |
|
|
/* assert(xhv_array != 0) */ |
1998 |
|
|
LOCK_STRTAB_MUTEX; |
1999 |
|
|
/* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */ |
2000 |
|
|
oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; |
2001 |
|
|
if (hek) { |
2002 |
|
|
for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) { |
2003 |
|
|
if (HeKEY_hek(entry) != hek) |
2004 |
|
|
continue; |
2005 |
|
|
found = 1; |
2006 |
|
|
break; |
2007 |
|
|
} |
2008 |
|
|
} else { |
2009 |
|
|
int flags_masked = k_flags & HVhek_MASK; |
2010 |
|
|
for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) { |
2011 |
|
|
if (HeHASH(entry) != hash) /* strings can't be equal */ |
2012 |
|
|
continue; |
2013 |
|
|
if (HeKLEN(entry) != len) |
2014 |
|
|
continue; |
2015 |
|
|
if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */ |
2016 |
|
|
continue; |
2017 |
|
|
if (HeKFLAGS(entry) != flags_masked) |
2018 |
|
|
continue; |
2019 |
|
|
found = 1; |
2020 |
|
|
break; |
2021 |
|
|
} |
2022 |
|
|
} |
2023 |
|
|
|
2024 |
|
|
if (found) { |
2025 |
|
|
if (--HeVAL(entry) == Nullsv) { |
2026 |
|
|
*oentry = HeNEXT(entry); |
2027 |
|
|
if (i && !*oentry) |
2028 |
|
|
xhv->xhv_fill--; /* HvFILL(hv)-- */ |
2029 |
|
|
Safefree(HeKEY_hek(entry)); |
2030 |
|
|
del_HE(entry); |
2031 |
|
|
xhv->xhv_keys--; /* HvKEYS(hv)-- */ |
2032 |
|
|
} |
2033 |
|
|
} |
2034 |
|
|
|
2035 |
|
|
UNLOCK_STRTAB_MUTEX; |
2036 |
|
|
if (!found && ckWARN_d(WARN_INTERNAL)) |
2037 |
|
|
Perl_warner(aTHX_ packWARN(WARN_INTERNAL), |
2038 |
|
|
"Attempt to free non-existent shared string '%s'%s" |
2039 |
|
|
pTHX__FORMAT, |
2040 |
|
|
hek ? HEK_KEY(hek) : str, |
2041 |
|
|
((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE); |
2042 |
|
|
if (k_flags & HVhek_FREEKEY) |
2043 |
|
|
Safefree(str); |
2044 |
|
|
} |
2045 |
|
|
|
2046 |
|
|
/* get a (constant) string ptr from the global string table |
2047 |
|
|
* string will get added if it is not already there. |
2048 |
|
|
* len and hash must both be valid for str. |
2049 |
|
|
*/ |
2050 |
|
|
HEK * |
2051 |
|
|
Perl_share_hek(pTHX_ const char *str, I32 len, register U32 hash) |
2052 |
|
|
{ |
2053 |
|
|
bool is_utf8 = FALSE; |
2054 |
|
|
int flags = 0; |
2055 |
|
|
const char *save = str; |
2056 |
|
|
|
2057 |
|
|
if (len < 0) { |
2058 |
|
|
STRLEN tmplen = -len; |
2059 |
|
|
is_utf8 = TRUE; |
2060 |
|
|
/* See the note in hv_fetch(). --jhi */ |
2061 |
|
|
str = (char*)bytes_from_utf8((U8*)str, &tmplen, &is_utf8); |
2062 |
|
|
len = tmplen; |
2063 |
|
|
/* If we were able to downgrade here, then than means that we were passed |
2064 |
|
|
in a key which only had chars 0-255, but was utf8 encoded. */ |
2065 |
|
|
if (is_utf8) |
2066 |
|
|
flags = HVhek_UTF8; |
2067 |
|
|
/* If we found we were able to downgrade the string to bytes, then |
2068 |
|
|
we should flag that it needs upgrading on keys or each. Also flag |
2069 |
|
|
that we need share_hek_flags to free the string. */ |
2070 |
|
|
if (str != save) |
2071 |
|
|
flags |= HVhek_WASUTF8 | HVhek_FREEKEY; |
2072 |
|
|
} |
2073 |
|
|
|
2074 |
|
|
return share_hek_flags (str, len, hash, flags); |
2075 |
|
|
} |
2076 |
|
|
|
2077 |
|
|
STATIC HEK * |
2078 |
|
|
S_share_hek_flags(pTHX_ const char *str, I32 len, register U32 hash, int flags) |
2079 |
|
|
{ |
2080 |
|
|
register XPVHV* xhv; |
2081 |
|
|
register HE *entry; |
2082 |
|
|
register HE **oentry; |
2083 |
|
|
register I32 i = 1; |
2084 |
|
|
I32 found = 0; |
2085 |
|
|
int flags_masked = flags & HVhek_MASK; |
2086 |
|
|
|
2087 |
|
|
/* what follows is the moral equivalent of: |
2088 |
|
|
|
2089 |
|
|
if (!(Svp = hv_fetch(PL_strtab, str, len, FALSE))) |
2090 |
|
|
hv_store(PL_strtab, str, len, Nullsv, hash); |
2091 |
|
|
|
2092 |
|
|
Can't rehash the shared string table, so not sure if it's worth |
2093 |
|
|
counting the number of entries in the linked list |
2094 |
|
|
*/ |
2095 |
|
|
xhv = (XPVHV*)SvANY(PL_strtab); |
2096 |
|
|
/* assert(xhv_array != 0) */ |
2097 |
|
|
LOCK_STRTAB_MUTEX; |
2098 |
|
|
/* oentry = &(HvARRAY(hv))[hash & (I32) HvMAX(hv)]; */ |
2099 |
|
|
oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max]; |
2100 |
|
|
for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) { |
2101 |
|
|
if (HeHASH(entry) != hash) /* strings can't be equal */ |
2102 |
|
|
continue; |
2103 |
|
|
if (HeKLEN(entry) != len) |
2104 |
|
|
continue; |
2105 |
|
|
if (HeKEY(entry) != str && memNE(HeKEY(entry),str,len)) /* is this it? */ |
2106 |
|
|
continue; |
2107 |
|
|
if (HeKFLAGS(entry) != flags_masked) |
2108 |
|
|
continue; |
2109 |
|
|
found = 1; |
2110 |
|
|
break; |
2111 |
|
|
} |
2112 |
|
|
if (!found) { |
2113 |
|
|
entry = new_HE(); |
2114 |
|
|
HeKEY_hek(entry) = save_hek_flags(str, len, hash, flags_masked); |
2115 |
|
|
HeVAL(entry) = Nullsv; |
2116 |
|
|
HeNEXT(entry) = *oentry; |
2117 |
|
|
*oentry = entry; |
2118 |
|
|
xhv->xhv_keys++; /* HvKEYS(hv)++ */ |
2119 |
|
|
if (i) { /* initial entry? */ |
2120 |
|
|
xhv->xhv_fill++; /* HvFILL(hv)++ */ |
2121 |
|
|
} else if (xhv->xhv_keys > (IV)xhv->xhv_max /* HvKEYS(hv) > HvMAX(hv) */) { |
2122 |
|
|
hsplit(PL_strtab); |
2123 |
|
|
} |
2124 |
|
|
} |
2125 |
|
|
|
2126 |
|
|
++HeVAL(entry); /* use value slot as REFCNT */ |
2127 |
|
|
UNLOCK_STRTAB_MUTEX; |
2128 |
|
|
|
2129 |
|
|
if (flags & HVhek_FREEKEY) |
2130 |
|
|
Safefree(str); |
2131 |
|
|
|
2132 |
|
|
return HeKEY_hek(entry); |
2133 |
|
|
} |
2134 |
|
|
|
2135 |
|
|
/* |
2136 |
|
|
* Local variables: |
2137 |
|
|
* c-indentation-style: bsd |
2138 |
|
|
* c-basic-offset: 4 |
2139 |
|
|
* indent-tabs-mode: t |
2140 |
|
|
* End: |
2141 |
|
|
* |
2142 |
|
|
* vim: shiftwidth=4: |
2143 |
|
|
*/ |