score password

score_password.pl

#!/usr/local/bin/perl

sub score_password {
  my ( $passwd ) = @_;
  my $strength;
  my $lc;
  my $c;
  my $count;
  my $max_a_run;
  my $a_run;
  my $max_n_run;
  my $n_run;
  my @tokens;

  $strength = 0;
  $lc = '';
  $count = 0;
  $a_run = 0;
  $max_a_run = 0;
  $n_run = 0;
  $max_n_run = 0;
  # break up the password into characters
  @tokens = split( //, $passwd );
  foreach $c ( @tokens ) {
    $count++;
    if ( $c =~ m/[A-Z]/ ) { # uppercase alpha
      if ( $lc eq 'l' | $lc eq 'd' | $lc eq 's' ) {
	# new type
	$strength += 2;
	if ( $max_n_run < $n_run ) {
	  $max_n_run = $n_run;
	}
	$n_run = 0;
      } else {
	$strength++;
      }
      $a_run++;
      $lc = 'u';
    } elsif ( $c =~ m/[a-z]/ ) { # lowercase alpha
      if ( $lc eq 'u' | $lc eq 'd' | $lc eq 's' ) {
	# new type
	$strength += 2;
	if ( $max_n_run < $n_run ) {
	  $max_n_run = $n_run;
	}
	$n_run = 0;
      } else {
	$strength++;
      }
      $a_run++;
      $lc = 'l';
    } elsif ( $c =~ m/\d/ ) { # decimal
      if ( $count == 1 ) {
	# number first, penalty
	$strength++;
      } elsif ( $count >= scalar( @tokens ) ) {
	# number last, penalty
	# don't increment stength
      } elsif ( $lc eq 'u' | $lc eq 'l' | $lc eq 's' ) {
	# new type
	$strength += 3;
	if ( $max_a_run < $a_run ) {
	  $max_a_run = $a_run;
	}
	$a_run = 0;
      } else {
	$strength++;
      }
      $n_run++;
      $lc = 'd';
    } elsif ( $c =~ m/[^a-zA-Z0-9]/ ) { # special
      if ( $count == 1 ) {
	# special character first, penalty
	$strength += 3;
      } elsif ( $count >= scalar( @tokens ) ) {
	# special character last, penalty
	$strength += 2;
      } elsif ( $lc eq 'u' | $lc eq 'l' | $lc eq 'd' ) {
	# new type
	$strength += 5;
	if ( $max_a_run < $a_run ) {
	  $max_a_run = $a_run;
	}
	$a_run = 0;
	if ( $max_n_run < $n_run ) {
	  $max_n_run = $n_run;
	}
	$n_run = 0;
      } else {
	$strength += 4;
      }
      $lc = 's';
    }
    if ( $::Config{'debug'} >= 5 ) {
      print "DEBUG - tok: $c c: $count str: $strength\n";
    }
  }
  # closeout token run counts
  if ( $max_a_run < $a_run ) {
    $max_a_run = $a_run;
  }
  if ( $max_n_run < $n_run ) {
    $max_n_run = $n_run;
  }
  if ( ( $max_a_run * 2 ) > $count ) {
    # too many alphas in a row, penalty
    $strength--;
  }
  if ( ( $max_n_run * 2 ) > $count ) {
    # too many nums in a row, penaly
    $strength -= 2;
  }
  # special formatting penalties
  if ( $passwd =~ m/^[a-z]+$/ ) {
    # aaa penalty
    $strength -= 4;
  }
  if ( $passwd =~ m/^[A-Z]+$/ ) {
    # AAA penalty
    $strength -= 4;
  }
  if ( $passwd =~ m/^[0-9]+$/ ) {
    # 000 penalty
    $strength -= 4;
  }
  if ( $passwd =~ m/^[a-zA-z]+[0-9]+$/ ) {
    # blah123 penalty
    $strength -= 3;
  }
  if ( $passwd =~ m/^[0-9]+[a-zA-z]+$/ ) {
    # 123blah penalty
    $strength -= 2;
  }
  if ( $passwd =~ m/^[a-zA-Z]+[^a-zA-z0-9]+$/ ) {
    # blah%^& penalty
    $strength -= 2;
  }
  if ( length( $passwd ) <= 4 ) {
    # too short, penalty
    $strength--;
  }
  @tokens = ();

  return $strength;
}