File Coverage

blib/lib/CAM/Session.pm

Criterion	Covered	Total	%
statement	31	171	18.1
branch	6	48	12.5
condition	4	24	16.6
subroutine	8	30	26.6
pod	18	18	100.0
total	67	291	23.0

package CAM::Session;

=head1 NAME

CAM::Session - DBI and cookie CGI session state maintenance

=head1 LICENSE

Copyright 2005 Clotho Advanced Media, Inc.,

This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=head1 COMPARISON

CGI::Session is a better module than this one, but this one is a
little easier to use.  If you are starting from scratch, use
CGI::Session.  If you are using CAM::App, then we recommend this
module for session management since CAM::App takes care of all of the
details for you.

See README for more detail.

=head1 SYNOPSIS

  use CAM::Session;
  use DBI;
  my $dbh = DBI->connect(...);
  CAM::Session->setDBH($dbh);

  my $session = new CAM::Session();
  $session->printCookie();

  $session->set("username", $username);
  ...
  $session->get("username", $username);
  $session->delete("username");

To periodically clean up the session table, run a script like the
following as a daily scheduled task:

  use CAM::Session;
  use DBI;
  my $dbh = DBI->connect(...) || die "no dbh";
  CAM::Session->setDBH($dbh);
  CAM::Session->setExpiration(24*60*60); # older than one day
  CAM::Session->clean();

=head1 DESCRIPTION

CAM::Session interacts with the CGI program, the database and the
visitor's cookie to create a storage space for persistent data.

=cut

#----------------

require 5.005_62;
use strict;
use warnings;
use Carp;
use CGI::Cookie;
use CGI;
use DBI;

our @ISA = qw();
our $VERSION = '1.03';

# global settings, can be overridden for the whole class or for
# individual instances.
our $global_expiration = 24*60*60;  # one day, in seconds
our $global_dbh = undef;
our $global_dbTablename = "session";
our $global_cookieName = "session";
our $global_keylength = 16;

our $colname_key  = "session_key";
our $colname_time = "session_time";
our $colname_data = "session_data";

#----------------

=head1 FUNCTIONS

=over 4

=cut

#----------------

=item new

=item new DBIHANDLE

Create a new session object, retrieving the session ID from the
cookie, if any.  If the database handle is not set here, it must have
been set previously via the setDBH() class method.

=cut

sub new
{
   my $pkg = shift;
   my $dbh = shift; # optional

   my $self = bless({
      data => {},
      expiration => $global_expiration,
      dbTablename => $global_dbTablename,
      cookieName => $global_cookieName,
      dbh => $dbh || $global_dbh,
      needsSave => 0,
   }, $pkg);

   if (!$self->{dbh})
   {
      &carp("No database connection has been specified.  Please use ".$pkg."::setDBH()");
      return undef;
   }
   if (!ref($self->{dbh}) || ref($self->{dbh}) !~ /^(DBI|DBD)\b/)
   {
      my $type = ref($self->{dbh}) ? ref($self->{dbh}) : "scalar";
      &carp("The DBH object is not a valid DBI/DBD connection: $type");
      return undef;
   }

   my %cookies = CGI::Cookie->fetch();
   if (exists $cookies{$self->{cookieName}})
   {
      # existing session
      $self->{id} = $cookies{$self->{cookieName}}->value;
      if (!$self->loadSessionData())
      {
         $self->_newSession();
      }
   }
   else
   {
      $self->_newSession();
   }

   return $self;
}
#----------------

=item DESTROY

Saves the session data on object destruction, if needed.

=cut

sub DESTROY
{
   my $self = shift;
   if ($self->{needsSave})
   {
      $self->saveSessionData();
   }
   return $self;
}
#----------------

=item getID

=cut

sub getID
{
   my $self = shift;
   return $self->{id};
}
#----------------

=item getCookie

Return a cookie that indicates this session.  Any arguments are passed
to CGI::Cookie::new().  Use this, for example, with

    print CGI->header(-cookie => $session->getCookie);

=cut

sub getCookie
{
   my $self = shift;

   my $id = $self->getID();
   my $cookie = CGI::Cookie->new(-name => $self->{cookieName},
                                 -value => $id,
                                 -path => "/",
                                 @_);
   return $cookie;
}
#----------------

=item printCookie

Outputs a cookie that indicates this session.  Use this just before
"print CGI->header()", for example.

=cut

sub printCookie
{
   my $self = shift;

   my $cookie = $self->getCookie(@_);
   print "Set-Cookie: $cookie\n";
}
#----------------

=item getAll

Retrieve a hash of all of the session data.

=cut

sub getAll
{
   my $self = shift;

   if (wantarray)
   {
      return (%{$self->{data}});
   }
   else
   {
      return (scalar keys %{$self->{data}});
   }
}
#----------------

=item get FIELDNAME

Retrieve a field from the session storage.

=cut

sub get
{
   my $self = shift;
   my $fieldName = shift;

   return undef if (!defined $fieldName);
   return $self->{data}->{$fieldName};
}
#----------------

=item set FIELDNAME, VALUE, FIELDNAME, VALUE, ...

Record a field in the session storage.  If autoSave is on (it is
by default) this value is immediately recorded in the database.

=cut

sub set
{
   my $self = shift;

   while (@_ > 0)
   {
      my $fieldName = shift;
      my $value = shift;

      return undef if (!defined $fieldName);

      $self->{data}->{$fieldName} = $value;
   }
   $self->{needsSave} = 1;
   return $self;
}
#----------------

=item delete FIELDNAME, FIELDNAME, ...

Remove one or more fields from the session storage.  If autoSave is on
(it is by default) this change is immediately recorded in the
database.

=cut

sub delete
{
   my $self = shift;

   foreach my $fieldName (@_)
   {
      delete $self->{data}->{$fieldName};
   }
   $self->{needsSave} = 1;
   return $self;
}
#----------------

=item clear

Calls delete() on every field in the session storage.

=cut

sub clear
{
   my $self = shift;
   return $self->delete(keys %{$self->{data}});
}
#----------------

=item loadSessionData

Retrieve the session data from storage.  This function is called by
new() so it is only needed if you need to reload the data for some
reason.

Returns a boolean indicating the success or failure of the load
operation.

=cut

sub loadSessionData
{
   my $self = shift;

   my $id = $self->getID();
   return undef if (!$id);
   my $dbrow = $self->_getSession($id);
   return undef if (!$dbrow);

   $self->{data} = $self->_explode($dbrow->{$colname_data});
   if (!$self->{data})
   {
      $self->{data} = {};
      return undef;
   }
   $self->{needsSave} = 0;
   return $self;
}
#----------------

=item saveSessionData

Write the session data to permanent storage.  This function is called
by the set() method. so it is only needed if you have turned off the
autoSave feature.

Returns a boolean indicating the success or failure of the save
operation.

=cut

sub saveSessionData
{
   my $self = shift;

   my $id = $self->getID();
   return undef if (!$id);
   my $data = $self->_implode($self->{data});
   $data = "" if (!defined $data);
   my $dbh = $self->{dbh};
   my $result = $dbh->do("update $$self{dbTablename} set " .
                         "$colname_data=" . $dbh->quote($data) . "," .
                         "$colname_time=now() " .
                         "where $colname_key='$id'");

   return undef if ((!$result) || $result == 0);
   return $self;
}
#----------------

=item isNewSession

Returns true if this session was newly created (as opposed to a repeat
visitor)

=cut

sub isNewSession
{
   my $self = shift;
   return $self->{newsession};
}
#----------------

# PRIVATE FUNCTION
sub _newSession
{
   my $self = shift;

   $self->{id} = undef;

   my $dbh = $self->{dbh};
   my $tries = 0;
   # Loop until we get an unused ID, but give up if it takes too long
   while ($tries++ < 20)
   {
      my $id = $self->_newID();
      my $sth = $dbh->prepare("select count(*) from $$self{dbTablename} " .
                              "where $colname_key=?");
      $sth->execute($id);
      my ($matches) = $sth->fetchrow_array();
      $sth->finish();

      if ($matches == 0)
      {
         $dbh->do("insert into $$self{dbTablename} set " .
                  "$colname_key='$id',$colname_time=now()");
         $self->{id} = $id;
         $self->{newsession} = 1;
         last;
      }
   }
   return $self;
}

# PRIVATE FUNCTION
sub _getSession
{
   my $self = shift;
   my $id = shift;

   return undef if (!$id);

   my $dbh = $self->{dbh};
   my $sth = $dbh->prepare("select *" .
                           (defined $self->{expiration} ?
                            ",date_add(now(), interval -$$self{expiration} second) as expires "
                            : "") .
                           "from $$self{dbTablename} " .
                           "where $colname_key=?");
   $sth->execute($id);
   my $row = $sth->fetchrow_hashref();
   $sth->finish();

   return undef if (!$row);

   if (defined $self->{expiration})
   {
      $row->{$colname_time} =~ s/\D//g;
      $row->{expires} =~ s/\D//g;

      if ($row->{$colname_time} lt $row->{expires})
      {
         $dbh->do("delete from $$self{dbTablename} " .
                  "where $colname_key=" . $dbh->quote($self->{cachekey}));
         return undef;
      }
   }

   return $row;
}
#----------------

=item setDBH DBI_HANDLE

Set the global database handle for this package.  Use like this:

  CAM::Session->setDBH($dbh);

=cut

sub setDBH
{
   my $pkg = shift; # unused
   my $val = shift;
   $global_dbh = $val;
}
#----------------

=item setExpiration SECONDS

Set the duration for the session content.  If the session is older
than the specified time, a new session will be created.  The default
expiration is unlimited (set solely by the visitor's cookie
expiration).  This is a class method

Use like this:

  CAM::Session->setExpiration($seconds);

=cut

sub setExpiration
{
   my $pkg = shift; # unused
   my $val = shift;
   $global_expiration = $val;
}
#----------------

=item setTableName NAME

Set the name of the database table that is used for the session
storage.  This is a class method.

Use like this:

  CAM::Session->setTableName($name);

=cut

sub setTableName
{
   my $pkg = shift; # unused
   my $val = shift;
   $global_dbTablename = $val;
}
#----------------

=item setCookieName NAME

Set the name of the cookie that is used for the recording the session.
This is a class method.

Use like this:

  CAM::Session->setCookieName($name);

=cut

sub setCookieName
{
   my $pkg = shift; # unused
   my $val = shift;
   $global_cookieName = $val;
}
#----------------


# PRIVATE FUNCTION
sub _implode
{
   my $self = shift;
   my $H_data = shift;

   # Treat the hash like an array.  The keys and values are treated
   # identically.
   my @escaped = (%$H_data);
   foreach (@escaped)
   {
      $_ = "" if (!defined $_);
      $_ = CGI::escape($_);
   }
   return join(",", @escaped);
}

# PRIVATE FUNCTION
sub _explode
{
   my $self = shift;
   my $implosion = shift;

   $implosion = "" if (!defined $implosion);

   # The split limit of -1 prevents trailing blank fields from being omitted
   my @fields = split /,/, $implosion, -1;
   if (@fields %2 != 0)
   {
      &carp("not an even number of fields in imploded data");
      return undef;
   }
   foreach (@fields)
   {
    $_ = CGI::unescape($_);
   }
   return {@fields};
}

# PRIVATE FUNCTION
sub _newID
{
   my $self = shift;

   require Digest::MD5;
   # Copied from CGI::Session::ID::MD5
   my $md5 = Digest::MD5->new();
   $md5->add($$ , time() , rand(9999) );
   return substr($md5->hexdigest(), 0, $global_keylength);
}
#----------------

=item setup

=item setup DBIHANDLE, TABLENAME

Create a database table for storing sessions.  This is not
intended to be called often, if ever.  This is a class method.

=cut

sub setup
{
   my $pkg = shift; # unused
   my $dbh = shift || $global_dbh;
   my $tablename = shift || $global_dbTablename;

   $dbh->do("create table if not exists $tablename (" .
            "$colname_key char($global_keylength) primary key not null," .
            "$colname_time timestamp," .
            "$colname_data mediumtext)");
}
#----------------

=item clean

=item clean DBIHANDLE, TABLENAME, SECONDS

Cleans out all records older than the specified number of seconds.
This is a class method.

=cut

sub clean
{
   my $pkg = shift; # unused
   my $dbh = shift || $global_dbh;
   my $tablename = shift || $global_dbTablename;
   my $seconds = shift || $global_expiration;

   return $dbh->do("delete from $tablename " .
                   "where $colname_time < " .
                   "date_add(now(),interval -$seconds second)");
}


1;
__END__