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


in reply to Efficient way to verify scalar contents

I feel the current implementation is kind of redundant or inefficient?

It turns out to be pretty good! Compared to the other solutions so far, it's only beaten by my second regex.

             Rate    LanX2    LanX1 choroba2 choroba1  haukex1     ori
+g  haukex2
LanX2     35040/s       --     -49%     -59%     -75%     -84%     -87
+%     -89%
LanX1     68981/s      97%       --     -19%     -51%     -69%     -74
+%     -79%
choroba2  84861/s     142%      23%       --     -39%     -62%     -68
+%     -74%
choroba1 139373/s     298%     102%      64%       --     -37%     -47
+%     -57%
haukex1  222355/s     535%     222%     162%      60%       --     -15
+%     -31%
orig     261901/s     647%     280%     209%      88%      18%       -
+-     -19%
haukex2  323064/s     822%     368%     281%     132%      45%      23
+%       --

[download]

Updated benchmarks here!

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

[download]

Replies are listed 'Best First'.
Re^2: Efficient way to verify scalar contents
by LanX (Saint) on Jun 22, 2020 at 13:32 UTC
    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.

    Also using regex-refs via qr// is faster, but code-refs allow implementing more complex rules if requirements change.

    Cheers Rolf
    (addicted to the Perl Programming Language :)
    Wikisyntax for the Monastery

[reply]
      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
+%       --

      [download]
      Read more... Benchmark code (9 kB)
[reply]
[d/l]
[select]

In Section Seekers of Perl Wisdom