package Tie::Cacher;
# this is the logical package, but first we need some help packages

package Tie::Cacher::Node;
use strict;
use warnings;
use fields qw(next previous key);

package Tie::Cacher;
use strict;
use warnings;

require Tie::Hash;

use base qw(Tie::Hash);
use fields qw(head nodes hit miss cnt max_cnt validate load save debug);
our $VERSION = 0.01;

use Carp;

sub TIEHASH {
    @_ >= 2 || croak "Too few arguments. Usage: tie %foo, 'Tie::Hash', key-val-pairs";
    my $class = shift;
    my __PACKAGE__ $self = [];
    my Tie::Cacher::Node $head = [];
    $self->{"head"} = $head;
    $self->{"hit"} = $self->{"miss"} = $self->{"cnt"} = 0;
    $self->{"nodes"} = {};
    $self->{"debug"} = 0;

    @_ = @{$_[0]} if ref($_[0]);
    @_ % 2 and croak "Odd number of arguments. Usage: tie %foo, 'Tie::Hash', key-val-pairs";
    my $key;
    while (@_) {
        $key = shift;
        if ($key eq "validate") {
            croak "Multiple $key keys in tie %foo, $class" if
                $self->{"validate"};
            $self->{"validate"} = shift;
        } elsif ($key eq "load") {
            croak "Multiple $key keys in tie %foo, $class" if
                $self->{"load"};
            $self->{"load"} = shift;
        } elsif ($key eq "save") {
            croak "Multiple $key keys in tie %foo, $class" if
                $self->{"save"};
            $self->{"save"} = shift;
        } elsif ($key eq "debug") {
            croak "Multiple $key keys in tie %foo, $class" if
                $self->{"debug"};
            $self->{"debug"} = shift;
        } elsif ($key eq "max_cnt" || $key eq "max_count") {
            croak "Multiple $key keys in tie %foo, $class" if
                $self->{"max_cnt"};
            $self->{"max_cnt"} = shift;
            croak "max_cnt must be at least 1 in tie %foo, $class" if
                $self->{"max_cnt"} < 1;
        } elsif ($key eq "head_debug") {
            croak "Multiple $key keys in tie %foo, $class" if
                $head->[0];
            $head->[0] = shift;
        } else {
            croak "Unknown key $key in tie %foo, $class";
        }
    }
    $head->{"next"} = $head;
    $head->{"previous"} = $head;
    return bless $self, $class;
}

sub DESTROY {
    my __PACKAGE__ $self = shift;
    my Tie::Cacher::Node ($head, $prev, $next);

    # Make nodes single connected
    $prev = $head = $self->{"head"};
    $next = $prev->{"next"};
    while ($next != $head) {
        undef($next->{"previous"});
        $prev = $next;
        $next = $prev->{"next"};
    }
    undef($next->{"previous"});
    undef($prev->{"next"});
}

sub STORE {
    my __PACKAGE__ $self = $_[0];
    print STDERR "STORE(@_)\n" if $self->{"debug"};
    my Tie::Cacher::Node ($node, $next, $prev);
    if ($node = $self->{"nodes"}{$_[1]}) {
        # Already exists
        $next = $node->{"next"};
        # Already existed
        $prev = $node->{"previous"};
        $prev->{"next"} = $next;
        $next->{"previous"} = $prev;
    } else {
        if (defined($self->{"max_cnt"}) &&
            $self->{"cnt"} >= $self->{"max_cnt"}) {
            # Drop an old one
            $next = $self->{"head"};
            $node = $next->{"previous"};
            delete $self->{"nodes"}{$node->{"key"}};
            # Already existed
            $prev = $node->{"previous"};
            $prev->{"next"} = $next;
            $next->{"previous"} = $prev;
        } else {
            $self->{"cnt"}++;
        }
        $self->{"nodes"}{$_[1]} = $node = [];
        $node->{"key"} = $_[1];
    }

    $node->[0] = $_[2];

    # Reattach node in front
    $prev = $self->{"head"};
    $next = $prev->{"next"};
    $prev->{"next"} = $node;
    $node->{"next"} = $next;
    $node->{"previous"} = $prev;
    $next->{"previous"} = $node;

    if ($self->{"save"}) {
        $_[2] = \$node->[0];
        goto $self->{"save"};
    }
}

sub FETCH {
    my __PACKAGE__ $self = $_[0];
    print STDERR "FETCH(@_)\n" if $self->{"debug"};
    my Tie::Cacher::Node ($node, $next, $prev);
    if ($node = $self->{"nodes"}{$_[1]}) {
        # Aha, existence is assured
        $self->{"hit"}++;

        # Detach node
        $next = $node->{"next"};
        $prev = $node->{"previous"};
        $prev->{"next"} = $next;
        $next->{"previous"} = $prev;

        # Reattach node in front
        $prev = $self->{"head"};
        $next = $prev->{"next"};
        $prev->{"next"} = $node;
        $node->{"next"} = $next;
        $node->{"previous"} = $prev;
        $next->{"previous"} = $node;

        return $node->[0] unless $self->{"validate"};
        push(@_, $node);
        return $node->[0] if &{$self->{"validate"}};
    } else {
        # Nope, new entry
        $self->{"miss"}++;
        if (defined($self->{"max_cnt"}) &&
            $self->{"cnt"} >= $self->{"max_cnt"}) {
            # Drop an old one
            $next = $self->{"head"};
            $node = $next->{"previous"};
            $prev = $node->{"previous"};
            $prev->{"next"} = $next;
            $next->{"previous"} = $prev;
            delete $self->{"nodes"}{$node->{"key"}};
        } else {
            $self->{"cnt"}++;
            $node = [];
        }
        $self->{"nodes"}{$_[1]} = $node;
        $node->{"key"} = $_[1];

        # Create node in front
        $prev = $self->{"head"};
        $next = $prev->{"next"};
        $prev->{"next"} = $node;
        $node->{"next"} = $next;
        $node->{"previous"} = $prev;
        $next->{"previous"} = $node;
        push(@_, $node);
    }
    if ($self->{"load"}) {
        eval {
            &{$self->{"load"}};
            &{$self->{"save"}} if $self->{"save"};
        };
        return $node->[0] unless $@;
        &DELETE;
        die $@;
    } else {
        # Duh, just avoid the unnecessary work in the first place !
        &DELETE;
        return;
    }
}

sub FIRSTKEY {
    my __PACKAGE__ $self = shift;
    print STDERR "FIRSTKEY($self)\n" if $self->{"debug"};
    keys %{$self->{"nodes"}};
    return each %{$self->{"nodes"}} unless wantarray;
    my @work = each %{$self->{"nodes"}} or return;
    return ($work[0], $work[1][0]);
}

sub NEXTKEY {
    my __PACKAGE__ $self = shift;
    print STDERR "NEXTKEY($self, @_)\n" if $self->{"debug"};
    return each %{$self->{"nodes"}} unless wantarray;
    my @work = each %{$self->{"nodes"}} or return;
    return ($work[0], $work[1][0]);
}

sub EXISTS {
    my __PACKAGE__ $self = shift;
    print STDERR "EXISTS($self, @_)\n" if $self->{"debug"};
    return exists $self->{"nodes"}{$_[0]};
}

sub DELETE {
    my __PACKAGE__ $self = shift;
    print STDERR "DELETE($self, @_)\n" if $self->{"debug"};
    my Tie::Cacher::Node ($node, $next, $prev);
    return unless $node = delete $self->{"nodes"}{$_[0]};
    $self->{"cnt"}--;

    # Detach node
    $next = $node->{"next"};
    $prev = $node->{"previous"};
    $prev->{"next"} = $next;
    $next->{"previous"} = $prev;

    return $node->[0] if defined(wantarray);
}

sub CLEAR {
    my __PACKAGE__ $self = shift;
    print STDERR "CLEAR($self)\n" if $self->{"debug"};
    $self->{"cnt"} = 0;

    my Tie::Cacher::Node ($head, $prev, $next);
    # Make nodes single connected
    $prev = $head = $self->{"head"};
    $next = $prev->{"next"};
    while ($next != $head) {
        undef($next->{"previous"});
        $prev = $next;
        $next = $prev->{"next"};
    }
    $head->{"next"} = $head;
    $head->{"previous"} = $head;

    # Order carefully chosen so this last line triggers the node cleanup
    $self->{"nodes"} = {};
}

sub recent_keys {
    my __PACKAGE__ $self = shift;
    my @keys;
    my Tie::Cacher::Node $head = $self->{"head"};
    for (my Tie::Cacher::Node $here = $head->{"next"}; $here != $head; $here = $here->{"next"}) {
        push(@keys, $here->{"key"});
    }
    return @keys;
}

sub old_keys {
    my __PACKAGE__ $self = shift;
    my @keys;
    my Tie::Cacher::Node $head = $self->{"head"};
    for (my Tie::Cacher::Node $here = $head->{"previous"}; $here != $head; $here = $here->{"previous"}) {
        push(@keys, $here->{"key"});
    }
    return @keys;
}

sub recent_key {
    my __PACKAGE__ $self = shift;
    my Tie::Cacher::Node $head = $self->{"head"};
    my Tie::Cacher::Node $here = $head->{"next"};
    return if $here == $head;
    return $here->{"key"};
}

sub old_key {
    my __PACKAGE__ $self = shift;
    my Tie::Cacher::Node $head = $self->{"head"};
    my Tie::Cacher::Node $here = $head->{"previous"};
    return if $here == $head;
    return $here->{"key"};
}

sub count {
    my __PACKAGE__ $self = shift;
    return $self->{"cnt"};
}

sub miss {
    my __PACKAGE__ $self = shift;
    return $self->{"miss"};
}

sub hit {
    my __PACKAGE__ $self = shift;
    return $self->{"hit"};
}

1;

__DATA__

########################################################
package Tie::Cacher::Test;
use strict;
use warnings;
use fields qw(sub);
my $data = 0;
our $nodes;

sub new {
    my $class = shift;
    my __PACKAGE__ $self = [];
    $self->[$data] = $_[0];
    $self->{sub} = $_[1] || sub {
        # print STDERR "Destroying $_[0]\n";
    };
    $nodes++;
    bless $self, $class;
}
    
DESTROY {
    my __PACKAGE__ $self = shift;
    $nodes--;
    $self->{"sub"}->($self->[$data]);
}

sub nodes {
    return $nodes;
}

package Tie::Cacher;
use strict;
use warnings;
use Test qw(:DEFAULT $TESTOUT);

use Benchmark;

my $verbose;

sub tok {
    my $line = shift;
    if ($verbose) {
        my $len = 50 - length($line);
        $len = 3 if $len < 3;
        print $TESTOUT $line, "." x $len;
    }
    goto &ok;
}

sub self_test {
    my __PACKAGE__ $self = shift;
    my Tie::Cacher::Node ($head, $next, $prev);
    $next = $head = $self->{"head"};
    $prev = $head->{"previous"};
    my $i;
    my $cnt = $self->{"cnt"};
    for ($i = 0; $prev != $head; $i++) {
        return "$i/$cnt long loop" if $i >= $cnt;
        return "$i/$cnt forward tangle" unless $prev->{"next"} == $next;
        return "$i/$cnt backward tangle" unless $next->{"previous"} == $prev;
        return "$i/$cnt no reference" unless
            $next = $self->{"nodes"}{$prev->{"key"}};
        return "$i/$cnt wrong reference" unless $next == $prev;
        $prev = $prev->{"previous"};
    }
    return "$i/$cnt short loop" if $i != $cnt;
    return "extra references" unless $i == keys %{$self->{"nodes"}};
    return "";
}

sub intern {
    my __PACKAGE__ $self = shift;
    @_ = ("internal test", $self->self_test, "");
    goto &tok;
}

sub test {
    my $class;
    ($class, $verbose) = @_;

    plan tests => 14;
    for my $run (1..2) {
        {
            my (%data, %shadow, $hit, $miss);
            $hit = $miss = 0;
            my $tie =
                tie(%data, $class,
                    head_debug => Tie::Cacher::Test->new(-1),
                    $run == 2 ? (max_cnt => 3) : (),
                    # debug => 1,
                    load => sub { $_[2][0] =
                                    Tie::Cacher::Test->new(length($_[1])); });
            intern($tie);
            tok("fetch/creating data",  $shadow{"fun"} = $data{"fun"}[0], 3);   $miss++;
            intern($tie);
            tok("fetch/creating data",  $shadow{"boem"} = $data{"boem"}[0], 4); $miss++;
            intern($tie);
            tok("fetching data",  $data{"fun"}[0], $shadow{"fun"}); $hit++;
            intern($tie);
            tok("fetch/creating data",  $shadow{"zzzzz"} = $data{"zzzzz"}[0], 5); $miss++;
            intern($tie);
            for (1..2) {
                tok("storing new data", $ {$data{"new"} = Tie::Cacher::Test->new($shadow{"new"} = 8)}[0], 8);
                intern($tie);
                tok("storing old data", $ {$data{"fun"} = Tie::Cacher::Test->new($shadow{"fun"} = 7)}[0], 7);
                delete $shadow{"boem"} if $run == 2;
                intern($tie);
                my @k1 = sort keys %data;
                intern($tie);
                my @k2 = sort keys %shadow;
                tok("get all keys", join(",", @k1), join(",", @k2));
                tok("element counter", $tie->count, scalar @k1);
                for (@k1) {
                    tok("Comparing key $_", $data{$_}[0], $shadow{$_}); $hit++;
                    intern($tie);
                }
                tok("hit counter", $tie->hit, $hit);
                tok("miss counter", $tie->miss, $miss);
                @k1 = delete @data{"fun", "boem", "rom"};
                intern($tie);
                @k2 = delete @shadow{"fun", "boem", "rom"};
                tok("deleted fields", scalar @k1, scalar @k2);
                tok("deleted fun", $k1[0][0], $k2[0]);
                tok("deleted boem", $k1[1][0], $k2[1]);
                tok("deleted rom", $k1[2], $k2[2]);
                tok("hit counter", $tie->hit, $hit);
                tok("miss counter", $tie->miss, $miss);
                intern($tie);
            }
            tok("leaktest", Tie::Cacher::Test->nodes, 3);
            if ($run == 2) {
                %data = ();
                tok("leaktest", Tie::Cacher::Test->nodes, 1);
            }
        }
        tok("leaktest", Tie::Cacher::Test->nodes, 0);
    }
    {
        my (%data, $hit, $miss, $counter);
        $hit = $miss = $counter = 0;
        
        my $tie =
            tie(%data, $class,
                head_debug => Tie::Cacher::Test->new(-1),
                # $run == 2 ? (max_cnt => 3) : (),
                # debug => 1,
                validate => sub { (++$counter + $_[2][0][0]) % 2 },
                load => sub { $_[2][0] =
                                Tie::Cacher::Test->new(++$counter); });
        tok("priming fun", $data{"fun"}[0], 1); $miss++;
        tok("valid fun", $data{"fun"}[0], 1); $hit++;
        tok("invalid fun", $data{"fun"}[0], 4); $hit++;
        tok("hit counter", $tie->hit, $hit);
        tok("miss counter", $tie->miss, $miss);
    }
    tok("leaktest", Tie::Cacher::Test->nodes, 0);
    # Todo: test cases for save
    #       guarentee every branch is taken at least once
    goto &cache_report;
}

# Stolen from Tie::Cache
my $Size = 5000;

sub report {
    my($desc, $count, $sub) = @_;
    print "[[ timing ]] $desc\n";
    print timestr(timeit($count, $sub))."\n";
    print "   ------   \n";
}

sub etok {
    my($desc, $eval) = @_;
    my $result = eval { &$eval } ? "OK" : "ERROR - $@";
    @_ = ($desc, $result, "OK");
    goto &tok;
}

sub cache_report {
    my %cache;
    my $tie = tie (%cache, 'Tie::Cacher',
         # MaxSize => 1000,
         max_count => $Size);
    my %normal;

    print "++++ Benchmarking operations on Tie::Cacher of size $Size\n\n";
    my $i = 0;
    report(
           "insert of $Size elements into normal %hash",
           $Size, 
           sub { $normal{++$i} = $i },
    );

    $i = 0;
    report(
           "insert of $Size elements into Tie::Cacher %hash",
           $Size,
           sub { $cache{++$i} = $i }
           );

    my $rv;
    $i = 0;
    report(
           "reading $Size elements from normal %hash",
           $Size,
           sub { $rv = $normal{++$i} }
           );
    $i = 0;
    report(
           "reading $Size elements from Tie::Cacher %hash",
           $Size,
           sub { $rv = $cache{++$i} }
           );

    $i = 0;
    report(
           "deleting $Size elements from normal %hash",
           $Size,
           sub { $rv = delete $normal{++$i} }
           );

    $i = 0;
    report(
           "deleting $Size elements from Tie::Cacher %hash",
           $Size,
           sub { $rv = delete $cache{++$i} }
           );

    my $over = $Size * 2;
    $i = 0;
    report(
           "$over inserts overflowing Tie::Cacher %hash ", 
           $over,
           sub { $cache{++$i} = $i; }
           );

    print "\n++++ Testing for correctness\n\n";
    my @keys = keys %cache;
    tok("number of keys in %cache = $Size", scalar @keys, $Size);
    @keys = $tie->old_keys();
    tok("number of keys in %cache = $Size", scalar @keys, $Size);
    tok("first key in %cache = ".($Size + 1), $keys[0], $Size + 1);
    tok("last key in %cache = ".($Size + $Size), $keys[$#keys], $Size + $Size);
    tok("first key value in %cache = ".($Size + 1), $cache{$keys[0]}, $Size + 1);
    delete $cache{$keys[0]};
    etok("deleting key $keys[0]; no value defined for deleted key",
         sub { ! defined $cache{$keys[0]} }
         );
    etok("existance of deleted key = ! exists",
         sub { ! exists $cache{$Size+1} }
         );
    @keys = $tie->old_keys();
    tok("first key in %cache after delete = ".($Size + 2), $keys[0], $Size + 2);
    tok("keys in cache after delete = ".($Size-1), scalar keys %cache, $Size - 1);

    print "\n++++ Stats for %cache\n\n";
    tok("count", $tie->count(), $Size-1);
    tok("hit", $tie->hit(), $Size+1);
    tok("miss", $tie->miss(), 1);
    # print join("\n", map { "$_:\t$tie->{$_}" } 'count', 'hit', 'miss', 'bytes');
}

__DATA__
    exit;

# personalize the Tie::Cacher object, by inheriting from it
    package My::Cache;
    @ISA = qw(Tie::Cacher);

# override the read() and write() member functions
# these tell the cache what to do with a cache miss or flush
    sub read { 
        my($self, $key) = @_; 
#    print "cache miss for $key, read() data\n";
        rand() * $key; 
    }
    sub write { 
        my($self, $key, $value) = @_;
#    print "flushing [$key, $value] from cache, write() data\n";
    }

    my $cache_size   = $ARGV[0] || 2;
    my $num_to_cache = $ARGV[1] || 4;   
    my $debug = $ARGV[2] || 2;

    tie %cache, 'My::Cache', {
        MaxBytes => $cache_size * 20,
        MaxCount => $cache_size,
        Debug => $debug,
        WriteSync => 0,
    };   

# load the cache with new data, each through its contents,
# and then reload in reverse order.
    my $count = 0;
    for(1..$num_to_cache) { 
        print "READ data $_: $value\n";
        my $value = $cache{$_};
        if($count++ % 2) {
            print "INCREMENTING data for $_\n";
            $cache{$_} = $value + 1;
        }
    }

    for(1..$num_to_cache) {
        my $new_value = int(rand() * 10);
        print "WRITING data $new_value\n";
        $cache{$_} = $new_value;
    }

    while(my($k, $v) = each %cache) { print "EACH data $k: $v\n"; }
#while(my($k, $v) = each %cache) { print "EACH data $k: $v\n"; }
#for(my $i=$num_to_cache; $i>0; $i--) { print "read data $i: $cache{$i}\n"; }

# clear cache in 2 ways, write will flush out to disk
    %cache = ();
    undef %cache;
}

1;

__END__
