File Coverage

blib/lib/Tickit/Widget/Button.pm
Criterion Covered Total %
statement 15 15 100.0
branch n/a
condition n/a
subroutine 5 5 100.0
pod n/a
total 20 20 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, 2012-2014 -- leonerd@leonerd.org.uk
5              
6             package Tickit::Widget::Button;
7              
8 1     1   901 use strict;
  1         1  
  1         23  
9 1     1   3 use warnings;
  1         1  
  1         20  
10 1     1   3 use feature qw( switch );
  1         0  
  1         59  
11 1     1   570 no if $] >= 5.017011, warnings => 'experimental::smartmatch';
  1         7  
  1         14  
12 1     1   63 use base qw( Tickit::Widget );
  1         1  
  1         83  
13              
14             use Tickit::Style;
15             use Tickit::RenderBuffer qw( LINE_SINGLE LINE_DOUBLE LINE_THICK );
16              
17             our $VERSION = '0.27';
18              
19             use Tickit::Utils qw( textwidth );
20              
21             use constant CAN_FOCUS => 1;
22              
23             =head1 NAME
24              
25             C - a widget displaying a clickable button
26              
27             =head1 SYNOPSIS
28              
29             use Tickit;
30             use Tickit::Widget::Button;
31              
32             my $button = Tickit::Widget::Button->new(
33             label => "Click Me!",
34             on_click => sub {
35             my ( $self ) = @_;
36              
37             # Do something!
38             },
39             );
40              
41             Tickit->new( root => $button )->run;
42              
43             =head1 DESCRIPTION
44              
45             This class provides a widget which displays a clickable area with a label.
46             When the area is clicked, a callback is invoked.
47              
48             =head1 STYLE
49              
50             The default style pen is used as the widget pen. The following style keys are
51             used:
52              
53             =over 4
54              
55             =item linetype => STRING
56              
57             What kind of border to draw around the button; one of
58              
59             none single double thick
60              
61             =item marker_left => STRING
62              
63             A two-character string to place just before the button label
64              
65             =item marker_right => STRING
66              
67             A two-character string to place just after the button label
68              
69             =back
70              
71             The following style tags are used:
72              
73             =over 4
74              
75             =item :active
76              
77             Set when the mouse is being held over the button, before it is released
78              
79             =back
80              
81             The following style actions are used:
82              
83             =over 4
84              
85             =item click
86              
87             The main action to activate the C handler.
88              
89             =back
90              
91             =cut
92              
93             style_definition base =>
94             fg => "black",
95             bg => "blue",
96             linetype => "single",
97             marker_left => "> ",
98             marker_right => " <",
99             '' => "click";
100              
101             style_definition ':focus' =>
102             marker_left => ">>",
103             marker_right => "<<";
104              
105             style_definition ':active' =>
106             rv => 1;
107              
108             style_reshape_keys qw( linetype );
109             style_redraw_keys qw( marker_left marker_right );
110              
111             use constant WIDGET_PEN_FROM_STYLE => 1;
112             use constant KEYPRESSES_FROM_STYLE => 1;
113              
114             =head1 CONSTRUCTOR
115              
116             =cut
117              
118             =head2 $entry = Tickit::Widget::Button->new( %args )
119              
120             Constructs a new C object.
121              
122             Takes the following named arguments:
123              
124             =over 8
125              
126             =item label => STR
127              
128             Text to display in the button area
129              
130             =item on_click => CODE
131              
132             Optional. Callback function to invoke when the button is clicked.
133              
134             =back
135              
136             =cut
137              
138             sub new
139             {
140             my $class = shift;
141             my %params = @_;
142              
143             my $self = $class->SUPER::new( %params );
144              
145             $self->set_label( $params{label} ) if defined $params{label};
146             $self->set_on_click( $params{on_click} ) if $params{on_click};
147              
148             $self->set_align ( $params{align} // 0.5 );
149             $self->set_valign( $params{valign} // 0.5 );
150              
151             return $self;
152             }
153              
154             sub lines
155             {
156             my $self = shift;
157             my $has_border = ( $self->get_style_values( "linetype" ) ) ne "none";
158             return 1 + 2*$has_border;
159             }
160              
161             sub cols
162             {
163             my $self = shift;
164             my $has_border = ( $self->get_style_values( "linetype" ) ) ne "none";
165             return 4 + textwidth( $self->label ) + 2*$has_border;
166             }
167              
168             =head1 ACCESSORS
169              
170             =cut
171              
172             =head2 $label = $button->label
173              
174             =cut
175              
176             sub label
177             {
178             return shift->{label}
179             }
180              
181             =head2 $button->set_label( $label )
182              
183             Return or set the text to display in the button area.
184              
185             =cut
186              
187             sub set_label
188             {
189             my $self = shift;
190             ( $self->{label} ) = @_;
191             $self->redraw;
192             }
193              
194             =head2 $on_click = $button->on_click
195              
196             =cut
197              
198             sub on_click
199             {
200             my $self = shift;
201             return $self->{on_click};
202             }
203              
204             =head2 $button->set_on_click( $on_click )
205              
206             Return or set the CODE reference to be called when the button area is clicked.
207              
208             $on_click->( $button )
209              
210             =cut
211              
212             sub set_on_click
213             {
214             my $self = shift;
215             ( $self->{on_click} ) = @_;
216             }
217              
218             =head2 $button->click
219              
220             Behave as if the button has been clicked; running its C handler.
221             This is provided for convenience of activating its handler programatically via
222             other parts of code.
223              
224             =cut
225              
226             sub click
227             {
228             my $self = shift;
229             $self->{on_click}->( $self );
230             }
231              
232             # Activation by key should "flash" the button briefly on the screen as a
233             # visual feedback
234             sub key_click
235             {
236             my $self = shift;
237             $self->click;
238             if( my $window = $self->window ) {
239             $self->set_style_tag( active => 1 );
240             $window->tickit->timer( after => 0.1, sub { $self->set_style_tag( active => 0 ) } );
241             }
242             return 1;
243             }
244              
245             sub _activate
246             {
247             my $self = shift;
248             my ( $active ) = @_;
249             $self->{active} = $active;
250             $self->set_style_tag( active => $active );
251             }
252              
253             =head2 $align = $button->align
254              
255             =head2 $button->set_align( $align )
256              
257             =head2 $valign = $button->valign
258              
259             =head2 $button->set_valign( $valign )
260              
261             Accessors for the horizontal and vertical alignment of the label text within
262             the button area. See also L.
263              
264             =cut
265              
266             use Tickit::WidgetRole::Alignable name => "align", style => "h";
267             use Tickit::WidgetRole::Alignable name => "valign", style => "v";
268              
269             sub reshape
270             {
271             my $self = shift;
272              
273             my $win = $self->window or return;
274             my $lines = $win->lines;
275             my $cols = $win->cols;
276              
277             my $width = textwidth $self->label;
278              
279             my $has_border = ( $self->get_style_values( "linetype" ) ) ne "none";
280              
281             my ( $lines_before, undef, $lines_after ) = $self->_valign_allocation( 1, $lines - (2 * $has_border) );
282             my ( $cols_before, undef, $cols_after ) = $self->_align_allocation( $width + 2, $cols - 2 );
283              
284             $self->{label_line} = $lines_before + $has_border;
285             $self->{label_col} = $cols_before + 2;
286             $self->{label_end} = $cols_before + $width + 2;
287              
288             $win->cursor_at( $self->{label_line}, $self->{label_col} );
289             }
290              
291             sub render_to_rb
292             {
293             my $self = shift;
294             my ( $rb, $rect ) = @_;
295              
296             my $win = $self->window or return;
297             my $lines = $win->lines;
298             my $cols = $win->cols;
299              
300             my ( $linetype, $marker_left, $marker_right ) =
301             $self->get_style_values(qw( linetype marker_left marker_right ));
302              
303             my $linestyle = $linetype eq "single" ? LINE_SINGLE :
304             $linetype eq "double" ? LINE_DOUBLE :
305             $linetype eq "thick" ? LINE_THICK :
306             undef;
307              
308             if( defined $linestyle ) {
309             $rb->hline_at( 0, 0, $cols-1, $linestyle );
310             $rb->hline_at( $lines-1, 0, $cols-1, $linestyle );
311             $rb->vline_at( 0, $lines-1, 0, $linestyle );
312             $rb->vline_at( 0, $lines-1, $cols-1, $linestyle );
313              
314             foreach my $line ( $rect->linerange( 1, $lines-2 ) ) {
315             $rb->erase_at( $line, 1, $cols-2 );
316             }
317             }
318             else {
319             foreach my $line ( $rect->linerange( 0, $lines-1 ) ) {
320             $rb->erase_at( $line, 0, $cols );
321             }
322             }
323              
324             $rb->text_at( $self->{label_line}, $self->{label_col} - 2, $marker_left );
325             $rb->text_at( $self->{label_line}, $self->{label_end}, $marker_right );
326              
327             $rb->text_at( $self->{label_line}, $self->{label_col}, $self->label );
328             }
329              
330             sub on_mouse
331             {
332             my $self = shift;
333             my ( $args ) = @_;
334              
335             my $type = $args->type;
336             my $button = $args->button;
337              
338             return unless $button == 1;
339              
340             for( $type ) {
341             when( "press" ) {
342             $self->_activate( 1 );
343             }
344             when( "drag_start" ) {
345             $self->{dragging_on_self} = 1;
346             }
347             when( "drag_stop" ) {
348             $self->{dragging_on_self} = 0;
349             }
350             when( "drag" ) {
351             # TODO: This could be neater with an $arg->srcwin
352             $self->_activate( 1 ) if $self->{dragging_on_self} and !$self->{active};
353             }
354             when( "drag_outside" ) {
355             $self->_activate( 0 ) if $self->{active};
356             }
357             when( "release" ) {
358             if( $self->{active} ) {
359             $self->_activate( 0 );
360             $self->click;
361             }
362             }
363             }
364              
365             return 1;
366             }
367              
368             =head1 AUTHOR
369              
370             Paul Evans
371              
372             =cut
373              
374             0x55AA;