gitweb/lib/GitwebCache/SimpleFileCache.pm

   1 # gitweb - simple web interface to track changes in git repositories
   2 #
   3 # (C) 2006, John 'Warthog9' Hawley <warthog19@eaglescrag.net>
   4 # (C) 2010, Jakub Narebski <jnareb@gmail.com>
   5 #
   6 # This program is licensed under the GPLv2
   7
   8 #
   9 # Gitweb caching engine, simple file-based cache
  10 #
  11
  12 # Minimalistic cache that stores data in the filesystem, without serialization
  13 # and currently without any kind of cache expiration (all keys last forever till
  14 # they got explicitely removed).
  15 #
  16 # It follows Cache::Cache and CHI interfaces (but does not implement it fully)
  17
  18 package GitwebCache::SimpleFileCache;
  19
  20 use strict;
  21 use warnings;
  22
  23 use File::Path qw(mkpath);
  24 use File::Temp qw(tempfile);
  25 use Digest::MD5 qw(md5_hex);
  26
  27 # by default, the cache nests all entries on the filesystem single
  28 # directory deep, i.e. '60/b725f10c9c85c70d97880dfe8191b3' for
  29 # key name (key digest) 60b725f10c9c85c70d97880dfe8191b3.
  30 #
  31 our $DEFAULT_CACHE_DEPTH = 1;
  32
  33 # by default, the root of the cache is located in 'cache'.
  34 #
  35 our $DEFAULT_CACHE_ROOT = "cache";
  36
  37 # by default we don't use cache namespace (empty namespace);
  38 # empty namespace does not allow for simple implementation of clear() method.
  39 #
  40 our $DEFAULT_NAMESPACE = '';
  41
  42 # ......................................................................
  43 # constructor
  44
  45 # The options are set by passing in a reference to a hash containing
  46 # any of the following keys:
  47 #  * 'namespace'
  48 #    The namespace associated with this cache.  This allows easy separation of
  49 #    multiple, distinct caches without worrying about key collision.  Defaults
  50 #    to $DEFAULT_NAMESPACE.
  51 #  * 'cache_root' (Cache::FileCache compatibile),
  52 #    'root_dir' (CHI::Driver::File compatibile),
  53 #    The location in the filesystem that will hold the root of the cache.
  54 #    Defaults to $DEFAULT_CACHE_ROOT.
  55 #  * 'cache_depth' (Cache::FileCache compatibile),
  56 #    'depth' (CHI::Driver::File compatibile),
  57 #    The number of subdirectories deep to cache object item.  This should be
  58 #    large enough that no cache directory has more than a few hundred objects.
  59 #    Defaults to $DEFAULT_CACHE_DEPTH unless explicitly set.
  60 #  * 'default_expires_in' (Cache::Cache compatibile),
  61 #    'expires_in' (CHI compatibile) [seconds]
  62 #    The expiration time for objects place in the cache.
  63 #    Defaults to -1 (never expire) if not explicitly set.
  64 sub new {
  65         my $class = shift;
  66         my %opts = ref $_[0] ? %{ $_[0] } : @_;
  67
  68         my $self = {};
  69         $self = bless($self, $class);
  70
  71         my ($root, $depth, $ns, $expires_in);
  72         if (%opts) {
  73                 $root =
  74                         $opts{'cache_root'} ||
  75                         $opts{'root_dir'};
  76                 $depth =
  77                         $opts{'cache_depth'} ||
  78                         $opts{'depth'};
  79                 $ns = $opts{'namespace'};
  80                 $expires_in =
  81                         $opts{'default_expires_in'} ||
  82                         $opts{'expires_in'};
  83         }
  84         $root  = $DEFAULT_CACHE_ROOT  unless defined($root);
  85         $depth = $DEFAULT_CACHE_DEPTH unless defined($depth);
  86         $ns    = $DEFAULT_NAMESPACE   unless defined($ns);
  87         $expires_in = -1 unless defined($expires_in); # <0 means never
  88
  89         $self->set_root($root);
  90         $self->set_depth($depth);
  91         $self->set_namespace($ns);
  92         $self->set_expires_in($expires_in);
  93
  94         return $self;
  95 }
  96
  97
  98 # ......................................................................
  99 # accessors
 100
 101 # http://perldesignpatterns.com/perldesignpatterns.html#AccessorPattern
 102
 103 # creates get_depth() and set_depth($depth) etc. methods
 104 foreach my $i (qw(depth root namespace expires_in)) {
 105         my $field = $i;
 106         no strict 'refs';
 107         *{"get_$field"} = sub {
 108                 my $self = shift;
 109                 return $self->{$field};
 110         };
 111         *{"set_$field"} = sub {
 112                 my ($self, $value) = @_;
 113                 $self->{$field} = $value;
 114         };
 115 }
 116
 117
 118 # ----------------------------------------------------------------------
 119 # utility functions and methods
 120
 121 # Return root dir for namespace (lazily built, cached)
 122 sub path_to_namespace {
 123         my ($self) = @_;
 124
 125         if (!exists $self->{'path_to_namespace'}) {
 126                 if (defined $self->{'namespace'} &&
 127                     $self->{'namespace'} ne '') {
 128                         $self->{'path_to_namespace'} = "$self->{'root'}/$self->{'namespace'}";
 129                 } else {
 130                         $self->{'path_to_namespace'} =  $self->{'root'};
 131                 }
 132         }
 133         return $self->{'path_to_namespace'};
 134 }
 135
 136 # $path = $cache->path_to_key($key);
 137 # $path = $cache->path_to_key($key, \$dir);
 138 #
 139 # Take an human readable key, and return file path.
 140 # Puts dirname of file path in second argument, if it is provided.
 141 sub path_to_key {
 142         my ($self, $key, $dir_ref) = @_;
 143
 144         my @paths = ( $self->path_to_namespace() );
 145
 146         # Create a unique (hashed) key from human readable key
 147         my $filename = md5_hex($key); # or $digester->add($key)->hexdigest();
 148
 149         # Split filename so that it have DEPTH subdirectories,
 150         # where each subdirectory has a two-letter name
 151         push @paths, unpack("(a2)[$self->{'depth'}] a*", $filename);
 152         $filename = pop @paths;
 153
 154         # Join paths together, computing dir separately if $dir_ref was passed.
 155         my $filepath;
 156         if (defined $dir_ref && ref($dir_ref)) {
 157                 my $dir = join('/', @paths);
 158                 $filepath = "$dir/$filename";
 159                 $$dir_ref = $dir;
 160         } else {
 161                 $filepath = join('/', @paths, $filename);
 162         }
 163
 164         return $filepath;
 165 }
 166
 167 sub read_file {
 168         my $filename = shift;
 169
 170         # Fast slurp, adapted from File::Slurp::read, with unnecessary options removed
 171         # via CHI::Driver::File (from CHI-0.33)
 172         my $buf = '';
 173         open my $read_fh, '<', $filename
 174                 or return;
 175         binmode $read_fh, ':raw';
 176
 177         my $size_left = -s $read_fh;
 178
 179         while ($size_left > 0) {
 180                 my $read_cnt = sysread($read_fh, $buf, $size_left, length($buf));
 181                 return unless defined $read_cnt;
 182
 183                 last if $read_cnt == 0;
 184                 $size_left -= $read_cnt;
 185                 #last if $size_left <= 0;
 186         }
 187
 188         close $read_fh
 189                 or die "Couldn't close file '$filename' opened for reading: $!";
 190         return $buf;
 191 }
 192
 193 sub write_fh {
 194         my ($write_fh, $filename, $data) = @_;
 195
 196         # Fast spew, adapted from File::Slurp::write, with unnecessary options removed
 197         # via CHI::Driver::File (from CHI-0.33)
 198         binmode $write_fh, ':raw';
 199
 200         my $size_left = length($data);
 201         my $offset = 0;
 202
 203         while ($size_left > 0) {
 204                 my $write_cnt = syswrite($write_fh, $data, $size_left, $offset);
 205                 return unless defined $write_cnt;
 206
 207                 $size_left -= $write_cnt;
 208                 $offset += $write_cnt; # == length($data);
 209         }
 210
 211         close $write_fh
 212                 or die "Couldn't close file '$filename' opened for writing: $!";
 213 }
 214
 215 # ----------------------------------------------------------------------
 216 # "private" utility functions and methods
 217
 218 # take a file path to cache entry, and its directory
 219 # return filehandle and filename of open temporary file,
 220 # like File::Temp::tempfile
 221 sub _tempfile_to_path {
 222         my ($file, $dir) = @_;
 223
 224         # tempfile will croak() if there is an error
 225         return tempfile("${file}_XXXXX",
 226                 #DIR => $dir,
 227                 'UNLINK' => 0, # ensure that we don't unlink on close; file is renamed
 228                 'SUFFIX' => '.tmp');
 229 }
 230
 231
 232 # ----------------------------------------------------------------------
 233 # worker methods
 234
 235 sub fetch {
 236         my ($self, $key) = @_;
 237
 238         my $file = $self->path_to_key($key);
 239         return unless (defined $file && -f $file);
 240
 241         return read_file($file);
 242 }
 243
 244 sub store {
 245         my ($self, $key, $data) = @_;
 246
 247         my $dir;
 248         my $file = $self->path_to_key($key, \$dir);
 249         return unless (defined $file && defined $dir);
 250
 251         # ensure that directory leading to cache file exists
 252         if (!-d $dir) {
 253                 # mkpath will croak()/die() if there is an error
 254                 mkpath($dir, 0, 0777);
 255         }
 256
 257         # generate a temporary file
 258         my ($temp_fh, $tempname) = _tempfile_to_path($file, $dir);
 259         chmod 0666, $tempname
 260                 or warn "Couldn't change permissions to 0666 / -rw-rw-rw- for '$tempname': $!";
 261
 262         write_fh($temp_fh, $tempname, $data);
 263
 264         rename($tempname, $file)
 265                 or die "Couldn't rename temporary file '$tempname' to '$file': $!";
 266 }
 267
 268 # get size of an element associated with the $key (not the size of whole cache)
 269 sub get_size {
 270         my ($self, $key) = @_;
 271
 272         my $path = $self->path_to_key($key)
 273                 or return undef;
 274         if (-f $path) {
 275                 return -s $path;
 276         }
 277         return 0;
 278 }
 279
 280
 281 # ......................................................................
 282 # interface methods
 283
 284 # Removing and expiring
 285
 286 # $cache->remove($key)
 287 #
 288 # Remove the data associated with the $key from the cache.
 289 sub remove {
 290         my ($self, $key) = @_;
 291
 292         my $file = $self->path_to_key($key)
 293                 or return;
 294         return unless -f $file;
 295         unlink($file)
 296                 or die "Couldn't remove file '$file': $!";
 297 }
 298
 299 # $cache->is_valid($key)
 300 #
 301 # Returns a boolean indicating whether $key exists in the cache
 302 # and has not expired (global per-cache 'expires_in').
 303 sub is_valid {
 304         my ($self, $key) = @_;
 305
 306         my $path = $self->path_to_key($key);
 307
 308         # does file exists in cache?
 309         return 0 unless -f $path;
 310         # get its modification time
 311         my $mtime = (stat(_))[9] # _ to reuse stat structure used in -f test
 312                 or die "Couldn't stat file '$path': $!";
 313
 314         # expire time can be set to never
 315         my $expires_in = $self->get_expires_in();
 316         return 1 unless (defined $expires_in && $expires_in >= 0);
 317
 318         # is file expired?
 319         my $now = time();
 320
 321         return (($now - $mtime) < $expires_in);
 322 }
 323
 324 # Getting and setting
 325
 326 # $cache->set($key, $data);
 327 #
 328 # Associates $data with $key in the cache, overwriting any existing entry.
 329 # Returns $data.
 330 sub set {
 331         my ($self, $key, $data) = @_;
 332
 333         return unless (defined $key && defined $data);
 334
 335         $self->store($key, $data);
 336
 337         return $data;
 338 }
 339
 340 # $data = $cache->get($key);
 341 #
 342 # Returns the data associated with $key.  If $key does not exist
 343 # or has expired, returns undef.
 344 sub get {
 345         my ($self, $key) = @_;
 346
 347         return unless $self->is_valid($key);
 348
 349         return $self->fetch($key);;
 350 }
 351
 352 # $data = $cache->compute($key, $code);
 353 #
 354 # Combines the get and set operations in a single call.  Attempts to
 355 # get $key; if successful, returns the value.  Otherwise, calls $code
 356 # and uses the return value as the new value for $key, which is then
 357 # returned.
 358 sub compute {
 359         my ($self, $key, $code) = @_;
 360
 361         my $data = $self->get($key);
 362         if (!defined $data) {
 363                 $data = $code->();
 364                 $self->set($key, $data);
 365         }
 366
 367         return $data;
 368 }
 369
 370 1;
 371 __END__
 372 # end of package GitwebCache::SimpleFileCache;