File Coverage

blib/lib/Text/Forge/MemCache.pm
Criterion Covered Total %
statement 27 70 38.5
branch 9 38 23.6
condition 0 2 0.0
subroutine 6 13 46.1
pod 0 8 0.0
total 42 131 32.0


line stmt bran cond sub pod time code
1             package Text::Forge::MemCache;
2              
3             # XXX Debuging code is haphazard
4              
5             # Setting these values in a BEGIN block doesn't work. The BEGIN
6             # block is called twice, wiping out any preloaded templates in
7             # the parent process.
8             unless (defined $Max_Templates) {
9             # Public globals
10             $Max_Templates = 0;
11             $Min_Templates = 0;
12             $Debug = 0;
13              
14             # Private globals
15             $Template_Count = 0;
16             $Total_Fetches = 0;
17             $Total_Hits = 0;
18             %Cache = ();
19             }
20              
21 5     5   23 use strict;
  5         16  
  5         224  
22 5         357 use vars qw(
23             $Max_Templates $Min_Templates $Debug $Template_Count %Cache
24             $Total_Fetches $Total_Hits
25 5     5   22 );
  5         7  
26 5     5   22 use Carp;
  5         5  
  5         4808  
27              
28             sub _debug {
29 0     0   0 my $self = shift;
30              
31 0         0 print STDERR "CACHE [$Min_Templates/$Template_Count/$Max_Templates]: ",
32             join(' ', @_), "\n";
33             }
34              
35             sub _evict {
36 0     0   0 my $self = shift;
37              
38 0         0 my @paths = sort { $Cache{ $b }->{age} <=> $Cache{ $a }->{age} } keys %Cache;
  0         0  
39              
40 0 0       0 if ($Debug) {
41 0         0 foreach(@paths) {
42 0         0 printf STDERR "%50s %d\n", $_, $Cache{$_}->{age};
43             }
44             }
45            
46 0         0 while($Template_Count > $Min_Templates) {
47 0 0       0 last unless @paths;
48 0         0 delete $Cache{ shift @paths };
49 0         0 $Template_Count--;
50             }
51             }
52              
53             sub fetch {
54 10     10 0 19 my $self = shift;
55 10         13 my $path = shift;
56              
57 10 50       25 $path or croak 'no path supplied';
58              
59 10 50       25 if ($Debug) {
60 0 0       0 $self->_debug( $Cache{ $path } ? "cache hit $path" : "cache miss $path" );
61             }
62              
63 10         11 $Total_Fetches++;
64 10 100       76 return undef unless exists $Cache{ $path };
65 1         2 $Total_Hits++;
66            
67 1 50       3 if ($Max_Templates) {
68 0         0 foreach(keys %Cache) { $Cache{ $_ }->{age}++ }
  0         0  
69 0         0 $Cache{ $path }->{age} = 0;
70             }
71              
72 1         4 $Cache{ $path }->{sub};
73             }
74              
75             sub store {
76 9     9 0 18 my $self = shift;
77 9         16 my($path, $sub) = @_;
78              
79 9 50       24 $path or croak 'no path supplied';
80              
81 9 50       26 if ($Max_Templates) {
82 0         0 foreach(keys %Cache) { $Cache{ $_ }->{age}++ }
  0         0  
83 0 0       0 $self->_evict if $Template_Count > $Max_Templates;
84             }
85              
86 9 50       23 $self->_debug("storing $path") if $Debug;
87              
88 9 50       30 $Template_Count++ unless exists $Cache{ $path };
89 9         33 $Cache{ $path }->{sub} = $sub;
90 9         33 $Cache{ $path }->{age} = 0;
91             }
92              
93             sub delete {
94 0     0 0 0 my $self = shift;
95 0         0 my $path = shift;
96              
97 0 0       0 $path or croak 'no path supplied';
98              
99 0 0       0 return unless exists $Cache{ $path };
100              
101 0         0 delete $Cache{ $path };
102 0         0 --$Template_Count;
103             }
104              
105             sub delete_all {
106 0     0 0 0 my $self = shift;
107              
108 0         0 $Template_Count = 0;
109 0         0 $Total_Fetches = 0;
110 0         0 $Total_Hits = 0;
111 0         0 %Cache = ();
112             }
113              
114 0 0   0 0 0 sub max_templates { (@_ > 1 ? $Max_Templates = $_[1] : $Max_Templates) }
115 0 0   0 0 0 sub min_templates { (@_ > 1 ? $Min_Templates = $_[1] : $Min_Templates) }
116              
117 19     19 0 114 sub is_cached { exists $Cache{ $_[1] } }
118              
119             # Apache::Status plugin
120              
121             sub modperl_status {
122 0     0 0   my($r, $q) = @_;
123              
124 0 0         my $lru = ($Max_Templates ? 'Enabled' : 'Disabled');
125 0 0         my $sort = ($ENV{PATH_INFO} =~ /age/ ? 'age' : 'path');
126              
127 0   0       my $perf = sprintf '%.2f', ($Total_Hits * 100 / ($Total_Fetches || 1));
128              
129 0           my @s = (<
130            

Configuration

131              
132            
133            
134             Max Templates$Max_Templates
135                
136             Debug$Debug
137            
138            
139             Min Templates$Min_Templates
140                
141             LRU Replacement$lru
142            
143            
144              
145            

Cached Templates (hit rate $perf%)

146              
147             ", ";
148            
PathAge
149             EOF
150             );
151            
152 0 0         my @keys = sort {
153 0           (
154             $sort eq 'age' ? $Cache{ $a }->{age} <=> $Cache{ $b }->{age}
155             : $a cmp $b
156             )
157             } keys %Cache;
158            
159 0           foreach my $path (@keys) {
160 0           push @s, "
$path
161             "$Cache{ $path }->{age}
162             }
163              
164 0           push @s, <
165            
166             EOF
167              
168 0           return \@s;
169             }
170              
171             eval {
172             if (Apache->module('Apache::Status')) {
173             Apache::Status->menu_item(
174             'forge-memcache' => 'Text::Forge::MemCache',
175             \&modperl_status
176             );
177             }
178             };
179              
180             1;
181              
182             __END__