File Coverage

blib/lib/Data/Password/zxcvbn/Match/Repeat.pm
Criterion Covered Total %
statement 31 31 100.0
branch 8 8 100.0
condition n/a
subroutine 5 5 100.0
pod 4 4 100.0
total 48 48 100.0


line stmt bran cond sub pod time code
1             package Data::Password::zxcvbn::Match::Repeat;
2 2     2   8931 use Moo;
  2         5  
  2         18  
3             with 'Data::Password::zxcvbn::Match';
4             our $VERSION = '1.1.2'; # VERSION
5             # ABSTRACT: match class for repetitions of other matches
6              
7              
8             has repeat_count => (is => 'ro', default => 1);
9             has base_token => ( is => 'ro', required => 1 );
10             has base_guesses => ( is => 'ro', default => 1 );
11             has base_matches => ( is => 'ro', default => sub { [] } );
12              
13             my $GREEDY_RE = qr{\G.*? ((.+) \2+)}x;
14             my $LAZY_RE = qr{\G.*? ((.+?) \2+)}x;
15             my $LAZY_ANCHORED_RE = qr{\A ((.+?) \2+) \z}x;
16              
17              
18             sub make {
19 1551     1551 1 201923 my ($class, $password, $opts) = @_;
20              
21 1551         4074 my $length = length($password);
22 1551 100       6693 return [] if $length <= 1;
23              
24 1101         2250 my @matches;
25 1101         2606 my $last_index = 0;
26 1101         4061 while ($last_index < $length) {
27             # make the regex matches start at $last_index
28 1410         5201 pos($password) = $last_index;
29 1410 100       20422 my @greedy_match = $password =~ $GREEDY_RE
30             or last;
31 496         2932 my @greedy_idx = ($-[1],$+[1]-1);
32              
33 496         1473 pos($password) = $last_index;
34 496         5152 my @lazy_match = $password =~ $LAZY_RE;
35 496         2404 my @lazy_idx = ($-[1],$+[1]-1);
36              
37 496         1570 my (@token,$i,$j);
38 496 100       1831 if (length($greedy_match[0]) > length($lazy_match[0])) {
39             # greedy beats lazy for 'aabaab'
40             # greedy: [aabaab, aab]
41             # lazy: [aa, a]
42 5         17 ($i,$j) = @greedy_idx;
43             # greedy's repeated string might itself be repeated, eg.
44             # aabaab in aabaabaabaab.
45             # run an anchored lazy match on greedy's repeated string
46             # to find the shortest repeated string
47 5         67 @token = $greedy_match[0] =~ $LAZY_ANCHORED_RE;
48             }
49             else {
50 491         1475 ($i,$j) = @lazy_idx;
51 491         1441 @token = @lazy_match;
52             }
53              
54 496         4049 require Data::Password::zxcvbn::MatchList;
55 496         3398 my $base_analysis = Data::Password::zxcvbn::MatchList->omnimatch(
56             $token[1],
57             $opts,
58             )->most_guessable_match_list;
59              
60 496         41129 push @matches, $class->new({
61             i => $i, j => $j,
62             token => $token[0],
63             base_token => $token[1],
64             repeat_count => length($token[0]) / length($token[1]),
65             base_guesses => $base_analysis->guesses,
66             base_matches => $base_analysis->matches,
67             });
68              
69 496         26444 $last_index = $j + 1;
70             }
71              
72 1101         5133 return \@matches;
73             }
74              
75              
76             sub estimate_guesses {
77 437     437 1 12255 my ($self) = @_;
78              
79 437         3955 return $self->base_guesses * $self->repeat_count;
80             }
81              
82              
83             sub feedback_warning {
84 38     38 1 175 my ($self) = @_;
85              
86 38 100       436 return length($self->base_token) == 1
87             ? 'Repeats like "aaa" are easy to guess'
88             : 'Repeats like "abcabcabc" are only slightly harder to guess than "abc"'
89             ;
90             }
91              
92             sub feedback_suggestions {
93 38     38 1 240 return [ 'Avoid repeated words and characters' ];
94             }
95              
96              
97             around fields_for_json => sub {
98             my ($orig,$self) = @_;
99             ( $self->$orig(), qw(repeat_count base_guesses base_token base_matches) )
100             };
101              
102             1;
103              
104             __END__
105              
106             =pod
107              
108             =encoding UTF-8
109              
110             =head1 NAME
111              
112             Data::Password::zxcvbn::Match::Repeat - match class for repetitions of other matches
113              
114             =head1 VERSION
115              
116             version 1.1.2
117              
118             =head1 DESCRIPTION
119              
120             This class represents the guess that a certain substring of a password
121             is a repetition of some other kind of match.
122              
123             =head1 ATTRIBUTES
124              
125             =head2 C<repeat_count>
126              
127             integer, how many time the L<< /C<base_token> >> is repeated
128              
129             =head2 C<base_token>
130              
131             the match that is repeated; this will be an instance of some other
132             C<Data::Password::zxcvbn::Match::*> class
133              
134             =head2 C<base_guesses>
135              
136             the minimal estimate of the attempts needed to guess the L<<
137             /C<base_token> >>
138              
139             =head2 C<base_matches>
140              
141             the list of patterns that L<< /C<base_guesses> >> is based on
142              
143             =head1 METHODS
144              
145             =head2 C<make>
146              
147             my @matches = @{ Data::Password::zxcvbn::Match::Repeat->make(
148             $password, \%opts,
149             ) };
150              
151             Scans the C<$password> for repeated substrings, then recursively
152             analyses them like the main L<< C<password_strength>
153             function|Data::Password::zxcvbn/password_strength >> would do:
154              
155             password_strength($substring,\%opts);
156              
157             L<< /C<base_guesses> >> and L<< /C<base_matches> >> come from that
158             recursive call.
159              
160             =head2 C<estimate_guesses>
161              
162             The number of guesses is the L<< /C<base_guesses> >> times the L<<
163             /C<repeat_count> >>.
164              
165             =head2 C<feedback_warning>
166              
167             =head2 C<feedback_suggestions>
168              
169             This class suggests not to repeat substrings.
170              
171             =head2 C<fields_for_json>
172              
173             The JSON serialisation for matches of this class will contain C<token
174             i j guesses guesses_log10 repeat_count base_guesses base_token
175             base_matches>.
176              
177             =head1 AUTHOR
178              
179             Gianni Ceccarelli <gianni.ceccarelli@broadbean.com>
180              
181             =head1 COPYRIGHT AND LICENSE
182              
183             This software is copyright (c) 2022 by BroadBean UK, a CareerBuilder Company.
184              
185             This is free software; you can redistribute it and/or modify it under
186             the same terms as the Perl 5 programming language system itself.
187              
188             =cut