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