Beefy Boxes and Bandwidth Generously Provided by pair Networks
Clear questions and runnable code
get the best and fastest answer
 
PerlMonks  

comment on

( [id://3333]=superdoc: print w/replies, xml ) Need Help??
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; }, });

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

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Are you posting in the right place? Check out Where do I post X? to know for sure.
  • Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
    <code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
  • Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
  • Want more info? How to link or How to display code and escape characters are good places to start.
Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others perusing the Monastery: (4)
As of 2024-03-29 11:08 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found