File Coverage

blib/lib/CGI/Test/Form/Group.pm
Criterion Covered Total %
statement 37 44 84.0
branch 8 10 80.0
condition 2 6 33.3
subroutine 8 8 100.0
pod 4 5 80.0
total 59 73 80.8


line stmt bran cond sub pod time code
1             package CGI::Test::Form::Group;
2 14     14   49 use strict;
  14         15  
  14         417  
3 14     14   88 use warnings;
  14         10  
  14         4408  
4             ################################################################
5             # $Id: Group.pm 411 2011-09-26 11:19:30Z nohuhu@nohuhu.org $
6             # $Name: cgi-test_0-104_t1 $
7             ################################################################
8             # Copyright (c) 2001, Raphael Manfredi
9             #
10             # You may redistribute only under the terms of the Artistic License,
11             # as specified in the README file that comes with the distribution.
12              
13             #
14             # This class records names of grouped objects (radio buttons, checkboxes),
15             # and which buttons belong to some named group.
16             #
17              
18             #
19             # ->new
20             #
21             # Creation routine
22             #
23             # From a listref of box widgets, build a hash table indexed by group name
24             # and listing all the buttons belonging to the named group. Each box is
25             # also made aware of this object.
26             #
27             sub new
28             {
29 32     32 0 63 my $this = bless {}, shift; # The object is the hash table we use
30 32         38 my ($rlist) = @_;
31              
32             #
33             # Create map: "group name" => [list of buttons in group]
34             #
35              
36 32         49 foreach my $b (@$rlist)
37             {
38 128         275 my $gname = $b->name;
39 128 100       283 $this->{$gname} = [] unless exists $this->{$gname};
40 128         82 push @{$this->{$gname}}, $b;
  128         122  
41 128         334 $b->set_group($this);
42             }
43              
44 32 100       103 $this->_validate_radios() if $rlist->[ 0 ]->is_radio();
45              
46 32         63 return $this;
47             }
48              
49             #
50             # Attribute access
51             #
52              
53             sub names
54             {
55 18     18 1 21 my $this = shift;
56 18         17 return keys %{$this};
  18         53  
57             }
58              
59             #
60             # ->widgets_in
61             #
62             # Returns list of widgets held within named group, empty if none.
63             #
64             sub widgets_in
65             {
66 31     31 1 326 my $this = shift;
67 31         38 my ($gname) = @_;
68              
69 31   100     80 my $list = $this->{$gname} || [];
70 31         72 return @$list;
71             }
72              
73             #
74             # ->widget_count
75             #
76             # Returns amount of widgets held within named group, 0 if none.
77             #
78             sub widget_count
79             {
80 4     4 1 689 my $this = shift;
81 4         5 my ($gname) = @_;
82              
83 4         4 my $list = $this->{$gname};
84 4 100       14 return ref $list ? scalar(@$list) : 0;
85             }
86              
87             #
88             # ->is_groupname
89             #
90             # Check whether name is that of a known widget group.
91             #
92             sub is_groupname
93             {
94 2     2 1 849 my $this = shift;
95 2         2 my ($gname) = @_;
96              
97 2         9 return exists $this->{$gname};
98             }
99              
100             #
101             # ->_validate_radios
102             #
103             # When groupping radio buttons, make sure there is at least one such
104             # button selected, otherwise mark the first as selected. Also ensure
105             # exactly one radio is selected, or unselect all extra.
106             #
107             sub _validate_radios
108             {
109 16     16   20 my $this = shift;
110              
111 16         36 foreach my $gname ($this->names)
112             {
113 16         37 my @checked = grep {$_->is_checked} $this->widgets_in($gname);
  48         130  
114 16         20 my $checked = @checked;
115              
116 16 50       68 if ($checked > 1)
    50          
117             {
118 0         0 my $first = shift @checked;
119              
120             #
121             # NB: we're not calling uncheck() nor set_is_checked() to fix
122             # incorrectly configured radio buttons, since it is normally an
123             # invalid operation. We're resettting the attribute directly.
124             #
125              
126 0   0     0 warn
127             "found %d checked %ss for '%s', keeping first (tag \"%s\")",
128             $checked, $first->gui_type, $gname, ($first->value || "");
129              
130 0         0 foreach my $b (@checked)
131             {
132 0         0 $b->{is_checked} = 0; # Direct access
133             }
134             }
135             elsif ($checked == 0)
136             {
137 0         0 my $first = $this->{$gname}->[ 0 ];
138 0   0     0 warn "no checked %ss for '%s', checking first (tag \"%s\")",
139             $first->gui_type, $gname, ($first->value || "");
140 0         0 $first->{is_checked} = 1; # Direct access
141             }
142              
143             }
144              
145 16         29 return;
146             }
147              
148             1;
149              
150             =head1 NAME
151              
152             CGI::Test::Form::Group - Records groups of box-type widgets
153              
154             =head1 SYNOPSIS
155              
156             # $form is a CGI::Test::Form object
157              
158             use CGI::Test;
159              
160             my $rgroup = $form->radio_groups;
161             ok 1, defined $rgroup;
162              
163             my @title = $rgroup->widgets_in("title");
164             my ($mister) = grep { $_->value eq "Mr" } @title;
165             ok 2, $mister->is_checked;
166              
167             =head1 DESCRIPTION
168              
169             This class is a container for box-type widgets, i.e. radio buttons and
170             checkboxes, which may be groupped by name.
171              
172             It can be queried to easily retrieve widgets belonging to a group, or to
173             get all the group names.
174              
175             It is also used internally by C to keep track of associated
176             radio buttons, so that checking one automatically unchecks the others in the
177             same group.
178              
179             =head1 INTERFACE
180              
181             The following features are available:
182              
183             =over 4
184              
185             =item C I
186              
187             Checks whether I is the name of a group.
188              
189             =item C
190              
191             Returns a list of group names, in random order.
192              
193             =item C I
194              
195             Returns amount of widgets held in I, 0 if none.
196              
197             =item C I
198              
199             Returns a list of all the widgets in the given I. If the
200             name is not a valid group name, the list will be empty.
201              
202             =back
203              
204             =head1 AUTHORS
205              
206             The original author is Raphael Manfredi.
207              
208             Steven Hilton was long time maintainer of this module.
209              
210             Current maintainer is Alexander Tokarev Ftokarev@cpan.orgE>.
211              
212             =head1 SEE ALSO
213              
214             CGI::Test::Form(3), CGI::Test::Form::Widget::Box(3).
215              
216             =cut
217