]> git.p6c8.net - selfforum.git/blobdiff - selfforum-cgi/shared/Posting/Cache.pm
git.p6c8.net / selfforum.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
added version checks and some comments, removed Posting::_lib::create_message_xml...
[selfforum.git] / selfforum-cgi / shared / Posting / Cache.pm
diff --git a/selfforum-cgi/shared/Posting/Cache.pm b/selfforum-cgi/shared/Posting/Cache.pm
index 42bbeb5265e73fbfaf663c1c35f8d9cc8bdc1827..cf8c3c42b56c99052491afe24c372e73604c778a 100644 (file)
--- a/selfforum-cgi/shared/Posting/Cache.pm
+++ b/selfforum-cgi/shared/Posting/Cache.pm
@@ -11,10 +11,20 @@ package Posting::Cache;
 ################################################################################
 
 use strict;
 ################################################################################
 
 use strict;
+use vars qw(
+  $VERSION
+);
 
 use Fcntl;
 
 use Fcntl;
+use File::Path;
 use Lock qw(:ALL);
 
 use Lock qw(:ALL);
 
+################################################################################
+#
+# Version check
+#
+$VERSION = do { my @r =(q$Revision$ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
+
 my $O_BINARY = eval "O_BINARY";
 $O_BINARY = 0 if ($@);
 
 my $O_BINARY = eval "O_BINARY";
 $O_BINARY = 0 if ($@);
 
@@ -22,7 +32,7 @@ $O_BINARY = 0 if ($@);
 #
 # Constructor
 #
 #
 # Constructor
 #
-# Params: $filename - full qualified cache file name
+# Params: $pathname - full qualified cache path
 #
 # Return: Posting::Cache object
 #
 #
 # Return: Posting::Cache object
 #
@@ -30,11 +40,7 @@ sub new {
   my $self = bless {} => shift;
 
   $self -> clear_error;
   my $self = bless {} => shift;
 
   $self -> clear_error;
-  $self -> set_file (+shift);
-
-  $self -> repair_cache or do {
-    $self -> set_error ('cache '.$self->cachefile.' is broken and not repairable.')
-  };
+  $self -> set_path (+shift);
 
   $self;
 }
 
   $self;
 }
@@ -61,102 +67,181 @@ sub set_error {
   my $self = shift;
 
   $self -> {verb_error} = +shift;
   my $self = shift;
 
   $self -> {verb_error} = +shift;
-
   return;
 }
 
   return;
 }
 
-### sub set_file ###############################################################
+### sub set_path ###############################################################
 #
 # set cache file name
 #
 #
 # set cache file name
 #
-# Params: $filename - full qualified cache file name
+# Params: $pathname - full qualified cache path
 #
 #
-sub set_file {
-  my ($self, $filename) = @_;
+sub set_path {
+  my ($self, $pathname) = @_;
 
 
-  $self -> {cachefile} = $filename;
+  $self -> {cachepath} = $pathname;
 
   return;
 }
 
 
   return;
 }
 
-sub cachefile {$_[0] -> {cachefile}}
-sub indexfile {$_[0] -> cachefile . '.index'}
-sub temp_cachefile {$_[0] -> cachefile . '.temp'}
-sub temp_indexfile {$_[0] -> indexfile . '.temp'}
+sub cachepath   {$_[0] -> {cachepath}}
+sub threaddir   {$_[0] -> cachepath          . $_[1] -> {thread}}
+sub threadpath  {$_[0] -> threaddir  ($_[1]) . '/'}
+sub cachefile   {$_[0] -> threadpath ($_[1]) . $_[1] -> {posting} . '.txt'}
+sub summaryfile {$_[0] -> cachepath          . 'summary.bin'}
+
+### sub delete_threads #########################################################
+#
+# remove threads from cache
+#
+# Params: @threads - list of threadnumbers
+#
+# Return: Status Code (Bool)
+#
+sub delete_threads {
+  my ($self, @threads) = @_;
+  my %threads = map {$_ => 1} @threads;
+
+  $self -> mod_wrap (
+    \&r_delete_threads,
+    \%threads
+  );
+}
+sub r_delete_threads {
+  my ($self, $handle, $threads) = @_;
+  my $l = length (pack 'L' => 0);
+  my $reclen = $l << 2;
+  my $len = -s $handle;
+  my $num = int ($len / $reclen) -1;
+  my ($buf, %hash);
+  local $/;
+  local $\;
+
+  for (0..$num) {
+    seek $handle, $_ * $reclen + $l, 0                 or return;
+    read ($handle, $buf, $l) == $l                     or return;
+    if ($threads->{unpack 'L' => $buf}) {
+      seek $handle, $_ * $reclen + $l, 0               or return;
+      print $handle pack ('L' => 0)                    or return;
+    }
+  }
+
+  rmtree ($self->threaddir({thread => $_}), 0, 0)
+    for (keys %$threads);
+
+  1;
+}
+
+### sub garbage_collection #####################################################
+#
+# remove old entrys from the beginning of the cache
+#
+# Params: ~none~
+#
+# Return: ~none~
+#
+sub garbage_collection {
+  my $self = shift;
+
+  $self -> purge_wrap (
+    \&r_garbage_collection
+  );
+}
+sub r_garbage_collection {
+  my ($self, $handle, $file) = @_;
+
+  my $reclen  = length (pack 'L', 0) << 2;
+  my $len = -s $handle;
+  my $num = int ($len / $reclen) -1;
+  my ($z, $buf, $h) = 0;
+  local $/;
+  local $\;
+
+  return; # no GC yet
+
+  seek $handle, 0, 0                                 or return;
+  read ($handle, $buf, $len)                         or return;
+  for (0..$num) {
+    (undef, $h) = (unpack 'L2' => substr ($buf, $_ * $reclen, $reclen));
+    last if $h;
+    return unless (defined $h);
+    $z++;
+  }
+  substr ($buf, 0, $z * $reclen) = '';
+
+  seek $file, 0, 0                                   or return;
+  print $file $buf                                   or return;
+
+  # looks good
+  1;
+}
 
 ### sub find_pos ($$) ##########################################################
 #
 # find position in cache file
 
 ### sub find_pos ($$) ##########################################################
 #
 # find position in cache file
-# (binary search in index file)
 #
 #
-# Params: $handle  - index file handle
+# Params: $handle  - summary file handle
 #         $posting - posting number
 #
 # Return: position or false (undef)
 #
 sub find_pos ($$) {
 #         $posting - posting number
 #
 # Return: position or false (undef)
 #
 sub find_pos ($$) {
-  my ($I, $posting) = @_;
-  my $reclen = 2 * length pack 'L',0;
-  my $end = (-s $I) / $reclen;
+  my ($handle, $posting) = @_;
+  my $reclen = length (pack 'L',0);
+  my $lreclen = $reclen << 2;
+  seek $handle, 0, 0                                       or return;
 
 
-  $end == int $end                                         or return;
-
-  my ($start, $buf, $current) = 0;
+  my $buf;
+  read ($handle, $buf, $reclen) == $reclen                 or return;
 
 
-  while ($start <= $end) {
-    seek $I, ($current = ($start + $end) >> 1)*$reclen, 0  or return;
-    $reclen == read ($I, $buf, $reclen)                    or return;
+  my $first = unpack ('L' => $buf);
+  $first <= $posting                                       or return;
 
 
-    my ($num, $found) = unpack 'L2',$buf;
+  my $pos = ($posting - $first) * $lreclen;
+  seek $handle, $pos, 0                                    or return;
 
 
-    if ($num == $posting) {
-      return $found;
-    }
-    elsif ($num < $posting) {
-      $start = $current+1
-    }
-    else {
-      $end   = $current-1
-    }
-  }
-
-  return;
+  $pos;
 }
 
 ### sub add_view ###############################################################
 #
 # increment the views-counter
 #
 }
 
 ### sub add_view ###############################################################
 #
 # increment the views-counter
 #
-# Params: ~none~
+# Params: hash reference
+#         (posting, thread)
 #
 # Return: Status code (Bool)
 #
 #
 # Return: Status code (Bool)
 #
+sub add_view {
+  my ($self, $param) = @_;
+
+  $self -> mod_wrap (
+    \&r_add_view,
+    $param
+  );
+}
 sub r_add_view {
 sub r_add_view {
-  my ($self, $h, $param) = @_;
-  my ($C, $I) = ($h->{C}, $h->{I});
-  my $reclen  = 4 * length pack 'L', 0;
+  my ($self, $handle, $param) = @_;
+  my $reclen  = length (pack 'L', 0) << 2;
   my $pos;
   my $pos;
-  defined ($pos = find_pos $I, $param->{posting})                or return;
+  defined ($pos = find_pos $handle, $param->{posting})                or return;
 
   my $buf;
 
   my $buf;
-  seek $C, $pos, 0                                               or return;
-  read ($C, $buf, $reclen) == $reclen                            or return;
+  seek $handle, $pos, 0                                               or return;
+  read ($handle, $buf, $reclen) == $reclen                            or return;
 
 
-  my ($posting, $thread, $views, $votings) = unpack 'L4',$buf;
-  $thread == $param->{thread}                                    or return;
-  seek $C, $pos, 0                                               or return;
-  print $C pack ('L4' => $posting, $thread, $views+1, $votings)  or return;
+  my ($posting, $thread, $views, $votings) = unpack 'L4' => $buf;
+  $thread == 0xFFFFFFFF and $thread = $param->{thread};
 
 
-  1;
-}
+  $param->{thread} == $thread                                         or return;
+  $param->{posting} == $posting                                       or return;
 
 
-sub add_view {
-  my ($self, $param) = @_;
+  seek $handle, $pos, 0                                               or return;
 
 
-  $self -> write_wrap (
-    \&r_add_view,
-    $param
-  );
+  local $\;
+  print $handle pack ('L4' => $posting, $thread, $views+1, $votings)  or return;
+
+  1;
 }
 
 ### sub pick ###################################################################
 }
 
 ### sub pick ###################################################################
@@ -168,20 +253,37 @@ sub add_view {
 #
 # Return: hash reference or false
 #
 #
 # Return: hash reference or false
 #
+sub pick {
+  my ($self, $param) = @_;
+
+  $self -> pick_wrap (
+    \&r_pick,
+    $self->cachefile($param),
+    $param
+  ) ? $self -> {pick}
+    : return;
+}
 sub r_pick {
 sub r_pick {
-  my ($self, $h, $param) = @_;
-  my ($C, $I) = ($h->{C}, $h->{I});
-  my $reclen  = 4 * length pack 'L', 0;
+  my ($self, $handle, $file, $param) = @_;
+  my $reclen  = 4 * length (pack 'L' => 0);
   my ($buf, $pos);
   my ($buf, $pos);
-  local $/="\012";
+  local $/="\n";
+
+  defined($pos = find_pos $handle, $param->{posting})                 or return;
+
+  seek $handle, $pos, 0                                               or return;
+  read ($handle, $buf, $reclen) == $reclen                            or return;
 
 
-  defined($pos = find_pos $I, $param->{posting})      or return;
+  my ($posting, $thread, $views, $votings) = unpack 'L4' => $buf;
+  $thread == 0xFFFFFFFF and $thread = $param->{thread};
 
 
-  seek $C, $pos, 0                                    or return;
-  read ($C, $buf, $reclen) == $reclen                 or return;
+  $param->{thread} == $thread                                         or return;
+  $param->{posting} == $posting                                       or return;
+
+  seek $file, 0, 0                                                    or return;
+  my @records = <$file>;
+  chomp @records;
 
 
-  my ($posting, $thread, $views, $votings) = unpack 'L4', $buf;
-  $buf = <$C>; chomp $buf;
   $self -> {pick} = {
     views   => $views,
     votings => $votings,
   $self -> {pick} = {
     views   => $views,
     votings => $votings,
@@ -192,8 +294,8 @@ sub r_pick {
             time => $_->[0] || 0,
             IP   => $_->[1] || 0
           }
             time => $_->[0] || 0,
             IP   => $_->[1] || 0
           }
-        } [split /;/]
-      } split ' ' => $buf
+        } [split ' ' => $_,3]
+      } @records
     }
   };
 
     }
   };
 
@@ -201,14 +303,6 @@ sub r_pick {
   1;
 }
 
   1;
 }
 
-sub pick {
-  my ($self, $param) = @_;
-
-  $self -> read_wrap (\&r_pick, $param)
-    ? $self -> {pick}
-    : return;
-}
-
 ### sub summary ################################################################
 #
 # read out the cache and return a summary
 ### sub summary ################################################################
 #
 # read out the cache and return a summary
@@ -217,22 +311,27 @@ sub pick {
 #
 # Return: hash reference or false
 #
 #
 # Return: hash reference or false
 #
-sub r_summary {
-  my ($self, $h) = @_;
-  my ($C, $I) = ($h->{C}, $h->{I});
-  my $reclen  = length pack 'L', 0;
-  my $ireclen = 2 * $reclen;
-  my $creclen = 4 * $reclen;
-  my ($buf, $pos, %hash);
-
-
-  while ($ireclen == read ($I, $buf, $ireclen)) {
-    (undef, $pos) = unpack 'L2', $buf;
+sub summary {
+  my $self = shift;
 
 
-    seek $C, $pos, 0                                 or return;
-    read ($C, $buf, $creclen) == $creclen            or return;
+  $self -> read_wrap (\&r_summary)
+    ? $self -> {summary}
+    : return;
+}
+sub r_summary {
+  my ($self, $handle) = @_;
+  my $reclen  = length (pack 'L', 0) << 2;
+  my $len = -s $handle;
+  my $num = int ($len / $reclen) -1;
+  my ($buf, %hash);
+  local $/;
+
+  seek $handle, 0, 0                                 or return;
+  read ($handle, $buf, $len)                         or return;
+  for (0..$num) {
+    my ($posting, $thread, $views, $votings)
+      = (unpack 'L4' => substr ($buf, $_ * $reclen, $reclen));
 
 
-    my ($posting, $thread, $views, $votings) = unpack 'L4', $buf;
     $hash{$thread} = {} unless $hash{$thread};
     $hash{$thread} -> {$posting} = {
       views   => $views,
     $hash{$thread} = {} unless $hash{$thread};
     $hash{$thread} -> {$posting} = {
       views   => $views,
@@ -246,67 +345,53 @@ sub r_summary {
   1;
 }
 
   1;
 }
 
-sub summary {
-  my $self = shift;
-
-  $self -> read_wrap (\&r_summary)
-    ? $self -> {summary}
-    : return;
-}
-
-### sub repair_cache ###########################################################
+### sub add_voting #############################################################
 #
 #
-# check on cache consistance and repair if broken
+# add a voting
 #
 #
-# Params: ~none~
+# Params: $param - hash reference
+#                  (thread, posting, IP, ID, time)
 #
 #
-# Return: sucess code (Bool)
+# Return: Status code (Bool)
 #
 #
-sub r_repair_cache {
-  my ($self, $h) = @_;
-  my ($C, $TC, $TI) = ($h->{C}, $h->{TC}, $h->{TI});
-  my $pos = tell $TC;
-  my ($block);
-  my $reclen = 4 * length pack 'L',0;
-  local $/="\012";
-  local $\;
-
-  while ($reclen == read $C, $block, $reclen) {
-    my $msg = unpack ('L' => $block);
-    my $rest = <$C>;
-    chomp $rest;
-    print $TC $block. $rest. $/;
-    print $TI pack ('L2' => $msg, $pos);
-    $pos = tell $TC;
-  }
+sub add_voting {
+  my ($self, $param) = @_;
 
 
-  1;
+  $self -> vote_wrap (
+    \&r_add_voting,
+    $param
+  );
 }
 }
+sub r_add_voting {
+  my ($self, $handle, $file, $param) = @_;
+  my $reclen  = length (pack 'L', 0) << 2;
+  my $pos;
+  defined ($pos = find_pos $handle, $param->{posting})          or return;
 
 
-sub repair_cache {
-  my $self = shift;
-
-  return unless ($self->cachefile and $self->indexfile);
-  return 1 if (-f $self->cachefile and -f $self->indexfile);
+  my $buf;
+  seek $handle, $pos, 0                                         or return;
+  read ($handle, $buf, $reclen) == $reclen                      or return;
 
 
-  unless (-f $self->cachefile) {
-    return if (-f $self->indexfile);
+  my ($posting, $thread, $views, $votings) = unpack 'L4' => $buf;
+  $thread == 0xFFFFFFFF and $thread = $param->{thread};
 
 
-    local *FILE;
-    return unless (open FILE, '>'.$self->cachefile);
-    return unless (close FILE);
-    return unless (open FILE, '>'.$self->indexfile);
-    return unless (close FILE);
+  $param->{thread} == $thread                                   or return;
 
 
-    release_file ($self->cachefile);
-    release_file ($self->indexfile);
-    release_file ($self->temp_indexfile);
-    release_file ($self->temp_cachefile);
+  {
+    local $\="\n";
+    seek $file, 0, 2                                            or return;
+    print $file
+      join (' ' => $param->{time}, $param->{IP}, $param->{ID})  or return;
+  }
 
 
-    return 1;
+  {
+    local $\;
+    seek $handle, $pos, 0                                       or return;
+    print $handle
+      pack ('L4' => $posting, $thread, $views, $votings+1)      or return;
   }
 
   }
 
-  $self -> open_wrap (\&r_repair_cache);
+  1;
 }
 
 ### sub add_posting ############################################################
 }
 
 ### sub add_posting ############################################################
@@ -318,322 +403,348 @@ sub repair_cache {
 #
 # Return: Status code (Bool)
 #
 #
 # Return: Status code (Bool)
 #
+sub add_posting {
+  my $self = shift;
+  $self -> add_wrap (
+    \&r_add_posting,
+    @_
+  );
+}
 sub r_add_posting {
 sub r_add_posting {
-  my ($self, $h, $param) = @_;
-  my ($C, $TC, $TI) = ($h->{C}, $h->{TC}, $h->{TI});
-  my $pos = tell $TC;
-  my ($block, $ins, $msg);
-  my $reclen = 4 * length pack 'L',0;
-  local $/="\012";
+  my ($self, $handle, $param) = @_;
+  local *FILE;
   local $\;
 
   local $\;
 
-  while ($reclen == read $C, $block, $reclen) {
-    $msg = unpack ('L' => $block);
-
-    if ($param -> {posting} == $msg) {
-      $self->set_error("double defined posting id 'm$msg'");
-      return;
-    };
-    next if ($param -> {posting} > $msg or $ins);
-
-    print $TC pack('L4' => $param->{posting}, $param->{thread}, 0, 0), $/;
-    print $TI pack('L2' => $param->{posting}, $pos);
-    $pos = tell $TC;
-    $ins = 1;
+  unless (-d $self -> threaddir($param)) {
+    mkdir $self->threaddir($param)                   or return;
   }
   }
-  continue {
-    my $rest = <$C>;
-    chomp $rest;
-    print $TC $block. $rest. $/;
-    print $TI pack ('L2' => $msg, $pos);
-    $pos = tell $TC;
+  sysopen (
+    FILE,
+    $self->cachefile($param),
+    O_WRONLY | O_CREAT | O_TRUNC
+  )                                                  or return;
+  close FILE                                         or return;
+
+  my $z;
+  if (-s $handle) {
+    my $reclen = length (pack 'L' => 0) << 2;
+    seek $handle, 0-$reclen, 2                       or return;
+    my $buf;
+    read ($handle, $buf, $reclen) == $reclen         or return;
+    $z = unpack 'L' => $buf;
+    if ($z < $param->{posting}) {
+      while (++$z < $param->{posting}) {
+        seek $handle, 0, 2                           or return;
+        print $handle pack(
+          'L4' => $z, 0xFFFFFFFF, 0, 0
+        )                                            or return;
+      }
+      $z = undef;
+    }
+    else {
+      my $pos;
+      defined (
+        $pos = find_pos $handle, $param->{posting}
+      )                                              or return;
+      seek $handle, $pos, 0                          or return;
+    }
   }
   }
-  unless ($ins) {
-    print $TC pack('L4' => $param->{posting}, $param->{thread}, 0, 0), $/;
-    print $TI pack('L2' => $param->{posting}, $pos);
+
+  unless (defined $z) {
+    seek $handle, 0, 2                               or return;
   }
 
   }
 
-  1;
-}
+  print $handle pack(
+    'L4' => $param->{posting}, $param->{thread}, 0, 0
+  )                                                  or return;
 
 
-sub add_posting {
-  my $self = shift;
-  $self -> open_wrap (
-    \&r_add_posting,
-    @_
-  );
+  release_file ($self->cachefile($param));
+
+  1;
 }
 
 }
 
-### sub add_voting #############################################################
+### sub add_wrap ################################################################
 #
 #
-# add a voting (increment vote counter and log the vote data)
+# file lock, open, execute, close, unlock wrapper
+# for adding an empty entry
 #
 #
-# Params: $param - hash reference
-#                  (thread, posting, IP, time, ID)
+# Params: $gosub - sub reference (for execution)
+#         @param - params (for $gosub)
 #
 # Return: Status code (Bool)
 #
 #
 # Return: Status code (Bool)
 #
-sub r_add_voting {
-  my ($self, $h, $param) = @_;
-  my ($C, $TC, $TI) = ($h->{C}, $h->{TC}, $h->{TI});
-  my $pos = tell $TC;
-  my $block;
-  my $reclen = 4 * length pack 'L',0;
-  local $/="\012";
-  local $\;
-
-  while ($reclen == read $C, $block, $reclen) {
-    my $rest = <$C>;
-    chomp $rest;
-    my ($msg, $thread, $views, $votings) = unpack ('L4' => $block);
-
-    $param -> {posting} != $msg or do {
-      $rest = join ' ' => (length $rest ? $rest: (), join ';' => ($param->{time}, $param->{IP}, $param->{ID}));
-      $votings++;
-    };
+sub add_wrap {
+  my ($self, $gosub, @param) = @_;
+  my $status;
 
 
-    print $TC pack ('L4' => ($msg, $thread, $views, $votings)), $rest, $/;
-    print $TI pack ('L2' => $msg, $pos);
-    $pos = tell $TC;
+  unless (write_lock_file ($self->summaryfile)) {
+    violent_unlock_file ($self->summaryfile);
+    $self->set_error ('could not write-lock summary file '.$self->summaryfile);
+  }
+  else {
+    local *SUM;
+    unless (sysopen (SUM, $self->summaryfile, $O_BINARY | O_APPEND | O_CREAT | O_RDWR)) {
+      $self->set_error
+        ('could not open to read/write/append summary file '.$self->summaryfile);
+    }
+    else {
+      $status = $gosub -> (
+        $self,
+        \*SUM,
+        @param
+      );
+      unless (close SUM) {
+        $status=0;
+        $self->set_error('could not close summary file '.$self->summaryfile);
+      }
+    }
+    violent_unlock_file ($self->summaryfile) unless (write_unlock_file ($self->summaryfile));
   }
 
   }
 
-  1;
-}
-
-sub add_voting {
-  my $self = shift;
-  $self -> open_wrap (
-    \&r_add_voting,
-    @_
-  );
+  # return
+  $status;
 }
 
 }
 
-### sub open_wrap ##############################################################
+### sub vote_wrap ###############################################################
 #
 # file lock, open, execute, close, unlock wrapper
 #
 # file lock, open, execute, close, unlock wrapper
-# for writing into temp files
+# for adding a vote
 #
 # Params: $gosub - sub reference (for execution)
 #         @param - params (for $gosub)
 #
 # Return: Status code (Bool)
 #
 #
 # Params: $gosub - sub reference (for execution)
 #         @param - params (for $gosub)
 #
 # Return: Status code (Bool)
 #
-sub open_wrap {
-  my ($self, $gosub, @param) = @_;
+sub vote_wrap {
+  my ($self, $gosub, $param) = @_;
   my $status;
 
   my $status;
 
-  unless (write_lock_file ($self->temp_cachefile)) {
-    violent_unlock_file ($self->temp_cachefile);
-    $self->set_error ('could not write-lock temp cache file '.$self->temp_cachefile);
+  unless (write_lock_file ($self->summaryfile)) {
+    violent_unlock_file ($self->summaryfile);
+    $self->set_error ('could not write-lock summary file '.$self->summaryfile);
   }
   else {
   }
   else {
-    unless (write_lock_file ($self->temp_indexfile)) {
-      violent_unlock_file ($self->temp_indexfile);
-      $self->set_error ('could not write-lock temp index file '.$self->temp_indexfile);
+    local *S;
+    unless (sysopen (S, $self->summaryfile, O_RDWR | $O_BINARY)) {
+      $self->set_error ('could not open to read/write summary file '.$self->summaryfile);
     }
     else {
     }
     else {
-      unless (lock_file ($self->cachefile)) {
-        violent_unlock_file ($self->cachefile);
-        $self->set_error ('could not read-lock cache file '.$self->cachefile);
+      unless (-d $self->threaddir($param)) {
+        mkdir $self->threaddir($param)                     or return;
+      }
+      my $filename = $self->cachefile($param);
+
+      unless (write_lock_file ($filename)) {
+        violent_unlock_file ($filename);
+        $self->set_error ('could not write-lock cache file '.$filename);
       }
       else {
       }
       else {
-        unless (lock_file ($self->indexfile)) {
-          violent_unlock_file ($self->indexfile);
-          $self->set_error ('could not read-lock index file '.$self->indexfile);
+        local *CACHE;
+        unless (sysopen (CACHE, $filename, O_APPEND | O_CREAT | O_RDWR)) {
+          $self->set_error ('could not open to read/write/append cache file '.$filename);
         }
         else {
         }
         else {
-          local (*C, *TC, *TI);
-          unless (sysopen (C, $self->cachefile, O_RDONLY | $O_BINARY)) {
-            $self->set_error ('could not open to read cache file '.$self->cachefile);
-          }
-          else {
-            unless (sysopen (TC, $self->temp_cachefile, O_WRONLY | O_TRUNC | O_CREAT | $O_BINARY)) {
-              $self->set_error ('could not open to write temp cache file '.$self->temp_cachefile);
-            }
-            else {
-              unless (sysopen (TI, $self->temp_indexfile, O_WRONLY | O_TRUNC | O_CREAT | $O_BINARY)) {
-                $self->set_error ('could not open to write temp index file '.$self->temp_indexfile);
-              }
-              else {
-                $status = $gosub -> (
-                  $self,
-                  { C  => \*C,
-                    TC => \*TC,
-                    TI => \*TI
-                  },
-                  @param
-                );
-                unless (close TI) {
-                  $status=0;
-                  $self->set_error('could not close temp index file '.$self->temp_indexfile);
-                }
-              }
-              unless (close TC) {
-                $status=0;
-                $self->set_error('could not close temp cache file '.$self->temp_cachefile);
-              }
-            }
-            unless (close C) {
-              $status=0;
-              $self->set_error('could not close cache file '.$self->cachefile);
-            }
-            if ($status) {
-              unless (write_lock_file ($self->cachefile) and write_lock_file ($self->indexfile)) {
-                $status=0;
-                $self->set_error('could not write-lock cache or index file');
-              }
-              else {
-                unless (unlink $self->indexfile or !-f $self->indexfile) {
-                  $status=0;
-                  $self->set_error('could not unlink '.$self->indexfile);
-                }
-                else {
-                  unless (rename $self->temp_cachefile => $self->cachefile) {
-                    $status=0;
-                    $self->set_error('could not rename '.$self->temp_cachefile);
-                  }
-                  else {
-                    unless (rename $self->temp_indexfile => $self->indexfile) {
-                      $status=0;
-                      $self->set_error('could not rename '.$self->temp_indexfile);
-                    }
-                  }
-                }
-              }
-            }
+          $status = $gosub -> (
+            $self,
+            \*S,
+            \*CACHE,
+            $param
+          );
+          unless (close CACHE) {
+            $status=0;
+            $self->set_error('could not close cache file '.$filename);
           }
           }
-          violent_unlock_file ($self->indexfile) unless (unlock_file ($self->indexfile));
         }
         }
-        violent_unlock_file ($self->cachefile) unless (unlock_file ($self->cachefile));
+        violent_unlock_file ($filename) unless (write_unlock_file ($filename));
+      }
+      unless (close S) {
+        $status=0;
+        $self->set_error('could not close summary file '.$self->summaryfile);
       }
       }
-      violent_unlock_file ($self->temp_indexfile) unless (write_unlock_file ($self->temp_indexfile));
     }
     }
-    violent_unlock_file ($self->temp_cachefile) unless (write_unlock_file ($self->temp_cachefile));
+    violent_unlock_file ($self->summaryfile) unless (write_unlock_file ($self->summaryfile));
   }
 
   # return
   $status;
 }
 
   }
 
   # return
   $status;
 }
 
-### sub read_wrap ##############################################################
+### sub purge_wrap ##############################################################
 #
 # file lock, open, execute, close, unlock wrapper
 #
 # file lock, open, execute, close, unlock wrapper
-# for reading
+# for garbage collection
 #
 # Params: $gosub - sub reference (for execution)
 #         @param - params (for $gosub)
 #
 # Return: Status code (Bool)
 #
 #
 # Params: $gosub - sub reference (for execution)
 #         @param - params (for $gosub)
 #
 # Return: Status code (Bool)
 #
-sub read_wrap {
+sub purge_wrap {
   my ($self, $gosub, @param) = @_;
   my $status;
   my ($self, $gosub, @param) = @_;
   my $status;
+  my $filename = $self -> summaryfile . '.temp';
 
 
-  unless (lock_file ($self->cachefile)) {
-    violent_unlock_file ($self->cachefile);
-    $self->set_error ('could not read-lock cache file '.$self->cachefile);
+  unless (write_lock_file ($self->summaryfile)) {
+    violent_unlock_file ($self->summaryfile);
+    $self->set_error ('could not write-lock summary file '.$self->summaryfile);
   }
   else {
   }
   else {
-    unless (lock_file ($self->indexfile)) {
-      violent_unlock_file ($self->indexfile);
-      $self->set_error ('could not read-lock index file '.$self->indexfile);
+    local *TEMP;
+    unless (sysopen (TEMP, $filename, O_CREAT | O_WRONLY | O_TRUNC | $O_BINARY)) {
+      $self->set_error ('could not open to write temp summary file '.$filename);
     }
     else {
     }
     else {
-      local (*C, *I);
-      unless (sysopen (C, $self->cachefile, O_RDONLY | $O_BINARY)) {
-        $self->set_error ('could not open to read cache file '.$self->cachefile);
+      local *S;
+      unless (sysopen (S, $self->summaryfile, O_RDONLY | $O_BINARY)) {
+        $self->set_error ('could not open to read summary file '.$self->summaryfile);
       }
       else {
       }
       else {
-        unless (sysopen (I, $self->indexfile, O_RDONLY | $O_BINARY)) {
-          $self->set_error ('could not open to read index file '.$self->indexfile);
+        $status = $gosub -> (
+          $self,
+          \*S,
+          \*TEMP,
+          @param
+        );
+        unless (close S) {
+          $status = 0;
+          $self->set_error('could not close summary file '.$self->summaryfile);
         }
         }
-        else {
-          $status = $gosub -> (
-            $self,
-            { C  => \*C,
-              I => \*I,
-            },
-            @param
-          );
-          unless (close I) {
-            $status=0;
-            $self->set_error('could not close index file '.$self->indexfile);
-          }
-        }
-        unless (close C) {
+      }
+      unless (close TEMP) {
+        $status=0;
+        $self->set_error('could not close temp summary file '.$filename);
+      }
+      if ($status) {
+        unless (rename $filename => $self->summaryfile) {
           $status=0;
           $status=0;
-          $self->set_error('could not close cache file '.$self->cachefile);
+          $self->set_error('could not rename temp summary file '.$filename);
         }
       }
         }
       }
-      violent_unlock_file ($self->indexfile) unless (unlock_file ($self->indexfile));
     }
     }
-    violent_unlock_file ($self->cachefile) unless (unlock_file ($self->cachefile));
+    violent_unlock_file ($self->summaryfile) unless (write_unlock_file ($self->summaryfile));
   }
 
   # return
   $status;
 }
 
   }
 
   # return
   $status;
 }
 
-### sub write_wrap ##############################################################
+### sub pick_wrap ###############################################################
 #
 # file lock, open, execute, close, unlock wrapper
 #
 # file lock, open, execute, close, unlock wrapper
-# for reading
+# for picking a posting
 #
 # Params: $gosub - sub reference (for execution)
 #         @param - params (for $gosub)
 #
 # Return: Status code (Bool)
 #
 #
 # Params: $gosub - sub reference (for execution)
 #         @param - params (for $gosub)
 #
 # Return: Status code (Bool)
 #
-sub write_wrap {
+sub pick_wrap {
+  my ($self, $gosub, $filename, @param) = @_;
+  my $status;
+
+  unless (lock_file ($filename)) {
+    violent_unlock_file ($filename);
+    $self->set_error ('could not lock cache file '.$filename);
+  }
+  else {
+    local *CACHE;
+    unless (sysopen (CACHE, $filename, O_RDONLY)) {
+      $self->set_error ('could not open to read cache file '.$filename);
+    }
+    else {
+      $status = $self -> read_wrap (
+        $gosub,
+        \*CACHE,
+        @param
+      );
+      unless (close CACHE) {
+        $status=0;
+        $self->set_error('could not close cache file '.$filename);
+      }
+    }
+    violent_unlock_file ($filename) unless (unlock_file ($filename));
+  }
+
+  # return
+  $status;
+}
+
+### sub read_wrap ###############################################################
+#
+# file lock, open, execute, close, unlock wrapper
+# for reading of summary file
+#
+# Params: $gosub - sub reference (for execution)
+#         @param - params (for $gosub)
+#
+# Return: Status code (Bool)
+#
+sub read_wrap {
   my ($self, $gosub, @param) = @_;
   my $status;
 
   my ($self, $gosub, @param) = @_;
   my $status;
 
-  unless (write_lock_file ($self->temp_cachefile)) {
-    violent_unlock_file ($self->temp_cachefile);
-    $self->set_error ('could not write-lock temp cache file '.$self->temp_cachefile);
+  unless (lock_file ($self->summaryfile)) {
+    violent_unlock_file ($self->summaryfile);
+    $self->set_error ('could not read-lock summary file '.$self->summaryfile);
   }
   else {
   }
   else {
-    unless (write_lock_file ($self->cachefile)) {
-      violent_unlock_file ($self->cachefile);
-      $self->set_error ('could not write-lock cache file '.$self->cachefile);
+    local *S;
+    unless (sysopen (S, $self->summaryfile, O_RDONLY | $O_BINARY)) {
+      $self->set_error ('could not open to read summary file '.$self->summaryfile);
     }
     else {
     }
     else {
-      unless (lock_file ($self->indexfile)) {
-        violent_unlock_file ($self->indexfile);
-        $self->set_error ('could not read-lock index file '.$self->indexfile);
+      $status = $gosub -> (
+        $self,
+        \*S,
+        @param
+      );
+      unless (close S) {
+        $status=0;
+        $self->set_error('could not close summary file '.$self->summaryfile);
       }
       }
-      else {
-        local (*C, *I);
-        unless (sysopen (C, $self->cachefile, O_RDWR | $O_BINARY)) {
-          $self->set_error ('could not open to read/write cache file '.$self->cachefile);
-        }
-        else {
-          unless (sysopen (I, $self->indexfile, O_RDONLY | $O_BINARY)) {
-            $self->set_error ('could not open to read index file '.$self->indexfile);
-          }
-          else {
-            $status = $gosub -> (
-              $self,
-              { C  => \*C,
-                I => \*I,
-              },
-              @param
-            );
-            unless (close I) {
-              $status=0;
-              $self->set_error('could not close index file '.$self->indexfile);
-            }
-          }
-          unless (close C) {
-            $status=0;
-            $self->set_error('could not close cache file '.$self->cachefile);
-          }
-        }
-        violent_unlock_file ($self->indexfile) unless (unlock_file ($self->indexfile));
+    }
+    violent_unlock_file ($self->summaryfile) unless (unlock_file ($self->summaryfile));
+  }
+
+  # return
+  $status;
+}
+
+### sub mod_wrap ################################################################
+#
+# file lock, open, execute, close, unlock wrapper
+# for modification of summary file
+#
+# Params: $gosub - sub reference (for execution)
+#         @param - params (for $gosub)
+#
+# Return: Status code (Bool)
+#
+sub mod_wrap {
+  my ($self, $gosub, @param) = @_;
+  my $status;
+
+  unless (write_lock_file ($self->summaryfile)) {
+    violent_unlock_file ($self->summaryfile);
+    $self->set_error ('could not write-lock summary file '.$self->summaryfile);
+  }
+  else {
+    local *S;
+    unless (sysopen (S, $self->summaryfile, O_RDWR | $O_BINARY)) {
+      $self->set_error ('could not open to read/write summary file '.$self->summaryfile);
+    }
+    else {
+      $status = $gosub -> (
+        $self,
+        \*S,
+        @param
+      );
+      unless (close S) {
+        $status=0;
+        $self->set_error('could not close summary file '.$self->summaryfile);
       }
       }
-      violent_unlock_file ($self->cachefile) unless (write_unlock_file ($self->cachefile));
     }
     }
-    violent_unlock_file ($self->temp_cachefile) unless (write_unlock_file ($self->temp_cachefile));
+    violent_unlock_file ($self->summaryfile) unless (write_unlock_file ($self->summaryfile));
   }
 
   # return
   }
 
   # return
Converted CVS repository of SELF's XML based forum

patrick-canterino.de