File Coverage

lib/Data/Processor/ValidatorFactory.pm
Criterion Covered Total %
statement 39 41 95.1
branch 5 8 62.5
condition n/a
subroutine 12 12 100.0
pod 5 5 100.0
total 61 66 92.4


line stmt bran cond sub pod time code
1 20     20   57878 use 5.10.1;
  20         60  
2 20     20   81 use strict;
  20         33  
  20         436  
3 20     20   106 use warnings;
  20         38  
  20         7358  
4             package Data::Processor::ValidatorFactory;
5              
6             =head1 NAME
7              
8             Data::Processor::ValidatorFactory - create validators for use in schemas
9              
10             =head1 SYNOPSIS
11              
12             use Data::Processor::ValidatorFactory;
13              
14             my $vf = Data::Processor::ValidatorFactory->new;
15              
16             my $SCHEMA = {
17             log => {
18             validator => $vf->file('>','writing'),
19             },
20             name => {
21             validator => $vf->rx(qr{[A-Z]+},'expected name made up from capital letters')
22             },
23             mode => {
24             validator => $vf->any(qw(UP DOWN))
25             }
26             }
27              
28             =head1 DESCRIPTION
29              
30             The ValidatorFactory lets you create falidator functions for use in L schemas.
31              
32             =head1 METHODS
33              
34             =head2 new
35              
36             create an instance of the factory
37              
38             =cut
39              
40             sub new {
41 39     39 1 139 my $class = shift;
42 39         59 my $self = { };
43 39         55 bless ($self, $class);
44 39         68 return $self;
45             }
46              
47             =head2 file($operation,$message)
48              
49             use the three parameter open to access the 'value' of if this does not work
50             return $message followed by the filename and the errormessage
51              
52             $vf->file('<','reading');
53             $vf->file('>>','appending to');
54              
55             =cut
56              
57             sub file {
58 1     1 1 6 my $self = shift;
59 1         2 my $op = shift;
60 1         3 my $msg = shift;
61             return sub {
62 1     1   2 my $file = shift;
63 1 50       153 open my $fh, $op, $file and return undef;
64 1         27 return "$msg $file: $!";
65             }
66 1         5 }
67              
68             =head2 dir()
69              
70             check if the given directory exists
71              
72             $vf->dir();
73              
74             =cut
75              
76             sub dir {
77 1     1 1 3 my $self = shift;
78             return sub {
79 1     1   3 my $value = shift;
80 1 50       19 return undef if -d $value;
81 0         0 return "directory $value does not exist";
82             }
83 1         4 }
84              
85             =head2 rx($rx,$message)
86              
87             apply the regular expression to the value and return $message if it does
88             not match.
89              
90             $vf->rx(qr{[A-Z]+},'use uppercase letters')
91              
92             =cut
93              
94             sub rx {
95 191     191 1 241 my $self = shift;
96 191         180 my $rx = shift;
97 191         200 my $msg = shift;
98             return sub {
99 62     62   98 my $value = shift;
100 62 100       357 if ($value =~ /$rx/){
101 61         150 return undef;
102             }
103 1         5 return "$msg ($value)";
104             }
105 191         2035 }
106              
107             =head2 any(@list)
108              
109             value must be one of the values of the @list
110              
111             $vf->any(qw(ON OFF))
112              
113             =cut
114              
115             sub any {
116 1     1 1 3 my $self = shift;
117 1         3 my $array = [ @_ ];
118 1         3 my %hash = ( map { $_ => 1 } @$array );
  2         6  
119             return sub {
120 1     1   4 my $value = shift;
121 1 50       3 if ($hash{$value}){
122 1         28 return undef;
123             }
124 0           return "expected one a value from the list: ".join(', ',@$array);
125             }
126 1         46 };
127              
128             =head1 COPYRIGHT
129              
130             Copyright (c) 2015 by OETIKER+PARTNER AG. All rights reserved.
131              
132             =head1 AUTHOR
133              
134             Tobias Oetiker Etobi@oetiker.chE
135              
136             =head1 LICENCE
137              
138             This module is free software; you can redistribute it and/or modify it under
139             the same terms as Perl itself. See L.
140              
141              
142             =cut
143             1;