File Coverage

blib/lib/File/HashCache.pm

Criterion	Covered	Total	%
statement	68	68	100.0
branch	15	24	62.5
condition	12	20	60.0
subroutine	11	11	100.0
pod	2	4	50.0
total	108	127	85.0

# Copyright © 2009-2013 David Caldwell and Jim Radford.
#
# This library is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself, either Perl version 5.12.4 or,
# at your option, any later version of Perl 5 you may have available.

package File::HashCache; use warnings; use strict;

our $VERSION = '1.0.2';

use List::Util qw(max);
use Digest::MD5 qw(md5_hex);
use File::Basename;
use File::Slurp qw(read_file write_file);
use JSON qw(to_json from_json);

sub max_timestamp(@) { max map { (stat $_)[9] || 0 } @_ } # Obviously 9 is mtime

# DEPRECATED. This has been subsumed by the concatenation code--It's easier
# to deal with and doesn't make you use a weird dialect of Javscript in your
# code. **This is only here for backwards compatibility. Do Not Use.**
sub pound_include($;$);
sub pound_include($;$) {
    my ($text, $referrer) = @_;
    my ($line, @deps) = (0);
    return (join('', map { $line++;
                         $_ .= "\n";
                         if (/^#include\s+"([^"]+)"/) {
                             my $included = read_file(my $name=$1) or die "include '$1' not found".($referrer?" at $referrer\n":"\n");
                             ($_, my @new_deps) = pound_include($included, $name);
                             push @deps, $name, @new_deps;
                         }
                         $_;
                     } split(/\n/, $text)),
            @deps);
}

sub hash {
    my ($config, @name) = @_;

    my ($dir,@base,$ext);
    for my $name (@name) {
        my ($_base, $_dir, $_ext) = fileparse $name, qr/\.[^.]+/;
        $_ext =~ s/^\.//;
        $_ext eq ($ext //= $_ext) or die  "extentions should be the same when concatenating";
        $dir //= $_dir; # Not quite right but works in most cases.
        push @base, $_base;
    }
    my $base = join '-', @base;
    my $name = "$dir$base.$ext"; # canonical version of the name in the single case, and a merged version in the multiple case

    my $script;
    if (   !($script = $config->{cache}->{$name})
        || ! -f $script->{path}
        || max_timestamp(@{$script->{deps}}) > $script->{timestamp}) {

        my @deps = @name;
        my $processed = join("\n", map { scalar read_file($_) } @name);
        my $process_ext = $config->{"process_$ext"};
        for my $process (@{ref($process_ext) eq 'CODE' ? [$process_ext] : $process_ext}) {
            ($processed, my @new_deps) = $process->($processed);
            push @deps, @new_deps;
        }

        my $hash = md5_hex($processed);
        $config->{cache}->{$name} = $script = { deps => \@deps,
                                                name => "$base-$hash.$ext",
                                                path => "$config->{cache_dir}/$base-$hash.$ext",
                                                hash => $hash,
                                                timestamp => max_timestamp(@deps) };
        if (! -f $script->{path}) {
          mkdir $config->{cache_dir};
          write_file($script->{path},       { atomic => 1 }, $processed) or die "couldn't cache $script->{path}";
          write_file($config->{cache_file}, { atomic => 1 }, to_json($config->{cache}, {pretty => 1})) or warn "Couldn't save cache control file";
        }
    }
    $script->{name};
}

sub new {
    my $class = shift;
    my $config = bless { cache_dir => '.hashcache',
                         @_,
                       }, $class;
    $config->{cache_file} ||= "$config->{cache_dir}/cache.json";
    $config->{cache} = from_json( read_file($config->{cache_file}) ) if -f $config->{cache_file};
    my $cache_file_version = 1;
    # On mismatched versions, just clear out the cache:
    $config->{cache} = { VERSION => $cache_file_version } unless $config->{cache} && ($config->{cache}->{VERSION} || 0) == $cache_file_version;
    $config;
}

1;

__END__