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
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 {
78     UV uv;
79     STRLEN len;
80     char *pv= SvPV(string,len);
81     if (items<2) {
82         PERL_HASH(uv, pv, len);
83     } else {
84         STRLEN seedlen;
85         U8 *seedbuf= (U8 *)SvPV(ST(1),seedlen);
86         if ( seedlen < PERL_HASH_SEED_BYTES ) {
87             sv_dump(ST(1));
88             Perl_croak(aTHX_ "seed len must be at least %d long only got %"UVuf" bytes", PERL_HASH_SEED_BYTES, (UV)seedlen);
89         }
90
91         PERL_HASH_WITH_SEED(seedbuf, uv, pv, len);
92     }
93     XSRETURN_UV(uv);
94 }
95
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))) {
103         HV *hv = (HV *)SvRV(rhv);
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 }
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     */
142     const HV * hv;
143     if (SvROK(rhv) && SvTYPE(SvRV(rhv))==SVt_PVHV && !SvMAGICAL(SvRV(rhv))) {
144         hv = (const HV *) SvRV(rhv);
145     } else if (!SvOK(rhv)) {
146         hv = PL_strtab;
147     }
148     if (hv) {
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      */
202     const HV * hv;
203     if (SvROK(rhv) && SvTYPE(SvRV(rhv))==SVt_PVHV && !SvMAGICAL(SvRV(rhv))) {
204         hv = (const HV *) SvRV(rhv);
205     } else if (!SvOK(rhv)) {
206         hv = PL_strtab;
207     }
208     if (hv) {
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 }