File Coverage

blib/lib/Crypt/HSXKPasswd/Types.pm
Criterion Covered Total %
statement 83 122 68.0
branch 28 52 53.8
condition 10 27 37.0
subroutine 20 23 86.9
pod 0 1 0.0
total 141 225 62.6


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 :)