Change 30139 by [EMAIL PROTECTED] on 2007/02/05 21:19:54
Integrate:
[ 27180]
Subject: [Patch] Enhance Hash::Util
From: demerphq <[EMAIL PROTECTED]>
Date: Mon, 13 Feb 2006 11:39:33 +0100
Message-ID: <[EMAIL PROTECTED]>
[ 27181]
Hash::Util tests should check if Hash::Util has been built, not
List::Util (spotted by Rafael).
[ 27257]
Add tests for the previously untested Hash::Util::all_keys().
Affected files ...
... //depot/maint-5.8/perl/MANIFEST#306 integrate
... //depot/maint-5.8/perl/ext/Hash/Util/Changes#1 branch
... //depot/maint-5.8/perl/ext/Hash/Util/Makefile.PL#1 branch
... //depot/maint-5.8/perl/ext/Hash/Util/Util.xs#1 branch
... //depot/maint-5.8/perl/ext/Hash/Util/lib/Hash/Util.pm#1 branch
... //depot/maint-5.8/perl/ext/Hash/Util/t/Util.t#1 branch
... //depot/maint-5.8/perl/lib/Hash/Util.pm#11 delete
... //depot/maint-5.8/perl/lib/Hash/Util.t#13 delete
... //depot/maint-5.8/perl/win32/Makefile#58 integrate
... //depot/maint-5.8/perl/win32/makefile.mk#66 integrate
Differences ...
==== //depot/maint-5.8/perl/MANIFEST#306 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST#305~30133~ 2007-02-05 10:05:43.000000000 -0800
+++ perl/MANIFEST 2007-02-05 13:19:54.000000000 -0800
@@ -607,6 +607,11 @@
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
@@ -1527,8 +1532,6 @@
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
==== //depot/maint-5.8/perl/ext/Hash/Util/Changes#1 (text) ====
Index: perl/ext/Hash/Util/Changes
--- /dev/null 2007-01-16 11:55:45.526841103 -0800
+++ perl/ext/Hash/Util/Changes 2007-02-05 13:19:54.000000000 -0800
@@ -0,0 +1,18 @@
+Revision history for Perl extension Hash::Util.
+
+0.05
+
+Pre /ext version of the code. By Michael G Schwern <[EMAIL PROTECTED]>
+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 :-)
+
+
+
+
==== //depot/maint-5.8/perl/ext/Hash/Util/Makefile.PL#1 (text) ====
Index: perl/ext/Hash/Util/Makefile.PL
--- /dev/null 2007-01-16 11:55:45.526841103 -0800
+++ perl/ext/Hash/Util/Makefile.PL 2007-02-05 13:19:54.000000000 -0800
@@ -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__
+ }
+}
==== //depot/maint-5.8/perl/ext/Hash/Util/Util.xs#1 (text) ====
Index: perl/ext/Hash/Util/Util.xs
--- /dev/null 2007-01-16 11:55:45.526841103 -0800
+++ perl/ext/Hash/Util/Util.xs 2007-02-05 13:19:54.000000000 -0800
@@ -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: [EMAIL PROTECTED]@
+ 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
==== //depot/maint-5.8/perl/ext/Hash/Util/lib/Hash/Util.pm#1 (text) ====
Index: perl/ext/Hash/Util/lib/Hash/Util.pm
--- /dev/null 2007-01-16 11:55:45.526841103 -0800
+++ perl/ext/Hash/Util/lib/Hash/Util.pm 2007-02-05 13:19:54.000000000 -0800
@@ -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<Hash::Util> contains special functions for manipulating hashes that
+don't really warrant a keyword.
+
+By default C<Hash::Util> 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<lock_keys>
+
+=item B<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<Note>: 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<Note> 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>
+
+ lock_keys_plus(%hash,@additional_keys)
+
+Similar to C<lock_keys()>, 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)[EMAIL PROTECTED];
+ 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 @[EMAIL PROTECTED];
+ return $hash
+}
+
+sub lock_keys_plus(\%;@) { lock_ref_keys_plus(@_) }
+
+
+=item B<lock_value>
+
+=item B<unlock_value>
+
+ 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<lock_hash>
+
+=item B<unlock_hash>
+
+ 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<lock_hash_recurse>
+
+=item B<unlock_hash_recurse>
+
+ 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<Only> 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_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<legal_keys>
+
+ 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<hidden_keys>
+
+ 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<defined>
+and C<exists> tests.
+
+In the case of an unrestricted hash this will return an empty list.
+
+B<NOTE> 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>
+
+ all_keys(%hash,@keys,@hidden);
+
+Populates the arrays @keys with the all the keys that would pass
+an C<exists> 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<NOTE> 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<hash_seed>
+
+ 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<Note that the hash seed is sensitive information>: by knowing it one
+can craft a denial-of-service attack against Perl code, even remotely,
+see L<perlsec/"Algorithmic Complexity Attacks"> for more information.
+B<Do not disclose the hash seed> to people who don't need to know it.
+See also L<perlrun/PERL_HASH_SEED_DEBUG>.
+
+=cut
+
+sub hash_seed () {
+ Internals::rehash_seed();
+}
+
+=item B<hv_store>
+
+ 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 <[EMAIL PROTECTED]> 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<Scalar::Util>, L<List::Util>, L<Hash::Util>,
+and L<perlsec/"Algorithmic Complexity Attacks">.
+
+=cut
+
+1;
==== //depot/maint-5.8/perl/ext/Hash/Util/t/Util.t#1 (text) ====
Index: perl/ext/Hash/Util/t/Util.t
--- /dev/null 2007-01-16 11:55:45.526841103 -0800
+++ perl/ext/Hash/Util/t/Util.t 2007-02-05 13:19:54.000000000 -0800
@@ -0,0 +1,472 @@
+#!/usr/bin/perl -Tw
+
+BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ keys %Config; # Silence warning
+ if ($Config{extensions} !~ /\bHash\/Util\b/) {
+ print "1..0 # Skip: Hash::Util was not built\n";
+ exit 0;
+ }
+ }
+}
+
+use strict;
+use Test::More;
+my @Exported_Funcs;
+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 => 204 + @Exported_Funcs;
+ use_ok 'Hash::Util', @Exported_Funcs;
+}
+foreach my $func (@Exported_Funcs) {
+ can_ok __PACKAGE__, $func;
+}
+
+my %hash = (foo => 42, bar => 23, locked => 'yep');
+lock_keys(%hash);
+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},'!exists $hash{baz}' );
+
+delete $hash{bar};
+ok( !exists $hash{bar},'!exists $hash{bar}' );
+$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/,
+ 'Disallowed 1' );
+
+lock_value(%hash, 'locked');
+eval { print "# oops" if $hash{four} };
+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/,
+ 'wide hex key' );
+
+eval { delete $hash{locked} };
+like( $@, qr/^Attempt to delete readonly key 'locked' from a restricted hash/,
+ 'trying to delete a locked key' );
+eval { $hash{locked} = 42; };
+like( $@, qr/^Modification of a read-only value attempted/,
+ 'trying to change a locked key' );
+is( $hash{locked}, 'yep' );
+
+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},'!exists $hash{I_dont_exist}' );
+
+unlock_keys(%hash);
+$hash{I_dont_exist} = 42;
+is( $hash{I_dont_exist}, 42, 'unlock_keys' );
+
+eval { $hash{locked} = 42; };
+like( $@, qr/^Modification of a read-only value attempted/,
+ ' individual key still readonly' );
+eval { delete $hash{locked} },
+is( $@, '', ' but can be deleted :(' );
+
+unlock_value(%hash, 'locked');
+$hash{locked} = 42;
+is( $hash{locked}, 42, 'unlock_value' );
+
+
+{
+ my %hash = ( foo => 42, locked => 23 );
+
+ lock_keys(%hash);
+ eval { %hash = ( wubble => 42 ) }; # we know this will bomb
+ 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');
+
+ eval { %hash = (KEY => 1) };
+ like( $@, qr/^Attempt to delete readonly key 'RO' from a restricted hash/
);
+}
+
+{
+ my %hash = (KEY => 1, RO => 2);
+ lock_keys(%hash);
+ eval { %hash = (KEY => 1, RO => 2) };
+ is( $@, '');
+}
+
+
+
+{
+ my %hash = ();
+ lock_keys(%hash, qw(foo bar));
+ is( keys %hash, 0, 'lock_keys() w/keyset shouldnt add new keys' );
+ $hash{foo} = 42;
+ is( keys %hash, 1 );
+ eval { $hash{wibble} = 42 };
+ like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted
hash/,
+ 'write threw error (locked)');
+
+ unlock_keys(%hash);
+ eval { $hash{wibble} = 23; };
+ is( $@, '', 'unlock_keys' );
+}
+
+
+{
+ 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' );
+
+ eval { $hash{up} = 42; };
+ is( $@, '','No error 1' );
+
+ eval { $hash{wibble} = 23 };
+ like( $@, qr/^Attempt to access disallowed key 'wibble' in a restricted
hash/,
+ 'locked "wibble"' );
+}
+
+
+{
+ 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),
+ 'carp test' );
+}
+
+
+{
+ my %hash = (foo => 42, bar => 23);
+ lock_hash( %hash );
+
+ 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),'Was unlocked %hash' );
+ ok( !Internals::SvREADONLY($hash{foo}),'Was unlocked $hash{foo}' );
+ ok( !Internals::SvREADONLY($hash{bar}),'Was unlocked $hash{bar}' );
+}
+
+
+lock_keys(%ENV);
+eval { () = $ENV{I_DONT_EXIST} };
+like( $@, qr/^Attempt to access disallowed key 'I_DONT_EXIST' in a restricted
hash/, 'locked %ENV');
+
+{
+ my %hash;
+
+ lock_keys(%hash, 'first');
+
+ is (scalar keys %hash, 0, "place holder isn't a key");
+ $hash{first} = 1;
+ is (scalar keys %hash, 1, "we now have a key");
+ delete $hash{first};
+ is (scalar keys %hash, 0, "now no key");
+
+ unlock_keys(%hash);
+
+ $hash{interregnum} = 1.5;
+ is (scalar keys %hash, 1, "key again");
+ delete $hash{interregnum};
+ is (scalar keys %hash, 0, "no key again");
+
+ lock_keys(%hash, 'second');
+
+ is (scalar keys %hash, 0, "place holder isn't a key");
+
+ eval {$hash{zeroeth} = 0};
+ like ($@,
+ qr/^Attempt to access disallowed key 'zeroeth' in a restricted hash/,
+ 'locked key never mentioned before should fail');
+ eval {$hash{first} = -1};
+ like ($@,
+ qr/^Attempt to access disallowed key 'first' in a restricted hash/,
+ 'previously locked place holders should also fail');
+ is (scalar keys %hash, 0, "and therefore there are no keys");
+ $hash{second} = 1;
+ is (scalar keys %hash, 1, "we now have just one key");
+ delete $hash{second};
+ is (scalar keys %hash, 0, "back to zero");
+
+ unlock_keys(%hash); # We have deliberately left a placeholder.
+
+ $hash{void} = undef;
+ $hash{nowt} = undef;
+
+ is (scalar keys %hash, 2, "two keys, values both undef");
+
+ lock_keys(%hash);
+
+ is (scalar keys %hash, 2, "still two keys after locking");
+
+ eval {$hash{second} = -1};
+ like ($@,
+ qr/^Attempt to access disallowed key 'second' in a restricted hash/,
+ 'previously locked place holders should fail');
+
+ is ($hash{void}, undef,
+ "undef values should not be misunderstood as placeholders");
+ is ($hash{nowt}, undef,
+ "undef values should not be misunderstood as placeholders (again)");
+}
+
+{
+ # perl #18651 - [EMAIL PROTECTED] found a rather nasty data dependant
+ # bug whereby hash iterators could lose hash keys (and values, as the code
+ # is common) for restricted hashes.
+
+ my @keys = qw(small medium large);
+
+ # There should be no difference whether it is restricted or not
+ foreach my $lock (0, 1) {
+ # Try setting all combinations of the 3 keys
+ foreach my $usekeys (0..7) {
+ my @usekeys;
+ for my $bits (0,1,2) {
+ push @usekeys, $keys[$bits] if $usekeys & (1 << $bits);
+ }
+ my %clean = map {$_ => length $_} @usekeys;
+ my %target;
+ lock_keys ( %target, @keys ) if $lock;
+
+ while (my ($k, $v) = each %clean) {
+ $target{$k} = $v;
+ }
+
+ my $message
+ = ($lock ? 'locked' : 'not locked') . ' keys ' . join ',', @usekeys;
+
+ is (scalar keys %target, scalar keys %clean, "scalar keys for $message");
+ is (scalar values %target, scalar values %clean,
+ "scalar values for $message");
+ # Yes. All these sorts are necessary. Even for "identical hashes"
+ # Because the data dependency of the test involves two of the strings
+ # colliding on the same bucket, so the iterator order (output of keys,
+ # values, each) depends on the addition order in the hash. And locking
+ # the keys of the hash involves behind the scenes key additions.
+ is_deeply( [sort keys %target] , [sort keys %clean],
+ "list keys for $message");
+ is_deeply( [sort values %target] , [sort values %clean],
+ "list values for $message");
+
+ is_deeply( [sort %target] , [sort %clean],
+ "hash in list context for $message");
+
+ my (@clean, @target);
+ while (my ($k, $v) = each %clean) {
+ push @clean, $k, $v;
+ }
+ while (my ($k, $v) = each %target) {
+ push @target, $k, $v;
+ }
+
+ is_deeply( [sort @target] , [sort @clean],
+ "iterating with each for $message");
+ }
+ }
+}
+
+# Check clear works on locked empty hashes - SEGVs on 5.8.2.
+{
+ my %hash;
+ lock_hash(%hash);
+ %hash = ();
+ ok(keys(%hash) == 0, 'clear empty lock_hash() hash');
+}
+{
+ my %hash;
+ lock_keys(%hash);
+ %hash = ();
+ ok(keys(%hash) == 0, 'clear empty lock_keys() hash');
+}
+
+my $hash_seed = hash_seed();
+ok($hash_seed >= 0, "hash_seed $hash_seed");
+
+{
+ package Minder;
+ my $counter;
+ sub DESTROY {
+ --$counter;
+ }
+ sub new {
+ ++$counter;
+ bless [], __PACKAGE__;
+ }
+ package main;
+
+ for my $state ('', 'locked') {
+ my $a = Minder->new();
+ is ($counter, 1, "There is 1 object $state");
+ my %hash;
+ $hash{a} = $a;
+ is ($counter, 1, "There is still 1 object $state");
+
+ lock_keys(%hash) if $state;
+
+ is ($counter, 1, "There is still 1 object $state");
+ undef $a;
+ is ($counter, 1, "Still 1 object $state");
+ delete $hash{a};
+ is ($counter, 0, "0 objects when hash key is deleted $state");
+ $hash{a} = undef;
+ is ($counter, 0, "Still 0 objects $state");
+ %hash = ();
+ 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,"Count of keys after delete on locked hash");
+ unlock_keys(%hash);
+ 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");
+ lock_keys(%hash);
+ is ($hash{$first}, $value, "Key has the expected value after the lock");
+
+ my ($second, $v2) = each %hash;
+
+ 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 "@[EMAIL PROTECTED]";
+ 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 "@[EMAIL PROTECTED]";
+ 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');
+}
+
+{
+ my %hash = ('a'..'f');
+ my @keys = ();
+ my @ph = ();
+ my @lock = ('a', 'c', 'e', 'g');
+ lock_keys(%hash, @lock);
+ my $ref = all_keys(%hash, @keys, @ph);
+ my @crrack = sort(@keys);
+ my @ooooff = qw(a c e);
+ my @bam = qw(g);
+
+ ok(ref $ref eq ref \%hash && $ref == \%hash,
+ "all_keys() - \$ref is a reference to \%hash");
+ is_deeply([EMAIL PROTECTED], [EMAIL PROTECTED], "Keys are what they should
be");
+ is_deeply([EMAIL PROTECTED], [EMAIL PROTECTED], "Placeholders in place");
+}
+
==== //depot/maint-5.8/perl/win32/Makefile#58 (text) ====
Index: perl/win32/Makefile
--- perl/win32/Makefile#57~30138~ 2007-02-05 11:37:53.000000000 -0800
+++ perl/win32/Makefile 2007-02-05 13:19:54.000000000 -0800
@@ -765,6 +765,7 @@
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
@@ -796,6 +797,7 @@
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
@@ -828,6 +830,7 @@
$(TIMEHIRES).c \
$(CWD).c \
$(LISTUTIL).c \
+ $(HASHUTIL).c \
$(PERLIOVIA).c \
$(XSAPITEST).c \
$(XSTYPEMAP).c \
@@ -860,6 +863,7 @@
$(TIMEHIRES_DLL) \
$(CWD_DLL) \
$(LISTUTIL_DLL) \
+ $(HASHUTIL_DLL) \
$(PERLIOVIA_DLL) \
$(XSAPITEST_DLL) \
$(XSTYPEMAP_DLL) \
@@ -1186,6 +1190,8 @@
-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
==== //depot/maint-5.8/perl/win32/makefile.mk#66 (text) ====
Index: perl/win32/makefile.mk
--- perl/win32/makefile.mk#65~30138~ 2007-02-05 11:37:53.000000000 -0800
+++ perl/win32/makefile.mk 2007-02-05 13:19:54.000000000 -0800
@@ -1360,6 +1360,8 @@
-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
End of Patch.
