Revision 2 (by moose, 2006/07/10 13:21:14) initial import
 
package Session::DB;
#use base 'Tie::Hash';

use strict;
use warnings;

sub new {
	my $this = shift;
	my $class = ref($this) || $this;
	my %arg = @_;
	my $self = \%arg;
	bless $self, $class;
   
   return $self;
}

# TIEHASH classname, LIST
sub TIEHASH {
   my $class = shift;
   my $self = new $class, @_;
   
   $self->{path} ||= '/tmp';
   die "Session path exists, but is not a directory.\n" if -e $self->{path} && !-d _;

   $self->{data} = {};
   
   return $self;
}

# FETCH this, key
sub FETCH {
   my $self = shift;
   my $key = shift;
   
   local *FH;
	my $file = $self->{path}."/".$key.".ses";
   if(!open(FH,$file)) {
      die "Failed to open '" .$file. "': $!\n";
   }

   my $data = join '', <FH>;
   $self->{data}{$key} = $data; #Storable::thaw($data);

   close FH;

	chmod 0766, $file;
   return $self->{data}{$key};
}

# STORE this, key, value
sub STORE {
   my $self = shift;
   my $key  = shift;
   my $val  = shift;
   
   local *FH;
   if(!open(FH,">".$self->{path}."/".$key.".ses")) {
      die "Failed to open '" .$self->{path}."/".$key. ".ses': $!\n";
   }

   my $data = $val; #Storable::freeze($val);
   $self->{data}{$key} = $data;

   print FH $data;
   
   close FH;
}

# DELETE this, key
sub DELETE {
   my $self = shift;
   my $key = shift;

   my $file = $self->{path}."/".$key.".ses";
   if(-e $file && !-f _) {
      die "Attempt to delete session failed, '$file' is not a plain file.";
   }

   unlink $file;
   delete $self->{data}{$key};
}

# CLEAR this
sub CLEAR {
   my $self = shift;
   local *DIR;
   
   opendir DIR, $self->{path} or die "failed to open session path for listing: $!\n";
   for my $ent (readdir DIR) {
      if($ent =~ /^(.*).ses$/) {
         delete $self->{data}{$1};
         unlink $self->{path}."/".$ent;
      }
   }
   closedir DIR;
}

# EXISTS this, key
sub EXISTS {
   my $self = shift;
   my $key = shift;
   
   my $file = $self->{path}."/".$key.".ses";
   if(-e $file && -f _) {
      return 1;
   }

   return 0;
}

sub refresh_keys {
   my $self = shift;
   
   opendir DIR, $self->{path} or die "failed to open session path for listing: $!\n";
   $self->{list} = [];
   for my $ent (readdir DIR) {
      next if $ent =~ /^\./;
      if($ent =~ /^(.*).ses$/) {
         push @{$self->{list}}, $1;
      }
   }
   closedir DIR;
}

# FIRSTKEY this
sub FIRSTKEY {
   my $self = shift;
   
   refresh_keys($self);
   $self->{li} = 1;

   return $self->{list}[0];
}

# NEXTKEY this, lastkey
sub NEXTKEY {
   my $self = shift;
   #my $lkey = shift; not needed
   
   my $ret = $self->{list}[$self->{li}];
   ++$self->{li};

   return $ret;
}

# SCALAR this
sub SCALAR {
   my $self = shift;
   
   return scalar @{$self->{list}};
}

# DESTROY this
sub DESTROY {
   my $self = shift;
   
   # anything needed here?
}

# UNTIE this
sub UNTIE {
   my $self = shift;
   
   # anything needed here?
}

package Session;
#use warnings;
#use strict;
use CGI::Carp qw/fatalsToBrowser/;


use CGI::Cookie;

use Fcntl;   # For O_RDWR, O_CREAT, etc.
use Digest::MD5 qw/md5_hex/;
use Storable qw/freeze thaw/;
$Storable::forgive_me = 1;

our $NAME = 'SESSIONID';

our %sessions;

sub exists : method { return exists $sessions{shift()->{'id'}}; }
sub thaw_session  {
   my $self = shift;
#   print "Thawed: " . $self->{'db'} . "<br>\n";
   $self->{'db'} = thaw($sessions{$self->{'id'}});
}

sub freeze_session {
   my $self = shift;
   $sessions{$self->{'id'}} = freeze($self->{'db'});
#   print "Froze: " . length($sessions{$self->id()}) . " bytes<br>\n";
}

sub name {
   my $cls = shift;
   my $ref = ref($cls) eq 'Session';
   my $val = shift;
   my $old = $ref ? ( exists $cls->{'NAME'} ? $cls->{'NAME'} : $NAME ) : $NAME;

   if(defined $val) {
      if($ref) {
         $cls->{'NAME'} = $val;
      } else {
         $NAME = $val;
      }
   }

   return $old;
}

sub new {
	my $this = shift;
	my $class = ref($this) || $this;
	my %arg = @_;
	my $self = \%arg;
	bless $self, $class;

   my %cookies = get_cookies();
   $self->{'cookies'} = \%cookies;
   if(!exists $cookies{$self->name()}) {
      $self->{'id'} = gen_id();
   } else {
      $self->{'id'} = $cookies{$self->name()};
   }

	my $path = $self->{'BASE_PATH'} . "/sessions/";
	if(!-e $path) {
		mkdir $path;
	}

	if(!tied(%sessions)) {
		tie(%sessions, 'Session::DB', path => $path) or die "failed to tie session db: '" .  $path . "': $!\n";
		if(!tied(%sessions)) {
			print "OMFG!<br>\n";
		}
	}

#	use Data::Dumper;
#	print Dumper(\%sessions) . "\n";

   if(exists $sessions{$self->{'id'}}) {
#		print "THAW BIATCH\n";
   	$self->{'db'} = thaw($sessions{$self->{'id'}}); #thaw_session();
   } else {
      $self->{'db'} = {
         _META => {
            created => time(),
            accessed => time(),
            expires => _time_alias('+1y'),
            'keys' => { },
         },

      };
		$sessions{$self->{'id'}} = Storable::freeze($self->{'db'});
   }

	untie(%sessions);

   if(time() > $self->ctime() + $self->etime()) {
#      print "sess: initial clear?<br>\n";
      $self->{'db'} = {};
   } else {
      $self->_expire_keys();
   }

   $self->{'db'}{'_META'}{'accessed'} = time();

	return $self;
}

sub clear {
   my $self = shift;
   my $todo = shift;
   if(ref($todo) eq 'ARRAY') {
      for(@$todo) {
			next if /^_META$/;
         delete $self->{'db'}{$_};
         delete $self->{'db'}{'_META'}{'keys'}{$_} if exists $self->{'db'}{'_META'}{'keys'}{$_};
      }
   } else {
      delete $self->{'db'}{$todo};
      delete $self->{'db'}{'_META'}{'keys'}{$todo} if exists $self->{'db'}{'_META'}{'keys'}{$todo};
   }
}

sub cookie {
   my $self = shift;

   return new CGI::Cookie(-name => $self->name(), -value => $self->id(), -expires => "+1y")
}

sub gen_id()
{
   my $id;
   for(1..40) { $id .= chr(rand(time)&255); }
   return md5_hex($id);
}

sub key_exists {
	my $self = shift;
	my $key = shift;

	return exists $self->{'db'}{$key};
}

sub key {
   my $self = shift;
#   return keys %{$self->{'db'}} if wantarray;

	my $key = shift;
	my $val = shift;

  # print "key: '$key' => '$val' :: " . join(', ', caller()) . "<br>\n";
   if(!exists $self->{'db'}{$key} && !defined $val) {
      return undef;
   }

   if(!exists $self->{'db'}{'_META'}{'keys'}{$key}) {
     # print "add meta: '$key'<br>\n";
      $self->{'db'}{'_META'}{'keys'}{$key} = { };
   }

   $self->{'db'}{'_META'}{'keys'}{$key}{'accessed'} = time();

	my $prev = exists $self->{'db'}{$key} ? $self->{'db'}{$key} : undef;

   if(exists $self->{'db'}{'_META'}{'keys'}{$key}{'expires'} && $self->{'db'}{'_META'}{'keys'}{$key}{'expires'} + $self->{'db'}{'_META'}{'keys'}{$key}{'created'} <= time()) {
      delete $self->{'db'}{'_META'}{'keys'}{$key};
      delete $self->{'db'}{$key};
      return undef;
   }

	if(defined $val) {
		$self->{'db'}{$key} = $val;
#      print "setting $key: $val<br>\n";
	} else {
#      print "getting $key: $prev<br>\n";
   }

	return $prev;
}

sub ref { return shift->{'db'}; }
sub id { return shift->{'id'}; }
sub atime { return shift->{'db'}{'_META'}{'accessed'}; }
sub etime { return shift->{'db'}{'_META'}{'expires'}; }
sub ctime { return shift->{'db'}{'_META'}{'created'}; }

sub expire {
   my $self = shift;
   my $oexp = $self->{'db'}{'_META'}{'expires'};

   $self->{'db'}{'_META'}{'expires'} = _time_alias($_[0]) if defined $_[0];

   return $oexp;
}

sub expire_key {
   my $self = shift;
   my $key = shift;
   my $oexp = ((exists $self->{'db'}{'_META'}{'keys'}{$key}) ? $self->{'db'}{'_META'}{'keys'}{$key}{'expires'} : undef);

   if($_[0] == -1) {
      delete $self->{'db'}{'_META'}{'keys'}{$key}{'expires'};
   } else {
		$self->{'db'}{'_META'}{'keys'}{$key}{'created'} = time();
      $self->{'db'}{'_META'}{'keys'}{$key}{'expires'} = _time_alias($_[0]) if defined $_[0];
   }

   return $oexp;
}

sub _expire_keys {
   my $self = shift;

   for my $key (keys %{$self->{'db'}{'_META'}{'keys'}}) {
      next unless exists $self->{'db'}{'_META'}{'keys'}{$key}{'expires'};

      delete $self->{'db'}{'_META'}{'keys'}{$key} if(
         $self->atime() >= ($self->{'db'}{'_META'}{'keys'}{$key}{'created'} + $self->{'db'}{'_META'}{'keys'}{$key}{'expires'}));
   }
}

# internal
sub get_cookies {
   return map { my ($k,$v) = split '=', $_; $k => $v } split(';', $ENV{"HTTP_COOKIE"});
}

DESTROY {
   my $self = shift;
   if(time() > $self->etime() + $self->ctime()) {
      $self->{'db'} = undef;
#      print "deleted session: " . $self->id() . "<br>\n";
   }

#use Data::Dumper;
#print Dumper($self->{'db'}) . "\n";

#   print "saving session: " . $self->id() . "<br>\n";

	my $path = $self->{'BASE_PATH'} . "/sessions/";
	if(!-e $path) {
		mkdir $path;
	}

	tie(%sessions, 'Session::DB', path => $path) or die "failed to tie session db: $!\n";
		if(defined $self->{'db'}) {
			my $ref = $self->{'db'};
		   $sessions{$self->{'id'}} = Storable::freeze($ref);
		} else {
			delete $sessions{$self->{'id'}};
		}
	untie %sessions;
#   print "saved.<br>\n"
}

# internal
# borowed from CGI::Session
sub _time_alias {
    my ($str) = @_;

    # If $str consists of just digits, return them as they are
    if ( $str =~ m/^\d+$/ ) {
        return $str;
    }

    my %time_map = (
        s           => 1,
        m           => 60,
        h           => 3600,
        d           => 86400,
        w           => 604800,
        M           => 2592000,
        y           => 31536000
    );

    my ($koef, $d) = $str =~ m/^([+-]?\d+)(\w)$/;

    if ( defined($koef) && defined($d) ) {
        return $koef * $time_map{$d};
    }
}

1;