File Coverage

blib/lib/Tie/SecureHash.pm
Criterion Covered Total %
statement 119 208 57.2
branch 70 118 59.3
condition 9 41 21.9
subroutine 17 22 77.2
pod 3 6 50.0
total 218 395 55.1


line stmt bran cond sub pod time code
1             package Tie::SecureHash;
2              
3 1     1   1088 use strict;
  1         3  
  1         58  
4 1     1   7 use vars qw($VERSION $strict $fast);
  1         2  
  1         92  
5 1     1   8 use Carp;
  1         6  
  1         4442  
6              
7             $VERSION = '1.06';
8              
9             sub import
10             {
11 1     1   14 my $pkg = shift;
12 1   0     10 foreach (@_) { $strict ||= /strict/; $fast ||= /fast/ }
  0   0     0  
  0         0  
13 1 0 33     5752 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 32     32   80 my ($caller, $nonpublic, @classes) = @_;
21              
22             # REMOVE CLASSES NOT IN HIERARCHY FOR NON-PUBLIC KEY
23              
24 32 100       62 @classes = grep { $caller->isa($_) } @classes if $nonpublic;
  22         89  
25              
26             # COMPARE REMAINING KEYS PAIRWISE, ELIMINATING "SHADOWED" KEYS...
27              
28 32         79 I: for(my $i=0; $i<$#classes; )
29             {
30 17         38 J: for(my $j=$i+1; $j<@classes; )
31             {
32 23 100       106 if ($classes[$j]->isa($classes[$i]))
    50          
33             {
34             # CLASS J SHADOWS I FROM $caller
35 13 100       44 if ($caller->isa($classes[$j]))
    100          
36             {
37 9         13 splice @classes,$i,1;
38 9         25 next I;
39             }
40             # CLASS J BELOW CALLING PACKAGE
41             # (SO CALLING PACKAGE COULDN'T INHERIT IT)
42             elsif($classes[$j]->isa($caller))
43             {
44 1         2 splice @classes,$j,1;
45 1         3 next J;
46             }
47             }
48             elsif ($classes[$i]->isa($classes[$j]))
49             {
50             # CLASS I SHADOWS J FROM $caller
51 0 0       0 if ($caller->isa($classes[$i]))
    0          
52             {
53 0         0 splice @classes,$j,1;
54 0         0 next J;
55             }
56             # CLASS I BELOW CALLING PACKAGE
57             # (SO CALLING PACKAGE COULDN'T INHERIT IT)
58             elsif($classes[$i]->isa($caller))
59             {
60 0         0 splice @classes,$i,1;
61 0         0 next I;
62             }
63             }
64 13         20 $j++;
65              
66             }
67 8         14 $i++;
68             }
69              
70 32         64 return @classes;
71             };
72              
73             # DETERMINE IF A KEY IS ACCESSIBLE
74              
75             sub _access # ($self,$key,$caller)
76             {
77 651     651   715 my ($self, $key, $caller, $file, $delete) = @_;
78              
79             # EXPLICIT KEYS...
80              
81 651 100       3090 if ($key =~ /\A([\w:]*)::((_{0,2})[^:]+)\Z/)
    100          
    50          
82             {
83 578         1163 my ($classname, $shortkey, $mode) = ($1,$2,$3);
84 578 100       935 unless ($classname)
85             {
86 18         18 $classname = 'main';
87 18         31 $key = $classname.$key;
88             }
89 578 100       1053 if ($mode eq '__') # PRIVATE
    100          
90             {
91 124 100       6356 croak "Private key $key of tied securehash inaccessible from package $caller"
92             unless $classname eq $caller;
93 58 100       96 if (exists $self->{fullkeys}{$key})
94             {
95 48 50       115 croak "Private key $key of tied securehash inaccessible from file $file"
96             if $self->{file}{$key} ne $file;
97             }
98             else
99             {
100 10 50       13 if ($delete) { delete $self->{file}{$key} }
  0         0  
101 10         21 else { $self->{file}{$key} = $file }
102             }
103             }
104             elsif ($mode eq '_') # PROTECTED
105             {
106 159 100       8373 croak "Protected key $key of tied securehash inaccessible from package $caller"
107             unless $caller->isa($classname);
108             }
109              
110 424 100       828 if (!exists $self->{fullkeys}{$key})
111             {
112 44 100 100     440 croak "Entry for key $key of tied securehash cannot be created " .
113             "from package $caller"
114             if $classname ne $caller && !$delete;
115 40 100       43 if ($delete)
116             {
117 2         4 @{$self->{keylist}{$shortkey}} =
  0         0  
118 2         6 grep { $_ !~ /$classname/ }
119 2         1 @{$self->{keylist}{$shortkey}}
120             }
121             else
122             {
123 38         30 push @{$self->{keylist}{$shortkey}}, $classname;
  38         99  
124             }
125             }
126             }
127              
128             # IMPLICIT PRIVATE KEY (MUST BE IN CALLING CLASS)
129             elsif ($key =~ /\A(__[^:]+)\Z/)
130             {
131 18 50 33     42 carp qq{Accessing securehash via unqualified key {"$key"}\n}.
132             qq{will be unsafe in 'fast' mode. Use {"${caller}::$key"}}
133             if $strict && $ENV{UNSAFE_WARN};
134 18 100       53 if (!exists $self->{fullkeys}{"${caller}::$key"})
135             {
136 11 100       435 croak "Private key '$key' of tied securehash is inaccessible from package $caller"
137             if exists $self->{keylist}{$key};
138 6         629 croak "Private key '${caller}::$key' does not exist in tied securehash"
139             }
140 7         17 $key = "${caller}::$key";
141 7 50       16 if (exists $self->{fullkeys}{$key})
142             {
143 7 50       19 croak "Private key $key of tied securehash inaccessible from file $file"
144             if $self->{file}{$key} ne $file;
145             }
146             }
147              
148             # IMPLICIT PROTECTED OR PUBLIC KEY
149             # (PROTECTED KEY MUST BE IN ANCESTRAL HIERARCHY OF CALLING CLASS)
150             elsif ($key =~ /\A((_?)[^:]+)\Z/)
151             {
152 55         90 my $fullkey = "${caller}::$key";
153 55 50 33     111 carp qq{Accessing securehash via unqualified key {"$key"}\n}.
154             qq{will be unsafe in 'fast' mode. Use {"${caller}::$key"}}
155             if $strict && $ENV{UNSAFE_WARN};
156 55 100       102 if (exists $self->{fullkeys}{$fullkey})
157             {
158 23         29 $key = $fullkey;
159             }
160             else
161             {
162 32 100       131 my @classes = _winnow($caller, $2,
163 32         31 @{$self->{keylist}{$key}||[]});
164            
165 32 100       54 if (@classes)
166             {
167             # TOO MANY CHOICES
168 12         648 croak "Ambiguous key '$key' (when accessed "
169             . "from package $caller).\nCould be:\n"
170 16 100       44 . join("", map {"\t${_}::$key\n"} @classes)
171             . " "
172             if @classes > 1;
173 11         27 $key = $classes[0]."::$key";
174             }
175             else # NOT ENOUGH CHOICES
176             {
177 16 100       382 croak +($2?"Protected":"Public")." key '$key' of tied securehash is inaccessible from package $caller"
    100          
178             if exists $self->{keylist}{$key};
179 12 100       1032 croak +($2?"Protected":"Public")." key '${caller}::$key' does not exist in tied securehash";
180             }
181             }
182             }
183             else # INVALID KEY
184             {
185 0         0 croak "Invalid key '$key'";
186             }
187              
188 461 100       596 if ($delete) { return delete $self->{fullkeys}{$key}; }
  2         7  
189 459         1375 return \$self->{fullkeys}{$key};
190              
191             };
192              
193              
194             # NOTE THAT NEW MAY TIE AND BLESS INTO THE SAME CLASS
195             # IF NOTHING MORE APPROPRIATE IS SPECIFIED
196              
197             sub new
198             {
199 1     1 1 52 my %self = ();
200 1   33     6 my $class = ref($_[0])||$_[0];
201 1   33     9 my $blessclass = ref($_[1])||$_[1]||$class;
202 1 50       7 my $impl = tie %self, $class unless $fast;
203 1         3 my $self = bless \%self, $blessclass;
204 1         4 splice(@_,0,2);
205 1 50       5 if (@_) # INITIALIZATION ARGUMENTS PRESENT
206             {
207 0         0 my ($ancestor, $file);
208 0         0 my $i = 0;
209 0         0 while ( ($ancestor,$file) = caller($i++) )
210             {
211 0 0       0 last if $ancestor eq $blessclass;
212             }
213 0 0       0 $file = "" if ! defined $file; # dms 14 Mar 2000: satisfy -w switch
214 0         0 my ($key, $value);
215 0         0 while (($key,$value) = splice(@_,0,2))
216             {
217 0 0       0 my $fullkey = $key=~/::/ ? $key : "${blessclass}::$key";
218 0 0       0 if ($fast)
219             {
220 0         0 $self->{$fullkey} = $value;
221             }
222             else
223             {
224 0         0 $impl->{fullkeys}{$fullkey} = $value;
225 0         0 push @{$impl->{keylist}{$key}}, $blessclass;
  0         0  
226 0 0       0 $impl->{file}{$fullkey} = $file
227             if $key =~ /\A__/;
228             }
229             }
230             }
231              
232 1         3 return $self;
233             }
234              
235             # USEFUL METHODS TO DUMP INFORMATION
236              
237             sub debug
238             {
239 0     0 0 0 my $self = tied %{$_[0]};
  0         0  
240 0   0     0 my ($caller, $file, $line, $sub) = (caller,(caller(1))[3]||"(none)");
241 0 0       0 return _simple_debug($_[0],$caller, $file, $line, $sub) unless $self;
242 0         0 my ($key, $val);
243 0         0 my %sorted = ();
244 0         0 while ($key = CORE::each %{$self->{fullkeys}})
  0         0  
245             {
246 0         0 $key =~ m/\A(.*?)([^:]*)\Z/;
247 0         0 push @{$sorted{$1}}, $key;
  0         0  
248             }
249              
250 0         0 print STDERR "\nIn subroutine '$sub' called from package '$caller' ($file, line $line):\n";
251 0         0 foreach my $class (CORE::keys %sorted)
252             {
253 0         0 print STDERR "\n\t$class\n";
254 0         0 foreach $key ( @{$sorted{$class}} )
  0         0  
255             {
256 0         0 print STDERR "\t\t";
257 0         0 my ($shortkey) = $key =~ /.*::(.*)/;
258 0         0 my $explanation = "";
259 0 0       0 if (eval { _access($self,$shortkey,$caller, $file); 1 })
  0 0       0  
  0         0  
260             {
261 0         0 print STDERR '(+)';
262             }
263             elsif ($@ =~ /\AAmbiguous key/)
264             {
265 0         0 print STDERR '(?)';
266 0         0 ($explanation = $@) =~ s/.*\n//;
267 0         0 $explanation =~ s/.*\n\Z//;
268 0         0 $explanation =~ s/\ACould/Ambiguous unless fully qualified. Could/;
269 0         0 $explanation =~ s/^(?!\Z)/\t\t\t>>> /gm;
270             }
271             else
272             {
273 0         0 print STDERR '(-)';
274 0 0 0     0 if ($shortkey =~ /\A__/ && $@ =~ /file/)
    0          
275             {
276 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"
277             }
278             elsif ($shortkey =~ /\A__/)
279             {
280 0         0 $explanation = "\t\t\t>>> Private entry of $class\n\t\t\t>>> is inaccessable from package $caller.\n"
281             }
282             else
283             {
284 0         0 $explanation = "\t\t\t>>> Protected entry of $class\n\t\t\t>>> is inaccessible outside its hierarchy (i.e. from $caller).\n"
285             }
286            
287             }
288 0         0 my $val = $self->{fullkeys}{$key};
289 0 0       0 if (defined $val) { $val = "'$val'" }
  0         0  
290 0         0 else { $val = "undef" }
291 0         0 print STDERR " '$shortkey'\t=> $val";
292 0 0       0 print STDERR "\n$explanation" if $explanation;
293 0         0 print STDERR "\n";
294             }
295             }
296             }
297              
298             sub _simple_debug
299             {
300 0     0   0 my ($self,$caller, $file, $line, $sub) = @_;
301 0         0 my ($key, $val);
302 0         0 my %sorted = ();
303 0         0 while ($key = CORE::each %{$self})
  0         0  
304             {
305 0         0 $key =~ m/\A(.*?)([^:]*)\Z/;
306 0         0 push @{$sorted{$1}}, $key;
  0         0  
307             }
308              
309 0         0 print "\nIn subroutine '$sub' called from package '$caller' ($file, line $line):\n";
310 0         0 foreach my $class (CORE::keys %sorted)
311             {
312 0         0 print "\n\t$class\n";
313 0         0 foreach $key ( @{$sorted{$class}} )
  0         0  
314             {
315 0         0 print "\t\t";
316 0         0 print " '$key'\t=> '$self->{$key}'\n";
317             }
318             }
319             }
320              
321              
322 16     16 0 380 sub each($) { CORE::each %{$_[0]} }
  16         44  
323 0     0 1 0 sub keys($) { CORE::keys %{$_[0]} }
  0         0  
324 1     1 0 33 sub values($) { CORE::values %{$_[0]} }
  1         6  
325 0     0 1 0 sub exists($$) { CORE::exists $_[0]->{$_[1]} }
326              
327             sub TIEHASH # ($class, @args)
328             {
329 1   33 1   4 my $class = ref($_[0]) || $_[0];
330 1 50       7 if ($strict)
    50          
331             {
332 0 0 0     0 carp qq{Tie'ing a securehash directly will be unsafe in 'fast' mode.\n}.
      0        
      0        
333             qq{Use Tie::SecureHash::new instead}
334             unless (caller 1)[3] =~ /\A(.*?)::([^:]*)\Z/
335             && $2 eq "new"
336             && "$1"->isa('Tie::SecureHash') && $ENV{UNSAFE_WARN};
337             }
338             elsif ($fast)
339             {
340 0         0 carp qq{Tie'ing a securehash directly should never happen in 'fast' mode.\n}.
341             qq{Use Tie::SecureHash::new instead}
342             }
343 1         4 bless {}, $class;
344             }
345              
346             sub FETCH # ($self, $key)
347             {
348 230     230   1728 my ($self, $key) = @_;
349 230         503 my $entry = _access($self,$key,(caller)[0..1]);
350 210 50       916 return $$entry if $entry;
351 0         0 return;
352             }
353              
354             sub STORE # ($self, $key, $value)
355             {
356 50     50   963 my ($self, $key, $value) = @_;
357 50         113 my $entry = _access($self,$key,(caller)[0..1]);
358 32 50       154 return $$entry = $value if $entry;
359 0         0 return;
360             }
361              
362             sub DELETE # ($self, $key)
363             {
364 3     3   35 my ($self, $key) = @_;
365 3         9 return _access($self,$key,(caller)[0..1],'DELETE');
366             }
367              
368             sub CLEAR # ($self)
369             {
370 2     2   118 my ($self) = @_;
371 2         6 my ($caller, $file) = caller;
372             my @inaccessibles =
373 76         784 grep { ! eval { _access($self,$_,$caller,$file); 1 } }
  76         113  
  46         98  
  2         15  
374 2         4 CORE::keys %{$self->{fullkeys}};
375 30         215 croak "Unable to assign to securehash because the following existing keys\nare inaccessible from package $caller and cannot be deleted:\n" .
376 2 50       49 join("\n", map {"\t$_"} @inaccessibles) . "\n "
377             if @inaccessibles;
378 0         0 %{$self} = ();
  0         0  
379             }
380              
381             sub EXISTS # ($self, $key)
382             {
383 64     64   690 my ($self, $key) = @_;
384 64         153 my @context = (caller)[0..1];
385 64 100       72 eval { _access($self,$key,@context); 1 } ? 1 : '';
  64         91  
  57         254  
386             }
387              
388             sub FIRSTKEY # ($self)
389             {
390 6     6   178 my ($self) = @_;
391 6         16 CORE::keys %{$self->{fullkeys}};
  6         17  
392 6         47 goto &NEXTKEY;
393             }
394              
395             sub NEXTKEY # ($self)
396             {
397 120     120   989 my $self = $_[0];
398 120         88 my $key;
399 120         285 my @context = (caller)[0..1];
400 120         105 while (defined($key = CORE::each %{$self->{fullkeys}}))
  234         639  
401             {
402 228 100       242 last if eval { _access($self,$key,@context) };
  228         307  
403 114 50       3312 carp "Attempt to iterate inaccessible key '$key' will be unsafe in 'fast' mode. Use explicit keys" if $ENV{UNSAFE_WARN};
404            
405             }
406 120         573 return $key;
407             }
408              
409             sub DESTROY # ($self)
410 0     0     {
411             # NOTHING TO DO
412             # (BE CAREFUL SINCE IT DOES DOUBLE DUTY FOR tie AND bless)
413             }
414              
415              
416             1;
417             __END__