File Coverage

blib/lib/Tie/Hash/FixedKeys.pm

Criterion	Covered	Total	%
statement	37	37	100.0
branch	4	4	100.0
condition			n/a
subroutine	11	11	100.0
pod			n/a
total	52	52	100.0

line	stmt	bran	sub	time	code
1					# $Id$
2
3					=head1 NAME
4
5					Tie::Hash::FixedKeys - Perl extension for hashes with fixed keys
6
7					=head1 SYNOPSIS
8
9					use Tie::Hash::FixedKeys;
10
11					my @keys = qw(forename surname date_of_birth gender);
12					my %person;
13					tie %person, 'Tie;::Hash::FixedKeys', @keys;
14
15					@person{@keys} = qw(Fred Bloggs 19700101 M);
16
17					$person{height} = "6'"; # generates a warning
18
19					or (new! improved!)
20
21					use Tie::Hash::FixedKeys;
22
23					my %person : FixedKeys(qw(forename surname date_of_birth gender));
24
25					=head1 DESCRIPTION
26
27					Tie::Hash::FixedKeys is a class which changes the behaviour of Perl hashes.
28					Any hash which is tied to this class can only contain a fixed set of keys.
29					This set of keys is given when the hash is tied. For example, after running
30					the code:
31
32					my @keys = qw(forename surename date_of_birth gender);
33					my %person;
34					tie %person, 'Tie;::Hash::FixedKeys', @keys;
35
36					the hash C<%person> can only contain the keys forename, surname,
37					date_of_birth and gender. Any attempt to set a value for another key
38					will generate a run-time warning.
39
40					=head2 ATTRIBUTE INTERFACE
41
42					From version 1.5, you can use attributes to set the keys for your hash.
43					You will need Attribute::Handlers version 0.76 or greater.
44
45					=head2 CAVEAT
46
47					The tied hash will always contain exactly one value for each of the keys
48					in the list. These values are initialised to C<undef> when the hash is
49					tied. If you try to C<delete> one if the keys, the effect is that the
50					value is reset to C<undef>.
51
52					=head2 NOTE
53
54					Versions of Perl from 5.8.0 include a module called L<Hash::Util> which
55					contains a function called C<lock_keys> which does the same as this module
56					but in a faster and more powerful way. I recommend that you use that
57					method in place of this module.
58
59					This module is left on CPAN as an example of tied hashes.
60
61					=cut
62
63					package Tie::Hash::FixedKeys;
64
65	2		2	136651	use 5.006;
	2			6
	2			30
66	2		2	5	use strict;
	2			1
	2			29
67	2		2	6	use warnings;
	2			3
	2			39
68
69	2		2	405	use Tie::Hash;
	2			1041
	2			34
70	2		2	6	use Carp;
	2			2
	2			70
71	2		2	10	use vars qw(@ISA $VERSION);
	2			2
	2			72
72
73	2		2	448	use Attribute::Handlers autotie => { "__CALLER__::FixedKeys" => __PACKAGE__ };
	2			4941
	2			15
74
75					@ISA = qw(Tie::StdHash);
76
77					$VERSION = sprintf "%d", '$Revision$ ' =~ /(\d+)/;
78
79					=head1 METHODS
80
81					=head2 TIEHASH
82
83					Creates a tied hash containing all the keys initialised to C<undef>.
84
85					=cut
86
87					sub TIEHASH {
88	1		1	89366	my $class = shift;
89
90	1			2	my %hash;
91	1			3	@hash{@_} = (undef) x @_;
92
93	1			12	bless \%hash, $class;
94					}
95
96					=head2 STORE
97
98					Attempts to store a value in the hash. If the key isn't in the valid
99					list (i.e. it doesn't already exist) the program croaks.
100
101					=cut
102
103					sub STORE {
104	3		3	684	my ($self, $key, $val) = @_;
105
106	3	100		9	unless (exists $self->{$key}) {
107	1			169	croak "invalid key [$key] in hash\n";
108					}
109	2			11	$self->{$key} = $val;
110					}
111
112					=head2 DELETE
113
114					Delete a value from the hash. Actually it just sets the value back to
115					C<undef>.
116
117					=cut
118
119					sub DELETE {
120	2		2	897	my ($self, $key) = @_;
121
122	2	100		14	return unless exists $self->{$key};
123
124	1			2	my $ret = $self->{$key};
125
126	1			2	$self->{$key} = undef;
127
128	1			7	return $ret;
129					}
130
131					=head2 CLEAR
132
133					Clears all values but resetting them to C<undef>.
134
135					=cut
136
137					sub CLEAR {
138	1		1	438	my $self = shift;
139
140	1			2	$self->{$_} = undef foreach keys %$self;
	1			11
141					}
142
143					1;
144					__END__
145
146					=head1 AUTHOR
147
148					Dave Cross <dave@mag-sol.com>
149
150					=head1 COPYRIGHT AND LICENSE
151
152					Copyright (C) 2001, Magnum Solutions Ltd. All Rights Reserved.
153
154					This script is free software; you can redistribute it and/or
155					modify it under the same terms as Perl itself.
156
157					=head1 SEE ALSO
158
159					perl(1), perltie(1).
160
161					=cut
162