Beefy Boxes and Bandwidth Generously Provided by pair Networks
go ahead... be a heretic
 
PerlMonks  

Re^3: Efficient way to verify scalar contents

by haukex (Bishop)
on Jun 22, 2020 at 13:44 UTC ( #11118367=note: print w/replies, xml ) Need Help??


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; }, });

Log In?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others lurking in the Monastery: (3)
As of 2021-03-03 11:44 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    My favorite kind of desktop background is:











    Results (77 votes). Check out past polls.

    Notices?