File Coverage

blib/lib/Text/Template/Simple/Cache.pm

Criterion	Covered	Total	%
statement	229	274	83.5
branch	70	132	53.0
condition	12	27	44.4
subroutine	28	30	93.3
pod	9	9	100.0
total	348	472	73.7

## no critic (ProhibitUnusedPrivateSubroutines)
package Text::Template::Simple::Cache;
use strict;
use warnings;

use Carp qw( croak );
use Text::Template::Simple::Constants qw(:all);
use Text::Template::Simple::Util      qw( DEBUG LOG ishref fatal );

our $VERSION = '0.86';

my $CACHE = {}; # in-memory template cache

sub new {
   my $class  = shift;
   my $parent = shift || fatal('tts.cache.new.parent');
   my $self   = [undef];
   bless $self, $class;
   $self->[CACHE_PARENT] = $parent;
   return $self;
}

sub id {
   my $self = shift;
   my $val  = shift;
   $self->[CACHE_PARENT][CID] = $val if $val;
   return $self->[CACHE_PARENT][CID];
}

sub type {
   my $self = shift;
   my $parent = $self->[CACHE_PARENT];
   return $parent->[CACHE] ? $parent->[CACHE_DIR] ? 'DISK'
                                                  : 'MEMORY'
                           : 'OFF';
}

sub reset { ## no critic (ProhibitBuiltinHomonyms)
   my $self   = shift;
   my $parent = $self->[CACHE_PARENT];
   %{$CACHE}  = ();

   if ( $parent->[CACHE] && $parent->[CACHE_DIR] ) {

      my $cdir = $parent->[CACHE_DIR];
      require Symbol;
      my $CDIRH = Symbol::gensym();
      opendir $CDIRH, $cdir or fatal( 'tts.cache.opendir' => $cdir, $! );
      require File::Spec;
      my $ext = quotemeta CACHE_EXT;
      my $file;

      while ( defined( $file = readdir $CDIRH ) ) {
         if ( $file =~ m{ ( .* $ext) \z}xmsi ) {
            $file = File::Spec->catfile( $parent->[CACHE_DIR], $1 );
            LOG( UNLINK => $file ) if DEBUG;
            unlink $file;
         }
      }

      closedir $CDIRH;
   }
   return 1;
}

sub dumper {
   my $self  = shift;
   my $type  = shift || 'structure';
   my $param = shift || {};
   fatal('tts.cache.dumper.hash')        if not ishref $param;
   my %valid = map { ($_, $_) } qw( ids structure );
   fatal('tts.cache.dumper.type', $type) if not $valid{ $type };
   my $method = '_dump_' . $type;
   return $self->$method( $param ); # TODO: modify the methods to accept HASH
}

sub _dump_ids {
   my $self   = shift;
   my $parent = $self->[CACHE_PARENT];
   my $p      = shift;
   my $VAR    = $p->{varname} || q{$} . q{CACHE_IDS};
   my @rv;

   if ( $parent->[CACHE_DIR] ) {

      require File::Find;
      require File::Spec;
      my $ext = quotemeta CACHE_EXT;
      my $re  = qr{ (.+?) $ext \z }xms;
      my($id, @list);

      File::Find::find(
         {
            no_chdir => 1,
            wanted   => sub {
                           if ( $_ =~ $re ) {
                              ($id = $1) =~ s{.*[\\/]}{}xms;
                              push @list, $id;
                           }
                        },
         },
         $parent->[CACHE_DIR]
      );

      @rv = sort @list;

   }
   else {
      @rv = sort keys %{ $CACHE };
   }

   require Data::Dumper;
   my $d = Data::Dumper->new( [ \@rv ], [ $VAR ]);
   return $d->Dump;
}

sub _dump_structure {
   my $self    = shift;
   my $parent  = $self->[CACHE_PARENT];
   my $p       = shift;
   my $VAR     = $p->{varname} || q{$} . q{CACHE};
   my $deparse = $p->{no_deparse} ? 0 : 1;
   require Data::Dumper;
   my $d;

   if ( $parent->[CACHE_DIR] ) {
      $d = Data::Dumper->new( [ $self->_dump_disk_cache ], [ $VAR ] );
   }
   else {
      $d = Data::Dumper->new( [ $CACHE ], [ $VAR ]);
      if ( $deparse ) {
         fatal('tts.cache.dumper' => $Data::Dumper::VERSION)
            if !$d->can('Deparse');
         $d->Deparse(1);
      }
   }

   my $str = eval { $d->Dump; };

   if ( my $error = $@ ) {
      if ( $deparse && $error =~ RE_DUMP_ERROR ) {
         my $name = ref($self) . '::dump_cache';
         warn "$name: An error occurred when dumping with deparse "
             ."(are you under mod_perl?). Re-Dumping without deparse...\n";
         warn "$error\n";
         my $nd = Data::Dumper->new( [ $CACHE ], [ $VAR ]);
         $nd->Deparse(0);
         $str = $nd->Dump;
      }
      else {
         croak $error;
      }
   }

   return $str;
}

sub _dump_disk_cache {
   require File::Find;
   require File::Spec;
   my $self    = shift;
   my $parent  = $self->[CACHE_PARENT];
   my $pattern = quotemeta DISK_CACHE_MARKER;
   my $ext     = quotemeta CACHE_EXT;
   my $re      = qr{(.+?) $ext \z}xms;
   my(%disk_cache);

   my $process = sub {
      my $file  = $_;
      my @match = $file =~ $re;
      return if ! @match;
      (my $id = $match[0]) =~ s{.*[\\/]}{}xms;
      my $content = $parent->io->slurp( File::Spec->canonpath($file) );
      my $ok      = 0;  # reset
      my $_temp   = EMPTY_STRING; # reset

      foreach my $line ( split m{\n}xms, $content ) {
         if ( $line =~ m{$pattern}xmso ) {
            $ok = 1;
            next;
         }
         next if not $ok;
         $_temp .= $line;
      }

      $disk_cache{ $id } = {
         MTIME => (stat $file)[STAT_MTIME],
         CODE  => $_temp,
      };
   };

   File::Find::find(
      {
         no_chdir => 1,
         wanted   => $process,
      },
      $parent->[CACHE_DIR]
   );
   return \%disk_cache;
}

sub size {
   my $self   = shift;
   my $parent = $self->[CACHE_PARENT];

   return 0 if not $parent->[CACHE]; # calculate only if cache is enabled

   if ( my $cdir = $parent->[CACHE_DIR] ) { # disk cache
      require File::Find;
      my $total  = 0;
      my $ext    = quotemeta CACHE_EXT;

      my $wanted = sub {
         return if $_ !~ m{ $ext \z }xms; # only calculate "our" files
         $total += (stat $_)[STAT_SIZE];
      };

      File::Find::find( { wanted => $wanted, no_chdir => 1 }, $cdir );
      return $total;

   }
   else { # in-memory cache

      local $SIG{__DIE__};
      if ( eval { require Devel::Size; 1; } ) {
         my $dsv = Devel::Size->VERSION;
         LOG( DEBUG => "Devel::Size v$dsv is loaded." ) if DEBUG;
         fatal('tts.cache.develsize.buggy', $dsv) if $dsv < DEVEL_SIZE_VERSION;
         my $size = eval { Devel::Size::total_size( $CACHE ) };
         fatal('tts.cache.develsize.total', $@) if $@;
         return $size;
      }
      else {
         warn "Failed to load Devel::Size: $@\n";
         return 0;
      }

   }
}

sub has {
   my($self, @args ) = @_;
   fatal('tts.cache.pformat') if @args % 2;
   my %opt    = @args;
   my $parent = $self->[CACHE_PARENT];

   if ( not $parent->[CACHE] ) {
      LOG( DEBUG => 'Cache is disabled!') if DEBUG;
      return;
   }


   my $id  = $parent->connector('Cache::ID')->new;
   my $cid = $opt{id}   ? $id->generate($opt{id}  , 'custom')
           : $opt{data} ? $id->generate($opt{data}          )
           :              fatal('tts.cache.incache');

   if ( my $cdir = $parent->[CACHE_DIR] ) {
      require File::Spec;
      return -e File::Spec->catfile( $cdir, $cid . CACHE_EXT ) ? 1 : 0;
   }
   else {
      return exists $CACHE->{ $cid } ? 1 : 0;
   }
}

sub _is_meta_version_old {
   my $self = shift;
   my $v    = shift;
   return 1 if ! $v; # no version? archaic then
   my $pv = PARENT->VERSION;
   foreach my $i ( $v, $pv ) {
      $i  =~ tr/_//d; # underscore versions cause warnings
      $i +=  0;       # force number
   }
   return 1 if $v < $pv;
   return;
}

sub hit {
   # TODO: return $CODE, $META;
   my $self     = shift;
   my $cache_id = shift;
   my $chkmt    = shift || 0;

   my $method = $self->[CACHE_PARENT][CACHE_DIR] ? '_hit_disk' : '_hit_memory';
   return $self->$method( $cache_id, $chkmt );
}

sub _hit_memory {
   my($self, $cache_id, $chkmt) = @_;
   if ( $chkmt ) {
      my $mtime = $CACHE->{$cache_id}{MTIME} || 0;
      if ( $mtime != $chkmt ) {
         LOG( MTIME_DIFF => "\tOLD: $mtime\n\t\tNEW: $chkmt" ) if DEBUG;
         return; # i.e.: Update cache
      }
   }
   LOG( MEM_CACHE => EMPTY_STRING ) if DEBUG;
   return $CACHE->{$cache_id}->{CODE};
}

sub _hit_disk {
   my($self, $cache_id, $chkmt) = @_;
   my $parent = $self->[CACHE_PARENT];
   my $cdir   = $parent->[CACHE_DIR];
   require File::Spec;
   my $cache = File::Spec->catfile( $cdir, $cache_id . CACHE_EXT );
   my $ok    = -e $cache && ! -d _ && -f _;
   return if not $ok;

   my $disk_cache = $parent->io->slurp($cache);
   my %meta;
   if ( $disk_cache =~ m{ \A \#META: (.+?) \n }xms ) {
      %meta = $self->_get_meta( $1 );
      fatal('tts.cache.hit.meta', $@) if $@;
   }
   if ( $self->_is_meta_version_old( $meta{VERSION} ) ) {
      my $id = $parent->[FILENAME] || $cache_id;
      warn "(This messeage will only appear once) $id was compiled with"
          .' an old version of ' . PARENT . ". Resetting cache.\n";
      return;
   }
   if ( my $mtime = $meta{CHKMT} ) {
      if ( $mtime != $chkmt ) {
         LOG( MTIME_DIFF => "\tOLD: $mtime\n\t\tNEW: $chkmt") if DEBUG;
         return; # i.e.: Update cache
      }
   }

   my($CODE, $error) = $parent->_wrap_compile($disk_cache);
   $parent->[NEEDS_OBJECT] = $meta{NEEDS_OBJECT} if $meta{NEEDS_OBJECT};
   $parent->[FAKER_SELF]   = $meta{FAKER_SELF}   if $meta{FAKER_SELF};

   fatal('tts.cache.hit.cache', $error) if $error;
   LOG( FILE_CACHE => EMPTY_STRING )    if DEBUG;
   #$parent->[COUNTER]++;
   return $CODE;
}

sub populate {
   my($self, $cache_id, $parsed, $chkmt) = @_;
   my $parent = $self->[CACHE_PARENT];
   my $target = ! $parent->[CACHE]     ? '_populate_no_cache'
              :   $parent->[CACHE_DIR] ? '_populate_disk'
              :                          '_populate_memory'
              ;

   my($CODE, $error) = $self->$target( $parsed, $cache_id, $chkmt );
   $self->_populate_error( $parsed, $cache_id, $error ) if $error;
   ++$parent->[COUNTER];
   return $CODE;
}

sub _populate_error {
   my($self, $parsed, $cache_id, $error) = @_;
   my $parent   = $self->[CACHE_PARENT];
   croak $parent->[VERBOSE_ERRORS]
         ?  $parent->_mini_compiler(
               $parent->_internal('compile_error'),
               {
                  CID    => $cache_id ? $cache_id : 'N/A',
                  ERROR  => $error,
                  PARSED => $parsed,
                  TIDIED => $parent->_tidy( $parsed ),
               }
            )
         : $error
         ;
}

sub _populate_no_cache {
   # cache is disabled
   my($self, $parsed, $cache_id, $chkmt) = @_;
   my($CODE, $error) = $self->[CACHE_PARENT]->_wrap_compile($parsed);
   LOG( NC_POPUL => $cache_id ) if DEBUG >= DEBUG_LEVEL_INSANE;
   return $CODE, $error;
}

sub _populate_memory {
   my($self, $parsed, $cache_id, $chkmt) = @_;
   my $parent = $self->[CACHE_PARENT];
   my $c = $CACHE->{ $cache_id } = {}; # init
   my($CODE, $error)  = $parent->_wrap_compile($parsed);
   $c->{CODE}         = $CODE;
   $c->{MTIME}        = $chkmt if $chkmt;
   $c->{NEEDS_OBJECT} = $parent->[NEEDS_OBJECT];
   $c->{FAKER_SELF}   = $parent->[FAKER_SELF];
   LOG( MEM_POPUL => $cache_id ) if DEBUG >= DEBUG_LEVEL_INSANE;
   return $CODE, $error;
}

sub _populate_disk {
   my($self, $parsed, $cache_id, $chkmt) = @_;

   require File::Spec;
   require Fcntl;
   require IO::File;

   my $parent = $self->[CACHE_PARENT];
   my %meta   = (
      CHKMT        => $chkmt,
      NEEDS_OBJECT => $parent->[NEEDS_OBJECT],
      FAKER_SELF   => $parent->[FAKER_SELF],
      VERSION      => PARENT->VERSION,
   );

   my $cache = File::Spec->catfile( $parent->[CACHE_DIR], $cache_id . CACHE_EXT);
   my $fh    = IO::File->new;
   $fh->open($cache, '>') or fatal('tts.cache.populate.write', $cache, $!);
   flock $fh, Fcntl::LOCK_EX() if IS_FLOCK;
   $parent->io->layer($fh);
   my $warn =  $parent->_mini_compiler(
                  $parent->_internal('disk_cache_comment'),
                  {
                     NAME => PARENT->class_id,
                     DATE => scalar localtime time,
                  }
               );
   my $ok = print { $fh } '#META:' . $self->_set_meta(\%meta) . "\n",
                          $warn,
                          $parsed;
   flock $fh, Fcntl::LOCK_UN() if IS_FLOCK;
   close $fh or croak "Unable to close filehandle: $!";
   chmod(CACHE_FMODE, $cache) || fatal('tts.cache.populate.chmod');

   my($CODE, $error) = $parent->_wrap_compile($parsed);
   LOG( DISK_POPUL => $cache_id ) if DEBUG >= DEBUG_LEVEL_INSANE;
   return $CODE, $error;
}

sub _get_meta {
   my $self = shift;
   my $raw  = shift;
   my %meta = map { split m{:}xms, $_ } split m{[|]}xms, $raw;
   return %meta;
}

sub _set_meta {
   my $self = shift;
   my $meta = shift;
   my $rv   = join q{|}, map { $_ . q{:} . $meta->{ $_ } } keys %{ $meta };
   return $rv;
}

sub DESTROY {
   my $self = shift;
   LOG( DESTROY => ref $self ) if DEBUG;
   $self->[CACHE_PARENT] = undef;
   @{$self} = ();
   return;
}

1;

__END__

=head1 NAME

Text::Template::Simple::Cache - Cache manager

=head1 SYNOPSIS

TODO

=head1 DESCRIPTION

This document describes version C<0.86> of C<Text::Template::Simple::Cache>
released on C<5 March 2012>.

Cache manager for C<Text::Template::Simple>.

=head1 METHODS

=head2 new PARENT_OBJECT

Constructor. Accepts a C<Text::Template::Simple> object as the parameter.

=head2 type

Returns the type of the cache.

=head2 reset

Resets the in-memory cache and deletes all cache files,
if you are using a disk cache.

=head2 dumper TYPE

   $template->cache->dumper( $type, \%opt );

C<TYPE> can either be C<structure> or C<ids>.
C<dumper> accepts some arguments as a hashref:

   $template->cache->dumper( $type, \%opt );

=over 4

=item *

varname

Controls the name of the dumped structure.

=item *

no_deparse

If you set this to a true value, deparsing will be disabled

=back

=head3 structure

Returns a string version of the dumped in-memory or disk-cache.
Cache is dumped via L<Data::Dumper>. C<Deparse> option is enabled
for in-memory cache.

Early versions of C<Data::Dumper> don' t have a C<Deparse>
method, so you may need to upgrade your C<Data::Dumper> or
disable deparse-ing if you want to use this method.

=head3 ids

Returns a list including the names (ids) of the templates in
the cache.

=head2 id

Gets/sets the cache id.

=head2 size

Returns the total cache (disk or memory) size in bytes. If
memory cache is used, then you must have L<Devel::Size> installed
on your system to get the size of the data structure inside memory.

=head2 has data => TEMPLATE_DATA

=head2 has id   => TEMPLATE_ID

This method can be called with C<data> or C<id> named parameter. If you
use the two together, C<id> will be used:

   if ( $template->cache->has( id => 'e369853df766fa44e1ed0ff613f563bd' ) ) {
      print "ok!";
   }

or

   if ( $template->cache->has( data => q~Foo is <%=$bar%>~ ) ) {
      print "ok!";
   }

=head2 hit

TODO

=head2 populate

TODO

=head1 AUTHOR

Burak Gursoy <[e-mail]>.

=head1 COPYRIGHT

Copyright 2004 - 2012 Burak Gursoy. All rights reserved.

=head1 LICENSE

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.3 or,
at your option, any later version of Perl 5 you may have available.

=cut