File Coverage

blib/lib/HTML/Widget/Constraint/CallbackOnce.pm
Criterion Covered Total %
statement 23 24 95.8
branch 3 4 75.0
condition 1 2 50.0
subroutine 5 6 83.3
pod 2 2 100.0
total 34 38 89.4


line stmt bran cond sub pod time code
1             package HTML::Widget::Constraint::CallbackOnce;
2              
3 88     88   71440 use warnings;
  88         224  
  88         2758  
4 88     88   477 use strict;
  88         191  
  88         2612  
5 88     88   469 use base 'HTML::Widget::Constraint';
  88         176  
  88         33383  
6              
7             __PACKAGE__->mk_accessors(qw/callback/);
8              
9             *cb = \&callback;
10              
11             =head1 NAME
12              
13             HTML::Widget::Constraint::CallbackOnce - CallbackOnce Constraint
14              
15             =head1 SYNOPSIS
16              
17             my $c = $widget->constraint( 'CallbackOnce', 'foo', 'bar' )->callback(
18             sub {
19             my ($foo, $bar) = @_;
20             return 1 if $foo == $bar * 2;
21             });
22              
23             =head1 DESCRIPTION
24              
25             A callback constraint which will only be run once for each call of
26             L.
27              
28             =head1 METHODS
29              
30             =head2 callback
31              
32             =head2 cb
33              
34             Arguments: \&callback
35              
36             Requires a subroutine reference used for validation, which will be passed
37             a list of values corresponding to the constraint names.
38              
39             L is provided as an alias to L.
40              
41             =head2 process
42              
43             Overrides L to ensure L is
44             only called once for each call of L.
45              
46             =cut
47              
48             sub process {
49 7     7 1 13 my ( $self, $w, $params ) = @_;
50              
51 7         12 my @names = @{ $self->names };
  7         37  
52 7         53 my @values = map { $params->{$_} } @names;
  15         50  
53              
54 7         26 my $result = $self->validate(@values);
55              
56 7         46 my $results = [];
57              
58 7 50       23 if ( $self->not ? $result : !$result ) {
    100          
59 4         34 for my $name (@names) {
60 8         82 push @$results, HTML::Widget::Error->new(
61             { name => $name, message => $self->mk_message } );
62             }
63             }
64              
65 7         109 return $results;
66             }
67              
68             =head2 render_errors
69              
70             Arguments: @names
71              
72             A list of element names for which an error should be displayed.
73              
74             If this is not set, the default behaviour is for the error to be displayed
75             for all of the Constraint's named elements.
76              
77             =head2 validate
78              
79             perform the actual validation.
80              
81             =cut
82              
83             sub validate {
84 7     7 1 17 my ( $self, @values ) = @_;
85              
86 7   50 0   24 my $callback = $self->callback || sub {1};
  0            
87              
88 7         72 return $callback->(@values);
89             }
90              
91             =head1 AUTHOR
92              
93             Carl Franks C
94              
95             =head1 LICENSE
96              
97             This library is free software, you can redistribute it and/or modify it under
98             the same terms as Perl itself.
99              
100             =cut
101              
102             1;