This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
printf formats are hard.
[perl5.git] / ext / Hash-Util / Util.xs
CommitLineData
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
7MODULE = Hash::Util PACKAGE = Hash::Util
8
2caa6900 9void
96c33d98 10all_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
30void
31hidden_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
47void
2caa6900
NC
48hv_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
64void
65hash_seed()
66 PROTOTYPE:
67 PPCODE:
68 mXPUSHs(newSVpvn((char *)PERL_HASH_SEED,PERL_HASH_SEED_BYTES));
69 XSRETURN(1);
70
6a5b4183 71
7dc86639 72void
3d53a8ea 73hash_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
96void
97hash_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
118void
119bucket_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 */
3eaa3d14 142 const HV * hv;
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
187void
188bucket_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 */
3eaa3d14 202 const HV * hv;
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}