File Coverage

blib/lib/Authen/Class/HtAuth.pm

Criterion	Covered	Total	%
statement	9	9	100.0
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	12	12	100.0

package Authen::Class::HtAuth::Base;

use strict;
use warnings;

use base 'Class::Data::Inheritable';

# Crikey!  I don't really like this.
# Explanation:
# a) create these inheritable class data accessors
# b) in the "real" class, override them to turn them into translucent dealies
__PACKAGE__->mk_classdata('htusers');
__PACKAGE__->mk_classdata('htgroups');
__PACKAGE__->mk_classdata('_ApacheHtpasswd');
__PACKAGE__->mk_classdata('_ApacheHtgroup');


package Authen::Class::HtAuth;
use base 'Authen::Class::HtAuth::Base';

use strict;
use warnings;

use Carp;
use Apache::Htpasswd;
use Apache::Htgroup;

our $VERSION = 0.02;

sub _ApacheHtpasswd {
	my $self = shift;

	if (ref $self and defined $self->{_apachehtpasswd}) {
		$self->{_apachehtpasswd} = shift if @_;
		$self->{_apachehtpasswd};
	}
	else {
		$self->__ApacheHtpasswd_accessor(@_);
	}
}

sub _ApacheHtgroup {
	my $self = shift;

	if (ref $self and defined $self->{_apachehtgroup}) {
		$self->{_apachehtgroup} = shift if @_;
		$self->{_apachehtgroup};
	}
	else {
		$self->__ApacheHtgroup_accessor(@_);
	}
}

sub htusers {
	my $self = shift;

	if (ref $self) {
		if (@_) {
			$self->{_apachehtpasswd} = Apache::Htpasswd->new(
				{ passwdFile => $_[0],
				  ReadOnly => 1,
				}
			);
			$self->{htusers} = $_[0];
		}

		return defined $self->{htusers} ? $self->{htusers} : $self->_htusers_accessor;
	}
	else {
		if (@_) {
			$self->_ApacheHtpasswd(
				Apache::Htpasswd->new(
					{ passwdFile => $_[0],
					  ReadOnly => 1,
					}
			) );
		}

		return $self->_htusers_accessor(@_);
	}
}

sub htgroups {
	my $self = shift;

	if (ref $self) {
		if (@_) {
			$self->{_apachehtgroup} = Apache::Htgroup->new($_[0]);
			$self->{htgroups} = $_[0];
		}

		return defined $self->{htgroups} ? $self->{htgroups} : $self->_htgroups_accessor;
	}
	else {
		if (@_) {
			$self->_ApacheHtgroup( Apache::Htgroup->new($_[0]) );
		}

		return $self->_htgroups_accessor(@_);
	}
}

sub _op_group_check {
	my ($htgroup, $user, $groupdef)  = @_;
	my ($op, @groups) = @$groupdef;

	if (lc $op eq "all") {
		foreach (@groups) {
			return 0 unless ref $_ eq "ARRAY"
				? _op_group_check($htgroup, $user, $_)
				: $htgroup->ismember($user, $_);
		}
		return 1;
	}
	elsif (lc $op eq "one") {
		foreach (@groups) {
			return 1 if ref $_ eq "ARRAY"
				? _op_group_check($htgroup, $user, $_)
				: $htgroup->ismember($user, $_);
		}
		return 0;
	}
	elsif (lc $op eq "not") {
		foreach (@groups) {
			return 0 if ref $_ eq "ARRAY"
				? _op_group_check($htgroup, $user, $_)
				: $htgroup->ismember($user, $_);
		}
		return 1;
	}
	else {
		croak "bad group definition, unknown logical operand $op";
	}
}

sub check {
	my ($self, $user, $pass, %named) = @_;

	return 0 unless $self->_ApacheHtpasswd->htCheckPassword($user, $pass);

	if (defined $named{groups}) {
		return 0 unless $self->groupcheck($user, %named);
	}

	return 1;
}

sub groupcheck {
	my ($self, $user, %named) = @_;
	my @groups;

	defined $named{groups} or croak "->groupcheck called with no groups to check";

	@groups = @{$named{groups}};

	GROUP: foreach (@groups) {
		if (ref $_ eq "ARRAY") {
			return 0 unless _op_group_check($self->_ApacheHtgroup, $user, $_);
		}
		else {
			return 0 unless $self->_ApacheHtgroup->ismember($user, $_);
		}
	}

	return 1;
}

sub new {
	my ($proto, %opts) = @_;
	my $class = ref $proto || $proto;

	my $self = bless {}, $class;

	$self->htusers($opts{htusers}) if $opts{htusers};
	$self->htgroups($opts{htgroups}) if $opts{htgroups};

	return $self;
}

1;
__END__