This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
hoping this works finally. gcc is too permissive with my build options
[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
YO
72void
73hash_value(string)
74 SV* string
75 PROTOTYPE: $
76 PPCODE:
77 STRLEN len;
78 char *pv;
79 UV uv;
80
81 pv= SvPV(string,len);
82 PERL_HASH(uv,pv,len);
83 XSRETURN_UV(uv);
84
6a5b4183
YO
85void
86hash_traversal_mask(rhv, ...)
87 SV* rhv
88 PPCODE:
89{
90#ifdef PERL_HASH_RANDOMIZE_KEYS
91 if (SvROK(rhv) && SvTYPE(SvRV(rhv))==SVt_PVHV && !SvMAGICAL(SvRV(rhv))) {
36dc2207 92 HV *hv = (HV *)SvRV(rhv);
6a5b4183
YO
93 if (items>1) {
94 hv_rand_set(hv, SvUV(ST(1)));
95 }
96 if (SvOOK(hv)) {
97 XSRETURN_UV(HvRAND_get(hv));
98 } else {
99 XSRETURN_UNDEF;
100 }
101 }
102#else
103 Perl_croak(aTHX_ "Perl has not been compiled with support for randomized hash key traversal");
104#endif
105}
7dc86639
YO
106
107void
108bucket_info(rhv)
109 SV* rhv
110 PPCODE:
111{
112 /*
113
114 Takes a non-magical hash ref as an argument and returns a list of
115 statistics about the hash. The number and keys and the size of the
116 array will always be reported as the first two values. If the array is
117 actually allocated (they are lazily allocated), then additionally
118 will return a list of counts of bucket lengths. In other words in
119
120 ($keys, $buckets, $used, @length_count)= hash::bucket_info(\%hash);
121
122 $length_count[0] is the number of empty buckets, and $length_count[1]
123 is the number of buckets with only one key in it, $buckets - $length_count[0]
124 gives the number of used buckets, and @length_count-1 is the maximum
125 bucket depth.
126
127 If the argument is not a hash ref, or if it is magical, then returns
128 nothing (the empty list).
129
130 */
131 if (SvROK(rhv) && SvTYPE(SvRV(rhv))==SVt_PVHV && !SvMAGICAL(SvRV(rhv))) {
132 const HV * const hv = (const HV *) SvRV(rhv);
133 U32 max_bucket_index= HvMAX(hv);
134 U32 total_keys= HvUSEDKEYS(hv);
135 HE **bucket_array= HvARRAY(hv);
136 mXPUSHi(total_keys);
137 mXPUSHi(max_bucket_index+1);
138 mXPUSHi(0); /* for the number of used buckets */
139#define BUCKET_INFO_ITEMS_ON_STACK 3
140 if (!bucket_array) {
141 XSRETURN(BUCKET_INFO_ITEMS_ON_STACK);
142 } else {
143 /* we use chain_length to index the stack - we eliminate an add
144 * by initializing things with the number of items already on the stack.
145 * If we have 2 items then ST(2+0) (the third stack item) will be the counter
146 * for empty chains, ST(2+1) will be for chains with one element, etc.
147 */
148 I32 max_chain_length= BUCKET_INFO_ITEMS_ON_STACK - 1; /* so we do not have to do an extra push for the 0 index */
149 HE *he;
150 U32 bucket_index;
151 for ( bucket_index= 0; bucket_index <= max_bucket_index; bucket_index++ ) {
152 I32 chain_length= BUCKET_INFO_ITEMS_ON_STACK;
153 for (he= bucket_array[bucket_index]; he; he= HeNEXT(he) ) {
154 chain_length++;
155 }
156 while ( max_chain_length < chain_length ) {
157 mXPUSHi(0);
158 max_chain_length++;
159 }
160 SvIVX( ST( chain_length ) )++;
161 }
162 /* now set the number of used buckets */
163 SvIVX( ST( BUCKET_INFO_ITEMS_ON_STACK - 1 ) ) = max_bucket_index - SvIVX( ST( BUCKET_INFO_ITEMS_ON_STACK ) ) + 1;
164 XSRETURN( max_chain_length + 1 ); /* max_chain_length is the index of the last item on the stack, so we add 1 */
165 }
166#undef BUCKET_INFO_ITEMS_ON_STACK
167 }
168 XSRETURN(0);
169}
170
171void
172bucket_array(rhv)
173 SV* rhv
174 PPCODE:
175{
176 /* Returns an array of arrays representing key/bucket mappings.
177 * Each element of the array contains either an integer or a reference
178 * to an array of keys. A plain integer represents K empty buckets. An
179 * array ref represents a single bucket, with each element being a key in
180 * the hash. (Note this treats a placeholder as a normal key.)
181 *
182 * This allows one to "see" the keyorder. Note the "insert first" nature
183 * of the hash store, combined with regular remappings means that relative
184 * order of keys changes each remap.
185 */
186 if (SvROK(rhv) && SvTYPE(SvRV(rhv))==SVt_PVHV && !SvMAGICAL(SvRV(rhv))) {
187 const HV * const hv = (const HV *) SvRV(rhv);
188 HE **he_ptr= HvARRAY(hv);
189 if (!he_ptr) {
190 XSRETURN(0);
191 } else {
192 U32 i, max;
193 AV *info_av;
194 HE *he;
195 I32 empty_count=0;
196 if (SvMAGICAL(hv)) {
197 Perl_croak(aTHX_ "hash::bucket_array only works on 'normal' hashes");
198 }
199 info_av= newAV();
200 max= HvMAX(hv);
201 mXPUSHs(newRV_noinc((SV*)info_av));
202 for ( i= 0; i <= max; i++ ) {
203 AV *key_av= NULL;
204 for (he= he_ptr[i]; he; he= HeNEXT(he) ) {
205 SV *key_sv;
206 char *str;
207 STRLEN len;
208 char mode;
209 if (!key_av) {
210 key_av= newAV();
211 if (empty_count) {
212 av_push(info_av, newSViv(empty_count));
213 empty_count= 0;
214 }
215 av_push(info_av, (SV *)newRV_noinc((SV *)key_av));
216 }
217 if (HeKLEN(he) == HEf_SVKEY) {
218 SV *sv= HeSVKEY(he);
219 SvGETMAGIC(sv);
220 str= SvPV(sv, len);
221 mode= SvUTF8(sv) ? 1 : 0;
222 } else {
223 str= HeKEY(he);
224 len= HeKLEN(he);
225 mode= HeKUTF8(he) ? 1 : 0;
226 }
227 key_sv= newSVpvn(str,len);
228 av_push(key_av,key_sv);
229 if (mode) {
230 SvUTF8_on(key_sv);
231 }
232 }
233 if (!key_av)
234 empty_count++;
235 }
236 if (empty_count) {
237 av_push(info_av, newSViv(empty_count));
238 empty_count++;
239 }
240 }
241 XSRETURN(1);
242 }
243 XSRETURN(0);
244}