discourse-legacysite-perl/site/slowtwitch.com/cgi-bin/articles/GT/Cache.pm

# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   GT::Cache
#   Author  : Scott Beck 
#   CVS Info : 087,071,086,086,085      
#   $Id: Cache.pm,v 1.13 2004/01/13 01:35:15 jagerman Exp $
# 
# Copyright (c) 2004 Gossamer Threads Inc.  All Rights Reserved.
# ==================================================================
#
# Description:
#   Implements a tied hash cache that will not grow forever, but expire
#   old/unused entries. Useful under mod_perl.
#

package GT::Cache;
# ===============================================================
    use vars qw /$DEBUG $VERSION $CACHE_SIZE/;
    use strict;

    $DEBUG      = 0;
    $VERSION    = sprintf "%d.%03d", q$Revision: 1.13 $ =~ /(\d+)\.(\d+)/;
    $CACHE_SIZE = 500;

##
# tie %cache, 'GT::Cache', $size, \&function;
# ----------------------------
#   Is called when you tie a hash to this
#   class. The size should be the size limit
#   you want on your hash. If not specified
#   this will default to the CLASS variable
#   $CACH_SIZE which is initialized to 500
##
sub TIEHASH {
    my $this = shift;
    my $size = shift || $CACHE_SIZE;
    my $code = shift || sub {undef};
    my $class = ref $this || $this;
    my $self = bless { 
            cache_size => $size,
            popularity => [],
            content    => {},
            indices    => {},
            is_indexed => 0,
            size       => 0,
            code       => $code,
        }, $class;
    $#{$self->{popularity}} = $size;
    return $self;
}

sub FETCH {
    my ($self, $key) = @_;
    if (ref $key) {
        require GT::Dumper;
        my $dmp = new GT::Dumper (
            {
                data => $key,
                sort => 1
            }
        );
        my $new = $dmp->dump;
        $key = $new;
    }
    unless (exists $self->{content}->{$key}) {
        my $val = $self->{code}->($key);
        defined $val or return undef;
        $self->STORE ($key, $val);
        return $val;
    }
    if ($self->{is_indexed}) {
        my ($pos1, $pos2, $replace);

        $pos1 = $self->{content}->{$key}->[1];
        $pos2 = $pos1 + (int (rand( ($self->{cache_size} - $pos1) / 2) )) || 1;

        $replace = ${$self->{popularity}}[$pos2];
    
        ${$self->{popularity}}[$pos2]     = $key;
        $self->{content}->{$key}->[1]     = $pos2;
        if (defined $replace) {
            ${$self->{popularity}}[$pos1]     = $replace;
            $self->{content}->{$replace}->[1] = $pos1;
        }
    }
    return $self->{content}->{$key}->[0];
}

##
# %cash = (key1 => $field1, key2 => $val2);
# -----------------------------------------
# $cash{key} = $val;
# ------------------
#   Called when you store something in the hash.
#   This will check the number of elements in the
#   hash and delete the oldest one if the limit.
#   is reached.
##
sub STORE {
    my ($self, $key, $value) = @_;
    if (ref $key) {
        require GT::Dumper;
        my $dmp = new GT::Dumper (
            {
                data => $key,
                sort => 1
            }
        );
        my $new = $dmp->dump;
        $key = $new;
    }
    my ($replace, $insid);
    if ($self->{is_indexed}) {
        $insid = int (rand($self->{cache_size} / 2)) || 1;
        if (defined ($replace = ${$self->{popularity}}[$insid])) {
            delete $self->{content}->{$replace};
            undef ${$self->{popularity}}[$insid];
        }
        ${$self->{popularity}}[$insid] = $key;
        $self->{content}->{$key} = [$value, $insid];
    }
    else {
        ${$self->{popularity}}[$self->{size}] = $key;
        $self->{content}->{$key} = [$value, $self->{size}];
        if ($self->{size} == $self->{cache_size}) {
            for (0 .. $#{$self->{popularity}}) {
                next unless defined $self->{popularity}[$_];
                $self->{content}{$self->{popularity}[$_]}[1] = $_;
            }
            $self->{is_indexed} = 1;
        }
        $self->{size}++;
    }
}

sub DELETE {
    my ($self, $key) = @_;
    if (ref $key) {
        require GT::Dumper;
        my $dmp = new GT::Dumper (
            {
                data => $key,
                sort => 1
            }
        );
        my $new = $dmp->dump;
        $key = $new;
    }
    exists $self->{content}->{$key} or return undef;
    $self->{size}--;
    my $aref = delete $self->{content}->{$key};
    undef $self->{popularity}->[$aref->[1]];
    return $aref->[0];
}

sub CLEAR {
    my $self = shift;
    $self->{content}    = {};
    $self->{size}       = 0;
    $self->{popularity} = [];
    $self->{is_indexed} = 0;
}

sub EXISTS {
    my ($self, $key) = @_;
    if (ref $key) {
        require GT::Dumper;
        my $dmp = new GT::Dumper (
            {
                data => $key,
                sort => 1
            }
        );
        my $new = $dmp->dump;
        $key = $new;
    }
    return exists $self->{content}->{$key} ? 1 : 0;
}

sub FIRSTKEY {
    my $self = shift;
    my $c = keys %{$self->{content}};
    return scalar each %{$self->{content}};
}

sub NEXTKEY {return scalar each %{shift()->{content}}}

1;

__END__

=head1 NAME

GT::Cache - Tied hash which caches output of functions.

=head1 SYNOPSIS

    use GT::Cache;
    my %cache;
    tie %cache, 'GT::Cache', $size, \&function;

=head1 DESCRIPTION

GT::Cache implements a simple but quick caching scheme for remembering
the results of functions. It also implements a max size to prevent 
the cache from growing and drops least frequently requested entries
first, making it very useful under mod_perl.

=head1 EXAMPLE

    use GT::Cache;
    my %cache;
    tie %cache, 'GT::Cache', 100, \&complex_func;
    
    while (<>) {
        print "RESULT: ", $cache{$_}, "\n";
    }

    sub complex_func {
        my $input = shift;
        # .. do complex work.
        return $output;
    }

This will cache the results of complex_func, and only run it when
the input is different. It stores a max of 100 entries at a time,
with the least frequently requested getting dropped first.

=head1 NOTES

Currently, you can only pass as input to the function a single
scalar, and the output must be a single scalar. See the
Memoize module in CPAN for a much more robust implementation.

=head1 COPYRIGHT

Copyright (c) 2004 Gossamer Threads Inc.  All Rights Reserved.
http://www.gossamer-threads.com/

=head1 VERSION

Revision: $Id: Cache.pm,v 1.13 2004/01/13 01:35:15 jagerman Exp $

=cut