1# ------------------------------------------------------------------
2# Petal::Cache::Disk - Caches generated code on disk.
3# ------------------------------------------------------------------
4# Author: Jean-Michel Hiver
5# Description: A simple cache module to avoid re-generating the Perl
6# code from the template file every time
7# ------------------------------------------------------------------
8package Petal::Cache::Disk;
9use strict;
10use warnings;
11use File::Spec;
12use File::Temp qw/tempfile/;
13use Digest::MD5 qw /md5_hex/;
14use Carp;
15
16
17# kill silly warnings
18sub sillyness
19{
20    + $Petal::INPUT &&
21    + $Petal::OUTPUT;
22}
23
24
25# local $Petal::Cache::Disk::TMP_DIR = <some_dir>
26# defaults to File::Spec->tmpdir;
27our $TMP_DIR = File::Spec->tmpdir;
28
29
30# local $Petal::Cache::Disk::PREFIX = <some_prefix>
31# defaults to 'petal_cache_'
32our $PREFIX = 'petal_cache';
33
34
35# $class->get ($file, $lang);
36# --------------------
37# Returns the cached data if its last modification time is more
38# recent than the last modification time of the template
39# Returns the code for template file $file, undef otherwise
40sub get
41{
42    my $class = shift;
43    my $file  = shift;
44    my $lang  = shift || '';
45    my $key   = $class->compute_key ($file, $lang);
46    return $class->cached ($key) if ($class->is_ok ($file, $lang));
47    return;
48}
49
50
51# $class->set ($file, $code, $lang);
52# ---------------------------
53# Sets the cached code for $file + $lang
54sub set
55{
56    my $class = shift;
57    my $file  = shift;
58    my $code  = shift;
59    my $lang  = shift || '';
60    my $key   = $class->compute_key ($file, $lang);
61    my $tmp   = $class->tmp;
62    my $final_file_path = "$tmp/$key";
63
64    #we write the cached templated to a temp file first and move it to the final
65    #destination afterwards. this prevents a rare race condition if a
66    #request attempts to use a cached template that is not yet fully written
67    #by turning it into a atomic operation
68
69    my ($fh, $temp_file_path) = tempfile( $PREFIX . "_XXXXXX", dir => $tmp);
70    binmode( $fh, ":utf8" );
71    print $fh $code;
72    close($fh);
73
74    rename($temp_file_path, $final_file_path)
75        or ( Carp::cluck "Cannot write-open $final_file_path ($!)" and return );
76}
77
78
79# $class->is_ok ($file, $lang);
80# ----------------------
81# Returns TRUE if the cache is still fresh, FALSE otherwise.
82sub is_ok
83{
84    my $class = shift;
85    my $file  = shift;
86    my $lang  = shift || '';
87
88    my $key = $class->compute_key ($file, $lang);
89    my $tmp = $class->tmp;
90    my $tmp_file = "$tmp/$key";
91    return unless (-e $tmp_file);
92
93    my $cached_mtime = $class->cached_mtime ($file, $lang);
94    my $current_mtime = $class->current_mtime ($file);
95    return $cached_mtime >= $current_mtime;
96}
97
98
99# $class->compute_key ($file, $lang);
100# ----------------------------
101# Computes a cache 'key' for $file+$lang, which should be unique.
102# (Well, currently an MD5 checksum is used, which is not
103# *exactly* unique but which should be good enough)
104sub compute_key
105{
106    my $class = shift;
107    my $file = shift;
108    my $lang = shift || '';
109
110    my $key = md5_hex ($file . ";$lang" . ";INPUT=" . $Petal::INPUT . ";OUTPUT=" . $Petal::OUTPUT);
111    $key = $PREFIX . "_" . $Petal::VERSION . "_" . $key if (defined $PREFIX);
112    return $key;
113}
114
115
116# $class->cached_mtime ($file, $lang);
117# -----------------------------
118# Returns the last modification date of the cached data
119# for $file + $lang
120sub cached_mtime
121{
122    my $class = shift;
123    my $file = shift;
124    my $lang = shift || '';
125    my $key = $class->compute_key ($file, $lang);
126    my $tmp = $class->tmp;
127
128    my $tmp_file = "$tmp/$key";
129    my $mtime = (stat($tmp_file))[9];
130    return $mtime;
131}
132
133
134# $class->current_mtime ($file);
135# ------------------------------
136# Returns the last modification date for $file
137sub current_mtime
138{
139    my $class = shift;
140    my $file = shift;
141    $file =~ s/#.*$//;
142    my $mtime = (stat($file))[9];
143    return $mtime;
144}
145
146
147# $class->cached ($key);
148# ----------------------
149# Returns the cached data for $key
150sub cached
151{
152    my $class = shift;
153    my $key = shift;
154    my $tmp = $class->tmp;
155    my $cached_filepath = $tmp . '/' . $key;
156
157    (-e $cached_filepath) or return;
158
159    my $res = undef;
160
161    open FP, "<:utf8", "$tmp/$key"
162        or ( Carp::cluck "Cannot read-open $tmp/$key ($!)" and return );
163
164    $res = join '', <FP>;
165    close FP;
166
167    return $res;
168}
169
170
171# $class->tmp;
172# ------------
173# Returns the temp directory in which the cached data is kept.
174sub tmp
175{
176    my $class = shift;
177    $TMP_DIR ||= File::Spec->tmpdir;
178
179    (-e $TMP_DIR) or confess "\$TMP_DIR '$TMP_DIR' does not exist";
180    (-d $TMP_DIR) or confess "\$TMP_DIR '$TMP_DIR' is not a directory";
181    $TMP_DIR =~ s/\/+$//;
182    return $TMP_DIR;
183}
184
185
1861;
187