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