File Coverage

blib/lib/HTML/Widget/Plugin/Radio.pm
Criterion Covered Total %
statement 50 51 98.0
branch 23 26 88.4
condition 7 12 58.3
subroutine 9 9 100.0
pod 3 3 100.0
total 92 101 91.0


line stmt bran cond sub pod time code
1 15     15   7331 use strict;
  15         24  
  15         482  
2 15     15   65 use warnings;
  15         16  
  15         636  
3             package HTML::Widget::Plugin::Radio;
4             # ABSTRACT: a widget for sets of radio buttons
5             $HTML::Widget::Plugin::Radio::VERSION = '0.203';
6 15     15   63 use parent 'HTML::Widget::Plugin';
  15         16  
  15         65  
7              
8             #pod =head1 SYNOPSIS
9             #pod
10             #pod $widget_factory->radio({
11             #pod name => 'radio',
12             #pod value => 'value_1',
13             #pod options => [
14             #pod [ value_1 => "Description 1" ],
15             #pod [ value_2 => "Description 2" ],
16             #pod [ value_2 => "Description 2", 'optional-elem-id' ],
17             #pod ],
18             #pod });
19             #pod
20             #pod This will emit roughly:
21             #pod
22             #pod
23             #pod checked='checked'>
24             #pod
25             #pod
26             #pod
27             #pod
28             #pod
29             #pod
30             #pod id='optional-elem-id'>
31             #pod
32             #pod
33             #pod =head1 DESCRIPTION
34             #pod
35             #pod This plugin provides a radio button-set widget
36             #pod
37             #pod =cut
38              
39 15     15   831 use HTML::Element;
  15         76  
  15         127  
40              
41             #pod =head1 METHODS
42             #pod
43             #pod =head2 C< provided_widgets >
44             #pod
45             #pod This plugin provides the following widgets: radio
46             #pod
47             #pod =cut
48              
49 16     16 1 36 sub provided_widgets { qw(radio) }
50              
51             #pod =head2 C< radio >
52             #pod
53             #pod This method returns a set of radio buttons.
54             #pod
55             #pod In addition to the generic L attributes, the following
56             #pod are valid arguments:
57             #pod
58             #pod =over
59             #pod
60             #pod =item disabled
61             #pod
62             #pod If true, this option indicates that the select widget can't be changed by the
63             #pod user.
64             #pod
65             #pod =item ignore_invalid
66             #pod
67             #pod If this is given and true, an invalid value is ignored instead of throwing an
68             #pod exception.
69             #pod
70             #pod =item options
71             #pod
72             #pod This option must be a reference to an array of allowed values, each of which
73             #pod will get its own radio button.
74             #pod
75             #pod =item value
76             #pod
77             #pod If this argument is given, the option with this value will be pre-selected in
78             #pod the widget's initial state.
79             #pod
80             #pod An exception will be thrown if more or less than one of the provided options
81             #pod has this value.
82             #pod
83             #pod =back
84             #pod
85             #pod =cut
86              
87 16     16   40 sub _attribute_args { qw(disabled) }
88 32     32   62 sub _boolean_args { qw(disabled) }
89              
90             sub radio {
91 8     8 1 8 my ($self, $factory, $arg) = @_;
92              
93 8         8 my @widgets;
94              
95 8 100       18 $self->validate_value($arg->{value}, $arg->{options})
96             unless $arg->{ignore_invalid};
97              
98 6 100       17 if (my $id_attr = delete $arg->{attr}{id}) {
99 3         423 Carp::cluck "id may not be used as a widget-level attribute for radio";
100 3 100       279 $arg->{attr}{name} = $id_attr if not defined $arg->{attr}{name};
101             }
102              
103 6         6 for my $option (@{ $arg->{options} }) {
  6         10  
104 18 100       33 my ($value, $text, $id) = (ref $option) ? (@$option) : (($option) x 2);
105              
106 18         35 my $widget = HTML::Element->new('input', type => 'radio');
107 18         313 $widget->attr($_ => $arg->{attr}{$_}) for keys %{ $arg->{attr} };
  18         56  
108              
109 18 100 66     189 $id = "$arg->{attr}{name}-$value"
110             if ! defined $id and defined $arg->{attr}{name};
111              
112 18 50       43 $widget->attr(id => $id) if defined $id;
113              
114 18         126 $widget->attr(value => $value);
115              
116 18 100 100     152 $widget->attr(checked => 'checked')
117             if defined $arg->{value} and $arg->{value} eq $value;
118              
119 18         37 push @widgets, $widget;
120              
121 18         31 my $text_elem = HTML::Element->new('~literal', text => $text);
122 18 50 33     301 if (! $arg->{parts} and defined $id) {
123 18         30 my $label = HTML::Element->new(label => (for => $id));
124 18         292 $label->push_content($text_elem);
125 18         200 push @widgets, $label;
126             } else {
127 0         0 push @widgets, $text_elem;
128             }
129             }
130              
131             # XXX document
132 6 50 33     12 return @widgets if wantarray and $arg->{parts};
133              
134 6         9 return join q{}, map { $_->as_XML } @widgets;
  36         4320  
135             }
136              
137             #pod =head2 C< validate_value >
138             #pod
139             #pod This method checks whether the given value option is valid. See C>
140             #pod for an explanation of its default rules.
141             #pod
142             #pod =cut
143              
144             sub validate_value {
145 7     7 1 7 my ($class, $value, $options) = @_;
146              
147 7 100       9 my @options = map { ref $_ ? $_->[0] : $_ } @$options;
  21         36  
148              
149 7 100       15 if (defined $value) {
150 6         8 my $matches = grep { $value eq $_ } @options;
  18         20  
151              
152 6 100       16 if (not $matches) {
    100          
153 3         125 Carp::croak "provided value '$value' not in given options: "
154 1         3 . join(q{ }, map { "'$_'" } @options);
155             } elsif ($matches > 1) {
156 1         89 Carp::croak "provided value '$value' matches more than one option";
157             }
158             }
159             }
160              
161             1;
162              
163             __END__