lib/Hash/Util.pm

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