File Coverage

lib/Class/Usul/Types.pm
Criterion Covered Total %
statement 34 34 100.0
branch n/a
condition n/a
subroutine 12 12 100.0
pod n/a
total 46 46 100.0


line stmt bran cond sub pod time code
1             package Class::Usul::Types;
2              
3 25     25   87170 use strict;
  25         54  
  25         825  
4 25     25   180 use warnings;
  25         65  
  25         901  
5              
6 25     25   427 use Class::Usul::Constants qw( DEFAULT_ENCODING FALSE LOG_LEVELS NUL TRUE );
  25         54  
  25         157  
7 25     25   20319 use Class::Usul::Functions qw( ensure_class_loaded exception untaint_cmdline );
  25         53  
  25         149  
8 25     25   32762 use Encode qw( find_encoding );
  25         66951  
  25         1257  
9 25     25   151 use Scalar::Util qw( blessed tainted );
  25         51  
  25         985  
10 25     25   125 use Try::Tiny;
  25         52  
  25         1352  
11 25         198 use Type::Library -base, -declare =>
12             qw( ConfigProvider DataEncoding DataLumper
13             DateTimeRef Localiser Locker Logger
14 25     25   142 NullLoadingClass Plinth ProcCommer );
  25         54  
15 25         146 use Type::Utils qw( as class_type coerce extends
16 25     25   33462 from message subtype via where );
  25         82  
17 25     25   23550 use Unexpected::Functions qw( inflate_message is_class_loaded );
  25         82  
  25         202  
18              
19 25     25   8987 use namespace::clean -except => 'meta';
  25         62  
  25         207  
20              
21 25     25   12696 BEGIN { extends q(Unexpected::Types) };
22              
23             # Private functions
24             my $_exception_message_for_object_reference = sub {
25             return inflate_message 'String [_1] is not an object reference', $_[ 0 ];
26             };
27              
28             my $_exception_message_for_configprovider = sub {
29             $_[ 0 ] and blessed $_[ 0 ] and return inflate_message
30             'Object [_1] is missing some configuration attributes', blessed $_[ 0 ];
31              
32             return $_exception_message_for_object_reference->( $_[ 0 ] );
33             };
34              
35             my $_exception_message_for_datetime = sub {
36             $_[ 0 ] and blessed $_[ 0 ] and return inflate_message
37             'Object [_1] is not of class DateTime', blessed $_[ 0 ];
38              
39             return $_exception_message_for_object_reference->( $_[ 0 ] );
40             };
41              
42             my $_exception_message_for_datalumper = sub {
43             $_[ 0 ] and blessed $_[ 0 ] and return inflate_message
44             'Object [_1] is missing the "data_load" method', blessed $_[ 0 ];
45              
46             return $_exception_message_for_object_reference->( $_[ 0 ] );
47             };
48              
49             my $_exception_message_for_localiser = sub {
50             $_[ 0 ] and blessed $_[ 0 ] and return inflate_message
51             'Object [_1] is missing the localize method', blessed $_[ 0 ];
52              
53             return $_exception_message_for_object_reference->( $_[ 0 ] );
54             };
55              
56             my $_exception_message_for_locker = sub {
57             $_[ 0 ] and blessed $_[ 0 ] and return inflate_message
58             'Object [_1] is missing set / reset methods', blessed $_[ 0 ];
59              
60             return $_exception_message_for_object_reference->( $_[ 0 ] );
61             };
62              
63             my $_exception_message_for_logger = sub {
64             $_[ 0 ] and blessed $_[ 0 ] and return inflate_message
65             'Object [_1] is missing a log level method', blessed $_[ 0 ];
66              
67             return $_exception_message_for_object_reference->( $_[ 0 ] );
68             };
69              
70             my $_exception_message_for_plinth = sub {
71             $_[ 0 ] and blessed $_[ 0 ] and return inflate_message
72             'Object [_1] is missing some builder attributes', blessed $_[ 0 ];
73              
74             return $_exception_message_for_object_reference->( $_[ 0 ] );
75             };
76              
77             my $_exception_message_for_proccommer = sub {
78             $_[ 0 ] and blessed $_[ 0 ] and return inflate_message
79             'Object [_1] is missing the "run_cmd" method', blessed $_[ 0 ];
80              
81             return $_exception_message_for_object_reference->( $_[ 0 ] );
82             };
83              
84             my $_has_builder_attributes = sub {
85             my $obj = shift;
86              
87             $obj->can( $_ ) or return FALSE for (qw( config debug l10n lock log ));
88              
89             return TRUE;
90             };
91              
92             my $_has_log_level_methods = sub {
93             my $obj = shift;
94              
95             $obj->can( $_ ) or return FALSE for (LOG_LEVELS);
96              
97             return TRUE;
98             };
99              
100             my $_has_min_config_attributes = sub {
101             my $obj = shift; my @config_attr = ( qw(appldir home root tempdir vardir) );
102              
103             $obj->can( $_ ) or return FALSE for (@config_attr);
104              
105             return TRUE;
106             };
107              
108             my $_isa_untainted_encoding = sub {
109             my $enc = shift; my $res;
110              
111             try { $res = !tainted( $enc ) && find_encoding( $enc ) ? TRUE : FALSE }
112             catch { $res = FALSE };
113              
114             return $res
115             };
116              
117             my $_load_if_exists = sub {
118             if (my $class = shift) {
119             eval { ensure_class_loaded( $class ) }; exception or return $class;
120             }
121              
122             ensure_class_loaded 'Class::Null'; return 'Class::Null';
123             };
124              
125             my $_str2date_time = sub {
126             my $str = shift; ensure_class_loaded 'Class::Usul::Time';
127              
128             return Class::Usul::Time::str2date_time( $str );
129             };
130              
131             # Type definitions
132             subtype ConfigProvider, as Object,
133             where { $_has_min_config_attributes->( $_ ) },
134             message { $_exception_message_for_configprovider->( $_ ) };
135              
136             subtype DataEncoding, as Str,
137             where { $_isa_untainted_encoding->( $_ ) },
138             message { inflate_message 'String [_1] is not a valid encoding', $_ };
139              
140             coerce DataEncoding,
141             from Str, via { untaint_cmdline $_ },
142             from Undef, via { DEFAULT_ENCODING };
143              
144             subtype DataLumper, as Object,
145             where { $_->can( 'data_load' ) and $_->can( 'data_dump' ) },
146             message { $_exception_message_for_datalumper->( $_ ) };
147              
148             subtype DateTimeRef, as Object,
149             where { blessed $_ && $_->isa( 'DateTime' ) },
150             message { $_exception_message_for_datetime->( $_ ) };
151              
152             coerce DateTimeRef, from Str, via { $_str2date_time->( $_ ) };
153              
154             subtype Localiser, as Object,
155             where { $_->can( 'localize' ) },
156             message { $_exception_message_for_localiser->( $_ ) };
157              
158             subtype Locker, as Object,
159             where { $_->can( 'set' ) and $_->can( 'reset' ) },
160             message { $_exception_message_for_locker->( $_ ) };
161              
162             subtype Logger, as Object,
163             where { $_->isa( 'Class::Null' ) or $_has_log_level_methods->( $_ ) },
164             message { $_exception_message_for_logger->( $_ ) };
165              
166             subtype NullLoadingClass, as ClassName,
167             where { is_class_loaded( $_ ) };
168              
169             coerce NullLoadingClass,
170             from Str, via { $_load_if_exists->( $_ ) },
171             from Undef, via { $_load_if_exists->( NUL ) };
172              
173             subtype Plinth, as Object,
174             where { $_has_builder_attributes->( $_ ) },
175             message { $_exception_message_for_plinth->( $_ ) };
176              
177             subtype ProcCommer, as Object,
178             where { $_->can( 'run_cmd' ) },
179             message { $_exception_message_for_proccommer->( $_ ) };
180              
181             1;
182              
183             __END__
184              
185             =pod
186              
187             =encoding utf-8
188              
189             =head1 Name
190              
191             Class::Usul::Types - Defines type constraints
192              
193             =head1 Synopsis
194              
195             use Class::Usul::Types q(:all);
196              
197             =head1 Description
198              
199             Defines the following type constraints;
200              
201             =over 3
202              
203             =item C<ConfigProvider>
204              
205             Subtype of I<Object> can be coerced from a hash reference
206              
207             =item C<DataEncoding>
208              
209             Subtype of I<Str> which has to be one of the list of encodings in the
210             L<ENCODINGS|Class::Usul::Constants/ENCODINGS> constant
211              
212             =item C<DataLumper>
213              
214             Duck type that can; C<data_load> and C<data_dump>. Load and dump, lump
215              
216             =item C<DateTimeRef>
217              
218             Coerces a L<DateTime> object from a string
219              
220             =item C<Localiser>
221              
222             Duck type that can; C<localize>
223              
224             =item C<Locker>
225              
226             Duck type that can; C<reset> and C<set>
227              
228             =item C<Logger>
229              
230             Subtype of I<Object> which has to implement all of the methods in the
231             L<LOG_LEVELS|Class::Usul::Constants/LOG_LEVELS> constant
232              
233             =item C<NullLoadingClass>
234              
235             Loads the given class if possible. If loading fails, load L<Class::Null>
236             and return that instead
237              
238             =item C<Plinth>
239              
240             Duck type that can; C<config>, C<debug>, C<l10n>, C<lock>, and C<log>
241              
242             =item C<ProcCommer>
243              
244             Duck type that can; C<run_cmd>
245              
246             =back
247              
248             =head1 Subroutines/Methods
249              
250             None
251              
252             =head1 Configuration and Environment
253              
254             None
255              
256             =head1 Diagnostics
257              
258             None
259              
260             =head1 Dependencies
261              
262             =over 3
263              
264             =item L<Class::Usul::Constants>
265              
266             =item L<Class::Usul::Functions>
267              
268             =item L<Type::Tiny>
269              
270             =back
271              
272             =head1 Incompatibilities
273              
274             There are no known incompatibilities in this module
275              
276             =head1 Bugs and Limitations
277              
278             There are no known bugs in this module.
279             Please report problems to the address below.
280             Patches are welcome
281              
282             =head1 Author
283              
284             Peter Flanigan, C<< <pjfl@cpan.org> >>
285              
286             =head1 Acknowledgements
287              
288             Larry Wall - For the Perl programming language
289              
290             =head1 License and Copyright
291              
292             Copyright (c) 2017 Peter Flanigan. All rights reserved
293              
294             This program is free software; you can redistribute it and/or modify it
295             under the same terms as Perl itself. See L<perlartistic>
296              
297             This program is distributed in the hope that it will be useful,
298             but WITHOUT WARRANTY; without even the implied warranty of
299             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE
300              
301             =cut
302              
303             # Local Variables:
304             # mode: perl
305             # tab-width: 3
306             # End:
307