File Coverage

lib/Petal/Cache/Disk.pm

Criterion	Covered	Total	%
statement	55	82	67.0
branch	6	18	33.3
condition	5	17	29.4
subroutine	11	15	73.3
pod	0	9	0.0
total	77	141	54.6

# ------------------------------------------------------------------
# Petal::Cache::Disk - Caches generated code on disk.
# ------------------------------------------------------------------
# Author: Jean-Michel Hiver
# Description: A simple cache module to avoid re-generating the Perl
# code from the template file every time
# ------------------------------------------------------------------
package Petal::Cache::Disk;
use strict;
use warnings;
use File::Spec;
use File::Temp qw/tempfile/;
use Digest::MD5 qw /md5_hex/;
use Carp;


# kill silly warnings
sub sillyness
{
    + $Petal::INPUT &&
    + $Petal::OUTPUT;
}


# local $Petal::Cache::Disk::TMP_DIR =
# defaults to File::Spec->tmpdir;
our $TMP_DIR = File::Spec->tmpdir;


# local $Petal::Cache::Disk::PREFIX =
# defaults to 'petal_cache_'
our $PREFIX = 'petal_cache';


# $class->get ($file, $lang);
# --------------------
# Returns the cached data if its last modification time is more
# recent than the last modification time of the template
# Returns the code for template file $file, undef otherwise
sub get
{
    my $class = shift;
    my $file  = shift;
    my $lang  = shift || '';
    my $key   = $class->compute_key ($file, $lang);
    return $class->cached ($key) if ($class->is_ok ($file, $lang));
    return;
}


# $class->set ($file, $code, $lang);
# ---------------------------
# Sets the cached code for $file + $lang
sub set
{
    my $class = shift;
    my $file  = shift;
    my $code  = shift;
    my $lang  = shift || '';
    my $key   = $class->compute_key ($file, $lang);
    my $tmp   = $class->tmp;
    my $final_file_path = "$tmp/$key";

    #we write the cached templated to a temp file first and move it to the final
    #destination afterwards. this prevents a rare race condition if a
    #request attempts to use a cached template that is not yet fully written
    #by turning it into a atomic operation

    my ($fh, $temp_file_path) = tempfile( $PREFIX . "_XXXXXX", dir => $tmp);
    binmode( $fh, ":utf8" );
    print $fh $code;
    close($fh);

    rename($temp_file_path, $final_file_path)
        or ( Carp::cluck "Cannot write-open $final_file_path ($!)" and return );
}


# $class->is_ok ($file, $lang);
# ----------------------
# Returns TRUE if the cache is still fresh, FALSE otherwise.
sub is_ok
{
    my $class = shift;
    my $file  = shift;
    my $lang  = shift || '';

    my $key = $class->compute_key ($file, $lang);
    my $tmp = $class->tmp;
    my $tmp_file = "$tmp/$key";
    return unless (-e $tmp_file);

    my $cached_mtime = $class->cached_mtime ($file, $lang);
    my $current_mtime = $class->current_mtime ($file);
    return $cached_mtime >= $current_mtime;
}


# $class->compute_key ($file, $lang);
# ----------------------------
# Computes a cache 'key' for $file+$lang, which should be unique.
# (Well, currently an MD5 checksum is used, which is not
# *exactly* unique but which should be good enough)
sub compute_key
{
    my $class = shift;
    my $file = shift;
    my $lang = shift || '';

    my $key = md5_hex ($file . ";$lang" . ";INPUT=" . $Petal::INPUT . ";OUTPUT=" . $Petal::OUTPUT);
    $key = $PREFIX . "_" . $Petal::VERSION . "_" . $key if (defined $PREFIX);
    return $key;
}


# $class->cached_mtime ($file, $lang);
# -----------------------------
# Returns the last modification date of the cached data
# for $file + $lang
sub cached_mtime
{
    my $class = shift;
    my $file = shift;
    my $lang = shift || '';
    my $key = $class->compute_key ($file, $lang);
    my $tmp = $class->tmp;

    my $tmp_file = "$tmp/$key";
    my $mtime = (stat($tmp_file))[9];
    return $mtime;
}


# $class->current_mtime ($file);
# ------------------------------
# Returns the last modification date for $file
sub current_mtime
{
    my $class = shift;
    my $file = shift;
    $file =~ s/#.*$//;
    my $mtime = (stat($file))[9];
    return $mtime;
}


# $class->cached ($key);
# ----------------------
# Returns the cached data for $key
sub cached
{
    my $class = shift;
    my $key = shift;
    my $tmp = $class->tmp;
    my $cached_filepath = $tmp . '/' . $key;

    (-e $cached_filepath) or return;

    my $res = undef;

    open FP, "<:utf8", "$tmp/$key"
        or ( Carp::cluck "Cannot read-open $tmp/$key ($!)" and return );

    $res = join '', ;
    close FP;

    return $res;
}


# $class->tmp;
# ------------
# Returns the temp directory in which the cached data is kept.
sub tmp
{
    my $class = shift;
    $TMP_DIR ||= File::Spec->tmpdir;

    (-e $TMP_DIR) or confess "\$TMP_DIR '$TMP_DIR' does not exist";
    (-d $TMP_DIR) or confess "\$TMP_DIR '$TMP_DIR' is not a directory";
    $TMP_DIR =~ s/\/+$//;
    return $TMP_DIR;
}


1;