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