File Coverage

blib/lib/UI/Various/Radio.pm
Criterion Covered Total %
statement 68 68 100.0
branch 14 14 100.0
condition 9 9 100.0
subroutine 15 15 100.0
pod 3 3 100.0
total 109 109 100.0


line stmt bran cond sub pod time code
1             package UI::Various::Radio;
2              
3             # Author, Copyright and License: see end of file
4              
5             =head1 NAME
6              
7             UI::Various::Radio - general radio button widget of L
8              
9             =head1 SYNOPSIS
10              
11             use UI::Various;
12             my $main = UI::Various::main();
13             my $variable = 0;
14             $main->window(...
15             UI::Various::Radio->new(buttons => {1 => 'One',
16             2 => 'Two',
17             3 => 'Three'}),
18             ...);
19             $main->mainloop();
20              
21             =head1 ABSTRACT
22              
23             This module defines the general radio button widget of an application using
24             L. The radio buttons are vertically aligned.
25              
26             Note that the limitation to the vertical orientation comes from
27             L.
28              
29             =head1 DESCRIPTION
30              
31             Besides the common attributes inherited from C the
32             C widget knows only two additional attributes:
33              
34             Note that the possible values for the variable are C<0> or C<1>, which will
35             be changed according Perl's standard true/false conversions.
36              
37             =head2 Attributes
38              
39             =over
40              
41             =cut
42              
43             #########################################################################
44              
45 8     8   105 use v5.14;
  8         26  
46 8     8   38 use strictures;
  8         15  
  8         54  
47 8     8   1559 no indirect 'fatal';
  8         18  
  8         47  
48 8     8   449 no multidimensional;
  8         26  
  8         46  
49 8     8   289 use warnings 'once';
  8         20  
  8         459  
50              
51             our $VERSION = '0.22';
52              
53 8     8   45 use UI::Various::core;
  8         15  
  8         47  
54 8     8   46 use UI::Various::widget;
  8         18  
  8         482  
55 8     8   42 BEGIN { require 'UI/Various/' . UI::Various::core::using() . '/Radio.pm'; }
56              
57             require Exporter;
58             our @ISA = qw(UI::Various::widget);
59             our @EXPORT_OK = qw();
60              
61             #########################################################################
62              
63             =item buttons [rw]
64              
65             an ARRAY with pairs of key values and corresponding displayed texts of the
66             radio buttons, e.g.:
67              
68             [ 1 => 'red', 2 => 'green', 3 => 'blue' ]
69              
70             (looks like a HASH, but is technically an ARRAY as its sequence is important)
71              
72             =cut
73              
74             sub buttons($;$)
75             {
76             local $_ =
77             access
78             ('buttons',
79             sub{
80 7 100   7   18 unless (ref($_) eq 'ARRAY')
81             {
82 1         3 error('_1_attribute_must_be_a_2_reference', 'buttons', 'ARRAY');
83 1         6 return undef;
84             }
85 6 100       7 if (0 == @{$_})
  6         13  
86             {
87 1         3 error('_1_may_not_be_empty', 'buttons');
88 1         5 return undef;
89             }
90 5 100       6 unless (0 == @{$_} % 2)
  5         12  
91             {
92 1         3 error('odd_number_of_parameters_in_initialisation_list_of__1',
93             'buttons');
94 1         5 return undef;
95             }
96 4         8 my ($self) = @_;
97 4         4 my @keys = ();
98 4         7 my @values = ();
99 4         4 foreach my $i (0..$#{$_})
  4         10  
100             {
101 34 100       48 if (0 == $i % 2)
102 17         23 { push @keys, $_->[$i]; }
103             else
104 17         21 { push @values, $_->[$i]; }
105             }
106 4         34 my %hash = @$_;
107 4         12 $self->{_button_hash} = \%hash;
108 4         11 $self->{_button_keys} = \@keys;
109 4         15 $self->{_button_values} = \@values;
110             },
111 7     7 1 53 @_);
112 7         60 _init_var(@_);
113 7         17 return $_;
114             }
115              
116             =item var [rw, recommended]
117              
118             a variable reference for the radio buttons
119              
120             The variable will be set to one of the key values of C>
121             when it is selected. Note that if it's initial value is defined to
122             something not being an existing key value of that ARRAY, it will be set to
123             C.
124              
125             =cut
126              
127             sub var($;$)
128             {
129 9     9 1 34 local $_ = access_varref('var', @_);
130 9         18 _init_var(@_);
131 9         20 return $_;
132             }
133              
134             # need special initialisation function as initialisation sequence is
135             # undefined:
136             sub _init_var($;@)
137             {
138 18     18   1358 my ($self) = @_;
139             return unless ($self->isa(__PACKAGE__) and
140             defined $self->{buttons} and
141             defined $self->{var} and
142 18 100 100     221 defined ${$self->{var}});
  12   100     32  
      100        
143             # direct access to avoid recursion:
144 10 100       14 defined $self->{_button_hash}{${$self->{var}}} or ${$self->{var}} = undef;
  4         6  
  10         22  
145             }
146              
147             #########################################################################
148             #
149             # internal constants and data:
150              
151 8         770 use constant ALLOWED_PARAMETERS =>
152 8     8   60 (UI::Various::widget::COMMON_PARAMETERS, qw(buttons var));
  8         16  
153 8     8   56 use constant DEFAULT_ATTRIBUTES => (var => dummy_varref());
  8         38  
  8         51  
154              
155             #########################################################################
156             #########################################################################
157              
158             =back
159              
160             =head1 METHODS
161              
162             Besides the accessors (attributes) described above and by
163             L and the methods
164             inherited from L only the
165             constructor is provided by the C class itself:
166              
167             =cut
168              
169             #########################################################################
170              
171             =head2 B - constructor
172              
173             see L
174             constructor for UI elements>
175              
176             =cut
177              
178             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
179              
180             sub new($;\[@$])
181             {
182 8     8 1 2900 debug(3, __PACKAGE__, '::new');
183 8         56 local $_ = construct({ DEFAULT_ATTRIBUTES },
184             '^(?:' . join('|', ALLOWED_PARAMETERS) . ')$',
185             @_);
186 8 100       29 unless (defined $_->{buttons})
187             {
188 4         9 error('mandatory_parameter__1_is_missing', 'buttons');
189 4         21 return undef;
190             }
191 4         10 return $_;
192             }
193              
194             1;
195              
196             #########################################################################
197             #########################################################################
198              
199             =head1 SEE ALSO
200              
201             L
202              
203             =head1 LICENSE
204              
205             Copyright (C) Thomas Dorner.
206              
207             This library is free software; you can redistribute it and/or modify it
208             under the same terms as Perl itself. See LICENSE file for more details.
209              
210             =head1 AUTHOR
211              
212             Thomas Dorner Edorner (at) cpan (dot) orgE
213              
214             =cut