Beefy Boxes and Bandwidth Generously Provided by pair Networks
Think about Loose Coupling
 
PerlMonks  

Re^4: Efficient way to verify scalar contents

by haukex (Bishop)
on Jun 25, 2020 at 06:36 UTC ( #11118485=note: print w/replies, xml ) Need Help??


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

Out of curiosity, I tried tr/// instead of regex, much faster :)

Looks like it's a winner :-)

Rate BillKSmith2 choroba2 LanX2 choroba1 LanX1 haukex1 + BillKSmith1 orig tybalt89 haukex2 tybalt89_2 BillKSmith2 40957/s -- -53% -58% -71% -71% -82% + -84% -85% -85% -88% -91% choroba2 88071/s 115% -- -10% -38% -38% -61% + -65% -67% -69% -73% -82% LanX2 97356/s 138% 11% -- -31% -31% -57% + -61% -63% -65% -71% -80% choroba1 141499/s 245% 61% 45% -- 0% -37% + -44% -47% -50% -57% -70% LanX1 141499/s 245% 61% 45% 0% -- -37% + -44% -47% -50% -57% -70% haukex1 225463/s 450% 156% 132% 59% 59% -- + -11% -15% -20% -32% -53% BillKSmith1 252057/s 515% 186% 159% 78% 78% 12% + -- -5% -11% -24% -47% orig 265476/s 548% 201% 173% 88% 88% 18% + 5% -- -6% -20% -44% tybalt89 281788/s 588% 220% 189% 99% 99% 25% + 12% 6% -- -15% -41% haukex2 331918/s 710% 277% 241% 135% 135% 47% + 32% 25% 18% -- -30% tybalt89_2 476665/s 1064% 441% 390% 237% 237% 111% + 89% 80% 69% 44% --
#!/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; } } # BillKSmith, https://www.perlmonks.org/?node_id=11118369 sub is_pw_valid { local $_ = $_[0]; return !(/[a-z]/ && /[A-Z]/) ? length >= 20 : !/\d/ ? length >= 16 : !/[\x21-\x2F\x3A-\x40\x5B-\x60\x7B-\x7E]/ ? length >= 12 : length >= 8 ; } sub is_pw_valid2 { my $password = $_[0]; my $MixedCase = qr/(:? [a-z].*[A-Z]) | (:? [A-Z].*[a-z] )/x; my $Digit = qr/\d/; my $special = qr/[\x21-\x2F\x3A-\x40\x5B-\x60\x7B-\x7E]/; my $min_length; if ($password !~ $MixedCase) {$min_length = 20} elsif ($password !~ $Digit) {$min_length = 16} elsif ($password !~ $special) {$min_length = 12} else {$min_length = 8} + my $is_OK = ( length($password) >= $min_length ); return $is_OK; } # tybalt89, https://www.perlmonks.org/?node_id=11118395 sub validate { local $_ = shift; length >= 20 ? 1 : !/[a-z]/ || !/[A-Z]/ ? 0 : length >= 16 ? 1 : !/\d/ ? 0 : length >= 12 ? 1 : !/[^_\w]/ ? 0 : length >= 8 ? 1 : 0; } # tybalt89, https://www.perlmonks.org/?node_id=11118433 sub validatetr { local $_ = shift; length >= 20 ? 1 : !tr/a-z// || !tr/A-Z// ? 0 : length >= 16 ? 1 : !tr/0-9// ? 0 : length >= 12 ? 1 : !tr/a-zA-Z0-9//c ? 0 : length >= 8 ? 1 : 0; } 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; }, BillKSmith1 => sub { is_pw_valid('aaaaA0-') and die; is_pw_valid('aaaaaA0-') or die; is_pw_valid('aaaaaaaaa0-') and die; is_pw_valid('aaaaaaaaaaA0') or die; is_pw_valid('aaaaaaaaaaaaaaA') and die; is_pw_valid('aaaaaaaaaaaaaaaA') or die; is_pw_valid('aaaaaaaaaaaaaaaaaaa') and die; is_pw_valid('aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa') or die; }, BillKSmith2 => sub { is_pw_valid2('aaaaA0-') and die; is_pw_valid2('aaaaaA0-') or die; is_pw_valid2('aaaaaaaaa0-') and die; is_pw_valid2('aaaaaaaaaaA0') or die; is_pw_valid2('aaaaaaaaaaaaaaA') and die; is_pw_valid2('aaaaaaaaaaaaaaaA') or die; is_pw_valid2('aaaaaaaaaaaaaaaaaaa') and die; is_pw_valid2('aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa') or die; }, tybalt89 => sub { validate('aaaaA0-') and die; validate('aaaaaA0-') or die; validate('aaaaaaaaa0-') and die; validate('aaaaaaaaaaA0') or die; validate('aaaaaaaaaaaaaaA') and die; validate('aaaaaaaaaaaaaaaA') or die; validate('aaaaaaaaaaaaaaaaaaa') and die; validate('aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa') or die; }, tybalt89_2 => sub { validatetr('aaaaA0-') and die; validatetr('aaaaaA0-') or die; validatetr('aaaaaaaaa0-') and die; validatetr('aaaaaaaaaaA0') or die; validatetr('aaaaaaaaaaaaaaA') and die; validatetr('aaaaaaaaaaaaaaaA') or die; validatetr('aaaaaaaaaaaaaaaaaaa') and die; validatetr('aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa') or die; }, });

Log In?
Username:
Password:

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

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











    Results (105 votes). Check out past polls.

    Notices?