File Coverage

blib/lib/Tie/Hash/Cannabinol.pm
Criterion Covered Total %
statement 25 25 100.0
branch 4 4 100.0
condition n/a
subroutine 9 9 100.0
pod n/a
total 38 38 100.0


line stmt bran cond sub pod time code
1             # $Id$
2              
3             =head1 NAME
4            
5             Tie::Hash::Cannabinol - Perl extension for creating hashes that forget things
6            
7             =head1 SYNOPSIS
8            
9             use Tie::Hash::Cannabinol;
10            
11             my %hash;
12             tie %hash, 'Tie::Hash::Cannabinol';
13            
14             or
15            
16             my %hash : Stoned;
17            
18             # % hash can now be treated exactly like a normal hash - but don't trust
19             # anything it tells you.
20            
21             =head1 DESCRIPTION
22            
23             Tie::Hash::Cannabinol is a completely useless demonstration of how to use
24             Tie::StdHash to pervert the behaviour of Perl hashes. Once a hash has been
25             C<tie>d to Tie::Hash::Cannabinol, there is a 25% chance that it will forget
26             anything that you tell it immediately and a further 25% chance that it
27             won't be able to retrieve any information you ask it for. Any information
28             that it does return will be pulled at random from its keys.
29            
30             Oh, and the return value from C<exists> isn't to be trusted either :)
31            
32             =cut
33              
34             package Tie::Hash::Cannabinol;
35              
36 3     3   142137 use 5.006;
  3         10  
  3         46  
37 3     3   8 use strict;
  3         3  
  3         43  
38 3     3   9 use warnings;
  3         4  
  3         71  
39 3     3   9 use vars qw($VERSION @ISA);
  3         3  
  3         92  
40 3     3   649 use Tie::Hash;
  3         1458  
  3         67  
41 3     3   723 use Attribute::Handlers autotie => { "__CALLER__::Stoned" => __PACKAGE__ };
  3         29404  
  3         32  
42              
43             $VERSION = sprintf "%d", '$Revision$ ' =~ /(\d+)/;
44             @ISA = qw(Tie::StdHash);
45              
46             =head2 STORE
47            
48             Stores data in the hash 3 times out of 4.
49            
50             =cut
51              
52             sub STORE {
53 8     8   192554   my ($self, $key, $val) = @_;
54              
55 8 100       34   return if rand > .75;
56              
57 6         21   $self->{$key} = $val;
58             }
59              
60             =head2 FETCH
61            
62             Fetchs I<something> from the hash 3 times out of 4.
63            
64             =cut
65              
66             sub FETCH {
67 9072     9072   71152   my ($self, $key) = @_;
68              
69 9072 100       19221   return if rand > .75;
70              
71 6753         34121   return $self->{(keys %$self)[rand keys %$self]};
72             }
73              
74             =head2 EXISTS
75            
76             Gives very dodgy information about the existance of keys in the hash.
77            
78             =cut
79              
80             sub EXISTS {
81 6001     6001   19504   return rand > .5;
82             }
83              
84             1;
85             __END__
86            
87            
88             =head1 AUTHOR
89            
90             Dave Cross <dave@mag-sol.com>
91            
92             =head1 UPDATES
93            
94             The latest version of this module will always be available from
95             L<http://code.mag-sol.com/Tie-Hash-Cannabinol> or from CPAN
96             at L<http://search.cpan.org/dist/Tie-Hash-Cannabinol/>.
97            
98             =head1 COPYRIGHT
99            
100             Copyright (C) 2001-8, Magnum Solutions Ltd. All Rights Reserved.
101            
102             =head1 LICENSE
103            
104             This script is free software; you can redistribute it and/or
105             modify it under the same terms as Perl itself.
106            
107             =head1 SEE ALSO
108            
109             perl(1), perltie(1), Tie::StdHash(1)
110            
111             =cut
112