package Data::Password::Check;
use strict;
use warnings;
use Carp;

our $VERSION = '0.04';

=head1 NAME

Data::Password::Check - sanity check passwords

=head1 DESCRIPTION

Users can be lazy. If you're a perl programmer this is a good thing. If you're
choosing a password this is a bad thing.

This module performs some sanity checks on passwords. Details on checks than
can be performed are described below.

=head1 SYNOPSIS

Basic use of the module is as follows:

  use Data::Password::Check;

  # check a password
  my $pwcheck = Data::Password::Check->check({
    'password' => $some_password
  });

  # did we have any errors?
  if ($pwcheck->has_errors) {
    # print the errors
      print(
       join("\n", @{ $pwcheck->error_list }),
       "\n"
      );
  }

=cut

=head1 PUBLIC METHODS

These methods are publically available. Use them to your heart's content.

=head2 check($proto,$options)

This is the main function for this module. You must pass one mandatory value in
the $options hash-reference - a password:

  # check a password
  $result = Data::Password::Check->check({'password' => $pwd_to_check});

There are other options that may be passed to invoke further password tests if
required:

=over 4

=item * tests

set this to a list of test names to replace the list of tests performed by the module

e.g. tests =E<gt> [ 'length' ] will make the module perfoem the length check only

=item * tests_append

set this to a list of additional tests to perform. This is useful if you want
to call more tests than are in the default list, or to include your own tests
when inheriting from this module.

e.g. test =E<gt> [ 'mytest1', 'mytest2' ] will make the module perform two
extra tests (assuming they exist) mytest1 and mytest2.

=back

=cut
sub check($$) {
	my ($proto, $options) = @_;
	my ($self, $class);

	$class = ref($proto) || $proto;
	$self = {};
	bless $self, $class;

	# make sure $options is a hash-reference
 	unless (ref($options) eq 'HASH') {
		Carp::carp("You need to pass a hash-reference of options to check()");
		return undef;
	}

	# make sure we at least have a password value
	unless (exists $options->{'password'}) {
		Carp::carp("You need to supply a password to check()!");
		return undef;
	}

	# store the password so it's easier to refer to
	# (i.e. $self->{'password'} rather than $self->{'options'}{'password'})
	$self->{'password'} = $options->{'password'};

	# make a copy of the incomong options
	$self->{'options'} = $options;

	# perform the password checks
	$self->_do_checks;

	return $self;
}

=head2 has_errors($class)

This function is used to determine if there were any errors found while sanity
checking the supplied password. It does not return the errors themselves.

Returns B<1> if there were errors, B<0> otherwise

=cut
sub has_errors($) {
	my ($self) = @_;
	return (exists $self->{'_error_count'} and $self->{'_error_count'} > 0);
}

=head2 error_list($class)

This function returns an array-reference to a list of the error messages.
If there are no errors B<undef> is returned.

=cut
sub error_list($) {
	my ($self) = @_;
	if ($self->has_errors) {
		return $self->{'_errors'};
	}

	return undef;
}


=head1 AVAILABLE CHECKS

By default the module will perform all checks listed below. You can limit the
number of checks by passing a list of desired tests via the B<tests> option
when calling check(). e.g.

  Data::Password::Check->check({
    ...
    'tests' => [ 'length' ], # check only that the password meets a minimum-length requirement
    ...
  });

=cut

=head2 alphanumeric_only

Make sure the password only contains a-z, A-Z and 0-9 characters.

=cut
sub _check_alphanumeric_only($) {
	my ($self) = @_;

	# make sure the password only contains alphanumeric characters
	unless ($self->{'password'} =~ /^[[:alnum:]]+$/) {
		$self->_add_error("Your password may only contain alphanumeric characters (A-Z, a-z and 0-9)");
	}
}

=head2 alphanumeric

Make sure the password contains one of each from the following sets: a-z, A-Z and 0-9

=cut
sub _check_alphanumeric($) {
	my ($self) = @_;

	# make sure the password contains one lower case and one uppercase character, and one digit - at least
	# tr// seems the best way (at the moment) to check this requirement
	unless (
		($self->{'password'} =~ tr/a-z//) and
		($self->{'password'} =~ tr/A-Z//) and
		($self->{'password'} =~ tr/0-9//) ) {
		$self->_add_error("Your password must contain mixed-case letters and numbers");
	}
}

=head2 length

Make sure the password it at least 6 characters long. If B<min_length> was passed
as an option to check(), this value will be used instead, assuming it's a
positive integer.

=cut
sub _check_length($) {
	my ($self) = @_;
	my $min_length = 6;

	# does the user want a different length
	if (exists $self->{'options'}{'min_length'} and not defined $self->{'options'}{'min_length'}) {
		# issue a warning
		Carp::cluck("min_length argument must be a defined value");
		# return undef
		return undef;
	}
	elsif (exists $self->{'options'}{'min_length'} and defined $self->{'options'}{'min_length'}) {
		# is it a positive, on-zero, integer?
		if ($self->{'options'}{'min_length'} =~ /^[1-9]\d*$/) {
			$min_length = $self->{'options'}{'min_length'};
		}
		else {
			# issue a warning
			Carp::cluck("min_length argument [$self->{'options'}{'min_length'} isn't a positive, non-zero, integer");
			# return undef
			return undef;
		}
	}

	# if password is undefined, set it to '', so we aren't comparing undef with anything 
	unless (defined $self->{'password'}) {
		$self->{'password'} = '';
	}

	# now we can check that the password meets the minimum length requirement
	if (length($self->{'password'}) >= $min_length) {
		return 1;
	}
	else {
		# store a failure message
		$self->_add_error("The password must be at least $min_length characters");
	}
}

=head2 mixed_case

Make sure the password is mixes case, i.e. not all lower case, nor all upper case

=cut
sub _check_mixed_case($) {
	my ($self) = @_;

	# does the password contain at least one lowercase and one uppercase character?
	unless ($self->{'password'} =~ /(?:[A-Z].*[a-z]|[a-z].*[A-Z])/) {
		$self->_add_error("Your password must contain a mixture of lower and upper-case letters");
	}
}

=head2 silly

Make sure the password isn't a known silly word (e.g 'password' is a bad choice
for a password).

The default list contains I<qwerty>, and I<password> only. You may choose to
replace this list of words or to add your own to the end of the list.

If you wish to B<replace> the list of silly-words, you should pass them in via
the options when calling check(), as 'silly_words'. e.g.

  Data::Password::Check->check({
	...
    'silly_words' => [ 'my', 'silly', 'words' ],
	...
  });

If you would like to add words to the existing list, you should pass them in
via the 'silly_words_append' option when calling check(). e.g.

  Data::Password::Check->check({
	...
    'silly_words_append' => [ 'more', 'silly', 'words' ],
	...
  });

All matching is case-insensitive, and if you choose to append words, duplicates
will be omitted.

=cut
sub _check_silly($) {
	my ($self) = @_;
	# default words we don't want people to use as passwords
	my @silly_words = qw{
		password
		qwerty
	};
	# does the user want to REPLACE the current list of words
	if (exists $self->{'options'}{'silly_words'}) {
		# is it an array-ref?
		if (ref($self->{'options'}{'silly_words'}) eq 'ARRAY') {
			# override the default checks
			@silly_words = @{ $self->{'options'}{'silly_words'} };
		}
		else {
			Carp::carp("The 'silly_words' option must be an array-reference. Continuing with default list.");
		}
	}

	# does the user want to ADD to the existing list of word
	if (exists $self->{'options'}{'silly_words_append'}) {
		# is it an array-ref?
		if (ref($self->{'options'}{'silly_words_append'}) eq 'ARRAY') {
			# push the words onto the end of the list
			# make sure we don't already have the word
			foreach my $append (@{ $self->{'options'}{'silly_words_append'} }) {
				unless ( grep { /^$append$/ } @silly_words ) {
					push @silly_words, $append;
				}
			}
		}
		else {
			Carp::carp("The 'silly_words' option must be an array-reference. Continuing with default list.");
		}
	}

	# now we loop through the silly_words and make sure our password doesn't match them
	foreach my $silly (@silly_words) {
		# do a case-insensitive match, but look for the whole string
		if ($self->{'password'} =~ /^$silly$/i) {
			$self->_add_error("You may not use '$self->{'password'}' as your password");
		}
	}
}

=head2 repeated

Make sure the password isn't a single character repeated, e.g. 'aaaaaaaaaa'.

=cut
sub _check_repeated($) {
	my ($self) = @_;

	# is the password made up of the same character repeated?
	if ($self->{'password'} =~ /^(.)\1+$/) {
		$self->_add_error("You cannot use a single repeated character as a password");
	}
}


=head1 PRIVATE METHODS

These methods are private to this module. If you choose to use them outside the
module, all bets are off.

=head2 _do_checks($self)

This function calls each required test in turn. It's an internal function
called within check().

=cut
sub _do_checks($) {
	my ($self) = @_;
	my (@checks, $fn, $custom_checks);

	# the list of checks to make
	@checks = qw(
		length
		mixed_case
		silly
		repeated
	);
	# custom_checks defaults to false
	$custom_checks = 0;

	# allow the user to override the list of checks
	# we require the 'tests' option to exist, and to be an array-reference
	if (exists $self->{'options'}{'tests'}) {
		if (ref($self->{'options'}{'tests'}) eq 'ARRAY') {
			# override the default checks
			@checks = @{ $self->{'options'}{'tests'} };
			# set the custom_checks flag
			$custom_checks = 1;
		}
		else {
			Carp::carp("The 'tests' option must be an array-reference. Continuing with default tests.");
		}
	}

	# allow the user to override the list of checks
	# we require the 'tests' option to exist, and to be an array-reference
	if (exists $self->{'options'}{'append_tests'}) {
		if (ref($self->{'options'}{'append_tests'}) eq 'ARRAY') {
			# override the default checks
			@checks = (@checks, @{ $self->{'options'}{'append_tests'} });
			# set the custom_checks flag
			$custom_checks = 1;
		}
		else {
			Carp::carp("The 'append_tests' option must be an array-reference. Continuing with default tests.");
		}
	}

	# loop through the checks we would like to do
	foreach my $test (@checks) {
		# set the name of the function we'd like to call
		my $fn = "_check_${test}";
		# if we can run the function, do so
		if ($self->can("_check_${test}")) {
			unless (defined $self->$fn) {
				# make a note that we skipped the test
				push @{ $self->{'skipped_tests'} }, $test;
				Carp::carp("skipped test '$test' due to errors") if $self->{'DEBUG'};
			};
		}
		# otherwise warn that we're trying to call something
		# that we can't find
		else {
			# warn or carp, depending on whether we've got a custom
			# list of tests
			if ($custom_checks) {
				Carp::carp("The are no password checks available for '$test'");
			}
			else {
				warn "no such password check function: $fn()";
			}
		}
	}
}

=head2 _add_error($class,$message)

This function is used to add an error message to the internal store.
The errors can later be retrieved using the B<error_list()> method.

=cut
sub _add_error($$) {
	my ($self, $message) = @_;

	# increase the count of errors we've added
	$self->{'_error_count'} ++;

	# add the error message to a list of messages
	push @{ $self->{'_errors'} }, $message;
}

=head2 _skipped_test($class,$testname)

This function exists so that it's possible to work out if a test was skipped
because "something went wrong" - usually because of an invalid option passed in
via the check() options.

This function was written to enable some tests in the "make test" phase of
installing the module.

=cut
sub _skipped_test($$) {
	my ($self, $testname) = @_;

	# do we have a list of skipped tests?
	if (exists $self->{'skipped_tests'}) {
		# does $testname exist in the list?
		if (grep { /^$testname$/ } @{ $self->{'skipped_tests'} }) {
			return 1;
		}
	}

	# no indication that we skipped the test
	return 0;
}

=head1 AUTHOR

Chisel Wright, E<lt>chisel@herlpacker.co.ukE<gt>

=head1 COPYRIGHT AND LICENCE

Copyright (C) 2004 by Chisel Wright

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.2 or,
at your option, any later version of Perl 5 you may have available.

=cut

# be true
1;
