It turns out to be pretty good! Compared to the other solutions so far, it's only beaten by my second regex.
#!/usr/bin/env perl
use warnings;
use strict;
use Benchmark qw/cmpthese/;
# x_stream3m, https://www.perlmonks.org/?node_id=11118334
sub orig {
use feature 'switch';
no if $] >= 5.018, warnings => "experimental::smartmatch";
my $password = shift;
my $lengthOfPassword = length $password;
given ($lengthOfPassword) {
when ($_ >= 8 && $_ <= 11) {
if ($password =~ /[a-z]/ &&
$password =~ /[A-Z]/ &&
$password =~ /[0-9]/ &&
($password =~ /[\x21-\x2F]/ ||
$password =~ /[\x3A-\x40]/ ||
$password =~ /[\x5B-\x60]/ ||
$password =~ /[\x7B-\x7E]/)) {
return 1;
} else {
return 0;
}
}
when ($_ >= 12 && $_ <= 15) {
if ($password =~ /[a-z]/ &&
$password =~ /[A-Z]/ &&
$password =~ /[0-9]/) {
return 1;
} else {
return 0;
}
}
when ($_ >= 16 && $_ <= 19) {
if ($password =~ /[a-z]/ && $password =~ /[A-Z]/) {
return 1;
} else {
return 0;
}
}
when ($_ >= 20) {
return 1;
}
default {
return 0;
}
}
}
# haukex, https://www.perlmonks.org/?node_id=11118347
sub regex1 { $_[0] =~ m{ \A (?:
.{20,}
| (?=.*[a-z]) (?=.*[A-Z])
.{16,19}
| (?=.*[a-z]) (?=.*[A-Z]) (?=.*[0-9])
.{12,15}
| (?=.*[a-z]) (?=.*[A-Z]) (?=.*[0-9])
(?=.*[\x21-\x2F\x3A-\x40\x5B-\x60\x7B-\x7E])
.{8,11}
) \z }msx }
sub regex2 { $_[0] =~ m{ \A (?: .{20,} | (?=.*[a-z]) (?=.*[A-Z])
(?: .{16,19} | (?=.*[0-9]) (?: .{12,15}
| (?=.*[\x21-\x2F\x3A-\x40\x5B-\x60\x7B-\x7E]) .{8,11}
) ) ) \z }msx }
# choroba, https://www.perlmonks.org/?node_id=11118354
my @RE1 = (qr/[[:lower:]]/, qr/[[:upper:]]/, qr/[0-9]/, qr/[^[:alnum:]
+]/);
sub check1 {
local ($_) = @_;
my $length = length;
return if $length < 8;
return if $length < 12 && (! /$RE1[0]/ || ! /$RE1[1]/ || ! /$RE1[2
+]/ || ! /$RE1[3]/);
return if $length < 16 && (! /$RE1[0]/ || ! /$RE1[1]/ || ! /$RE1[2
+]/);
return if $length < 20 && (! /$RE1[0]/ || ! /$RE1[1]/);
return 1
}
use List::Util qw{ any };
my @RE2 = (qr/[[:lower:]]/, qr/[[:upper:]]/, qr/[0-9]/, qr/[^[:alnum:]
+]/);
sub check2 {
my ($password) = @_;
my $length = length $password;
return if $length < 8;
return if $length < 12 && any { $password !~ $RE2[$_] } 0 .. 3;
return if $length < 16 && any { $password !~ $RE2[$_] } 0 .. 2;
return if $length < 20 && any { $password !~ $RE2[$_] } 0 .. 1;
return 1
}
# LanX, https://www.perlmonks.org/?node_id=11118358
use List::Util qw/min/;
sub pw_not_ok1 {
my $pw = shift;
my $short = sub { "is too short" };
my $lowercase = sub { /[a-z]/ ? "" : "has no lowercase character"
+};
my $uppercase = sub { /[A-Z]/ ? "" : "has no uppercase character"
+};
my $number = sub { /[0-9]/ ? "" : "has no number" };
my $special = sub {
if (/[\x21-\x2F]/ ||
/[\x3A-\x40]/ ||
/[\x5B-\x60]/ ||
/[\x7B-\x7E]/ ) {
return "";
} else {
return "has no special characters";
}
};
my $pass = sub {""};
my @rules_for_class = (
[ $short ],
[ $short ],
[ $lowercase, $uppercase, $number ,$special ],
[ $lowercase, $uppercase, $number ],
[ $lowercase, $uppercase ],
[ $pass ] );
my $len = length $pw;
my $idx = min(int($len/4),5);
for my $rule ( @{ $rules_for_class[$idx] } ) {
$_ = $pw;
if ( my $err = $rule->() ) {
return $err;
}
}
return;
}
# LanX, https://www.perlmonks.org/?node_id=11118360
sub pw_not_ok2 {
my $pw = shift;
my $short = sub { "is too short" };
my $lowercase = sub { /[a-z]/ ? "" : "has no lowercase character"
+};
my $uppercase = sub { /[A-Z]/ ? "" : "has no uppercase character"
+};
my $number = sub { /[0-9]/ ? "" : "has no number" };
my $special = sub {
if (/[\x21-\x2F]/ ||
/[\x3A-\x40]/ ||
/[\x5B-\x60]/ ||
/[\x7B-\x7E]/ ) {
return "";
} else {
return "has no special characters";
}
};
my $pass = sub {""};
my %rules_by_max_length = (
7 => [ $short ],
11 => [ $lowercase, $uppercase, $number ,$special ],
15 => [ $lowercase, $uppercase, $number ],
19 => [ $lowercase, $uppercase ],
50 => [ $pass ] );
my $len = length $pw;
return "too long" if $len >= 50;
my @boundaries = sort { $a <=> $b } keys %rules_by_max_length;
for my $boundary ( @boundaries ) {
next if $len > $boundary;
my $rules = $rules_by_max_length{$boundary};
for my $rule ( @$rules ) {
$_ = $pw;
if ( my $err = $rule->() ) {
return $err;
}
}
}
return;
}
cmpthese(-2, {
orig => sub {
orig('aaaaA0-') and die;
orig('aaaaaA0-') or die;
orig('aaaaaaaaa0-') and die;
orig('aaaaaaaaaaA0') or die;
orig('aaaaaaaaaaaaaaA') and die;
orig('aaaaaaaaaaaaaaaA') or die;
orig('aaaaaaaaaaaaaaaaaaa') and die;
orig('aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa') or die;
},
haukex1 => sub {
regex1('aaaaA0-') and die;
regex1('aaaaaA0-') or die;
regex1('aaaaaaaaa0-') and die;
regex1('aaaaaaaaaaA0') or die;
regex1('aaaaaaaaaaaaaaA') and die;
regex1('aaaaaaaaaaaaaaaA') or die;
regex1('aaaaaaaaaaaaaaaaaaa') and die;
regex1('aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa') or die;
},
haukex2 => sub {
regex2('aaaaA0-') and die;
regex2('aaaaaA0-') or die;
regex2('aaaaaaaaa0-') and die;
regex2('aaaaaaaaaaA0') or die;
regex2('aaaaaaaaaaaaaaA') and die;
regex2('aaaaaaaaaaaaaaaA') or die;
regex2('aaaaaaaaaaaaaaaaaaa') and die;
regex2('aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa') or die;
},
choroba1 => sub {
check1('aaaaA0-') and die;
check1('aaaaaA0-') or die;
check1('aaaaaaaaa0-') and die;
check1('aaaaaaaaaaA0') or die;
check1('aaaaaaaaaaaaaaA') and die;
check1('aaaaaaaaaaaaaaaA') or die;
check1('aaaaaaaaaaaaaaaaaaa') and die;
check1('aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa') or die;
},
choroba2 => sub {
check2('aaaaA0-') and die;
check2('aaaaaA0-') or die;
check2('aaaaaaaaa0-') and die;
check2('aaaaaaaaaaA0') or die;
check2('aaaaaaaaaaaaaaA') and die;
check2('aaaaaaaaaaaaaaaA') or die;
check2('aaaaaaaaaaaaaaaaaaa') and die;
check2('aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa') or die;
},
LanX1 => sub {
pw_not_ok1('aaaaA0-') or die;
pw_not_ok1('aaaaaA0-') and die;
pw_not_ok1('aaaaaaaaa0-') or die;
pw_not_ok1('aaaaaaaaaaA0') and die;
pw_not_ok1('aaaaaaaaaaaaaaA') or die;
pw_not_ok1('aaaaaaaaaaaaaaaA') and die;
pw_not_ok1('aaaaaaaaaaaaaaaaaaa') or die;
pw_not_ok1('aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa') and die;
},
LanX2 => sub {
pw_not_ok2('aaaaA0-') or die;
pw_not_ok2('aaaaaA0-') and die;
pw_not_ok2('aaaaaaaaa0-') or die;
pw_not_ok2('aaaaaaaaaaA0') and die;
pw_not_ok2('aaaaaaaaaaaaaaA') or die;
pw_not_ok2('aaaaaaaaaaaaaaaA') and die;
pw_not_ok2('aaaaaaaaaaaaaaaaaaa') or die;
pw_not_ok2('aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa') and die;
},
});
