http://qs321.pair.com?node_id=11118367


in reply to Re^2: Efficient way to verify scalar contents
in thread Efficient way to verify scalar contents

my goal was maintainability, if speed mattered, I'd move the declaration of the rules and rulesets out of the sub. redefining them each time is useless.

Good point, modified:

Rate choroba2 LanX2 choroba1 LanX1 haukex1 ori +g haukex2 choroba2 84800/s -- -8% -37% -38% -59% -68 +% -73% LanX2 91935/s 8% -- -32% -33% -56% -66 +% -71% choroba1 134606/s 59% 46% -- -2% -35% -50 +% -58% LanX1 136955/s 62% 49% 2% -- -34% -49 +% -57% haukex1 208522/s 146% 127% 55% 52% -- -22 +% -35% orig 267007/s 215% 190% 98% 95% 28% - +- -16% haukex2 318577/s 276% 247% 137% 133% 53% 19 +% --
#!/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/; { # for lexicals 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 ] ); sub pw_not_ok1 { my $pw = shift; 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 my %rules_by_max_length = ( 7 => [ $short ], 11 => [ $lowercase, $uppercase, $number ,$special ], 15 => [ $lowercase, $uppercase, $number ], 19 => [ $lowercase, $uppercase ], 50 => [ $pass ] ); my @boundaries = sort { $a <=> $b } keys %rules_by_max_length; sub pw_not_ok2 { my $pw = shift; my $len = length $pw; return "too long" if $len >= 50; 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; }, });