package Tie::TSHashMirror;

# Tie::TSHashMirror, a Perl hash tie module to mirror timestamped hashes.
# Copyright (C) 2001 Tom Rathborne
# Copyright (C) 2001 Convoke Communications Corp.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

require 5.005;
use strict;

####### Documentation ########################################################

=head1 NAME

Tie::TSHashMirror - mirror a slower hash via a fast hash, checking timestamps
if the slower hash supplies them.

=head1 SYNOPSIS

my (%tsdir, %cache, %tsmir);

tie %tsdir, 'Tie::TSHashDir', '/path/to/files', '.suffix';
tie %cache, 'Tie::SomeFasterThing', $cache;

tie %tsmir, 'Tie::TSHashMirror', \%tsdir, \%cache, 30;

=head1 DESCRIPTION

Tie::TSHashMirror provides a tied hash interface to a fast cache hash which
mirrors a slower hash. If the slower hash provides _TS_-prefix timestamps, then
Tie::TSHashMirror uses them to tell when to update the mirror.

=head1 AUTHOR

Tom Rathborne <tomr@convoke.com>

=cut

####### Public methods #######################################################

sub TIEHASH {
    my $class = shift;

    my $self = {};
    $self->{'SRC'} = shift || die 'No source hashref supplied';
    $self->{'MIR'} = shift || {};
    $self->{'DEL'} = shift || 0; # delay

    return bless $self, $class;
}

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

    my $mir = $self->{'MIR'};
    my $src = $self->{'SRC'};

    if (exists $mir->{$key}) {

        if (!(exists $src->{$key})) {
            delete $mir->{$key};
            delete $mir->{"_TS_$key"};
        } elsif (exists $mir->{"_TS_$key"}
            and ($mir->{"_TS_$key"} + $self->{'DEL'} < time())
            and ($mir->{"_TS_$key"} < $src->{"_TS_$key"})) {
            $mir->{"_TS_$key"} = $src->{"_TS_$key"};
            $mir->{$key} = $src->{$key};
        }

    } elsif (exists $src->{$key}) {
        $mir->{"_TS_$key"} = $src->{"_TS_$key"}
            if exists $src->{"_TS_$key"};
        $mir->{$key} = $src->{$key};
    }

    return ((exists $mir->{$key}) ? $mir->{$key} : undef);
}

sub STORE {
    my ($self, $key, $value) = @_;

    $self->{'SRC'}{$key} = $value;
    $self->{'MIR'}{$key} = $value;

    $self->{'MIR'}{"_TS_$key"} = $self->{'SRC'}{"_TS_$key"}
        if exists $self->{'SRC'}{"_TS_$key"};
}

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

    delete $self->{'SRC'}{$key};
    delete $self->{'MIR'}{$key};
    delete $self->{'MIR'}{"_TS_$key"};
}

sub CLEAR {
    my $self = shift;

    foreach my $key (keys %{$self->{'SRC'}}) {
        delete $self->{'SRC'}{$key};
        delete $self->{'MIR'}{$key};
        delete $self->{'MIR'}{"_TS_$key"};
    }
}

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

    return exists $self->{'SRC'}{$key};
}

sub FIRSTKEY {
    my $self = shift;

    my $a = keys %{$self->{'SRC'}}; # reset each()
    return each %{$self->{'SRC'}};
}

sub NEXTKEY {
    my ($self, $lastkey) = @_;
    return each %{$self->{'SRC'}};
}

####### Private methods ######################################################

####### End of Code ##########################################################

1; # Return true

####### EOF ##################################################################
