File Coverage

blib/lib/DBI/Util/CacheMemory.pm
Criterion Covered Total %
statement 23 28 82.1
branch n/a
condition 4 4 100.0
subroutine 8 11 72.7
pod 7 9 77.7
total 42 52 80.7


line stmt bran cond sub pod time code
1             package DBI::Util::CacheMemory;
2              
3             # $Id: CacheMemory.pm 10314 2007-11-26 22:25:33Z Tim $
4             #
5             # Copyright (c) 2007, Tim Bunce, Ireland
6             #
7             # You may distribute under the terms of either the GNU General Public
8             # License or the Artistic License, as specified in the Perl README file.
9              
10 4     4   294715 use strict;
  4         12  
  4         114  
11 4     4   21 use warnings;
  4         9  
  4         1580  
12              
13             =head1 NAME
14              
15             DBI::Util::CacheMemory - a very fast but very minimal subset of Cache::Memory
16              
17             =head1 DESCRIPTION
18              
19             Like Cache::Memory (part of the Cache distribution) but doesn't support any fancy features.
20              
21             This module aims to be a very fast compatible strict sub-set for simple cases,
22             such as basic client-side caching for DBD::Gofer.
23              
24             Like Cache::Memory, and other caches in the Cache and Cache::Cache
25             distributions, the data will remain in the cache until cleared, it expires,
26             or the process dies. The cache object simply going out of scope will I
27             destroy the data.
28              
29             =head1 METHODS WITH CHANGES
30              
31             =head2 new
32              
33             All options except C are ignored.
34              
35             =head2 set
36              
37             Doesn't support expiry.
38              
39             =head2 purge
40              
41             Same as clear() - deletes everything in the namespace.
42              
43             =head1 METHODS WITHOUT CHANGES
44              
45             =over
46              
47             =item clear
48              
49             =item count
50              
51             =item exists
52              
53             =item remove
54              
55             =back
56              
57             =head1 UNSUPPORTED METHODS
58              
59             If it's not listed above, it's not supported.
60              
61             =cut
62              
63             our $VERSION = "0.010315";
64              
65             my %cache;
66              
67             sub new {
68 8     8 1 2353 my ($class, %options ) = @_;
69 8   100     58 my $namespace = $options{namespace} ||= 'Default';
70             #$options{_cache} = \%cache; # can be handy for debugging/dumping
71 8         27 my $self = bless \%options => $class;
72 8   100     80 $cache{ $namespace } ||= {}; # init - ensure it exists
73 8         39 return $self;
74             }
75              
76             sub set {
77 14     14 1 44 my ($self, $key, $value) = @_;
78 14         88 $cache{ $self->{namespace} }->{$key} = $value;
79             }
80              
81             sub get {
82 18     18 0 52 my ($self, $key) = @_;
83 18         93 return $cache{ $self->{namespace} }->{$key};
84             }
85              
86             sub exists {
87 0     0 1 0 my ($self, $key) = @_;
88 0         0 return exists $cache{ $self->{namespace} }->{$key};
89             }
90              
91             sub remove {
92 0     0 1 0 my ($self, $key) = @_;
93 0         0 return delete $cache{ $self->{namespace} }->{$key};
94             }
95              
96             sub purge {
97 0     0 1 0 return shift->clear;
98             }
99              
100             sub clear {
101 6     6 1 37 $cache{ shift->{namespace} } = {};
102             }
103              
104             sub count {
105 8     8 1 1395 return scalar keys %{ $cache{ shift->{namespace} } };
  8         70  
106             }
107              
108             sub size {
109 12     12 0 4113 my $c = $cache{ shift->{namespace} };
110 12         26 my $size = 0;
111 12         80 while ( my ($k,$v) = each %$c ) {
112 8         39 $size += length($k) + length($v);
113             }
114 12         67 return $size;
115             }
116              
117             1;