Apache::Session::Counted - Session management via a File::CounterFile

 tie %s, 'Apache::Session::Counted', $sessionid, {
                                Directory => <root of directory tree>,
                                DirLevels => <number of dirlevels>,
                                CounterFile => <filename for File::CounterFile>,
                                AlwaysSave => <boolean>,
                                HostID => <string>,
                                HostURL => <callback>,
                                Timeout => <seconds>,
                                                 }

  my(@t) = localtime;
  tie %session, 'Apache::Session::Counted', $sid,
  {
   Directory => ...,
   DirLevels => ...,
   CounterFile => sprintf("/some/dir/%04d-%02d-%02d", $t[5]+1900,$t[4]+1,$t[3])
  };

  use File::CounterFile;
  $c=File::CounterFile->new("/usr/local/apache/data/perl/sessiondemo/counter");
  $c->lock;
  $c-- while $c>0;
  $c->unlock;

package Apache::Session::Counted;
use Apache::Session::Serialize::Storable;

use strict;
use vars qw(@ISA);
@ISA = qw(Apache::Session);
use vars qw($VERSION $RELEASE_DATE);
$VERSION = sprintf "%d.%03d", q$Revision: 1.118 $ =~ /(\d+)\.(\d+)/;
$RELEASE_DATE = q$Date: 2002/04/15 12:39:07 $;

use Apache::Session 1.50;
use File::CounterFile;

{
  package Apache::Session::CountedStore;
  use Symbol qw(gensym);

  use strict;

  sub new { bless {}, shift }

  # write. Note that we alias insert and update
  sub update {
    my $self    = shift;
    my $session = shift;
    my $storefile = $self->storefilename($session);
    my $fh = gensym;
    unless ( open $fh, ">$storefile\0" ) {
      warn qq{A:S:Counted: Could not open file $storefile for writing: $!
Maybe you haven't initialized the storage directory with
  use Apache::Session::Counted;
  Apache::Session::CountedStore->tree_init("$session->{args}{Directory}","$session->{args}{DirLevels}");
I'm trying to band-aid by creating this directory};
      require File::Basename;
      my $dir = File::Basename::dirname($storefile);
      require File::Path;
      File::Path::mkpath($dir);
      warn "A:S:Counted: mkdir on directory $dir successfully done.";
    }
    if ( open $fh, ">$storefile\0" ) {
      print $fh $session->{serialized}; # $fh->print might fail in some perls
      close $fh;
    } else {
      die "Giving up. Could not open file $storefile for writing: $!";
    }
  }
  *insert = \&update;

  # retrieve
  sub materialize {
    my $self    = shift;
    my $session = shift;
    my $sessionID = $session->{data}{_session_id} or die "Got no session ID";
    my($host) = $sessionID =~ /(?:([^:]+)(?::))/;
    my($content);

    if ($host &&
        $session->{args}{HostID} &&
        $session->{args}{HostID} ne $host
       ) {
      # warn sprintf("configured hostID[%s]host from argument[%s]",
      #              $session->{args}{HostID},
      #              $host);
      my $surl;
      if (exists $session->{args}{HostURL}) {
        $surl = $session->{args}{HostURL}->($host,$sessionID);
      } else {
        $surl = sprintf "http://%s/?SESSIONID=%s", $host, $sessionID;
      }
      # warn "surl[$surl]";
      if ($surl) {
        require LWP::UserAgent;
        require HTTP::Request::Common;
        my $ua = LWP::UserAgent->new;
        $ua->timeout($session->{args}{Timeout} || 10);
        my $req = HTTP::Request::Common::GET $surl;
        my $result = $ua->request($req);
        if ($result->is_success) {
          $content = $result->content;
        } else {
          $content = Storable::nfreeze {};
        }
      } else {
        $content = Storable::nfreeze {};
      }
      $session->{serialized} = $content;
      return;
    }

    my $storefile = $self->storefilename($session);
    my $fh = gensym;
    if ( open $fh, "<$storefile\0" ) {
      local $/;
      $session->{serialized} = <$fh>;
      close $fh or die $!;
      if ($content && $content ne $session->{serialized}) {
        warn "A:S:Counted: content and serialized are NOT equal";
        require Dumpvalue;
        my $dumper = Dumpvalue->new;
        $dumper->set(unctrl => "quote");
        warn sprintf "A:S:Counted: content[%s]serialized[%s]",
            $dumper->stringify($content),
                $dumper->stringify($session->{serialized});
      }
    } else {
      warn "A:S:Counted: Could not open file $storefile for reading: $!";
      $session->{data} = {};
      $session->{serialized} = $session->{serialize}->($session);
    }
  }

  sub remove {
    warn "A:S:Counted: remove not implemented"; # doesn't make sense
                                                # for our concept of a
                                                # session
    return;

    my $self    = shift;
    my $session = shift;
    my $storefile = $self->storefilename($session);
    unlink $storefile or
        warn "A:S:Counted: Object $storefile does not exist in the data store";
  }

  sub tree_init {
    my $self    = shift;
    my $dir = shift;
    my $levels = shift;
    my $n = 0x100 ** $levels;
    warn "A:S:Counted: Creating directory $dir
  and $n subdirectories in $levels level(s)\n";
    warn "A:S:Counted: This may take a while\n" if $levels>1;
    require File::Path;
    $|=1;
    my $feedback =
        sub {
          $n--;
          printf "\r$n directories left             " unless $n % 256;
          print "\n" unless $n;
        };
    File::Path::mkpath($dir);
    make_dirs($dir,$levels,$feedback); # function for speed
  }

  sub make_dirs {
    my($dir, $levels, $feedback) = @_;
    $levels--;
    for (my $i=0; $i<256; $i++) {
      my $subdir = sprintf "%s/%02x", $dir, $i;
      -d $subdir or mkdir $subdir, 0755 or die "Couldn't mkdir $subdir: $!";
      $feedback->();
      make_dirs($subdir, $levels, $feedback) if $levels;
    }
  }

  sub storefilename {
    my $self    = shift;
    my $session = shift;
    die "The argument 'Directory' for object storage must be passed as an argument"
       unless defined $session->{args}{Directory};
    my $dir = $session->{args}{Directory};
    my $levels = $session->{args}{DirLevels} || 0;
    # here we depart from TreeStore:
    my $sessionID = $session->{data}{_session_id} or die "Got no session ID";
    my($host,$file) = $sessionID =~ /(?:([^:]+)(?::))?([\da-f]+)/;
    die "Too short ID part '$file' in session ID'" if length($file)<8;
    while ($levels) {
      $file =~ s|((..){$levels})|$1/|;
      $levels--;
    }
    "$dir/$file";
  }
}

# Counted is locked by definition
sub release_all_locks {
  return;
}

*get_lock_manager = \&release_all_locks;
*release_read_lock = \&release_all_locks;
*release_write_lock = \&release_all_locks;
*acquire_read_lock = \&release_all_locks;
*acquire_write_lock = \&release_all_locks;

sub TIEHASH {
  my $class = shift;

  my $session_id = shift;
  my $args       = shift || {};

  my $self = {
              args         => $args,

              data         => { _session_id => $session_id },
              # we always *have* read and write lock and need not care
              lock         => Apache::Session::READ_LOCK|Apache::Session::WRITE_LOCK,
              status       => 0,
              lock_manager => undef,
              generate     => undef,
              serialize    => \&Apache::Session::Serialize::Storable::serialize,
              unserialize  => \&Apache::Session::Serialize::Storable::unserialize,
            };

  bless $self, $class;
  $self->{object_store} = Apache::Session::CountedStore->new($self);

  #If a session ID was passed in, this is an old hash.
  #If not, it is a fresh one.

  if (defined $session_id) {
    $self->make_old;
    $self->restore; # calls materialize and unserialize via Apache::Session
    if (
        exists $self->{data} &&
        exists $self->{data}{_session_id} &&
        defined $self->{data}{_session_id} && # protect agains unini warning
        $session_id eq $self->{data}{_session_id}
       ) {
      # Fine. Validated. Kind of authenticated.
      # ready for a new session ID, keeping state otherwise.
      $self->make_modified if $self->{args}{AlwaysSave};
    } else {
      # oops, somebody else tried this ID, don't show him data.
      delete $self->{data};
      $self->make_new;
    }
  }
  # if we have no counterfile, we cannot generate an ID, that's OK:
  # this session will not need to be written.
  $self->{data}->{_session_id} = $self->generate_id() if
      $self->{args}{CounterFile};
  # no make_new here, session-ID doesn't count as data

  return $self;
}

sub generate_id {
  my $self = shift;
  # wants counterfile
  my $cf = $self->{args}{CounterFile} or
      die "Argument CounterFile needed in the attribute hash to the tie";
  my $c;
  eval { $c = File::CounterFile->new($cf,"0"); };
  if ($@) {
    warn "A:S:Counted: Counterfile problem, trying to repair...";
    if (-e $cf) {
      warn "A:S:Counted: Retrying after removing $cf.";
      unlink $cf; # May fail. stupid enough that we are here.
      $c = File::CounterFile->new($cf,"0");
    } else {
      require File::Basename;
      my $dirname = File::Basename::dirname($cf);
      my @mkdir;
      while (! -d $dirname) {
        push @mkdir, $dirname;
        $dirname = File::Basename::dirname($dirname);
      }
      while (@mkdir) {
        my $dirname = pop @mkdir;
        mkdir $dirname, 0755 or die "Couldn't mkdir $dirname. Please create it with appropriate permissions";
      }
      $c = File::CounterFile->new($cf,"0");
    }
    warn "A:S:Counted: Counterfile problem successfully reapired.";
  }
  my $rhexid = sprintf "%08x", $c->inc;
  my $hexid = scalar reverse $rhexid; # optimized for treestore. Not
                                      # everything in one directory

  # we have entropy as bad as rand(). Typically not very good.
  my $password = sprintf "%08x%08x", rand(0xffffffff), rand(0xffffffff);

  if (exists $self->{args}{HostID}) {
    return sprintf "%s:%s_%s", $self->{args}{HostID}, $hexid, $password;
  } else {
    return $hexid . "_" . $password;
  }
}

1;