#!/usr/bin/perl
#
# call this file passcheck.pl in order to test it with the
# test script

use strict ;
use warnings ;

sub passcheck {
  my ($username,$password,$name,$surname,$city) = @_ ;

  my ($minlen,$maxlen,$maxfreq) = (5,8,.5) ;
  my $plen                      = length $password ;
  my $pclean                    = lc $password ;
  $pclean =~ s/[^a-z]//g ;
  my %prots = map {$_,qr/$_/} ($pclean,leftrotations($pclean)) ;

  # Check length
  {
    return "password is too short" if $plen < $minlen ;
    return "password is too long"  if $plen > $maxlen ;
  }

  # Check repetitions
  {
    my @chars = split //,$password ;
    my %unique ;
    foreach my $char (@chars) { $unique{$char}++ } ;
    while (my ($char,$count) = each %unique) {
      return "Too many repetions of char $char"
        if $count/$plen > $maxfreq ;
    }
  }

  # Check password against username, name, surname and city
  # All but username could be composed, like "Alan Louis", or "Di Cioccio"
  # or "Los Angeles", so we have to treat each chunk separately.
  {
    my %chunks = map { ($_,qr/$_/) }
      split(/\s+/,lc(join(" ",$name,$surname,$city))) ;

    # Add username to %chunks
    # You can compact the code below in one line, but why? :-)
    {
      my $lcuser  = lc $username ;
      $chunks{$lcuser} = qr/$lcuser/ ;
    }

    foreach my $chunk (keys %chunks) {
      foreach my $rot (keys %prots) {
        return "password matches personal data after some left rotation"
	  if $rot =~ $chunks{$chunk} or $chunk =~ $prots{$rot} ;
      }
    }
  }


  # Left rotations of the password don't match it
  {
    foreach my $rot (leftrotations($password)) {
      return "Password matches itself after some left rotation"
        if $rot eq $password ;
    }
  }

  # Password contains alphas, digits and non-alpha-digits
  {
    local $_ = $password ;
    return "Password must contain alphanumeric characters, digits and symbols"
      unless /[a-z]/i and /\d/ and /[^a-z0-9]/i ;
  }

  return "password ok" ;
}

sub leftrotations {
  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 =~ s/^(.)(.*)$/$2$1/ ;
    push @result,$string ;
  }
  return @result ;
}

1 ;