Re: Regular expression to check for qwerty sequence in a password

I posted a couple of replies in this thread then, just out of interest, continued to work on adding functionality. It may be overkill for what you want but you could pick out any bits that are useful.

use strict;
use warnings;

use 5.014;
use re qw{ eval };

my $max = shift || 3;

# Create pattern for consecutive ascending and descending digits.
#
my $ascDigPatt  =
   q{(?x) ( ( \d ) (??{ join q{}, map { $2 + $_ } 1 .. $max }) ) };
my $descDigPatt =
   q{(?x) ( ( \d ) (??{ join q{}, map { $2 - $_ } 1 .. $max }) ) };

# Create pattern for consecutive ascending letters.
#
my $ucAscEnd = chr( ord( q{Z} ) - $max );
my $lcAscEnd = chr( ord( q{z} ) - $max );
my $ascLtrPatt  = join q{ },
    q{(?x)},
   qq{( ( [A-${ucAscEnd}a-${lcAscEnd}] )},
    q{(??{ join q{}, map { chr( ord( $2 ) + $_ ) } 1 .. $max }) ) };

# Create pattern for consecutive descending letters.
#
my $ucDescStart = chr( ord( q{A} ) + $max );
my $lcDescStart = chr( ord( q{a} ) + $max );
my $descLtrPatt = join q{ },
    q{(?x)},
   qq{( ( [${ucDescStart}-Z${lcDescStart}-z] )},
    q{(??{ join q{}, map { chr( ord( $2 ) - $_ ) } 1 .. $max }) ) };

my $kbdTopRow    = q{qwertyuiop};
my $kbdMiddleRow = q{asdfghjkl};
my $kbdBottomRow = q{zxcvbnm};


# 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
   def
   PQRST
   YXWV
   bcde bcdf stu stuc stuv wxyz
   hgfe lkjh edbca dhfe
   };

foreach my $pw ( @passwords )
{
    print qq{$pw - };
    my $err = checkConsec( $pw );
    say
       $err
       ? $err
       : q{pass};
}

sub checkConsec
{
    my $pw = shift;
    return qq{too many consecutive ascending digits - $1}
       if $pw =~ m{$ascDigPatt};
    return qq{too many consecutive descending digits - $1}
       if $pw =~ m{$descDigPatt};
    return qq{too many consecutive ascending letters - $1}
       if $pw =~ m{$ascLtrPatt};
    return qq{too many consecutive descending letters - $1}
       if $pw =~ m{$descLtrPatt};
    return 0;
}
[download]

I didn't post it at the time but hope it might be helpful now.

Update: Looking at the code again, it seems that I hadn't got around to implementing the "qwerty" part of the problem yet :-}

Cheers,

JohnGG

Comment on Re: Regular expression to check for qwerty sequence in a password Download Code

Replies are listed 'Best First'.
Re^2: Regular expression to check for qwerty sequence in a password by bradcathey (Prior) on Oct 10, 2016 at 06:13 UTC
Thanks for all the work. I know the feeling of working on something like this. You did help me see some other password issues that would make them less secure. I will noodle this further. —Brad "The important work of moving the world forward does not wait to be done by perfect men." George Eliot	[reply] [d/l]
Re^3: Regular expression to check for qwerty sequence in a password by johngg (Canon) on Oct 15, 2016 at 21:07 UTC
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; } [download] I hope this is useful. Cheers, JohnGG	[reply] [d/l]


There's more than one way to do things
	PerlMonks