XAO::DO::Cache::Memory - memory storage back-end for XAO::Cache

XAO-Base documentation Contained in the XAO-Base distribution.

Index

Code Index:

NAME

Top

XAO::DO::Cache::Memory - memory storage back-end for XAO::Cache

SYNOPSIS

Top

You should not use this object directly, it is a back-end for XAO::Cache.

 if($backend->exists(\@c)) {
     return $backend->get(\@c);
 }

DESCRIPTION

Top

Cache::Memory is the default implementation of XAO::Cache back-end. It stores data in memory.

METHODS

Top

calculate_size ($)

Calculates size in bytes of the given reference.

drop (@)

Drops an element from the cache.

exists (@)

Checks if an element exists in the cache. Does not update its access time, but checks it. If the element should be expired it removes it from the cache and returns false.

get (\@)

Retrieves an element from the cache. Does not check if it is expired or not, that is done in exists() method and does not update access time.

make_key (\@)

Makes a key from the given list of coordinates.

put (\@\$)

Add a new element to the cache; before adding it checks cache size and throws out elements to make space for the new element. Order of removal depends on when an element was accessed last.

setup (%)

Sets expiration time and maximum cache size.

PRIVATE METHODS

Top

###############################################################################

drop_oldest ($)

Drops oldest element from the cache using supplied key and element.

Prints cache as a chain from the most recent to the least recent. The order is most_recent->next->...->next->least_recent.

touch ($)

Private method that updates access time and moves an element to the most recent position.

AUTHORS

Top

Copyright (c) 2002 XAO Inc.

Andrew Maltsev <am@xao.com>.

SEE ALSO

Top

Have a look at: XAO::DO::Cache::Memory, XAO::Objects, XAO::Base, XAO::FS, XAO::Web.

XAO-Base documentation Contained in the XAO-Base distribution. 
###############################################################################
package XAO::DO::Cache::Memory;
use strict;
use XAO::Utils;
use XAO::Objects;

use base XAO::Objects->load(objname => 'Atom');

use vars qw($VERSION);
$VERSION=(0+sprintf('%u.%03u',(q$Id: Memory.pm,v 2.1 2005/01/13 22:34:34 am Exp $ =~ /\s(\d+)\.(\d+)\s/))) || die "Bad VERSION";

###############################################################################


sub calculate_size ($$) {
    my $self=shift;
    my $d=shift;
    my $r=ref($d);
    my $sz=0;
    while($r eq 'REF') {
        $d=$$d;
        $r=ref($d);
        $sz+=4;
    }
    if($r eq 'ARRAY') {
        foreach my $dd (@$d) {
            $sz+=$self->calculate_size($dd);
        }
    }
    elsif($r eq 'HASH') {
        foreach my $dk (keys %$d) {
            # very rough estimate
            $sz+=length($dk) + $self->calculate_size($d->{$dk});
        }
    }
    elsif($r eq 'SCALAR') {
        $sz=length($$d) + 4;
    }
    elsif($r eq '') {
        $sz=length($d) + 4;
    }
    else {
        $sz+=200;
    }
    return $sz;
}

###############################################################################


sub drop ($@) {
    my $self=shift;

    my $key=$self->make_key($_[0]);
    my $data=$self->{data};
    my $ed=$data->{$key};

    return unless $ed;

    if($ed->{next}) {
        $data->{$ed->{next}}->{previous}=$ed->{previous};
    }
    else {
        $self->{least_recent}=$ed->{previous};
    }

    if($ed->{previous}) {
        $data->{$ed->{previous}}->{next}=$ed->{next};
    }
    else {
        $self->{most_recent}=$ed->{next};
    }

    delete $data->{$key};
}

###############################################################################


sub exists ($$) {
    my $self=shift;

    my $key=$self->make_key($_[0]);
    my $ed=$self->{data}->{$key};

    return $ed && $ed->{access_time} + $self->{expire} > time;
}

###############################################################################


sub get ($$) {
    my $self=shift;

    my $key=$self->make_key($_[0]);
    my $ed=$self->{data}->{$key} ||
        throw $self "get - no such element in the cache ($key), internal error";

    return $ed->{element};
}

###############################################################################


sub make_key ($$) {
    my $self=shift;
    return join("\001",map { defined($_) ? $_ : '' } @{$_[0]});
}

###############################################################################


sub put ($$$) {
    my $self=shift;
    my $key=$self->make_key(shift);
    my $element=shift;

    my $data=$self->{data};
    my $size=$self->{size};
    my $nsz=$size ? $self->calculate_size($element) : 0;

    my $lr=$self->{least_recent};
    my $expire=$self->{expire};
    my $now=time;
    my $count=5;
    while(defined($lr)) {
        my $lred=$data->{$lr};
        last unless $count--;
        last unless ($size && $self->{current_size}+$nsz>$size) ||
                    $lred->{access_time}+$expire < $now;
        $lr=$self->drop_oldest($lr,$lred);
    }

    $data->{$key}={
        size        => $nsz,
        element     => $element,
        access_time => time,
        previous    => undef,
        next        => $self->{most_recent},
    };

    $data->{$self->{most_recent}}->{previous}=$key
        if defined($self->{most_recent});

    $self->{most_recent}=$key;
    $self->{least_recent}=$key unless defined($self->{least_recent});
    $self->{current_size}+=$nsz;

    undef;
}

###############################################################################


sub setup ($%) {
    my $self=shift;
    my $args=get_args(\@_);

    $self->{data}={};
    $self->{current_size}=0;
    $self->{expire}=$args->{expire} || 60;
    $self->{size}=$args->{size} || 0;
}

###############################################################################


sub drop_oldest ($$$) {
    my ($self,$key,$ed)=@_;

    $self->{most_recent}=undef if defined($self->{most_recent}) &&
                                  $self->{most_recent} eq $key;

    my $previous=$ed->{previous};
    $self->{least_recent}=$previous;

    $self->{current_size}-=$ed->{size};

    my $data=$self->{data};

    $data->{$previous}->{next}=undef if defined($previous);

    delete $data->{$key};

    # $self->print_chain();

    return $previous;
}

###############################################################################


sub print_chain ($) {
    my $self=shift;
    my $data=$self->{data};

    dprint "CHAIN: mr=",$self->{most_recent},
           " lr=",$self->{least_recent},
           " csz=",$self->{current_size},
           " size=",$self->{size},"\n";
    my $id=$self->{most_recent};
    my $c='';
    while(defined($id)) {
        my $ed=$data->{$id};
        $c.="->" if $id ne $self->{most_recent};
        $c.="[$id/$ed->{access_time}/".($ed->{previous}||'')."/".($ed->{next}||'')."]";
        $id=$ed->{next};
    }
    print STDERR "$c\n";
}

###############################################################################


sub touch ($$$) {
    my ($self,$key,$ed)=@_;

    $ed->{access_time}=time;

    my $previous=$ed->{previous};
    if(defined $previous) {
        my $next=$ed->{next};

        my $data=$self->{data};

        my $ped=$data->{$previous};
        $ped->{next}=$next;

        $self->{least_recent}=$previous if $self->{least_recent} eq $key;

        if(defined($next)) {
            my $ned=$data->{$next};
            $ned->{previous}=$previous;
        }

        $ed->{next}=$self->{most_recent};
        $ed->{previous}=undef;

        $self->{most_recent}=$data->{$ed->{next}}->{previous}=$key;
    }

    # $self->print_chain;
}

###############################################################################
1;
__END__