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

In reply to Re^3: Regular expression to check for qwerty sequence in a password by johngg
in thread Regular expression to check for qwerty sequence in a password by bradcathey

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post, it's "PerlMonks-approved HTML":


  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.