ext/Data/Util/lib/Hash/Util.pm

   1 package Hash::Util;
   2
   3 require 5.007003;
   4 use strict;
   5 use Data::Util qw(sv_readonly_flag);
   6 use Carp;
   7
   8 require Exporter;
   9 our @ISA        = qw(Exporter);
  10 our @EXPORT_OK  = qw(lock_keys unlock_keys lock_value unlock_value
  11                      lock_hash unlock_hash
  12                     );
  13 our $VERSION    = 0.04;
  14
  15
  16 =head1 NAME
  17
  18 Hash::Util - A selection of general-utility hash subroutines
  19
  20 =head1 SYNOPSIS
  21
  22   use Hash::Util qw(lock_keys   unlock_keys
  23                     lock_value  unlock_value
  24                     lock_hash   unlock_hash
  25                    );
  26
  27   %hash = (foo => 42, bar => 23);
  28   lock_keys(%hash);
  29   lock_keys(%hash, @keyset);
  30   unlock_keys(%hash);
  31
  32   lock_value  (%hash, 'foo');
  33   unlock_value(%hash, 'foo');
  34
  35   lock_hash  (%hash);
  36   unlock_hash(%hash);
  37
  38
  39 =head1 DESCRIPTION
  40
  41 C<Hash::Util> contains special functions for manipulating hashes that
  42 don't really warrant a keyword.
  43
  44 By default C<Hash::Util> does not export anything.
  45
  46 =head2 Restricted hashes
  47
  48 5.8.0 introduces the ability to restrict a hash to a certain set of
  49 keys.  No keys outside of this set can be added.  It also introduces
  50 the ability to lock an individual key so it cannot be deleted and the
  51 value cannot be changed.
  52
  53 This is intended to largely replace the deprecated pseudo-hashes.
  54
  55 =over 4
  56
  57 =item lock_keys
  58
  59 =item unlock_keys
  60
  61   lock_keys(%hash);
  62   lock_keys(%hash, @keys);
  63
  64   unlock_keys(%hash;)
  65
  66 Restricts the given %hash's set of keys to @keys.  If @keys is not
  67 given it restricts it to its current keyset.  No more keys can be
  68 added.  delete() and exists() will still work, but it does not effect
  69 the set of allowed keys.
  70
  71 Removes the restriction on the %hash's keyset.
  72
  73 =cut
  74
  75 sub lock_keys (\%;@) {
  76     my($hash, @keys) = @_;
  77
  78     if( @keys ) {
  79         my %keys = map { ($_ => 1) } @keys;
  80         my %original_keys = map { ($_ => 1) } keys %$hash;
  81         foreach my $k (keys %original_keys) {
  82             die sprintf "Hash has key '$k' which is not in the new key ".
  83                         "set at %s line %d\n", (caller)[1,2]
  84               unless $keys{$k};
  85         }
  86
  87         foreach my $k (@keys) {
  88             $hash->{$k} = undef unless exists $hash->{$k};
  89         }
  90         sv_readonly_flag %$hash, 1;
  91
  92         foreach my $k (@keys) {
  93             delete $hash->{$k} unless $original_keys{$k};
  94         }
  95     }
  96     else {
  97         sv_readonly_flag %$hash, 1;
  98     }
  99
 100     return undef;
 101 }
 102
 103 sub unlock_keys (\%) {
 104     my($hash) = shift;
 105
 106     sv_readonly_flag %$hash, 0;
 107     return undef;
 108 }
 109
 110 =item lock_value
 111
 112 =item unlock_value
 113
 114   lock_key  (%hash, $key);
 115   unlock_key(%hash, $key);
 116
 117 Locks and unlocks an individual key of a hash.  The value of a locked
 118 key cannot be changed.
 119
 120 %hash must have already been locked for this to have useful effect.
 121
 122 =cut
 123
 124 sub lock_value (\%$) {
 125     my($hash, $key) = @_;
 126     carp "Cannot usefully lock values in an unlocked hash"
 127       unless sv_readonly_flag %$hash;
 128     sv_readonly_flag $hash->{$key}, 1;
 129 }
 130
 131 sub unlock_value (\%$) {
 132     my($hash, $key) = @_;
 133     sv_readonly_flag $hash->{$key}, 0;
 134 }
 135
 136
 137 =item B<lock_hash>
 138
 139 =item B<unlock_hash>
 140
 141     lock_hash(%hash);
 142     unlock_hash(%hash);
 143
 144 lock_hash() locks an entire hash, making all keys and values readonly.
 145 No value can be changed, no keys can be added or deleted.
 146
 147 unlock_hash() does the opposite.  All keys and values are made
 148 read/write.  All values can be changed and keys can be added and
 149 deleted.
 150
 151 =cut
 152
 153 sub lock_hash (\%) {
 154     my($hash) = shift;
 155
 156     lock_keys(%$hash);
 157
 158     foreach my $key (keys %$hash) {
 159         lock_value(%$hash, $key);
 160     }
 161
 162     return 1;
 163 }
 164
 165 sub unlock_hash (\%) {
 166     my($hash) = shift;
 167
 168     foreach my $key (keys %$hash) {
 169         unlock_value(%$hash, $key);
 170     }
 171
 172     unlock_keys(%$hash);
 173
 174     return 1;
 175 }
 176
 177
 178 =back
 179
 180 =head1 AUTHOR
 181
 182 Michael G Schwern <schwern@pobox.com> on top of code by Nick
 183 Ing-Simmons and Jeffrey Friedl.
 184
 185 =head1 SEE ALSO
 186
 187 L<Scalar::Util>, L<List::Util>, L<Hash::Util>
 188
 189 =cut
 190
 191 1;