This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
hoping this works finally. gcc is too permissive with my build options
[perl5.git] / ext / Hash-Util / Util.xs
index 03b049f..2758d69 100644 (file)
+#define PERL_NO_GET_CONTEXT
+
 #include "EXTERN.h"
 #include "perl.h"
 #include "XSUB.h"
 
-
 MODULE = Hash::Util            PACKAGE = Hash::Util
 
-
-SV*
+void
 all_keys(hash,keys,placeholder)
-       SV* hash
-       SV* keys
-       SV* placeholder
+       HV *hash
+       AV *keys
+       AV *placeholder
     PROTOTYPE: \%\@\@
     PREINIT:
-       AV* av_k;
-        AV* av_p;
-        HV* hv;
         SV *key;
         HE *he;
-    CODE:
-       if (!SvROK(hash) || SvTYPE(SvRV(hash)) != SVt_PVHV)
-          croak("First argument to all_keys() must be an HASH reference");
-       if (!SvROK(keys) || SvTYPE(SvRV(keys)) != SVt_PVAV)
-          croak("Second argument to all_keys() must be an ARRAY reference");
-        if (!SvROK(placeholder) || SvTYPE(SvRV(placeholder)) != SVt_PVAV)
-          croak("Third argument to all_keys() must be an ARRAY reference");
-
-       hv = (HV*)SvRV(hash);
-       av_k = (AV*)SvRV(keys);
-       av_p = (AV*)SvRV(placeholder);
-
-        av_clear(av_k);
-        av_clear(av_p);
-
-        (void)hv_iterinit(hv);
-       while((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))!= NULL) {
+    PPCODE:
+        av_clear(keys);
+        av_clear(placeholder);
+
+        (void)hv_iterinit(hash);
+       while((he = hv_iternext_flags(hash, HV_ITERNEXT_WANTPLACEHOLDERS))!= NULL) {
            key=hv_iterkeysv(he);
-            if (HeVAL(he) == &PL_sv_placeholder) {
-                SvREFCNT_inc(key);
-               av_push(av_p, key);
-            } else {
-                SvREFCNT_inc(key);
-               av_push(av_k, key);
-            }
+           av_push(HeVAL(he) == &PL_sv_placeholder ? placeholder : keys,
+                   SvREFCNT_inc(key));
         }
-        RETVAL=hash;
-
+       XSRETURN(1);
 
 void
 hidden_ref_keys(hash)
-       SV* hash
+       HV *hash
+    ALIAS:
+       Hash::Util::legal_ref_keys = 1
     PREINIT:
-        HV* hv;
         SV *key;
         HE *he;
     PPCODE:
-       if (!SvROK(hash) || SvTYPE(SvRV(hash)) != SVt_PVHV)
-          croak("First argument to hidden_keys() must be an HASH reference");
-
-       hv = (HV*)SvRV(hash);
-
-        (void)hv_iterinit(hv);
-       while((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))!= NULL) {
+        (void)hv_iterinit(hash);
+       while((he = hv_iternext_flags(hash, HV_ITERNEXT_WANTPLACEHOLDERS))!= NULL) {
            key=hv_iterkeysv(he);
-            if (HeVAL(he) == &PL_sv_placeholder) {
+            if (ix || HeVAL(he) == &PL_sv_placeholder) {
                 XPUSHs( key );
             }
         }
 
 void
-legal_ref_keys(hash)
-       SV* hash
-    PREINIT:
-        HV* hv;
-        SV *key;
-        HE *he;
-    PPCODE:
-       if (!SvROK(hash) || SvTYPE(SvRV(hash)) != SVt_PVHV)
-          croak("First argument to legal_keys() must be an HASH reference");
-
-       hv = (HV*)SvRV(hash);
-
-        (void)hv_iterinit(hv);
-       while((he = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))!= NULL) {
-           key=hv_iterkeysv(he);
-            XPUSHs( key );
-        }
-
-void
-hv_store(hvref, key, val)
-       SV* hvref
+hv_store(hash, key, val)
+       HV *hash
        SV* key
        SV* val
     PROTOTYPE: \%$$
-    PREINIT:
-       HV* hv;
     CODE:
     {
-       if (!SvROK(hvref) || SvTYPE(SvRV(hvref)) != SVt_PVHV)
-          croak("First argument to hv_store() must be a HASH reference");
-       hv = (HV*)SvRV(hvref);
         SvREFCNT_inc(val);
-       if (!hv_store_ent(hv, key, val, 0)) {
+       if (!hv_store_ent(hash, key, val, 0)) {
            SvREFCNT_dec(val);
            XSRETURN_NO;
        } else {
@@ -109,3 +61,184 @@ hv_store(hvref, key, val)
        }
     }
 
+void
+hash_seed()
+    PROTOTYPE:
+    PPCODE:
+    mXPUSHs(newSVpvn((char *)PERL_HASH_SEED,PERL_HASH_SEED_BYTES));
+    XSRETURN(1);
+
+
+void
+hash_value(string)
+        SV* string
+    PROTOTYPE: $
+    PPCODE:
+    STRLEN len;
+    char *pv;
+    UV uv;
+
+    pv= SvPV(string,len);
+    PERL_HASH(uv,pv,len);
+    XSRETURN_UV(uv);
+
+void
+hash_traversal_mask(rhv, ...)
+        SV* rhv
+    PPCODE:
+{
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+    if (SvROK(rhv) && SvTYPE(SvRV(rhv))==SVt_PVHV && !SvMAGICAL(SvRV(rhv))) {
+        HV *hv = (HV *)SvRV(rhv);
+        if (items>1) {
+            hv_rand_set(hv, SvUV(ST(1)));
+        }
+        if (SvOOK(hv)) {
+            XSRETURN_UV(HvRAND_get(hv));
+        } else {
+            XSRETURN_UNDEF;
+        }
+    }
+#else
+    Perl_croak(aTHX_ "Perl has not been compiled with support for randomized hash key traversal");
+#endif
+}
+
+void
+bucket_info(rhv)
+        SV* rhv
+    PPCODE:
+{
+    /*
+
+    Takes a non-magical hash ref as an argument and returns a list of
+    statistics about the hash. The number and keys and the size of the
+    array will always be reported as the first two values. If the array is
+    actually allocated (they are lazily allocated), then additionally
+    will return a list of counts of bucket lengths. In other words in
+
+        ($keys, $buckets, $used, @length_count)= hash::bucket_info(\%hash);
+
+    $length_count[0] is the number of empty buckets, and $length_count[1]
+    is the number of buckets with only one key in it, $buckets - $length_count[0]
+    gives the number of used buckets, and @length_count-1 is the maximum
+    bucket depth.
+
+    If the argument is not a hash ref, or if it is magical, then returns
+    nothing (the empty list).
+
+    */
+    if (SvROK(rhv) && SvTYPE(SvRV(rhv))==SVt_PVHV && !SvMAGICAL(SvRV(rhv))) {
+        const HV * const hv = (const HV *) SvRV(rhv);
+        U32 max_bucket_index= HvMAX(hv);
+        U32 total_keys= HvUSEDKEYS(hv);
+        HE **bucket_array= HvARRAY(hv);
+        mXPUSHi(total_keys);
+        mXPUSHi(max_bucket_index+1);
+        mXPUSHi(0); /* for the number of used buckets */
+#define BUCKET_INFO_ITEMS_ON_STACK 3
+        if (!bucket_array) {
+            XSRETURN(BUCKET_INFO_ITEMS_ON_STACK);
+        } else {
+            /* we use chain_length to index the stack - we eliminate an add
+             * by initializing things with the number of items already on the stack.
+             * If we have 2 items then ST(2+0) (the third stack item) will be the counter
+             * for empty chains, ST(2+1) will be for chains with one element,  etc.
+             */
+            I32 max_chain_length= BUCKET_INFO_ITEMS_ON_STACK - 1; /* so we do not have to do an extra push for the 0 index */
+            HE *he;
+            U32 bucket_index;
+            for ( bucket_index= 0; bucket_index <= max_bucket_index; bucket_index++ ) {
+                I32 chain_length= BUCKET_INFO_ITEMS_ON_STACK;
+                for (he= bucket_array[bucket_index]; he; he= HeNEXT(he) ) {
+                    chain_length++;
+                }
+                while ( max_chain_length < chain_length ) {
+                    mXPUSHi(0);
+                    max_chain_length++;
+                }
+                SvIVX( ST( chain_length ) )++;
+            }
+            /* now set the number of used buckets */
+            SvIVX( ST( BUCKET_INFO_ITEMS_ON_STACK - 1 ) ) = max_bucket_index - SvIVX( ST( BUCKET_INFO_ITEMS_ON_STACK ) ) + 1;
+            XSRETURN( max_chain_length + 1 ); /* max_chain_length is the index of the last item on the stack, so we add 1 */
+        }
+#undef BUCKET_INFO_ITEMS_ON_STACK
+    }
+    XSRETURN(0);
+}
+
+void
+bucket_array(rhv)
+        SV* rhv
+    PPCODE:
+{
+    /* Returns an array of arrays representing key/bucket mappings.
+     * Each element of the array contains either an integer or a reference
+     * to an array of keys. A plain integer represents K empty buckets. An
+     * array ref represents a single bucket, with each element being a key in
+     * the hash. (Note this treats a placeholder as a normal key.)
+     *
+     * This allows one to "see" the keyorder. Note the "insert first" nature
+     * of the hash store, combined with regular remappings means that relative
+     * order of keys changes each remap.
+     */
+    if (SvROK(rhv) && SvTYPE(SvRV(rhv))==SVt_PVHV && !SvMAGICAL(SvRV(rhv))) {
+        const HV * const hv = (const HV *) SvRV(rhv);
+        HE **he_ptr= HvARRAY(hv);
+        if (!he_ptr) {
+            XSRETURN(0);
+        } else {
+            U32 i, max;
+            AV *info_av;
+            HE *he;
+            I32 empty_count=0;
+            if (SvMAGICAL(hv)) {
+                Perl_croak(aTHX_ "hash::bucket_array only works on 'normal' hashes");
+            }
+            info_av= newAV();
+            max= HvMAX(hv);
+            mXPUSHs(newRV_noinc((SV*)info_av));
+            for ( i= 0; i <= max; i++ ) {
+                AV *key_av= NULL;
+                for (he= he_ptr[i]; he; he= HeNEXT(he) ) {
+                    SV *key_sv;
+                    char *str;
+                    STRLEN len;
+                    char mode;
+                    if (!key_av) {
+                        key_av= newAV();
+                        if (empty_count) {
+                            av_push(info_av, newSViv(empty_count));
+                            empty_count= 0;
+                        }
+                        av_push(info_av, (SV *)newRV_noinc((SV *)key_av));
+                    }
+                    if (HeKLEN(he) == HEf_SVKEY) {
+                        SV *sv= HeSVKEY(he);
+                        SvGETMAGIC(sv);
+                        str= SvPV(sv, len);
+                        mode= SvUTF8(sv) ? 1 : 0;
+                    } else {
+                        str= HeKEY(he);
+                        len= HeKLEN(he);
+                        mode= HeKUTF8(he) ? 1 : 0;
+                    }
+                    key_sv= newSVpvn(str,len);
+                    av_push(key_av,key_sv);
+                    if (mode) {
+                        SvUTF8_on(key_sv);
+                    }
+                }
+                if (!key_av)
+                    empty_count++;
+            }
+            if (empty_count) {
+                av_push(info_av, newSViv(empty_count));
+                empty_count++;
+            }
+        }
+        XSRETURN(1);
+    }
+    XSRETURN(0);
+}