File Coverage

blib/lib/Data/Password/BasicCheck.pm

Criterion	Covered	Total	%
statement	118	121	97.5
branch	26	32	81.2
condition	9	15	60.0
subroutine	21	24	87.5
pod	5	5	100.0
total	179	197	90.8

package Data::Password::BasicCheck;

use 5.006;
use strict;
use warnings;

our $VERSION = '2.03';

# Object parameters
use constant MIN => 0 ;
use constant MAX => 1 ;
use constant SYM => 2 ;

# Return values
use constant OK    => 0 ; # password ok
use constant SHORT => 1 ; # password is too short
use constant LONG  => 2 ; # password is too long
use constant A1SYM => 3 ; # password must contain alphas, digits and symbols
use constant NOSYM => 4 ; # not enough different symbols in password
use constant ROT   => 5 ; # password matches itself after some rotation
use constant PINFO => 6 ; # password matches personal information
use constant WEAK  => 127 ; # password too weak (generic)


# Other constants
use constant DEBUG => 0 ;

sub new {
  my $class = shift ;

  die "Not an object method" if ref $class ;
  my ($minlen,$maxlen,$psym) = @_ ;

  # Avoid bothering about uninitialized values...
  no warnings ;
  return undef unless $minlen =~ /^\d+$/ and $minlen >= 0 ;
  return undef unless $maxlen =~ /^\d+$/ and $maxlen >= $minlen ;
  $psym = 2/3  unless $psym > 0 ;

  return bless [$minlen,$maxlen,$psym],$class ;
}

sub minlen { return $_[0]->[MIN] }
sub maxlen { return $_[0]->[MAX] }
sub psym   { return $_[0]->[SYM] }
sub _parms { return @{$_[0]}     }

sub check {
  my $self = shift ;
  my ($password,@userinfo) = @_ ;

  die "Not a class method!"
    unless ref $self and eval { $self->isa('Data::Password::BasicCheck') } ;

  my ($minlen,$maxlen,$psym) = $self->_parms ;
  my $plen                   = length $password ;
  # Check length
  {
    return SHORT if $plen < $minlen ;
    return LONG  if $plen > $maxlen ;
  }

  my $result = $self->_docheck(@_) ;
  return $result if $result eq OK ;

  # Try shorter segments...
  my $segments = $plen - $minlen ;
  return $result unless $segments > 1 ;
  foreach (my $i = 0 ; $i <= $segments; $i++) {
    my $segment = substr $password,$i,$minlen ;
    print STDERR "DEBUG: Trying $segment\n" if DEBUG ;
    $result = $self->_docheck($segment,@userinfo) ;
    return $result if $result eq OK ;
  }
  return WEAK ;
}

sub _docheck {
  my ($self,$password,@userinfo) = @_ ;

  my ($minlen,$maxlen,$psym) = $self->_parms ;
  my $plen                   = length $password ;
  # Password contains alphas, digits and non-alpha-digits
  {
    local $_ = $password ;
    return A1SYM
      unless /[a-z]/i and /\d/ and /[^a-z0-9]/i ;
  }

  # Check unique characters
  {
    my @chars = split //,$password ;
    my %unique ;
    foreach my $char (@chars) {
      $unique{$char}++;
    }
    ;
    return NOSYM
      unless scalar keys %unique >= sprintf "%.0f",$psym * $plen ;
  }

  # rotations of the password don't match it
  {
    foreach my $rot (_rotations($password)) {
      return ROT
	if $rot eq $password ;
    }
  }

  # Check password against user data.Some of user data could be
  # composed, like "Alan Louis", or "Di Cioccio" or
  # "Los Angeles", so we have to treat each chunk separately.  But we
  # should also check for passwords like "alanlouis", or "dicioccio"
  # or "losangeles". So we must add them, too.
  {
    # Prepare password rotations; check reverse password and reverse
    # password rotations, too
    my $pclean                    = lc $password ;
    $pclean =~ s/[^a-z]//g ;
    my $rpclean = reverse $pclean ;
    my @prots = ($pclean, _rotations($pclean),
		 $rpclean,_rotations($rpclean)) ;

    # Prepare personal information to match @prots against
    @userinfo = map lc,@userinfo  ;
    my @chunks = split(/\s+/,join(" ",@userinfo)) ;
    foreach (@userinfo) {
      if (/\s/) {
	s/\s// ;
	push @chunks,$_ ;
      }
    }

    my $idx ;
    foreach my $chunk (@chunks) {
      my $chunklen = length $chunk ;
      foreach my $rot (@prots) {
	my $cutrot = substr $rot,0,$minlen ;
	$idx = $chunklen >= $minlen?
	  index $chunk,$cutrot:
	  index $cutrot,$chunk;
	unless ($idx == -1) {
	  return PINFO ;
	}
      }
    }
  }

  return OK ;
}


sub _rotations {
  my $string = shift ;
  my $n      = length $string ;
  my @result ;

  # note: $i < $n, since the n-th permutation is the password again
  for (my $i = 1 ; $i < $n ; $i++) {
    $string = chop($string).$string ;
    push @result,$string ;
  }
  return @result ;
}

1;
__END__