Beefy Boxes and Bandwidth Generously Provided by pair Networks
Keep It Simple, Stupid
 
PerlMonks  

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

by bradcathey (Prior)
on Oct 10, 2016 at 06:13 UTC ( #1173631=note: print w/replies, xml ) Need Help??


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

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
  • Comment on Re^2: Regular expression to check for qwerty sequence in a password
  • Download Code

Replies are listed 'Best First'.
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; }

    I hope this is useful.

    Cheers,

    JohnGG

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: note [id://1173631]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others imbibing at the Monastery: (5)
As of 2020-09-21 13:09 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    If at first I donít succeed, I Ö










    Results (126 votes). Check out past polls.

    Notices?