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 _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 %"UVuf" bytes", PERL_HASH_SEED_BYTES, (UV)seedlen);
  99         }
 100
 101         PERL_HASH_WITH_SEED(seedbuf, uv, pv, len);
 102     }
 103     XSRETURN_UV(uv);
 104 }
 105
 106 void
 107 hash_traversal_mask(rhv, ...)
 108         SV* rhv
 109     PPCODE:
 110 {
 111 #ifdef PERL_HASH_RANDOMIZE_KEYS
 112     if (SvROK(rhv) && SvTYPE(SvRV(rhv))==SVt_PVHV && !SvMAGICAL(SvRV(rhv))) {
 113         HV *hv = (HV *)SvRV(rhv);
 114         if (items>1) {
 115             hv_rand_set(hv, SvUV(ST(1)));
 116         }
 117         if (SvOOK(hv)) {
 118             XSRETURN_UV(HvRAND_get(hv));
 119         } else {
 120             XSRETURN_UNDEF;
 121         }
 122     }
 123 #else
 124     Perl_croak(aTHX_ "Perl has not been compiled with support for randomized hash key traversal");
 125 #endif
 126 }
 127
 128 void
 129 bucket_info(rhv)
 130         SV* rhv
 131     PPCODE:
 132 {
 133     /*
 134
 135     Takes a non-magical hash ref as an argument and returns a list of
 136     statistics about the hash. The number and keys and the size of the
 137     array will always be reported as the first two values. If the array is
 138     actually allocated (they are lazily allocated), then additionally
 139     will return a list of counts of bucket lengths. In other words in
 140
 141         ($keys, $buckets, $used, @length_count)= hash::bucket_info(\%hash);
 142
 143     $length_count[0] is the number of empty buckets, and $length_count[1]
 144     is the number of buckets with only one key in it, $buckets - $length_count[0]
 145     gives the number of used buckets, and @length_count-1 is the maximum
 146     bucket depth.
 147
 148     If the argument is not a hash ref, or if it is magical, then returns
 149     nothing (the empty list).
 150
 151     */
 152     const HV * hv = NULL;
 153     if (SvROK(rhv) && SvTYPE(SvRV(rhv))==SVt_PVHV && !SvMAGICAL(SvRV(rhv))) {
 154         hv = (const HV *) SvRV(rhv);
 155     } else if (!SvOK(rhv)) {
 156         hv = PL_strtab;
 157     }
 158     if (hv) {
 159         U32 max_bucket_index= HvMAX(hv);
 160         U32 total_keys= HvUSEDKEYS(hv);
 161         HE **bucket_array= HvARRAY(hv);
 162         mXPUSHi(total_keys);
 163         mXPUSHi(max_bucket_index+1);
 164         mXPUSHi(0); /* for the number of used buckets */
 165 #define BUCKET_INFO_ITEMS_ON_STACK 3
 166         if (!bucket_array) {
 167             XSRETURN(BUCKET_INFO_ITEMS_ON_STACK);
 168         } else {
 169             /* we use chain_length to index the stack - we eliminate an add
 170              * by initializing things with the number of items already on the stack.
 171              * If we have 2 items then ST(2+0) (the third stack item) will be the counter
 172              * for empty chains, ST(2+1) will be for chains with one element,  etc.
 173              */
 174             I32 max_chain_length= BUCKET_INFO_ITEMS_ON_STACK - 1; /* so we do not have to do an extra push for the 0 index */
 175             HE *he;
 176             U32 bucket_index;
 177             for ( bucket_index= 0; bucket_index <= max_bucket_index; bucket_index++ ) {
 178                 I32 chain_length= BUCKET_INFO_ITEMS_ON_STACK;
 179                 for (he= bucket_array[bucket_index]; he; he= HeNEXT(he) ) {
 180                     chain_length++;
 181                 }
 182                 while ( max_chain_length < chain_length ) {
 183                     mXPUSHi(0);
 184                     max_chain_length++;
 185                 }
 186                 SvIVX( ST( chain_length ) )++;
 187             }
 188             /* now set the number of used buckets */
 189             SvIVX( ST( BUCKET_INFO_ITEMS_ON_STACK - 1 ) ) = max_bucket_index - SvIVX( ST( BUCKET_INFO_ITEMS_ON_STACK ) ) + 1;
 190             XSRETURN( max_chain_length + 1 ); /* max_chain_length is the index of the last item on the stack, so we add 1 */
 191         }
 192 #undef BUCKET_INFO_ITEMS_ON_STACK
 193     }
 194     XSRETURN(0);
 195 }
 196
 197 void
 198 bucket_array(rhv)
 199         SV* rhv
 200     PPCODE:
 201 {
 202     /* Returns an array of arrays representing key/bucket mappings.
 203      * Each element of the array contains either an integer or a reference
 204      * to an array of keys. A plain integer represents K empty buckets. An
 205      * array ref represents a single bucket, with each element being a key in
 206      * the hash. (Note this treats a placeholder as a normal key.)
 207      *
 208      * This allows one to "see" the keyorder. Note the "insert first" nature
 209      * of the hash store, combined with regular remappings means that relative
 210      * order of keys changes each remap.
 211      */
 212     const HV * hv = NULL;
 213     if (SvROK(rhv) && SvTYPE(SvRV(rhv))==SVt_PVHV && !SvMAGICAL(SvRV(rhv))) {
 214         hv = (const HV *) SvRV(rhv);
 215     } else if (!SvOK(rhv)) {
 216         hv = PL_strtab;
 217     }
 218     if (hv) {
 219         HE **he_ptr= HvARRAY(hv);
 220         if (!he_ptr) {
 221             XSRETURN(0);
 222         } else {
 223             U32 i, max;
 224             AV *info_av;
 225             HE *he;
 226             I32 empty_count=0;
 227             if (SvMAGICAL(hv)) {
 228                 Perl_croak(aTHX_ "hash::bucket_array only works on 'normal' hashes");
 229             }
 230             info_av= newAV();
 231             max= HvMAX(hv);
 232             mXPUSHs(newRV_noinc((SV*)info_av));
 233             for ( i= 0; i <= max; i++ ) {
 234                 AV *key_av= NULL;
 235                 for (he= he_ptr[i]; he; he= HeNEXT(he) ) {
 236                     SV *key_sv;
 237                     char *str;
 238                     STRLEN len;
 239                     char mode;
 240                     if (!key_av) {
 241                         key_av= newAV();
 242                         if (empty_count) {
 243                             av_push(info_av, newSViv(empty_count));
 244                             empty_count= 0;
 245                         }
 246                         av_push(info_av, (SV *)newRV_noinc((SV *)key_av));
 247                     }
 248                     if (HeKLEN(he) == HEf_SVKEY) {
 249                         SV *sv= HeSVKEY(he);
 250                         SvGETMAGIC(sv);
 251                         str= SvPV(sv, len);
 252                         mode= SvUTF8(sv) ? 1 : 0;
 253                     } else {
 254                         str= HeKEY(he);
 255                         len= HeKLEN(he);
 256                         mode= HeKUTF8(he) ? 1 : 0;
 257                     }
 258                     key_sv= newSVpvn(str,len);
 259                     av_push(key_av,key_sv);
 260                     if (mode) {
 261                         SvUTF8_on(key_sv);
 262                     }
 263                 }
 264                 if (!key_av)
 265                     empty_count++;
 266             }
 267             if (empty_count) {
 268                 av_push(info_av, newSViv(empty_count));
 269                 empty_count++;
 270             }
 271         }
 272         XSRETURN(1);
 273     }
 274     XSRETURN(0);
 275 }
 276
 277 void
 278 bucket_ratio(rhv)
 279         SV* rhv
 280     PROTOTYPE: \%
 281     PPCODE:
 282 {
 283     if (SvROK(rhv)) {
 284         rhv= SvRV(rhv);
 285         if ( SvTYPE(rhv)==SVt_PVHV ) {
 286 #if PERL_VERSION < 25
 287             SV *ret= Perl_hv_scalar(aTHX_ (HV*)rhv);
 288 #else
 289             SV *ret= Perl_hv_bucket_ratio(aTHX_ (HV*)rhv);
 290 #endif
 291             ST(0)= ret;
 292             XSRETURN(1);
 293         }
 294     }
 295     XSRETURN_UNDEF;
 296 }
 297
 298 void
 299 num_buckets(rhv)
 300         SV* rhv
 301     PROTOTYPE: \%
 302     PPCODE:
 303 {
 304     if (SvROK(rhv)) {
 305         rhv= SvRV(rhv);
 306         if ( SvTYPE(rhv)==SVt_PVHV ) {
 307             XSRETURN_UV(HvMAX((HV*)rhv)+1);
 308         }
 309     }
 310     XSRETURN_UNDEF;
 311 }
 312
 313 void
 314 used_buckets(rhv)
 315         SV* rhv
 316     PROTOTYPE: \%
 317     PPCODE:
 318 {
 319     if (SvROK(rhv)) {
 320         rhv= SvRV(rhv);
 321         if ( SvTYPE(rhv)==SVt_PVHV ) {
 322             XSRETURN_UV(HvFILL((HV*)rhv));
 323         }
 324     }
 325     XSRETURN_UNDEF;
 326 }
 327