add Tie::JournaledDir which wraps Tie::JournaledFile and uses some

directory as cache area.

add/update test tools for Tie::Journaled{File,Dir} modules.

clean up Tie::JournaledFile
o remove header in the cache file
o $self->{ 'key' }
o $debug is on if $ENV{'debug'} is defined.
o more carefull check of whether the value is defined or not.
o quotemeta() for pre search key in find()
o rename grep() to find()

4 files changed, 418 insertions, 53 deletions

diff --git a/fml/lib/Tie/JournaledDir.pm b/fml/lib/Tie/JournaledDir.pm
new file mode 100644
index 00000000..7561ef2a
--- /dev/null
+++ b/fml/lib/Tie/JournaledDir.pm
@@ -0,0 +1,267 @@
+#-*- perl -*-
+#
+#  Copyright (C) 2001 Ken'ichi Fukamachi
+#   All rights reserved. This program is free software; you can
+#   redistribute it and/or modify it under the same terms as Perl itself. 
+#
+# $FML: JournaledDir.pm,v 1.7 2001/08/05 13:03:31 fukachan Exp $
+#
+
+package Tie::JournaledDir;
+
+use strict;
+use vars qw(@ISA @EXPORT @EXPORT_OK $AUTOLOAD);
+use Carp;
+
+=head1 NAME
+
+Tie::JournaledDir - wrap Tie::JournaledFile
+
+=head1 SYNOPSIS
+
+    use Tie::JournaledDir;
+    $db = new Tie::JournaledDir { 
+        dir => '/some/where',
+    };
+
+    # get all entries with the key = 'rudo'
+    @values = $db->grep( 'rudo' );
+
+OR
+
+    use Tie::JournaledDir;
+    tie %db, 'Tie::JournaledDir', { dir => '/some/where' };
+    $db{ 1 } = 1;
+    untie %db
+
+
+=head1 METHODS
+
+=head2 TIEHASH, FETCH, STORE, FIRSTKEY, NEXTKEY
+
+standard hash functions.
+
+=cut
+
+
+use Tie::JournaledFile;
+
+my $debug = $ENV{'debug'} ? 1 :0;
+
+
+# Descriptions: constructor
+#    Arguments: $self $args
+# Side Effects: import _match_style into $self
+# Return Value: object
+sub new
+{
+    my ($self, $args) = @_;
+    my ($type) = ref($self) || $self;
+    my $me     = {};
+
+    my $dir   = $args->{ 'dir' };
+    my $unit  = $args->{ 'unit' }  || 24*3600; # 1 day 
+    my $limit = $args->{ 'limit' } || 90;
+
+    # reverse order file list to search
+    my @filelist = ();
+    for (my $i = 0; $i < $limit; $i++) {
+	$filelist[ $i ] = _file_name($unit, $dir, $i);
+    }
+
+    # set up object
+    $me->{ 'dir' }   = $dir;
+    $me->{ 'files' } = \@filelist;
+    return bless $me, $type;
+}
+
+
+sub _file_name
+{
+    my ($unit, $dir, $i) = @_;
+    my $fn = $unit * int(time / $unit) - ($i * $unit);
+
+    use File::Spec;
+    File::Spec->catfile($dir, $fn);
+}
+
+
+sub TIEHASH
+{
+    my ($self, $args) = @_;
+    new($self, $args);
+}
+
+
+sub FETCH
+{
+    my ($self, $key) = @_;
+    my $files = $self->{ 'files' } || [];
+    my $x     = '';
+
+  FILES_LOOP:
+    for my $f (@$files) { 
+	if (-f $f) {
+	    my $obj = new Tie::JournaledFile { 
+		'last_match' => 1, 
+		'file'       => $f, 
+	    };
+
+	    if (defined $obj) {
+		$x = $obj->FETCH($key);
+		last FILES_LOOP if defined $x;
+	    }
+	}
+    }
+
+    return $x;
+}
+
+
+sub STORE
+{
+    my ($self, $key, $value) = @_;
+    my $f = $self->{ 'files' }->[ 0 ]; # XXX [0] is the latest file.
+
+    my $obj = new Tie::JournaledFile { 
+	'last_match' => 1, 
+	'file'       => $f, 
+    };
+
+    return $obj->STORE($key, $value);
+}
+
+
+sub __find_key
+{
+    my ($self) = @_;
+    my $files = $self->{ 'files' };
+
+    # we open some file now, search in the file.
+    if (defined $self->{ '_key_files_obj' }) {
+	my $obj = $self->{ '_key_files_obj' };
+	my $x   = $obj->NEXTKEY();
+
+	if (defined $x) {
+	    print STDERR "NEXTKEY: $x\n" if $debug; 
+	    return $x;
+	}
+	else {
+	    delete $self->{ '_key_files_obj' };
+	}
+    }
+
+    # 1. for the first time 
+    # 2. no more valid keys in the file ( _key_files_obj object )
+    # so try to read the first/next file
+  FILES:
+    for my $f (@$files) {
+	# skip the file already done
+	next FILES if defined $self->{ '_key_files_done' }->{ $f };
+
+	# try to open the next file
+	if (-f $f) {
+	    print STDERR "open $f\n" if $debug; 
+	    my $obj = new Tie::JournaledFile { 
+		'last_match' => 1, 
+		'file'       => $f, 
+	    };
+
+	    if (defined $obj) {
+		# negative cache: mark which file is opened.
+		$self->{ '_key_files_done' }->{ $f } = 1;
+
+		# XXX for the first time
+		my $x = $obj->FIRSTKEY();
+
+		# save object if this file has valid value(s).
+		if (defined $x) {
+		    print STDERR "FIRSTKEY: $x\n" if $debug; 
+		    $self->{ '_key_files_obj' } = $obj;
+		    return $x;
+		}
+		# skip this file if this file has no valid value. 
+		else {
+		    print STDERR "FIRSTKEY: not found\n" if $debug; 
+		    next FILES;
+		}
+	    }
+	}
+    }
+
+    undef;
+}
+
+
+sub __in_valid_search
+{
+    my ($self) = @_;
+    return $self->{ '_key_files_obj' } ? 1 : 0;
+}
+
+
+sub FIRSTKEY
+{
+    my ($self) = @_;
+    my $files = $self->{ 'files' };
+
+    # initialize cache area which holds done lists
+    undef $self->{ '_key_files_done' };
+
+    my $x = $self->__find_key();
+
+    if (defined $x) {
+	$self->{ '_key_cache' }->{ $x } = 1;
+	return $x;
+    }
+    else {
+	return undef;
+    }
+}
+
+
+sub NEXTKEY
+{
+    my ($self) = @_;
+
+    # XXX we need the duplication check.
+    # XXX This class opens plural files and
+    # XXX is responsible to check return values.
+
+    while (defined $self->__in_valid_search()) {
+	my $x = $self->__find_key();
+
+	if (defined $x) {
+	    unless (defined $self->{ '_key_cache' }->{ $x }) {
+		$self->{ '_key_cache' }->{ $x } = 1;
+		return $x;
+	    }
+	    else {
+		return undef;
+	    }
+	}
+    }
+
+    undef;
+}
+
+
+=head1 AUTHOR
+
+Ken'ichi Fukamachi
+
+=head1 COPYRIGHT
+
+Copyright (C) 2001 Ken'ichi Fukamachi
+
+All rights reserved. This program is free software; you can
+redistribute it and/or modify it under the same terms as Perl itself. 
+
+=head1 HISTORY
+
+Tie::JournaledDir appeared in fml5 mailing list driver package.
+See C<http://www.fml.org/> for more details.
+
+=cut
+
+1;
diff --git a/fml/lib/Tie/JournaledFile.pm b/fml/lib/Tie/JournaledFile.pm
index d06c82ac..31947fd3 100644
--- a/fml/lib/Tie/JournaledFile.pm
+++ b/fml/lib/Tie/JournaledFile.pm
@@ -4,7 +4,7 @@
 #   All rights reserved. This program is free software; you can
 #   redistribute it and/or modify it under the same terms as Perl itself. 
 #
-# $FML: JournaledFile.pm,v 1.6 2001/08/05 04:22:03 fukachan Exp $
+# $FML: JournaledFile.pm,v 1.7 2001/08/05 13:03:31 fukachan Exp $
 #
 
 package Tie::JournaledFile;
@@ -15,7 +15,7 @@ use Carp;
 
 =head1 NAME
 
-Tie::JournaledFile - hash emulation for a log structered file
+Tie::JournaledFile - hash operation for a jurnaled style log file
 
 =head1 SYNOPSIS
 
@@ -23,16 +23,19 @@ Tie::JournaledFile - hash emulation for a log structered file
    $db = new Tie::JournaledFile { file => 'cache.txt' };
 
    # get all entries with the key = 'rudo'
-   @values = $db->grep( 'rudo' );
+   @values = $db->find( 'rudo' );
 
-or
+or access in hash style
 
    use Tie::JournaledFile;
    tie %db, 'Tie::JournaledFile', { file => 'cache.txt' };
    print $db{ rudo }, "\n";
 
-where the format of "cache.txt" is "key value" for each line.
-For example
+where the format of "cache.txt" is 
+
+   key value
+
+for each line. For example
 
      rudo   teddy bear
      kenken north fox
@@ -44,13 +47,19 @@ By default, FETCH() returns the first value with the key.
    tie %db, 'Tie::JournaledFile', { first_match => 1, file => 'cache.txt' };
    print $db{ rudo }, "\n";
 
-If you print out the latest value (so at the later line somewhere in
-the file) for the specified C<$key>
+If you print out the latest value for C<$key>
 
    use Tie::JournaledFile;
    tie %db, 'Tie::JournaledFile', { last_match => 1, file => 'cache.txt' };
    print $db{ rudo }, "\n";
 
+It is the value at the latest line with the key in the file.
+
+=head2 KNOWN BUG
+
+YOU CANNOT USE SPACE (\s+) IN THE KEY.
+
+
 =head1 METHODS
 
 =head2 TIEHASH, FETCH, STORE, FIRSTKEY, NEXTKEY
@@ -60,6 +69,9 @@ standard hash functions.
 =cut
 
 
+my $debug = $ENV{'debug'} ? 1 : 0;
+
+
 # Descriptions: constructor
 #    Arguments: $self $args
 # Side Effects: import _match_style into $self
@@ -70,27 +82,20 @@ sub new
     my ($type) = ref($self) || $self;
     my $me     = {};
 
-    # make a cache file if not exists
     $me->{ _file } = $args->{ file };
-    unless (-f $me->{ _file }) {
-	use Time::localtime;
-	my $date = ctime(time);
-	_puts($me, "# format: ^key\\s+value\$");
-	_puts($me, "#              key: should not have spaces in it.");
-	_puts($me, "#            value: may have spaces in it.");
-	_puts($me, "#");
-	_puts($me, "# created at $date");
-    }
-    
+
     # define search strategy: first or last match
-    if (defined $args->{ first_match }) {
-	$me->{ _match_style } = 'first';
+    if (defined $args->{ 'first_match' } && defined $args->{ 'last_match' }) {
+	croak "both first_match and last_match specified\n";
+    }
+    elsif (defined $args->{ 'first_match' }) {
+	$me->{ '_match_style' } = 'first';
     }
-    elsif (defined $args->{ last_match }) {
-	$me->{ _match_style } = 'last';
+    elsif (defined $args->{ 'last_match' }) {
+	$me->{ '_match_style' } = 'last';
     }
     else {
-	$me->{ _match_style } = 'first';
+	$me->{ '_match_style' } = 'first';
     }
 
     return bless $me, $type;
@@ -101,7 +106,7 @@ sub TIEHASH
 {
     my ($self, $args) = @_;
     my ($type) = ref($self) || $self;
-    $args->{ last_match } = 1;
+    $args->{ 'last_match' } = 1;
     new($self, $args);
 }
 
@@ -126,12 +131,21 @@ sub FIRSTKEY
 
     use IO::File;
     my $fh = new IO::File;
-    $fh->open( $self->{ _file }, "r");
-    $self->{ _fh } = $fh;
+    if ($fh->open( $self->{ '_file' }, "r")) {
+	$self->{ _fh } = $fh;
 
-    my $r = <$fh>;
-    my @r = split(/\s+/, $r);
-    return $r[0];
+	my $r   = <$fh>;
+	my $key = (split(/\s+/, $r))[0];
+
+	# negative cache
+	$self->{ '_key_negative_cache' }->{ $key } = 1;
+
+	print STDERR "   File.FIRSTKEY: $key (return)\n" if $debug;	
+	return $key;
+    }
+    else {
+	return undef; # error: cannot open file
+    }
 }
 
 
@@ -139,23 +153,60 @@ sub NEXTKEY
 {
     my ($self) = @_;
     my $fh = $self->{ _fh };
-    my $r  = <$fh>;
-    my @r  = split(/\s+/, $r);
-    return $r[0];
+
+    if (defined $fh) {
+	my ($r, $key);
+
+      LOOP:
+	while (defined ($r = <$fh>)) {
+	    $key = (split(/\s+/, $r))[0];
+
+	    # duplicated (already returned key)
+	    if (defined $self->{ '_key_negative_cache' }->{ $key }) {
+		print STDERR "   File.NEXTKEY: $key (dup, ignored)\n" if $debug;
+		next LOOP;
+	    }
+	    else {
+		print STDERR "   File.NEXTKEY: $key (found)\n" if $debug;
+	    }
+
+	    # negative cache
+	    $self->{ '_key_negative_cache' }->{ $key }++;
+	    last LOOP;
+	}
+
+	# duplicated key ( > 1 ) is found. ignore it.
+	# XXX "> 1" is important to clarify duplication or not.
+	if ((defined $self->{ '_key_negative_cache' }->{ $key }) &&
+	    ($self->{ '_key_negative_cache' }->{ $key } > 1)) {
+	    print STDERR "   File.NEXTKEY: $key (ignored*)\n" if $debug;
+	    return undef;
+	}
+	# not found
+	else {
+	    print STDERR "   File.NEXTKEY: not found\n" if $debug;
+	    return $key;
+	}
+    }
+    # error: file handle is not defined.
+    else { 
+	return undef;
+    }
 }
 
 
-=head2 C<grep(key)>
+=head2 C<find(key)>
+
+return the array of line(s) with the specified C<key>. 
 
-return the line with the C<key>. 
 The line is either first or last mached line.
-It is determined by C<last_match> or C<first_match> parameter at
-C<new()> method. 
-C<first_match> by default.
+The maching strategy is determined by C<last_match> or C<first_match>
+parameter at C<new()> method. C<first_match> by default.
 
 =cut
 
-sub grep
+
+sub find
 {
     my ($self, $key) = @_;
     my $rarray = $self->_fetch($key, 'array');
@@ -164,9 +215,9 @@ sub grep
 
 
 # Descriptions: real function to search $key.
-#               This routine is used at grep() and FETCH() methods.
+#               This routine is used at find() and FETCH() methods.
 #               return the value with the $key
-#               $self->{ _match_style } conrolls the matching algorithm
+#               $self->{ '_match_style' } conrolls the matching algorithm
 #               is either of the fist or last match.
 #    Arguments: $self $key $mode
 #               $key is the string to search.
@@ -176,14 +227,15 @@ sub grep
 sub _fetch
 {
     my ($self, $key, $mode) = @_;
-    my $prekey = $key;
+    my $prekey  = $key;
+    my $keytrap = quotemeta($key);
 
     # the first 1 byte of the key
-    if ($key =~ /^(.)/) { $prekey = $1;}
+    if ($key =~ /^(.)/) { $prekey = quotemeta($1);}
 
     use IO::File;
     my $fh = new IO::File;
-    $fh->open( $self->{ _file }, "r");
+    $fh->open( $self->{ '_file' }, "r");
 
     # error (we fail to open cache file).
     unless (defined $fh) { return undef;}
@@ -196,7 +248,7 @@ sub _fetch
 	next SEARCH if /^\#*$/;
 	next SEARCH if /^\s*$/;
 	next SEARCH unless /^$prekey/i; 
-	next SEARCH unless /^$key/i;
+	next SEARCH unless /^$keytrap/i;
 
 	chop;
 
@@ -207,7 +259,7 @@ sub _fetch
 	    }
 	    if ($mode eq 'scalar') {
 		# firstmatch: exit loop ASAP if the $key is found.
-		if ($self->{ _match_style } eq 'first') {
+		if ($self->{ '_match_style' } eq 'first') {
 		    last SEARCH;
 		}
 	    }
@@ -218,7 +270,7 @@ sub _fetch
     if ($mode eq 'scalar') {
 	return( $xvalue || undef );
     }
-    if ($mode eq 'array') {
+    elsif ($mode eq 'array') {
 	return \@values;
     }    
 }
@@ -237,7 +289,6 @@ sub _store
 }
 
 
-
 # Descriptions: append given string to cache file
 #    Arguments: $self $string
 # Side Effects: update cache file
@@ -245,7 +296,7 @@ sub _store
 sub _puts
 {
     my ($self, $string) = @_;
-    my $file = $self->{ _file };
+    my $file = $self->{ '_file' };
 
     use IO::File;
     my $fh = new IO::File;
diff --git a/regress/base/journaleddir.pl b/regress/base/journaleddir.pl
new file mode 100755
index 00000000..7f7e194f
--- /dev/null
+++ b/regress/base/journaleddir.pl
@@ -0,0 +1,46 @@
+#!/usr/bin/env perl
+#
+# $FML$
+#
+
+use Tie::JournaledDir;
+
+my $key  = shift || 'uja';
+my $unit = 60;
+my $dir  = "/tmp/fml5/jd";
+
+system "mkdir -p $dir" unless -d $dir;
+&_read();
+&_write();
+
+exit 0;
+
+
+sub _read
+{
+    tie %db, 'Tie::JournaledDir', { 
+	unit => $unit,
+	dir  => $dir,
+    };
+
+    print "   $key => $db{ $key }\n";
+
+    print "\n   keys: ";
+    print join(" ", keys %db);
+    print "\n";
+}
+
+
+sub _write
+{
+    tie %db, 'Tie::JournaledDir', { 
+	unit => $unit,
+	dir  => $dir,
+    };
+
+    my $x = `date`;
+    chop $x;
+    $db{ $key } = $x;
+
+    untie %db;
+}
diff --git a/regress/base/journaledfile.pl b/regress/base/journaledfile.pl
index c0760371..3b4797fa 100755
--- a/regress/base/journaledfile.pl
+++ b/regress/base/journaledfile.pl
@@ -1,6 +1,6 @@
 #!/usr/bin/env perl
 #
-# $FML$
+# $FML: journaledfile.pl,v 1.1 2001/08/05 13:07:59 fukachan Exp $
 #
 
 use strict;
@@ -10,10 +10,11 @@ use Tie::JournaledFile;
 my %db   = ();
 my $file = '/tmp/fml5/cache.txt';
 my $buf  = '';
+my $key  = "rudo$$";
 chop($buf = `date`);
 
 tie %db, 'Tie::JournaledFile', { file => $file };
-$db{ 'rudo' } = $buf;
+$db{ $key } = $buf;
 untie %db;
 
 print "   ", `ls -l $file`;
@@ -21,12 +22,12 @@ print "   ", `ls -l $file`;
 tie %db, 'Tie::JournaledFile', { file => $file };
 
 print "verify written string ... ";
-if ($db{ 'rudo' } eq $buf) {
+if ($db{ $key } eq $buf) {
     print "ok\n";
 } 
 else {
     print "fail\n";
-    print "   >", $db{'rudo'}, "<\n";
+    print "   >", $db{ $key }, "<\n";
     print "   >", $buf, "<\n";
 }