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 _clear_placeholders(hashref) 11 HV *hashref 12 PROTOTYPE: \% 13 PREINIT: 14 HV *hv; 15 CODE: 16 hv = MUTABLE_HV(hashref); 17 hv_clear_placeholders(hv); 18 19 void 20 all_keys(hash,keys,placeholder) 21 HV *hash 22 AV *keys 23 AV *placeholder 24 PROTOTYPE: \%\@\@ 25 PREINIT: 26 SV *key; 27 HE *he; 28 PPCODE: 29 av_clear(keys); 30 av_clear(placeholder); 31 32 (void)hv_iterinit(hash); 33 while((he = hv_iternext_flags(hash, HV_ITERNEXT_WANTPLACEHOLDERS))!= NULL) { 34 key=hv_iterkeysv(he); 35 av_push(HeVAL(he) == &PL_sv_placeholder ? placeholder : keys, 36 SvREFCNT_inc(key)); 37 } 38 XSRETURN(1); 39 40 void 41 hidden_ref_keys(hash) 42 HV *hash 43 ALIAS: 44 Hash::Util::legal_ref_keys = 1 45 PREINIT: 46 SV *key; 47 HE *he; 48 PPCODE: 49 (void)hv_iterinit(hash); 50 while((he = hv_iternext_flags(hash, HV_ITERNEXT_WANTPLACEHOLDERS))!= NULL) { 51 key=hv_iterkeysv(he); 52 if (ix || HeVAL(he) == &PL_sv_placeholder) { 53 XPUSHs( key ); 54 } 55 } 56 57 void 58 hv_store(hash, key, val) 59 HV *hash 60 SV* key 61 SV* val 62 PROTOTYPE: \%$$ 63 CODE: 64 { 65 SvREFCNT_inc(val); 66 if (!hv_store_ent(hash, key, val, 0)) { 67 SvREFCNT_dec(val); 68 XSRETURN_NO; 69 } else { 70 XSRETURN_YES; 71 } 72 } 73 74 void 75 hash_seed() 76 PROTOTYPE: 77 PPCODE: 78 mXPUSHs(newSVpvn((char *)PERL_HASH_SEED,PERL_HASH_SEED_BYTES)); 79 XSRETURN(1); 80 81 82 void 83 hash_value(string,...) 84 SV* string 85 PROTOTYPE: $;$ 86 PPCODE: 87 { 88 UV uv; 89 STRLEN len; 90 char *pv= SvPV(string,len); 91 if (items<2) { 92 PERL_HASH(uv, pv, len); 93 } else { 94 STRLEN seedlen; 95 U8 *seedbuf= (U8 *)SvPV(ST(1),seedlen); 96 if ( seedlen < PERL_HASH_SEED_BYTES ) { 97 sv_dump(ST(1)); 98 Perl_croak(aTHX_ "seed len must be at least %d long only got %" 99 UVuf " bytes", PERL_HASH_SEED_BYTES, (UV)seedlen); 100 } 101 102 PERL_HASH_WITH_SEED(seedbuf, uv, pv, len); 103 } 104 XSRETURN_UV(uv); 105 } 106 107 void 108 hash_traversal_mask(rhv, ...) 109 SV* rhv 110 PPCODE: 111 { 112 #ifdef PERL_HASH_RANDOMIZE_KEYS 113 if (SvROK(rhv) && SvTYPE(SvRV(rhv))==SVt_PVHV && !SvMAGICAL(SvRV(rhv))) { 114 HV *hv = (HV *)SvRV(rhv); 115 if (items>1) { 116 hv_rand_set(hv, SvUV(ST(1))); 117 } 118 if (SvOOK(hv)) { 119 XSRETURN_UV(HvRAND_get(hv)); 120 } else { 121 XSRETURN_UNDEF; 122 } 123 } 124 #else 125 Perl_croak(aTHX_ "Perl has not been compiled with support for randomized hash key traversal"); 126 #endif 127 } 128 129 void 130 bucket_info(rhv) 131 SV* rhv 132 PPCODE: 133 { 134 /* 135 136 Takes a non-magical hash ref as an argument and returns a list of 137 statistics about the hash. The number and keys and the size of the 138 array will always be reported as the first two values. If the array is 139 actually allocated (they are lazily allocated), then additionally 140 will return a list of counts of bucket lengths. In other words in 141 142 ($keys, $buckets, $used, @length_count)= hash::bucket_info(\%hash); 143 144 $length_count[0] is the number of empty buckets, and $length_count[1] 145 is the number of buckets with only one key in it, $buckets - $length_count[0] 146 gives the number of used buckets, and @length_count-1 is the maximum 147 bucket depth. 148 149 If the argument is not a hash ref, or if it is magical, then returns 150 nothing (the empty list). 151 152 */ 153 const HV * hv = NULL; 154 if (SvROK(rhv) && SvTYPE(SvRV(rhv))==SVt_PVHV && !SvMAGICAL(SvRV(rhv))) { 155 hv = (const HV *) SvRV(rhv); 156 } else if (!SvOK(rhv)) { 157 hv = PL_strtab; 158 } 159 if (hv) { 160 U32 max_bucket_index= HvMAX(hv); 161 U32 total_keys= HvUSEDKEYS(hv); 162 HE **bucket_array= HvARRAY(hv); 163 mXPUSHi(total_keys); 164 mXPUSHi(max_bucket_index+1); 165 mXPUSHi(0); /* for the number of used buckets */ 166 #define BUCKET_INFO_ITEMS_ON_STACK 3 167 if (!bucket_array) { 168 XSRETURN(BUCKET_INFO_ITEMS_ON_STACK); 169 } else { 170 /* we use chain_length to index the stack - we eliminate an add 171 * by initializing things with the number of items already on the stack. 172 * If we have 2 items then ST(2+0) (the third stack item) will be the counter 173 * for empty chains, ST(2+1) will be for chains with one element, etc. 174 */ 175 I32 max_chain_length= BUCKET_INFO_ITEMS_ON_STACK - 1; /* so we do not have to do an extra push for the 0 index */ 176 HE *he; 177 U32 bucket_index; 178 for ( bucket_index= 0; bucket_index <= max_bucket_index; bucket_index++ ) { 179 I32 chain_length= BUCKET_INFO_ITEMS_ON_STACK; 180 for (he= bucket_array[bucket_index]; he; he= HeNEXT(he) ) { 181 chain_length++; 182 } 183 while ( max_chain_length < chain_length ) { 184 mXPUSHi(0); 185 max_chain_length++; 186 } 187 SvIVX( ST( chain_length ) )++; 188 } 189 /* now set the number of used buckets */ 190 SvIVX( ST( BUCKET_INFO_ITEMS_ON_STACK - 1 ) ) = max_bucket_index - SvIVX( ST( BUCKET_INFO_ITEMS_ON_STACK ) ) + 1; 191 XSRETURN( max_chain_length + 1 ); /* max_chain_length is the index of the last item on the stack, so we add 1 */ 192 } 193 #undef BUCKET_INFO_ITEMS_ON_STACK 194 } 195 XSRETURN(0); 196 } 197 198 void 199 bucket_array(rhv) 200 SV* rhv 201 PPCODE: 202 { 203 /* Returns an array of arrays representing key/bucket mappings. 204 * Each element of the array contains either an integer or a reference 205 * to an array of keys. A plain integer represents K empty buckets. An 206 * array ref represents a single bucket, with each element being a key in 207 * the hash. (Note this treats a placeholder as a normal key.) 208 * 209 * This allows one to "see" the keyorder. Note the "insert first" nature 210 * of the hash store, combined with regular remappings means that relative 211 * order of keys changes each remap. 212 */ 213 const HV * hv = NULL; 214 if (SvROK(rhv) && SvTYPE(SvRV(rhv))==SVt_PVHV && !SvMAGICAL(SvRV(rhv))) { 215 hv = (const HV *) SvRV(rhv); 216 } else if (!SvOK(rhv)) { 217 hv = PL_strtab; 218 } 219 if (hv) { 220 HE **he_ptr= HvARRAY(hv); 221 if (!he_ptr) { 222 XSRETURN(0); 223 } else { 224 U32 i, max; 225 AV *info_av; 226 HE *he; 227 I32 empty_count=0; 228 if (SvMAGICAL(hv)) { 229 Perl_croak(aTHX_ "hash::bucket_array only works on 'normal' hashes"); 230 } 231 info_av= newAV(); 232 max= HvMAX(hv); 233 mXPUSHs(newRV_noinc((SV*)info_av)); 234 for ( i= 0; i <= max; i++ ) { 235 AV *key_av= NULL; 236 for (he= he_ptr[i]; he; he= HeNEXT(he) ) { 237 SV *key_sv; 238 char *str; 239 STRLEN len; 240 char mode; 241 if (!key_av) { 242 key_av= newAV(); 243 if (empty_count) { 244 av_push(info_av, newSViv(empty_count)); 245 empty_count= 0; 246 } 247 av_push(info_av, (SV *)newRV_noinc((SV *)key_av)); 248 } 249 if (HeKLEN(he) == HEf_SVKEY) { 250 SV *sv= HeSVKEY(he); 251 SvGETMAGIC(sv); 252 str= SvPV(sv, len); 253 mode= SvUTF8(sv) ? 1 : 0; 254 } else { 255 str= HeKEY(he); 256 len= HeKLEN(he); 257 mode= HeKUTF8(he) ? 1 : 0; 258 } 259 key_sv= newSVpvn(str,len); 260 av_push(key_av,key_sv); 261 if (mode) { 262 SvUTF8_on(key_sv); 263 } 264 } 265 if (!key_av) 266 empty_count++; 267 } 268 if (empty_count) { 269 av_push(info_av, newSViv(empty_count)); 270 empty_count++; 271 } 272 } 273 XSRETURN(1); 274 } 275 XSRETURN(0); 276 } 277 278 void 279 bucket_ratio(rhv) 280 SV* rhv 281 PROTOTYPE: \% 282 PPCODE: 283 { 284 if (SvROK(rhv)) { 285 rhv= SvRV(rhv); 286 if ( SvTYPE(rhv)==SVt_PVHV ) { 287 #if PERL_VERSION < 25 288 SV *ret= Perl_hv_scalar(aTHX_ (HV*)rhv); 289 #else 290 SV *ret= Perl_hv_bucket_ratio(aTHX_ (HV*)rhv); 291 #endif 292 ST(0)= ret; 293 XSRETURN(1); 294 } 295 } 296 XSRETURN_UNDEF; 297 } 298 299 void 300 num_buckets(rhv) 301 SV* rhv 302 PROTOTYPE: \% 303 PPCODE: 304 { 305 if (SvROK(rhv)) { 306 rhv= SvRV(rhv); 307 if ( SvTYPE(rhv)==SVt_PVHV ) { 308 XSRETURN_UV(HvMAX((HV*)rhv)+1); 309 } 310 } 311 XSRETURN_UNDEF; 312 } 313 314 void 315 used_buckets(rhv) 316 SV* rhv 317 PROTOTYPE: \% 318 PPCODE: 319 { 320 if (SvROK(rhv)) { 321 rhv= SvRV(rhv); 322 if ( SvTYPE(rhv)==SVt_PVHV ) { 323 XSRETURN_UV(HvFILL((HV*)rhv)); 324 } 325 } 326 XSRETURN_UNDEF; 327 } 328 329