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

   1 package Hash::Util;
   2
   3 require 5.007003;
   4 use strict;
   5 use Carp;
   6 use warnings;
   7 use warnings::register;
   8 use Scalar::Util qw(reftype);
   9
  10 require Exporter;
  11 our @ISA        = qw(Exporter);
  12 our @EXPORT_OK  = qw(
  13                      all_keys
  14                      lock_keys unlock_keys
  15                      lock_value unlock_value
  16                      lock_hash unlock_hash
  17                      lock_keys_plus hash_locked
  18                      hidden_keys legal_keys
  19
  20                      lock_ref_keys unlock_ref_keys
  21                      lock_ref_value unlock_ref_value
  22                      lock_hashref unlock_hashref
  23                      lock_ref_keys_plus hashref_locked
  24                      hidden_ref_keys legal_ref_keys
  25
  26                      hash_seed hv_store
  27
  28                     );
  29 our $VERSION    = 0.06;
  30 require DynaLoader;
  31 local @ISA = qw(DynaLoader);
  32 bootstrap Hash::Util $VERSION;
  33
  34
  35 =head1 NAME
  36
  37 Hash::Util - A selection of general-utility hash subroutines
  38
  39 =head1 SYNOPSIS
  40
  41   use Hash::Util qw(
  42                      hash_seed all_keys
  43                      lock_keys unlock_keys
  44                      lock_value unlock_value
  45                      lock_hash unlock_hash
  46                      lock_keys_plus hash_locked
  47                      hidden_keys legal_keys
  48                    );
  49
  50   %hash = (foo => 42, bar => 23);
  51   # Ways to restrict a hash
  52   lock_keys(%hash);
  53   lock_keys(%hash, @keyset);
  54   lock_keys_plus(%hash, @additional_keys);
  55
  56   #Ways to inspect the properties of a restricted hash
  57   my @legal=legal_keys(%hash);
  58   my @hidden=hidden_keys(%hash);
  59   my $ref=all_keys(%hash,@keys,@hidden);
  60   my $is_locked=hash_locked(%hash);
  61
  62   #Remove restrictions on the hash
  63   unlock_keys(%hash);
  64
  65   #Lock individual values in a hash
  66   lock_value  (%hash, 'foo');
  67   unlock_value(%hash, 'foo');
  68
  69   #Ways to change the restrictions on both keys and values
  70   lock_hash  (%hash);
  71   unlock_hash(%hash);
  72
  73   my $hashes_are_randomised = hash_seed() != 0;
  74
  75 =head1 DESCRIPTION
  76
  77 C<Hash::Util> contains special functions for manipulating hashes that
  78 don't really warrant a keyword.
  79
  80 By default C<Hash::Util> does not export anything.
  81
  82 =head2 Restricted hashes
  83
  84 5.8.0 introduces the ability to restrict a hash to a certain set of
  85 keys.  No keys outside of this set can be added.  It also introduces
  86 the ability to lock an individual key so it cannot be deleted and the
  87 ability to ensure that an individual value cannot be changed.
  88
  89 This is intended to largely replace the deprecated pseudo-hashes.
  90
  91 =over 4
  92
  93 =item B<lock_keys>
  94
  95 =item B<unlock_keys>
  96
  97   lock_keys(%hash);
  98   lock_keys(%hash, @keys);
  99
 100 Restricts the given %hash's set of keys to @keys.  If @keys is not
 101 given it restricts it to its current keyset.  No more keys can be
 102 added. delete() and exists() will still work, but will not alter
 103 the set of allowed keys. B<Note>: the current implementation prevents
 104 the hash from being bless()ed while it is in a locked state. Any attempt
 105 to do so will raise an exception. Of course you can still bless()
 106 the hash before you call lock_keys() so this shouldn't be a problem.
 107
 108   unlock_keys(%hash);
 109
 110 Removes the restriction on the %hash's keyset.
 111
 112 B<Note> that if any of the values of the hash have been locked they will not be unlocked
 113 after this sub executes.
 114
 115 Both routines return a reference to the hash operated on.
 116
 117 =cut
 118
 119 sub lock_ref_keys {
 120     my($hash, @keys) = @_;
 121
 122     Internals::hv_clear_placeholders %$hash;
 123     if( @keys ) {
 124         my %keys = map { ($_ => 1) } @keys;
 125         my %original_keys = map { ($_ => 1) } keys %$hash;
 126         foreach my $k (keys %original_keys) {
 127             croak "Hash has key '$k' which is not in the new key set"
 128               unless $keys{$k};
 129         }
 130
 131         foreach my $k (@keys) {
 132             $hash->{$k} = undef unless exists $hash->{$k};
 133         }
 134         Internals::SvREADONLY %$hash, 1;
 135
 136         foreach my $k (@keys) {
 137             delete $hash->{$k} unless $original_keys{$k};
 138         }
 139     }
 140     else {
 141         Internals::SvREADONLY %$hash, 1;
 142     }
 143
 144     return $hash;
 145 }
 146
 147 sub unlock_ref_keys {
 148     my $hash = shift;
 149
 150     Internals::SvREADONLY %$hash, 0;
 151     return $hash;
 152 }
 153
 154 sub   lock_keys (\%;@) {   lock_ref_keys(@_) }
 155 sub unlock_keys (\%)   { unlock_ref_keys(@_) }
 156
 157 =item B<lock_keys_plus>
 158
 159   lock_keys_plus(%hash,@additional_keys)
 160
 161 Similar to C<lock_keys()>, with the difference being that the optional key list
 162 specifies keys that may or may not be already in the hash. Essentially this is
 163 an easier way to say
 164
 165   lock_keys(%hash,@additional_keys,keys %hash);
 166
 167 Returns a reference to %hash
 168
 169 =cut
 170
 171
 172 sub lock_ref_keys_plus {
 173     my ($hash,@keys)=@_;
 174     my @delete;
 175     Internals::hv_clear_placeholders(%$hash);
 176     foreach my $key (@keys) {
 177         unless (exists($hash->{$key})) {
 178             $hash->{$key}=undef;
 179             push @delete,$key;
 180         }
 181     }
 182     Internals::SvREADONLY(%$hash,1);
 183     delete @{$hash}{@delete};
 184     return $hash
 185 }
 186
 187 sub lock_keys_plus(\%;@) { lock_ref_keys_plus(@_) }
 188
 189
 190 =item B<lock_value>
 191
 192 =item B<unlock_value>
 193
 194   lock_value  (%hash, $key);
 195   unlock_value(%hash, $key);
 196
 197 Locks and unlocks the value for an individual key of a hash.  The value of a
 198 locked key cannot be changed.
 199
 200 Unless %hash has already been locked the key/value could be deleted
 201 regardless of this setting.
 202
 203 Returns a reference to the %hash.
 204
 205 =cut
 206
 207 sub lock_ref_value {
 208     my($hash, $key) = @_;
 209     # I'm doubtful about this warning, as it seems not to be true.
 210     # Marking a value in the hash as RO is useful, regardless
 211     # of the status of the hash itself.
 212     carp "Cannot usefully lock values in an unlocked hash"
 213       if !Internals::SvREADONLY(%$hash) && warnings::enabled;
 214     Internals::SvREADONLY $hash->{$key}, 1;
 215     return $hash
 216 }
 217
 218 sub unlock_ref_value {
 219     my($hash, $key) = @_;
 220     Internals::SvREADONLY $hash->{$key}, 0;
 221     return $hash
 222 }
 223
 224 sub   lock_value (\%$) {   lock_ref_value(@_) }
 225 sub unlock_value (\%$) { unlock_ref_value(@_) }
 226
 227
 228 =item B<lock_hash>
 229
 230 =item B<unlock_hash>
 231
 232     lock_hash(%hash);
 233
 234 lock_hash() locks an entire hash, making all keys and values readonly.
 235 No value can be changed, no keys can be added or deleted.
 236
 237     unlock_hash(%hash);
 238
 239 unlock_hash() does the opposite of lock_hash().  All keys and values
 240 are made writable.  All values can be changed and keys can be added
 241 and deleted.
 242
 243 Returns a reference to the %hash.
 244
 245 =cut
 246
 247 sub lock_hashref {
 248     my $hash = shift;
 249
 250     lock_ref_keys($hash);
 251
 252     foreach my $value (values %$hash) {
 253         Internals::SvREADONLY($value,1);
 254     }
 255
 256     return $hash;
 257 }
 258
 259 sub unlock_hashref {
 260     my $hash = shift;
 261
 262     foreach my $value (values %$hash) {
 263         Internals::SvREADONLY($value, 0);
 264     }
 265
 266     unlock_ref_keys($hash);
 267
 268     return $hash;
 269 }
 270
 271 sub   lock_hash (\%) {   lock_hashref(@_) }
 272 sub unlock_hash (\%) { unlock_hashref(@_) }
 273
 274 =item B<lock_hash_recurse>
 275
 276 =item B<unlock_hash_recurse>
 277
 278     lock_hash_recurse(%hash);
 279
 280 lock_hash() locks an entire hash and any hashes it references recursively,
 281 making all keys and values readonly. No value can be changed, no keys can
 282 be added or deleted.
 283
 284 B<Only> recurses into hashes that are referenced by another hash. Thus a
 285 Hash of Hashes (HoH) will all be restricted, but a Hash of Arrays of Hashes
 286 (HoAoH) will only have the top hash restricted.
 287
 288     unlock_hash_recurse(%hash);
 289
 290 unlock_hash_recurse() does the opposite of lock_hash_recurse().  All keys and
 291 values are made writable.  All values can be changed and keys can be added
 292 and deleted. Identical recursion restrictions apply as to lock_hash_recurse().
 293
 294 Returns a reference to the %hash.
 295
 296 =cut
 297
 298 sub lock_hashref_recurse {
 299     my $hash = shift;
 300
 301     lock_ref_keys($hash);
 302     foreach my $value (values %$hash) {
 303         if (reftype($value) eq 'HASH') {
 304             lock_hashref_recurse($value);
 305         }
 306         Internals::SvREADONLY($value,1);
 307     }
 308     return $hash
 309 }
 310
 311 sub unlock_hashref_recurse {
 312     my $hash = shift;
 313
 314     foreach my $value (values %$hash) {
 315         if (reftype($value) eq 'HASH') {
 316             unlock_hashref_recurse($value);
 317         }
 318         Internals::SvREADONLY($value,1);
 319     }
 320     unlock_ref_keys($hash);
 321     return $hash;
 322 }
 323
 324 sub   lock_hash_recurse (\%) {   lock_hashref_recurse(@_) }
 325 sub unlock_hash_recurse (\%) { unlock_hashref_recurse(@_) }
 326
 327
 328 =item B<hash_unlocked>
 329
 330   hash_unlocked(%hash) and print "Hash is unlocked!\n";
 331
 332 Returns true if the hash and its keys are unlocked.
 333
 334 =cut
 335
 336 sub hashref_unlocked {
 337     my $hash=shift;
 338     return Internals::SvREADONLY($hash)
 339 }
 340
 341 sub hash_unlocked(\%) { hashref_unlocked(@_) }
 342
 343 =for demerphqs_editor
 344 sub legal_ref_keys{}
 345 sub hidden_ref_keys{}
 346 sub all_keys{}
 347
 348 =cut
 349
 350 sub legal_keys(\%) { legal_ref_keys(@_)  }
 351 sub hidden_keys(\%){ hidden_ref_keys(@_) }
 352
 353 =item b<legal_keys>
 354
 355   my @keys=legal_keys(%hash);
 356
 357 Returns a list of the keys that are legal in a restricted hash.
 358 In the case of an unrestricted hash this is identical to calling
 359 keys(%hash).
 360
 361 =item B<hidden_keys>
 362
 363   my @keys=hidden_keys(%hash);
 364
 365 Returns a list of the keys that are legal in a restricted hash but
 366 do not have a value associated to them. Thus if 'foo' is a
 367 "hidden" key of the %hash it will return false for both C<defined>
 368 and C<exists> tests.
 369
 370 In the case of an unrestricted hash this will return an empty list.
 371
 372 B<NOTE> this is an experimental feature that is heavily dependent
 373 on the current implementation of restricted hashes. Should the
 374 implementation change this routine may become meaningless in which
 375 case it will return an empty list.
 376
 377 =item B<all_keys>
 378
 379   all_keys(%hash,@keys,@hidden);
 380
 381 Populates the arrays @keys with the all the keys that would pass
 382 an C<exists> tests, and populates @hidden with the remaining legal
 383 keys that have not been utilized.
 384
 385 Returns a reference to the hash.
 386
 387 In the case of an unrestricted hash this will be equivelent to
 388
 389   $ref=do{
 390             @keys  =keys %hash;
 391             @hidden=();
 392             \%hash
 393          };
 394
 395 B<NOTE> this is an experimental feature that is heavily dependent
 396 on the current implementation of restricted hashes. Should the
 397 implementation change this routine may become meaningless in which
 398 case it will behave identically to how it would behave on an
 399 unrestrcited hash.
 400
 401 =item B<hash_seed>
 402
 403     my $hash_seed = hash_seed();
 404
 405 hash_seed() returns the seed number used to randomise hash ordering.
 406 Zero means the "traditional" random hash ordering, non-zero means the
 407 new even more random hash ordering introduced in Perl 5.8.1.
 408
 409 B<Note that the hash seed is sensitive information>: by knowing it one
 410 can craft a denial-of-service attack against Perl code, even remotely,
 411 see L<perlsec/"Algorithmic Complexity Attacks"> for more information.
 412 B<Do not disclose the hash seed> to people who don't need to know it.
 413 See also L<perlrun/PERL_HASH_SEED_DEBUG>.
 414
 415 =cut
 416
 417 sub hash_seed () {
 418     Internals::rehash_seed();
 419 }
 420
 421 =item B<hv_store>
 422
 423   my $sv=0;
 424   hv_store(%hash,$key,$sv) or die "Failed to alias!";
 425   $hash{$key}=1;
 426   print $sv; # prints 1
 427
 428 Stores an alias to a variable in a hash instead of copying the value.
 429
 430 =back
 431
 432 =head2 Operating on references to hashes.
 433
 434 Most subroutines documented in this module have equivelent versions
 435 that operate on references to hashes instead of native hashes.
 436 The following is a list of these subs. They are identical except
 437 in name and in that instead of taking a %hash they take a $hashref,
 438 and additionally are not prototyped.
 439
 440 =over 4
 441
 442 =item lock_ref_keys
 443
 444 =item unlock_ref_keys
 445
 446 =item lock_ref_keys_plus
 447
 448 =item lock_ref_value
 449
 450 =item unlock_ref_value
 451
 452 =item lock_hashref
 453
 454 =item unlock_hashref
 455
 456 =item lock_hashref_recurse
 457
 458 =item unlock_hashref_recurse
 459
 460 =item hash_ref_unlocked
 461
 462 =item legal_ref_keys
 463
 464 =item hidden_ref_keys
 465
 466 =back
 467
 468 =head1 CAVEATS
 469
 470 Note that the trapping of the restricted operations is not atomic:
 471 for example
 472
 473     eval { %hash = (illegal_key => 1) }
 474
 475 leaves the C<%hash> empty rather than with its original contents.
 476
 477 =head1 BUGS
 478
 479 The interface exposed by this module is very close to the current
 480 imlementation of restricted hashes. Over time it is expected that
 481 this behavior will be extended and the interface abstracted further.
 482
 483 =head1 AUTHOR
 484
 485 Michael G Schwern <schwern@pobox.com> on top of code by Nick
 486 Ing-Simmons and Jeffrey Friedl.
 487
 488 hv_store() is from Array::RefElem, Copyright 2000 Gisle Aas.
 489
 490 Additional code by Yves Orton.
 491
 492 =head1 SEE ALSO
 493
 494 L<Scalar::Util>, L<List::Util>, L<Hash::Util>,
 495 and L<perlsec/"Algorithmic Complexity Attacks">.
 496
 497 =cut
 498
 499 1;