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