interactive/gms/SKBB/httpd/wwwroot/tts/TTXCache.pm

package TTXCache;
#
# This is an optional Cache module for
# Trouble Ticket Express help desk package.
# http://www.troubleticketexpress.com
#
# COPYRIGHT: 2005, United Web Coders
# http://www.unitedwebcoders.com
#
# $Revision: 156 $
# $Date: 2006-05-05 03:02:47 -0400 (Fri, 05 May 2006) $
#

$TTXCache::VERSION='2.22';
BEGIN {
  $TTXCache::REVISION = '$Revision: 156 $';
  if ($TTXCache::REVISION =~ /(\d+)/) {
    $TTXCache::REVISION = $1;
  }
};
use strict;
use TTXCommon;
use TTXData;
use Digest::MD5 qw(md5_hex);
my $useencode = 0;
#
# constants
#
my $cacheidxfn = 'cache.cgi';
my $cachedir = 'cache';
my $maxage = 180; # seconds
my $nolog = 1;
my $serial;

# ==================================================================== signature

sub signature {
  my $query = $_[0];
  my $str;
  foreach my $key (sort $query->param) {
    $str .= $key.'='.$query->param($key);
  }
  if (!$useencode) {
    eval "use Encode";
    $useencode = 1 if $@ eq undef;
  }
  if ($useencode) {
    return md5_hex(Encode::encode_utf8($str));
  }
  my $sig = '-';
  eval '$sig = md5_hex($str)';
  return $sig if $@ eq undef && $sig ne '-';
  return undef;
}
# ======================================================================== store

sub store {
  my ($cfg, $query, $pg, $pgsig) = @_;
  my $pgsid = $query->param('sid');
  $pgsid = 0 if $pgsid eq undef;
  my $pgcmd = $query->param('cmd');
  my $idxfn = $cfg->get('basedir')."/$cacheidxfn";
  if (! -e $idxfn) {
    if (open(IDX, ">$idxfn")) {
      flock(IDX,2);
      print IDX "0\n";
      $serial = 0;
      close IDX;
    } else {
      return;
    }
  }
  if (! -d $cfg->get('basedir')."/$cachedir") {
    mkdir $cfg->get('basedir')."/$cachedir", 0777;
  }
  if (open(IDX, "+<$idxfn")) {
    flock IDX,2;
    my @pages;
    my @buff = <IDX>;
    chomp @buff;
    my $curtm = time();
    my $purgetm = $curtm - $maxage;
    my $sn = shift @buff;
    if ($sn ne undef && $serial ne undef && $sn ne $serial) {
      close IDX;
      return;
    }
    foreach my $line (@buff) {
      my ($tm, $cmd, $sid, $sig, $n) = split(/-/, $line);
      if ($tm < $purgetm || "$cmd-$sid-$sig" eq "$pgcmd-$pgsid-$pgsig") {
        unlink $cfg->get('basedir')."/$cachedir/$tm-$n.cgi";
        next;
      }
      push (@pages, "$tm-$cmd-$sid-$sig-$n");
    }
    my $n = 0;
    while (-e $cfg->get('basedir')."/$cachedir/$curtm-$n.cgi") {
      ++$n;
      return if $n > 100; # endless loop control, just to make sure
    }
    push (@pages, "$curtm-$pgcmd-$pgsid-$pgsig-$n");
    if (!open(PG, ">".$cfg->get('basedir')."/$cachedir/$curtm-$n.cgi")) {
      close IDX;
      return;
    }
    seek IDX,0,0;
    print IDX "$serial\n";
    foreach my $p (@pages) {
      print IDX "$p\n";
    }
    truncate(IDX, tell (IDX));
    close IDX;
    print PG $pg;
    close PG;
  }
}
# ========================================================================== hit

sub hit {
  my ($cfg, $query) = @_;
  my $pgsig = signature($query);
  my $pgsid = $query->param('sid');
  $pgsid = 0 if $pgsid eq undef;
  my $pgcmd = $query->param('cmd');
  my $idxfn = $cfg->get('basedir')."/$cacheidxfn";
  if (open(IDX, "$idxfn")) {
    my @buff = <IDX>;
    close IDX;
    chomp @buff;
    my $curtm = time();
    my $purgetm = $curtm - $maxage;
    $serial = shift @buff;
    foreach my $line (@buff) {
      my ($tm, $cmd, $sid, $sig, $n) = split(/-/, $line);
      next if $tm < $purgetm || "$cmd-$sid-$sig" ne "$pgcmd-$pgsid-$pgsig";
      return "$tm-$n";
    }
  }
  return 0;
}

# ========================================================================= page

sub page {
  my ($cfg, $pgid) = @_;
  if (open(PG, $cfg->get('basedir')."/$cachedir/$pgid.cgi")) {
    my @buff = <PG>;
    close PG;
    return join('', @buff);
  }
  return undef;
}
# ======================================================================== purge

sub purge {
  my $cfg = TTXData::get('CONFIG');
  my $idxfn = $cfg->get('basedir')."/$cacheidxfn";
  if (open(IDX, "+<$idxfn")) {
    flock IDX,2;
    my @buff = <IDX>;
    chomp @buff;
    foreach my $line (@buff) {
      my ($tm, $cmd, $sid, $sig, $n) = split(/-/, $line);
      unlink $cfg->get('basedir')."/$cachedir/$tm-$n.cgi";
    }
    seek IDX,0,0;
    ++$serial;
    print IDX "$serial\n";
    truncate(IDX, tell (IDX));
    close IDX;
  }
  logit('P');
}
# ======================================================================== logit

sub logit {
  return if $nolog;
  my $cfg = TTXData::get('CONFIG');
  my $fn = $cfg->get('basedir')."/ttxcachelog.txt";
  if (open(CACHELOG, ">>$fn")) {
    flock(CACHELOG,2);
    seek(CACHELOG, 0, 2);
    print CACHELOG time()."|$_[0]\n";
    close CACHELOG;
  }
}

1;
#