File Coverage

blib/lib/Validator/Custom/Constraint.pm
Criterion Covered Total %
statement 173 177 97.7
branch 126 136 92.6
condition 114 114 100.0
subroutine 37 41 90.2
pod 0 34 0.0
total 450 502 89.6


line stmt bran cond sub pod time code
1             # Version 0 module
2             package Validator::Custom::Constraint;
3              
4 5     5   27 use strict;
  5         9  
  5         145  
5 5     5   25 use warnings;
  5         8  
  5         138  
6              
7 5     5   179 use Carp 'croak';
  5         10  
  5         15454  
8              
9             # Carp trust relationship
10             push @Validator::Custom::CARP_NOT, __PACKAGE__;
11              
12             my $NUM_RE = qr/^[-+]?[0-9]+(:?\.[0-9]+)?$/;
13              
14 6 100 100 6 0 47 sub ascii { defined $_[0] && $_[0] =~ /^[\x21-\x7E]+$/ ? 1 : 0 }
15              
16             sub between {
17 17     17 0 31 my ($value, $args) = @_;
18 17         36 my ($start, $end) = @$args;
19              
20            
21 17 100 100     726 croak "Constraint 'between' needs two numeric arguments"
      100        
      100        
22             unless defined($start) && $start =~ /$NUM_RE/ && defined($end) && $end =~ /$NUM_RE/;
23            
24 13 100 100     100 return 0 unless defined $value && $value =~ /$NUM_RE/;
25 10 100 100     76 return $value >= $start && $value <= $end ? 1 : 0;
26             }
27              
28 18 100   18 0 111 sub blank { defined $_[0] && $_[0] eq '' }
29              
30             sub date_to_timepiece {
31 20     20 0 29 my $value = shift;
32            
33 20         103 require Time::Piece;
34            
35             # To Time::Piece object
36 20 100       54 if (ref $value eq 'ARRAY') {
37 14         22 my $year = $value->[0];
38 14         19 my $mon = $value->[1];
39 14         20 my $mday = $value->[2];
40            
41 14 100 100     100 return [0, undef]
      100        
42             unless defined $year && defined $mon && defined $mday;
43            
44 11 100 100     102 unless ($year =~ /^[0-9]{1,4}$/ && $mon =~ /^[0-9]{1,2}$/
      100        
45             && $mday =~ /^[0-9]{1,2}$/)
46             {
47 6         28 return [0, undef];
48             }
49            
50 5         22 my $date = sprintf("%04s%02s%02s", $year, $mon, $mday);
51            
52 5         6 my $tp;
53 5         9 eval {
54 5     0   32 local $SIG{__WARN__} = sub { die @_ };
  0         0  
55 5         21 $tp = Time::Piece->strptime($date, '%Y%m%d');
56             };
57            
58 5 100       154 return $@ ? [0, undef] : [1, $tp];
59             }
60             else {
61 6 100       18 $value = '' unless defined $value;
62 6         86 $value =~ s/[^0-9]//g;
63            
64 6 100       39 return [0, undef] unless $value =~ /^[0-9]{8}$/;
65            
66 4         7 my $tp;
67 4         10 eval {
68 4     0   38 local $SIG{__WARN__} = sub { die @_ };
  0         0  
69 4         25 $tp = Time::Piece->strptime($value, '%Y%m%d');
70             };
71 4 100       190 return $@ ? [0, undef] : [1, $tp];
72             }
73             }
74              
75             sub datetime_to_timepiece {
76 26     26 0 37 my $value = shift;
77            
78 26         119 require Time::Piece;
79            
80             # To Time::Piece object
81 26 100       65 if (ref $value eq 'ARRAY') {
82 20         33 my $year = $value->[0];
83 20         25 my $mon = $value->[1];
84 20         26 my $mday = $value->[2];
85 20         27 my $hour = $value->[3];
86 20         23 my $min = $value->[4];
87 20         26 my $sec = $value->[5];
88              
89 20 100 100     275 return [0, undef]
      100        
      100        
      100        
      100        
90             unless defined $year && defined $mon && defined $mday
91             && defined $hour && defined $min && defined $sec;
92            
93 14 100 100     218 unless ($year =~ /^[0-9]{1,4}$/ && $mon =~ /^[0-9]{1,2}$/
      100        
      100        
      100        
      100        
94             && $mday =~ /^[0-9]{1,2}$/ && $hour =~ /^[0-9]{1,2}$/
95             && $min =~ /^[0-9]{1,2}$/ && $sec =~ /^[0-9]{1,2}$/)
96             {
97 9         44 return [0, undef];
98             }
99            
100 5         24 my $date = sprintf("%04s%02s%02s%02s%02s%02s",
101             $year, $mon, $mday, $hour, $min, $sec);
102 5         7 my $tp;
103 5         6 eval {
104 5     0   28 local $SIG{__WARN__} = sub { die @_ };
  0         0  
105 5         19 $tp = Time::Piece->strptime($date, '%Y%m%d%H%M%S');
106             };
107            
108 5 100       180 return $@ ? [0, undef] : [1, $tp];
109             }
110             else {
111 6 100       15 $value = '' unless defined $value;
112 6         42 $value =~ s/[^0-9]//g;
113            
114 6 100       28 return [0, undef] unless $value =~ /^[0-9]{14}$/;
115            
116 4         4 my $tp;
117 4         9 eval {
118 4     0   28 local $SIG{__WARN__} = sub { die @_ };
  0         0  
119 4         18 $tp = Time::Piece->strptime($value, '%Y%m%d%H%M%S');
120             };
121 4 100       125 return $@ ? [0, undef] : [1, $tp];
122             }
123             }
124              
125             sub decimal {
126 16     16 0 28 my ($value, $digits_tmp) = @_;
127            
128             # 桁数情報を整理
129 16         29 my $digits;
130 16 100       32 if (defined $digits_tmp) {
131 13 100       25 if (ref $digits_tmp eq 'ARRAY') {
132 9         13 $digits = $digits_tmp;
133             }
134             else {
135 4         10 $digits = [$digits_tmp, undef];
136             }
137             }
138             else {
139 3         7 $digits = [undef, undef];
140             }
141            
142             # 正規表現を作成
143 16         19 my $re;
144 16 100 100     81 if (defined $digits->[0] && defined $digits->[1]) {
    100          
    100          
145 4         100 $re = qr/^[0-9]{1,$digits->[0]}(\.[0-9]{0,$digits->[1]})?$/;
146             }
147             elsif (defined $digits->[0]) {
148 7         95 $re = qr/^[0-9]{1,$digits->[0]}(\.[0-9]*)?$/;
149             }
150             elsif (defined $digits->[1]) {
151 2         24 $re = qr/^[0-9]+(\.[0-9]{0,$digits->[1]})?$/;
152             }
153             else {
154 3         7 $re = qr/^[0-9]+(\.[0-9]*)?$/;
155             }
156            
157             # 値をチェック
158 16 100 100     135 if (defined $value && $value =~ /$re/) {
159 6         29 return 1;
160             }
161             else {
162 10         47 return 0;
163             }
164             }
165              
166             sub duplication {
167 10     10 0 19 my $values = shift;
168              
169 10 100 100     58 return 0 unless defined $values->[0] && defined $values->[1];
170 6 100       43 return $values->[0] eq $values->[1] ? [1, $values->[0]] : 0;
171             }
172              
173             sub equal_to {
174 9     9 0 15 my ($value, $target) = @_;
175            
176 9 100 100     303 croak "Constraint 'equal_to' needs a numeric argument"
177             unless defined $target && $target =~ /$NUM_RE/;
178            
179 7 100 100     53 return 0 unless defined $value && $value =~ /$NUM_RE/;
180 4 100       23 return $value == $target ? 1 : 0;
181             }
182              
183             sub greater_than {
184 13     13 0 24 my ($value, $target) = @_;
185            
186 13 100 100     374 croak "Constraint 'greater_than' needs a numeric argument"
187             unless defined $target && $target =~ /$NUM_RE/;
188            
189 11 100 100     88 return 0 unless defined $value && $value =~ /$NUM_RE/;
190 8 100       39 return $value > $target ? 1 : 0;
191             }
192              
193             sub http_url {
194 5 100 100 5 0 44 return defined $_[0] && $_[0] =~ /^s?https?:\/\/[-_.!~*'()a-zA-Z0-9;\/?:\@&=+\$,%#]+$/ ? 1 : 0;
195             }
196              
197 55 100 100 55 0 427 sub int { defined $_[0] && $_[0] =~ /^\-?[0-9]+$/ ? 1 : 0 }
198              
199             sub in_array {
200 6     6 0 10 my ($value, $args) = @_;
201 6 100       15 $value = '' unless defined $value;
202 6         13 my $match = grep { $_ eq $value } @$args;
  12         31  
203 6 100       25 return $match > 0 ? 1 : 0;
204             }
205              
206             sub length {
207 23     23 0 38 my ($value, $args) = @_;
208            
209 23 100       55 return unless defined $value;
210            
211 22         32 my $min;
212             my $max;
213 22 100       66 if(ref $args eq 'ARRAY') { ($min, $max) = @$args }
  8 100       15  
214             elsif (ref $args eq 'HASH') {
215 12         20 $min = $args->{min};
216 12         22 $max = $args->{max};
217             }
218 2         4 else { $min = $max = $args }
219            
220 22 100 100     251 croak "Constraint 'length' needs one or two arguments"
221             unless defined $min || defined $max;
222            
223 21         28 my $length = length $value;
224 21         20 my $is_valid;
225 21 100 100     97 if (defined $min && defined $max) {
    100          
    50          
226 13   100     70 $is_valid = $length >= $min && $length <= $max;
227             }
228             elsif (defined $min) {
229 4         8 $is_valid = $length >= $min;
230             }
231             elsif (defined $max) {
232 4         8 $is_valid =$length <= $max;
233             }
234            
235 21         81 return $is_valid;
236             }
237              
238             sub less_than {
239 11     11 0 24 my ($value, $target) = @_;
240            
241 11 100 100     313 croak "Constraint 'less_than' needs a numeric argument"
242             unless defined $target && $target =~ /$NUM_RE/;
243            
244 9 100 100     70 return 0 unless defined $value && $value =~ /$NUM_RE/;
245 6 100       29 return $value < $target ? 1 : 0;
246             }
247              
248             sub merge {
249 3     3 0 6 my $values = shift;
250            
251 3 100       11 $values = [$values] unless ref $values eq 'ARRAY';
252            
253 3         15 return [1, join('', @$values)];
254             }
255              
256 6 100   6 0 37 sub string { defined $_[0] && !ref $_[0] }
257 30 100   30 0 201 sub not_blank { defined $_[0] && $_[0] ne '' }
258 2     2 0 8 sub not_defined { !defined $_[0] }
259 8 100 100 8 0 87 sub not_space { defined $_[0] && $_[0] !~ '^[ \t\n\r\f]*$' ? 1 : 0 }
260              
261 10 100 100 10 0 87 sub uint { defined $_[0] && $_[0] =~ /^[0-9]+$/ ? 1 : 0 }
262              
263             sub regex {
264 7     7 0 40 my ($value, $regex) = @_;
265 7 100 100     98 defined $value && $value =~ /$regex/ ? 1 : 0;
266             }
267              
268             sub selected_at_least {
269 10     10 0 19 my ($values, $num) = @_;
270            
271 10 100       18 my $selected = ref $values ? $values : [$values];
272 10         15 $num += 0;
273 10 100       40 return scalar(@$selected) >= $num ? 1 : 0;
274             }
275              
276             sub shift_array {
277 2     2 0 4 my $values = shift;
278            
279 2 100       8 $values = [$values] unless ref $values eq 'ARRAY';
280            
281 2         8 return [1, shift @$values];
282             }
283              
284 8 100 100 8 0 75 sub space { defined $_[0] && $_[0] =~ '^[ \t\n\r\f]*$' ? 1 : 0 }
285              
286             sub to_array {
287 8     8 0 15 my $value = shift;
288            
289 8 100       24 $value = [$value] unless ref $value eq 'ARRAY';
290            
291 8         29 return [1, $value];
292             }
293              
294             sub to_array_remove_blank {
295 4     4 0 7 my $values = shift;
296            
297 4 100       19 $values = [$values] unless ref $values eq 'ARRAY';
298 4 50       9 $values = [grep { defined $_ && CORE::length $_} @$values];
  8         41  
299            
300 4         22 return [1, $values];
301             }
302              
303             sub trim {
304 3     3 0 8 my $value = shift;
305 3 50       34 $value =~ s/^[ \t\n\r\f]*(.*?)[ \t\n\r\f]*$/$1/ms if defined $value;
306 3         17 return [1, $value];
307             }
308              
309             sub trim_collapse {
310 2     2 0 4 my $value = shift;
311 2 50       6 if (defined $value) {
312 2         9 $value =~ s/[ \t\n\r\f]+/ /g;
313 2         12 $value =~ s/^[ \t\n\r\f]*(.*?)[ \t\n\r\f]*$/$1/ms;
314             }
315 2         10 return [1, $value];
316             }
317              
318             sub trim_lead {
319 2     2 0 6 my $value = shift;
320 2 50       11 $value =~ s/^[ \t\n\r\f]+(.*)$/$1/ms if defined $value;
321 2         9 return [1, $value];
322             }
323              
324             sub trim_trail {
325 2     2 0 4 my $value = shift;
326 2 50       15 $value =~ s/^(.*?)[ \t\n\r\f]+$/$1/ms if defined $value;
327 2         8 return [1, $value];
328             }
329              
330             sub trim_uni {
331 1     1 0 3 my $value = shift;
332 1 50       11 $value =~ s/^\s*(.*?)\s*$/$1/ms if defined $value;
333 1         11 return [1, $value];
334             }
335              
336             sub trim_uni_collapse {
337 1     1 0 3 my $value = shift;
338 1 50       5 if (defined $value) {
339 1         8 $value =~ s/\s+/ /g;
340 1         7 $value =~ s/^\s*(.*?)\s*$/$1/ms;
341             }
342 1         5 return [1, $value];
343             }
344              
345             sub trim_uni_lead {
346 1     1 0 3 my $value = shift;
347 1 50       21 $value =~ s/^\s+(.*)$/$1/ms if defined $value;
348 1         5 return [1, $value];
349             }
350              
351             sub trim_uni_trail {
352 1     1 0 2 my $value = shift;
353 1 50       19 $value =~ s/^(.*?)\s+$/$1/ms if defined $value;
354 1         5 return [1, $value];
355             }
356              
357             1;
358              
359             =head1 NAME
360              
361             Validator::Custom::Constraint - Constrint functions