1 #define PERL_NO_GET_CONTEXT
2
3 #include "EXTERN.h"
4 #include "perl.h"
5 #include "XSUB.h"
6
7 MODULE = Hash::Util PACKAGE = Hash::Util
8
9 void
10 _clear_placeholders(hashref)
11 HV *hashref
12 PROTOTYPE: \%
13 PREINIT:
14 HV *hv;
15 CODE:
16 hv = MUTABLE_HV(hashref);
17 hv_clear_placeholders(hv);
18
19 void
20 all_keys(hash,keys,placeholder)
21 HV *hash
22 AV *keys
23 AV *placeholder
24 PROTOTYPE: \%\@\@
25 PREINIT:
26 SV *key;
27 HE *he;
28 PPCODE:
29 av_clear(keys);
30 av_clear(placeholder);
31
32 (void)hv_iterinit(hash);
33 while((he = hv_iternext_flags(hash, HV_ITERNEXT_WANTPLACEHOLDERS))!= NULL) {
34 key=hv_iterkeysv(he);
35 av_push(HeVAL(he) == &PL_sv_placeholder ? placeholder : keys,
36 SvREFCNT_inc(key));
37 }
38 XSRETURN(1);
39
40 void
41 hidden_ref_keys(hash)
42 HV *hash
43 ALIAS:
44 Hash::Util::legal_ref_keys = 1
45 PREINIT:
46 SV *key;
47 HE *he;
48 PPCODE:
49 (void)hv_iterinit(hash);
50 while((he = hv_iternext_flags(hash, HV_ITERNEXT_WANTPLACEHOLDERS))!= NULL) {
51 key=hv_iterkeysv(he);
52 if (ix || HeVAL(he) == &PL_sv_placeholder) {
53 XPUSHs( key );
54 }
55 }
56
57 void
58 hv_store(hash, key, val)
59 HV *hash
60 SV* key
61 SV* val
62 PROTOTYPE: \%$$
63 CODE:
64 {
65 SvREFCNT_inc(val);
66 if (!hv_store_ent(hash, key, val, 0)) {
67 SvREFCNT_dec(val);
68 XSRETURN_NO;
69 } else {
70 XSRETURN_YES;
71 }
72 }
73
74 void
75 hash_seed()
76 PROTOTYPE:
77 PPCODE:
78 mXPUSHs(newSVpvn((char *)PERL_HASH_SEED,PERL_HASH_SEED_BYTES));
79 XSRETURN(1);
80
81
82 void
hash_value(string,...)83 hash_value(string,...)
84 SV* string
85 PROTOTYPE: $;$
86 PPCODE:
87 {
88 UV uv;
89 STRLEN len;
90 char *pv= SvPV(string,len);
91 if (items<2) {
92 PERL_HASH(uv, pv, len);
93 } else {
94 STRLEN seedlen;
95 U8 *seedbuf= (U8 *)SvPV(ST(1),seedlen);
96 if ( seedlen < PERL_HASH_SEED_BYTES ) {
97 sv_dump(ST(1));
98 Perl_croak(aTHX_ "seed len must be at least %" UVuf " long only got %"
99 UVuf " bytes", (UV)PERL_HASH_SEED_BYTES, (UV)seedlen);
100 }
101
102 PERL_HASH_WITH_SEED(seedbuf, uv, pv, len);
103 }
104 XSRETURN_UV(uv);
105 }
106
107 void
hash_traversal_mask(rhv,...)108 hash_traversal_mask(rhv, ...)
109 SV* rhv
110 PPCODE:
111 {
112 #ifdef PERL_HASH_RANDOMIZE_KEYS
113 if (SvROK(rhv) && SvTYPE(SvRV(rhv))==SVt_PVHV && !SvMAGICAL(SvRV(rhv))) {
114 HV *hv = (HV *)SvRV(rhv);
115 if (items>1) {
116 hv_rand_set(hv, SvUV(ST(1)));
117 }
118 if (HvHasAUX(hv)) {
119 XSRETURN_UV(HvRAND_get(hv));
120 } else {
121 XSRETURN_UNDEF;
122 }
123 }
124 #else
125 Perl_croak(aTHX_ "Perl has not been compiled with support for randomized hash key traversal");
126 #endif
127 }
128
129 void
bucket_info(rhv)130 bucket_info(rhv)
131 SV* rhv
132 PPCODE:
133 {
134 /*
135
136 Takes a non-magical hash ref as an argument and returns a list of
137 statistics about the hash. The number and keys and the size of the
138 array will always be reported as the first two values. If the array is
139 actually allocated (they are lazily allocated), then additionally
140 will return a list of counts of bucket lengths. In other words in
141
142 ($keys, $buckets, $used, @length_count)= hash::bucket_info(\%hash);
143
144 $length_count[0] is the number of empty buckets, and $length_count[1]
145 is the number of buckets with only one key in it, $buckets - $length_count[0]
146 gives the number of used buckets, and @length_count-1 is the maximum
147 bucket depth.
148
149 If the argument is not a hash ref, or if it is magical, then returns
150 nothing (the empty list).
151
152 */
153 const HV * hv = NULL;
154 if (SvROK(rhv) && SvTYPE(SvRV(rhv))==SVt_PVHV && !SvMAGICAL(SvRV(rhv))) {
155 hv = (const HV *) SvRV(rhv);
156 } else if (!SvOK(rhv)) {
157 hv = PL_strtab;
158 }
159 if (hv) {
160 U32 max_bucket_index= HvMAX(hv);
161 U32 total_keys= HvUSEDKEYS(hv);
162 HE **bucket_array= HvARRAY(hv);
163 mXPUSHi(total_keys);
164 mXPUSHi(max_bucket_index+1);
165 mXPUSHi(0); /* for the number of used buckets */
166 #define BUCKET_INFO_ITEMS_ON_STACK 3
167 if (!bucket_array) {
168 XSRETURN(BUCKET_INFO_ITEMS_ON_STACK);
169 } else {
170 /* we use chain_length to index the stack - we eliminate an add
171 * by initializing things with the number of items already on the stack.
172 * If we have 2 items then ST(2+0) (the third stack item) will be the counter
173 * for empty chains, ST(2+1) will be for chains with one element, etc.
174 */
175 I32 max_chain_length= BUCKET_INFO_ITEMS_ON_STACK - 1; /* so we do not have to do an extra push for the 0 index */
176 HE *he;
177 U32 bucket_index;
178 for ( bucket_index= 0; bucket_index <= max_bucket_index; bucket_index++ ) {
179 I32 chain_length= BUCKET_INFO_ITEMS_ON_STACK;
180 for (he= bucket_array[bucket_index]; he; he= HeNEXT(he) ) {
181 chain_length++;
182 }
183 while ( max_chain_length < chain_length ) {
184 mXPUSHi(0);
185 max_chain_length++;
186 }
187 SvIVX( ST( chain_length ) )++;
188 }
189 /* now set the number of used buckets */
190 SvIVX( ST( BUCKET_INFO_ITEMS_ON_STACK - 1 ) ) = max_bucket_index - SvIVX( ST( BUCKET_INFO_ITEMS_ON_STACK ) ) + 1;
191 XSRETURN( max_chain_length + 1 ); /* max_chain_length is the index of the last item on the stack, so we add 1 */
192 }
193 #undef BUCKET_INFO_ITEMS_ON_STACK
194 }
195 XSRETURN(0);
196 }
197
198 void
bucket_array(rhv)199 bucket_array(rhv)
200 SV* rhv
201 PPCODE:
202 {
203 /* Returns an array of arrays representing key/bucket mappings.
204 * Each element of the array contains either an integer or a reference
205 * to an array of keys. A plain integer represents K empty buckets. An
206 * array ref represents a single bucket, with each element being a key in
207 * the hash. (Note this treats a placeholder as a normal key.)
208 *
209 * This allows one to "see" the keyorder. Note the "insert first" nature
210 * of the hash store, combined with regular remappings means that relative
211 * order of keys changes each remap.
212 */
213 const HV * hv = NULL;
214 if (SvROK(rhv) && SvTYPE(SvRV(rhv))==SVt_PVHV && !SvMAGICAL(SvRV(rhv))) {
215 hv = (const HV *) SvRV(rhv);
216 } else if (!SvOK(rhv)) {
217 hv = PL_strtab;
218 }
219 if (hv) {
220 HE **he_ptr= HvARRAY(hv);
221 if (!he_ptr) {
222 XSRETURN(0);
223 } else {
224 U32 i, max;
225 AV *info_av;
226 HE *he;
227 I32 empty_count=0;
228 if (SvMAGICAL(hv)) {
229 Perl_croak(aTHX_ "hash::bucket_array only works on 'normal' hashes");
230 }
231 info_av= newAV();
232 max= HvMAX(hv);
233 mXPUSHs(newRV_noinc((SV*)info_av));
234 for ( i= 0; i <= max; i++ ) {
235 AV *key_av= NULL;
236 for (he= he_ptr[i]; he; he= HeNEXT(he) ) {
237 SV *key_sv;
238 char *str;
239 STRLEN len;
240 char mode;
241 if (!key_av) {
242 key_av= newAV();
243 if (empty_count) {
244 av_push_simple(info_av, newSViv(empty_count));
245 empty_count= 0;
246 }
247 av_push_simple(info_av, (SV *)newRV_noinc((SV *)key_av));
248 }
249 if (HeKLEN(he) == HEf_SVKEY) {
250 SV *sv= HeSVKEY(he);
251 SvGETMAGIC(sv);
252 str= SvPV(sv, len);
253 mode= SvUTF8(sv) ? 1 : 0;
254 } else {
255 str= HeKEY(he);
256 len= HeKLEN(he);
257 mode= HeKUTF8(he) ? 1 : 0;
258 }
259 key_sv= newSVpvn(str,len);
260 av_push_simple(key_av,key_sv);
261 if (mode) {
262 SvUTF8_on(key_sv);
263 }
264 }
265 if (!key_av)
266 empty_count++;
267 }
268 if (empty_count) {
269 av_push_simple(info_av, newSViv(empty_count));
270 empty_count++;
271 }
272 }
273 XSRETURN(1);
274 }
275 XSRETURN(0);
276 }
277
278 void
279 bucket_ratio(rhv)
280 SV* rhv
281 PROTOTYPE: \%
282 PPCODE:
283 {
284 if (SvROK(rhv)) {
285 rhv= SvRV(rhv);
286 if ( SvTYPE(rhv)==SVt_PVHV ) {
287 #if PERL_VERSION_LT(5,25,0)
288 SV *ret= Perl_hv_scalar(aTHX_ (HV*)rhv);
289 #else
290 SV *ret= Perl_hv_bucket_ratio(aTHX_ (HV*)rhv);
291 #endif
292 ST(0)= ret;
293 XSRETURN(1);
294 }
295 }
296 XSRETURN_UNDEF;
297 }
298
299 void
300 num_buckets(rhv)
301 SV* rhv
302 PROTOTYPE: \%
303 PPCODE:
304 {
305 if (SvROK(rhv)) {
306 rhv= SvRV(rhv);
307 if ( SvTYPE(rhv)==SVt_PVHV ) {
308 XSRETURN_UV(HvMAX((HV*)rhv)+1);
309 }
310 }
311 XSRETURN_UNDEF;
312 }
313
314 void
315 used_buckets(rhv)
316 SV* rhv
317 PROTOTYPE: \%
318 PPCODE:
319 {
320 if (SvROK(rhv)) {
321 rhv= SvRV(rhv);
322 if ( SvTYPE(rhv)==SVt_PVHV ) {
323 XSRETURN_UV(HvFILL((HV*)rhv));
324 }
325 }
326 XSRETURN_UNDEF;
327 }
328
329