line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package DTL::Fast::Cache; |
2
|
98
|
|
|
98
|
|
31124
|
use strict; |
|
98
|
|
|
|
|
204
|
|
|
98
|
|
|
|
|
2708
|
|
3
|
98
|
|
|
98
|
|
437
|
use warnings FATAL => 'all'; |
|
98
|
|
|
|
|
210
|
|
|
98
|
|
|
|
|
38186
|
|
4
|
|
|
|
|
|
|
# This is a prototype class for caching templates |
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
sub new |
7
|
|
|
|
|
|
|
{ |
8
|
7
|
|
|
7
|
0
|
31
|
my ( $proto, %kwargs ) = @_; |
9
|
|
|
|
|
|
|
|
10
|
7
|
|
|
|
|
32
|
@kwargs{'hits', 'misses'} = (0, 0); |
11
|
|
|
|
|
|
|
|
12
|
7
|
|
|
|
|
93
|
return bless{ %kwargs }, $proto; |
13
|
|
|
|
|
|
|
} |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
sub get |
16
|
|
|
|
|
|
|
{ |
17
|
92
|
|
|
92
|
0
|
209
|
my ( $self, $key ) = @_; |
18
|
|
|
|
|
|
|
|
19
|
92
|
|
|
|
|
290
|
my $template = $self->validate_template( |
20
|
|
|
|
|
|
|
$self->read_data( |
21
|
|
|
|
|
|
|
$key |
22
|
|
|
|
|
|
|
) |
23
|
|
|
|
|
|
|
); |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
defined $template ? |
26
|
|
|
|
|
|
|
$self->{hits}++ |
27
|
92
|
100
|
|
|
|
227
|
: $self->{misses}++; |
28
|
|
|
|
|
|
|
|
29
|
92
|
|
|
|
|
423
|
return $template; |
30
|
|
|
|
|
|
|
} |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
sub put |
33
|
|
|
|
|
|
|
{ |
34
|
53
|
|
|
53
|
0
|
143
|
my ( $self, $key, $template, %kwargs ) = @_; |
35
|
|
|
|
|
|
|
|
36
|
53
|
50
|
|
|
|
144
|
if (defined $template) |
37
|
|
|
|
|
|
|
{ |
38
|
53
|
|
|
|
|
122
|
my @keys = ('cache', 'url_source'); |
39
|
53
|
|
|
|
|
90
|
my @backup = @{$template}{@keys}; |
|
53
|
|
|
|
|
122
|
|
40
|
53
|
|
|
|
|
88
|
delete @{$template}{@keys}; |
|
53
|
|
|
|
|
101
|
|
41
|
53
|
|
|
|
|
208
|
$self->write_data($key, $template, %kwargs); |
42
|
53
|
|
|
|
|
92
|
@{$template}{@keys} = @backup; |
|
53
|
|
|
|
|
145
|
|
43
|
|
|
|
|
|
|
} |
44
|
53
|
|
|
|
|
132
|
return $self; |
45
|
|
|
|
|
|
|
} |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
sub read_data |
48
|
|
|
|
|
|
|
{ |
49
|
0
|
|
|
0
|
0
|
0
|
my ( $self, $key ) = @_; |
50
|
0
|
|
|
|
|
0
|
die "read_data method was not defined in ".(ref $self); |
51
|
|
|
|
|
|
|
} |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
sub clear |
54
|
|
|
|
|
|
|
{ |
55
|
0
|
|
|
0
|
0
|
0
|
my ( $self ) = @_; |
56
|
0
|
|
|
|
|
0
|
die "clear method was not defined in ".(ref $self); |
57
|
|
|
|
|
|
|
} |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
sub write_data |
60
|
|
|
|
|
|
|
{ |
61
|
0
|
|
|
0
|
0
|
0
|
my ( $self, $key, $value ) = @_; |
62
|
|
|
|
|
|
|
|
63
|
0
|
|
|
|
|
0
|
die "write_data method was not defined in ".(ref $self); |
64
|
|
|
|
|
|
|
} |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
sub validate_template |
67
|
|
|
|
|
|
|
{ |
68
|
92
|
|
|
92
|
0
|
185
|
my ( $self, $template ) = @_; |
69
|
92
|
100
|
|
|
|
255
|
return if (not defined $template); |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
# here we check if template is still valid |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
# check perl version |
74
|
24
|
50
|
33
|
|
|
118
|
return if (not $template->{perl} or $template->{perl} != $]); |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
# check modules version |
77
|
24
|
50
|
|
|
|
68
|
if (my $modules = $template->{modules}) |
78
|
|
|
|
|
|
|
{ |
79
|
24
|
|
|
|
|
70
|
foreach my $module (keys(%$modules)) |
80
|
|
|
|
|
|
|
{ |
81
|
82
|
|
66
|
|
|
373
|
my $current_version = $module->VERSION // $DTL::Fast::VERSION; |
82
|
82
|
50
|
|
|
|
242
|
return if ($modules->{$module} ne $current_version); |
83
|
|
|
|
|
|
|
} |
84
|
|
|
|
|
|
|
} |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
# check files modification |
87
|
24
|
50
|
|
|
|
64
|
if (my $files = $template->{inherits}) |
88
|
|
|
|
|
|
|
{ |
89
|
0
|
|
|
|
|
0
|
foreach my $file (keys( %$files )) |
90
|
|
|
|
|
|
|
{ |
91
|
0
|
0
|
|
|
|
0
|
next if ($file eq 'inline'); |
92
|
|
|
|
|
|
|
return if |
93
|
|
|
|
|
|
|
(not -e $file |
94
|
0
|
0
|
0
|
|
|
0
|
or $files->{$file} != (stat($file))[9]) |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
} |
97
|
|
|
|
|
|
|
|
98
|
24
|
|
|
|
|
48
|
return $template; |
99
|
|
|
|
|
|
|
} |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
1; |