File Coverage

memcache.pm

Criterion	Covered	Total	%
statement	21	44	47.7
branch	4	16	25.0
condition	1	2	50.0
subroutine	7	11	63.6
pod	5	5	100.0
total	38	78	48.7

# Storage Driver backend for memcached

package CGI::Session::Driver::memcache;
use strict;

#use Carp;

use CGI::Session::Driver;

our $sess_space = "sessions";
our $memd_connerror = "Need a connection handle to live memcached\n";
our @ISA        = ('CGI::Session::Driver');
our $VERSION    = '0.10';
our $trace = 0;
BEGIN {
    # keep historical behavior
    no strict 'refs';
    # WHY would we want unbuffered output ? Having this can mess up mod_perl runtime.
    #
    #$| = 1;
    # Introspect %INC to see if CGI::Session::Driver::memcache has been
    # loaded from expected install-location (Patch %INC if necessary)
    #if (!$INC{'CGI/Session/Driver/memcache.pm'}) {...}
}
#sub new {}

# Developer info:
# - CGI::Session::new (as class / constructor method, forwards args to load)
#  - CGI::Session::load() (Create self-stub, parse_dsn(), _load_pluggables())


# CGI::Session::Driver init method to be called
# merely validate a connection to memcached exists
sub init {
    my $self = shift;
    #DEBUG:print CGI::header('text/plain');
    #DEBUG:require Data::Dumper;print(Dumper($self));
    # Require Handle to memcached connection
    my $memd  = $self->{'Handle'} || die($memd_connerror);
    if ($trace) {
       #die("Vary: Using Connection: $memd\n");
    }
    # Must add ?
    # Problem: Because of shallow copy does not persist
    #$self->{'_DSN'}->{'driver'} = 'memcache';
    # TODO: Optionally grab a connection to memcached
    # Cache::memcache->new('servers' => [$self->{'servers'}]);
    # Success (see Driver.pm)
    #$self->{'_STATUS'} = 55;
    return 1;
}
# Combine Session space and ID for truly unique ID
# TODO: Add self to have session instance specific $sess_space
sub _useid {
   if ($trace) {
      require Data::Dumper;
      my @ci = caller(1);
      #print(Data::Dumper::Dumper(\@ci));
      print("$ci[3] : useid: $sess_space:$_[0]\n");}
   # Allow instace specific ID-space prefix ???
   # my $use_space = $_[1] && $_[1]->{'space'} ? $_[1]->{'space'} : $sess_space;
   "$sess_space:$_[0]";
}

# Retrieve Session (will be passed to deserializer)
sub retrieve {
    my ($self, $sid) = @_;
    my $memd = $self->{'Handle'};
    if ($trace) {print("retrieve: Using $memd\n");}
    if (!$memd) {die($memd_connerror);}
    # Return Session to be de-serialized
    my $r = $memd->get(_useid($sid));
    if (!$r) {return(0);}
    return $r;
}

# Store serialized session
sub store {
   my ($self, $sid, $datastr) = @_;
   my $memd = $self->{'Handle'};
   if (!$memd) {die($memd_connerror);}
   my $ok = $memd->set(_useid($sid),  $datastr);
   #if (!$ok) {$self->set_error( "store(): \$dbh->do failed " . $dbh->errstr );}
   return $ok ? 1 : 0;
}

# Remove Session
sub remove {
   my ($self, $sid) = @_;
   my $memd = $self->{'Handle'};
   if (!$memd) {die($memd_connerror);}
   $memd->delete(_useid($sid));
   return 1;
}

# execute $coderef for each session id passing session id as the first and the only
# argument
sub traverse {
   my ($self, $coderef) = @_;
   die("Traversing unsupported for memcached (for obvious security reasons)");
}
sub DESTROY {}
1;
__END__