view release on metacpan or  search on metacpan

lib/Text/Template/Simple/Cache.pm  view on Meta::CPAN

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;
      }

lib/Text/Template/Simple/Cache.pm  view on Meta::CPAN

   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();
   $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();
   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__

=pod

=encoding UTF-8

=head1 NAME

Text::Template::Simple::Cache

=head1 VERSION

version 0.91

=head1 SYNOPSIS

   TODO

=head1 DESCRIPTION

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

=head1 NAME

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

=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.