File Coverage

ext/Hash-Util/Util.xs
Criterion Covered Total %
statement 0 82 0.0
branch n/a
condition n/a
subroutine n/a
total 0 82 0.0


line stmt bran cond sub time code
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           all_keys(hash,keys,placeholder)
11           HV *hash
12           AV *keys
13           AV *placeholder
14           PROTOTYPE: \%\@\@
15           PREINIT:
16           SV *key;
17           HE *he;
18           PPCODE:
19 0         av_clear(keys);
20 0         av_clear(placeholder);
21            
22 0         (void)hv_iterinit(hash);
23 0         while((he = hv_iternext_flags(hash, HV_ITERNEXT_WANTPLACEHOLDERS))!= NULL) {
24 0         key=hv_iterkeysv(he);
25 0         av_push(HeVAL(he) == &PL_sv_placeholder ? placeholder : keys,
26           SvREFCNT_inc(key));
27           }
28 0         XSRETURN(1);
29            
30           void
31           hidden_ref_keys(hash)
32           HV *hash
33           ALIAS:
34           Hash::Util::legal_ref_keys = 1
35           PREINIT:
36           SV *key;
37           HE *he;
38           PPCODE:
39 0         (void)hv_iterinit(hash);
40 0         while((he = hv_iternext_flags(hash, HV_ITERNEXT_WANTPLACEHOLDERS))!= NULL) {
41 0         key=hv_iterkeysv(he);
42 0         if (ix || HeVAL(he) == &PL_sv_placeholder) {
43 0         XPUSHs( key );
44           }
45           }
46            
47           void
48           hv_store(hash, key, val)
49           HV *hash
50           SV* key
51           SV* val
52           PROTOTYPE: \%$$
53           CODE:
54           {
55           SvREFCNT_inc(val);
56 0         if (!hv_store_ent(hash, key, val, 0)) {
57           SvREFCNT_dec(val);
58 0         XSRETURN_NO;
59           } else {
60 0         XSRETURN_YES;
61           }
62           }
63            
64           void
65           hash_seed()
66           PROTOTYPE:
67           PPCODE:
68 0         mXPUSHs(newSVpvn((char *)PERL_HASH_SEED,PERL_HASH_SEED_BYTES));
69 0         XSRETURN(1);
70            
71            
72           void
73           hash_value(string)
74           SV* string
75           PROTOTYPE: $
76           PPCODE:
77           STRLEN len;
78           char *pv;
79           UV uv;
80            
81 0         pv= SvPV(string,len);
82 0         PERL_HASH(uv,pv,len);
83 0         XSRETURN_UV(uv);
84            
85           void
86           hash_traversal_mask(rhv, ...)
87           SV* rhv
88           PPCODE:
89           {
90           #ifdef PERL_HASH_RANDOMIZE_KEYS
91 0         if (SvROK(rhv) && SvTYPE(SvRV(rhv))==SVt_PVHV && !SvMAGICAL(SvRV(rhv))) {
92 0         HV *hv = (HV *)SvRV(rhv);
93 0         if (items>1) {
94 0         hv_rand_set(hv, SvUV(ST(1)));
95           }
96 0         if (SvOOK(hv)) {
97 0         XSRETURN_UV(HvRAND_get(hv));
98           } else {
99 0         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           }
106            
107           void
108           bucket_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 0         if (SvROK(rhv) && SvTYPE(SvRV(rhv))==SVt_PVHV && !SvMAGICAL(SvRV(rhv))) {
132 0         const HV * const hv = (const HV *) SvRV(rhv);
133 0         U32 max_bucket_index= HvMAX(hv);
134 0         U32 total_keys= HvUSEDKEYS(hv);
135 0         HE **bucket_array= HvARRAY(hv);
136 0         mXPUSHi(total_keys);
137 0         mXPUSHi(max_bucket_index+1);
138 0         mXPUSHi(0); /* for the number of used buckets */
139           #define BUCKET_INFO_ITEMS_ON_STACK 3
140 0         if (!bucket_array) {
141 0         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 0         for ( bucket_index= 0; bucket_index <= max_bucket_index; bucket_index++ ) {
152           I32 chain_length= BUCKET_INFO_ITEMS_ON_STACK;
153 0         for (he= bucket_array[bucket_index]; he; he= HeNEXT(he) ) {
154 0         chain_length++;
155           }
156 0         while ( max_chain_length < chain_length ) {
157 0         mXPUSHi(0);
158 0         max_chain_length++;
159           }
160 0         SvIVX( ST( chain_length ) )++;
161           }
162           /* now set the number of used buckets */
163 0         SvIVX( ST( BUCKET_INFO_ITEMS_ON_STACK - 1 ) ) = max_bucket_index - SvIVX( ST( BUCKET_INFO_ITEMS_ON_STACK ) ) + 1;
164 0         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 0         XSRETURN(0);
169           }
170            
171           void
172           bucket_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 0         if (SvROK(rhv) && SvTYPE(SvRV(rhv))==SVt_PVHV && !SvMAGICAL(SvRV(rhv))) {
187 0         const HV * const hv = (const HV *) SvRV(rhv);
188 0         HE **he_ptr= HvARRAY(hv);
189 0         if (!he_ptr) {
190 0         XSRETURN(0);
191           } else {
192           U32 i, max;
193           AV *info_av;
194           HE *he;
195           I32 empty_count=0;
196 0         if (SvMAGICAL(hv)) {
197 0         Perl_croak(aTHX_ "hash::bucket_array only works on 'normal' hashes");
198           }
199 0         info_av= newAV();
200 0         max= HvMAX(hv);
201 0         mXPUSHs(newRV_noinc((SV*)info_av));
202 0         for ( i= 0; i <= max; i++ ) {
203           AV *key_av= NULL;
204 0         for (he= he_ptr[i]; he; he= HeNEXT(he) ) {
205           SV *key_sv;
206           char *str;
207           STRLEN len;
208           char mode;
209 0         if (!key_av) {
210 0         key_av= newAV();
211 0         if (empty_count) {
212 0         av_push(info_av, newSViv(empty_count));
213           empty_count= 0;
214           }
215 0         av_push(info_av, (SV *)newRV_noinc((SV *)key_av));
216           }
217 0         if (HeKLEN(he) == HEf_SVKEY) {
218 0         SV *sv= HeSVKEY(he);
219 0         SvGETMAGIC(sv);
220 0         str= SvPV(sv, len);
221 0         mode= SvUTF8(sv) ? 1 : 0;
222           } else {
223 0         str= HeKEY(he);
224 0         len= HeKLEN(he);
225 0         mode= HeKUTF8(he) ? 1 : 0;
226           }
227 0         key_sv= newSVpvn(str,len);
228 0         av_push(key_av,key_sv);
229 0         if (mode) {
230 0         SvUTF8_on(key_sv);
231           }
232           }
233 0         if (!key_av)
234 0         empty_count++;
235           }
236 0         if (empty_count) {
237 0         av_push(info_av, newSViv(empty_count));
238           empty_count++;
239           }
240           }
241 0         XSRETURN(1);
242           }
243 0         XSRETURN(0);
244           }