File Coverage

blib/lib/Validator/Custom.pm
Criterion Covered Total %
statement 293 301 97.3
branch 172 184 93.4
condition 27 36 75.0
subroutine 26 27 96.3
pod 8 12 66.6
total 526 560 93.9


line stmt bran cond sub pod time code
1             package Validator::Custom;
2 5     5   99991 use Object::Simple -base;
  5         5886  
  5         41  
3 5     5   542 use 5.008001;
  5         19  
4             our $VERSION = '1.01';
5              
6 5     5   25 use Carp 'croak';
  5         13  
  5         352  
7 5     5   3120 use Validator::Custom::Validation;
  5         20  
  5         50  
8 5     5   2858 use Validator::Custom::FilterFunction;
  5         13  
  5         150  
9 5     5   2766 use Validator::Custom::CheckFunction;
  5         12  
  5         163  
10              
11             # Version 0 modules
12 5     5   2878 use Validator::Custom::Constraints;
  5         14  
  5         52  
13 5     5   3590 use Validator::Custom::Constraint;
  5         13  
  5         192  
14 5     5   3142 use Validator::Custom::Result;
  5         15  
  5         47  
15 5     5   2501 use Validator::Custom::Rule;
  5         12  
  5         46  
16              
17 18     18 1 3442 sub validation { Validator::Custom::Validation->new }
18              
19             sub new {
20 135     135 1 107613 my $self = shift->SUPER::new(@_);
21            
22             # Add checks
23 135         1200 $self->add_check(
24             ascii_graphic => \&Validator::Custom::CheckFunction::ascii_graphic,
25             number => \&Validator::Custom::CheckFunction::number,
26             int => \&Validator::Custom::CheckFunction::int,
27             in => \&Validator::Custom::CheckFunction::in
28             );
29            
30             # Add filters
31 135         440 $self->add_filter(
32             remove_blank => \&Validator::Custom::FilterFunction::remove_blank,
33             trim => \&Validator::Custom::FilterFunction::trim,
34             );
35            
36             # Version 0 constraints
37             $self->register_constraint(
38 2     2   6 any => sub { 1 },
39             ascii => \&Validator::Custom::Constraint::ascii,
40             between => \&Validator::Custom::Constraint::between,
41             blank => \&Validator::Custom::Constraint::blank,
42             date_to_timepiece => \&Validator::Custom::Constraint::date_to_timepiece,
43             datetime_to_timepiece => \&Validator::Custom::Constraint::datetime_to_timepiece,
44             decimal => \&Validator::Custom::Constraint::decimal,
45 3     3   11 defined => sub { defined $_[0] },
46 135         1870 duplication => \&Validator::Custom::Constraint::duplication,
47             equal_to => \&Validator::Custom::Constraint::equal_to,
48             greater_than => \&Validator::Custom::Constraint::greater_than,
49             http_url => \&Validator::Custom::Constraint::http_url,
50             int => \&Validator::Custom::Constraint::int,
51             in_array => \&Validator::Custom::Constraint::in_array,
52             length => \&Validator::Custom::Constraint::length,
53             less_than => \&Validator::Custom::Constraint::less_than,
54             merge => \&Validator::Custom::Constraint::merge,
55             not_defined => \&Validator::Custom::Constraint::not_defined,
56             not_space => \&Validator::Custom::Constraint::not_space,
57             not_blank => \&Validator::Custom::Constraint::not_blank,
58             uint => \&Validator::Custom::Constraint::uint,
59             regex => \&Validator::Custom::Constraint::regex,
60             selected_at_least => \&Validator::Custom::Constraint::selected_at_least,
61             shift => \&Validator::Custom::Constraint::shift_array,
62             space => \&Validator::Custom::Constraint::space,
63             string => \&Validator::Custom::Constraint::string,
64             to_array => \&Validator::Custom::Constraint::to_array,
65             to_array_remove_blank => \&Validator::Custom::Constraint::to_array_remove_blank,
66             trim => \&Validator::Custom::Constraint::trim,
67             trim_collapse => \&Validator::Custom::Constraint::trim_collapse,
68             trim_lead => \&Validator::Custom::Constraint::trim_lead,
69             trim_trail => \&Validator::Custom::Constraint::trim_trail,
70             trim_uni => \&Validator::Custom::Constraint::trim_uni,
71             trim_uni_collapse => \&Validator::Custom::Constraint::trim_uni_collapse,
72             trim_uni_lead => \&Validator::Custom::Constraint::trim_uni_lead,
73             trim_uni_trail => \&Validator::Custom::Constraint::trim_uni_trail
74             );
75            
76 135         653 return $self;
77             }
78              
79             sub check_each {
80 8     8 1 566 my ($self, $values, $name, $arg) = @_;
81            
82 8 100       23 if (@_ < 3) {
83 2         206 croak "values and the name of a checking function must be passed";
84             }
85            
86 6   50     15 my $checks = $self->{checks} || {};
87            
88             croak "Can't call \"$name\" checking function"
89 6 100       113 unless $checks->{$name};
90            
91 5 100       125 croak "values must be array reference"
92             unless ref $values eq 'ARRAY';
93            
94 4         6 my $is_invalid;
95 4         7 for my $value (@$values) {
96 7         20 my $is_valid = $checks->{$name}->($self, $value, $arg);
97 7 100       45 unless ($is_valid) {
98 2         3 $is_invalid = 1;
99 2         4 last;
100             }
101             }
102            
103 4 100       13 return $is_invalid ? 0 : 1;
104             }
105              
106             sub filter_each {
107 6     6 1 580 my ($self, $values, $name, $arg) = @_;
108            
109 6 100       20 if (@_ < 3) {
110 2         231 croak "values and the name of a filtering function must be passed";
111             }
112            
113 4   50     11 my $filters = $self->{filters} || {};
114            
115             croak "Can't call \"$name\" filtering function"
116 4 100       109 unless $filters->{$name};
117            
118 3 100       104 croak "values must be array reference"
119             unless ref $values eq 'ARRAY';
120            
121 2         4 my $new_values = [];
122 2         5 for my $value (@$values) {
123 4         12 my $new_value = $filters->{$name}->($self, $value, $arg);
124 4         23 push @$new_values, $new_value;
125             }
126            
127 2         6 return $new_values;
128             }
129              
130             sub check {
131 44     44 1 774 my ($self, $value, $name, $arg) = @_;
132              
133 44 100       98 if (@_ < 3) {
134 2         272 croak "value and the name of a checking function must be passed";
135             }
136            
137 42   50     99 my $checks = $self->{checks} || {};
138            
139             croak "Can't call \"$name\" checking function"
140 42 100       186 unless $checks->{$name};
141            
142 41         118 return $checks->{$name}->($self, $value, $arg);
143             }
144              
145             sub filter {
146 10     10 1 578 my ($self, $value, $name, $arg) = @_;
147            
148 10 100       26 if (@_ < 3) {
149 2         239 croak "value and the name of a filtering function must be passed";
150             }
151            
152 8   50     24 my $filters = $self->{filters} || {};
153            
154             croak "Can't call \"$name\" filtering function"
155 8 100       115 unless $filters->{$name};
156            
157 7         25 return $filters->{$name}->($self, $value, $arg);
158             }
159              
160             sub add_check {
161 137     137 1 230 my $self = shift;
162            
163             # Merge
164 137 50       671 my $checks = ref $_[0] eq 'HASH' ? $_[0] : {@_};
165 137 100       196 $self->{checks} = ({%{$self->{checks} || {}}, %$checks});
  137         1223  
166            
167 137         451 return $self;
168             }
169              
170             sub add_filter {
171 137     137 1 194 my $self = shift;
172            
173             # Merge
174 137 50       495 my $filters = ref $_[0] eq 'HASH' ? $_[0] : {@_};
175 137 100       180 $self->{filters} = ({%{$self->{filters} || {}}, %$filters});
  137         827  
176            
177 137         373 return $self;
178             }
179              
180             # Version 0 method
181             our %VALID_OPTIONS = map {$_ => 1} qw/message default copy require optional/;
182             sub _parse_constraint {
183 452     452   2591 my ($self, $c) = @_;
184              
185             # Constraint information
186 452         691 my $cinfo = {};
187              
188             # Arrange constraint information
189 452         826 my $constraint = $c->{constraint};
190 452         874 $cinfo->{message} = $c->{message};
191 452         787 $cinfo->{original_constraint} = $c->{constraint};
192            
193             # Code reference
194 452 100       935 if (ref $constraint eq 'CODE') {
195 19         44 $cinfo->{funcs} = [$constraint];
196             }
197             # Simple constraint name
198             else {
199 433         444 my $constraints;
200 433 100       872 if (ref $constraint eq 'ARRAY') {
201 6         8 $constraints = $constraint;
202             }
203             else {
204 427 100       937 if ($constraint =~ /\|\|/) {
205 13         47 $constraints = [split(/\|\|/, $constraint)];
206             }
207             else {
208 414         823 $constraints = [$constraint];
209             }
210             }
211            
212             # Constraint functions
213 433         665 my @cfuncs;
214             my @cargs;
215 433         728 for my $cname (@$constraints) {
216             # Arrange constraint
217 457 100       993 if (ref $cname eq 'HASH') {
218 108         264 my $first_key = (keys %$cname)[0];
219 108         225 push @cargs, $cname->{$first_key};
220 108         162 $cname = $first_key;
221             }
222              
223             # Target is array elements
224 457 100       1040 $cinfo->{each} = 1 if $cname =~ s/^@//;
225 457 50       1080 croak qq{"\@" must be one at the top of constrinat name}
226             if index($cname, '@') > -1;
227            
228            
229             # Trim space
230 457         910 $cname =~ s/^\s+//;
231 457         786 $cname =~ s/\s+$//;
232            
233             # Negative
234 457 100       892 my $negative = $cname =~ s/^!// ? 1 : 0;
235 457 50       942 croak qq{"!" must be one at the top of constraint name}
236             if index($cname, '!') > -1;
237            
238             # Trim space
239 457         698 $cname =~ s/^\s+//;
240 457         723 $cname =~ s/\s+$//;
241            
242             # Constraint function
243 457 100       1353 croak "Constraint name '$cname' must be [A-Za-z0-9_]"
244             if $cname =~ /\W/;
245 456   100     1294 my $cfunc = $self->constraints->{$cname} || '';
246 456 100       5846 croak qq{"$cname" is not registered}
247             unless ref $cfunc eq 'CODE';
248            
249             # Negativate
250             my $f = $negative ? sub {
251 9     9   24 my $ret = $cfunc->(@_);
252 9 100       32 if (ref $ret eq 'ARRAY') {
253 2         11 $ret->[0] = ! $ret->[0];
254 2         6 return $ret;
255             }
256 7         21 else { return !$ret }
257 455 100       906 } : $cfunc;
258            
259             # Add
260 455         1119 push @cfuncs, $f;
261             }
262 431         836 $cinfo->{funcs} = \@cfuncs;
263 431         1161 $cinfo->{args} = \@cargs;
264             }
265            
266 450         1871 return $cinfo;
267             }
268              
269             # DEPRECATED!
270             has shared_rule => sub { [] };
271             # DEPRECATED!
272             __PACKAGE__->dual_attr('constraints',
273             default => sub { {} }, inherit => 'hash_copy');
274              
275             # Version 0 method
276 173     173 0 2453 sub create_rule { Validator::Custom::Rule->new(validator => shift) }
277              
278             # Version 0 method
279             sub register_constraint {
280 151     151 0 6073 my $self = shift;
281            
282             # Merge
283 151 100       2913 my $constraints = ref $_[0] eq 'HASH' ? $_[0] : {@_};
284 151         240 $self->constraints({%{$self->constraints}, %$constraints});
  151         527  
285            
286 151         9522 return $self;
287             }
288              
289             # Version 0 method
290             sub _parse_random_string_rule {
291 1     1   5 my $self = shift;
292            
293             # Rule
294 1 50       11 my $rule = ref $_[0] eq 'HASH' ? $_[0] : {@_};
295            
296             # Result
297 1         2 my $result = {};
298            
299             # Parse string rule
300 1         5 for my $name (keys %$rule) {
301             # Pettern
302 5         9 my $pattern = $rule->{$name};
303 5 100       10 $pattern = '' unless $pattern;
304            
305             # State
306 5         9 my $state = 'character';
307              
308             # Count
309 5         7 my $count = '';
310            
311             # Chacacter sets
312 5         6 my $csets = [];
313 5         7 my $cset = [];
314            
315             # Parse pattern
316 5         7 my $c;
317 5   66     28 while (defined ($c = substr($pattern, 0, 1, '')) && length $c) {
318             # Character class
319 42 100       83 if ($state eq 'character_class') {
    100          
320 9 100       16 if ($c eq ']') {
321 3         5 $state = 'character';
322 3         5 push @$csets, $cset;
323 3         5 $cset = [];
324 3         13 $state = 'character';
325             }
326 6         29 else { push @$cset, $c }
327             }
328            
329             # Count
330             elsif ($state eq 'count') {
331 13 100       23 if ($c eq '}') {
332 6 50       16 $count = 1 if $count < 1;
333 6         19 for (my $i = 0; $i < $count - 1; $i++) {
334 14 50       17 push @$csets, [@{$csets->[-1] || ['']}];
  14         70  
335             }
336 6         7 $count = '';
337 6         29 $state = 'character';
338             }
339 7         31 else { $count .= $c }
340             }
341            
342             # Character
343             else {
344 20 100       47 if ($c eq '[') { $state = 'character_class' }
  3 100       12  
345 6         25 elsif ($c eq '{') { $state = 'count' }
346 11         61 else { push @$csets, [$c] }
347             }
348             }
349            
350             # Add Charcter sets
351 5         13 $result->{$name} = $csets;
352             }
353            
354 1         8 return $result;
355             }
356              
357             # Version 0 method
358             sub validate {
359 177     177 0 20481 my ($self, $input, $rule) = @_;
360            
361             # Class
362 177         341 my $class = ref $self;
363            
364             # Validation rule
365 177   100     624 $rule ||= $self->rule;
366            
367             # Data filter
368 177         4625 my $filter = $self->data_filter;
369 177 100       1029 $input = $filter->($input) if $filter;
370            
371             # Check data
372 177 100       604 croak "First argument must be hash ref"
373             unless ref $input eq 'HASH';
374            
375             # Check rule
376 176 100       411 unless (ref $rule eq 'Validator::Custom::Rule') {
377 159 100       532 croak "Invalid rule structure" unless ref $rule eq 'ARRAY';
378             }
379            
380             # Result
381 175         587 my $result = Validator::Custom::Result->new;
382 175         1180 $result->{_error_infos} = {};
383            
384             # Save raw data
385 175         4003 $result->raw_data($input);
386            
387             # Error is stock?
388 175         4545 my $error_stock = $self->error_stock;
389            
390             # Valid keys
391 175         1098 my $valid_keys = {};
392            
393             # Error position
394 175         245 my $pos = 0;
395            
396             # Found missing parameters
397 175         248 my $found_missing_params = {};
398            
399             # Shared rule
400 175         3786 my $shared_rule = $self->shared_rule;
401 175 100       826 warn "Validator::Custom::shared_rule is DEPRECATED!"
402             if @$shared_rule;
403            
404 175 100       419 if (ref $rule eq 'Validator::Custom::Rule') {
405 17         360 $self->rule_obj($rule);
406             }
407             else {
408 158         391 my $rule_obj = $self->create_rule;
409 158         1614 $rule_obj->parse($rule, $shared_rule);
410 156         3281 $self->rule_obj($rule_obj);
411             }
412 173         4652 my $rule_obj = $self->rule_obj;
413              
414 173 50 33     1074 if ($rule_obj->{version} && $rule_obj->{version} == 1) {
415 0         0 croak "Can't call validate method(Validator::Custom). Use \$rule->validate(\$input) instead";
416             }
417            
418             # Process each key
419             OUTER_LOOP:
420 173         267 for (my $i = 0; $i < @{$rule_obj->rule}; $i++) {
  564         12193  
421            
422 407         10494 my $r = $rule_obj->rule->[$i];
423            
424             # Increment position
425 407         2215 $pos++;
426            
427             # Key, options, and constraints
428 407         650 my $key = $r->{key};
429 407         607 my $opts = $r->{option};
430 407   100     937 my $cinfos = $r->{constraints} || [];
431            
432             # Check constraints
433 407 100       1191 croak "Invalid rule structure"
434             unless ref $cinfos eq 'ARRAY';
435              
436             # Arrange key
437 405         500 my $result_key = $key;
438 405 100       1135 if (ref $key eq 'HASH') {
    50          
439 49         141 my $first_key = (keys %$key)[0];
440 49         91 $result_key = $first_key;
441 49         90 $key = $key->{$first_key};
442             }
443             elsif (defined $r->{name}) {
444 0         0 $result_key = $r->{name};
445             }
446            
447             # Real keys
448 405         441 my $keys;
449            
450 405 100       947 if (ref $key eq 'ARRAY') { $keys = $key }
  49 100       67  
451             elsif (ref $key eq 'Regexp') {
452 2         5 $keys = [];
453 2         6 for my $k (keys %$input) {
454 5 100       48 push @$keys, $k if $k =~ /$key/;
455             }
456             }
457 354         732 else { $keys = [$key] }
458            
459             # Check option
460 405 100       936 if (exists $opts->{optional}) {
461 1 50       4 if ($opts->{optional}) {
462 1         3 $opts->{require} = 0;
463             }
464 1         2 delete $opts->{optional};
465             }
466 405         1055 for my $oname (keys %$opts) {
467             croak qq{Option "$oname" of "$result_key" is invalid name}
468 25 50       79 unless $VALID_OPTIONS{$oname};
469             }
470            
471             # Default
472 405 100       860 if (exists $opts->{default}) {
473 8         20 $r->{default} = $opts->{default};
474             }
475            
476             # Is data copy?
477 405         496 my $copy = 1;
478 405 100       833 $copy = $opts->{copy} if exists $opts->{copy};
479            
480             # Check missing parameters
481 405 100       684 my $require = exists $opts->{require} ? $opts->{require} : 1;
482 405         410 my $found_missing_param;
483 405         8751 my $missing_params = $result->missing_params;
484 405         1707 for my $key (@$keys) {
485 551 100       1467 unless (exists $input->{$key}) {
486 16 100 100     79 if ($require && !exists $r->{default}) {
487             push @$missing_params, $key
488 10 100       30 unless $found_missing_params->{$key};
489 10         21 $found_missing_params->{$key}++;
490             }
491 16         33 $found_missing_param = 1;
492             }
493             }
494 405 100       798 if ($found_missing_param) {
495             $result->data->{$result_key} = ref $r->{default} eq 'CODE'
496             ? $r->{default}->($self) : $r->{default}
497 15 100 100     75 if exists $r->{default} && $copy;
    100          
498 15 100 100     98 next if $r->{default} || !$require;
499             }
500            
501             # Already valid
502 399 100       793 next if $valid_keys->{$result_key};
503            
504             # Validation
505             my $value = @$keys > 1
506 196         416 ? [map { $input->{$_} } @$keys]
507 396 100       1070 : $input->{$keys->[0]};
508            
509 396         686 for my $cinfo (@$cinfos) {
510            
511             # Constraint information
512 427         640 my $args = $cinfo->{args};
513 427         579 my $message = $cinfo->{message};
514            
515             # Constraint function
516 427         551 my $cfuncs = $cinfo->{funcs};
517            
518             # Is valid?
519 427         459 my $is_valid;
520            
521             # Data is array
522 427 100       754 if($cinfo->{each}) {
523            
524             # To array
525 21 100       63 $value = [$value] unless ref $value eq 'ARRAY';
526            
527             # Validation loop
528 21         54 for (my $k = 0; $k < @$value; $k++) {
529 37         58 my $input = $value->[$k];
530            
531             # Validation
532 37         90 for (my $j = 0; $j < @$cfuncs; $j++) {
533 43         60 my $cfunc = $cfuncs->[$j];
534 43         54 my $arg = $args->[$j];
535            
536             # Validate
537 43         83 my $cresult;
538             {
539 43         53 local $_ = Validator::Custom::Constraints->new(
  43         135  
540             constraints => $self->constraints
541             );
542 43         675 $cresult= $cfunc->($input, $arg, $self);
543             }
544            
545             # Constrint result
546 43         207 my $v;
547 43 100       110 if (ref $cresult eq 'ARRAY') {
    100          
548 18         32 ($is_valid, $v) = @$cresult;
549 18         34 $value->[$k] = $v;
550             }
551             elsif (ref $cresult eq 'HASH') {
552 4         6 $is_valid = $cresult->{result};
553 4 100       10 $message = $cresult->{message} unless $is_valid;
554 4 100       12 $value->[$k] = $cresult->{output} if exists $cresult->{output};
555             }
556 21         32 else { $is_valid = $cresult }
557            
558 43 100       125 last if $is_valid;
559             }
560            
561             # Validation error
562 37 100       120 last unless $is_valid;
563             }
564             }
565            
566             # Data is scalar
567             else {
568             # Validation
569 406         1037 for (my $k = 0; $k < @$cfuncs; $k++) {
570 418         574 my $cfunc = $cfuncs->[$k];
571 418         558 my $arg = $args->[$k];
572            
573 418         466 my $cresult;
574             {
575 418         428 local $_ = Validator::Custom::Constraints->new(
  418         1194  
576             constraints => $self->constraints
577             );
578 418         7213 $cresult = $cfunc->($value, $arg, $self);
579             }
580            
581 407 100       1532 if (ref $cresult eq 'ARRAY') {
    100          
582 95         118 my $v;
583 95         181 ($is_valid, $v) = @$cresult;
584 95 100       262 $value = $v if $is_valid;
585             }
586             elsif (ref $cresult eq 'HASH') {
587 2         4 $is_valid = $cresult->{result};
588 2 100       6 $message = $cresult->{message} unless $is_valid;
589 2 100 66     11 $value = $cresult->{output} if exists $cresult->{output} && $is_valid;
590             }
591 310         470 else { $is_valid = $cresult }
592            
593 407 100       1434 last if $is_valid;
594             }
595             }
596            
597             # Add error if it is invalid
598 416 100       984 unless ($is_valid) {
599 197 100       394 if (exists $r->{default}) {
600             # Set default value
601             $result->data->{$result_key} = ref $r->{default} eq 'CODE'
602             ? $r->{default}->($self)
603             : $r->{default}
604 6 100 66     127 if exists $r->{default} && $copy;
    100          
605 6         22 $valid_keys->{$result_key} = 1
606             }
607             else {
608             # Resist error info
609 191 100       479 $message = $opts->{message} unless defined $message;
610             $result->{_error_infos}->{$result_key} = {
611             message => $message,
612             position => $pos,
613             reason => $cinfo->{original_constraint},
614             original_key => $key
615 191 100       1072 } unless exists $result->{_error_infos}->{$result_key};
616            
617             # No Error stock
618 191 100       455 unless ($error_stock) {
619             # Check rest constraint
620 5         7 my $found;
621 5         12 for (my $k = $i + 1; $k < @{$rule_obj->rule}; $k++) {
  13         355  
622 8         266 my $r_next = $rule_obj->rule->[$k];
623 8         50 my $key_next = $r_next->{key};
624 8 50       21 $key_next = (keys %$key)[0] if ref $key eq 'HASH';
625 8 100       27 $found = 1 if $key_next eq $result_key;
626             }
627 5 100       51 last OUTER_LOOP unless $found;
628             }
629             }
630 194         690 next OUTER_LOOP;
631             }
632             }
633            
634             # Result data
635 188 100       4383 $result->data->{$result_key} = $value if $copy;
636            
637             # Key is valid
638 188         710 $valid_keys->{$result_key} = 1;
639            
640             # Remove invalid key
641 188         592 delete $result->{_error_infos}->{$key};
642             }
643            
644 160         1572 return $result;
645             }
646              
647             # Version 0 attributes
648             has 'data_filter';
649             has 'rule';
650             has 'rule_obj';
651             has error_stock => 1;
652              
653             # Version 0 method
654             sub js_fill_form_button {
655 0     0 0   my ($self, $rule) = @_;
656            
657 0           my $r = $self->_parse_random_string_rule($rule);
658            
659 0           require JSON;
660 0           my $r_json = JSON->new->encode($r);
661            
662 0           my $javascript = << "EOS";
663             (function () {
664              
665             var rule = $r_json;
666              
667             var create_random_value = function (rule, name) {
668             var patterns = rule[name];
669             if (patterns === undefined) {
670             return "";
671             }
672            
673             var value = "";
674             for (var i = 0; i < patterns.length; i++) {
675             var pattern = patterns[i];
676             var num = Math.floor(Math.random() * pattern.length);
677             value = value + pattern[num];
678             }
679            
680             return value;
681             };
682            
683             var addEvent = (function(){
684             if(document.addEventListener) {
685             return function(node,type,handler){
686             node.addEventListener(type,handler,false);
687             };
688             } else if (document.attachEvent) {
689             return function(node,type,handler){
690             node.attachEvent('on' + type, function(evt){
691             handler.call(node, evt);
692             });
693             };
694             }
695             })();
696            
697             var button = document.createElement("input");
698             button.setAttribute("type","button");
699             button.value = "Fill Form";
700             document.body.insertBefore(button, document.body.firstChild)
701              
702             addEvent(
703             button,
704             "click",
705             function () {
706            
707             var input_elems = document.getElementsByTagName('input');
708             var radio_names = {};
709             var checkbox_names = {};
710             for (var i = 0; i < input_elems.length; i++) {
711             var e = input_elems[i];
712              
713             var name = e.getAttribute("name");
714             var type = e.getAttribute("type");
715             if (type === "text" || type === "hidden" || type === "password") {
716             var value = create_random_value(rule, name);
717             e.value = value;
718             }
719             else if (type === "checkbox") {
720             e.checked = Math.floor(Math.random() * 2) ? true : false;
721             }
722             else if (type === "radio") {
723             radio_names[name] = 1;
724             }
725             }
726            
727             for (name in radio_names) {
728             var elems = document.getElementsByName(name);
729             var num = Math.floor(Math.random() * elems.length);
730             elems[num].checked = true;
731             }
732            
733             var textarea_elems = document.getElementsByTagName("textarea");
734             for (var i = 0; i < textarea_elems.length; i++) {
735             var e = textarea_elems[i];
736            
737             var name = e.getAttribute("name");
738             var value = create_random_value(rule, name);
739            
740             var text = document.createTextNode(value);
741            
742             if (e.firstChild) {
743             e.removeChild(e.firstChild);
744             }
745            
746             e.appendChild(text);
747             }
748            
749             var select_elems = document.getElementsByTagName("select");
750             for (var i = 0; i < select_elems.length; i++) {
751             var e = select_elems[i];
752             var options = e.options;
753             if (e.multiple) {
754             for (var k = 0; k < options.length; k++) {
755             options[k].selected = Math.floor(Math.random() * 2) ? true : false;
756             }
757             }
758             else {
759             var num = Math.floor(Math.random() * options.length);
760             e.selectedIndex = num;
761             }
762             }
763             }
764             );
765             })();
766             EOS
767              
768 0           return $javascript;
769             }
770              
771             1;
772              
773             =head1 NAME
774              
775             Validator::Custom - HTML form Validation, simple and good flexibility
776              
777             =head1 SYNOPSYS
778              
779             use Validator::Custom;
780             my $vc = Validator::Custom->new;
781            
782             # Input data
783             my $id = 1;
784             my $name = 'Ken Suzuki';
785             my $price = ' 19.23 ';
786             my $favorite = ['001', '002'];
787            
788             # Create validation object
789             my $validation = $vc->validation;
790            
791             # Check if id is integer
792             if (!$vc->check($id, 'int')) {
793             # Add failed message
794             $validation->add_failed(id => 'id must be integer');
795             }
796            
797             # Check if name has length
798             if (!(length $name)) {
799             $validation->add_failed(name => 'name must have length');
800             }
801             # Check if name's length is less than 30
802             elsif (!(length $name < 30)) {
803             $validation->add_failed(name => 'name is too long');
804             }
805            
806             # Filter price to remove left-rigth space
807             $price = $vc->filter($price, 'trim');
808              
809             # Check price is number and the digits of the decimal part is two or less than two
810             if (!$vc->check($price, 'number', {decimal_part_max => 2})) {
811             # Set default value if validation fail
812             $price = 20.25;
813             }
814            
815             # Filter each value of favorite using "trim" filtering function
816             $favorite = $vc->filter_each($favorite, 'trim');
817            
818             # Check if favorite has at least one values
819             if (@$favorite == 0) {
820             $validation->add_failed(favorite => 'favorite must be selected more than one');
821             }
822             # Check if favorite is one of the specified values
823             elsif (!($vc->check_each($favorite, 'in', ['001', '002', '003']))) {
824             $validation->add_failed(favorite => 'favorite is invalid');
825             }
826            
827             # Check if validation result is valid
828             if ($validation->is_valid) {
829             # ...
830             }
831             else {
832            
833             # Check what parameter fail
834             unless ($validation->is_valid('name')) {
835             # ...
836             }
837            
838             # Get all failed parameter names
839             my $failed = $validation->failed;
840              
841             # Get a failed parameter message
842             my $name_message = $validation->message('name');
843            
844             # Get all failed parameter messages
845             my $messages = $validation->messages;
846            
847             # Get all failed parameter names and the messages as hash reference
848             my $messages_h = $validation->messages_to_hash;
849             }
850            
851             =head1 DESCRIPTION
852              
853             L is a validator for HTML form
854             with simple and good flexibility.
855              
856             The features are the following ones.
857              
858             =over 4
859              
860             =item *
861              
862             Sevral checking functions are available by default, C,
863             C, C, C.
864              
865             =item *
866              
867             Several filtering functions are available by default, such as C, C.
868              
869             =item *
870              
871             You can add your own checking and filtering function.
872              
873             =item *
874              
875             Simple validation object is available.
876             You can add failed parameter names
877             and the messages keeping the order of validation.
878              
879             =back
880              
881             =head1 GUIDE
882              
883             =head2 1. Basic usage
884              
885             =head3 1. Create a new Validator::Custom object
886              
887             At first, create L object using C method.
888              
889             use Validator::Custom;
890             my $vc = Validator::Custom->new;
891              
892             =head3 2. Prepare input data for validation
893              
894             Next, prepare input data.
895              
896             my $id = 1;
897             my $name = 'Ken Suzuki';
898             my $price = ' 19.23 ';
899             my $favorite = ['001', '002'];
900              
901             =head3 3. Create a new validation object
902              
903             Next, create a new validation object using C method.
904              
905             my $validation = $vc->validation;
906              
907             This is L object
908             to store failed parameter names and the messages.
909              
910             =head3 4. Validate input data
911              
912             # Check if id is integer
913             if (!$vc->check($id, 'int')) {
914             # Add failed message
915             $validation->add_failed(id => 'id must be integer');
916             }
917              
918             You can use C checking function to check the value is integer.
919             C checking function is default one.
920             Any checking function is available through C method.
921              
922             When the check dosen't success, you can add failed parameter name and the message
923             using C method of L class.
924            
925             # Filter price to remove left-rigth space
926             $price = $vc->filter($price, 'trim');
927              
928             You can use C filtering function to trim left-rigth spaces.
929            
930             # Filter each value of favorite using "trim" filtering function
931             $favorite = $vc->filter_each($favorite, 'trim');
932              
933             You can use C method to filter each value of favorite.
934            
935             # Check if favorite has at least one values
936             if (@$favorite == 0) {
937             $validation->add_failed(favorite => 'favorite must be selected more than one');
938             }
939             # Check if favorite is one of the specified values
940             elsif (!($vc->check_each($favorite, 'in', ['001', '002', '003']))) {
941             $validation->add_failed(favorite => 'favorite is invalid');
942             }
943              
944             You can use C method to check each value of favorite.
945              
946             If you see default checks and filter,
947             see L and L.
948              
949             =head2 2. Manipulate validation object
950              
951             If you check all input data is valid, use C method.
952            
953             # Check if validation result is valid
954             if ($validation->is_valid) {
955             # Success
956             }
957             else {
958             # Failed
959             }
960              
961             If you can check a input data is valid, use C method with parameter name.
962            
963             # Check what parameter fail
964             unless ($validation->is_valid('name')) {
965             # ...
966             }
967              
968             You can get all failed parameter names using C method.
969              
970             # Get all failed parameter names
971             my $failed = $validation->failed;
972              
973             You can get a failed parameter message using C method.
974              
975             # Get a failed parameter message
976             my $name_message = $validation->message('name');
977              
978             You can get all failed parameter messages using C method.
979              
980             # Get all failed parameter messages
981             my $messages = $validation->messages;
982              
983             You can get all failed names and the messages as hash reference using C method.
984              
985             # Get all failed parameter names and the messages as hash reference
986             my $messages_h = $validation->messages_to_hash;
987              
988             See also L.
989              
990             =head2 3. Advanced tequnique
991              
992             =head3 1. Add checking function
993              
994             You can add your own checking function using C method if you need.
995              
996             $vc->add_check(
997             telephone => sub {
998             my ($vc, $value, $arg) = @_;
999            
1000             my $is_valid;
1001             if ($value =~ /^[\d-]+$/) {
1002             $is_valid = 1;
1003             }
1004             return $is_valid;
1005             }
1006             );
1007              
1008             Checking function receives three arguments,
1009             First argument is L object,
1010             Second argument is the value for checking,
1011             Third argument is the argument of checking function.
1012              
1013             Your Checking function must return true or false value.
1014              
1015             =head3 2. Add filtering function
1016              
1017             You can add your filtering function by C method if you need.
1018              
1019             $vc->add_filter(
1020             to_upper_case => sub {
1021             my ($vc, $value, $arg) = @_;
1022            
1023             my $new_$value = uc $value;
1024            
1025             return $new_value;
1026             }
1027             );
1028              
1029             Filtering function receives three arguments,
1030             First argument is L object,
1031             Second argument is the value for filtering.
1032             Third argument is the argument of filtering function.
1033              
1034             Your filtering function must return the result of filtering.
1035              
1036             =head1 CHECKING FUNCTIONS
1037              
1038             L have the following default checking functions.
1039             You can call any checking function by C method.
1040              
1041             =head2 int
1042              
1043             my $value = 19;
1044             my $is_valid = $vc->check($value, 'int');
1045              
1046             Check if the value is integer value.
1047              
1048             Example of valid values:
1049              
1050             "-10"
1051             "234"
1052              
1053             Example of invalid values:
1054              
1055             "10.11"
1056             "abc"
1057              
1058             If you also need to check the range of value, you can write the following way.
1059              
1060             my $is_valid = $vc->check($value, 'int') && $value > 0;
1061              
1062             =head2 number
1063            
1064             my $is_valid = $vc->check($value, 'number');
1065              
1066             Check if the value is number.
1067             Number means integer or decimal.
1068              
1069             Example of valid values:
1070              
1071             '1'
1072             '123'
1073             '123.456'
1074             '-1'
1075             '-100'
1076             '-100.789'
1077              
1078             Example of invalid values:
1079              
1080             'a';
1081             '1.a';
1082             'a.1';
1083              
1084             You can also specify decimal part max digits using C option.
1085              
1086             my $is_valid = $vc->check($value, 'number', {decimal_part_max => 3});
1087              
1088             Example of valid values:
1089              
1090             '123'
1091             '123.456'
1092             '-100.789'
1093              
1094             Example of invalid values:
1095              
1096             '123.4567'
1097             '-100.7891'
1098              
1099             =head2 ascii_graphic
1100            
1101             my $is_valid = $vc->check($value, 'ascii');
1102            
1103             Check if the value is Ascii graphic characters(hex 21-7e).
1104             Generally, C function is used to
1105             check the characters of a password.
1106              
1107             Example of valid values:
1108              
1109             "Ken!@-"
1110              
1111             Example of invalid values:
1112            
1113             "aa aa"
1114             "\taaa"
1115              
1116             =head2 in
1117            
1118             my $value = '001';
1119             my $is_valid = $vc->check($value, 'in', ['001', '002', '003']);
1120              
1121             Check if the value is one of the given values.
1122              
1123             Example of valid values:
1124              
1125             '001'
1126             '002'
1127             '003'
1128              
1129             Example of invalid values:
1130              
1131             '004'
1132             '005'
1133              
1134             =head1 FILTERING FUNCTIONS
1135              
1136             L have the following default filtering functions.
1137             You can call any filtering function using C method.
1138              
1139             =head2 trim
1140              
1141             my $new_value = $vc->filter($value, 'trim');
1142              
1143             Trim leading and trailing white space.
1144             Note that trim function remove unicode space character, not only C<[ \t\n\r\f]>.
1145              
1146             Filtering example:
1147              
1148             Input : '  Ken '
1149             Output: 'Ken'
1150              
1151             =head2 remove_blank
1152              
1153             my $new_values = $vc->filter($values, 'remove_blank');
1154              
1155             Remove blank character and undefined value from array reference.
1156              
1157             Filtering example:
1158              
1159             Input : [1, 2, '', undef, 4]
1160             Output: [1, 2, 4]
1161              
1162             =head1 METHODS
1163              
1164             L inherits all methods from L
1165             and implements the following new ones.
1166              
1167             =head2 new
1168              
1169             my $vc = Validator::Custom->new;
1170              
1171             Create a new L object.
1172              
1173             =head2 add_check
1174              
1175             $vc->add_check(int => sub { ... });
1176              
1177             Add a checking function.
1178              
1179             Example:
1180            
1181             $vc->add_check(
1182             int => sub {
1183             my ($vc, $value, $arg) = @_;
1184            
1185             my $is_valid = $value =~ /^\-?[\d]+$/;
1186            
1187             return $is_valid;
1188             }
1189             );
1190              
1191             Checking function receives three arguments,
1192             First argument is L object,
1193             Second argument is the value for checking,
1194             Third argument is the argument of checking function.
1195              
1196             Your Checking function must return true or false value.
1197              
1198             =head2 add_filter
1199              
1200             $vc->add_filter(trim => sub { ... });
1201              
1202             Add a filtering function.
1203              
1204             Example:
1205              
1206             $vc->add_filter(
1207             trim => sub {
1208             my ($vc, $value, $arg) = @_;
1209            
1210             $value =~ s/^\s+//;
1211             $value =~ s/\s+$//;
1212            
1213             return $value;
1214             }
1215             );
1216              
1217             =head2 check
1218              
1219             my $is_valid = $vc->check($value, 'int');
1220             my $is_valid = $vc->check($value, 'int', $arg);
1221              
1222             Execute a checking function.
1223              
1224             First argument is the value for checking.
1225             Second argument is the name of the checking funcion.
1226             Third argument is the argument of the checking function.
1227              
1228             =head2 check_each
1229              
1230             my $is_valid = $vc->check_each($values, 'int');
1231             my $is_valid = $vc->check_each($values, 'int', $arg);
1232              
1233             Execute a checking function to all elements of array reference.
1234             If more than one element is invalid, C method return false.
1235              
1236             First argument is the values for checking, which must be array reference.
1237             Second argument is the name of the checking funcion.
1238             Third argument is the argument of the checking function.
1239              
1240             =head2 filter
1241              
1242             my $new_value = $vc->filter($value, 'trim');
1243             my $new_value = $vc->filter($value, 'trim', $arg);
1244              
1245             Execute a filtering function.
1246              
1247             First argument is the value for filtering.
1248             Second argument is the name of the filtering funcion.
1249             Third argument is the argument of the filtering function.
1250              
1251             =head2 filter_each
1252              
1253             my $new_values = $vc->filter_each($values, 'trim');
1254             my $new_values = $vc->filter_each($values, 'trim', $arg);
1255              
1256             Execute a filtering function to all elements of array reference.
1257              
1258             First argument is the values for filtering, which must be array reference.
1259             Second argument is the name of the filtering funcion.
1260             Third argument is the argument of the filtering function.
1261              
1262             =head1 EXAMPLES
1263              
1264             Show you some examples to do some validation.
1265              
1266             Password checking:
1267            
1268             my $password = 'abc';
1269             my $password2 = 'abc';
1270            
1271             my $validation = $vc->validation;
1272            
1273             if (!length $password) {
1274             $validation->add_failed(password => 'password must have length');
1275             }
1276             elsif (!$vc->check($password, 'ascii')) {
1277             $validation->add_failed(password => 'password contains invalid characters');
1278             }
1279             elsif ($password ne $password2) {
1280             $validation->add_failed(password => "two passwords don't match");
1281             }
1282            
1283             if ($validation->is_valid) {
1284             # ...
1285             }
1286             else {
1287             # ...
1288             }
1289              
1290             Check box, selected at least 1, one of the given values:
1291              
1292             my $favorite = ['001', '002'];
1293              
1294             my $validation = $vc->validation;
1295            
1296             if (@$favorite == 0) {
1297             $validation->add_failed(favorite => 'favorite must be selected at least 1');
1298             }
1299             elsif (!$vc->check($favorite, 'in', ['001', '002', '003'])) {
1300             $validation->add_failed(favorite => 'favorite have invalid value');
1301             }
1302            
1303             if ($validtion->is_valid) {
1304             # ...
1305             }
1306             else {
1307             # ...
1308             }
1309              
1310             Convert date string to L object.
1311              
1312             my $date = '2014/05/16';
1313            
1314             my $validation = $vc->validation;
1315            
1316             my $date_tp;
1317             if (!length $date) {
1318             $validation->add_failed(date => 'date must have length');
1319             }
1320             else {
1321             eval { $date_tp = Time::Piece->strptime($date, '%Y/%m/%d') };
1322             if (!$date_tp) {
1323             $validation->add_failed(date => 'date value is invalid');
1324             }
1325             }
1326              
1327             Convert datetime string to L object.
1328              
1329             my $datetime = '2014/05/16 12:30:40';
1330            
1331             my $validation = $vc->validation;
1332            
1333             my $datetime_tp;
1334             if (!length $datetime) {
1335             $validation->add_failed(datetime => 'datetime must have length');
1336             }
1337             else {
1338             eval { $datetime_tp = Time::Piece->strptime($datetime, '%Y/%m/%d %H:%M:%S') };
1339             if (!$datetime_tp) {
1340             $validation->add_failed(datetime => 'datetime value is invalid');
1341             }
1342             }
1343              
1344             =head1 FAQ
1345              
1346             =head2 I use Validator::Custom 0.xx yet. I want to see documentation of Version 0.xx.
1347              
1348             See L.
1349             This is complete document for L version 0.xx.
1350              
1351             =head2 What point I take care of in Version 1.xx.
1352              
1353             =over 4
1354              
1355             =item *
1356              
1357             C constraint function is renamed to C checking function.
1358              
1359             =item *
1360              
1361             C filtering function becomes triming unicode space characters, not only C<[ \t\n\r\f]>.
1362              
1363             =item *
1364              
1365             C constraint is renamed to C checking function and simplified.
1366              
1367             =item *
1368              
1369             C checking function dosen't exist.
1370             About alternative way, see the topic "Convert date string to Time::Piece object" in "EXAMPLES".
1371              
1372             =item *
1373              
1374             C checking function dosen't exists.
1375             About alternative way, see the topic "Convert datetime string to Time::Piece object" in "EXAMPLES".
1376              
1377             =back
1378              
1379             =head2 How to create the corresponding checking functions in Version 0.xx constraint functions.
1380              
1381             I show some examples.
1382              
1383             space
1384              
1385             $vc->add_check(space => sub {
1386             my ($vc, $value, $arg) = @_;
1387             return defined $value && $value =~ '^[ \t\n\r\f]*$' ? 1 : 0;
1388             });
1389              
1390             http_url
1391              
1392             $vc->add_check(http_url => sub {
1393             my ($vc, $value, $arg) = @_;
1394             return defined $value && $value =~ /^s?https?:\/\/[-_.!~*'()a-zA-Z0-9;\/?:\@&=+\$,%#]+$/ ? 1 : 0;
1395             });
1396              
1397             decimal
1398              
1399             $vc->add_check(decimal => sub {
1400             my ($vc, $value, $arg) = @_;
1401              
1402             return undef unless defined $value;
1403            
1404             my $digits_tmp = $arg;
1405            
1406             # Digit
1407             my $digits;
1408             if (defined $digits_tmp) {
1409             if (ref $digits_tmp eq 'ARRAY') {
1410             $digits = $digits_tmp;
1411             }
1412             else {
1413             $digits = [$digits_tmp, undef];
1414             }
1415             }
1416             else {
1417             $digits = [undef, undef];
1418             }
1419            
1420             # Regex
1421             my $re;
1422             if (defined $digits->[0] && defined $digits->[1]) {
1423             $re = qr/^[0-9]{1,$digits->[0]}(\.[0-9]{0,$digits->[1]})?$/;
1424             }
1425             elsif (defined $digits->[0]) {
1426             $re = qr/^[0-9]{1,$digits->[0]}(\.[0-9]*)?$/;
1427             }
1428             elsif (defined $digits->[1]) {
1429             $re = qr/^[0-9]+(\.[0-9]{0,$digits->[1]})?$/;
1430             }
1431             else {
1432             $re = qr/^[0-9]+(\.[0-9]*)?$/;
1433             }
1434            
1435             # Check value
1436             if ($value =~ /$re/) {
1437             return 1;
1438             }
1439             else {
1440             return 0;
1441             }
1442             }
1443              
1444             =head2 How to create the corresponding filtering functions in Version 0.xx constraint functions.
1445              
1446             I show some examples.
1447              
1448             trim_collapse
1449              
1450             $vc->add_filter(trim_collapse => sub {
1451             my ($vc, $value, $arg) = @_;
1452            
1453             return undef unless defined $value;
1454            
1455             $value =~ s/[ \t\n\r\f]+/ /g;
1456             $value =~ s/^[ \t\n\r\f]*(.*?)[ \t\n\r\f]*$/$1/ms;
1457              
1458             return $value;
1459             });
1460              
1461             trim_lead
1462              
1463             $vc->add_filter(trim_lead => sub {
1464             my ($vc, $value, $arg) = @_;
1465            
1466             return undef unless defined $value;
1467              
1468             $value =~ s/^[ \t\n\r\f]+(.*)$/$1/ms;
1469              
1470             return $value;
1471             });
1472              
1473             trim_trail
1474              
1475             $vc->add_filter(trim_trail => sub {
1476             my ($vc, $value, $arg) = @_;
1477            
1478             return undef unless defined $value;
1479              
1480             $value =~ s/^(.*?)[ \t\n\r\f]+$/$1/ms;
1481              
1482             return $value;
1483             });
1484              
1485             trim_uni
1486              
1487             $vc->add_filter(trim_uni => sub {
1488             my ($vc, $value, $arg) = @_;
1489            
1490             return undef unless defined $value;
1491              
1492             $value =~ s/^\s*(.*?)\s*$/$1/ms;
1493              
1494             return $value;
1495             });
1496              
1497             trim_uni_collapse
1498              
1499             $vc->add_filter(trim_uni_collapse => sub {
1500             my ($vc, $value, $arg) = @_;
1501              
1502             return undef unless defined $value;
1503            
1504             $value =~ s/\s+/ /g;
1505             $value =~ s/^\s*(.*?)\s*$/$1/ms;
1506              
1507             return $value;
1508             });
1509              
1510             trim_uni_lead
1511              
1512             $vc->add_filter(trim_uni_lead => sub {
1513             my ($vc, $value, $arg) = @_;
1514            
1515             return undef unless defined $value;
1516            
1517             $value =~ s/^\s+(.*)$/$1/ms;
1518            
1519             return $value;
1520             });
1521              
1522             trim_uni_trail
1523              
1524             $vc->add_filter(trim_uni_trail => sub {
1525             my ($vc, $value, $arg) = @_;
1526            
1527             return undef unless defined $value;
1528              
1529             $value =~ s/^(.*?)\s+$/$1/ms;
1530              
1531             return $value;
1532             });
1533              
1534             =head1 AUTHOR
1535              
1536             Yuki Kimoto, C<< >>
1537              
1538             L
1539              
1540             =head1 COPYRIGHT & LICENCE
1541              
1542             Copyright 2009-2015 Yuki Kimoto, all rights reserved.
1543              
1544             This program is free software; you can redistribute it and/or modify it
1545             under the same terms as Perl itself.
1546              
1547             =cut