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 void
  72 hash_value(string)
  73         SV* string
  74     PROTOTYPE: $
  75     PPCODE:
  76     STRLEN len;
  77     char *pv;
  78     UV uv;
  79
  80     pv= SvPV(string,len);
  81     PERL_HASH(uv,pv,len);
  82     XSRETURN_UV(uv);
  83
  84
  85 void
  86 bucket_info(rhv)
  87         SV* rhv
  88     PPCODE:
  89 {
  90     /*
  91
  92     Takes a non-magical hash ref as an argument and returns a list of
  93     statistics about the hash. The number and keys and the size of the
  94     array will always be reported as the first two values. If the array is
  95     actually allocated (they are lazily allocated), then additionally
  96     will return a list of counts of bucket lengths. In other words in
  97
  98         ($keys, $buckets, $used, @length_count)= hash::bucket_info(\%hash);
  99
 100     $length_count[0] is the number of empty buckets, and $length_count[1]
 101     is the number of buckets with only one key in it, $buckets - $length_count[0]
 102     gives the number of used buckets, and @length_count-1 is the maximum
 103     bucket depth.
 104
 105     If the argument is not a hash ref, or if it is magical, then returns
 106     nothing (the empty list).
 107
 108     */
 109     if (SvROK(rhv) && SvTYPE(SvRV(rhv))==SVt_PVHV && !SvMAGICAL(SvRV(rhv))) {
 110         const HV * const hv = (const HV *) SvRV(rhv);
 111         U32 max_bucket_index= HvMAX(hv);
 112         U32 total_keys= HvUSEDKEYS(hv);
 113         HE **bucket_array= HvARRAY(hv);
 114         mXPUSHi(total_keys);
 115         mXPUSHi(max_bucket_index+1);
 116         mXPUSHi(0); /* for the number of used buckets */
 117 #define BUCKET_INFO_ITEMS_ON_STACK 3
 118         if (!bucket_array) {
 119             XSRETURN(BUCKET_INFO_ITEMS_ON_STACK);
 120         } else {
 121             /* we use chain_length to index the stack - we eliminate an add
 122              * by initializing things with the number of items already on the stack.
 123              * If we have 2 items then ST(2+0) (the third stack item) will be the counter
 124              * for empty chains, ST(2+1) will be for chains with one element,  etc.
 125              */
 126             I32 max_chain_length= BUCKET_INFO_ITEMS_ON_STACK - 1; /* so we do not have to do an extra push for the 0 index */
 127             HE *he;
 128             U32 bucket_index;
 129             for ( bucket_index= 0; bucket_index <= max_bucket_index; bucket_index++ ) {
 130                 I32 chain_length= BUCKET_INFO_ITEMS_ON_STACK;
 131                 for (he= bucket_array[bucket_index]; he; he= HeNEXT(he) ) {
 132                     chain_length++;
 133                 }
 134                 while ( max_chain_length < chain_length ) {
 135                     mXPUSHi(0);
 136                     max_chain_length++;
 137                 }
 138                 SvIVX( ST( chain_length ) )++;
 139             }
 140             /* now set the number of used buckets */
 141             SvIVX( ST( BUCKET_INFO_ITEMS_ON_STACK - 1 ) ) = max_bucket_index - SvIVX( ST( BUCKET_INFO_ITEMS_ON_STACK ) ) + 1;
 142             XSRETURN( max_chain_length + 1 ); /* max_chain_length is the index of the last item on the stack, so we add 1 */
 143         }
 144 #undef BUCKET_INFO_ITEMS_ON_STACK
 145     }
 146     XSRETURN(0);
 147 }
 148
 149 void
 150 bucket_array(rhv)
 151         SV* rhv
 152     PPCODE:
 153 {
 154     /* Returns an array of arrays representing key/bucket mappings.
 155      * Each element of the array contains either an integer or a reference
 156      * to an array of keys. A plain integer represents K empty buckets. An
 157      * array ref represents a single bucket, with each element being a key in
 158      * the hash. (Note this treats a placeholder as a normal key.)
 159      *
 160      * This allows one to "see" the keyorder. Note the "insert first" nature
 161      * of the hash store, combined with regular remappings means that relative
 162      * order of keys changes each remap.
 163      */
 164     if (SvROK(rhv) && SvTYPE(SvRV(rhv))==SVt_PVHV && !SvMAGICAL(SvRV(rhv))) {
 165         const HV * const hv = (const HV *) SvRV(rhv);
 166         HE **he_ptr= HvARRAY(hv);
 167         if (!he_ptr) {
 168             XSRETURN(0);
 169         } else {
 170             U32 i, max;
 171             AV *info_av;
 172             HE *he;
 173             I32 empty_count=0;
 174             if (SvMAGICAL(hv)) {
 175                 Perl_croak(aTHX_ "hash::bucket_array only works on 'normal' hashes");
 176             }
 177             info_av= newAV();
 178             max= HvMAX(hv);
 179             mXPUSHs(newRV_noinc((SV*)info_av));
 180             for ( i= 0; i <= max; i++ ) {
 181                 AV *key_av= NULL;
 182                 for (he= he_ptr[i]; he; he= HeNEXT(he) ) {
 183                     SV *key_sv;
 184                     char *str;
 185                     STRLEN len;
 186                     char mode;
 187                     if (!key_av) {
 188                         key_av= newAV();
 189                         if (empty_count) {
 190                             av_push(info_av, newSViv(empty_count));
 191                             empty_count= 0;
 192                         }
 193                         av_push(info_av, (SV *)newRV_noinc((SV *)key_av));
 194                     }
 195                     if (HeKLEN(he) == HEf_SVKEY) {
 196                         SV *sv= HeSVKEY(he);
 197                         SvGETMAGIC(sv);
 198                         str= SvPV(sv, len);
 199                         mode= SvUTF8(sv) ? 1 : 0;
 200                     } else {
 201                         str= HeKEY(he);
 202                         len= HeKLEN(he);
 203                         mode= HeKUTF8(he) ? 1 : 0;
 204                     }
 205                     key_sv= newSVpvn(str,len);
 206                     av_push(key_av,key_sv);
 207                     if (mode) {
 208                         SvUTF8_on(key_sv);
 209                     }
 210                 }
 211                 if (!key_av)
 212                     empty_count++;
 213             }
 214             if (empty_count) {
 215                 av_push(info_av, newSViv(empty_count));
 216                 empty_count++;
 217             }
 218         }
 219         XSRETURN(1);
 220     }
 221     XSRETURN(0);
 222 }