view release on metacpan or  search on metacpan

lib/Apache/Session/DBMS.pm  view on Meta::CPAN

#############################################################################
#
# Apache::Session::DBMS
# Apache persistent user sessions using DBMS
# Copyright(c) 2005 Asemantics S.r.l.
# Alberto Reggiori (alberto@asemantics.com)
# Distribute under a BSD license (see LICENSE file in main dir)
#
############################################################################

package Apache::Session::DBMS;

use strict;
use vars qw(@ISA $VERSION $incl);

$VERSION = '0.32';
@ISA = qw(Apache::Session);

$incl = {};

use Apache::Session;
use Apache::Session::Lock::Null;
use Apache::Session::Store::DBMS;
use Apache::Session::Generate::DBMS;

use Apache::Session::Serialize::DBMS::Storable;

sub populate {
	my $self = shift;

	$self->{object_store} = new Apache::Session::Store::DBMS $self;
	$self->{lock_manager} = new Apache::Session::Lock::Null $self;
	$self->{generate}     = \&Apache::Session::Generate::DBMS::generate;
	$self->{validate}     = \&Apache::Session::Generate::DBMS::validate;

	if( exists $self->{args}->{Serialize} ) {
		my $ser   = "Apache::Session::Serialize::$self->{args}->{Serialize}";

		if (!exists $incl->{$ser}) {
			eval "require $ser" || die $@;
			eval '$incl->{$ser}->[0] = \&' . $ser . '::serialize'   || die $@;
			eval '$incl->{$ser}->[1] = \&' . $ser . '::unserialize' || die $@;

			$self->{serialize}    = $incl->{$ser}->[0];
			$self->{unserialize}  = $incl->{$ser}->[1];
			};
	} else {
		# Storable is the default
		$self->{serialize}    = \&Apache::Session::Serialize::DBMS::Storable::serialize;
		$self->{unserialize}  = \&Apache::Session::Serialize::DBMS::Storable::unserialize;
		};

	$self->{ isObjectPerKey } = (	( defined $self->{data}->{_session_id} ) and
					(	$self->{data}->{_session_id} =~ m|^\s*dbms://([^:]+):(\d+)/([^\s]+)| or
						$self->{data}->{_session_id} =~ m|^\s*dbms://([^/]+)/([^\s]+)| ) ) ? 1 : 0 ;

	return $self;
	};

# override perltie part
sub FETCH {
	my $self = shift;
	my $key  = shift;

        if( $self->{isObjectPerKey} ) {
		&{$self->{unserialize}}( $self, $self->{object_store}->{dbh}->FETCH( $key ) ); # yep we do unserialize it each time
        } else {
		$self->SUPER::FETCH( $key );
		};
	};

sub STORE {
	my $self  = shift;
	my $key   = shift;
	my $value = shift;

	if( $self->{isObjectPerKey} ) {
		$self->{object_store}->{dbh}->STORE( $key, &{$self->{serialize}}( $self, $value ) ); # yep we do serialize it each time
        } else {
		$self->SUPER::STORE( $key, $value );
		};
	};

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

	if( $self->{isObjectPerKey} ) {
		$self->{object_store}->{dbh}->DELETE( $key );
        } else {
		$self->SUPER::DELETE( $key );
		};
	};