File Coverage

blib/lib/Form/Factory/Feature/Control/MatchAvailableChoices.pm
Criterion Covered Total %
statement 17 25 68.0
branch 4 10 40.0
condition n/a
subroutine 4 4 100.0
pod 2 2 100.0
total 27 41 65.8


line stmt bran cond sub pod time code
1             package Form::Factory::Feature::Control::MatchAvailableChoices;
2             $Form::Factory::Feature::Control::MatchAvailableChoices::VERSION = '0.022';
3 1     1   559 use Moose;
  1         2  
  1         6  
4              
5             with qw(
6             Form::Factory::Feature
7             Form::Factory::Feature::Role::Check
8             Form::Factory::Feature::Role::Control
9             Form::Factory::Feature::Role::CustomControlMessage
10             );
11              
12 1     1   5089 use Carp ();
  1         3  
  1         221  
13              
14             # ABSTRACT: Check for choice availability
15              
16              
17             sub check_control {
18 5     5 1 10 my ($self, $control) = @_;
19              
20 5 50       23 Carp::croak("the match_available_options feature only works for controls that have available choices, not $control")
21             unless $control->does('Form::Factory::Control::Role::AvailableChoices');
22             }
23              
24              
25             sub check {
26 1     1 1 2 my $self = shift;
27 1         36 my $control = $self->control;
28              
29 3         81 my %available_values = map { $_->value => 1 }
  1         29  
30 1         3 @{ $self->control->available_choices };
31              
32             # Deal with list valued controls
33 1 50       4 if ($control->does('Form::Factory::Control::Role::ListValue')) {
34 0         0 my $values = $control->current_values;
35 0         0 VALUE: for my $value (@$values) {
36 0 0       0 unless ($available_values{ $value }) {
37 0         0 $self->control_error('one of the values given for %s is not in the list of available choices');
38 0         0 $self->result->is_valid(0);
39 0         0 last VALUE;
40             }
41             }
42             }
43              
44             # Deal with scalar valued controls
45             else {
46 1         30 my $value = $control->current_value;
47 1 50       4 unless ($available_values{ $value }) {
48 0         0 $self->control_error('the given value for %s is not one of the available choices');
49 0         0 $self->is_valid(0);
50             }
51             }
52              
53             # If not already validated
54 1 50       29 $self->result->is_valid(1) unless $self->result->is_validated;
55             }
56              
57             __PACKAGE__->meta->make_immutable;
58              
59             __END__
60              
61             =pod
62              
63             =encoding UTF-8
64              
65             =head1 NAME
66              
67             Form::Factory::Feature::Control::MatchAvailableChoices - Check for choice availability
68              
69             =head1 VERSION
70              
71             version 0.022
72              
73             =head1 SYNOPSIS
74              
75             has_control time_zone => (
76             control => 'select_one',
77             options => {
78             available_choices => [
79             map { Form::Factory::Control::Choice->new($_) } qw( PST MST CST EST )
80             ],
81             },
82             features => {
83             match_available_choices => 1,
84             },
85             );
86              
87             =head1 DESCRIPTION
88              
89             Verifies that the value set for the control matches one of the available choices.
90              
91             =head1 METHODS
92              
93             =head2 check_control
94              
95             Verifies that the control does the L<Form::Factory::Control::Role::AvailableChoices>.
96              
97             =head2 check
98              
99             Verifies that the value or values set match one or more of the available values.
100              
101             =head1 AUTHOR
102              
103             Andrew Sterling Hanenkamp <hanenkamp@cpan.org>
104              
105             =head1 COPYRIGHT AND LICENSE
106              
107             This software is copyright (c) 2015 by Qubling Software LLC.
108              
109             This is free software; you can redistribute it and/or modify it under
110             the same terms as the Perl 5 programming language system itself.
111              
112             =cut