Here's a re-factored script that also now caters for the "qwerty" keyboard sequences you wanted to check for in your OP. The script uses Term::ANSIColor to highlight the non-compliant parts of each password.
use strict;
use warnings;
use Term::ANSIColor qw{ :constants };
use feature qw{ say };
use re qw{ eval };
my $maxAllowed = shift || 3;
# Create pattern for consecutive ascending and descending digits.
#
my $rxAscDig =
qr{(?x) ( ( \d ) (??{ join q{}, map { $2 + $_ } 1 .. $maxAllowed })
+ ) };
my $rxDescDig =
qr{(?x) ( ( \d ) (??{ join q{}, map { $2 - $_ } 1 .. $maxAllowed })
+ ) };
# Create pattern for consecutive ascending letters.
#
my $ucAscEnd = chr( ord( q{Z} ) - $maxAllowed );
my $ascLtrPatt = join q{ },
qq{( ( [A-${ucAscEnd}] )},
q{(??{ join q{}, map { chr( ord( $2 ) + $_ ) } 1 .. $maxAllowed })
+ ) };
my $rxAscLtr = qr{(?xi) $ascLtrPatt };
# Create pattern for consecutive descending letters.
#
my $ucDescStart = chr( ord( q{A} ) + $maxAllowed );
my $descLtrPatt = join q{ },
qq{( ( [${ucDescStart}-Z] )},
q{(??{ join q{}, map { chr( ord( $2 ) - $_ ) } 1 .. $maxAllowed })
+ ) };
my $rxDescLtr = qr{(?xi) $descLtrPatt };
# Create pattern for left to tight and right to left keyboard sequence
+s.
#
my @kbdLtrRows = qw{
QWERTYUIOP
ASDFGHJKL
ZXCVBNM
};
my @kbdLtrPatts = do {
my $bad = $maxAllowed + 1;
my @patts;
foreach my $row ( @kbdLtrRows, map { scalar reverse } @kbdLtrRows )
{
push @patts, $1 while $row =~ m{(?=(.{$bad}))}g;
}
@patts;
};
my $rxKbdLtr = do {
local $" = q{|};
qr{(?xi) ( @kbdLtrPatts ) };
};
# Create passwords to test.
#
my @passwords = qw{
1234 1243 4321 298761 4562 4568 4578 123 12 1
01234 01243 04321 0298761 04562 04568 04578 0123 012 01
a1234 1a234 12a34 123a4 1234a
a1b2c3 a12b34c56 a1b2c3d a12b34c56d
a123b45c6 a12b345c6 a123b45c6d a12b345c6d
1a2 1ab2 12ab34 12abc34def 12abc34def567
abc ab12c 2345 234y 012345 2356 3457
abcd XWVU bcd1e ZYX
ZYXW kjyihGfs
abcd aNbvcd3456
def
PQRST
PQrST
YXWV
zYXwv
bcde bcdf stu stuc stuv wxyz
hgfe lkjh edbca dhfe
gertys
fgh8d
hnbvcer
};
foreach my $pwd ( @passwords )
{
testPwd( $pwd );
}
sub appendError
{
my( $rsMsg, $text, $marked ) = @_;
${ $rsMsg } .= qq{\n Too many consecutive $text - $marked};
}
sub testPwd
{
my $pwd = shift;
my $msg = qq{Password: $pwd};
my $err = 0;
if ( $pwd =~ m{$rxKbdLtr} )
{
$err ++;
my $marked = $pwd =~ s{$rxKbdLtr}{ BOLD RED . $1 . RESET }er;
appendError( \ $msg, q{adjacent letter keys}, $marked );
}
if ( $pwd =~ m{$rxAscDig} )
{
$err ++;
my $marked = $pwd =~ s{$rxAscDig}{ BOLD RED . $1 . RESET }er;
appendError( \ $msg, q{consecutive ascending digits}, $marked
+);
}
if ( $pwd =~ m{$rxDescDig} )
{
$err ++;
my $marked = $pwd =~ s{$rxDescDig}{ BOLD RED . $1 . RESET }er;
appendError( \ $msg, q{consecutive descending digits}, $marked
+ );
}
if ( $pwd =~ m{$rxAscLtr} )
{
$err ++;
my $marked = $pwd =~ s{$rxAscLtr}{ BOLD RED . $1 . RESET }er;
appendError( \ $msg, q{consecutive ascending letters}, $marked
+ );
}
if ( $pwd =~ m{$rxDescLtr} )
{
$err ++;
my $marked = $pwd =~ s{$rxDescLtr}{ BOLD RED . $1 . RESET }er;
appendError( \ $msg, q{consecutive descending letters}, $marke
+d );
}
$msg .= qq{\n Passed tests} unless $err;
say $msg;
}
I hope this is useful.
-
Are you posting in the right place? Check out Where do I post X? to know for sure.
-
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big>
<blockquote> <br /> <dd>
<dl> <dt> <em> <font>
<h1> <h2> <h3> <h4>
<h5> <h6> <hr /> <i>
<li> <nbsp> <ol> <p>
<small> <strike> <strong>
<sub> <sup> <table>
<td> <th> <tr> <tt>
<u> <ul>
-
Snippets of code should be wrapped in
<code> tags not
<pre> tags. In fact, <pre>
tags should generally be avoided. If they must
be used, extreme care should be
taken to ensure that their contents do not
have long lines (<70 chars), in order to prevent
horizontal scrolling (and possible janitor
intervention).
-
Want more info? How to link
or How to display code and escape characters
are good places to start.