File Coverage

blib/lib/Tickit/Widget/RadioButton.pm
Criterion Covered Total %
statement 9 9 100.0
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 12 12 100.0


line stmt bran cond sub pod time code
1             # You may distribute under the terms of either the GNU General Public License
2             # or the Artistic License (the same terms as Perl itself)
3             #
4             # (C) Paul Evans, 2013 -- leonerd@leonerd.org.uk
5              
6             package Tickit::Widget::RadioButton;
7              
8 1     1   775 use strict;
  1         1  
  1         22  
9 1     1   2 use warnings;
  1         2  
  1         18  
10 1     1   3 use base qw( Tickit::Widget );
  1         1  
  1         48  
11             use Tickit::Style;
12              
13             our $VERSION = '0.27';
14              
15             use Carp;
16              
17             use Tickit::Utils qw( textwidth );
18             use List::Util 1.33 qw( any );
19              
20             use constant CAN_FOCUS => 1;
21              
22             =head1 NAME
23              
24             C - a widget allowing a selection from multiple
25             options
26              
27             =head1 SYNOPSIS
28              
29             use Tickit;
30             use Tickit::Widget::RadioButton;
31             use Tickit::Widget::VBox;
32              
33             my $group = Tickit::Widget::RadioButton::Group->new;
34              
35             my $vbox = Tickit::Widget::VBox->new;
36             $vbox->add( Tickit::Widget::RadioButton->new(
37             caption => "Radio button $_",
38             group => $group,
39             ) ) for 1 .. 5;
40              
41             Tickit->new( root => $vbox )->run;
42              
43             =head1 DESCRIPTION
44              
45             This class provides a widget which allows a selection of one value from a
46             group of related options. It provides a clickable area and a visual indication
47             of which button in the group is the one currently active. Selecting a new
48             button within a group will unselect the previously-selected one.
49              
50             This widget is part of an experiment in evolving the design of the
51             L widget integration code, and such is subject to change of
52             details.
53              
54             =head1 STYLE
55              
56             The default style pen is used as the widget pen. The following style pen
57             prefixes are also used:
58              
59             =over 4
60              
61             =item tick => PEN
62              
63             The pen used to render the tick marker
64              
65             =back
66              
67             The following style keys are used:
68              
69             =over 4
70              
71             =item tick => STRING
72              
73             The text used to indicate the active button
74              
75             =item spacing => INT
76              
77             Number of columns of spacing between the tick mark and the caption text
78              
79             =back
80              
81             The following style tags are used:
82              
83             =over 4
84              
85             =item :active
86              
87             Set when this button is the active one of the group.
88              
89             =back
90              
91             The following style actions are used:
92              
93             =over 4
94              
95             =item activate
96              
97             The main action to activate the C handler.
98              
99             =back
100              
101             =cut
102              
103             style_definition base =>
104             tick_fg => "hi-white",
105             tick_b => 1,
106             tick => "( )",
107             spacing => 2,
108             '' => "activate";
109              
110             style_definition ':active' =>
111             b => 1,
112             tick => "(*)";
113              
114             style_reshape_keys qw( spacing );
115              
116             style_reshape_textwidth_keys qw( tick );
117              
118             use constant WIDGET_PEN_FROM_STYLE => 1;
119             use constant KEYPRESSES_FROM_STYLE => 1;
120              
121             =head1 CONSTRUCTOR
122              
123             =cut
124              
125             =head2 $radiobutton = Tickit::Widget::RadioButton->new( %args )
126              
127             Constructs a new C object.
128              
129             Takes the following named argmuents
130              
131             =over 8
132              
133             =item label => STRING
134              
135             The label text to display alongside this button.
136              
137             =item group => Tickit::Widget::RadioButton::Group
138              
139             Optional. If supplied, the group that the button should belong to. If not
140             supplied, a new group will be constructed that can be accessed using the
141             C accessor.
142              
143             =item value => SCALAR
144              
145             Optional. If supplied, used to set the button's identification value, which
146             is passed to the group's C callback.
147              
148             =back
149              
150             =cut
151              
152             sub new
153             {
154             my $class = shift;
155             my %args = @_;
156              
157             my $self = $class->SUPER::new( %args );
158              
159             $self->set_label( $args{label} ) if defined $args{label};
160             $self->set_on_toggle( $args{on_toggle} ) if $args{on_toggle};
161             $self->set_value( $args{value} ) if defined $args{value};
162              
163             $self->{group} = $args{group} || Tickit::Widget::RadioButton::Group->new;
164              
165             return $self;
166             }
167              
168             sub lines
169             {
170             my $self = shift;
171             return 1;
172             }
173              
174             sub cols
175             {
176             my $self = shift;
177             return textwidth( $self->get_style_values( "tick" ) ) +
178             $self->get_style_values( "spacing" ) +
179             textwidth( $self->{label} );
180             }
181              
182             =head1 ACCESSORS
183              
184             =cut
185              
186             =head2 $group = $radiobutton->group
187              
188             Returns the C this button belongs to.
189              
190             =cut
191              
192             sub group
193             {
194             my $self = shift;
195             return $self->{group};
196             }
197              
198             =head2 $label = $radiobutton->label
199              
200             =head2 $radiobutton->set_label( $label )
201              
202             Returns or sets the label text of the button.
203              
204             =cut
205              
206             sub label
207             {
208             my $self = shift;
209             return $self->{label};
210             }
211              
212             sub set_label
213             {
214             my $self = shift;
215             ( $self->{label} ) = @_;
216             $self->reshape;
217             $self->redraw;
218             }
219              
220             =head2 $on_toggle = $radiobutton->on_toggle
221              
222             =cut
223              
224             sub on_toggle
225             {
226             my $self = shift;
227             return $self->{on_toggle};
228             }
229              
230             =head2 $radiobutton->set_on_toggle( $on_toggle )
231              
232             Return or set the CODE reference to be called when the button state is
233             changed.
234              
235             $on_toggle->( $radiobutton, $active )
236              
237             When the radio tick mark moves from one button to another, the old button is
238             marked unactive before the new one is marked active.
239              
240             =cut
241              
242             sub set_on_toggle
243             {
244             my $self = shift;
245             ( $self->{on_toggle} ) = @_;
246             }
247              
248             =head2 $value = $radiobutton->value
249              
250             =cut
251              
252             sub value
253             {
254             my $self = shift;
255             return $self->{value};
256             }
257              
258             =head2 $radiobutton->set_value( $value )
259              
260             Return or set the scalar value used to identify the radio button to the
261             group's C callback. This can be any scalar value; it is simply
262             stored by the button and not otherwise used.
263              
264             =cut
265              
266             sub set_value
267             {
268             my $self = shift;
269             ( $self->{value} ) = @_;
270             }
271              
272             =head1 METHODS
273              
274             =cut
275              
276             =head2 $radiobutton->activate
277              
278             Sets this button as the active member of the group, deactivating the previous
279             one.
280              
281             =cut
282              
283             *key_activate = \&activate;
284             sub activate
285             {
286             my $self = shift;
287             my $group = $self->{group};
288              
289             if( my $old = $group->active ) {
290             $old->set_style_tag( active => 0 );
291             $old->{on_toggle}->( $old, 0 ) if $old->{on_toggle};
292             }
293              
294             $group->set_active( $self );
295              
296             $self->set_style_tag( active => 1 );
297             $self->{on_toggle}->( $self, 1 ) if $self->{on_toggle};
298              
299             return 1;
300             }
301              
302             =head2 $active = $radiobutton->is_active
303              
304             Returns true if this button is the active button of the group.
305              
306             =cut
307              
308             sub is_active
309             {
310             my $self = shift;
311             return $self->group->active == $self;
312             }
313              
314             sub reshape
315             {
316             my $self = shift;
317              
318             my $win = $self->window or return;
319              
320             my $tick = $self->get_style_values( "tick" );
321              
322             $win->cursor_at( 0, ( textwidth( $tick )-1 ) / 2 );
323             }
324              
325             sub render_to_rb
326             {
327             my $self = shift;
328             my ( $rb, $rect ) = @_;
329              
330             $rb->clear;
331              
332             return if $rect->top > 0;
333              
334             $rb->goto( 0, 0 );
335              
336             $rb->text( my $tick = $self->get_style_values( "tick" ), $self->get_style_pen( "tick" ) );
337             $rb->erase( $self->get_style_values( "spacing" ) );
338             $rb->text( $self->{label} );
339             $rb->erase_to( $rect->right );
340             }
341              
342             sub on_mouse
343             {
344             my $self = shift;
345             my ( $args ) = @_;
346              
347             return unless $args->type eq "press" and $args->button == 1;
348             return 1 unless $args->line == 0;
349              
350             $self->activate;
351             }
352              
353             package # hide from indexer
354             Tickit::Widget::RadioButton::Group;
355             use Scalar::Util qw( weaken refaddr );
356              
357             =head1 GROUPS
358              
359             Every C belongs to a group. Only one button can
360             be active in a group at any one time. The C accessor returns the group
361             the button is a member of. The following methods are available on it.
362              
363             A group can be explicitly created to pass to a button's constructor, or one
364             will be implicitly created for a button if none is passed.
365              
366             =cut
367              
368             =head2 $group = Tickit::Widget::RadioButton::Group->new
369              
370             Returns a new group.
371              
372             =cut
373              
374             sub new
375             {
376             my $class = shift;
377             return bless [ undef, undef ], $class;
378             }
379              
380             =head2 $radiobutton = $group->active
381              
382             Returns the button which is currently active in the group
383              
384             =cut
385              
386             sub active
387             {
388             my $self = shift;
389             return $self->[0];
390             }
391              
392             sub set_active
393             {
394             my $self = shift;
395             ( $self->[0] ) = @_;
396             $self->[1]->( $self->active, $self->active->value ) if $self->[1];
397             }
398              
399             =head2 $on_changed = $group->on_changed
400              
401             =cut
402              
403             sub on_changed
404             {
405             my $self = shift;
406             return $self->[1];
407             }
408              
409             =head2 $group->set_on_changed( $on_changed )
410              
411             Return or set the CODE reference to be called when the active member of the
412             group changes. This may be more convenient than setting the C
413             callback of each button in the group.
414              
415             The callback is passed the currently-active button, and its C.
416              
417             $on_changed->( $active, $value )
418              
419             =cut
420              
421             sub set_on_changed
422             {
423             my $self = shift;
424             ( $self->[1] ) = @_;
425             }
426              
427             =head1 AUTHOR
428              
429             Paul Evans
430              
431             =cut
432              
433             0x55AA;