File Coverage

lib/CGI/Auth/Auto.pm

Criterion	Covered	Total	%
statement	41	130	31.5
branch	5	46	10.8
condition	6	29	20.6
subroutine	9	30	30.0
pod	9	15	60.0
total	70	250	28.0

package CGI::Auth::Auto;
use Carp;
use strict;
use base qw(CGI::Auth);
use LEOCHARRE::DEBUG;
use CGI::Scriptpaths;
use vars qw($VERSION);
$VERSION = sprintf "%d.%02d", q$Revision: 1.21 $ =~ /(\d+)/g;

$CGI::Auth::Auto::CGI_APP_COMPATIBLE = 'rm=logout';


sub new {
	my $proto = shift;
   my $class = ref($proto) || $proto;
	my $self = {};
	bless $self, $class;

	my $param = shift;
	$param->{-authfields} ||= [
            {id => 'user', display => 'User Name', hidden => 0, required => 1},
            {id => 'pw', display => 'Password', hidden => 1, required => 1},
        ];

	$param->{-authdir}      ||= _guess_authdir();

	$param->{-formaction}   ||= CGI::Scriptpaths::script_rel_path(); #_guess_formaction();
   $param->{-sessdir}      ||= $param->{-authdir}.'/sess';

   if (defined $param->{-logintmplpath} or defined $param->{-logintmpl}){
      $param->{-logintmplpath}   ||= $param->{-authdir};
      $param->{-logintmpl}       ||= 'login.html';
   }

   if (DEBUG){
      require Data::Dumper;
      printf STDERR __PACKAGE__."::new() params: %s\n", Data::Dumper::Dumper($param);
      #debug(Data::Dumper::Dumper(\%ENV)."\n");
   }

   if (!defined $param->{-authdir}){
      carp(__PACKAGE__."::new() missing -authdir param to constructor or setting \$ENV{DOCUMENT_ROOT}");
      return;
   }

	unless( $self->init($param) ){
      warn( sprintf "%s\::init() failed, authdir [%s], userfile expected at:[%s]",__PACKAGE__,$param->{-authdir}, $param->{-authdir}.'/user.dat');
      return undef;
   }

	return $self;
}



sub authdir {
   my $self = shift;
   return $self->{authdir};
}

sub userdat {
   my $self = shift;
   return $self->{userdat};
}

sub sessdir {
   my $self = shift;
   return $self->{sessdir};
}

sub userfile {
   my $self = shift;
   return $self->{userfile};
}


# override check so that we can do cookie thing
sub check {
	my $self = shift;
	$self->_pre_check;
	$self->SUPER::check; # access overridden method
	$self->_post_check;
   return;
}



# this runs before auth check
# RATIONALE: pre only tries to load an auth string (unless logout is detected)
sub _pre_check {
	my $self = shift;



	# 1) first of all see if a prev sess_file id (filename really) can be gotten from cookie
	my $sess_file = $self->_get_sess_file_from_cookie
		or # no sess_file on cooie? no harm done.. just return.
			return;





	# 2) ok. so the cookie has a sess_file in it...
	# TODO: had to mess with internals of CGI::Auth ( with $self->{sess_file} ) because that module
	# does not provide for a set() type of method for the sess_file, it does accept as constructor
	# but i'd rather leave the constructor to do what it does, which seems to be to assure that
	# CGI::Auth finds its support files, user db, template, etc.

	$self->{sess_file} = $sess_file; # <- had to mess with CGI::Auth internals here.
	unless( $self->OpenSessionFile ){ # CGI::Auth::OpenSessionFile() checks with $CGI::Auth::OpenSessionFile::sess_file
		# delete the cookie
		$self->_ruin_cookie_and_redirect and exit(0);
	}




	# 3) cookie was found, sess_file was ok.. now pass it for CGI::Auth::check() to use later.
	### $sess_file
	$self->{cgi}->param( -name=> $self->sfparam_name, -value=> $sess_file );

	return 1;
}



sub _ruin_cookie_and_redirect {
	my $self = shift;

	print $self->get_cgi->redirect(
		-uri			=> $self->{formaction},
		-cookie		=>
			$self->get_cgi->cookie(
				-name		=> $self->sfparam_name,
				-value	=> '',
				-expire	=> 'now'
			)
	);

	return 1;
}

sub _set_cookie_and_redirect {
	my $self = shift;

	print $self->get_cgi->redirect(
		-uri			=> $self->{formaction},
		-cookie		=>
			$self->get_cgi->cookie(
				-name		=> $self->sfparam_name,
				-value	=> $self->sfparam_value,
				-expire	=> $self->get_cookie_expire_time
			)
	);

	return 1;
}








# post_check() only runs if user is successfully authenticated.
# its task is
#	a) to assure a cookie is present.
#  b) check for a logout for this already authenticated user
sub _post_check {
	my $self = shift;

	# 1) assure cookie is here
	unless ( $self->_get_sess_file_from_cookie ) { # if no cookie
		$self->_set_cookie_and_redirect() and exit(0);
	}

	# 2) detect logout for authenticated user
	# ok. so now we found cookie and sess_file id in it- did the user request a logout???

	if ( $self->_requested_logout ) { # check if logout was requested.
		$self->logout; # logout will exit(0). we dont do it here because logout() method could be called directly.
	};

	return 1;
}






sub logout {
	my $self = shift;

	# delete auth session
	$self->endsession;

	# ruin cookie and redirects back here
	$self->_ruin_cookie_and_redirect and exit(0);
}

# legacy
sub run {
	my $self = shift;
	$self->check;
}




# basic get and set methods. useful..
# these methods dont do anything major like exit or redirect etc

sub get_cgi {
	my $self = shift;
	return $self->{cgi};
}

sub username {
	my $self = shift;
   my ($username, undef) =	$self->OpenSessionFile;
	$username or return;
	return $username;
}


sub start_session {
	my $self = shift;
	return $self->SUPER::start_session;
}

sub _get_sess_file_from_cookie {
	## _load_cookie()
	my $self = shift;
	my $session_file = $self->get_cgi->cookie($self->sfparam_name);
	$session_file or return;
	return $session_file;
}

sub _requested_logout {
	my $self= shift;

   # does the query string look like we are trying to log out?


   # for cgi application:

   if ($CGI::Auth::Auto::CGI_APP_COMPATIBLE){
      my($param,$runmode) = split(/\=/, $CGI::Auth::Auto::CGI_APP_COMPATIBLE );

      if ( defined $self->get_cgi->param($param) and $self->get_cgi->param($param) eq $runmode ){
         debug("detected $CGI::Auth::Auto::CGI_APP_COMPATIBLE\n");
         return 1;
      }
   }

   if ( defined $ENV{QUERY_STRING} ){
      debug("\$ENV{QUERY_STRING} $ENV{QUERY_STRING}\n");
      return 1 if $ENV{QUERY_STRING} eq 'logout';
   }

   my $paramname = $self->get_logout_param_name;
   my $paramval = $self->get_cgi->param($self->get_logout_param_name);
   debug( sprintf " param name: $paramname [$paramval:%s]", ( defined $paramval ? 1 : 0 ));

   defined $paramval or return 0;
	return 1;
}

sub set_cookie_expire_time {
	my $self= shift;
	my $val = shift; $val or croak("must have valid arg to set_cookie_expire()");
	$self->{cookie_expire_time}= $val;
	return $self->{cookie_expire_time};
}

sub get_cookie_expire_time {
	my $self= shift;
	$self->{cookie_expire_time} ||= '+1h';
	return $self->{cookie_expire_time};
}

sub get_logout_param_name {
	my $self = shift;
	$self->{logout_param_name} ||= 'logout';
	return $self->{logout_param_name};
}

sub set_logout_param_name {
	my $self = shift;
	my $val = shift; $val or croak("must have arg to set_logout_param_name()");
	$self->{logout_param_name} = $val;
	return $self->{logout_param_name};
}





# GUESSING SUBS


sub _guess_authdir {
   my $dir = __guess_base().'/auth';
   debug("$dir\n");
   return $dir;
}

sub __guess_base {
   my $cgibin = CGI::Scriptpaths::abs_cgibin();

   unless(defined $cgibin){
      $cgibin = script_abs_loc() or confess("cant get script's absolute location");
   }
   debug($cgibin);
   return $cgibin;
}

sub _guess_sessdir {
   my $dir = __guess_authdir().'/sess';
   debug("$dir\n");
   return $dir;
}


1;


__END__