File Coverage

blib/lib/CGI/Session/MembersArea.pm

Criterion	Covered	Total	%
statement	15	57	26.3
branch	0	20	0.0
condition	0	33	0.0
subroutine	5	12	41.6
pod	0	4	0.0
total	20	126	15.8

package CGI::Session::MembersArea;

# Name:
#	CGI::Session::MembersArea.
#
# 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;
no warnings 'redefine';

use Carp;
use DBI;

require 5.005_62;

require Exporter;

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::MembersArea ':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 = '2.06';

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

# Preloaded methods go here.

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

# Encapsulated class data.

{
	my(%_attr_data) =
	(	# Alphabetical order.
		_dsn						=> 'dbi:mysql:myadmin',
		_form_field_width			=> 50,
		_form_resource				=> 'my_resource',
		_form_password				=> 'my_password',
		_form_username				=> 'my_username',
		_password					=> '',
		_query						=> '',
		_resource_name_column		=> 'user_resource_name',
		_resource_password_column	=> 'user_resource_password',
		_resource_username_column	=> 'user_resource_username',
		_session_full_name_column	=> 'user_full_name',
		_session_key_name_column	=> 'user_full_name_key',
		_session_password_column	=> 'user_password',
		_session_table				=> 'user',
		_username					=> '',
	);

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

		$_attr_data{$attr_name};
	}

	sub _standard_keys
	{
		keys %_attr_data;
	}

}	# End of encapsulated class data.

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

sub clean_user_data
{
	my($self, $data, $max_length, $integer) = @_;
	$data = '' if (! defined($data) || ($data !~ /^([^`\x00-\x1F\x7F-\x9F]+)$/) || (length($1) == 0) || (length($1) > $max_length) );
	$data = '' if ($data =~ /.+<\s*\/?\s*script\s*>/i);	# http://www.perl.com/pub/a/2002/02/20/css.html.
	$data = '' if ($data =~ /<(.+)\s*>.*<\s*\/?\s*\1\s*>/i);		# Ditto, but much more strict.
	$data =~ s/^\s+//;
	$data =~ s/\s+$//;
	$data = 0 if ($integer && (! $data || ($data !~ /^[0-9]+$/) ) );

	$data;

}	# End of clean_user_data.

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

sub DESTROY
{
	my($self) = @_;

	$$self{'_dbh'} -> disconnect() if ($$self{'_dbh'});

}	# End of DESTROY.

# -----------------------------------------------
# Return values:
# o $profile
# o undef

sub init
{
	my($self) = @_;

	my($my_resource) = $self -> clean_user_data( ($$self{'_query'} -> param($$self{'_form_resource'}) || ''), $$self{'_form_field_width'});
	my($my_username) = $self -> clean_user_data( ($$self{'_query'} -> param($$self{'_form_username'}) || ''), $$self{'_form_field_width'});
	my($my_password) = $self -> clean_user_data( ($$self{'_query'} -> param($$self{'_form_password'}) || ''), $$self{'_form_field_width'});

	my($profile);

	if ($my_username && $my_password)
	{
		$profile = $self -> load_profile($my_resource, $my_username, $my_password);
	}

	$profile;

}	# End of init.

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

sub load_profile
{
	my($self, $resource, $username, $password) = @_;
	my($sql) = "select * from $$self{'_session_table'} where $$self{'_resource_name_column'} = ? and $$self{'_session_key_name_column'} = ? and $$self{'_session_password_column'} = ?";
	my($sth) = $$self{'_dbh'} -> prepare($sql);

	$sth -> execute($resource, lc $username, $password);

	my($profile) = $sth -> fetchrow_hashref();

	$sth -> finish();

	if ($profile && $$profile{$$self{'_session_key_name_column'} })
	{
		$profile =
		{
			full_name	=> $$profile{$$self{'_session_full_name_column'} },
			resource	=> $$profile{$$self{'_resource_name_column'} },
			username	=> $$profile{$$self{'_resource_username_column'} },
			password	=> $$profile{$$self{'_resource_password_column'} },
		};
	}
	else
	{
		$profile = undef;
	}

	$profile;

}	# End of load_profile.

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

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);
		}
	}

	Carp::croak(__PACKAGE__ . ". You must specify values for the parameters 'dsn', 'username' and 'query'") if (! ($$self{'_dsn'} && $$self{'_username'} && $$self{'_query'}) );

	$$self{'_dbh'} = DBI -> connect
	(
		$$self{'_dsn'}, $$self{'_username'}, $$self{'_password'},
		{
			AutoCommit			=> 1,
			PrintError			=> 0,
			RaiseError			=> 1,
			ShowErrorStatement	=> 1,
		}
	);

	Carp::croak(__PACKAGE__ . " Cannot log on to database using DSN '$$self{'_dsn'}'") if (! $$self{'_dbh'});

	return $self;

}	# End of new.

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

1;

__END__