File Coverage

blib/lib/Config/Apple/Profile/Payload/Types/Validation.pm
Criterion Covered Total %
statement 110 127 86.6
branch 53 70 75.7
condition 7 9 77.7
subroutine 25 27 92.5
pod 10 10 100.0
total 205 243 84.3


line stmt bran cond sub pod time code
1             package Config::Apple::Profile::Payload::Types::Validation;
2              
3 15     15   129 use 5.10.1;
  15         35  
  15         608  
4 15     15   64 use strict;
  15         20  
  15         411  
5 15     15   54 use warnings FATAL => 'all';
  15         21  
  15         659  
6              
7             our $VERSION = '0.87';
8              
9 15     15   11773 use DateTime;
  15         1587875  
  15         569  
10 15     15   8453 use DateTime::Format::Flexible;
  15         851853  
  15         215  
11 15     15   1504 use Encode qw(encode);
  15         25  
  15         2016  
12             use Exporter::Easy (
13 15         164 OK => [qw(
14             validate
15             validate_string validate_number validate_real validate_date
16             validate_boolean validate_data validate_identifier validate_uuid
17             validate_class
18             )],
19             TAGS => [
20             'all' => [qw(
21             validate
22             validate_string validate_number validate_real validate_date
23             validate_boolean validate_data validate_identifier validate_uuid
24             validate_class
25             )],
26             'types' => [qw(
27             validate_string validate_number validate_real validate_date
28             validate_boolean validate_data validate_identifier validate_uuid
29             validate_class
30             )],
31             ],
32 15     15   81 );
  15         18  
33 15     15   4545 use Fcntl qw(F_GETFL O_RDONLY O_RDWR :seek);
  15         25  
  15         2306  
34 15     15   10030 use Regexp::Common;
  15         30518  
  15         60  
35 15     15   641330 use Scalar::Util qw(openhandle blessed);
  15         27  
  15         919  
36 15     15   69 use Try::Tiny;
  15         25  
  15         782  
37 15     15   76 use Config::Apple::Profile::Payload::Types qw(:all);
  15         21  
  15         17267  
38              
39              
40             =encoding utf8
41              
42             =head1 NAME
43              
44             Config::Apple::Profile::Payload::Types::Validation - Validation of common
45             payload types.
46              
47             =head1 DESCRIPTION
48              
49             Apple Configuration Profiles contain one or more I. Each payload
50             contains a dictionary, which can be thought of like a Perl hash. Within a
51             payload's dictionary, each key's value is restricted to a specific type.
52             One key might require a number; a different key might require a string, or some
53             binary data.
54              
55             Provided in this module are a number of Readonly scalars that will be used
56             (instead of strings) to identify the data types for configuration profile keys.
57             The scalars are all OK for import into your local namespace, or you can simply
58             import C<:all> to get all of them at once.
59              
60              
61             =head1 FUNCTIONS
62              
63             =head2 validate
64              
65             my $validated_value = validate($type, $value);
66              
67             Validates C<$value> as a valid C<$type>. If valid, returns the de-tainted
68             C<$value>. If invalid, returns C.
69              
70             C<$type> is one of the values from L.
71             C<$value> is the value to be validated.
72              
73             IF C<$type> is not valid, or C<$value> is C, then C is returned.
74              
75             =cut
76              
77             sub validate {
78 681     681 1 1036 my ($type, $value) = @_;
79            
80             # We recognize String types
81 681 100 66     1146 if ($type == $ProfileString) {
    100          
    100          
    50          
    100          
    100          
    100          
    50          
    0          
82 64         314 return validate_string($value);
83             }
84            
85             # We recognize Number types
86             elsif ($type == $ProfileNumber) {
87 184         1285 return validate_number($value);
88             }
89            
90             # We recognize Real (floating-point number) types
91             elsif ($type == $ProfileReal) {
92 49         460 return validate_real($value);
93             }
94            
95             # We recognize Boolean types
96             elsif ($type == $ProfileBool) {
97 0         0 return validate_boolean($value);
98             }
99            
100             # We recognize Data types
101             elsif ( ($type == $ProfileData)
102             || ($type == $ProfileNSDataBlob)
103             ) {
104 16         340 return validate_data($value);
105             }
106            
107             # We recognize Date types
108             elsif ($type == $ProfileDate) {
109 15         433 return validate_date($value);
110             }
111            
112             # We recognize Identifier types
113             elsif ($type == $ProfileIdentifier) {
114 31         991 return validate_identifier($value);
115             }
116            
117             # We recognize UUID types
118             elsif ($type == $ProfileUUID) {
119 322         9485 return validate_uuid($value);
120             }
121            
122             # We recognize classes
123             elsif ($type == $ProfileClass) {
124 0         0 return validate_class($value);
125             }
126             }
127              
128              
129             =head2 validate_string
130              
131             my $valid_string = validate_string($value);
132              
133             Returns a de-tained C<$value> if it is a defined, non-empty scalar, and can be
134             encoded as UTF-8 by L.
135              
136             =cut
137              
138             sub validate_string {
139 64     64 1 110 my ($value) = @_;
140            
141             # References aren't allowed here
142             ## no critic (ProhibitExplicitReturnUndef)
143 64 100       159 return undef if ref($value);
144             ##use critic
145            
146             # Empty strings aren't allowed, either.
147 58 100       310 if ($value =~ m/^(.+)$/s) {
148 51         119 $value = $1;
149            
150             }
151             else {
152             ## no critic (ProhibitExplicitReturnUndef)
153 6         23 return undef;
154             ##use critic
155             }
156            
157             # Try to encode as UTF-8, to make sure it's safe
158             try {
159 51     51   1781 encode('UTF-8', $value, Encode::FB_CROAK | Encode::LEAVE_SRC);
160             }
161             catch {
162 2     2   163 $value = undef;
163 51         369 };
164            
165             # If we're here, then we are valid!
166 51         3077 return $value;
167             }
168              
169              
170             =head2 validate_number
171              
172             my $number = validate_number($value)
173              
174             Returns a de-tained C<$value> if it is an integer. A leading + is OK.
175             Any other input returns C.
176              
177             =cut
178              
179             sub validate_number {
180 184     184 1 186 my ($value) = @_;
181            
182             # References aren't allowed here
183             ## no critic (ProhibitExplicitReturnUndef)
184 184 100       328 return undef if ref($value);
185             ##use critic
186            
187             # Numbers must be integers, positive or negative (or zero).
188 175 100       591 if ($value =~ /^$RE{num}{int}{-keep}$/) {
189 155         22959 return $1;
190             }
191            
192             # If we're here, the matching failed, so return undef
193             ## no critic (ProhibitExplicitReturnUndef)
194 18         3193 return undef;
195             ##use critic
196             }
197              
198              
199             =head2 validate_real
200              
201             my $number = validate_real($value)
202              
203             Returns a de-tainted C<$value> if it is an integer or a floating-point number.
204             A loading C<+> is OK. An exponent, positive or negative, is also OK.
205             Any other input returns C.
206              
207             =cut
208              
209             sub validate_real {
210 49     49 1 47 my ($value) = @_;
211            
212             # References aren't allowed here
213             ## no critic (ProhibitExplicitReturnUndef)
214 49 100       95 return undef if ref($value);
215             ##use critic
216            
217             # Numbers must be floating-point, positive or negative (or zero).
218 43 100       190 if ($value =~ /^$RE{num}{real}{-keep}$/i) {
219 36         6491 return $1;
220             }
221            
222             # If we're here, the matching failed, so return undef
223             ## no critic (ProhibitExplicitReturnUndef)
224 6         1077 return undef;
225             ##use critic
226             }
227              
228              
229             =head2 validate_boolean
230              
231             my $boolean = validate_boolean($value);
232              
233             If C<$value> can be evaluated as true or false, returns a C<1> or a C<0>,
234             respectively. Will return C if a reference is passed.
235              
236             =cut
237              
238             sub validate_boolean {
239 0     0 1 0 my ($value) = @_;
240            
241             # References aren't allowed here
242             ## no critic (ProhibitExplicitReturnUndef)
243 0 0       0 return undef if ref($value);
244             ##use critic
245            
246             # A simple evaluation!
247 0 0       0 if ($value) {
248 0         0 return 1;
249             }
250 0 0       0 if (!$value) {
251 0         0 return 0;
252             }
253             }
254              
255              
256             =head2 validate_date
257              
258             my $date_object = validate_date($value);
259              
260             If C<$value> is already a finite C object, it is returned immediately.
261             If C<$value> is a string, and can be parsed by L,
262             the resulting C object will be returned.
263              
264             Unparseable strings, infinite C objects, and any other input will
265             return C.
266              
267             =cut
268              
269             sub validate_date {
270 15     15 1 19 my ($value) = @_;
271            
272             # If we have a blessed ref, which is a DateTime object, and it represents
273             # a finite time, then we're good!
274 15 100       32 if (ref $value) {
275             ## no critic (ProhibitExplicitReturnUndef)
276 4 50       18 return undef unless blessed($value);
277 4 100       34 return undef unless $value->isa('DateTime');
278 3 100       17 return undef unless $value->is_finite;
279             ##use critic
280            
281 1         10 return $value;
282             }
283            
284             # At this point, we have a scalar, so let's see if it can be parsed
285             try {
286 11     11   311 $value = DateTime::Format::Flexible->parse_datetime($value);
287             }
288             # If the parse fails, it dies, so return undef
289             catch {
290 3     3   23247 $value = undef;
291 11         72 };
292            
293             # Return either our object, or undef
294 11         34717 return $value;
295             }
296              
297              
298             =head2 validate_data
299              
300             # With a file handle
301             my $handle = validate_data($handle);
302              
303             # With binary data
304             my $handle = validate_data($bytes);
305              
306             If passed an already-open file handle, or any object that represents a file
307             (such as an C object), the handle (without the object tie) will be
308             returned.
309              
310             If passed a scalar, it will be checked to make sure it is not empty, and that
311             is not a utf8 string. The contents of the string will be placed into an
312             anonymous in-memory file, and the filehandle will be returned.
313              
314             =cut
315              
316             sub validate_data {
317 16     16 1 19 my ($value) = @_;
318            
319             # How we act here depends if we have a string or a filehandle
320             # Let's first check if we were given an open filehandle
321 16 100       57 if (openhandle($value)) {
322             # First, get just the plain filehandle
323 12         22 my $value = openhandle($value);
324            
325             # Check if the file is open for reading
326             # I would like to use the solution from
327             # , but that doesn't work on
328             # all filehandles, unfortunately.
329             # We'll have to do it the hard way.
330            
331             #my $modes = fcntl($value, F_GETFL, 0);
332             #my $mask = 2**O_RDONLY + 2**O_RDWR;
333             #unless (($modes & $mask) > 0) {
334             # die "Filehandle is not open for reading.";
335             #}
336 12         15 my $ignore;
337             my $count ;
338             try {
339 12     12   403 $count = read $value, $ignore, 1;
340 12         90 };
341 12 100       156 unless (defined $count) {
342 2         14 die "Unable to read from filehandle. Is it open for reading?";
343             }
344            
345             # If we can't seek, we're probably dealing with something bad
346 10 50       44 unless (seek $value, -1, SEEK_CUR) {
347 0         0 die "Unable to seek with filehandle. Is it pointing to a file?";
348             }
349            
350 10         44 return $value;
351             }
352            
353             # If we don't have an open handle, then make sure it's not an object
354 4 100       11 unless (ref($value)) {
355             # We have a string. Let's make sure it's binary, and non-empty.
356 3 100 66     28 if ( (!utf8::is_utf8($value))
357             && (length($value) > 0)
358             ) {
359             # Pull the string into an anonymous in-memory file, and return that.
360 2         359 open(my $file, '+>', undef);
361 2         8 binmode $file;
362 2         16 print $file $value;
363 2         76 seek $file, 0, 0;
364 2         15 return $file;
365             }
366             }
367            
368             # If we're here, then we are dealing with something unknown to us.
369             ## no critic (ProhibitExplicitReturnUndef)
370 2         7 return undef;
371             ##use critic
372             }
373              
374              
375             =head2 validate_identifier
376              
377             my $valid_identifier = validate_identifier($value);
378              
379             Returns a de-tained C<$value> if it is a single-line string that matches the
380             format of a domain name (without spaces). Otherwise, returns C.
381              
382             =cut
383              
384             sub validate_identifier {
385 31     31 1 47 my ($value) = @_;
386            
387             # References aren't allowed here
388             ## no critic (ProhibitExplicitReturnUndef)
389 31 100       96 return undef if ref($value);
390             ##use critic
391            
392             # Empty strings aren't allowed, either.
393 25 100       162 if ($value =~ m/^(.+)$/s) {
394 22         45 my $matched_string = $1;
395             # Identifiers are one-line strings
396 22 100 100     199 if ( ($matched_string !~ m/\n/s)
397             && ($matched_string =~ m/^$RE{net}{domain}{-nospace}$/)
398             ) {
399 17         3353 return $matched_string;
400             }
401             }
402            
403             # If we're here, the matching failed, so return undef
404             ## no critic (ProhibitExplicitReturnUndef)
405 7         1103 return undef;
406             ##use critic
407             }
408              
409             =head2 validate_uuid
410              
411             my $guid = validate_uuid($value);
412              
413             If C<$value> is a C object, it is returned immediately.
414             If C<$value> is a C object, an equivalent C object is
415             returned. Objects of other types return C.
416              
417             If C<$value> is a string that can be parsed as a GUID, an equivalent
418             C object is returned. Otherwise, C is returned.
419              
420             =cut
421              
422             sub validate_uuid {
423 322     322 1 339 my ($value) = @_;
424            
425 322         424 my $class = ref($value);
426 322         308 my $uuid;
427            
428             # We accept Data::UUID objects
429 322 50       641 if ($class eq 'Data::UUID') {
430 0         0 $uuid = Data::GUID::from_data_uuid($value);
431 0         0 return $uuid;
432             }
433            
434             # We accept Data::GUID objects
435 322 100       552 if ($class eq 'Data::GUID') {
436 101         384 return $value;
437             }
438            
439             # We don't accept other kinds of objects
440 221 100       380 if ($class ne '') {
441             ## no critic (ProhibitExplicitReturnUndef)
442 3         12 return undef;
443             ## use critic
444             }
445            
446             # Have Data::GUID try to parse the input
447             # If from_any_string doesn't die, then it wored OK
448 218         315 eval {
449 218         632 $uuid = Data::GUID->from_any_string($value);
450             };
451              
452             # If parsing went OK, then we have our object! Otherwise, we have undef.
453 218         109749 return $uuid;
454             }
455              
456              
457             =head2 validate_class
458              
459             my $object = validate_class($value)
460              
461             If C<$value> is an object, and is also an instance of
462             C (or something that is a subclass),
463             then C<$value> is returned. Otherwise, C is returned.
464              
465             =cut
466              
467             sub validate_class {
468 0     0 1   my ($object) = @_;
469            
470             # We don't accept non-references
471 0 0         if (!blessed($object)) {
472             ## no critic (ProhibitExplicitReturnUndef)
473 0           return undef;
474             ## use critic
475             }
476            
477 0 0         if ($object->isa('Config::Apple::Profile::Payload::Common')) {
478 0           return $object;
479             }
480            
481             # If we're here, then we have an object of the wrong class
482             ## no critic (ProhibitExplicitReturnUndef)
483 0           return undef;
484             ## use critic
485             }
486              
487             =head1 ACKNOWLEDGEMENTS
488              
489             Refer to L for acknowledgements.
490              
491             =head1 AUTHOR
492              
493             A. Karl Kornel, C<< >>
494              
495             =head1 COPYRIGHT AND LICENSE
496              
497             Copyright © 2014 A. Karl Kornel.
498              
499             This program is free software; you can redistribute it and/or modify it
500             under the terms of either: the GNU General Public License as published
501             by the Free Software Foundation; or the Artistic License.
502              
503             See L for more information.
504              
505             =cut
506              
507             1;