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 %"
  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