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; |