From: Yves Orton Date: Mon, 13 Feb 2006 11:39:33 +0000 (+0100) Subject: [Patch] Enhance Hash::Util X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=96c33d98b34ca8475e06ac046725bba9fb34e6b6;p=p5sagit%2Fp5-mst-13.2.git [Patch] Enhance Hash::Util Message-ID: <9b18b3110602130239w311d05fcr776ae8333776ca2e@mail.gmail.com> p4raw-id: //depot/perl@27180 --- diff --git a/MANIFEST b/MANIFEST index 96808ee..a0ed64b 100644 --- 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 index 0000000..f6ba16b --- /dev/null +++ b/ext/Hash/Util/Changes @@ -0,0 +1,18 @@ +Revision history for Perl extension Hash::Util. + +0.05 + +Pre /ext version of the code. By Michael G Schwern +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 index 0000000..a328bfe --- /dev/null +++ b/ext/Hash/Util/Makefile.PL @@ -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 index 0000000..4d7c964 --- /dev/null +++ b/ext/Hash/Util/Util.xs @@ -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 index 0000000..c62a8bf --- /dev/null +++ b/ext/Hash/Util/lib/Hash/Util.pm @@ -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 contains special functions for manipulating hashes that +don't really warrant a keyword. + +By default C 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 + +=item B + + 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: 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 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(%hash,@additional_keys) + +Similar to C, 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 + +=item B + + 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 + +=item B + + 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 + +=item B + + 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 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) 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 + + 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 + + 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 +and C tests. + +In the case of an unrestricted hash this will return an empty list. + +B 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(%hash,@keys,@hidden); + +Populates the arrays @keys with the all the keys that would pass +an C 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 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 + + 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: by knowing it one +can craft a denial-of-service attack against Perl code, even remotely, +see L for more information. +B to people who don't need to know it. +See also L. + +=cut + +sub hash_seed () { + Internals::rehash_seed(); +} + +=item B + + 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 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, L, L, +and L. + +=cut + +1; diff --git a/lib/Hash/Util.t b/ext/Hash/Util/t/Util.t similarity index 62% rename from lib/Hash/Util.t rename to ext/Hash/Util/t/Util.t index adce3d1..df7e2df 100644 --- a/lib/Hash/Util.t +++ b/ext/Hash/Util/t/Util.t @@ -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 index 3d65ee0..0000000 --- a/lib/Hash/Util.pm +++ /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 contains special functions for manipulating hashes that -don't really warrant a keyword. - -By default C 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: 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 - -=item B - - 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 - - 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: by knowing it one -can craft a denial-of-service attack against Perl code, even remotely, -see L for more information. -B to people who don't need to know it. -See also L. - -=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 on top of code by Nick -Ing-Simmons and Jeffrey Friedl. - -=head1 SEE ALSO - -L, L, L, -and L. - -=cut - -1; diff --git a/win32/Makefile b/win32/Makefile index 4fad42a..876c016 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -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 diff --git a/win32/makefile.mk b/win32/makefile.mk index 8e5ecce..8b9d7d5 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -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