File Coverage

blib/lib/CGI/Scribe.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

package CGI::Scribe;

$SESSION_LENGTH = 16;
$CGI::Scribe::DEBUG = 0;

use strict;
use vars qw( $VERSION $AUTOLOAD $SESSION_LENGTH $SRAND );
use Carp;
use Storable qw( freeze thaw );
use MD5;
use CGI::Cookie;

require 5.004; # Depends on srand() supplying good seed

$VERSION = '0.03';
$SRAND = 0;

sub new {
  my $class   = shift;
  my($session, $attr) = @_;

  $class = ref $class || $class;
  bless my $self = {}, $class;

  $self->initialize;

  if ($session) {
    croak "invalid session id $session" unless $session =~ /^[-A-Za-z0-9]+$/;
    $self->{session} = $session;
  }

  @$self{ keys %$attr } = values %$attr if $attr;

  $self->_fetch_cookie if ref $self->{cookie};
  $self->_new_session unless $self->{session};

  $self;
}

sub initialize {
  my $self = shift;

  $self->{session}        = undef;
  $self->{cookie}         = undef;
  $self->{secret}         = 'eaven-hay and-ay e-thay earth-ay';
  $self->{session_length} = $SESSION_LENGTH;
  $self->{is_new}         = 0;
  $self->{_fetched}       = 0;
  $self->{_dirty}         = 0;
  $self->{_data}          = {};
  $self->{_cookie_data}   = {};
  $self->{debug}          = $CGI::Scribe::DEBUG;

  $self->{autoload}       = {
                              session_length => 1,
                              session        => 1,
                              secret         => 1,
                              debug          => 1,
                              is_new         => 1,
                            };
}

sub version { $VERSION }

sub _debug {
  my $self = shift;
  my($msg, $level) = @_;

  $level ||= 1;
  $msg = "[$self->{session}] $msg" if $self->{session};
  warn ref $self, " $msg\n" if $self->{debug} >= $level;
}

sub _fetch_cookie {
  my $self = shift;

  my($mac, $session, $frozen) = $self->{cookie}->value;
  return undef unless $mac and $session;
  # If the session is defined but doesn't match the cookie, then ignore cookie
  return undef if $self->{session} and $self->{session} ne $session;

  # Check the Message Authentication Code (MAC)
  my $mac_check = MD5->hexhash($self->{secret} .
                    MD5->hexhash(join '', $self->{secret}, $session, $frozen));
  return undef unless $mac eq $mac_check;

  # Thaw the session data
  $self->{session} = $session;
  # Convert the hex data to binary
  my $thawed = eval { thaw( pack 'H*', $frozen ) };
  croak "error thawing session in cookie: $@" if $@ or ref $thawed ne 'HASH';

  foreach my $key (keys %$thawed) {
    $self->{_cookie_data}{$key} = 1; # keep track of what was in cookie
    $self->{_data}{ $key } = $thawed->{ $key };
  }

  if ($self->{debug}) {
    $self->_debug('fetched from cookie', 1);
    foreach my $key (keys %$thawed) {
      $self->_debug("cookie data: $key=$thawed->{$key}", 2);
    }
  }

  1;
}

sub _new_session {
  my $self = shift;
  my $seed = shift;

  # Perl 5.004 and later automatically call srand() with a "good"
  # seed, if it hasn't been called already.  However, it seems to
  # happen at compile-time such that child processes generate
  # identical sequences.  We've added a flag so that we make sure to
  # call srand() on the first invocation of this method.
  srand unless $SRAND++;

  $self->{session} = join '-',
                       substr(MD5->hexhash($self->{secret} . rand() . $seed),
                              0, $self->{session_length}), time;

  $self->_debug('generated', 1) if $self->{debug};

  $self->{_fetched} = 1;
  $self->{_dirty}   = 0;
  $self->{is_new}   = 1;
  $self->{session};
}

sub _fetch {
  my $self = shift;

  $self->{_fetched} = 1;
  $self->_debug('fetched from server', 1) if $self->{debug};
}

sub _store {
  my $self = shift;

  $self->{_dirty} = 0;
  $self->_fetch unless $self->{_fetched};
  $self->_debug('stored on server', 1) if $self->{debug};
}

sub clear {
  my $self = shift;

  $self->{_data}    = {};
  $self->{_dirty}   = 1;
  $self->{_fetched} = 1;
  $self->_debug('cleared', 1) if $self->{debug};
}

sub param {
  my $self = shift;

  # If no arguments, return list of keys
  unless(@_) {
    $self->_fetch unless $self->{_fetched};
    return keys %{ $self->{_data} };
  }

  # If just one parameter named is supplied, return the value
  if (@_ == 1) {
    return $self->{_data}{ $_[0] }
      if exists $self->{_data}{ $_[0] } or $self->{_fetched};
    $self->_fetch;
    return $self->{_data}{ $_[0] };
  }

  # If more than one parameter, they want to set value(s)
  $self->{_dirty} = 1;
  $self->_fetch unless $self->{_fetched};
  my %hash = @_;
  @{ $self->{_data} }{ keys %hash } = values %hash;

  1;
}

sub exists {
  my $self = shift;

  return undef unless @_;
  return exists $self->{_data}{ $_[0] }
    if exists $self->{_data}{ $_[0] } or $self->{_fetched};
  $self->_fetch;
  exists $self->{_data}{ $_[0] };
}

sub delete_param {
  my $self = shift;

  return unless @_;

  # We must make sure we've fetched, to protect ourselves from reading
  # the deleted value(s) later
  $self->_fetch unless $self->{_fetched};
  $self->{_dirty} = 1;

  foreach my $param (@_) {
    delete $self->{_data}{$param};
  }
}

sub cookie {
  my $self = shift;

  # If a hash reference is passed, it specifies all of the param names
  # to place in the cookie.  If a list is passed, we include those
  # names *along with* whatever was previously stored in the cookie.
  my %params = map { $_ => 1 }
               (ref $_[0] eq 'ARRAY'
                  ? @{ $_[0] }
                  : keys %{ $self->{_cookie_data} }, @_);
  my @params = grep { $self->exists( $_ ) } keys %params;

  unless ($self->{cookie}) {
    $self->{cookie} = new CGI::Cookie( -name => 'session' );
  }

  my $frozen = eval {
                 freeze( { map { $_ => $self->param($_) } @params } );
               };
  croak $@ if $@;
  $frozen = unpack 'H*', $frozen;
  my $mac = MD5->hexhash($self->{secret} .
              MD5->hexhash(join '', $self->{secret}, $self->{session},
                           $frozen));
  $self->{cookie}->value([ $mac, $self->{session}, $frozen ]);
  $self->{cookie};
}

sub DESTROY {
  my $self = shift;

  $self->_store if $self->{_dirty};
}

sub AUTOLOAD {
  my $self = shift;
  my $type = ref($self) || croak "autoload: $self is not an object";
  my $name = $AUTOLOAD;

  $name =~ s/.*://;
  return if $name eq 'DESTROY';
  croak "unknown autoload name '$name'" unless exists $self->{autoload}{$name};
  return (@_ ? $self->{$name} = shift : $self->{$name});
}

sub TIEHASH { shift()->new( @_ ) }
sub STORE   { shift()->param( @_ ) }
sub DELETE  { shift()->delete_param( @_ ) }
sub CLEAR   { shift()->clear( @_ ) }
sub EXISTS  { shift()->exists( @_ ) }

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

  return $self->{session} if $key eq '_session';
  $self->param( $key );
}

sub FIRSTKEY {
  my $self = shift;

  $self->_fetch unless $self->{_fetched};
  my $reset = keys %{ $self->{_data} };
  return each %{ $self->{_data} };
}

sub NEXTKEY { each %{ shift()->{_data} } }


1;

__END__