[Templates-cvs] cvs commit: TT3/lib/Template Cache.pm
cvs@template-toolkit.org
cvs@template-toolkit.org
Wed, 24 Mar 2004 12:25:20 +0000
cvs 04/03/24 12:25:20
Added: lib/Template Cache.pm
Log:
* added Template::Cache module
Revision Changes Path
1.1 TT3/lib/Template/Cache.pm
Index: Cache.pm
===================================================================
#========================================================================
#
# Template::Cache
#
# DESCRIPTION
# This module implements a base class cache object. A cache is used to
# provide in-memory transient storage of templates compiled into Perl
# objects.
#
# AUTHOR
# Andy Wardley <abw@wardley.org>
#
# COPYRIGHT
# Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved.
# Copyright (C) 1998-2002 Canon Research Centre Europe Ltd.
# Copyright (C) 2002-2004 Fotango Ltd.
#
# This module is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# REVISION
# $Id: Cache.pm,v 1.1 2004/03/24 12:25:19 abw Exp $
#
#========================================================================
package Template::Cache;
use strict;
use warnings;
use Template::Base;
use base qw( Template::Base );
use vars qw( $VERSION $DEBUG $ERROR $THROW );
$VERSION = sprintf("%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/);
$DEBUG = 0 unless defined $DEBUG;
$ERROR = '';
$THROW = 'cache'; # we currently don't raise any errors, but
# would throw them as exceptions if we did
use constant PREV => 0;
use constant NAME => 1;
use constant DATA => 2;
use constant NEXT => 3;
sub init {
my ($self, $config) = @_;
$self->{ slot } = { }; # slot lookup by name
$self->{ used } = 0; # slots used
$self->{ size } = $config->{ size }; # max slots
$self->{ time } = $config->{ time }; # max time
return $self;
}
sub set {
my ($self, $name, $data) = @_;
my $size = $self->{ size };
my ($head, $slot);
if (defined $size) {
# if a size limit has been defined then we must make sure we
# haven't exceeded it
if ($slot = $self->{ slot }->{ $name }) {
# reuse the existing slot for the name provided
$self->debug("recycling existing cache slot for '$name'\n")
if $self->{ DEBUG };
$self->_remove_slot($slot);
$slot->[ DATA ] = $data;
}
elsif ($self->{ used } >= $size) {
# all slots filled so recycle the least recently used
$self->debug("recycling oldest cache slot '$self->{tail}->[NAME]' for '$name'\n")
if $self->{ DEBUG };
# remove the last slot (least recently used)
$slot = $self->_remove_slot($self->{ tail });
# change link from name to slot
delete $self->{ slot }->{ $slot->[ NAME ] };
$self->{ slot }->{ $name } = $slot;
$slot->[ NAME ] = $name;
$slot->[ DATA ] = $data;
}
else {
# we've got slots left to fill
$self->debug("adding new cache slot for '$name'\n")
if $self->{ DEBUG };
# create a new slot
$slot = [ undef, $name, $data, undef ];
$self->{ slot }->{ $name } = $slot;
$self->{ used }++;
}
# add slot to head of list to indicate most recently used
$self->_head_slot($slot);
}
else {
$self->debug("adding data to cache for '$name'\n")
if $self->{ DEBUG };
# no size defined so cache everything directly in slot hash
$self->{ slot }->{ $name } = $data;
}
return 1;
}
sub get {
my ($self, $name) = @_;
# first lookup item in slot table
my $slot = $self->{ slot }->{ $name };
my $data;
return $self->decline("not found in cache: $name")
unless defined $slot;
if (defined $self->{ size }) {
# if the cache is size limited then we need to move the slot up
# to the head of list to indicate that it has been used most
# recently - of course we only need to do this if it's not already
# at the head of the list
unless( $self->{ head } == $slot ) {
$self->_remove_slot($slot);
$self->_head_slot($slot);
}
# fetch data from relevent item in slot
$data = $slot->[ DATA ];
}
else {
# no size defined so $slot is direct reference to data
$data = $slot;
}
return $data;
}
sub _remove_slot {
my ($self, $slot) = @_;
my $prev;
# fix link from previous slot forward to this slot
if ($prev = $slot->[ PREV ]) {
$prev->[ NEXT ] = $slot->[ NEXT ];
$slot->[ PREV ] = undef;
}
else {
$self->{ head } = $slot->[ NEXT ];
}
# fix link from next slot backward to this slot
if ($slot->[ NEXT ]) {
$slot->[ NEXT ]->[ PREV ] = $prev;
$slot->[ NEXT ] = undef;
}
else {
$self->{ tail } = $prev;
}
return $slot;
}
sub _head_slot {
my $self = shift;
return $self->{ head } unless @_;
my $slot = shift;
my $head = $self->{ head };
# add at head of list
$head->[ PREV ] = $slot if $head;
$slot->[ NEXT ] = $head;
$slot->[ PREV ] = undef;
$self->{ head } = $slot;
$self->{ tail } = $slot unless $self->{ tail };
return $slot;
}
sub _slot_report {
my $self = shift;
my $output = '';
my $slot = $self->{ head };
while ($slot) {
my ($prev, $name, $data, $next) = @$slot;
my $prevname = $prev ? $prev->[NAME] : '<NULL>';
my $nextname = $next ? $next->[NAME] : '<NULL>';
$output .= "$prevname <-- [$name] --> ${nextname}\n";
$slot = $next;
}
$output .= "tail: $self->{ tail }->[NAME]\n";
return $output;
}
#------------------------------------------------------------------------
# DESTROY
#
# The cache slots are implemented as a doubly linked list which Perl
# cannot free by itself due to the circular references between NEXT <=>
# PREV items. This cleanup method walks the list deleting all the NEXT/PREV
# references, allowing the proper cleanup to occur and memory to be
# repooled.
#------------------------------------------------------------------------
sub DESTROY {
my $self = shift;
my ($slot, $next);
$self->debug("clearing cache slots\n") if $self->{ DEBUG };
$slot = $self->{ head };
while ($slot) {
$next = $slot->[ NEXT ];
undef $slot->[ PREV ];
undef $slot->[ NEXT ];
$slot = $next;
}
undef $self->{ head };
undef $self->{ tail };
}
1;
__END__
=head1 NAME
Template::Cache - TODO
=head1 SYNOPSIS
TODO
=head1 DESCRIPTION
TODO
=head1 METHODS
TODO
=head1 AUTHOR
Andy Wardley E<lt>abw@wardley.orgE<gt>
=head1 VERSION
$Revision: 1.1 $
=head1 COPYRIGHT
Copyright (C) 1996-2004 Andy Wardley. All Rights Reserved.
Copyright (C) 1998-2002 Canon Research Centre Europe Ltd.
Copyright (C) 2002-2004 Fotango Ltd.
This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut
# Local Variables:
# mode: perl
# perl-indent-level: 4
# indent-tabs-mode: nil
# End:
#
# vim: expandtab shiftwidth=4: