line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Crypt::HSXKPasswd::Types; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
# inhert from Type::Library |
4
|
3
|
|
|
3
|
|
1635
|
use parent Type::Library; |
|
3
|
|
|
|
|
861
|
|
|
3
|
|
|
|
|
18
|
|
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
# import required modules |
7
|
3
|
|
|
3
|
|
177
|
use strict; |
|
3
|
|
|
|
|
4
|
|
|
3
|
|
|
|
|
63
|
|
8
|
3
|
|
|
3
|
|
13
|
use warnings; |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
111
|
|
9
|
3
|
|
|
3
|
|
13
|
use English qw( -no_match_vars ); |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
23
|
|
10
|
3
|
|
|
3
|
|
1232
|
use Carp; # for nicer 'exceptions' for users of the module |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
181
|
|
11
|
3
|
|
|
3
|
|
13
|
use Fatal qw( :void open close binmode ); # make builtins throw exceptions |
|
3
|
|
|
|
|
4
|
|
|
3
|
|
|
|
|
19
|
|
12
|
3
|
|
|
3
|
|
4318
|
use List::MoreUtils qw( uniq ); |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
35
|
|
13
|
3
|
|
|
3
|
|
3827
|
use Data::Dumper; # for generating sane error messages |
|
3
|
|
|
|
|
17959
|
|
|
3
|
|
|
|
|
216
|
|
14
|
3
|
|
|
3
|
|
24
|
use Type::Tiny; |
|
3
|
|
|
|
|
4
|
|
|
3
|
|
|
|
|
90
|
|
15
|
3
|
|
|
3
|
|
14
|
use Types::Standard qw( :types ); |
|
3
|
|
|
|
|
4
|
|
|
3
|
|
|
|
|
43
|
|
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
# set things up for using UTF-8 |
18
|
3
|
|
|
3
|
|
9814
|
use 5.016; # min Perl for good UTF-8 support, implies feature 'unicode_strings' |
|
3
|
|
|
|
|
8
|
|
19
|
3
|
|
|
3
|
|
1901
|
use Encode qw(encode decode); |
|
3
|
|
|
|
|
25482
|
|
|
3
|
|
|
|
|
267
|
|
20
|
3
|
|
|
3
|
|
1280
|
use utf8; |
|
3
|
|
|
|
|
21
|
|
|
3
|
|
|
|
|
15
|
|
21
|
|
|
|
|
|
|
binmode STDOUT, ':encoding(UTF-8)'; |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
#==============================================================================# |
24
|
|
|
|
|
|
|
# Custom Type Library for Crypt::HSXKPasswd |
25
|
|
|
|
|
|
|
#==============================================================================# |
26
|
|
|
|
|
|
|
# |
27
|
|
|
|
|
|
|
# A library of custom Type::Tiny types for use in the various Crypt::HSXKPasswd |
28
|
|
|
|
|
|
|
# packages. |
29
|
|
|
|
|
|
|
# |
30
|
|
|
|
|
|
|
#==============================================================================# |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
# |
33
|
|
|
|
|
|
|
# === CONSTANTS ===============================================================# |
34
|
|
|
|
|
|
|
# |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
# version info |
37
|
3
|
|
|
3
|
|
1803
|
use version; our $VERSION = qv('1.2'); |
|
3
|
|
|
|
|
5376
|
|
|
3
|
|
|
|
|
17
|
|
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
# |
40
|
|
|
|
|
|
|
# === Define The Fundamental Types ============================================# |
41
|
|
|
|
|
|
|
# |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
# add a type for Perl package names |
44
|
|
|
|
|
|
|
my $PERL_PACKAGE_NAME_ENGLISH = q{a valid Perl Package Name like 'Crypt::HSXKPasswd'}; |
45
|
|
|
|
|
|
|
my $PERL_PACKAGE_NAME = Type::Tiny->new( |
46
|
|
|
|
|
|
|
name => 'PerlPackageName', |
47
|
|
|
|
|
|
|
parent => Str, |
48
|
|
|
|
|
|
|
constraint => sub{ m/^[a-zA-Z_]\w*(?:[:]{2}\w+)*$/sx; }, ## no critic (ProhibitEnumeratedClasses) |
49
|
|
|
|
|
|
|
message => sub{ |
50
|
|
|
|
|
|
|
return var_to_string($_).qq{ is not $PERL_PACKAGE_NAME_ENGLISH}; |
51
|
|
|
|
|
|
|
}, |
52
|
|
|
|
|
|
|
my_methods => { |
53
|
|
|
|
|
|
|
english => sub {return $PERL_PACKAGE_NAME_ENGLISH;}, |
54
|
|
|
|
|
|
|
}, |
55
|
|
|
|
|
|
|
); |
56
|
|
|
|
|
|
|
__PACKAGE__->meta->add_type($PERL_PACKAGE_NAME); |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
# add a type for positive integers (including 0) |
59
|
|
|
|
|
|
|
my $POSITIVE_INTEGER_ENGLISH = 'an integer greater than or equal to zero'; |
60
|
|
|
|
|
|
|
my $POSITIVE_INTEGER = Type::Tiny->new( |
61
|
|
|
|
|
|
|
name => 'PositiveInteger', |
62
|
|
|
|
|
|
|
parent => Int, |
63
|
|
|
|
|
|
|
constraint => sub{ |
64
|
|
|
|
|
|
|
return $_ >= 0; |
65
|
|
|
|
|
|
|
}, |
66
|
|
|
|
|
|
|
message => sub{ |
67
|
|
|
|
|
|
|
return var_to_string($_).qq{ is not $POSITIVE_INTEGER_ENGLISH}; |
68
|
|
|
|
|
|
|
}, |
69
|
|
|
|
|
|
|
my_methods => { |
70
|
|
|
|
|
|
|
english => sub {return $POSITIVE_INTEGER_ENGLISH;}, |
71
|
|
|
|
|
|
|
}, |
72
|
|
|
|
|
|
|
); |
73
|
|
|
|
|
|
|
__PACKAGE__->meta->add_type($POSITIVE_INTEGER); |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
# add a type for positive integers (including 0) |
76
|
|
|
|
|
|
|
my $NON_ZERO_POSITIVE_INTEGER_ENGLISH = 'an integer greater than zero'; |
77
|
|
|
|
|
|
|
my $NON_ZERO_POSITIVE_INTEGER = Type::Tiny->new( |
78
|
|
|
|
|
|
|
name => 'NonZeroPositiveInteger', |
79
|
|
|
|
|
|
|
parent => Int, |
80
|
|
|
|
|
|
|
constraint => sub{ |
81
|
|
|
|
|
|
|
return $_ > 0; |
82
|
|
|
|
|
|
|
}, |
83
|
|
|
|
|
|
|
message => sub{ |
84
|
|
|
|
|
|
|
return var_to_string($_).qq{ is not $NON_ZERO_POSITIVE_INTEGER_ENGLISH}; |
85
|
|
|
|
|
|
|
}, |
86
|
|
|
|
|
|
|
my_methods => { |
87
|
|
|
|
|
|
|
english => sub {return $NON_ZERO_POSITIVE_INTEGER_ENGLISH;}, |
88
|
|
|
|
|
|
|
}, |
89
|
|
|
|
|
|
|
); |
90
|
|
|
|
|
|
|
__PACKAGE__->meta->add_type($NON_ZERO_POSITIVE_INTEGER); |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
# add a type for strings of at least one character |
93
|
|
|
|
|
|
|
my $NON_EMPTY_STRING_ENGLISH = 'a string contianing at least one character'; |
94
|
|
|
|
|
|
|
my $NON_EMPTY_STRING = Type::Tiny->new( |
95
|
|
|
|
|
|
|
name => 'NonEmptyString', |
96
|
|
|
|
|
|
|
parent => Str, |
97
|
|
|
|
|
|
|
constraint => sub{ |
98
|
|
|
|
|
|
|
return length $_ > 0; |
99
|
|
|
|
|
|
|
}, |
100
|
|
|
|
|
|
|
message => sub{ |
101
|
|
|
|
|
|
|
return var_to_string($_).qq{ is not $NON_EMPTY_STRING_ENGLISH}; |
102
|
|
|
|
|
|
|
}, |
103
|
|
|
|
|
|
|
my_methods => { |
104
|
|
|
|
|
|
|
english => sub {return $NON_EMPTY_STRING_ENGLISH;}, |
105
|
|
|
|
|
|
|
}, |
106
|
|
|
|
|
|
|
); |
107
|
|
|
|
|
|
|
__PACKAGE__->meta->add_type($NON_EMPTY_STRING); |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
# add a type for a single letter (a single alpha grapheme) |
110
|
|
|
|
|
|
|
my $LETTER_ENGLISH = q{a string containing exactly one letter}; |
111
|
|
|
|
|
|
|
my $LETTER = Type::Tiny->new( |
112
|
|
|
|
|
|
|
name => 'Letter', |
113
|
|
|
|
|
|
|
parent => Str, |
114
|
|
|
|
|
|
|
constraint => sub{ |
115
|
3
|
|
|
3
|
|
1889
|
return m/^\pL$/sx; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
43
|
|
116
|
|
|
|
|
|
|
}, |
117
|
|
|
|
|
|
|
message => sub{ |
118
|
|
|
|
|
|
|
return var_to_string($_).qq{ is not a Letter (must be $LETTER_ENGLISH)}; |
119
|
|
|
|
|
|
|
}, |
120
|
|
|
|
|
|
|
my_methods => { |
121
|
|
|
|
|
|
|
english => sub {return $LETTER_ENGLISH;}, |
122
|
|
|
|
|
|
|
}, |
123
|
|
|
|
|
|
|
); |
124
|
|
|
|
|
|
|
__PACKAGE__->meta->add_type($LETTER); |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
# add a type for words (a grouping of alpha characters at least four graphemes |
127
|
|
|
|
|
|
|
# long) |
128
|
|
|
|
|
|
|
my $WORD_ENGLISH = q{a string of only letters at least four long}; |
129
|
|
|
|
|
|
|
my $WORD = Type::Tiny->new( |
130
|
|
|
|
|
|
|
name => 'Word', |
131
|
|
|
|
|
|
|
parent => Str, |
132
|
|
|
|
|
|
|
constraint => sub{ |
133
|
|
|
|
|
|
|
return m/^\pL{4,}$/sx; |
134
|
|
|
|
|
|
|
}, |
135
|
|
|
|
|
|
|
message => sub{ |
136
|
|
|
|
|
|
|
return var_to_string($_).qq{ is not a Word (must be $WORD_ENGLISH)}; |
137
|
|
|
|
|
|
|
}, |
138
|
|
|
|
|
|
|
my_methods => { |
139
|
|
|
|
|
|
|
english => sub {return $WORD_ENGLISH;}, |
140
|
|
|
|
|
|
|
}, |
141
|
|
|
|
|
|
|
); |
142
|
|
|
|
|
|
|
__PACKAGE__->meta->add_type($WORD); |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
# add a type for a single symbol (a single non-letter unicode grapheme) |
145
|
|
|
|
|
|
|
my $SYMBOL_ENGLISH = 'a string containing exactly one non-letter character'; |
146
|
|
|
|
|
|
|
my $SYMBOL = Type::Tiny->new( |
147
|
|
|
|
|
|
|
name => 'Symbol', |
148
|
|
|
|
|
|
|
parent => Str, |
149
|
|
|
|
|
|
|
constraint => sub{ |
150
|
|
|
|
|
|
|
return m/^\X$/sx && m/^[^\pL]$/sx; |
151
|
|
|
|
|
|
|
}, |
152
|
|
|
|
|
|
|
message => sub{ |
153
|
|
|
|
|
|
|
return var_to_string($_).qq{ is not a Symbol (must be $SYMBOL_ENGLISH)}; |
154
|
|
|
|
|
|
|
}, |
155
|
|
|
|
|
|
|
my_methods => { |
156
|
|
|
|
|
|
|
english => sub {return $SYMBOL_ENGLISH;}, |
157
|
|
|
|
|
|
|
}, |
158
|
|
|
|
|
|
|
); |
159
|
|
|
|
|
|
|
__PACKAGE__->meta->add_type($SYMBOL); |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
# add a type for symbol alphabets - array refs containing only, and at least 2, |
162
|
|
|
|
|
|
|
# single-character strings |
163
|
|
|
|
|
|
|
my $SYMBOL_ALPHABET_ENGLISH = 'a reference to an array of distinct Symbols at least two long'; |
164
|
|
|
|
|
|
|
my $SYMBOL_ALPHABET = Type::Tiny->new( |
165
|
|
|
|
|
|
|
name => 'SymbolAlphabet', |
166
|
|
|
|
|
|
|
parent => ArrayRef[$SYMBOL], |
167
|
|
|
|
|
|
|
constraint => sub{ |
168
|
|
|
|
|
|
|
my @unique_symbols = uniq(@{$_}); |
169
|
|
|
|
|
|
|
return scalar @unique_symbols >= 2; |
170
|
|
|
|
|
|
|
}, |
171
|
|
|
|
|
|
|
message => sub{ |
172
|
|
|
|
|
|
|
return var_to_string($_).qq{ is not a Symbol Alphabet (must be $SYMBOL_ALPHABET_ENGLISH)}; |
173
|
|
|
|
|
|
|
}, |
174
|
|
|
|
|
|
|
my_methods => { |
175
|
|
|
|
|
|
|
english => sub {return $SYMBOL_ALPHABET_ENGLISH;}, |
176
|
|
|
|
|
|
|
}, |
177
|
|
|
|
|
|
|
); |
178
|
|
|
|
|
|
|
__PACKAGE__->meta->add_type($SYMBOL_ALPHABET); |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
# add a type for word lengths - integers greater than 3 |
181
|
|
|
|
|
|
|
my $WORD_LENGTH_ENGLISH = 'an integer greater than 3'; |
182
|
|
|
|
|
|
|
my $WORD_LENGTH = Type::Tiny->new( |
183
|
|
|
|
|
|
|
name => 'WordLength', |
184
|
|
|
|
|
|
|
parent => Int, |
185
|
|
|
|
|
|
|
constraint => sub{ |
186
|
|
|
|
|
|
|
return $_ > 3; |
187
|
|
|
|
|
|
|
}, |
188
|
|
|
|
|
|
|
message => sub{ |
189
|
|
|
|
|
|
|
return var_to_string($_).qq{ is not a valid Word Length (must be $WORD_LENGTH_ENGLISH)}; |
190
|
|
|
|
|
|
|
}, |
191
|
|
|
|
|
|
|
my_methods => { |
192
|
|
|
|
|
|
|
english => sub {return $WORD_LENGTH_ENGLISH;}, |
193
|
|
|
|
|
|
|
}, |
194
|
|
|
|
|
|
|
); |
195
|
|
|
|
|
|
|
__PACKAGE__->meta->add_type($WORD_LENGTH); |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
# add a type for word lengths - integers greater than 3 |
198
|
|
|
|
|
|
|
my $TRUE_FALSE_ENGLISH = '1 to indicate true, or 0, undef, or the empty string to indicate false'; |
199
|
|
|
|
|
|
|
my $TRUE_FALSE = Type::Tiny->new( |
200
|
|
|
|
|
|
|
name => 'TrueFalse', |
201
|
|
|
|
|
|
|
parent => Bool, |
202
|
|
|
|
|
|
|
message => sub{ |
203
|
|
|
|
|
|
|
return var_to_string($_).qq{ is not a valid True/False value (must be $TRUE_FALSE_ENGLISH)}; |
204
|
|
|
|
|
|
|
}, |
205
|
|
|
|
|
|
|
my_methods => { |
206
|
|
|
|
|
|
|
english => sub {return $TRUE_FALSE_ENGLISH;}, |
207
|
|
|
|
|
|
|
}, |
208
|
|
|
|
|
|
|
); |
209
|
|
|
|
|
|
|
__PACKAGE__->meta->add_type($TRUE_FALSE); |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
# |
212
|
|
|
|
|
|
|
# === Define HSXKPasswd-specific general Types ================================# |
213
|
|
|
|
|
|
|
# |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
# add a type for upper-case identifiers |
216
|
|
|
|
|
|
|
my $UPPERCASE_IDENTIFIER_ENGLISH = 'a non-empty string containging only upper-case un-accented letters, digits and underscores'; |
217
|
|
|
|
|
|
|
my $UPPERCASE_IDENTIFIER = Type::Tiny->new( |
218
|
|
|
|
|
|
|
name => 'UppercaseIdentifier', |
219
|
|
|
|
|
|
|
parent => Str, |
220
|
|
|
|
|
|
|
constraint => sub{ |
221
|
|
|
|
|
|
|
return m/^[A-Z0-9_]+$/sx; ## no critic (ProhibitEnumeratedClasses) |
222
|
|
|
|
|
|
|
}, |
223
|
|
|
|
|
|
|
message => sub{ |
224
|
|
|
|
|
|
|
return var_to_string($_).qq{ is not $UPPERCASE_IDENTIFIER_ENGLISH}; |
225
|
|
|
|
|
|
|
}, |
226
|
|
|
|
|
|
|
my_methods => { |
227
|
|
|
|
|
|
|
english => sub {return $UPPERCASE_IDENTIFIER_ENGLISH;}, |
228
|
|
|
|
|
|
|
}, |
229
|
|
|
|
|
|
|
); |
230
|
|
|
|
|
|
|
__PACKAGE__->meta->add_type($UPPERCASE_IDENTIFIER); |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
# add a type for entropy warning levels |
233
|
|
|
|
|
|
|
my $ENTROPY_WARNING_LEVEL_ENGLISH = q{one of 'ALL', 'BLIND', or 'NONE'}; |
234
|
|
|
|
|
|
|
my $ENTROPY_WARNING_LEVEL = Type::Tiny->new( |
235
|
|
|
|
|
|
|
name => 'EntropyWarningLevel', |
236
|
|
|
|
|
|
|
parent => Str, |
237
|
|
|
|
|
|
|
constraint => sub{ |
238
|
|
|
|
|
|
|
return m/^[A-Z0-9_]+$/sx; ## no critic (ProhibitEnumeratedClasses) |
239
|
|
|
|
|
|
|
}, |
240
|
|
|
|
|
|
|
message => sub{ |
241
|
|
|
|
|
|
|
return var_to_string($_).qq{ is not a valid entropy warning level, must be $ENTROPY_WARNING_LEVEL_ENGLISH}; |
242
|
|
|
|
|
|
|
}, |
243
|
|
|
|
|
|
|
my_methods => { |
244
|
|
|
|
|
|
|
english => sub {return $ENTROPY_WARNING_LEVEL_ENGLISH;}, |
245
|
|
|
|
|
|
|
}, |
246
|
|
|
|
|
|
|
); |
247
|
|
|
|
|
|
|
$ENTROPY_WARNING_LEVEL->coercion()->add_type_coercions(Str, q{uc $_}); ## no critic (RequireInterpolationOfMetachars) |
248
|
|
|
|
|
|
|
__PACKAGE__->meta->add_type($ENTROPY_WARNING_LEVEL); |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
# |
251
|
|
|
|
|
|
|
# === Define the Config Keys and related Types ================================# |
252
|
|
|
|
|
|
|
# |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
# add a type for config key definitions - a hashref with the correct indexes and values |
255
|
|
|
|
|
|
|
my $CONFIG_KEY_DEFINITION_ENGLISH = q{a reference to a hash mapping 'required' to a true/false value, 'expects' to a non-empty string, and 'type' to a Type::Tiny object}; |
256
|
|
|
|
|
|
|
my $CONFIG_KEY_DEFINITION = Type::Tiny->new( |
257
|
|
|
|
|
|
|
name => 'ConfigKeyDefinition', |
258
|
|
|
|
|
|
|
parent => Dict[required => $TRUE_FALSE, expects => $NON_EMPTY_STRING, type => InstanceOf['Type::Tiny']] , |
259
|
|
|
|
|
|
|
message => sub{ |
260
|
|
|
|
|
|
|
return var_to_string($_).qq{ is not a valid Config Key Definition (must be $CONFIG_KEY_DEFINITION_ENGLISH)}; |
261
|
|
|
|
|
|
|
}, |
262
|
|
|
|
|
|
|
my_methods => { |
263
|
|
|
|
|
|
|
english => sub {return $CONFIG_KEY_DEFINITION_ENGLISH;}, |
264
|
|
|
|
|
|
|
}, |
265
|
|
|
|
|
|
|
); |
266
|
|
|
|
|
|
|
__PACKAGE__->meta->add_type($CONFIG_KEY_DEFINITION); |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
# define the config keys |
269
|
|
|
|
|
|
|
my $_KEYS = { |
270
|
|
|
|
|
|
|
allow_accents => { |
271
|
|
|
|
|
|
|
required => 0, |
272
|
|
|
|
|
|
|
expects => $TRUE_FALSE_ENGLISH, |
273
|
|
|
|
|
|
|
type => Type::Tiny->new( |
274
|
|
|
|
|
|
|
parent => $TRUE_FALSE, |
275
|
|
|
|
|
|
|
message => sub { |
276
|
|
|
|
|
|
|
return _config_key_message($_, 'allow_accents', $TRUE_FALSE_ENGLISH); |
277
|
|
|
|
|
|
|
}, |
278
|
|
|
|
|
|
|
), |
279
|
|
|
|
|
|
|
}, |
280
|
|
|
|
|
|
|
symbol_alphabet => { |
281
|
|
|
|
|
|
|
required => 0, |
282
|
|
|
|
|
|
|
expects => $SYMBOL_ALPHABET_ENGLISH, |
283
|
|
|
|
|
|
|
type => Type::Tiny->new( |
284
|
|
|
|
|
|
|
parent => $SYMBOL_ALPHABET, |
285
|
|
|
|
|
|
|
message => sub { |
286
|
|
|
|
|
|
|
return _config_key_message($_, 'key symbol_alphabet', $SYMBOL_ALPHABET_ENGLISH); |
287
|
|
|
|
|
|
|
}, |
288
|
|
|
|
|
|
|
), |
289
|
|
|
|
|
|
|
}, |
290
|
|
|
|
|
|
|
separator_alphabet => { |
291
|
|
|
|
|
|
|
required => 0, |
292
|
|
|
|
|
|
|
expects => $SYMBOL_ALPHABET_ENGLISH, |
293
|
|
|
|
|
|
|
type => Type::Tiny->new( |
294
|
|
|
|
|
|
|
parent => $SYMBOL_ALPHABET, |
295
|
|
|
|
|
|
|
message => sub { |
296
|
|
|
|
|
|
|
return _config_key_message($_, 'separator_alphabet', $SYMBOL_ALPHABET_ENGLISH); |
297
|
|
|
|
|
|
|
}, |
298
|
|
|
|
|
|
|
), |
299
|
|
|
|
|
|
|
}, |
300
|
|
|
|
|
|
|
padding_alphabet => { |
301
|
|
|
|
|
|
|
required => 0, |
302
|
|
|
|
|
|
|
expects => $SYMBOL_ALPHABET_ENGLISH, |
303
|
|
|
|
|
|
|
type => Type::Tiny->new( |
304
|
|
|
|
|
|
|
parent => $SYMBOL_ALPHABET, |
305
|
|
|
|
|
|
|
message => sub { |
306
|
|
|
|
|
|
|
return _config_key_message($_, 'padding_alphabet', $SYMBOL_ALPHABET_ENGLISH); |
307
|
|
|
|
|
|
|
}, |
308
|
|
|
|
|
|
|
), |
309
|
|
|
|
|
|
|
}, |
310
|
|
|
|
|
|
|
word_length_min => { |
311
|
|
|
|
|
|
|
required => 1, |
312
|
|
|
|
|
|
|
expects => $WORD_LENGTH_ENGLISH, |
313
|
|
|
|
|
|
|
type => Type::Tiny->new( |
314
|
|
|
|
|
|
|
parent => $WORD_LENGTH, |
315
|
|
|
|
|
|
|
message => sub { |
316
|
|
|
|
|
|
|
return _config_key_message($_, 'word_length_min', $WORD_LENGTH_ENGLISH); |
317
|
|
|
|
|
|
|
}, |
318
|
|
|
|
|
|
|
), |
319
|
|
|
|
|
|
|
}, |
320
|
|
|
|
|
|
|
word_length_max => { |
321
|
|
|
|
|
|
|
required => 1, |
322
|
|
|
|
|
|
|
expects => $WORD_LENGTH_ENGLISH, |
323
|
|
|
|
|
|
|
type => Type::Tiny->new( |
324
|
|
|
|
|
|
|
parent => $WORD_LENGTH, |
325
|
|
|
|
|
|
|
message => sub { |
326
|
|
|
|
|
|
|
return _config_key_message($_, 'word_length_max', $WORD_LENGTH_ENGLISH); |
327
|
|
|
|
|
|
|
}, |
328
|
|
|
|
|
|
|
), |
329
|
|
|
|
|
|
|
}, |
330
|
|
|
|
|
|
|
padding_digits_before => { |
331
|
|
|
|
|
|
|
required => 1, |
332
|
|
|
|
|
|
|
expects => $POSITIVE_INTEGER_ENGLISH, |
333
|
|
|
|
|
|
|
type => Type::Tiny->new( |
334
|
|
|
|
|
|
|
parent => $POSITIVE_INTEGER, |
335
|
|
|
|
|
|
|
message => sub { |
336
|
|
|
|
|
|
|
return _config_key_message($_, 'padding_digits_before', $POSITIVE_INTEGER_ENGLISH); |
337
|
|
|
|
|
|
|
}, |
338
|
|
|
|
|
|
|
), |
339
|
|
|
|
|
|
|
}, |
340
|
|
|
|
|
|
|
padding_digits_after => { |
341
|
|
|
|
|
|
|
required => 1, |
342
|
|
|
|
|
|
|
expects => $POSITIVE_INTEGER_ENGLISH, |
343
|
|
|
|
|
|
|
type => Type::Tiny->new( |
344
|
|
|
|
|
|
|
parent => $POSITIVE_INTEGER, |
345
|
|
|
|
|
|
|
message => sub { |
346
|
|
|
|
|
|
|
return _config_key_message($_, 'padding_digits_after', $POSITIVE_INTEGER_ENGLISH); |
347
|
|
|
|
|
|
|
}, |
348
|
|
|
|
|
|
|
), |
349
|
|
|
|
|
|
|
}, |
350
|
|
|
|
|
|
|
padding_characters_before => { |
351
|
|
|
|
|
|
|
required => 0, |
352
|
|
|
|
|
|
|
expects => $POSITIVE_INTEGER_ENGLISH, |
353
|
|
|
|
|
|
|
type => Type::Tiny->new( |
354
|
|
|
|
|
|
|
parent => $POSITIVE_INTEGER, |
355
|
|
|
|
|
|
|
message => sub { |
356
|
|
|
|
|
|
|
return _config_key_message($_, 'padding_characters_before', $POSITIVE_INTEGER_ENGLISH); |
357
|
|
|
|
|
|
|
}, |
358
|
|
|
|
|
|
|
), |
359
|
|
|
|
|
|
|
}, |
360
|
|
|
|
|
|
|
padding_characters_after => { |
361
|
|
|
|
|
|
|
required => 0, |
362
|
|
|
|
|
|
|
expects => $POSITIVE_INTEGER_ENGLISH, |
363
|
|
|
|
|
|
|
type => Type::Tiny->new( |
364
|
|
|
|
|
|
|
parent => $POSITIVE_INTEGER, |
365
|
|
|
|
|
|
|
message => sub { |
366
|
|
|
|
|
|
|
return _config_key_message($_, 'padding_characters_after', $POSITIVE_INTEGER_ENGLISH); |
367
|
|
|
|
|
|
|
}, |
368
|
|
|
|
|
|
|
), |
369
|
|
|
|
|
|
|
}, |
370
|
|
|
|
|
|
|
}; |
371
|
|
|
|
|
|
|
$_KEYS->{num_words} = { |
372
|
|
|
|
|
|
|
required => 1, |
373
|
|
|
|
|
|
|
expects => 'an integer greater than or equal to two', |
374
|
|
|
|
|
|
|
}; |
375
|
|
|
|
|
|
|
$_KEYS->{num_words}->{type} = Type::Tiny->new( |
376
|
|
|
|
|
|
|
parent => Int, |
377
|
|
|
|
|
|
|
constraint => sub{ |
378
|
|
|
|
|
|
|
return $_ >= 2; |
379
|
|
|
|
|
|
|
}, |
380
|
|
|
|
|
|
|
message => sub { |
381
|
|
|
|
|
|
|
return _config_key_message($_, 'num_words', $_KEYS->{num_words}->{expects}); |
382
|
|
|
|
|
|
|
}, |
383
|
|
|
|
|
|
|
); |
384
|
|
|
|
|
|
|
$_KEYS->{separator_character} = { |
385
|
|
|
|
|
|
|
required => 1, |
386
|
|
|
|
|
|
|
expects => q{a single Symbol or one of the special values: 'NONE' or 'RANDOM'}, |
387
|
|
|
|
|
|
|
}; |
388
|
|
|
|
|
|
|
$_KEYS->{separator_character}->{type} = Type::Tiny->new( |
389
|
|
|
|
|
|
|
parent => Str, |
390
|
|
|
|
|
|
|
constraint => sub{ |
391
|
|
|
|
|
|
|
return $SYMBOL->check($_) || m/^(?:NONE)|(?:RANDOM)$/sx; |
392
|
|
|
|
|
|
|
}, |
393
|
|
|
|
|
|
|
message => sub { |
394
|
|
|
|
|
|
|
return _config_key_message($_, 'separator_character', $_KEYS->{separator_character}->{expects}); |
395
|
|
|
|
|
|
|
}, |
396
|
|
|
|
|
|
|
); |
397
|
|
|
|
|
|
|
$_KEYS->{padding_type} = { |
398
|
|
|
|
|
|
|
required => 1, |
399
|
|
|
|
|
|
|
expects => q{one of the values 'NONE', 'FIXED', or 'ADAPTIVE'}, |
400
|
|
|
|
|
|
|
}; |
401
|
|
|
|
|
|
|
$_KEYS->{padding_type}->{type} = Type::Tiny->new( |
402
|
|
|
|
|
|
|
parent => Enum[qw( NONE FIXED ADAPTIVE )], |
403
|
|
|
|
|
|
|
message => sub { |
404
|
|
|
|
|
|
|
return _config_key_message($_, 'key padding_type', $_KEYS->{padding_type}->{expects}); |
405
|
|
|
|
|
|
|
}, |
406
|
|
|
|
|
|
|
); |
407
|
|
|
|
|
|
|
$_KEYS->{pad_to_length} = { |
408
|
|
|
|
|
|
|
required => 0, |
409
|
|
|
|
|
|
|
expects => 'an integer greater than or equal to twelve', |
410
|
|
|
|
|
|
|
}; |
411
|
|
|
|
|
|
|
$_KEYS->{pad_to_length}->{type} = Type::Tiny->new( |
412
|
|
|
|
|
|
|
parent => Int, |
413
|
|
|
|
|
|
|
constraint => sub{ |
414
|
|
|
|
|
|
|
return $_ >= 12; |
415
|
|
|
|
|
|
|
}, |
416
|
|
|
|
|
|
|
message => sub { |
417
|
|
|
|
|
|
|
return _config_key_message($_, 'pad_to_length', $_KEYS->{pad_to_length}->{expects}); |
418
|
|
|
|
|
|
|
}, |
419
|
|
|
|
|
|
|
); |
420
|
|
|
|
|
|
|
$_KEYS->{padding_character} = { |
421
|
|
|
|
|
|
|
required => 0, |
422
|
|
|
|
|
|
|
expects => q{a single Symbol or one of the special values: 'NONE', 'RANDOM', or 'SEPARATOR'}, |
423
|
|
|
|
|
|
|
}; |
424
|
|
|
|
|
|
|
$_KEYS->{padding_character}->{type} = Type::Tiny->new( |
425
|
|
|
|
|
|
|
parent => Str, |
426
|
|
|
|
|
|
|
constraint => sub{ |
427
|
|
|
|
|
|
|
return $SYMBOL->check($_) || m/^(?:NONE)|(?:RANDOM)|(?:SEPARATOR)$/sx; |
428
|
|
|
|
|
|
|
}, |
429
|
|
|
|
|
|
|
message => sub { |
430
|
|
|
|
|
|
|
return _config_key_message($_, 'padding_character', $_KEYS->{padding_character}->{expects}); |
431
|
|
|
|
|
|
|
}, |
432
|
|
|
|
|
|
|
); |
433
|
|
|
|
|
|
|
$_KEYS->{case_transform} = { |
434
|
|
|
|
|
|
|
required => 0, |
435
|
|
|
|
|
|
|
expects => q{one of the values 'NONE' , 'UPPER', 'LOWER', 'CAPITALISE', 'INVERT', 'ALTERNATE', or 'RANDOM'}, |
436
|
|
|
|
|
|
|
}; |
437
|
|
|
|
|
|
|
$_KEYS->{case_transform}->{type} = Type::Tiny->new( |
438
|
|
|
|
|
|
|
parent => Enum[qw( NONE UPPER LOWER CAPITALISE INVERT ALTERNATE RANDOM )], |
439
|
|
|
|
|
|
|
message => sub { |
440
|
|
|
|
|
|
|
return _config_key_message($_, 'case_transform', $_KEYS->{case_transform}->{expects}); |
441
|
|
|
|
|
|
|
}, |
442
|
|
|
|
|
|
|
); |
443
|
|
|
|
|
|
|
$_KEYS->{character_substitutions} = { |
444
|
|
|
|
|
|
|
required => 0, |
445
|
|
|
|
|
|
|
expects => 'a reference to a hash mapping zero or more Letters to their replacements which must be strings', |
446
|
|
|
|
|
|
|
}; |
447
|
|
|
|
|
|
|
$_KEYS->{character_substitutions}->{type} = Type::Tiny->new( |
448
|
|
|
|
|
|
|
parent => Map[$LETTER, Str], |
449
|
|
|
|
|
|
|
message => sub { |
450
|
|
|
|
|
|
|
return _config_key_message($_, 'character_substitutions', $_KEYS->{character_substitutions}->{expects}); |
451
|
|
|
|
|
|
|
}, |
452
|
|
|
|
|
|
|
); |
453
|
|
|
|
|
|
|
|
454
|
|
|
|
|
|
|
# add a type for config key names |
455
|
|
|
|
|
|
|
my $CONFIG_KEY_NAME_ENGLISH = 'for a list of all defined config key names see the docs, or the output from the function Crypt::HSXKPasswd->defined_config_keys()'; |
456
|
|
|
|
|
|
|
my $CONFIG_KEY_NAME = Type::Tiny->new( |
457
|
|
|
|
|
|
|
name => 'ConfigKeyName', |
458
|
|
|
|
|
|
|
parent => Str, |
459
|
|
|
|
|
|
|
constraint => sub{ |
460
|
|
|
|
|
|
|
my $test_val = $_; |
461
|
|
|
|
|
|
|
foreach my $key_name (keys %{$_KEYS}){ |
462
|
|
|
|
|
|
|
if($test_val eq $key_name){ |
463
|
|
|
|
|
|
|
return 1; |
464
|
|
|
|
|
|
|
} |
465
|
|
|
|
|
|
|
} |
466
|
|
|
|
|
|
|
return 0; |
467
|
|
|
|
|
|
|
}, |
468
|
|
|
|
|
|
|
message => sub{ |
469
|
|
|
|
|
|
|
return var_to_string($_).qq{ is not a defined Config Name ($CONFIG_KEY_NAME_ENGLISH)}; |
470
|
|
|
|
|
|
|
}, |
471
|
|
|
|
|
|
|
my_methods => { |
472
|
|
|
|
|
|
|
english => sub {return 'a defined config name - '.$CONFIG_KEY_NAME_ENGLISH;}, |
473
|
|
|
|
|
|
|
}, |
474
|
|
|
|
|
|
|
); |
475
|
|
|
|
|
|
|
$CONFIG_KEY_NAME->coercion()->add_type_coercions(Str, q{lc $_}); ## no critic (RequireInterpolationOfMetachars) |
476
|
|
|
|
|
|
|
__PACKAGE__->meta->add_type($CONFIG_KEY_NAME); |
477
|
|
|
|
|
|
|
|
478
|
|
|
|
|
|
|
# add a type for a config key name-value pair - must be a reference to a |
479
|
|
|
|
|
|
|
# hash with exactly one key, which must be a valid config key, and the |
480
|
|
|
|
|
|
|
# value accompanying that key must be valid for the given key |
481
|
|
|
|
|
|
|
my $CONFIG_KEY_ASSIGNMENT_ENGLISH = 'a mapping from a valid config key name to a valid value for that key'; |
482
|
|
|
|
|
|
|
my $CONFIG_KEY_ASSIGNMENT = Type::Tiny->new( |
483
|
|
|
|
|
|
|
name => 'ConfigKeyAssignment', |
484
|
|
|
|
|
|
|
parent => Map[$CONFIG_KEY_NAME, Item], |
485
|
|
|
|
|
|
|
coercion => 1, |
486
|
|
|
|
|
|
|
constraint => sub{ |
487
|
|
|
|
|
|
|
# make sure there is exactly 1 key |
488
|
|
|
|
|
|
|
unless(scalar keys %{$_} == 1){ |
489
|
|
|
|
|
|
|
return 0; |
490
|
|
|
|
|
|
|
} |
491
|
|
|
|
|
|
|
|
492
|
|
|
|
|
|
|
# extract the key and value |
493
|
|
|
|
|
|
|
my $key = (keys %{$_})[0]; |
494
|
|
|
|
|
|
|
my $val = $_->{$key}; |
495
|
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
# validate the value and return the result |
497
|
|
|
|
|
|
|
return $_KEYS->{$key}->{type}->check($val); |
498
|
|
|
|
|
|
|
}, |
499
|
|
|
|
|
|
|
message => sub{ |
500
|
|
|
|
|
|
|
# if we were not even passed a single-keyed hash, give the basic error |
501
|
|
|
|
|
|
|
unless(HashRef->check($_) && scalar keys %{$_} == 1){ |
502
|
|
|
|
|
|
|
return var_to_string($_).qq{ is not a valid Config Key Assignment (must be $CONFIG_KEY_ASSIGNMENT_ENGLISH)}; |
503
|
|
|
|
|
|
|
} |
504
|
|
|
|
|
|
|
|
505
|
|
|
|
|
|
|
# extract the key and value |
506
|
|
|
|
|
|
|
my $key = (keys %{$_})[0]; |
507
|
|
|
|
|
|
|
my $val = $_->{$key}; |
508
|
|
|
|
|
|
|
|
509
|
|
|
|
|
|
|
# if the config key is not valid, offer help with that |
510
|
|
|
|
|
|
|
unless($CONFIG_KEY_NAME->check($key)){ |
511
|
|
|
|
|
|
|
return var_to_string($_).' is not a valid Config Key Assignment because the specified key name '.var_to_string($key). " is not defined - $CONFIG_KEY_NAME_ENGLISH"; |
512
|
|
|
|
|
|
|
} |
513
|
|
|
|
|
|
|
|
514
|
|
|
|
|
|
|
# if we got here the problem must be with the value, so give useful info about the expected value |
515
|
|
|
|
|
|
|
return var_to_string($_).' is not a valid Config Key Assignment because '.$_KEYS->{$key}->{type}->get_message($val); |
516
|
|
|
|
|
|
|
}, |
517
|
|
|
|
|
|
|
my_methods => { |
518
|
|
|
|
|
|
|
english => sub {return $CONFIG_KEY_ASSIGNMENT_ENGLISH;}, |
519
|
|
|
|
|
|
|
}, |
520
|
|
|
|
|
|
|
); |
521
|
|
|
|
|
|
|
__PACKAGE__->meta->add_type($CONFIG_KEY_ASSIGNMENT); |
522
|
|
|
|
|
|
|
|
523
|
|
|
|
|
|
|
# a type for config overrides |
524
|
|
|
|
|
|
|
my $CONFIG_OVERRIDE_ENGLISH = 'a reference to a hash containing one or more Config Key Assignments'; |
525
|
|
|
|
|
|
|
my $CONFIG_OVERRIDE = Type::Tiny->new( |
526
|
|
|
|
|
|
|
name => 'ConfigOverride', |
527
|
|
|
|
|
|
|
parent => Map[$CONFIG_KEY_NAME, Item], |
528
|
|
|
|
|
|
|
coercion => 1, |
529
|
|
|
|
|
|
|
constraint => sub{ |
530
|
|
|
|
|
|
|
my %test_hash = %{$_}; |
531
|
|
|
|
|
|
|
|
532
|
|
|
|
|
|
|
# make sure at least one key is specified |
533
|
|
|
|
|
|
|
unless(scalar keys %test_hash){ |
534
|
|
|
|
|
|
|
return 0; |
535
|
|
|
|
|
|
|
} |
536
|
|
|
|
|
|
|
|
537
|
|
|
|
|
|
|
# make sure each key specified maps to a valid value |
538
|
|
|
|
|
|
|
foreach my $key (keys %test_hash){ |
539
|
|
|
|
|
|
|
unless($CONFIG_KEY_ASSIGNMENT->check({$key => $test_hash{$key}})){ |
540
|
|
|
|
|
|
|
return 0; |
541
|
|
|
|
|
|
|
} |
542
|
|
|
|
|
|
|
} |
543
|
|
|
|
|
|
|
|
544
|
|
|
|
|
|
|
# if we got here, all is well, so return 1 |
545
|
|
|
|
|
|
|
return 1; |
546
|
|
|
|
|
|
|
}, |
547
|
|
|
|
|
|
|
message => sub{ |
548
|
|
|
|
|
|
|
# if we were not even passed a hash, give the basic error |
549
|
|
|
|
|
|
|
unless(HashRef->check($_)){ |
550
|
|
|
|
|
|
|
return var_to_string($_).qq{ is not a valid Config Override (must be $CONFIG_OVERRIDE_ENGLISH)}; |
551
|
|
|
|
|
|
|
} |
552
|
|
|
|
|
|
|
|
553
|
|
|
|
|
|
|
# get an easy reference to the hash |
554
|
|
|
|
|
|
|
my %overrides = %{$_}; |
555
|
|
|
|
|
|
|
|
556
|
|
|
|
|
|
|
# make sure at least one key is present |
557
|
|
|
|
|
|
|
unless(scalar keys %overrides){ |
558
|
|
|
|
|
|
|
return var_to_string($_)." is not a valid Config Override because it is empty (must be $CONFIG_OVERRIDE_ENGLISH)"; |
559
|
|
|
|
|
|
|
} |
560
|
|
|
|
|
|
|
|
561
|
|
|
|
|
|
|
# check for invalid names |
562
|
|
|
|
|
|
|
my @invalid_key_names = _extract_invalid_key_names(\%overrides); |
563
|
|
|
|
|
|
|
if(scalar @invalid_key_names){ |
564
|
|
|
|
|
|
|
my $msg = var_to_string($_)." is not a valid Config Override because it contains one or more invalid Config Key Names:\n"; |
565
|
|
|
|
|
|
|
foreach my $key (sort @invalid_key_names){ |
566
|
|
|
|
|
|
|
$msg .= "* '$key'\n"; |
567
|
|
|
|
|
|
|
} |
568
|
|
|
|
|
|
|
$msg .= "($CONFIG_KEY_NAME_ENGLISH)"; |
569
|
|
|
|
|
|
|
return $msg; |
570
|
|
|
|
|
|
|
} |
571
|
|
|
|
|
|
|
|
572
|
|
|
|
|
|
|
# it must be down to invalid values, find the offending key(s) |
573
|
|
|
|
|
|
|
my @invalid_valued_keys = _extract_invalid_valued_keys(\%overrides); |
574
|
|
|
|
|
|
|
if(scalar @invalid_valued_keys){ |
575
|
|
|
|
|
|
|
my $msg = var_to_string($_)." is not a valid Config Override because one of more of the config keys specify an invalid value:\n"; |
576
|
|
|
|
|
|
|
foreach my $key_name (@invalid_valued_keys){ |
577
|
|
|
|
|
|
|
$msg .= '* '.$_KEYS->{$key_name}->{type}->get_message($overrides{$key_name})."\n"; |
578
|
|
|
|
|
|
|
} |
579
|
|
|
|
|
|
|
chomp $msg; |
580
|
|
|
|
|
|
|
return $msg; |
581
|
|
|
|
|
|
|
} |
582
|
|
|
|
|
|
|
|
583
|
|
|
|
|
|
|
# it should not be possible to get here, but to be sure to be sure, return a basic message |
584
|
|
|
|
|
|
|
return var_to_string($_)." is not a valid Config Override for an unexpected reason - (must be $CONFIG_OVERRIDE_ENGLISH)"; |
585
|
|
|
|
|
|
|
}, |
586
|
|
|
|
|
|
|
my_methods => { |
587
|
|
|
|
|
|
|
english => sub {return $CONFIG_OVERRIDE_ENGLISH;}, |
588
|
|
|
|
|
|
|
}, |
589
|
|
|
|
|
|
|
); |
590
|
|
|
|
|
|
|
__PACKAGE__->meta->add_type($CONFIG_OVERRIDE); |
591
|
|
|
|
|
|
|
|
592
|
|
|
|
|
|
|
# add a type for a valid config hashref |
593
|
|
|
|
|
|
|
my $CONFIG_ENGLISH = 'a reference to a hash indexed only by valid Config Names, containing only valid values, with all required config names present, and all config key interdependencies satisfied'; |
594
|
|
|
|
|
|
|
my $CONFIG = Type::Tiny->new( |
595
|
|
|
|
|
|
|
name => 'Config', |
596
|
|
|
|
|
|
|
parent => $CONFIG_OVERRIDE, |
597
|
|
|
|
|
|
|
coercion => 1, |
598
|
|
|
|
|
|
|
constraint => sub{ |
599
|
|
|
|
|
|
|
# check for missing required keys |
600
|
|
|
|
|
|
|
my @missing_required_keys = _extract_missing_required_keys($_); |
601
|
|
|
|
|
|
|
if(scalar @missing_required_keys){ |
602
|
|
|
|
|
|
|
return 0; |
603
|
|
|
|
|
|
|
} |
604
|
|
|
|
|
|
|
|
605
|
|
|
|
|
|
|
# check for unfulfilled dependencies |
606
|
|
|
|
|
|
|
my @unfulfilled_key_interdependencies = _extract_unfulfilled_key_interdependencies($_); |
607
|
|
|
|
|
|
|
if(scalar @unfulfilled_key_interdependencies){ |
608
|
|
|
|
|
|
|
return 0; |
609
|
|
|
|
|
|
|
} |
610
|
|
|
|
|
|
|
|
611
|
|
|
|
|
|
|
# if we got here, all is well, so return 1 |
612
|
|
|
|
|
|
|
return 1; |
613
|
|
|
|
|
|
|
}, |
614
|
|
|
|
|
|
|
my_methods => { |
615
|
|
|
|
|
|
|
english => sub {return $CONFIG_ENGLISH;}, |
616
|
|
|
|
|
|
|
}, |
617
|
|
|
|
|
|
|
message => sub{ |
618
|
|
|
|
|
|
|
# if we were not even passed a hash, give the basic error |
619
|
|
|
|
|
|
|
unless(HashRef->check($_)){ |
620
|
|
|
|
|
|
|
return var_to_string($_).qq{ is not a valid Config (must be $CONFIG_ENGLISH)}; |
621
|
|
|
|
|
|
|
} |
622
|
|
|
|
|
|
|
|
623
|
|
|
|
|
|
|
# get an easy reference to the hash |
624
|
|
|
|
|
|
|
my $config = $_; |
625
|
|
|
|
|
|
|
|
626
|
|
|
|
|
|
|
# check for invalid names |
627
|
|
|
|
|
|
|
my @invalid_key_names = _extract_invalid_key_names($config); |
628
|
|
|
|
|
|
|
if(scalar @invalid_key_names){ |
629
|
|
|
|
|
|
|
my $msg = var_to_string($_)." is not a valid Config because it contains one or more invalid Config Key Names:\n"; |
630
|
|
|
|
|
|
|
foreach my $key (sort @invalid_key_names){ |
631
|
|
|
|
|
|
|
$msg .= "* '$key'\n"; |
632
|
|
|
|
|
|
|
} |
633
|
|
|
|
|
|
|
$msg .= "($CONFIG_KEY_NAME_ENGLISH)"; |
634
|
|
|
|
|
|
|
return $msg; |
635
|
|
|
|
|
|
|
} |
636
|
|
|
|
|
|
|
|
637
|
|
|
|
|
|
|
# check for missing required keys |
638
|
|
|
|
|
|
|
my @missing_required_keys = _extract_missing_required_keys($_); |
639
|
|
|
|
|
|
|
if(scalar @missing_required_keys){ |
640
|
|
|
|
|
|
|
my $msg = var_to_string($_)." is not a valid Config because one or more required config keys are missing:\n"; |
641
|
|
|
|
|
|
|
foreach my $key (sort @missing_required_keys){ |
642
|
|
|
|
|
|
|
$msg .= "'$key'\n"; |
643
|
|
|
|
|
|
|
} |
644
|
|
|
|
|
|
|
chomp $msg; |
645
|
|
|
|
|
|
|
return $msg; |
646
|
|
|
|
|
|
|
} |
647
|
|
|
|
|
|
|
|
648
|
|
|
|
|
|
|
# check for invalid values and find the offending key(s) |
649
|
|
|
|
|
|
|
my @invalid_valued_keys = _extract_invalid_valued_keys($config); |
650
|
|
|
|
|
|
|
if(scalar @invalid_valued_keys){ |
651
|
|
|
|
|
|
|
my $msg = var_to_string($_)." is not a valid Config because one of more of the config keys specify invalid values:\n"; |
652
|
|
|
|
|
|
|
foreach my $key_name (@invalid_valued_keys){ |
653
|
|
|
|
|
|
|
$msg .= '* '.$_KEYS->{$key_name}->{type}->get_message($config->{$key_name})."\n"; |
654
|
|
|
|
|
|
|
} |
655
|
|
|
|
|
|
|
chomp $msg; |
656
|
|
|
|
|
|
|
return $msg; |
657
|
|
|
|
|
|
|
} |
658
|
|
|
|
|
|
|
|
659
|
|
|
|
|
|
|
# that means it must be unfulfilled interdependencies |
660
|
|
|
|
|
|
|
my @unfulfilled_key_interdependencies = _extract_unfulfilled_key_interdependencies($_); |
661
|
|
|
|
|
|
|
if(scalar @unfulfilled_key_interdependencies){ |
662
|
|
|
|
|
|
|
my $msg = var_to_string($_)." is not a valid Config because one of more interdependencies between config keys is not fullfilled:\n"; |
663
|
|
|
|
|
|
|
foreach my $problem (@unfulfilled_key_interdependencies){ |
664
|
|
|
|
|
|
|
$msg .= "* $problem\n"; |
665
|
|
|
|
|
|
|
} |
666
|
|
|
|
|
|
|
chomp $msg; |
667
|
|
|
|
|
|
|
return $msg; |
668
|
|
|
|
|
|
|
} |
669
|
|
|
|
|
|
|
|
670
|
|
|
|
|
|
|
|
671
|
|
|
|
|
|
|
# it should not be possible to get here, but to be sure to be sure, return a basic message |
672
|
|
|
|
|
|
|
return var_to_string($_)." is not a valid Config for an unexpected reason - (must be $CONFIG_ENGLISH)"; |
673
|
|
|
|
|
|
|
}, |
674
|
|
|
|
|
|
|
); |
675
|
|
|
|
|
|
|
__PACKAGE__->meta->add_type($CONFIG); |
676
|
|
|
|
|
|
|
|
677
|
|
|
|
|
|
|
# |
678
|
|
|
|
|
|
|
# === Define the Presets and related Types ====================================# |
679
|
|
|
|
|
|
|
# |
680
|
|
|
|
|
|
|
|
681
|
|
|
|
|
|
|
# add a type for preset definitions - a hashref with the correct indexes and values |
682
|
|
|
|
|
|
|
my $PRESET_DEFINITION_ENGLISH = q{a reference to a hash mapping 'description' to a non-empty string, and 'config' to a valid Config}; |
683
|
|
|
|
|
|
|
my $PRESET_DEFINITION = Type::Tiny->new( |
684
|
|
|
|
|
|
|
name => 'PresetDefinition', |
685
|
|
|
|
|
|
|
parent => Dict[description => $NON_EMPTY_STRING, config => $CONFIG] , |
686
|
|
|
|
|
|
|
message => sub{ |
687
|
|
|
|
|
|
|
return var_to_string($_).qq{ is not a valid Preset Definition (must be $PRESET_DEFINITION_ENGLISH)}; |
688
|
|
|
|
|
|
|
}, |
689
|
|
|
|
|
|
|
my_methods => { |
690
|
|
|
|
|
|
|
english => sub {return $PRESET_DEFINITION_ENGLISH;}, |
691
|
|
|
|
|
|
|
}, |
692
|
|
|
|
|
|
|
); |
693
|
|
|
|
|
|
|
__PACKAGE__->meta->add_type($PRESET_DEFINITION); |
694
|
|
|
|
|
|
|
|
695
|
|
|
|
|
|
|
# preset definitions |
696
|
|
|
|
|
|
|
my $_PRESETS = { |
697
|
|
|
|
|
|
|
DEFAULT => { |
698
|
|
|
|
|
|
|
description => 'The default preset resulting in a password consisting of 3 random words of between 4 and 8 letters with alternating case separated by a random character, with two random digits before and after, and padded with two random characters front and back', |
699
|
|
|
|
|
|
|
config => { |
700
|
|
|
|
|
|
|
symbol_alphabet => [qw{! @ $ % ^ & * - _ + = : | ~ ? / . ;}], |
701
|
|
|
|
|
|
|
word_length_min => 4, |
702
|
|
|
|
|
|
|
word_length_max => 8, |
703
|
|
|
|
|
|
|
num_words => 3, |
704
|
|
|
|
|
|
|
separator_character => 'RANDOM', |
705
|
|
|
|
|
|
|
padding_digits_before => 2, |
706
|
|
|
|
|
|
|
padding_digits_after => 2, |
707
|
|
|
|
|
|
|
padding_type => 'FIXED', |
708
|
|
|
|
|
|
|
padding_character => 'RANDOM', |
709
|
|
|
|
|
|
|
padding_characters_before => 2, |
710
|
|
|
|
|
|
|
padding_characters_after => 2, |
711
|
|
|
|
|
|
|
case_transform => 'ALTERNATE', |
712
|
|
|
|
|
|
|
allow_accents => 0, |
713
|
|
|
|
|
|
|
}, |
714
|
|
|
|
|
|
|
}, |
715
|
|
|
|
|
|
|
WEB32 => { |
716
|
|
|
|
|
|
|
description => q{A preset for websites that allow passwords up to 32 characteres long.}, |
717
|
|
|
|
|
|
|
config => { |
718
|
|
|
|
|
|
|
padding_alphabet => [qw{! @ $ % ^ & * + = : | ~ ?}], |
719
|
|
|
|
|
|
|
separator_alphabet => [qw{- + = . * _ | ~}, q{,}], |
720
|
|
|
|
|
|
|
word_length_min => 4, |
721
|
|
|
|
|
|
|
word_length_max => 5, |
722
|
|
|
|
|
|
|
num_words => 4, |
723
|
|
|
|
|
|
|
separator_character => 'RANDOM', |
724
|
|
|
|
|
|
|
padding_digits_before => 2, |
725
|
|
|
|
|
|
|
padding_digits_after => 2, |
726
|
|
|
|
|
|
|
padding_type => 'FIXED', |
727
|
|
|
|
|
|
|
padding_character => 'RANDOM', |
728
|
|
|
|
|
|
|
padding_characters_before => 1, |
729
|
|
|
|
|
|
|
padding_characters_after => 1, |
730
|
|
|
|
|
|
|
case_transform => 'ALTERNATE', |
731
|
|
|
|
|
|
|
allow_accents => 0, |
732
|
|
|
|
|
|
|
}, |
733
|
|
|
|
|
|
|
}, |
734
|
|
|
|
|
|
|
WEB16 => { |
735
|
|
|
|
|
|
|
description => 'A preset for websites that insit passwords not be longer than 16 characters. WARNING - only use this preset if you have to, it is too short to be acceptably secure and will always generate entropy warnings for the case where the config and dictionary are known.', |
736
|
|
|
|
|
|
|
config => { |
737
|
|
|
|
|
|
|
symbol_alphabet => [qw{! @ $ % ^ & * - _ + = : | ~ ? / . ;}], |
738
|
|
|
|
|
|
|
word_length_min => 4, |
739
|
|
|
|
|
|
|
word_length_max => 4, |
740
|
|
|
|
|
|
|
num_words => 3, |
741
|
|
|
|
|
|
|
separator_character => 'RANDOM', |
742
|
|
|
|
|
|
|
padding_digits_before => 0, |
743
|
|
|
|
|
|
|
padding_digits_after => 2, |
744
|
|
|
|
|
|
|
padding_type => 'NONE', |
745
|
|
|
|
|
|
|
case_transform => 'RANDOM', |
746
|
|
|
|
|
|
|
allow_accents => 0, |
747
|
|
|
|
|
|
|
}, |
748
|
|
|
|
|
|
|
}, |
749
|
|
|
|
|
|
|
WIFI => { |
750
|
|
|
|
|
|
|
description => 'A preset for generating 63 character long WPA2 keys (most routers allow 64 characters, but some only 63, hence the odd length).', |
751
|
|
|
|
|
|
|
config => { |
752
|
|
|
|
|
|
|
padding_alphabet => [qw{! @ $ % ^ & * + = : | ~ ?}], |
753
|
|
|
|
|
|
|
separator_alphabet => [qw{- + = . * _ | ~}, q{,}], |
754
|
|
|
|
|
|
|
word_length_min => 4, |
755
|
|
|
|
|
|
|
word_length_max => 8, |
756
|
|
|
|
|
|
|
num_words => 6, |
757
|
|
|
|
|
|
|
separator_character => 'RANDOM', |
758
|
|
|
|
|
|
|
padding_digits_before => 4, |
759
|
|
|
|
|
|
|
padding_digits_after => 4, |
760
|
|
|
|
|
|
|
padding_type => 'ADAPTIVE', |
761
|
|
|
|
|
|
|
padding_character => 'RANDOM', |
762
|
|
|
|
|
|
|
pad_to_length => 63, |
763
|
|
|
|
|
|
|
case_transform => 'RANDOM', |
764
|
|
|
|
|
|
|
allow_accents => 0, |
765
|
|
|
|
|
|
|
}, |
766
|
|
|
|
|
|
|
}, |
767
|
|
|
|
|
|
|
APPLEID => { |
768
|
|
|
|
|
|
|
description => 'A preset respecting the many prerequisites Apple places on Apple ID passwords. The preset also limits itself to symbols found on the iOS letter and number keyboards (i.e. not the awkward to reach symbol keyboard)', |
769
|
|
|
|
|
|
|
config => { |
770
|
|
|
|
|
|
|
padding_alphabet => [qw{- : . ! ? @ &}], |
771
|
|
|
|
|
|
|
separator_alphabet => [qw{- : . @}, q{,}, q{ }], |
772
|
|
|
|
|
|
|
word_length_min => 4, |
773
|
|
|
|
|
|
|
word_length_max => 7, |
774
|
|
|
|
|
|
|
num_words => 3, |
775
|
|
|
|
|
|
|
separator_character => 'RANDOM', |
776
|
|
|
|
|
|
|
padding_digits_before => 2, |
777
|
|
|
|
|
|
|
padding_digits_after => 2, |
778
|
|
|
|
|
|
|
padding_type => 'FIXED', |
779
|
|
|
|
|
|
|
padding_character => 'RANDOM', |
780
|
|
|
|
|
|
|
padding_characters_before => 1, |
781
|
|
|
|
|
|
|
padding_characters_after => 1, |
782
|
|
|
|
|
|
|
case_transform => 'RANDOM', |
783
|
|
|
|
|
|
|
allow_accents => 0, |
784
|
|
|
|
|
|
|
}, |
785
|
|
|
|
|
|
|
}, |
786
|
|
|
|
|
|
|
NTLM => { |
787
|
|
|
|
|
|
|
description => 'A preset for 14 character Windows NTLMv1 password. WARNING - only use this preset if you have to, it is too short to be acceptably secure and will always generate entropy warnings for the case where the config and dictionary are known.', |
788
|
|
|
|
|
|
|
config => { |
789
|
|
|
|
|
|
|
padding_alphabet => [qw{! @ $ % ^ & * + = : | ~ ?}], |
790
|
|
|
|
|
|
|
separator_alphabet => [qw{- + = . * _ | ~}, q{,}], |
791
|
|
|
|
|
|
|
word_length_min => 5, |
792
|
|
|
|
|
|
|
word_length_max => 5, |
793
|
|
|
|
|
|
|
num_words => 2, |
794
|
|
|
|
|
|
|
separator_character => 'RANDOM', |
795
|
|
|
|
|
|
|
padding_digits_before => 1, |
796
|
|
|
|
|
|
|
padding_digits_after => 0, |
797
|
|
|
|
|
|
|
padding_type => 'FIXED', |
798
|
|
|
|
|
|
|
padding_character => 'RANDOM', |
799
|
|
|
|
|
|
|
padding_characters_before => 0, |
800
|
|
|
|
|
|
|
padding_characters_after => 1, |
801
|
|
|
|
|
|
|
case_transform => 'INVERT', |
802
|
|
|
|
|
|
|
allow_accents => 0, |
803
|
|
|
|
|
|
|
}, |
804
|
|
|
|
|
|
|
}, |
805
|
|
|
|
|
|
|
SECURITYQ => { |
806
|
|
|
|
|
|
|
description => 'A preset for creating fake answers to security questions.', |
807
|
|
|
|
|
|
|
config => { |
808
|
|
|
|
|
|
|
word_length_min => 4, |
809
|
|
|
|
|
|
|
word_length_max => 8, |
810
|
|
|
|
|
|
|
num_words => 6, |
811
|
|
|
|
|
|
|
separator_character => q{ }, |
812
|
|
|
|
|
|
|
padding_digits_before => 0, |
813
|
|
|
|
|
|
|
padding_digits_after => 0, |
814
|
|
|
|
|
|
|
padding_type => 'FIXED', |
815
|
|
|
|
|
|
|
padding_character => 'RANDOM', |
816
|
|
|
|
|
|
|
padding_alphabet => [qw{. ! ?}], |
817
|
|
|
|
|
|
|
padding_characters_before => 0, |
818
|
|
|
|
|
|
|
padding_characters_after => 1, |
819
|
|
|
|
|
|
|
case_transform => 'NONE', |
820
|
|
|
|
|
|
|
allow_accents => 0, |
821
|
|
|
|
|
|
|
}, |
822
|
|
|
|
|
|
|
}, |
823
|
|
|
|
|
|
|
XKCD => { |
824
|
|
|
|
|
|
|
description => 'A preset for generating passwords similar to the example in the original XKCD cartoon, but with an extra word, a dash to separate the random words, and the capitalisation randomised to add sufficient entropy to avoid warnings.', |
825
|
|
|
|
|
|
|
config => { |
826
|
|
|
|
|
|
|
word_length_min => 4, |
827
|
|
|
|
|
|
|
word_length_max => 8, |
828
|
|
|
|
|
|
|
num_words => 5, |
829
|
|
|
|
|
|
|
separator_character => q{-}, |
830
|
|
|
|
|
|
|
padding_digits_before => 0, |
831
|
|
|
|
|
|
|
padding_digits_after => 0, |
832
|
|
|
|
|
|
|
padding_type => 'NONE', |
833
|
|
|
|
|
|
|
case_transform => 'RANDOM', |
834
|
|
|
|
|
|
|
allow_accents => 0, |
835
|
|
|
|
|
|
|
}, |
836
|
|
|
|
|
|
|
}, |
837
|
|
|
|
|
|
|
}; |
838
|
|
|
|
|
|
|
|
839
|
|
|
|
|
|
|
# add a type for config key names |
840
|
|
|
|
|
|
|
my $PRESET_NAME_ENGLISH = 'for a list of all defined preset names see the docs, or the output from the function Crypt::HSXKPasswd->defined_presets()'; |
841
|
|
|
|
|
|
|
my $PRESET_NAME = Type::Tiny->new( |
842
|
|
|
|
|
|
|
name => 'PresetName', |
843
|
|
|
|
|
|
|
parent => Str, |
844
|
|
|
|
|
|
|
constraint => sub{ |
845
|
|
|
|
|
|
|
my $test_val = $_; |
846
|
|
|
|
|
|
|
foreach my $preset_name (keys %{$_PRESETS}){ |
847
|
|
|
|
|
|
|
if($test_val eq $preset_name){ |
848
|
|
|
|
|
|
|
return 1; |
849
|
|
|
|
|
|
|
} |
850
|
|
|
|
|
|
|
} |
851
|
|
|
|
|
|
|
return 0; |
852
|
|
|
|
|
|
|
}, |
853
|
|
|
|
|
|
|
message => sub{ |
854
|
|
|
|
|
|
|
return var_to_string($_).qq{ is not a defined Preset Name ($PRESET_NAME_ENGLISH)}; |
855
|
|
|
|
|
|
|
}, |
856
|
|
|
|
|
|
|
my_methods => { |
857
|
|
|
|
|
|
|
english => sub {return 'a defined preset name - '.$PRESET_NAME_ENGLISH;}, |
858
|
|
|
|
|
|
|
}, |
859
|
|
|
|
|
|
|
); |
860
|
|
|
|
|
|
|
$PRESET_NAME->coercion()->add_type_coercions(Str, q{uc $_}); ## no critic (RequireInterpolationOfMetachars) |
861
|
|
|
|
|
|
|
__PACKAGE__->meta->add_type($PRESET_NAME); |
862
|
|
|
|
|
|
|
|
863
|
|
|
|
|
|
|
# |
864
|
|
|
|
|
|
|
# === Define .hsxkpassdrc file related Types ==================================# |
865
|
|
|
|
|
|
|
# |
866
|
|
|
|
|
|
|
|
867
|
|
|
|
|
|
|
my $RCFILE_DATA_ENGLISH = q{a reference to a hash defining one or more of: custom presets, default_entropy_warnings, default dictionary, and default random number generator}; |
868
|
|
|
|
|
|
|
my $RCFILE_DATA = Type::Tiny->new( |
869
|
|
|
|
|
|
|
name => 'RCFileData', |
870
|
|
|
|
|
|
|
parent => Dict[ |
871
|
|
|
|
|
|
|
custom_presets => Optional[Map[$UPPERCASE_IDENTIFIER, $PRESET_DEFINITION]], |
872
|
|
|
|
|
|
|
default_entropy_warnings => Optional[$ENTROPY_WARNING_LEVEL], |
873
|
|
|
|
|
|
|
default_dictionary => Optional[Dict[ |
874
|
|
|
|
|
|
|
package => Optional[$PERL_PACKAGE_NAME], |
875
|
|
|
|
|
|
|
package_constructor_args => Optional[ArrayRef], |
876
|
|
|
|
|
|
|
file => Optional[$NON_EMPTY_STRING], |
877
|
|
|
|
|
|
|
]], |
878
|
|
|
|
|
|
|
default_rng => Optional[Dict[ |
879
|
|
|
|
|
|
|
package => $PERL_PACKAGE_NAME, |
880
|
|
|
|
|
|
|
package_constructor_args => Optional[ArrayRef], |
881
|
|
|
|
|
|
|
]], |
882
|
|
|
|
|
|
|
], |
883
|
|
|
|
|
|
|
constraint => sub{ |
884
|
|
|
|
|
|
|
# if there is a default dictionary section, make sure there is exactly one source specified |
885
|
|
|
|
|
|
|
if($_->{default_dictionary}){ |
886
|
|
|
|
|
|
|
unless($_->{default_dictionary}->{package} || $_->{default_dictionary}->{file}){ |
887
|
|
|
|
|
|
|
return 0; |
888
|
|
|
|
|
|
|
} |
889
|
|
|
|
|
|
|
if($_->{default_dictionary}->{package} && $_->{default_dictionary}->{file}){ |
890
|
|
|
|
|
|
|
return 0; |
891
|
|
|
|
|
|
|
} |
892
|
|
|
|
|
|
|
} |
893
|
|
|
|
|
|
|
|
894
|
|
|
|
|
|
|
# if we got here, all is OK |
895
|
|
|
|
|
|
|
return 1; |
896
|
|
|
|
|
|
|
}, |
897
|
|
|
|
|
|
|
message => sub{ |
898
|
|
|
|
|
|
|
my $basic_msg = var_to_string($_).qq{ is not a valid hsxkpasswdrc file data structure (must be $RCFILE_DATA_ENGLISH)}; |
899
|
|
|
|
|
|
|
# make sure we at least have a hash |
900
|
|
|
|
|
|
|
unless(HashRef->check($_)){ |
901
|
|
|
|
|
|
|
return $basic_msg; |
902
|
|
|
|
|
|
|
} |
903
|
|
|
|
|
|
|
|
904
|
|
|
|
|
|
|
# make sure there are no invalid keys present |
905
|
|
|
|
|
|
|
my @invalid_keys = (); |
906
|
|
|
|
|
|
|
foreach my $key (sort keys %{$_}){ |
907
|
|
|
|
|
|
|
unless($key =~ m/^(?:custom_presets)|(?:default_entropy_warnings)|(?:default_dictionary)|(?:default_rng)$/sx){ ## no critic (ProhibitComplexRegexes) |
908
|
|
|
|
|
|
|
push @invalid_keys, $key; |
909
|
|
|
|
|
|
|
} |
910
|
|
|
|
|
|
|
} |
911
|
|
|
|
|
|
|
if(scalar @invalid_keys){ |
912
|
|
|
|
|
|
|
return var_to_string($_).q{ is not a valid hsxkpasswdrc file data structure because it is indexed by one or more invalid keys: }.(join q{, }, @invalid_keys); |
913
|
|
|
|
|
|
|
} |
914
|
|
|
|
|
|
|
|
915
|
|
|
|
|
|
|
# if defined, make sure each preset is valid |
916
|
|
|
|
|
|
|
if($_->{custom_presets}){ |
917
|
|
|
|
|
|
|
# make sure custom_presets is a hashref |
918
|
|
|
|
|
|
|
unless(HashRef->check($_->{custom_presets})){ |
919
|
|
|
|
|
|
|
return var_to_string($_).q{ is not a valid hsxkpasswdrc file data structure because it defines the key 'custom_presets', but not as a reference to a hash}; |
920
|
|
|
|
|
|
|
} |
921
|
|
|
|
|
|
|
|
922
|
|
|
|
|
|
|
# make sure all the preset names are valid |
923
|
|
|
|
|
|
|
my @invalid_preset_names = (); |
924
|
|
|
|
|
|
|
foreach my $preset_name (sort keys %{$_->{custom_presets}}){ |
925
|
|
|
|
|
|
|
unless($UPPERCASE_IDENTIFIER->check($preset_name)){ |
926
|
|
|
|
|
|
|
push @invalid_preset_names, $preset_name; |
927
|
|
|
|
|
|
|
} |
928
|
|
|
|
|
|
|
} |
929
|
|
|
|
|
|
|
if(scalar @invalid_preset_names){ |
930
|
|
|
|
|
|
|
return var_to_string($_).q{ is not a valid hsxkpasswdrc file data structure because it contains one or more invalid custom preset names: }.(join q{, }, @invalid_preset_names).qq{ (each preset name must be $UPPERCASE_IDENTIFIER_ENGLISH)}; |
931
|
|
|
|
|
|
|
} |
932
|
|
|
|
|
|
|
|
933
|
|
|
|
|
|
|
# test each preset |
934
|
|
|
|
|
|
|
my @invalid_preset_defs = (); |
935
|
|
|
|
|
|
|
## no critic (ProhibitDeepNests); |
936
|
|
|
|
|
|
|
foreach my $preset_name (sort keys %{$_->{custom_presets}}){ |
937
|
|
|
|
|
|
|
unless($PRESET_DEFINITION->check($_->{custom_presets}->{$preset_name})){ |
938
|
|
|
|
|
|
|
# make sure the preset does not define any invalid keys |
939
|
|
|
|
|
|
|
my @invalid_preset_keys = (); |
940
|
|
|
|
|
|
|
foreach my $preset_key (sort keys %{$_->{custom_presets}->{$preset_name}}){ |
941
|
|
|
|
|
|
|
unless($preset_key =~ m/^(?:description)|(?:config)$/sx){ |
942
|
|
|
|
|
|
|
push @invalid_preset_keys, $preset_key; |
943
|
|
|
|
|
|
|
} |
944
|
|
|
|
|
|
|
} |
945
|
|
|
|
|
|
|
if(scalar @invalid_preset_keys){ |
946
|
|
|
|
|
|
|
return var_to_string($_).qq{ is not a valid hsxkpasswdrc file data structure because the custom preset '$preset_name' is indexed by one or more invalid keys: }.(join q{, }, @invalid_preset_keys); |
947
|
|
|
|
|
|
|
} |
948
|
|
|
|
|
|
|
|
949
|
|
|
|
|
|
|
# if the preset is valid except for the config, print the problem with the config |
950
|
|
|
|
|
|
|
# NOTE - this code is potentially brittle - if the test for a preset definition |
951
|
|
|
|
|
|
|
# is changed, this code could fail to be triggered, leading to less helpful |
952
|
|
|
|
|
|
|
# error message. Because of the final check against config, the message cannot |
953
|
|
|
|
|
|
|
# be triggered if the config is valid though, so at least the code can't give a |
954
|
|
|
|
|
|
|
# BS answer! |
955
|
|
|
|
|
|
|
if( |
956
|
|
|
|
|
|
|
$_->{custom_presets}->{$preset_name}->{description} && |
957
|
|
|
|
|
|
|
$NON_EMPTY_STRING->check($_->{custom_presets}->{$preset_name}->{description}) && |
958
|
|
|
|
|
|
|
$_->{custom_presets}->{$preset_name}->{config} && |
959
|
|
|
|
|
|
|
HashRef->check($_->{custom_presets}->{$preset_name}->{config}) && |
960
|
|
|
|
|
|
|
!$CONFIG->check($_->{custom_presets}->{$preset_name}->{config}) |
961
|
|
|
|
|
|
|
){ |
962
|
|
|
|
|
|
|
return return var_to_string($_).qq{ is not a valid hsxkpasswdrc file data structure because it defines a custom preset '$preset_name' which is invalid:\n}.$CONFIG->get_message($_->{custom_presets}->{$preset_name}->{config}); |
963
|
|
|
|
|
|
|
} |
964
|
|
|
|
|
|
|
|
965
|
|
|
|
|
|
|
# otherwise, just report that there is a problem with the definition |
966
|
|
|
|
|
|
|
push @invalid_preset_defs, $preset_name; |
967
|
|
|
|
|
|
|
} |
968
|
|
|
|
|
|
|
} |
969
|
|
|
|
|
|
|
## use critic |
970
|
|
|
|
|
|
|
if(scalar @invalid_preset_defs){ |
971
|
|
|
|
|
|
|
return var_to_string($_).q{ is not a valid hsxkpasswdrc file data structure because it contains one or more invalid preset definitions: }.(join q{, }, @invalid_preset_defs).qq{ (each preset definition must be $PRESET_DEFINITION_ENGLISH)}; |
972
|
|
|
|
|
|
|
} |
973
|
|
|
|
|
|
|
} |
974
|
|
|
|
|
|
|
|
975
|
|
|
|
|
|
|
# if defined, make sure the default entropy warning level is valid |
976
|
|
|
|
|
|
|
if($_->{default_entropy_warnings}){ |
977
|
|
|
|
|
|
|
unless($ENTROPY_WARNING_LEVEL->check($_->{default_entropy_warnings})){ |
978
|
|
|
|
|
|
|
return var_to_string($_).qq{ is not a valid hsxkpasswdrc file data structure because it contains an invalid value for the key 'default_entropy_warnings', which must be $ENTROPY_WARNING_LEVEL_ENGLISH)}; |
979
|
|
|
|
|
|
|
} |
980
|
|
|
|
|
|
|
} |
981
|
|
|
|
|
|
|
|
982
|
|
|
|
|
|
|
# if defined, make sure the default dictionary is valid |
983
|
|
|
|
|
|
|
if($_->{default_dictionary}){ |
984
|
|
|
|
|
|
|
# make sure it is a hashref |
985
|
|
|
|
|
|
|
unless(HashRef->check($_->{default_dictionary})){ |
986
|
|
|
|
|
|
|
return var_to_string($_).q{ is not a valid hsxkpasswdrc file data structure because it defines the key 'default_dictionary', but not as a reference to a hash}; |
987
|
|
|
|
|
|
|
} |
988
|
|
|
|
|
|
|
|
989
|
|
|
|
|
|
|
# make sure there are no invalid keys |
990
|
|
|
|
|
|
|
my @invalid_dict_keys = (); |
991
|
|
|
|
|
|
|
foreach my $key (sort keys %{$_->{default_dictionary}}){ |
992
|
|
|
|
|
|
|
unless($key =~ m/^(?:package)|(?:package_constructor_args)|(?:file)$/sx){ |
993
|
|
|
|
|
|
|
push @invalid_dict_keys, $key; |
994
|
|
|
|
|
|
|
} |
995
|
|
|
|
|
|
|
} |
996
|
|
|
|
|
|
|
if(scalar @invalid_dict_keys){ |
997
|
|
|
|
|
|
|
return var_to_string($_).q{ is not a valid hsxkpasswdrc file data structure because 'default_dictionary' is indexed by one or more invalid keys: }.(join q{, }, @invalid_dict_keys); |
998
|
|
|
|
|
|
|
} |
999
|
|
|
|
|
|
|
|
1000
|
|
|
|
|
|
|
# make sure each key is valid |
1001
|
|
|
|
|
|
|
if($_->{default_dictionary}->{package} && !$PERL_PACKAGE_NAME->check($_->{default_dictionary}->{package})){ |
1002
|
|
|
|
|
|
|
return var_to_string($_).q{ is not a valid hsxkpasswdrc file data structure because 'default_dictionary'->'package' is not a valid Perl package name}; |
1003
|
|
|
|
|
|
|
} |
1004
|
|
|
|
|
|
|
if($_->{default_dictionary}->{package_constructor_args} && !ArrayRef->check($_->{default_dictionary}->{package_constructor_args})){ |
1005
|
|
|
|
|
|
|
return var_to_string($_).q{ is not a valid hsxkpasswdrc file data structure because 'default_dictionary'->'package_constructor_args' is not a reference to an array}; |
1006
|
|
|
|
|
|
|
} |
1007
|
|
|
|
|
|
|
if($_->{default_dictionary}->{file} && !$NON_EMPTY_STRING->check($_->{default_dictionary}->{file})){ |
1008
|
|
|
|
|
|
|
return var_to_string($_).q{ is not a valid hsxkpasswdrc file data structure because 'default_dictionary'->'file' is not a file path}; |
1009
|
|
|
|
|
|
|
} |
1010
|
|
|
|
|
|
|
|
1011
|
|
|
|
|
|
|
# make sure there is exactly 1 dictionary source defined |
1012
|
|
|
|
|
|
|
unless($_->{default_dictionary}->{package} || $_->{default_dictionary}->{file}){ |
1013
|
|
|
|
|
|
|
return var_to_string($_).q{ is not a valid hsxkpasswdrc file data structure because 'default_dictionary' does not specify 'package' or 'file'}; |
1014
|
|
|
|
|
|
|
} |
1015
|
|
|
|
|
|
|
if($_->{default_dictionary}->{package} && $_->{default_dictionary}->{file}){ |
1016
|
|
|
|
|
|
|
return var_to_string($_).q{ is not a valid hsxkpasswdrc file data structure because 'default_dictionary' specifies both 'package' and 'file'}; |
1017
|
|
|
|
|
|
|
} |
1018
|
|
|
|
|
|
|
} |
1019
|
|
|
|
|
|
|
|
1020
|
|
|
|
|
|
|
# if defined, make sure the default rng is valid |
1021
|
|
|
|
|
|
|
if($_->{default_rng}){ |
1022
|
|
|
|
|
|
|
# make sure it is a hashref |
1023
|
|
|
|
|
|
|
unless(HashRef->check($_->{default_rng})){ |
1024
|
|
|
|
|
|
|
return var_to_string($_).q{ is not a valid hsxkpasswdrc file data structure because it defines the key 'default_rng', but not as a reference to a hash}; |
1025
|
|
|
|
|
|
|
} |
1026
|
|
|
|
|
|
|
|
1027
|
|
|
|
|
|
|
# make sure there are no invalid keys |
1028
|
|
|
|
|
|
|
my @invalid_rng_keys = (); |
1029
|
|
|
|
|
|
|
foreach my $key (sort keys %{$_->{default_rng}}){ |
1030
|
|
|
|
|
|
|
unless($key =~ m/^(?:package)|(?:package_constructor_args)$/sx){ |
1031
|
|
|
|
|
|
|
push @invalid_rng_keys, $key; |
1032
|
|
|
|
|
|
|
} |
1033
|
|
|
|
|
|
|
} |
1034
|
|
|
|
|
|
|
if(scalar @invalid_rng_keys){ |
1035
|
|
|
|
|
|
|
return var_to_string($_).q{ is not a valid hsxkpasswdrc file data structure because 'default_rng' is indexed by one or more invalid keys: }.(join q{, }, @invalid_rng_keys); |
1036
|
|
|
|
|
|
|
} |
1037
|
|
|
|
|
|
|
|
1038
|
|
|
|
|
|
|
# make sure each key is valid |
1039
|
|
|
|
|
|
|
if($_->{default_rng}->{package} && !$PERL_PACKAGE_NAME->check($_->{default_rng}->{package})){ |
1040
|
|
|
|
|
|
|
return var_to_string($_).q{ is not a valid hsxkpasswdrc file data structure because 'default_rng'->'package' is not a valid Perl package name}; |
1041
|
|
|
|
|
|
|
} |
1042
|
|
|
|
|
|
|
if($_->{default_rng}->{package_constructor_args} && !ArrayRef->check($_->{default_rng}->{package_constructor_args})){ |
1043
|
|
|
|
|
|
|
return var_to_string($_).q{ is not a valid hsxkpasswdrc file data structure because 'default_rng'->'package_constructor_args' is not a reference to an array}; |
1044
|
|
|
|
|
|
|
} |
1045
|
|
|
|
|
|
|
|
1046
|
|
|
|
|
|
|
# make sure there is a package specified |
1047
|
|
|
|
|
|
|
unless($_->{default_rng}->{package}){ |
1048
|
|
|
|
|
|
|
return var_to_string($_).q{ is not a valid hsxkpasswdrc file data structure because 'default_rng' does not specify a 'package'}; |
1049
|
|
|
|
|
|
|
} |
1050
|
|
|
|
|
|
|
} |
1051
|
|
|
|
|
|
|
|
1052
|
|
|
|
|
|
|
# a final return, in case none of the other more detailed messages were triggered |
1053
|
|
|
|
|
|
|
return $basic_msg; |
1054
|
|
|
|
|
|
|
}, |
1055
|
|
|
|
|
|
|
my_methods => { |
1056
|
|
|
|
|
|
|
english => sub {return $RCFILE_DATA_ENGLISH;}, |
1057
|
|
|
|
|
|
|
}, |
1058
|
|
|
|
|
|
|
); |
1059
|
|
|
|
|
|
|
__PACKAGE__->meta->add_type($RCFILE_DATA); |
1060
|
|
|
|
|
|
|
|
1061
|
|
|
|
|
|
|
# |
1062
|
|
|
|
|
|
|
# === Finalise the Defined Types ==============================================# |
1063
|
|
|
|
|
|
|
# |
1064
|
|
|
|
|
|
|
|
1065
|
|
|
|
|
|
|
# make the defined types immutable |
1066
|
|
|
|
|
|
|
__PACKAGE__->meta->make_immutable; |
1067
|
|
|
|
|
|
|
|
1068
|
|
|
|
|
|
|
# |
1069
|
|
|
|
|
|
|
# === Public functions ========================================================# |
1070
|
|
|
|
|
|
|
# |
1071
|
|
|
|
|
|
|
|
1072
|
|
|
|
|
|
|
#####-SUB-###################################################################### |
1073
|
|
|
|
|
|
|
# Type : SUBROUTINE |
1074
|
|
|
|
|
|
|
# Purpose : Stringify any $ variable in a sane way |
1075
|
|
|
|
|
|
|
# Returns : A string |
1076
|
|
|
|
|
|
|
# Arguments : 1) the variable to render |
1077
|
|
|
|
|
|
|
# Throws : NOTHING |
1078
|
|
|
|
|
|
|
# Notes : |
1079
|
|
|
|
|
|
|
# See Also : |
1080
|
|
|
|
|
|
|
sub var_to_string{ |
1081
|
13
|
|
|
13
|
0
|
24
|
my $var = shift; |
1082
|
|
|
|
|
|
|
|
1083
|
|
|
|
|
|
|
# deal with undef |
1084
|
13
|
50
|
|
|
|
38
|
unless(defined $var){ |
1085
|
0
|
|
|
|
|
0
|
return 'Undef'; |
1086
|
|
|
|
|
|
|
} |
1087
|
|
|
|
|
|
|
|
1088
|
|
|
|
|
|
|
# find out if the variable is a referece |
1089
|
13
|
|
|
|
|
40
|
my $ref = ref $var; |
1090
|
|
|
|
|
|
|
|
1091
|
|
|
|
|
|
|
# deal with a non-reference (i.e a plain scalars) |
1092
|
13
|
100
|
|
|
|
30
|
unless($ref){ |
1093
|
1
|
|
|
|
|
15
|
return "Value '$var'"; |
1094
|
|
|
|
|
|
|
} |
1095
|
|
|
|
|
|
|
|
1096
|
|
|
|
|
|
|
# deal with each possible reference type |
1097
|
12
|
50
|
66
|
|
|
94
|
if($ref eq 'SCALAR'){ |
|
|
100
|
|
|
|
|
|
1098
|
0
|
|
|
|
|
0
|
my $val = ${$var}; |
|
0
|
|
|
|
|
0
|
|
1099
|
0
|
0
|
|
|
|
0
|
unless($val){ |
1100
|
0
|
|
|
|
|
0
|
return 'Reference to EmptyString'; |
1101
|
|
|
|
|
|
|
} |
1102
|
0
|
|
|
|
|
0
|
return "Reference to '$val'"; |
1103
|
|
|
|
|
|
|
}elsif($ref eq 'ARRAY' || $ref eq 'HASH'){ |
1104
|
|
|
|
|
|
|
# use data dumper to stringify the reference |
1105
|
2
|
|
|
|
|
17
|
my $dd = Data::Dumper->new([$var]); |
1106
|
2
|
|
|
|
|
64
|
$dd->Indent(0)->Useqq(1)->Terse(1)->Sortkeys(1)->Maxdepth(2); ## no critic (ProhibitLongChainsOfMethodCalls) |
1107
|
2
|
|
|
|
|
57
|
my $var_str = $dd->Dump(); |
1108
|
|
|
|
|
|
|
|
1109
|
|
|
|
|
|
|
# truncate the stringified reference if needed |
1110
|
2
|
|
|
|
|
64
|
my $max_length = 72; |
1111
|
2
|
50
|
|
|
|
7
|
if(length $var_str > $max_length){ |
1112
|
0
|
|
|
|
|
0
|
$var_str = (substr $var_str, 0, $max_length - 12).'...'.(substr $var_str, -1, 1); |
1113
|
|
|
|
|
|
|
} |
1114
|
|
|
|
|
|
|
|
1115
|
|
|
|
|
|
|
# return the final string |
1116
|
2
|
|
|
|
|
34
|
return 'Reference to '.$var_str; |
1117
|
|
|
|
|
|
|
}else{ |
1118
|
10
|
|
|
|
|
151
|
return "Reference to $ref"; |
1119
|
|
|
|
|
|
|
} |
1120
|
|
|
|
|
|
|
} |
1121
|
|
|
|
|
|
|
|
1122
|
|
|
|
|
|
|
# |
1123
|
|
|
|
|
|
|
# === 'Private' helper functions ==============================================# |
1124
|
|
|
|
|
|
|
# |
1125
|
|
|
|
|
|
|
|
1126
|
|
|
|
|
|
|
#####-SUB-###################################################################### |
1127
|
|
|
|
|
|
|
# Type : SUBROUTINE |
1128
|
|
|
|
|
|
|
# Purpose : Expose direct access to $_KEYS for classes in the |
1129
|
|
|
|
|
|
|
# Crypt::HSXKPasswd package |
1130
|
|
|
|
|
|
|
# Returns : A hashref |
1131
|
|
|
|
|
|
|
# Arguments : NONE |
1132
|
|
|
|
|
|
|
# Throws : NOTHING |
1133
|
|
|
|
|
|
|
# Notes : This function is private so it should not be used by any 3rd |
1134
|
|
|
|
|
|
|
# party devs - Use the public function |
1135
|
|
|
|
|
|
|
# Crypt::HSXKPasswd->config_key_definitions() instead! |
1136
|
|
|
|
|
|
|
# See Also : Crypt::HSXKPasswd->config_key_definitions() |
1137
|
|
|
|
|
|
|
sub _config_keys{ ## no critic (ProhibitUnusedPrivateSubroutines) |
1138
|
13
|
|
|
13
|
|
139
|
return $_KEYS; |
1139
|
|
|
|
|
|
|
} |
1140
|
|
|
|
|
|
|
|
1141
|
|
|
|
|
|
|
#####-SUB-###################################################################### |
1142
|
|
|
|
|
|
|
# Type : SUBROUTINE |
1143
|
|
|
|
|
|
|
# Purpose : Expose direct access to $_PRESETS for classes in the |
1144
|
|
|
|
|
|
|
# Crypt::HSXKPasswd package |
1145
|
|
|
|
|
|
|
# Returns : A hashref |
1146
|
|
|
|
|
|
|
# Arguments : NONE |
1147
|
|
|
|
|
|
|
# Throws : NOTHING |
1148
|
|
|
|
|
|
|
# Notes : This function is private so it should not be used by any 3rd |
1149
|
|
|
|
|
|
|
# party devs - Use the public function |
1150
|
|
|
|
|
|
|
# Crypt::HSXKPasswd->preset_definitions() instead! |
1151
|
|
|
|
|
|
|
# See Also : Crypt::HSXKPasswd->preset_definitions() |
1152
|
|
|
|
|
|
|
sub _presets{ ## no critic (ProhibitUnusedPrivateSubroutines) |
1153
|
11
|
|
|
11
|
|
94
|
return $_PRESETS; |
1154
|
|
|
|
|
|
|
} |
1155
|
|
|
|
|
|
|
|
1156
|
|
|
|
|
|
|
#####-SUB-###################################################################### |
1157
|
|
|
|
|
|
|
# Type : SUBROUTINE (PRIVATE) |
1158
|
|
|
|
|
|
|
# Purpose : Generate the error message for a config key |
1159
|
|
|
|
|
|
|
# Returns : a string |
1160
|
|
|
|
|
|
|
# Arguments : 1) the invalid value |
1161
|
|
|
|
|
|
|
# 2) the name of the config key |
1162
|
|
|
|
|
|
|
# 3) a description of the expected value |
1163
|
|
|
|
|
|
|
# Throws : NOTHING |
1164
|
|
|
|
|
|
|
# Notes : |
1165
|
|
|
|
|
|
|
# See Also : |
1166
|
|
|
|
|
|
|
sub _config_key_message{ |
1167
|
0
|
|
|
0
|
|
0
|
my $val = shift; |
1168
|
0
|
|
|
|
|
0
|
my $key = shift; |
1169
|
0
|
|
|
|
|
0
|
my $exp = shift; |
1170
|
0
|
|
|
|
|
0
|
return var_to_string($val).qq{ is not a valid value for the config key '$key' - must be $exp}; |
1171
|
|
|
|
|
|
|
} |
1172
|
|
|
|
|
|
|
|
1173
|
|
|
|
|
|
|
#####-SUB-###################################################################### |
1174
|
|
|
|
|
|
|
# Type : SUBROUTINE (PRIVATE) |
1175
|
|
|
|
|
|
|
# Purpose : Extract invalid key names from a hashref |
1176
|
|
|
|
|
|
|
# Returns : An array of strings, potentially of length 0 |
1177
|
|
|
|
|
|
|
# Arguments : 1) a reference to a hash validated against HashRef |
1178
|
|
|
|
|
|
|
# Throws : NOTHING |
1179
|
|
|
|
|
|
|
# Notes : If invalid args are received, an empty array is returned. |
1180
|
|
|
|
|
|
|
# Validation against HashRef is assumed, and not re-tested. |
1181
|
|
|
|
|
|
|
# See Also : |
1182
|
|
|
|
|
|
|
sub _extract_invalid_key_names{ |
1183
|
0
|
|
|
0
|
|
0
|
my $hashref = shift; |
1184
|
|
|
|
|
|
|
|
1185
|
|
|
|
|
|
|
# validate args |
1186
|
0
|
0
|
0
|
|
|
0
|
unless(defined $hashref && ref $hashref eq 'HASH'){ |
1187
|
0
|
|
|
|
|
0
|
return (); |
1188
|
|
|
|
|
|
|
} |
1189
|
|
|
|
|
|
|
|
1190
|
|
|
|
|
|
|
# check each key in the hash and return all that are not valid config key names |
1191
|
0
|
|
|
|
|
0
|
my @invaid_keys = (); |
1192
|
0
|
|
|
|
|
0
|
foreach my $key (keys %{$hashref}){ |
|
0
|
|
|
|
|
0
|
|
1193
|
0
|
0
|
|
|
|
0
|
unless($CONFIG_KEY_NAME->check($key)){ |
1194
|
0
|
|
|
|
|
0
|
push @invaid_keys, $key; |
1195
|
|
|
|
|
|
|
} |
1196
|
|
|
|
|
|
|
} |
1197
|
0
|
|
|
|
|
0
|
return @invaid_keys; |
1198
|
|
|
|
|
|
|
} |
1199
|
|
|
|
|
|
|
|
1200
|
|
|
|
|
|
|
#####-SUB-###################################################################### |
1201
|
|
|
|
|
|
|
# Type : SUBROUTINE |
1202
|
|
|
|
|
|
|
# Purpose : Extract keys with invalid values from a hashref |
1203
|
|
|
|
|
|
|
# Returns : An array of strings, potentially of length 0 |
1204
|
|
|
|
|
|
|
# Arguments : 1) a reference to a hash where every key has been validated |
1205
|
|
|
|
|
|
|
# against ConfigKeyName. |
1206
|
|
|
|
|
|
|
# Throws : NOTHING |
1207
|
|
|
|
|
|
|
# Notes : If invalid args are received, an empty array is returned. |
1208
|
|
|
|
|
|
|
# Validation of the keys is assumed and not re-tested. |
1209
|
|
|
|
|
|
|
# See Also : |
1210
|
|
|
|
|
|
|
sub _extract_invalid_valued_keys{ |
1211
|
0
|
|
|
0
|
|
0
|
my $hashref = shift; |
1212
|
|
|
|
|
|
|
|
1213
|
|
|
|
|
|
|
# validate args |
1214
|
0
|
0
|
0
|
|
|
0
|
unless(defined $hashref && ref $hashref eq 'HASH'){ |
1215
|
0
|
|
|
|
|
0
|
return (); |
1216
|
|
|
|
|
|
|
} |
1217
|
|
|
|
|
|
|
|
1218
|
|
|
|
|
|
|
# check each value in the hash and return the keys for all that are not valid |
1219
|
0
|
|
|
|
|
0
|
my @invaid_valued_keys = (); |
1220
|
0
|
|
|
|
|
0
|
foreach my $key (keys %{$hashref}){ |
|
0
|
|
|
|
|
0
|
|
1221
|
0
|
0
|
|
|
|
0
|
unless($CONFIG_KEY_ASSIGNMENT->check({$key => $hashref->{$key}})){ |
1222
|
0
|
|
|
|
|
0
|
push @invaid_valued_keys, $key; |
1223
|
|
|
|
|
|
|
} |
1224
|
|
|
|
|
|
|
} |
1225
|
0
|
|
|
|
|
0
|
return @invaid_valued_keys; |
1226
|
|
|
|
|
|
|
} |
1227
|
|
|
|
|
|
|
|
1228
|
|
|
|
|
|
|
#####-SUB-###################################################################### |
1229
|
|
|
|
|
|
|
# Type : SUBROUTINE (PRIVATE) |
1230
|
|
|
|
|
|
|
# Purpose : Return a list of required config keys not defined in a hashref |
1231
|
|
|
|
|
|
|
# Returns : An array of strings |
1232
|
|
|
|
|
|
|
# Arguments : 1) a reference to a hashref that has been validated against |
1233
|
|
|
|
|
|
|
# ConfigOverrides |
1234
|
|
|
|
|
|
|
# Throws : NOTHIG |
1235
|
|
|
|
|
|
|
# Notes : If invalid args are received, an empty array is returned. |
1236
|
|
|
|
|
|
|
# Validation against ConfigOverrides is assumed and not re-tested. |
1237
|
|
|
|
|
|
|
# See Also : |
1238
|
|
|
|
|
|
|
sub _extract_missing_required_keys{ |
1239
|
222
|
|
|
222
|
|
250
|
my $hashref = shift; |
1240
|
|
|
|
|
|
|
|
1241
|
|
|
|
|
|
|
# validate args |
1242
|
222
|
50
|
33
|
|
|
1020
|
unless(defined $hashref && ref $hashref eq 'HASH'){ |
1243
|
0
|
|
|
|
|
0
|
return (); |
1244
|
|
|
|
|
|
|
} |
1245
|
|
|
|
|
|
|
|
1246
|
|
|
|
|
|
|
# check that each required key is present |
1247
|
222
|
|
|
|
|
330
|
my @missing_keys = (); |
1248
|
|
|
|
|
|
|
CONFIG_KEY: |
1249
|
222
|
|
|
|
|
189
|
foreach my $key (keys %{$_KEYS}){ |
|
222
|
|
|
|
|
698
|
|
1250
|
|
|
|
|
|
|
# skip keys that are not required |
1251
|
3774
|
100
|
|
|
|
6049
|
next CONFIG_KEY unless $_KEYS->{$key}->{required}; |
1252
|
|
|
|
|
|
|
|
1253
|
|
|
|
|
|
|
# check the required key is present, and if not, save that fact |
1254
|
1554
|
50
|
|
|
|
2659
|
unless(defined $hashref->{$key}){ |
1255
|
0
|
|
|
|
|
0
|
push @missing_keys, $key; |
1256
|
|
|
|
|
|
|
} |
1257
|
|
|
|
|
|
|
} |
1258
|
|
|
|
|
|
|
|
1259
|
|
|
|
|
|
|
# return the list of missing keys |
1260
|
222
|
|
|
|
|
529
|
return @missing_keys; |
1261
|
|
|
|
|
|
|
} |
1262
|
|
|
|
|
|
|
|
1263
|
|
|
|
|
|
|
#####-SUB-###################################################################### |
1264
|
|
|
|
|
|
|
# Type : SUBROUTINE (PRIVATE) |
1265
|
|
|
|
|
|
|
# Purpose : Return a list of unfulfilled config key interdependencies |
1266
|
|
|
|
|
|
|
# Returns : An array of strings |
1267
|
|
|
|
|
|
|
# Arguments : 1) a reference to a hashref that has been validated against |
1268
|
|
|
|
|
|
|
# ConfigOverrides |
1269
|
|
|
|
|
|
|
# Throws : NOTHING |
1270
|
|
|
|
|
|
|
# Notes : If invalid args are received, an empty array is returned. |
1271
|
|
|
|
|
|
|
# Validation against ConfigOverrides is assumed and not re-tested. |
1272
|
|
|
|
|
|
|
# See Also : |
1273
|
|
|
|
|
|
|
sub _extract_unfulfilled_key_interdependencies{ |
1274
|
222
|
|
|
222
|
|
214
|
my $hashref = shift; |
1275
|
|
|
|
|
|
|
|
1276
|
|
|
|
|
|
|
# validate args |
1277
|
222
|
50
|
33
|
|
|
970
|
unless(defined $hashref && ref $hashref eq 'HASH'){ |
1278
|
0
|
|
|
|
|
0
|
return (); |
1279
|
|
|
|
|
|
|
} |
1280
|
|
|
|
|
|
|
|
1281
|
|
|
|
|
|
|
# check that all key interrelationships are valid |
1282
|
222
|
|
|
|
|
245
|
my @unfulfilled_key_interdependencies = (); |
1283
|
|
|
|
|
|
|
|
1284
|
|
|
|
|
|
|
# if there is a need for a symbol alphabet, make sure one is defined |
1285
|
222
|
100
|
|
|
|
517
|
if($hashref->{separator_character} eq 'RANDOM'){ |
1286
|
136
|
50
|
66
|
|
|
338
|
unless(defined $hashref->{symbol_alphabet} || defined $hashref->{separator_alphabet}){ |
1287
|
0
|
|
|
|
|
0
|
push @unfulfilled_key_interdependencies, q{when the config key 'separator_character' is set to 'RANDOM', a symbol alphabet must be specified with one of the config keys 'symbol_alphabet' or 'separator_alphabet'}; |
1288
|
|
|
|
|
|
|
} |
1289
|
|
|
|
|
|
|
} |
1290
|
|
|
|
|
|
|
|
1291
|
|
|
|
|
|
|
# if there is any kind of character padding, make sure a cromulent padding character is specified |
1292
|
222
|
100
|
|
|
|
442
|
if($hashref->{padding_type} ne 'NONE'){ |
1293
|
136
|
50
|
|
|
|
265
|
unless(defined $hashref->{padding_character}){ |
1294
|
0
|
|
|
|
|
0
|
push @unfulfilled_key_interdependencies, q{when the config key 'padding_type' is not set to 'NONE', the config key 'padding_character' must be set}; |
1295
|
|
|
|
|
|
|
} |
1296
|
136
|
50
|
|
|
|
254
|
if($hashref->{padding_character} eq 'RANDOM'){ |
1297
|
136
|
50
|
66
|
|
|
321
|
unless(defined $hashref->{symbol_alphabet} || defined $hashref->{padding_alphabet}){ |
1298
|
0
|
|
|
|
|
0
|
push @unfulfilled_key_interdependencies, q{when the config key 'padding_character' is set to 'RANDOM', a symbol alphabet must be specified with one of the config keys 'symbol_alphabet' or 'padding_alphabet'}; |
1299
|
|
|
|
|
|
|
} |
1300
|
|
|
|
|
|
|
} |
1301
|
136
|
50
|
33
|
|
|
357
|
if($hashref->{padding_character} eq 'SEPARATOR' && $hashref->{separator_character} eq 'NONE'){ |
1302
|
0
|
|
|
|
|
0
|
push @unfulfilled_key_interdependencies, q{the config key 'padding_character' cannot be set 'SEPARATOR' when the config key 'separator_character' is set to 'NONE'}; |
1303
|
|
|
|
|
|
|
} |
1304
|
|
|
|
|
|
|
} |
1305
|
|
|
|
|
|
|
|
1306
|
|
|
|
|
|
|
# if there is fixed character padding, make sure before and after are specified, and at least one has a value greater than 1 |
1307
|
222
|
100
|
|
|
|
691
|
if($hashref->{padding_type} eq 'FIXED'){ |
1308
|
135
|
50
|
33
|
|
|
550
|
unless(defined $hashref->{padding_characters_before} && defined $hashref->{padding_characters_after}){ |
1309
|
0
|
|
|
|
|
0
|
push @unfulfilled_key_interdependencies, q{when the config key 'padding_type' is set to 'FIXED', both the config keys 'padding_characters_before' and 'padding_characters_after' must be set}; |
1310
|
|
|
|
|
|
|
} |
1311
|
135
|
50
|
|
|
|
321
|
unless($hashref->{padding_characters_before} + $hashref->{padding_characters_after} > 0){ |
1312
|
0
|
|
|
|
|
0
|
push @unfulfilled_key_interdependencies, q{when the config key 'padding_type' is set to 'FIXED', at least one of the config keys 'padding_characters_before' and 'padding_characters_after' must be set to a value greater than 1. (to specify that no symbol padding should be used, set the config key 'padding_type' to 'NONE')}; |
1313
|
|
|
|
|
|
|
} |
1314
|
|
|
|
|
|
|
} |
1315
|
|
|
|
|
|
|
|
1316
|
|
|
|
|
|
|
# if there is adaptive padding, make sure a length is specified |
1317
|
222
|
100
|
|
|
|
453
|
if($hashref->{padding_type} eq 'ADAPTIVE'){ |
1318
|
1
|
50
|
|
|
|
4
|
unless(defined $hashref->{pad_to_length}){ |
1319
|
0
|
|
|
|
|
0
|
push @unfulfilled_key_interdependencies, q{when the config key 'padding_type' is set to 'ADAPTIVE', the config key 'pad_to_length' must be set}; |
1320
|
|
|
|
|
|
|
} |
1321
|
|
|
|
|
|
|
} |
1322
|
|
|
|
|
|
|
|
1323
|
|
|
|
|
|
|
# return the list of unfullfilled requirements |
1324
|
222
|
|
|
|
|
310
|
return @unfulfilled_key_interdependencies; |
1325
|
|
|
|
|
|
|
} |
1326
|
|
|
|
|
|
|
|
1327
|
|
|
|
|
|
|
1; # because perl is a tad odd :) |