File Coverage

blib/lib/CGI/Session/ExpireSessions.pm

Criterion	Covered	Total	%
statement	64	100	64.0
branch	17	58	29.3
condition	3	20	15.0
subroutine	11	15	73.3
pod	3	5	60.0
total	98	198	49.4

package CGI::Session::ExpireSessions;

# Name:
#	CGI::Session::ExpireSessions.
#
# Documentation:
#	POD-style documentation is at the end. Extract it with pod2html.*.
#
# Reference:
#	Object Oriented Perl
#	Damian Conway
#	Manning
#	1-884777-79-1
#	P 114
#
# Note:
#	o Tab = 4 spaces || die.
#
# Author:
#	Ron Savage
#	Home page: http://savage.net.au/index.html
#
# Licence:
#	Australian copyright (c) 2004 Ron Savage.
#
#	All Programs of mine are 'OSI Certified Open Source Software';
#	you can redistribute them and/or modify them under the terms of
#	The Artistic License, a copy of which is available at:
#	http://www.opensource.org/licenses/index.html

use strict;
use warnings;

require 5.005_62;

require Exporter;

use Carp;
use CGI::Session;
use File::Spec;

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use CGI::Session::ExpireSessions ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(

) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(

);
our $VERSION = '1.13';

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

# Preloaded methods go here.

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

# Encapsulated class data.

{
	my(%_attr_data) =
	(
		_cgi_session_dsn	=> undef,
		_dbh				=> '',
		_delta				=> 2 * 24 * 60 * 60, # Seconds.
		_dsn_args			=> undef,
		_table_name			=> 'sessions',
		_temp_dir			=> '/tmp',
		_time				=> time(),
		_verbose			=> 0,
	);

	sub _check_expiry
	{
		my($self, $D)	= @_;
		my($expired)	= 0;
		my($time)		= time();

		if ( ($time - $$D{'_SESSION_ATIME'}) >= $$self{'_delta'})
		{
			$expired = 1;

			print STDOUT "Delta time: $$self{'_delta'}. Time elapsed: ", $time - $$D{'_SESSION_ATIME'}, ". Expired?: $expired. \n" if ($$self{'_verbose'});
		}

		if ($$D{'_SESSION_ETIME'} && ! $expired)
		{
			$expired = 1 if ($time >= ($$D{'_SESSION_ATIME'} + $$D{'_SESSION_ETIME'}) );

			print STDOUT "Last access time: $$D{'_SESSION_ATIME'}. Expiration time: $$D{'_SESSION_ETIME'}. Time elapsed: ", $time - $$D{'_SESSION_ATIME'}, ". Expired?: $expired. \n" if ($$self{'_verbose'});
		}

		$expired;
	}

	sub _default_for
	{
		my($self, $attr_name) = @_;

		$_attr_data{$attr_name};
	}

	# Warning: The args hashref passed in to sub _purge() has /no/ connexion
	# with the $self hashref with belongs to the object instantiated by our client.
	# The client code did something like this to create an object:
	# my($expirer) = CGI::Session::ExpireSessions -> new(delta => 1);
	# and we, the object, i.e. $expirer, are in fact the server.

	sub _purge
	{
		my($session, $args) = @_;

		return if ($session -> is_empty() );

		if ($session -> is_expired() || ($$args{'_time'} - $session -> atime() >= $$args{'_delta'}) )
		{
			print STDOUT "Expiring id @{[$session -> id()]}. \n" if ($$args{'_verbose'});

			$session -> delete();
			$session -> flush();
		}
	}

	sub _standard_keys
	{
		keys %_attr_data;
	}

}	# End of encapsulated class data.

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

sub expire_db_sessions
{
	my($self, %arg) = @_;

	$self -> set(%arg) if (%arg);

	Carp::croak(__PACKAGE__ . ". You must specify a value for the parameter 'dbh'") if (! $$self{'_dbh'});

	my($sth) = $$self{'_dbh'} -> prepare("select * from $$self{'_table_name'}");

	$sth -> execute();

	my($data, $D, @id, $untainted_data);

	while ($data = $sth -> fetchrow_hashref() )
	{
		# Untaint the data the brute force way.

		($untainted_data) = $$data{'a_session'} =~ /(.*)/;

		eval $untainted_data;

		push @id, $$data{'id'} if ($self -> _check_expiry($D) );
	}

	for (@id)
	{
		print STDOUT "Expiring db id: $_. \n" if ($$self{'_verbose'});

		$sth = $$self{'_dbh'} -> prepare("delete from $$self{'_table_name'} where id = ?");

		$sth -> execute($_);

		$sth -> finish();
	}

	if ( ($#id < 0) && $$self{'_verbose'})
	{
		print STDOUT "No db ids are due to expire. \n";
	}

}	# End of expire_db_sessions.

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

sub expire_file_sessions
{
	my($self, %arg) = @_;

	$self -> set(%arg) if (%arg);

	Carp::croak(__PACKAGE__ . ". You must specify a value for the parameter 'temp_dir'") if (! $$self{'_temp_dir'});

	opendir(INX, $$self{'_temp_dir'}) || Carp::croak("Can't opendir($$self{'_temp_dir'}): $!");
	my(@file) = map{File::Spec -> catfile($$self{'_temp_dir'}, $_)} grep{/cgisess_[0-9a-f]{32}/} readdir(INX);
	closedir INX;

	my($count)	= 0;
	my($time)	= time();

	my($file, @stat, $D);

	for my $file (@file)
	{
		@stat = stat($file);

		# Delete old, tiny files.

		if ( ( ($time - $stat[8]) >= $$self{'_delta'}) && ($stat[7] <= 5) )
		{
			$count++;

			print STDOUT "Delta time: $$self{'_delta'}. Size: $stat[7] bytes. Time elapsed: ", $time - $stat[8], ". Expired?: 1. \n" if ($$self{'_verbose'});

			unlink $file;

			next;
		}

		# Ignore new, tiny files.

		next if ($stat[7] <= 5);

		open(INX, $file) || Carp::croak("Can't open($file): $!");
		binmode INX;
		my(@session) = ;
		close INX;

		# Pod/perlfunc.html#item_eval
		# This does not work:
		# eval{no warnings 'all'; $session[0]};
		# This was when I used to say 'eval $session[0];', but that fails
		# when the session data contains \n characters. Hence the join.

		eval join('', @session);

		if ($@)
		{
			print STDOUT "Unable to parse contents of file: $file. \n" if ($$self{'_verbose'});

			next;
		}

		if ($self -> _check_expiry($D) )
		{
			$count++;

			print STDOUT "Expiring file id: $$D{'_SESSION_ID'}. \n" if ($$self{'_verbose'});

			unlink $file;
		}
	}

	print STDOUT "No file ids are due to expire. \n" if ( ($count == 0) && $$self{'_verbose'});

}	# End of expire_file_sessions.

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

sub expire_sessions
{
	my($self, %arg) = @_;

	return if (! CGI::Session -> can('find') );

	# Return the result of find, which is:
	# o Undef for failure
	# o 1 for success

	$self -> set(%arg) if (%arg);

	return CGI::Session -> find
	(
		$$self{'_cgi_session_dsn'},
		sub{_purge(@_,
		{												# This hashref is a parameter for _purge().
			_delta		=> $$self{'_delta'}	|| 0,		# These 2 defaults are in case the user sets them to undef!
			_time		=> $$self{'_time'}	|| time(),	# The defaults then stop Perl issuing warning messages about
			_verbose	=> $$self{'_verbose'},			# uninitialized variables during the call to sub _purge().
		})},
		$$self{'_dsn_args'}
	);

}	# End of expire_sessions.

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

sub new
{
	my($class, %arg)	= @_;
	my($self)			= bless({}, $class);

	for my $attr_name ($self -> _standard_keys() )
	{
		my($arg_name) = $attr_name =~ /^_(.*)/;

		if (exists($arg{$arg_name}) )
		{
			$$self{$attr_name} = $arg{$arg_name};
		}
		else
		{
			$$self{$attr_name} = $self -> _default_for($attr_name);
		}
	}

	return $self;

}	# End of new.

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

sub set
{
	my($self, %arg) = @_;

	for my $arg (keys %arg)
	{
		$$self{"_$arg"} = $arg{$arg} if (exists($$self{"_$arg"}) );
	}

}	# End of set.

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

1;

__END__