File Coverage

blib/lib/String/MkPasswd.pm
Criterion Covered Total %
statement 106 106 100.0
branch 32 40 80.0
condition 4 5 80.0
subroutine 16 16 100.0
pod 0 1 0.0
total 158 168 94.0


line stmt bran cond sub pod time code
1             package String::MkPasswd;
2              
3 5     5   265440 use 5.006001;
  5         22  
  5         213  
4 5     5   32 use strict;
  5         10  
  5         224  
5 5     5   31 use base qw(Exporter);
  5         13  
  5         812  
6              
7 5     5   29 use Carp qw(croak);
  5         10  
  5         437  
8              
9             # Defaults.
10 5     5   27 use constant LENGTH => 9;
  5         9  
  5         567  
11 5     5   29 use constant MINNUM => 2;
  5         9  
  5         364  
12 5     5   24 use constant MINLOWER => 2;
  5         7  
  5         210  
13 5     5   25 use constant MINUPPER => 2;
  5         9  
  5         308  
14 5     5   26 use constant MINSPECIAL => 1;
  5         6  
  5         244  
15 5     5   66 use constant DISTRIBUTE => "";
  5         9  
  5         227  
16 5     5   30 use constant FATAL => "";
  5         10  
  5         218  
17              
18             # A few conveniences for dealing with homographs
19 5     5   26 use constant ALLOWAMBIGUOUS => 0;
  5         7  
  5         216  
20 5     5   37 use constant NOAMBIGUOUS => 1;
  5         8  
  5         11577  
21             our %IS_AMBIGUOUS = (
22             'o' => 1, # easily confused with zero, especially when capitalized
23             '0' => 1, # easily confused with capital O
24             '1' => 1, # easily confused for lower l or capital I
25             'i' => 1, # especially when capitalized, easily confused for 1, lower l, or pipe
26             'l' => 1, # easily confused for 1 or capital I
27             'v' => 1, # a pair of these looks like w
28             'w' => 1, # one of these looks like a pair of v's
29             'c' => 1, # can be confused for a paren
30             '|' => 1, # easily confused with 1, lower l, or capital I
31             '_' => 1, # easily confused with dash
32             '-' => 1, # easily confused with underscore
33             '.' => 1, # easily confused with comma
34             ',' => 1, # easily confused with period
35             ':' => 1, # easily confused with colon
36             ';' => 1, # easily confused with semicolon
37             ']' => 1, # easily confused with } and )
38             '[' => 1, # easily confused with { and (
39             '(' => 1, # easily confused with { and [
40             ')' => 1, # easily confused with } and ]
41             '{' => 1, # easily confused with ( and [
42             '}' => 1, # easily confused with ) and ]
43             );
44              
45             our %EXPORT_TAGS = (
46             all => [ qw(mkpasswd) ],
47             );
48             our @EXPORT_OK = @{ $EXPORT_TAGS{all} };
49             our $VERSION = "0.05";
50             our $FATAL = "";
51              
52             my %keys = (
53             ALLOWAMBIGUOUS() => {
54             dist => {
55             lkeys => [ qw(q w e r t a s d f g z x c v b) ],
56             rkeys => [ qw(y u i o p h j k l n m) ],
57             lnums => [ qw(1 2 3 4 5 6) ],
58             rnums => [ qw(7 8 9 0) ],
59             lspec => [ qw(! @ $ %), "#" ],
60             rspec => [
61             qw(^ & * ( ) - = _ + [ ] { } \ | ; : ' " < > . ? /), ","
62             ],
63             },
64             undist => {
65             lkeys => [
66             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z)
67             ],
68             lkeys => [
69             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z)
70             ],
71             rkeys => [
72             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z)
73             ],
74             lnums => [ qw(0 1 2 3 4 5 6 7 8 9) ],
75             rnums => [ qw(0 1 2 3 4 5 6 7 8 9) ],
76             lspec => [
77             qw(! @ $ % ~ ^ & * ( ) - = _ + [ ] { } \ | ; : ' " < > . ? /),
78             "#", ","
79             ],
80             rspec => [
81             qw(! @ $ % ~ ^ & * ( ) - = _ + [ ] { } \ | ; : ' " < > . ? /),
82             "#", ","
83             ],
84             },
85             }
86             );
87              
88              
89             # Build unambiguous (NOAMBIGUOUS) keys entries from the ALLOWAMBIGUOUS set
90             foreach my $distribution ( keys %{ $keys{ ALLOWAMBIGUOUS() } } ) {
91             foreach my $block ( keys %{ $keys{ ALLOWAMBIGUOUS() }->{ $distribution } } ) {
92             $keys{ NOAMBIGUOUS() }->{ $distribution }->{ $block } = [
93             grep
94             { ! $IS_AMBIGUOUS{ $_ } }
95             @{ $keys{ ALLOWAMBIGUOUS() }->{ $distribution }->{ $block } }
96             ];
97             }
98             }
99              
100             sub mkpasswd {
101 234 50   234 0 148965 my $class = shift if UNIVERSAL::isa $_[0], __PACKAGE__;
102 234         817 my %args = @_;
103              
104             # Configuration.
105 234   100     1005 my $length = $args{"-length"} || LENGTH;
106 234 100       539 my $minnum = defined $args{"-minnum"}
107             ? $args{"-minnum"}
108             : MINNUM;
109 234 100       548 my $minlower = defined $args{"-minlower"}
110             ? $args{"-minlower"}
111             : MINLOWER;
112 234 100       521 my $minupper = defined $args{"-minupper"}
113             ? $args{"-minupper"}
114             : MINUPPER;
115 234 100       410 my $minspecial = defined $args{"-minspecial"}
116             ? $args{"-minspecial"}
117             : MINSPECIAL;
118 234 50       453 my $distribute = defined $args{"-distribute"}
119             ? $args{"-distribute"}
120             : DISTRIBUTE;
121 234 100       556 my $ambiguousity = defined $args{"-noambiguous"}
122             ? $args{"-noambiguous"}
123             : ALLOWAMBIGUOUS;
124 234 100       413 my $fatal = defined $args{"-fatal"}
125             ? $args{"-fatal"}
126             : FATAL;
127              
128 234 100       733 if ( $minnum + $minlower + $minupper + $minspecial > $length ) {
129 8 100 66     36 if ( $fatal || $FATAL ) {
130 2         423 croak "Impossible to generate $length-character password with "
131             . "$minnum numbers, $minlower lowercase letters, "
132             . "$minupper uppercase letters and $minspecial special "
133             . "characters";
134             } else {
135 6         31 return;
136             }
137             }
138              
139             # If there is any underspecification, use additional lowercase letters.
140 226         639 $minlower = $length - ($minnum + $minupper + $minspecial);
141              
142             # Choose left or right starting hand.
143 226         2642 my $initially_left = my $isleft = int rand 2;
144              
145             # Select distribution of keys.
146 226 50       2165 my $lkeys = $distribute ? $keys{$ambiguousity}{dist}{lkeys} : $keys{$ambiguousity}{undist}{lkeys};
147 226 50       665 my $rkeys = $distribute ? $keys{$ambiguousity}{dist}{rkeys} : $keys{$ambiguousity}{undist}{rkeys};
148 226 50       484 my $lnums = $distribute ? $keys{$ambiguousity}{dist}{lnums} : $keys{$ambiguousity}{undist}{lnums};
149 226 50       1647 my $rnums = $distribute ? $keys{$ambiguousity}{dist}{rnums} : $keys{$ambiguousity}{undist}{rnums};
150 226 50       1100 my $lspec = $distribute ? $keys{$ambiguousity}{dist}{lspec} : $keys{$ambiguousity}{undist}{lspec};
151 226 50       454 my $rspec = $distribute ? $keys{$ambiguousity}{dist}{rspec} : $keys{$ambiguousity}{undist}{rspec};
152              
153             # Generate password.
154              
155 226         792 my @lpass = (undef) x $length; # password chars typed by left hand
156 226         436 my @rpass = (undef) x $length; # password chars typed by right hand
157 226         461 my ($left, $right);
158              
159 226         476 ($left, $right) = &_psplit($minnum, \$isleft);
160 226         828 for ( my $i = 0; $i < $left; $i++ ) {
161 226         1425 &_insert(\@lpass, $lnums->[rand @$lnums]);
162             }
163 226         508 for ( my $i = 0; $i < $right; $i++ ) {
164 225         560 &_insert(\@rpass, $rnums->[rand @$rnums]);
165             }
166              
167 226         408 ($left, $right) = &_psplit($minlower, \$isleft);
168 226         613 for ( my $i = 0; $i < $left; $i++ ) {
169 493         1026 &_insert(\@lpass, $lkeys->[rand @$lkeys]);
170             }
171 226         871 for ( my $i = 0; $i < $right; $i++ ) {
172 483         1306 &_insert(\@rpass, $rkeys->[rand @$rkeys]);
173             }
174              
175 226         434 ($left, $right) = &_psplit($minupper, \$isleft);
176 226         569 for ( my $i = 0; $i < $left; $i++ ) {
177 225         711 &_insert(\@lpass, uc $lkeys->[rand @$lkeys]);
178             }
179 226         512 for ( my $i = 0; $i < $right; $i++ ) {
180 225         786 &_insert(\@rpass, uc $rkeys->[rand @$rkeys]);
181             }
182              
183 226         389 ($left, $right) = &_psplit($minspecial, \$isleft);
184 226         661 for ( my $i = 0; $i < $left; $i++ ) {
185 224         592 &_insert(\@lpass, $lspec->[rand @$lspec]);
186             }
187 226         578 for ( my $i = 0; $i < $right; $i++ ) {
188 1         5 &_insert(\@rpass, $rspec->[rand @$rspec]);
189             }
190              
191             # Merge results together.
192 226 100       388 my $lpass = join "", map { defined $_ ? $_ : () } @lpass;
  2239         7061  
193 226 100       496 my $rpass = join "", map { defined $_ ? $_ : () } @rpass;
  2210         4133  
194              
195 226 100       2041 return $initially_left ? "$lpass$rpass" : "$rpass$lpass";
196             }
197              
198             # Insert $char into password at a random position, thereby spreading the
199             # different kinds of characters throughout the password.
200             sub _insert {
201 2102     2102   2556 my $pass = shift; # ref = ARRAY
202 2102         2440 my $char = shift;
203              
204 2102         2054 my $pos;
205 2102         2276 do {
206 2604         7630 $pos = int rand(1 + @$pass);
207             } while ( defined $pass->[$pos] );
208              
209 2102         7452 $pass->[$pos] = $char;
210             }
211              
212             # Given a size, distribute between left and right hands, taking into account
213             # where we left off.
214             sub _psplit {
215 904     904   1518 my $max = shift;
216 904         959 my $isleft = shift; # ref = SCALAR
217              
218 904         865 my ($left, $right);
219              
220 904 100       1450 if ( $$isleft ) {
221 785         2151 $right = int($max / 2);
222 785         850 $left = $max - $right;
223 785         1275 $$isleft = !($max % 2);
224             } else {
225 119         202 $left = int($max / 2);
226 119         126 $right = $max - $left;
227 119         222 $$isleft = !($max % 2);
228             }
229              
230 904         2001 return ($left, $right);
231             }
232              
233             1;
234              
235             __END__