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