File Coverage

blib/lib/Tie/Hash/Cannabinol.pm
Criterion Covered Total %
statement 21 21 100.0
branch 4 4 100.0
condition n/a
subroutine 8 8 100.0
pod n/a
total 33 33 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             Cd 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 isn't to be trusted either :)
31              
32             =cut
33              
34             package Tie::Hash::Cannabinol;
35              
36 2     2   136797 use 5.006;
  2         22  
37 2     2   10 use strict;
  2         4  
  2         37  
38 2     2   10 use warnings;
  2         4  
  2         54  
39 2     2   991 use Tie::Hash;
  2         1919  
  2         70  
40 2     2   1178 use Attribute::Handlers autotie => { "__CALLER__::Stoned" => __PACKAGE__ };
  2         9682  
  2         12  
41              
42             our $VERSION = '1.12.3';
43             our @ISA = qw(Tie::StdHash);
44              
45             =head2 STORE
46              
47             Stores data in the hash 3 times out of 4.
48              
49             =cut
50              
51             sub STORE {
52 8     8   4558 my ($self, $key, $val) = @_;
53              
54 8 100       75 return if rand > .75;
55              
56 6         30 $self->{$key} = $val;
57             }
58              
59             =head2 FETCH
60              
61             Fetchs I from the hash 3 times out of 4.
62              
63             =cut
64              
65             sub FETCH {
66 9072     9072   92320 my ($self, $key) = @_;
67              
68 9072 100       19376 return if rand > .75;
69              
70 6752         22768 return $self->{(keys %$self)[rand keys %$self]};
71             }
72              
73             =head2 EXISTS
74              
75             Gives very dodgy information about the existence of keys in the hash.
76              
77             =cut
78              
79             sub EXISTS {
80 6001     6001   24150 return rand > .5;
81             }
82              
83             1;
84             __END__