From: ndparker <>
Date: Wed, 25 Apr 2001 18:24:41 +0000 (+0000)
Subject: Cache.pm added
X-Git-Url: https://git.p6c8.net/selfforum.git/commitdiff_plain/12d929a433173569d20424b6322bfe9e178f235d

Cache.pm added
---

diff --git a/selfforum-cgi/shared/Posting/Cache.pm b/selfforum-cgi/shared/Posting/Cache.pm
new file mode 100644
index 0000000..42bbeb5
--- /dev/null
+++ b/selfforum-cgi/shared/Posting/Cache.pm
@@ -0,0 +1,649 @@
+package Posting::Cache;
+
+################################################################################
+#                                                                              #
+# File:        shared/Posting/Cache.pm                                         #
+#                                                                              #
+# Authors:     André Malo <nd@o3media.de>, 2001-04-21                          #
+#                                                                              #
+# Description: Views/Voting Cache class                                        #
+#                                                                              #
+################################################################################
+
+use strict;
+
+use Fcntl;
+use Lock qw(:ALL);
+
+my $O_BINARY = eval "O_BINARY";
+$O_BINARY = 0 if ($@);
+
+### sub new ####################################################################
+#
+# Constructor
+#
+# Params: $filename - full qualified cache file name
+#
+# Return: Posting::Cache object
+#
+sub new {
+  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;
+}
+
+### sub clear_error ############################################################
+#
+# clear verbal error data
+#
+# Params: ~none~
+#
+# Return: ~none~
+#
+sub clear_error {
+  my $self = shift;
+
+  $self -> {verb_error} = undef;
+
+  return;
+}
+
+sub error {$_[0]->{verb_error}}
+
+sub set_error {
+  my $self = shift;
+
+  $self -> {verb_error} = +shift;
+
+  return;
+}
+
+### sub set_file ###############################################################
+#
+# set cache file name
+#
+# Params: $filename - full qualified cache file name
+#
+sub set_file {
+  my ($self, $filename) = @_;
+
+  $self -> {cachefile} = $filename;
+
+  return;
+}
+
+sub cachefile {$_[0] -> {cachefile}}
+sub indexfile {$_[0] -> cachefile . '.index'}
+sub temp_cachefile {$_[0] -> cachefile . '.temp'}
+sub temp_indexfile {$_[0] -> indexfile . '.temp'}
+
+### sub find_pos ($$) ##########################################################
+#
+# find position in cache file
+# (binary search in index file)
+#
+# Params: $handle  - index file handle
+#         $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;
+
+  $end == int $end                                         or return;
+
+  my ($start, $buf, $current) = 0;
+
+  while ($start <= $end) {
+    seek $I, ($current = ($start + $end) >> 1)*$reclen, 0  or return;
+    $reclen == read ($I, $buf, $reclen)                    or return;
+
+    my ($num, $found) = unpack 'L2',$buf;
+
+    if ($num == $posting) {
+      return $found;
+    }
+    elsif ($num < $posting) {
+      $start = $current+1
+    }
+    else {
+      $end   = $current-1
+    }
+  }
+
+  return;
+}
+
+### sub add_view ###############################################################
+#
+# increment the views-counter
+#
+# Params: ~none~
+#
+# Return: Status code (Bool)
+#
+sub r_add_view {
+  my ($self, $h, $param) = @_;
+  my ($C, $I) = ($h->{C}, $h->{I});
+  my $reclen  = 4 * length pack 'L', 0;
+  my $pos;
+  defined ($pos = find_pos $I, $param->{posting})                or return;
+
+  my $buf;
+  seek $C, $pos, 0                                               or return;
+  read ($C, $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;
+
+  1;
+}
+
+sub add_view {
+  my ($self, $param) = @_;
+
+  $self -> write_wrap (
+    \&r_add_view,
+    $param
+  );
+}
+
+### sub pick ###################################################################
+#
+# read information of one posting
+#
+# Params: $param - hash reference
+#                  (thread, posting)
+#
+# Return: hash reference or false
+#
+sub r_pick {
+  my ($self, $h, $param) = @_;
+  my ($C, $I) = ($h->{C}, $h->{I});
+  my $reclen  = 4 * length pack 'L', 0;
+  my ($buf, $pos);
+  local $/="\012";
+
+  defined($pos = find_pos $I, $param->{posting})      or return;
+
+  seek $C, $pos, 0                                    or return;
+  read ($C, $buf, $reclen) == $reclen                 or return;
+
+  my ($posting, $thread, $views, $votings) = unpack 'L4', $buf;
+  $buf = <$C>; chomp $buf;
+  $self -> {pick} = {
+    views   => $views,
+    votings => $votings,
+    voteRef  => {
+      map {
+        map {
+          $_->[2] => {
+            time => $_->[0] || 0,
+            IP   => $_->[1] || 0
+          }
+        } [split /;/]
+      } split ' ' => $buf
+    }
+  };
+
+  # looks good
+  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
+#
+# Params: ~none~
+#
+# 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;
+
+    seek $C, $pos, 0                                 or return;
+    read ($C, $buf, $creclen) == $creclen            or return;
+
+    my ($posting, $thread, $views, $votings) = unpack 'L4', $buf;
+    $hash{$thread} = {} unless $hash{$thread};
+    $hash{$thread} -> {$posting} = {
+      views   => $views,
+      votings => $votings
+    };
+  }
+
+  $self -> {summary} = \%hash;
+
+  # looks good
+  1;
+}
+
+sub summary {
+  my $self = shift;
+
+  $self -> read_wrap (\&r_summary)
+    ? $self -> {summary}
+    : return;
+}
+
+### sub repair_cache ###########################################################
+#
+# check on cache consistance and repair if broken
+#
+# Params: ~none~
+#
+# Return: sucess 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;
+  }
+
+  1;
+}
+
+sub repair_cache {
+  my $self = shift;
+
+  return unless ($self->cachefile and $self->indexfile);
+  return 1 if (-f $self->cachefile and -f $self->indexfile);
+
+  unless (-f $self->cachefile) {
+    return if (-f $self->indexfile);
+
+    local *FILE;
+    return unless (open FILE, '>'.$self->cachefile);
+    return unless (close FILE);
+    return unless (open FILE, '>'.$self->indexfile);
+    return unless (close FILE);
+
+    release_file ($self->cachefile);
+    release_file ($self->indexfile);
+    release_file ($self->temp_indexfile);
+    release_file ($self->temp_cachefile);
+
+    return 1;
+  }
+
+  $self -> open_wrap (\&r_repair_cache);
+}
+
+### sub add_posting ############################################################
+#
+# add an empty cache entry of a posting
+#
+# Params: $param - hash reference
+#                  (thread, posting)
+#
+# Return: Status code (Bool)
+#
+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";
+  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;
+  }
+  continue {
+    my $rest = <$C>;
+    chomp $rest;
+    print $TC $block. $rest. $/;
+    print $TI pack ('L2' => $msg, $pos);
+    $pos = tell $TC;
+  }
+  unless ($ins) {
+    print $TC pack('L4' => $param->{posting}, $param->{thread}, 0, 0), $/;
+    print $TI pack('L2' => $param->{posting}, $pos);
+  }
+
+  1;
+}
+
+sub add_posting {
+  my $self = shift;
+  $self -> open_wrap (
+    \&r_add_posting,
+    @_
+  );
+}
+
+### sub add_voting #############################################################
+#
+# add a voting (increment vote counter and log the vote data)
+#
+# Params: $param - hash reference
+#                  (thread, posting, IP, time, ID)
+#
+# 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++;
+    };
+
+    print $TC pack ('L4' => ($msg, $thread, $views, $votings)), $rest, $/;
+    print $TI pack ('L2' => $msg, $pos);
+    $pos = tell $TC;
+  }
+
+  1;
+}
+
+sub add_voting {
+  my $self = shift;
+  $self -> open_wrap (
+    \&r_add_voting,
+    @_
+  );
+}
+
+### sub open_wrap ##############################################################
+#
+# file lock, open, execute, close, unlock wrapper
+# for writing into temp files
+#
+# Params: $gosub - sub reference (for execution)
+#         @param - params (for $gosub)
+#
+# Return: Status code (Bool)
+#
+sub open_wrap {
+  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);
+  }
+  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);
+    }
+    else {
+      unless (lock_file ($self->cachefile)) {
+        violent_unlock_file ($self->cachefile);
+        $self->set_error ('could not read-lock cache file '.$self->cachefile);
+      }
+      else {
+        unless (lock_file ($self->indexfile)) {
+          violent_unlock_file ($self->indexfile);
+          $self->set_error ('could not read-lock index file '.$self->indexfile);
+        }
+        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);
+                    }
+                  }
+                }
+              }
+            }
+          }
+          violent_unlock_file ($self->indexfile) unless (unlock_file ($self->indexfile));
+        }
+        violent_unlock_file ($self->cachefile) unless (unlock_file ($self->cachefile));
+      }
+      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));
+  }
+
+  # return
+  $status;
+}
+
+### sub read_wrap ##############################################################
+#
+# file lock, open, execute, close, unlock wrapper
+# for reading
+#
+# Params: $gosub - sub reference (for execution)
+#         @param - params (for $gosub)
+#
+# Return: Status code (Bool)
+#
+sub read_wrap {
+  my ($self, $gosub, @param) = @_;
+  my $status;
+
+  unless (lock_file ($self->cachefile)) {
+    violent_unlock_file ($self->cachefile);
+    $self->set_error ('could not read-lock cache file '.$self->cachefile);
+  }
+  else {
+    unless (lock_file ($self->indexfile)) {
+      violent_unlock_file ($self->indexfile);
+      $self->set_error ('could not read-lock index file '.$self->indexfile);
+    }
+    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);
+      }
+      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->cachefile) unless (unlock_file ($self->cachefile));
+  }
+
+  # return
+  $status;
+}
+
+### sub write_wrap ##############################################################
+#
+# file lock, open, execute, close, unlock wrapper
+# for reading
+#
+# Params: $gosub - sub reference (for execution)
+#         @param - params (for $gosub)
+#
+# Return: Status code (Bool)
+#
+sub write_wrap {
+  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);
+  }
+  else {
+    unless (write_lock_file ($self->cachefile)) {
+      violent_unlock_file ($self->cachefile);
+      $self->set_error ('could not write-lock cache file '.$self->cachefile);
+    }
+    else {
+      unless (lock_file ($self->indexfile)) {
+        violent_unlock_file ($self->indexfile);
+        $self->set_error ('could not read-lock index file '.$self->indexfile);
+      }
+      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->cachefile) unless (write_unlock_file ($self->cachefile));
+    }
+    violent_unlock_file ($self->temp_cachefile) unless (write_unlock_file ($self->temp_cachefile));
+  }
+
+  # return
+  $status;
+}
+
+# keep 'require' happy
+#
+1;
+
+#
+#
+### end of Posting::Cache ######################################################
\ No newline at end of file