fix build issue with picky compilers
[perl.git] / ext / Hash-Util / Util.xs
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         av_clear(keys);
20         av_clear(placeholder);
21
22         (void)hv_iterinit(hash);
23         while((he = hv_iternext_flags(hash, HV_ITERNEXT_WANTPLACEHOLDERS))!= NULL) {
24             key=hv_iterkeysv(he);
25             av_push(HeVAL(he) == &PL_sv_placeholder ? placeholder : keys,
26                     SvREFCNT_inc(key));
27         }
28         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         (void)hv_iterinit(hash);
40         while((he = hv_iternext_flags(hash, HV_ITERNEXT_WANTPLACEHOLDERS))!= NULL) {
41             key=hv_iterkeysv(he);
42             if (ix || HeVAL(he) == &PL_sv_placeholder) {
43                 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         if (!hv_store_ent(hash, key, val, 0)) {
57             SvREFCNT_dec(val);
58             XSRETURN_NO;
59         } else {
60             XSRETURN_YES;
61         }
62     }
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
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     pv= SvPV(string,len);
82     PERL_HASH(uv,pv,len);
83     XSRETURN_UV(uv);
84
85 void
86 hash_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))) {
92         HV *hv = SvRV(rhv);
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 }
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     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
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     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 }