File Coverage

blib/lib/Tie/InSecureHash.pm
Criterion Covered Total %
statement 64 145 44.1
branch 9 44 20.4
condition 4 29 13.7
subroutine 16 22 72.7
pod 0 6 0.0
total 93 246 37.8


line stmt bran cond sub pod time code
1             package Tie::InSecureHash;
2              
3 1     1   475 use strict;
  1         2  
  1         40  
4 1     1   7 use vars qw($VERSION $strict $fast);
  1         1  
  1         60  
5 1     1   3 use Carp;
  1         3  
  1         1576  
6              
7             $VERSION = '1.05';
8              
9             sub import
10             {
11 1     1   7 my $pkg = shift;
12 1   0     3 foreach (@_) { $strict ||= /strict/; $fast ||= /fast/ }
  0   0     0  
  0         0  
13 1 0 33     4593 croak qq{$pkg can't be both "strict" and "fast"} if $strict && $fast;
14             }
15              
16             # TAKE A LIST OF POSSIBLE CLASSES FOR AN IMPLICIT KEY AND REMOVE NON-CONTENDERS
17              
18             sub _winnow
19             {
20 0     0   0 my ($caller, $nonpublic, @classes) = @_;
21 0         0 return @classes;
22             };
23              
24             # DETERMINE IF A KEY IS ACCESSIBLE
25              
26             sub _access # ($self,$key,$caller)
27             {
28 516     516   423 my ($self, $key, $caller, $file, $delete) = @_;
29 516         682 return \$self->{fullkeys}{$key};
30              
31             };
32              
33              
34             # NOTE THAT NEW MAY TIE AND BLESS INTO THE SAME CLASS
35             # IF NOTHING MORE APPROPRIATE IS SPECIFIED
36              
37             sub new
38             {
39 1     1 0 38 my %self = ();
40 1   33     5 my $class = ref($_[0])||$_[0];
41 1   33     8 my $blessclass = ref($_[1])||$_[1]||$class;
42 1 50       7 my $impl = tie %self, $class unless $fast;
43 1         2 my $self = bless \%self, $blessclass;
44 1         4 splice(@_,0,2);
45 1 50       4 if (@_) # INITIALIZATION ARGUMENTS PRESENT
46             {
47 0         0 my ($ancestor, $file);
48 0         0 my $i = 0;
49 0         0 while ( ($ancestor,$file) = caller($i++) )
50             {
51 0 0       0 last if $ancestor eq $blessclass;
52             }
53 0         0 my ($key, $value);
54 0         0 while (($key,$value) = splice(@_,0,2))
55             {
56 0 0       0 my $fullkey = $key=~/::/ ? $key : "${blessclass}::$key";
57 0 0       0 if ($fast)
58             {
59 0         0 $self->{$fullkey} = $value;
60             }
61             else
62             {
63 0         0 $impl->{fullkeys}{$fullkey} = $value;
64 0         0 push @{$impl->{keylist}{$key}}, $blessclass;
  0         0  
65 0 0       0 $impl->{file}{$fullkey} = $file
66             if $key =~ /\A__/;
67             }
68             }
69             }
70              
71 1         3 return $self;
72             }
73              
74             # USEFUL METHODS TO DUMP INFORMATION
75              
76             sub debug
77             {
78 0     0 0 0 my $self = tied %{$_[0]};
  0         0  
79 0   0     0 my ($caller, $file, $line, $sub) = (caller,(caller(1))[3]||"(none)");
80 0 0       0 return _simple_debug($_[0],$caller, $file, $line, $sub) unless $self;
81 0         0 my ($key, $val);
82 0         0 my %sorted = ();
83 0         0 while ($key = each %{$self->{fullkeys}})
  0         0  
84             {
85 0         0 $key =~ m/\A(.*?)([^:]*)\Z/;
86 0         0 push @{$sorted{$1}}, $key;
  0         0  
87             }
88              
89 0         0 print STDERR "\nIn subroutine '$sub' called from package '$caller' ($file, line $line):\n";
90 0         0 foreach my $class (keys %sorted)
91             {
92 0         0 print STDERR "\n\t$class\n";
93 0         0 foreach $key ( @{$sorted{$class}} )
  0         0  
94             {
95 0         0 print STDERR "\t\t";
96 0         0 my ($shortkey) = $key =~ /.*::(.*)/;
97 0         0 my $explanation = "";
98 0 0       0 if (eval { _access($self,$shortkey,$caller, $file); 1 })
  0 0       0  
  0         0  
99             {
100 0         0 print STDERR '(+)';
101             }
102             elsif ($@ =~ /\AAmbiguous key/)
103             {
104 0         0 print STDERR '(?)';
105 0         0 ($explanation = $@) =~ s/.*\n//;
106 0         0 $explanation =~ s/.*\n\Z//;
107 0         0 $explanation =~ s/\ACould/Ambiguous unless fully qualified. Could/;
108 0         0 $explanation =~ s/^(?!\Z)/\t\t\t>>> /gm;
109             }
110             else
111             {
112 0         0 print STDERR '(-)';
113 0 0 0     0 if ($shortkey =~ /\A__/ && $@ =~ /file/)
    0          
114             {
115 0         0 $explanation = "\t\t\t>>> Private entry of $class\n\t\t\t>>> declared in file $self->{file}{$key}\n\t\t\t>>> is inaccessable from file $file.\n"
116             }
117             elsif ($shortkey =~ /\A__/)
118             {
119 0         0 $explanation = "\t\t\t>>> Private entry of $class\n\t\t\t>>> is inaccessable from package $caller.\n"
120             }
121             else
122             {
123 0         0 $explanation = "\t\t\t>>> Protected entry of $class\n\t\t\t>>> is inaccessible outside its hierarchy (i.e. from $caller).\n"
124             }
125            
126             }
127 0         0 my $val = $self->{fullkeys}{$key};
128 0 0       0 if (defined $val) { $val = "'$val'" }
  0         0  
129 0         0 else { $val = "undef" }
130 0         0 print STDERR " '$shortkey'\t=> $val";
131 0 0       0 print STDERR "\n$explanation" if $explanation;
132 0         0 print STDERR "\n";
133             }
134             }
135             }
136              
137             sub _simple_debug
138             {
139 0     0   0 my ($self,$caller, $file, $line, $sub) = @_;
140 0         0 my ($key, $val);
141 0         0 my %sorted = ();
142 0         0 while ($key = each %{$self})
  0         0  
143             {
144 0         0 $key =~ m/\A(.*?)([^:]*)\Z/;
145 0         0 push @{$sorted{$1}}, $key;
  0         0  
146             }
147              
148 0         0 print "\nIn subroutine '$sub' called from package '$caller' ($file, line $line):\n";
149 0         0 foreach my $class (keys %sorted)
150             {
151 0         0 print "\n\t$class\n";
152 0         0 foreach $key ( @{$sorted{$class}} )
  0         0  
153             {
154 0         0 print "\t\t";
155 0         0 print " '$key'\t=> '$self->{$key}'\n";
156             }
157             }
158             }
159              
160              
161 20     20 0 351 sub each { each %{$_[0]} }
  20         38  
162 0     0 0 0 sub keys { keys %{$_[0]} }
  0         0  
163 1     1 0 24 sub values { values %{$_[0]} }
  1         3  
164 0     0 0 0 sub exists { exists $_[0]->{$_[1]} }
165              
166             sub TIEHASH # ($class, @args)
167             {
168 1   33 1   4 my $class = ref($_[0]) || $_[0];
169 1 50       4 if ($strict)
    50          
170             {
171 0 0 0     0 carp qq{Tie'ing a securehash directly will be unsafe in 'fast' mode.\n}.
      0        
172             qq{Use Tie::SecureHash::new instead}
173             unless (caller 1)[3] =~ /\A(.*?)::([^:]*)\Z/
174             && $2 eq "new"
175             && $1->isa('Tie::SecureHash');
176             }
177             elsif ($fast)
178             {
179 0         0 carp qq{Tie'ing a securehash directly should never happen in 'fast' mode.\n}.
180             qq{Use Tie::SecureHash::new instead}
181             }
182 1         14 bless {}, $class;
183             }
184              
185             sub FETCH # ($self, $key)
186             {
187 217     217   309 my ($self, $key) = @_;
188 217         297 my $entry = _access($self,$key,(caller)[0..1]);
189 217 50       630 return $$entry if $entry;
190 0         0 return;
191             }
192              
193             sub STORE # ($self, $key, $value)
194             {
195 54     54   130 my ($self, $key, $value) = @_;
196 54         94 my $entry = _access($self,$key,(caller)[0..1]);
197 54 50       148 return $$entry = $value if $entry;
198 0         0 return;
199             }
200              
201             sub DELETE # ($self, $key)
202             {
203 3     3   29 my ($self, $key) = @_;
204 3         7 return _access($self,$key,(caller)[0..1],'DELETE');
205             }
206              
207             sub CLEAR # ($self)
208             {
209 2     2   45 my ($self) = @_;
210 2         4 my ($caller, $file) = caller;
211             my @inaccessibles =
212 72         40 grep { ! eval { _access($self,$_,$caller,$file); 1 } }
  72         62  
  72         66  
  2         13  
213 2         2 keys %{$self->{fullkeys}};
214 0         0 croak "Unable to assign to securehash because the following existing keys\nare inaccessible from package $caller and cannot be deleted:\n" .
215 2 50       6 join("\n", map {"\t$_"} @inaccessibles) . "\n "
216             if @inaccessibles;
217 2         2 %{$self} = ();
  2         13  
218             }
219              
220             sub EXISTS # ($self, $key)
221             {
222 56     56   364 my ($self, $key) = @_;
223 56         73 my @context = (caller)[0..1];
224 56 50       45 eval { _access($self,$key,@context); 1 } ? 1 : '';
  56         50  
  56         135  
225             }
226              
227             sub FIRSTKEY # ($self)
228             {
229 6     6   106 my ($self) = @_;
230 6         6 keys %{$self->{fullkeys}};
  6         6  
231 6         13 goto &NEXTKEY;
232             }
233              
234             sub NEXTKEY # ($self)
235             {
236 120     120   902 my $self = $_[0];
237 120         66 my $key;
238 120         189 my @context = (caller)[0..1];
239 120         85 while (defined($key = each %{$self->{fullkeys}}))
  120         211  
240             {
241 114 50       85 last if eval { _access($self,$key,@context) };
  114         105  
242             }
243 120         236 return $key;
244             }
245              
246             sub DESTROY # ($self)
247 0     0     {
248             # NOTHING TO DO
249             # (BE CAREFUL SINCE IT DOES DOUBLE DUTY FOR tie AND bless)
250             }
251              
252              
253             1;
254             __END__