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 = NULL;
 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 = NULL;
 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 }