[Patch] Enhance Hash::Util
authorYves Orton <demerphq@gmail.com>
Mon, 13 Feb 2006 11:39:33 +0000 (12:39 +0100)
committerSteve Peters <steve@fisharerojo.org>
Tue, 14 Feb 2006 17:08:08 +0000 (17:08 +0000)
Message-ID: <9b18b3110602130239w311d05fcr776ae8333776ca2e@mail.gmail.com>

p4raw-id: //depot/perl@27180

MANIFEST
ext/Hash/Util/Changes [new file with mode: 0644]
ext/Hash/Util/Makefile.PL [new file with mode: 0644]
ext/Hash/Util/Util.xs [new file with mode: 0644]
ext/Hash/Util/lib/Hash/Util.pm [new file with mode: 0644]
ext/Hash/Util/t/Util.t [moved from lib/Hash/Util.t with 62% similarity]
lib/Hash/Util.pm [deleted file]
win32/Makefile
win32/makefile.mk

index 96808ee..a0ed64b 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -763,6 +763,11 @@ ext/GDBM_File/hints/sco.pl Hint for GDBM_File for named architecture
 ext/GDBM_File/Makefile.PL      GDBM extension makefile writer
 ext/GDBM_File/t/gdbm.t         See if GDBM_File works
 ext/GDBM_File/typemap          GDBM extension interface types
+ext/Hash/Util/Changes          Change history of Hash::Util
+ext/Hash/Util/lib/Hash/Util.pm Hash::Util
+ext/Hash/Util/Makefile.PL      Makefile for Hash::Util
+ext/Hash/Util/t/Util.t         See if Hash::Util works
+ext/Hash/Util/Util.xs          XS bits of Hash::Util
 ext/I18N/Langinfo/fallback/const-c.inc I18N::Langinfo
 ext/I18N/Langinfo/fallback/const-xs.inc        I18N::Langinfo
 ext/I18N/Langinfo/Langinfo.pm  I18N::Langinfo
@@ -1735,8 +1740,6 @@ lib/Getopt/Std.pm         Fetch command options (getopt, getopts)
 lib/Getopt/Std.t               See if Getopt::Std and Getopt::Long work
 lib/h2ph.t                     See if h2ph works like it should
 lib/h2xs.t                     See if h2xs produces expected lists of files
-lib/Hash/Util.pm               Hash::Util
-lib/Hash/Util.t                        See if Hash::Util works
 lib/hostname.pl                        Old hostname code
 lib/I18N/Collate.pm            Routines to do strxfrm-based collation
 lib/I18N/Collate.t             See if I18N::Collate works
diff --git a/ext/Hash/Util/Changes b/ext/Hash/Util/Changes
new file mode 100644 (file)
index 0000000..f6ba16b
--- /dev/null
@@ -0,0 +1,18 @@
+Revision history for Perl extension Hash::Util.
+
+0.05
+
+Pre /ext version of the code. By Michael G Schwern <schwern@pobox.com>
+on top of code by Nick Ing-Simmons and Jeffrey Friedl.
+
+0.06  Thu Mar 25 20:26:32 2004
+       - original XS version; created by h2xs 1.21 with options
+               -n Hash::Util -A
+        XS Code and additional Perl code by Yves Orton
+        with help from Yitzchak Scott-Thoenes. This code was originally
+        developed to support restricted hashes in Data::Dump::Streamer
+        (shameless plug :-)
+
+
+
+
diff --git a/ext/Hash/Util/Makefile.PL b/ext/Hash/Util/Makefile.PL
new file mode 100644 (file)
index 0000000..a328bfe
--- /dev/null
@@ -0,0 +1,50 @@
+use ExtUtils::MakeMaker;
+
+# this file was templated from ext/List/Util/Makefile.PL
+# thanks to Graham Barr who wrote that module.
+
+WriteMakefile(
+    VERSION_FROM    => "lib/Hash/Util.pm",
+    MAN3PODS        => {},  # Pods will be built by installman.
+    NAME            => "Hash::Util",
+    DEFINE          => "-DPERL_EXT",
+);
+
+package MY;
+
+# We go through the HashUtil.c trickery to foil platforms
+# that have the feature combination of
+# (1) static builds
+# (2) allowing only one object by the same name in the static library
+# (3) the object name matching being case-blind
+# This means that we can't have the top-level util.o
+# and the extension-level Util.o in the same build.
+# One such platform is the POSIX-BC BS2000 EBCDIC mainframe platform.
+
+BEGIN {
+    use Config;
+    unless (defined $Config{usedl}) {
+       eval <<'__EOMM__';
+sub xs_c {
+    my($self) = shift;
+    return '' unless $self->needs_linking();
+'
+HashUtil.c:    Util.xs
+       $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) Util.xs > HashUtil.xsc && $(MV) HashUtil.xsc HashUtil.c
+';
+}
+
+sub xs_o {
+    my($self) = shift;
+    return '' unless $self->needs_linking();
+'
+
+Util$(OBJ_EXT):        HashUtil.c
+       $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) HashUtil.c
+       $(MV) HashUtil$(OBJ_EXT) Util$(OBJ_EXT)
+';
+}
+
+__EOMM__
+    }
+}
diff --git a/ext/Hash/Util/Util.xs b/ext/Hash/Util/Util.xs
new file mode 100644 (file)
index 0000000..4d7c964
--- /dev/null
@@ -0,0 +1,113 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+
+MODULE = Hash::Util            PACKAGE = Hash::Util
+
+
+SV*
+all_keys(hash,keys,placeholder)
+       SV* hash
+       SV* keys
+       SV* 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) {
+           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);
+            }
+        }
+        RETVAL=hash;
+
+
+void
+hidden_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 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) {
+           key=hv_iterkeysv(he);
+            if (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 );
+        }
+
+SV*
+hv_store(hvref, key, val)
+       SV* hvref
+       SV* key
+       SV* val
+    PROTOTYPE: \%$$
+    PREINIT:
+       HV* hv;
+    CODE:
+    {
+       if (!SvROK(hvref) || SvTYPE(SvRV(hvref)) != SVt_PVHV)
+          croak("First argument to alias_hv() must be a hash reference");
+       hv = (HV*)SvRV(hvref);
+        SvREFCNT_inc(val);
+       if (!hv_store_ent(hv, key, val, 0)) {
+           SvREFCNT_dec(val);
+           XSRETURN_NO;
+       } else {
+           XSRETURN_YES;
+       }
+
+    }
+    OUTPUT:
+        RETVAL
\ No newline at end of file
diff --git a/ext/Hash/Util/lib/Hash/Util.pm b/ext/Hash/Util/lib/Hash/Util.pm
new file mode 100644 (file)
index 0000000..c62a8bf
--- /dev/null
@@ -0,0 +1,499 @@
+package Hash::Util;
+
+require 5.007003;
+use strict;
+use Carp;
+use warnings;
+use warnings::register;
+use Scalar::Util qw(reftype);
+
+require Exporter;
+our @ISA        = qw(Exporter);
+our @EXPORT_OK  = qw(
+                     all_keys
+                     lock_keys unlock_keys
+                     lock_value unlock_value
+                     lock_hash unlock_hash
+                     lock_keys_plus hash_locked
+                     hidden_keys legal_keys
+
+                     lock_ref_keys unlock_ref_keys
+                     lock_ref_value unlock_ref_value
+                     lock_hashref unlock_hashref
+                     lock_ref_keys_plus hashref_locked
+                     hidden_ref_keys legal_ref_keys
+
+                     hash_seed hv_store
+
+                    );
+our $VERSION    = 0.06;
+require DynaLoader;
+local @ISA = qw(DynaLoader);
+bootstrap Hash::Util $VERSION;
+
+
+=head1 NAME
+
+Hash::Util - A selection of general-utility hash subroutines
+
+=head1 SYNOPSIS
+
+  use Hash::Util qw(
+                     hash_seed all_keys
+                     lock_keys unlock_keys
+                     lock_value unlock_value
+                     lock_hash unlock_hash
+                     lock_keys_plus hash_locked
+                     hidden_keys legal_keys
+                   );
+
+  %hash = (foo => 42, bar => 23);
+  # Ways to restrict a hash
+  lock_keys(%hash);
+  lock_keys(%hash, @keyset);
+  lock_keys_plus(%hash, @additional_keys);
+
+  #Ways to inspect the properties of a restricted hash
+  my @legal=legal_keys(%hash);
+  my @hidden=hidden_keys(%hash);
+  my $ref=all_keys(%hash,@keys,@hidden);
+  my $is_locked=hash_locked(%hash);
+
+  #Remove restrictions on the hash
+  unlock_keys(%hash);
+
+  #Lock individual values in a hash
+  lock_value  (%hash, 'foo');
+  unlock_value(%hash, 'foo');
+
+  #Ways to change the restrictions on both keys and values
+  lock_hash  (%hash);
+  unlock_hash(%hash);
+
+  my $hashes_are_randomised = hash_seed() != 0;
+
+=head1 DESCRIPTION
+
+C<Hash::Util> contains special functions for manipulating hashes that
+don't really warrant a keyword.
+
+By default C<Hash::Util> does not export anything.
+
+=head2 Restricted hashes
+
+5.8.0 introduces the ability to restrict a hash to a certain set of
+keys.  No keys outside of this set can be added.  It also introduces
+the ability to lock an individual key so it cannot be deleted and the
+ability to ensure that an individual value cannot be changed.
+
+This is intended to largely replace the deprecated pseudo-hashes.
+
+=over 4
+
+=item B<lock_keys>
+
+=item B<unlock_keys>
+
+  lock_keys(%hash);
+  lock_keys(%hash, @keys);
+
+Restricts the given %hash's set of keys to @keys.  If @keys is not
+given it restricts it to its current keyset.  No more keys can be
+added. delete() and exists() will still work, but will not alter
+the set of allowed keys. B<Note>: the current implementation prevents
+the hash from being bless()ed while it is in a locked state. Any attempt
+to do so will raise an exception. Of course you can still bless()
+the hash before you call lock_keys() so this shouldn't be a problem.
+
+  unlock_keys(%hash);
+
+Removes the restriction on the %hash's keyset.
+
+B<Note> that if any of the values of the hash have been locked they will not be unlocked
+after this sub executes.
+
+Both routines return a reference to the hash operated on.
+
+=cut
+
+sub lock_ref_keys {
+    my($hash, @keys) = @_;
+
+    Internals::hv_clear_placeholders %$hash;
+    if( @keys ) {
+        my %keys = map { ($_ => 1) } @keys;
+        my %original_keys = map { ($_ => 1) } keys %$hash;
+        foreach my $k (keys %original_keys) {
+            croak "Hash has key '$k' which is not in the new key set"
+              unless $keys{$k};
+        }
+
+        foreach my $k (@keys) {
+            $hash->{$k} = undef unless exists $hash->{$k};
+        }
+        Internals::SvREADONLY %$hash, 1;
+
+        foreach my $k (@keys) {
+            delete $hash->{$k} unless $original_keys{$k};
+        }
+    }
+    else {
+        Internals::SvREADONLY %$hash, 1;
+    }
+
+    return $hash;
+}
+
+sub unlock_ref_keys {
+    my $hash = shift;
+
+    Internals::SvREADONLY %$hash, 0;
+    return $hash;
+}
+
+sub   lock_keys (\%;@) {   lock_ref_keys(@_) }
+sub unlock_keys (\%)   { unlock_ref_keys(@_) }
+
+=item B<lock_keys_plus>
+
+  lock_keys_plus(%hash,@additional_keys)
+
+Similar to C<lock_keys()>, with the difference being that the optional key list
+specifies keys that may or may not be already in the hash. Essentially this is
+an easier way to say
+
+  lock_keys(%hash,@additional_keys,keys %hash);
+
+Returns a reference to %hash
+
+=cut
+
+
+sub lock_ref_keys_plus {
+    my ($hash,@keys)=@_;
+    my @delete;
+    Internals::hv_clear_placeholders(%$hash);
+    foreach my $key (@keys) {
+        unless (exists($hash->{$key})) {
+            $hash->{$key}=undef;
+            push @delete,$key;
+        }
+    }
+    Internals::SvREADONLY(%$hash,1);
+    delete @{$hash}{@delete};
+    return $hash
+}
+
+sub lock_keys_plus(\%;@) { lock_ref_keys_plus(@_) }
+
+
+=item B<lock_value>
+
+=item B<unlock_value>
+
+  lock_value  (%hash, $key);
+  unlock_value(%hash, $key);
+
+Locks and unlocks the value for an individual key of a hash.  The value of a
+locked key cannot be changed.
+
+Unless %hash has already been locked the key/value could be deleted
+regardless of this setting.
+
+Returns a reference to the %hash.
+
+=cut
+
+sub lock_ref_value {
+    my($hash, $key) = @_;
+    # I'm doubtful about this warning, as it seems not to be true.
+    # Marking a value in the hash as RO is useful, regardless
+    # of the status of the hash itself.
+    carp "Cannot usefully lock values in an unlocked hash"
+      if !Internals::SvREADONLY(%$hash) && warnings::enabled;
+    Internals::SvREADONLY $hash->{$key}, 1;
+    return $hash
+}
+
+sub unlock_ref_value {
+    my($hash, $key) = @_;
+    Internals::SvREADONLY $hash->{$key}, 0;
+    return $hash
+}
+
+sub   lock_value (\%$) {   lock_ref_value(@_) }
+sub unlock_value (\%$) { unlock_ref_value(@_) }
+
+
+=item B<lock_hash>
+
+=item B<unlock_hash>
+
+    lock_hash(%hash);
+
+lock_hash() locks an entire hash, making all keys and values readonly.
+No value can be changed, no keys can be added or deleted.
+
+    unlock_hash(%hash);
+
+unlock_hash() does the opposite of lock_hash().  All keys and values
+are made writable.  All values can be changed and keys can be added
+and deleted.
+
+Returns a reference to the %hash.
+
+=cut
+
+sub lock_hashref {
+    my $hash = shift;
+
+    lock_ref_keys($hash);
+
+    foreach my $value (values %$hash) {
+        Internals::SvREADONLY($value,1);
+    }
+
+    return $hash;
+}
+
+sub unlock_hashref {
+    my $hash = shift;
+
+    foreach my $value (values %$hash) {
+        Internals::SvREADONLY($value, 0);
+    }
+
+    unlock_ref_keys($hash);
+
+    return $hash;
+}
+
+sub   lock_hash (\%) {   lock_hashref(@_) }
+sub unlock_hash (\%) { unlock_hashref(@_) }
+
+=item B<lock_hash_recurse>
+
+=item B<unlock_hash_recurse>
+
+    lock_hash_recurse(%hash);
+
+lock_hash() locks an entire hash and any hashes it references recursively,
+making all keys and values readonly. No value can be changed, no keys can
+be added or deleted.
+
+B<Only> recurses into hashes that are referenced by another hash. Thus a
+Hash of Hashes (HoH) will all be restricted, but a Hash of Arrays of Hashes
+(HoAoH) will only have the top hash restricted.
+
+    unlock_hash_recurse(%hash);
+
+unlock_hash_recurse() does the opposite of lock_hash_recurse().  All keys and
+values are made writable.  All values can be changed and keys can be added
+and deleted. Identical recursion restrictions apply as to lock_hash_recurse().
+
+Returns a reference to the %hash.
+
+=cut
+
+sub lock_hashref_recurse {
+    my $hash = shift;
+
+    lock_ref_keys($hash);
+    foreach my $value (values %$hash) {
+        if (reftype($value) eq 'HASH') {
+            lock_hashref_recurse($value);
+        }
+        Internals::SvREADONLY($value,1);
+    }
+    return $hash
+}
+
+sub unlock_hashref_recurse {
+    my $hash = shift;
+
+    foreach my $value (values %$hash) {
+        if (reftype($value) eq 'HASH') {
+            unlock_hashref_recurse($value);
+        }
+        Internals::SvREADONLY($value,1);
+    }
+    unlock_ref_keys($hash);
+    return $hash;
+}
+
+sub   lock_hash_recurse (\%) {   lock_hashref_recurse(@_) }
+sub unlock_hash_recurse (\%) { unlock_hashref_recurse(@_) }
+
+
+=item B<hash_unlocked>
+
+  hash_unlocked(%hash) and print "Hash is unlocked!\n";
+
+Returns true if the hash and its keys are unlocked.
+
+=cut
+
+sub hashref_unlocked {
+    my $hash=shift;
+    return Internals::SvREADONLY($hash)
+}
+
+sub hash_unlocked(\%) { hashref_unlocked(@_) }
+
+=for demerphqs_editor
+sub legal_ref_keys{}
+sub hidden_ref_keys{}
+sub all_keys{}
+
+=cut
+
+sub legal_keys(\%) { legal_ref_keys(@_)  }
+sub hidden_keys(\%){ hidden_ref_keys(@_) }
+
+=item b<legal_keys>
+
+  my @keys=legal_keys(%hash);
+
+Returns a list of the keys that are legal in a restricted hash.
+In the case of an unrestricted hash this is identical to calling
+keys(%hash).
+
+=item B<hidden_keys>
+
+  my @keys=hidden_keys(%hash);
+
+Returns a list of the keys that are legal in a restricted hash but
+do not have a value associated to them. Thus if 'foo' is a
+"hidden" key of the %hash it will return false for both C<defined>
+and C<exists> tests.
+
+In the case of an unrestricted hash this will return an empty list.
+
+B<NOTE> this is an experimental feature that is heavily dependent
+on the current implementation of restricted hashes. Should the
+implementation change this routine may become meaningless in which
+case it will return an empty list.
+
+=item B<all_keys>
+
+  all_keys(%hash,@keys,@hidden);
+
+Populates the arrays @keys with the all the keys that would pass
+an C<exists> tests, and populates @hidden with the remaining legal
+keys that have not been utilized.
+
+Returns a reference to the hash.
+
+In the case of an unrestricted hash this will be equivelent to
+
+  $ref=do{
+            @keys  =keys %hash;
+            @hidden=();
+            \%hash
+         };
+
+B<NOTE> this is an experimental feature that is heavily dependent
+on the current implementation of restricted hashes. Should the
+implementation change this routine may become meaningless in which
+case it will behave identically to how it would behave on an
+unrestrcited hash.
+
+=item B<hash_seed>
+
+    my $hash_seed = hash_seed();
+
+hash_seed() returns the seed number used to randomise hash ordering.
+Zero means the "traditional" random hash ordering, non-zero means the
+new even more random hash ordering introduced in Perl 5.8.1.
+
+B<Note that the hash seed is sensitive information>: by knowing it one
+can craft a denial-of-service attack against Perl code, even remotely,
+see L<perlsec/"Algorithmic Complexity Attacks"> for more information.
+B<Do not disclose the hash seed> to people who don't need to know it.
+See also L<perlrun/PERL_HASH_SEED_DEBUG>.
+
+=cut
+
+sub hash_seed () {
+    Internals::rehash_seed();
+}
+
+=item B<hv_store>
+
+  my $sv=0;
+  hv_store(%hash,$key,$sv) or die "Failed to alias!";
+  $hash{$key}=1;
+  print $sv; # prints 1
+
+Stores an alias to a variable in a hash instead of copying the value.
+
+=back
+
+=head2 Operating on references to hashes.
+
+Most subroutines documented in this module have equivelent versions
+that operate on references to hashes instead of native hashes.
+The following is a list of these subs. They are identical except
+in name and in that instead of taking a %hash they take a $hashref,
+and additionally are not prototyped.
+
+=over 4
+
+=item lock_ref_keys
+
+=item unlock_ref_keys
+
+=item lock_ref_keys_plus
+
+=item lock_ref_value
+
+=item unlock_ref_value
+
+=item lock_hashref
+
+=item unlock_hashref
+
+=item lock_hashref_recurse
+
+=item unlock_hashref_recurse
+
+=item hash_ref_unlocked
+
+=item legal_ref_keys
+
+=item hidden_ref_keys
+
+=back
+
+=head1 CAVEATS
+
+Note that the trapping of the restricted operations is not atomic:
+for example
+
+    eval { %hash = (illegal_key => 1) }
+
+leaves the C<%hash> empty rather than with its original contents.
+
+=head1 BUGS
+
+The interface exposed by this module is very close to the current
+imlementation of restricted hashes. Over time it is expected that
+this behavior will be extended and the interface abstracted further.
+
+=head1 AUTHOR
+
+Michael G Schwern <schwern@pobox.com> on top of code by Nick
+Ing-Simmons and Jeffrey Friedl.
+
+hv_store() is from Array::RefElem, Copyright 2000 Gisle Aas.
+
+Additional code by Yves Orton.
+
+=head1 SEE ALSO
+
+L<Scalar::Util>, L<List::Util>, L<Hash::Util>,
+and L<perlsec/"Algorithmic Complexity Attacks">.
+
+=cut
+
+1;
similarity index 62%
rename from lib/Hash/Util.t
rename to ext/Hash/Util/t/Util.t
index adce3d1..df7e2df 100644 (file)
@@ -1,21 +1,47 @@
 #!/usr/bin/perl -Tw
 
 BEGIN {
-    if( $ENV{PERL_CORE} ) {
-        @INC = '../lib';
-        chdir 't';
+    unless (-d 'blib') {
+       chdir 't' if -d 't';
+       @INC = '../lib';
+       require Config; import Config;
+       keys %Config; # Silence warning
+       if ($Config{extensions} !~ /\bList\/Util\b/) {
+           print "1..0 # Skip: List::Util was not built\n";
+           exit 0;
+       }
     }
 }
-use Test::More tests => 179;
-use strict;
 
+#BEGIN {
+#    if( $ENV{PERL_CORE} ) {
+#        @INC = '../lib';
+#        chdir 't';
+#    }
+#}
+
+
+use strict;
+use Test::More;
 my @Exported_Funcs;
-BEGIN { 
-    @Exported_Funcs = qw(lock_keys   unlock_keys
-                         lock_value  unlock_value
-                         lock_hash   unlock_hash
-                         hash_seed
-                        );
+BEGIN {
+    @Exported_Funcs = qw(
+                     hash_seed all_keys
+                     lock_keys unlock_keys
+                     lock_value unlock_value
+                     lock_hash unlock_hash
+                     lock_keys_plus hash_locked
+                     hidden_keys legal_keys
+
+                     lock_ref_keys unlock_ref_keys
+                     lock_ref_value unlock_ref_value
+                     lock_hashref unlock_hashref
+                     lock_ref_keys_plus hashref_locked
+                     hidden_ref_keys legal_ref_keys
+                     hv_store
+
+                    );
+    plan tests => 201 + @Exported_Funcs;
     use_ok 'Hash::Util', @Exported_Funcs;
 }
 foreach my $func (@Exported_Funcs) {
@@ -28,19 +54,21 @@ eval { $hash{baz} = 99; };
 like( $@, qr/^Attempt to access disallowed key 'baz' in a restricted hash/,
                                                        'lock_keys()');
 is( $hash{bar}, 23 );
-ok( !exists $hash{baz} );
+ok( !exists $hash{baz},'!exists $hash{baz}' );
 
 delete $hash{bar};
-ok( !exists $hash{bar} );
+ok( !exists $hash{bar},'!exists $hash{bar}' );
 $hash{bar} = 69;
-is( $hash{bar}, 69 );
+is( $hash{bar}, 69 ,'$hash{bar} == 69');
 
 eval { () = $hash{i_dont_exist} };
-like( $@, qr/^Attempt to access disallowed key 'i_dont_exist' in a restricted hash/ );
+like( $@, qr/^Attempt to access disallowed key 'i_dont_exist' in a restricted hash/,
+      'Disallowed 1' );
 
 lock_value(%hash, 'locked');
 eval { print "# oops" if $hash{four} };
-like( $@, qr/^Attempt to access disallowed key 'four' in a restricted hash/ );
+like( $@, qr/^Attempt to access disallowed key 'four' in a restricted hash/,
+      'Disallowed 2' );
 
 eval { $hash{"\x{2323}"} = 3 };
 like( $@, qr/^Attempt to access disallowed key '(.*)' in a restricted hash/,
@@ -58,7 +86,7 @@ eval { delete $hash{I_dont_exist} };
 like( $@, qr/^Attempt to delete disallowed key 'I_dont_exist' from a restricted hash/,
                              'trying to delete a key that doesnt exist' );
 
-ok( !exists $hash{I_dont_exist} );
+ok( !exists $hash{I_dont_exist},'!exists $hash{I_dont_exist}' );
 
 unlock_keys(%hash);
 $hash{I_dont_exist} = 42;
@@ -80,11 +108,11 @@ is( $hash{locked}, 42,  'unlock_value' );
 
     lock_keys(%hash);
     eval { %hash = ( wubble => 42 ) };  # we know this will bomb
-    like( $@, qr/^Attempt to access disallowed key 'wubble'/ );
+    like( $@, qr/^Attempt to access disallowed key 'wubble'/,'Disallowed 3' );
     unlock_keys(%hash);
 }
 
-{ 
+{
     my %hash = (KEY => 'val', RO => 'val');
     lock_keys(%hash);
     lock_value(%hash, 'RO');
@@ -110,7 +138,7 @@ is( $hash{locked}, 42,  'unlock_value' );
     is( keys %hash, 1 );
     eval { $hash{wibble} = 42 };
     like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/,
-                        '  locked');
+                        'write threw error (locked)');
 
     unlock_keys(%hash);
     eval { $hash{wibble} = 23; };
@@ -122,13 +150,14 @@ is( $hash{locked}, 42,  'unlock_value' );
     my %hash = (foo => 42, bar => undef, baz => 0);
     lock_keys(%hash, qw(foo bar baz up down));
     is( keys %hash, 3,   'lock_keys() w/keyset didnt add new keys' );
-    is_deeply( \%hash, { foo => 42, bar => undef, baz => 0 } );
+    is_deeply( \%hash, { foo => 42, bar => undef, baz => 0 },'is_deeply' );
 
     eval { $hash{up} = 42; };
-    is( $@, '' );
+    is( $@, '','No error 1' );
 
     eval { $hash{wibble} = 23 };
-    like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/, '  locked' );
+    like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted hash/,
+          'locked "wibble"' );
 }
 
 
@@ -136,7 +165,8 @@ is( $hash{locked}, 42,  'unlock_value' );
     my %hash = (foo => 42, bar => undef);
     eval { lock_keys(%hash, qw(foo baz)); };
     is( $@, sprintf("Hash has key 'bar' which is not in the new key ".
-                    "set at %s line %d\n", __FILE__, __LINE__ - 2) );
+                    "set at %s line %d\n", __FILE__, __LINE__ - 2),
+                    'carp test' );
 }
 
 
@@ -144,15 +174,15 @@ is( $hash{locked}, 42,  'unlock_value' );
     my %hash = (foo => 42, bar => 23);
     lock_hash( %hash );
 
-    ok( Internals::SvREADONLY(%hash) );
-    ok( Internals::SvREADONLY($hash{foo}) );
-    ok( Internals::SvREADONLY($hash{bar}) );
+    ok( Internals::SvREADONLY(%hash),'Was locked %hash' );
+    ok( Internals::SvREADONLY($hash{foo}),'Was locked $hash{foo}' );
+    ok( Internals::SvREADONLY($hash{bar}),'Was locked $hash{bar}' );
 
     unlock_hash ( %hash );
 
-    ok( !Internals::SvREADONLY(%hash) );
-    ok( !Internals::SvREADONLY($hash{foo}) );
-    ok( !Internals::SvREADONLY($hash{bar}) );
+    ok( !Internals::SvREADONLY(%hash),'Was unlocked %hash' );
+    ok( !Internals::SvREADONLY($hash{foo}),'Was unlocked $hash{foo}' );
+    ok( !Internals::SvREADONLY($hash{bar}),'Was unlocked $hash{bar}' );
 }
 
 
@@ -323,14 +353,13 @@ ok($hash_seed >= 0, "hash_seed $hash_seed");
        is ($counter, 0, "0 objects after clear $state");
     }
 }
-
 {
     my %hash = map {$_,$_} qw(fwiffffff foosht teeoo);
     lock_keys(%hash);
     delete $hash{fwiffffff};
-    is (scalar keys %hash, 2);
+    is (scalar keys %hash, 2,"Count of keys after delete on locked hash");
     unlock_keys(%hash);
-    is (scalar keys %hash, 2);
+    is (scalar keys %hash, 2,"Count of keys after unlock");
 
     my ($first, $value) = each %hash;
     is ($hash{$first}, $value, "Key has the expected value before the lock");
@@ -342,3 +371,92 @@ ok($hash_seed >= 0, "hash_seed $hash_seed");
     is ($hash{$first}, $value, "Still correct after iterator advances");
     is ($hash{$second}, $v2, "Other key has the expected value");
 }
+{
+    my $x='foo';
+    my %test;
+    hv_store(%test,'x',$x);
+    is($test{x},'foo','hv_store() stored');
+    $test{x}='bar';
+    is($x,'bar','hv_store() aliased');
+    is($test{x},'bar','hv_store() aliased and stored');
+}
+
+{
+    my %hash=map { $_ => 1 } qw( a b c d e f);
+    delete $hash{c};
+    lock_keys(%hash);
+    ok(Internals::SvREADONLY(%hash),'lock_keys DDS/t 1');
+    delete @hash{qw(b e)};
+    my @hidden=sort(hidden_keys(%hash));
+    my @legal=sort(legal_keys(%hash));
+    my @keys=sort(keys(%hash));
+    #warn "@legal\n@keys\n";
+    is("@hidden","b e",'lock_keys @hidden DDS/t');
+    is("@legal","a b d e f",'lock_keys @legal DDS/t');
+    is("@keys","a d f",'lock_keys @keys DDS/t');
+}
+{
+    my %hash=(0..9);
+    lock_keys(%hash);
+    ok(Internals::SvREADONLY(%hash),'lock_keys DDS/t 2');
+    Hash::Util::unlock_keys(%hash);
+    ok(!Internals::SvREADONLY(%hash),'unlock_keys DDS/t 2');
+}
+{
+    my %hash=(0..9);
+    lock_keys(%hash,keys(%hash),'a'..'f');
+    ok(Internals::SvREADONLY(%hash),'lock_keys args DDS/t');
+    my @hidden=sort(hidden_keys(%hash));
+    my @legal=sort(legal_keys(%hash));
+    my @keys=sort(keys(%hash));
+    is("@hidden","a b c d e f",'lock_keys() @hidden DDS/t 3');
+    is("@legal","0 2 4 6 8 a b c d e f",'lock_keys() @legal DDS/t 3');
+    is("@keys","0 2 4 6 8",'lock_keys() @keys');
+}
+{
+    my %hash=map { $_ => 1 } qw( a b c d e f);
+    delete $hash{c};
+    lock_ref_keys(\%hash);
+    ok(Internals::SvREADONLY(%hash),'lock_ref_keys DDS/t');
+    delete @hash{qw(b e)};
+    my @hidden=sort(hidden_keys(%hash));
+    my @legal=sort(legal_keys(%hash));
+    my @keys=sort(keys(%hash));
+    #warn "@legal\n@keys\n";
+    is("@hidden","b e",'lock_ref_keys @hidden DDS/t 1');
+    is("@legal","a b d e f",'lock_ref_keys @legal DDS/t 1');
+    is("@keys","a d f",'lock_ref_keys @keys DDS/t 1');
+}
+{
+    my %hash=(0..9);
+    lock_ref_keys(\%hash,keys %hash,'a'..'f');
+    ok(Internals::SvREADONLY(%hash),'lock_ref_keys args DDS/t');
+    my @hidden=sort(hidden_keys(%hash));
+    my @legal=sort(legal_keys(%hash));
+    my @keys=sort(keys(%hash));
+    is("@hidden","a b c d e f",'lock_ref_keys() @hidden DDS/t 2');
+    is("@legal","0 2 4 6 8 a b c d e f",'lock_ref_keys() @legal DDS/t 2');
+    is("@keys","0 2 4 6 8",'lock_ref_keys() @keys DDS/t 2');
+}
+{
+    my %hash=(0..9);
+    lock_ref_keys_plus(\%hash,'a'..'f');
+    ok(Internals::SvREADONLY(%hash),'lock_ref_keys_plus args DDS/t');
+    my @hidden=sort(hidden_keys(%hash));
+    my @legal=sort(legal_keys(%hash));
+    my @keys=sort(keys(%hash));
+    is("@hidden","a b c d e f",'lock_ref_keys_plus() @hidden DDS/t');
+    is("@legal","0 2 4 6 8 a b c d e f",'lock_ref_keys_plus() @legal DDS/t');
+    is("@keys","0 2 4 6 8",'lock_ref_keys_plus() @keys DDS/t');
+}
+{
+    my %hash=(0..9);
+    lock_keys_plus(%hash,'a'..'f');
+    ok(Internals::SvREADONLY(%hash),'lock_keys_plus args DDS/t');
+    my @hidden=sort(hidden_keys(%hash));
+    my @legal=sort(legal_keys(%hash));
+    my @keys=sort(keys(%hash));
+    is("@hidden","a b c d e f",'lock_keys_plus() @hidden DDS/t 3');
+    is("@legal","0 2 4 6 8 a b c d e f",'lock_keys_plus() @legal DDS/t 3');
+    is("@keys","0 2 4 6 8",'lock_keys_plus() @keys DDS/t 3');
+}
diff --git a/lib/Hash/Util.pm b/lib/Hash/Util.pm
deleted file mode 100644 (file)
index 3d65ee0..0000000
+++ /dev/null
@@ -1,225 +0,0 @@
-package Hash::Util;
-
-require 5.007003;
-use strict;
-use Carp;
-
-require Exporter;
-our @ISA        = qw(Exporter);
-our @EXPORT_OK  = qw(lock_keys unlock_keys lock_value unlock_value
-                     lock_hash unlock_hash hash_seed
-                    );
-our $VERSION    = 0.05;
-
-=head1 NAME
-
-Hash::Util - A selection of general-utility hash subroutines
-
-=head1 SYNOPSIS
-
-  use Hash::Util qw(lock_keys   unlock_keys
-                    lock_value  unlock_value
-                    lock_hash   unlock_hash
-                    hash_seed);
-
-  %hash = (foo => 42, bar => 23);
-  lock_keys(%hash);
-  lock_keys(%hash, @keyset);
-  unlock_keys(%hash);
-
-  lock_value  (%hash, 'foo');
-  unlock_value(%hash, 'foo');
-
-  lock_hash  (%hash);
-  unlock_hash(%hash);
-
-  my $hashes_are_randomised = hash_seed() != 0;
-
-=head1 DESCRIPTION
-
-C<Hash::Util> contains special functions for manipulating hashes that
-don't really warrant a keyword.
-
-By default C<Hash::Util> does not export anything.
-
-=head2 Restricted hashes
-
-5.8.0 introduces the ability to restrict a hash to a certain set of
-keys.  No keys outside of this set can be added.  It also introduces
-the ability to lock an individual key so it cannot be deleted and the
-value cannot be changed.
-
-This is intended to largely replace the deprecated pseudo-hashes.
-
-=over 4
-
-=item lock_keys
-
-=item unlock_keys
-
-  lock_keys(%hash);
-  lock_keys(%hash, @keys);
-
-Restricts the given %hash's set of keys to @keys.  If @keys is not
-given it restricts it to its current keyset.  No more keys can be
-added. delete() and exists() will still work, but will not alter
-the set of allowed keys. B<Note>: the current implementation prevents
-the hash from being bless()ed while it is in a locked state. Any attempt
-to do so will raise an exception. Of course you can still bless()
-the hash before you call lock_keys() so this shouldn't be a problem.
-
-  unlock_keys(%hash);
-
-Removes the restriction on the %hash's keyset.
-
-=cut
-
-sub lock_keys (\%;@) {
-    my($hash, @keys) = @_;
-
-    Internals::hv_clear_placeholders %$hash;
-    if( @keys ) {
-        my %keys = map { ($_ => 1) } @keys;
-        my %original_keys = map { ($_ => 1) } keys %$hash;
-        foreach my $k (keys %original_keys) {
-            die sprintf "Hash has key '$k' which is not in the new key ".
-                        "set at %s line %d\n", (caller)[1,2]
-              unless $keys{$k};
-        }
-    
-        foreach my $k (@keys) {
-            $hash->{$k} = undef unless exists $hash->{$k};
-        }
-        Internals::SvREADONLY %$hash, 1;
-
-        foreach my $k (@keys) {
-            delete $hash->{$k} unless $original_keys{$k};
-        }
-    }
-    else {
-        Internals::SvREADONLY %$hash, 1;
-    }
-
-    return;
-}
-
-sub unlock_keys (\%) {
-    my($hash) = shift;
-
-    Internals::SvREADONLY %$hash, 0;
-    return;
-}
-
-=item lock_value
-
-=item unlock_value
-
-  lock_value  (%hash, $key);
-  unlock_value(%hash, $key);
-
-Locks and unlocks an individual key of a hash.  The value of a locked
-key cannot be changed.
-
-%hash must have already been locked for this to have useful effect.
-
-=cut
-
-sub lock_value (\%$) {
-    my($hash, $key) = @_;
-    carp "Cannot usefully lock values in an unlocked hash" 
-      unless Internals::SvREADONLY %$hash;
-    Internals::SvREADONLY $hash->{$key}, 1;
-}
-
-sub unlock_value (\%$) {
-    my($hash, $key) = @_;
-    Internals::SvREADONLY $hash->{$key}, 0;
-}
-
-
-=item B<lock_hash>
-
-=item B<unlock_hash>
-
-    lock_hash(%hash);
-
-lock_hash() locks an entire hash, making all keys and values readonly.
-No value can be changed, no keys can be added or deleted.
-
-    unlock_hash(%hash);
-
-unlock_hash() does the opposite of lock_hash().  All keys and values
-are made read/write.  All values can be changed and keys can be added
-and deleted.
-
-=cut
-
-sub lock_hash (\%) {
-    my($hash) = shift;
-
-    lock_keys(%$hash);
-
-    foreach my $key (keys %$hash) {
-        lock_value(%$hash, $key);
-    }
-
-    return 1;
-}
-
-sub unlock_hash (\%) {
-    my($hash) = shift;
-
-    foreach my $key (keys %$hash) {
-        unlock_value(%$hash, $key);
-    }
-
-    unlock_keys(%$hash);
-
-    return 1;
-}
-
-
-=item B<hash_seed>
-
-    my $hash_seed = hash_seed();
-
-hash_seed() returns the seed number used to randomise hash ordering.
-Zero means the "traditional" random hash ordering, non-zero means the
-new even more random hash ordering introduced in Perl 5.8.1.
-
-B<Note that the hash seed is sensitive information>: by knowing it one
-can craft a denial-of-service attack against Perl code, even remotely,
-see L<perlsec/"Algorithmic Complexity Attacks"> for more information.
-B<Do not disclose the hash seed> to people who don't need to know it.
-See also L<perlrun/PERL_HASH_SEED_DEBUG>.
-
-=cut
-
-sub hash_seed () {
-    Internals::rehash_seed();
-}
-
-=back
-
-=head1 CAVEATS
-
-Note that the trapping of the restricted operations is not atomic:
-for example
-
-    eval { %hash = (illegal_key => 1) }
-
-leaves the C<%hash> empty rather than with its original contents.
-
-=head1 AUTHOR
-
-Michael G Schwern <schwern@pobox.com> on top of code by Nick
-Ing-Simmons and Jeffrey Friedl.
-
-=head1 SEE ALSO
-
-L<Scalar::Util>, L<List::Util>, L<Hash::Util>,
-and L<perlsec/"Algorithmic Complexity Attacks">.
-
-=cut
-
-1;
index 4fad42a..876c016 100644 (file)
@@ -747,6 +747,7 @@ MIMEBASE64          = $(EXTDIR)\MIME\Base64\Base64
 TIMEHIRES              = $(EXTDIR)\Time\HiRes\HiRes
 CWD                    = $(EXTDIR)\Cwd\Cwd
 LISTUTIL               = $(EXTDIR)\List\Util\Util
+HASHUTIL               = $(EXTDIR)\Hash\Util\Util
 PERLIOVIA              = $(EXTDIR)\PerlIO\via\via
 XSAPITEST              = $(EXTDIR)\XS\APItest\APItest
 XSTYPEMAP              = $(EXTDIR)\XS\Typemap\Typemap
@@ -781,6 +782,7 @@ MIMEBASE64_DLL              = $(AUTODIR)\MIME\Base64\Base64.dll
 TIMEHIRES_DLL          = $(AUTODIR)\Time\HiRes\HiRes.dll
 CWD_DLL                        = $(AUTODIR)\Cwd\Cwd.dll
 LISTUTIL_DLL           = $(AUTODIR)\List\Util\Util.dll
+HASHUTIL_DLL           = $(AUTODIR)\HASH\Util\Util.dll
 PERLIOVIA_DLL          = $(AUTODIR)\PerlIO\via\via.dll
 XSAPITEST_DLL          = $(AUTODIR)\XS\APItest\APItest.dll
 XSTYPEMAP_DLL          = $(AUTODIR)\XS\Typemap\Typemap.dll
@@ -816,6 +818,7 @@ EXTENSION_C =               \
                $(TIMEHIRES).c  \
                $(CWD).c        \
                $(LISTUTIL).c   \
+               $(HASHUTIL).c   \
                $(PERLIOVIA).c  \
                $(XSAPITEST).c  \
                $(XSTYPEMAP).c  \
@@ -851,6 +854,7 @@ EXTENSION_DLL       =               \
                $(TIMEHIRES_DLL)  \
                $(CWD_DLL)      \
                $(LISTUTIL_DLL) \
+               $(HASHUTIL_DLL) \
                $(PERLIOVIA_DLL)        \
                $(XSAPITEST_DLL)        \
                $(XSTYPEMAP_DLL)        \
@@ -1184,6 +1188,8 @@ distclean: realclean
        -if exist $(LIBDIR)\MIME rmdir /s $(LIBDIR)\MIME
        -if exist $(LIBDIR)\List rmdir /s /q $(LIBDIR)\List
        -if exist $(LIBDIR)\List rmdir /s $(LIBDIR)\List
+       -if exist $(LIBDIR)\Hash rmdir /s /q $(LIBDIR)\Hash
+       -if exist $(LIBDIR)\Hash rmdir /s $(LIBDIR)\Hash
        -if exist $(LIBDIR)\Scalar rmdir /s /q $(LIBDIR)\Scalar
        -if exist $(LIBDIR)\Scalar rmdir /s $(LIBDIR)\Scalar
        -if exist $(LIBDIR)\Sys rmdir /s /q $(LIBDIR)\Sys
index 8e5ecce..8b9d7d5 100644 (file)
@@ -1350,6 +1350,8 @@ distclean: realclean
        -if exist $(LIBDIR)\MIME rmdir /s $(LIBDIR)\MIME
        -if exist $(LIBDIR)\List rmdir /s /q $(LIBDIR)\List
        -if exist $(LIBDIR)\List rmdir /s $(LIBDIR)\List
+       -if exist $(LIBDIR)\Hash rmdir /s /q $(LIBDIR)\Hash
+       -if exist $(LIBDIR)\Hash rmdir /s $(LIBDIR)\Hash
        -if exist $(LIBDIR)\Scalar rmdir /s /q $(LIBDIR)\Scalar
        -if exist $(LIBDIR)\Scalar rmdir /s $(LIBDIR)\Scalar
        -if exist $(LIBDIR)\Sys rmdir /s /q $(LIBDIR)\Sys