File Coverage

blib/lib/Text/Forge/MemCache.pm

Criterion	Covered	Total	%
statement	27	70	38.5
branch	9	38	23.6
condition	0	2	0.0
subroutine	6	13	46.1
pod	0	8	0.0
total	42	131	32.0

package Text::Forge::MemCache;

# XXX Debuging code is haphazard

# Setting these values in a BEGIN block doesn't work.  The BEGIN
# block is called twice, wiping out any preloaded templates in
# the parent process.
unless (defined $Max_Templates) {
  # Public globals
  $Max_Templates = 0;
  $Min_Templates = 0;
  $Debug         = 0;

  # Private globals
  $Template_Count = 0;
  $Total_Fetches  = 0;
  $Total_Hits     = 0;
  %Cache          = ();
}

use strict;
use vars qw(
             $Max_Templates $Min_Templates $Debug $Template_Count %Cache
             $Total_Fetches $Total_Hits
           );
use Carp;

sub _debug {
  my $self = shift;

  print STDERR "CACHE [$Min_Templates/$Template_Count/$Max_Templates]: ",
               join(' ', @_), "\n";
}

sub _evict {
  my $self = shift;

  my @paths = sort { $Cache{ $b }->{age} <=> $Cache{ $a }->{age} } keys %Cache;

  if ($Debug) {
    foreach(@paths) {
      printf STDERR "%50s %d\n", $_, $Cache{$_}->{age};
    }
  }

  while($Template_Count > $Min_Templates) {
    last unless @paths;
    delete $Cache{ shift @paths };
    $Template_Count--;
  }
}

sub fetch {
  my $self = shift;
  my $path = shift;

  $path or croak 'no path supplied';

  if ($Debug) {
    $self->_debug( $Cache{ $path } ? "cache hit $path" : "cache miss $path" );
  }

  $Total_Fetches++;
  return undef unless exists $Cache{ $path };
  $Total_Hits++;

  if ($Max_Templates) {
    foreach(keys %Cache) { $Cache{ $_ }->{age}++ }
    $Cache{ $path }->{age} = 0;
  }

  $Cache{ $path }->{sub};
}

sub store {
  my $self = shift;
  my($path, $sub) = @_;

  $path or croak 'no path supplied';

  if ($Max_Templates) {
    foreach(keys %Cache) { $Cache{ $_ }->{age}++ }
    $self->_evict if $Template_Count > $Max_Templates;
  }

  $self->_debug("storing $path") if $Debug;

  $Template_Count++ unless exists $Cache{ $path };
  $Cache{ $path }->{sub}   = $sub;
  $Cache{ $path }->{age}   = 0;
}

sub delete {
  my $self = shift;
  my $path = shift;

  $path or croak 'no path supplied';

  return unless exists $Cache{ $path };

  delete $Cache{ $path };
  --$Template_Count;
}

sub delete_all {
  my $self = shift;

  $Template_Count = 0;
  $Total_Fetches  = 0;
  $Total_Hits     = 0;
  %Cache          = ();
}

sub max_templates { (@_ > 1 ? $Max_Templates = $_[1] : $Max_Templates) }
sub min_templates { (@_ > 1 ? $Min_Templates = $_[1] : $Min_Templates) }

sub is_cached { exists $Cache{ $_[1] } }

# Apache::Status plugin

sub modperl_status {
  my($r, $q) = @_;

  my $lru  = ($Max_Templates ? 'Enabled' : 'Disabled');
  my $sort = ($ENV{PATH_INFO} =~ /age/ ? 'age' : 'path');

  my $perf = sprintf '%.2f', ($Total_Hits * 100 / ($Total_Fetches || 1));

  my @s = (<
Configuration

 




133




 





 





 





 





 





 



  




134




 





 





 





 





 





 



   Max Templates$Max_Templates 




135




 





 





 





 





 





 



       




136




 





 





 





 





 





 



   Debug$Debug 




137




 





 





 





 





 





 



  




138




 





 





 





 





 





 



  




139




 





 





 





 





 





 



   Min Templates$Min_Templates 




140




 





 





 





 





 





 



       




141




 





 





 





 





 





 



   LRU Replacement$lru 




142




 





 





 





 





 





 



  




143












Cached Templates (hit rate $perf%)

", ";  




148




 





 





 





 





 





 



 PathAge 




149




 





 





 





 





 





 



 EOF 




150




 





 





 





 





 





 



   ); 




151




 





 





 





 





 





 



   




152




0




  
  0
  




 





 





 





 



   my @keys = sort { 




153




0





 





 





 





 





 



                ( 




154




 





 





 





 





 





 



                  $sort eq 'age' ? $Cache{ $a }->{age} <=> $Cache{ $b }->{age}  




155




 





 





 





 





 





 



                                 : $a cmp $b 




156




 





 





 





 





 





 



                ) 




157




 





 





 





 





 





 



              } keys %Cache; 




158




 





 





 





 





 





 



   




159




0





 





 





 





 





 



   foreach my $path (@keys) { 




160




0





 





 





 





 





 



     push @s, "$path




161




 





 





 





 





 





 



              "$Cache{ $path }->{age}




162




 





 





 





 





 





 



   }  




163




 





 





 





 





 





 



   




164




0





 





 





 





 





 



   push @s, <




165

EOF
  );

  my @keys = sort {
               (
                 $sort eq 'age' ? $Cache{ $a }->{age} <=> $Cache{ $b }->{age}
                                : $a cmp $b
               )
             } keys %Cache;

  foreach my $path (@keys) {
    push @s, "
             "
  }

  push @s, <

EOF

  return \@s;
}

eval {
  if (Apache->module('Apache::Status')) {
    Apache::Status->menu_item(
      'forge-memcache' => 'Text::Forge::MemCache',
      \&modperl_status
    );
  }
};

1;

__END__