comment on

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]

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

In reply to Re^3: Efficient way to verify scalar contents by haukex
in thread Efficient way to verify scalar contents by x_stream3m

Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!

Titles consisting of a single word are discouraged, and in most cases are disallowed outright.

Read Where should I post X? if you're not absolutely sure you're posting in the right place.

Please read these before you post! —

Posts may use any of the Perl Monks Approved HTML tags:

a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr

You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)

	For:		Use:
	&		`&`
	<		`<`
	>		`>`
	[		`[`
	]		`]`

Link using PerlMonks shortcuts! What shortcuts can I use for linking?

See Writeup Formatting Tips and other pages linked from there for more info.


"be consistent"
	PerlMonks