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-2017 -- leonerd@leonerd.org.uk |
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
package Tickit::Widget::Menu; |
7
|
|
|
|
|
|
|
|
8
|
1
|
|
|
1
|
|
529
|
use strict; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
24
|
|
9
|
1
|
|
|
1
|
|
4
|
use warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
29
|
|
10
|
1
|
|
|
1
|
|
9
|
use feature qw( switch ); |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
81
|
|
11
|
|
|
|
|
|
|
|
12
|
1
|
|
|
1
|
|
233
|
use Tickit::Window 0.49; # hierarchy changes are asynchronous |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
our $VERSION = '0.11'; |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
# Much of this code actually lives in a class called T:W:Menu::base, which is |
17
|
|
|
|
|
|
|
# the base class used by T:W:Menu and T:W:MenuBar |
18
|
|
|
|
|
|
|
use base qw( Tickit::Widget::Menu::base ); |
19
|
|
|
|
|
|
|
use Tickit::Widget::Menu::Item; |
20
|
|
|
|
|
|
|
use Tickit::Style; |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
use Tickit::RenderBuffer qw( LINE_SINGLE ); |
23
|
|
|
|
|
|
|
use List::Util qw( max min ); |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
# Re-import the constant for compiletime use |
26
|
|
|
|
|
|
|
use constant separator => __PACKAGE__->separator; |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
=head1 NAME |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
C - display a menu of choices |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
=head1 SYNOPSIS |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
use Tickit; |
35
|
|
|
|
|
|
|
use Tickit::Widget::Menu; |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
my $tickit = Tickit->new; |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
my $menu = Tickit::Widget::Menu->new( |
40
|
|
|
|
|
|
|
items => [ |
41
|
|
|
|
|
|
|
Tickit::Widget::Menu::Item->new( |
42
|
|
|
|
|
|
|
name => "Exit", |
43
|
|
|
|
|
|
|
on_activate => sub { $tickit->stop } |
44
|
|
|
|
|
|
|
), |
45
|
|
|
|
|
|
|
], |
46
|
|
|
|
|
|
|
); |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
$menu->popup( $tickit->rootwin, 5, 5 ); |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
$tickit->run; |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
=head1 DESCRIPTION |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
This widget class acts as a display container for a list of items representing |
55
|
|
|
|
|
|
|
individual choices. It can be displayed as a floating window using the |
56
|
|
|
|
|
|
|
C method, or attached to a L or as a child |
57
|
|
|
|
|
|
|
menu within another C. |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
This widget is intended to be displayed transiently, either as a pop-up menu |
60
|
|
|
|
|
|
|
over some other widget, or as a child menu of another menu or an instance of |
61
|
|
|
|
|
|
|
a menu bar. Specifically, such objects should not be directly added to |
62
|
|
|
|
|
|
|
container widgets. |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
=head1 STYLE |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
The default style pen is used as the widget pen. The following style pen |
67
|
|
|
|
|
|
|
prefixes are also used: |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
=over 4 |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
=item highlight => PEN |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
The pen used to highlight the active menu selection |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
=back |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
The following style actions are used: |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
=over 4 |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
=item highlight_next () |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
=item highlight_prev () |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
Highlight the next or previous item |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
=item activate () |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
Activate the highlighted item |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
=item dismiss () |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
Dismiss the menu |
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
=back |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
=cut |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
style_definition base => |
100
|
|
|
|
|
|
|
rv => 1, |
101
|
|
|
|
|
|
|
highlight_rv => 0, |
102
|
|
|
|
|
|
|
highlight_bg => "green", |
103
|
|
|
|
|
|
|
"" => "highlight_next", |
104
|
|
|
|
|
|
|
"" => "highlight_prev", |
105
|
|
|
|
|
|
|
"" => "activate", |
106
|
|
|
|
|
|
|
"" => "dismiss"; |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
use constant KEYPRESSES_FROM_STYLE => 1; |
109
|
|
|
|
|
|
|
use constant WIDGET_PEN_FROM_STYLE => 1; |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
# These methods come from T:W:Menu::base but better to document them here so |
112
|
|
|
|
|
|
|
# the reader can find them |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
=head1 CONSTRUCTOR |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
=head2 $menu = Tickit::Widget::Menu->new( %args ) |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
Constructs a new C object. |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
Takes the following named arguments: |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
=over 8 |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
=item name => STRING |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
Optional. If present, gives the name of the menu item for a submenu. Not used |
127
|
|
|
|
|
|
|
in a top-level menu. |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
=item items => ARRAY |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
Optional. If present, contains a list of C or |
132
|
|
|
|
|
|
|
C objects to add to the menu. Equivalent to passing each |
133
|
|
|
|
|
|
|
to the C method after construction. |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
=back |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
=head2 $separator = Tickit::Window::Menu->separator |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
Returns a special menu item which draws a separation line between its |
140
|
|
|
|
|
|
|
neighbours. |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
=cut |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
=head1 METHODS |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
=cut |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
sub lines |
149
|
|
|
|
|
|
|
{ |
150
|
|
|
|
|
|
|
my $self = shift; |
151
|
|
|
|
|
|
|
return 2 + $self->items; |
152
|
|
|
|
|
|
|
} |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
sub cols |
155
|
|
|
|
|
|
|
{ |
156
|
|
|
|
|
|
|
my $self = shift; |
157
|
|
|
|
|
|
|
return 4 + max( map { $self->_itemwidth( $_ ) } 0 .. $self->items-1 ); |
158
|
|
|
|
|
|
|
} |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
=head2 $name = $menu->name |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
Returns the string name for the menu. |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
=head2 @items = $menu->items |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
Returns the list of items currently stored. |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
=head2 $menu->push_item( $item ) |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
Adds another item. |
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
Each item may either be created using L's |
173
|
|
|
|
|
|
|
constructor, another C item itself (to create a |
174
|
|
|
|
|
|
|
submenu), or the special separator value. |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
=cut |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
=head2 $menu->highlight_item( $idx ) |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
Gives the selection highlight to the item at the given index. This may be |
181
|
|
|
|
|
|
|
called before the menu is actually displayed in order to pre-select the |
182
|
|
|
|
|
|
|
highlight initially. |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
=cut |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
=head2 $menu->popup( $win, $line, $col ) |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
Makes the menu appear at the given position relative to the given window. Note |
189
|
|
|
|
|
|
|
that as C<< $win->make_popup >> is called, the menu is always displayed in a |
190
|
|
|
|
|
|
|
popup window, floating over the root window. Passed window is used simply as |
191
|
|
|
|
|
|
|
the origin for the given line and column position. |
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
=cut |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
sub popup |
196
|
|
|
|
|
|
|
{ |
197
|
|
|
|
|
|
|
my $self = shift; |
198
|
|
|
|
|
|
|
my ( $parentwin, $line, $col ) = @_; |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
my $win = $parentwin->make_popup( $line, $col, $self->lines, $self->cols ); |
201
|
|
|
|
|
|
|
$self->set_window( $win ); |
202
|
|
|
|
|
|
|
$win->show; |
203
|
|
|
|
|
|
|
} |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
=head2 $menu->dismiss |
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
Hides a menu previously displayed using C. |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
=cut |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
sub set_supermenu |
212
|
|
|
|
|
|
|
{ |
213
|
|
|
|
|
|
|
my $self = shift; |
214
|
|
|
|
|
|
|
( $self->{supermenu} ) = @_; |
215
|
|
|
|
|
|
|
} |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
sub pos2item |
218
|
|
|
|
|
|
|
{ |
219
|
|
|
|
|
|
|
my $self = shift; |
220
|
|
|
|
|
|
|
my ( $line, $col ) = @_; |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
$line > 0 or return (); |
223
|
|
|
|
|
|
|
$line--; |
224
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
$col > 1 or return (); |
226
|
|
|
|
|
|
|
$col < $self->cols - 1 or return (); |
227
|
|
|
|
|
|
|
$col -= 2; |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
my @items = $self->items; |
230
|
|
|
|
|
|
|
$line < @items or return (); |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
return ( $items[$line], $line, $col ); |
233
|
|
|
|
|
|
|
} |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
sub redraw_item |
236
|
|
|
|
|
|
|
{ |
237
|
|
|
|
|
|
|
my $self = shift; |
238
|
|
|
|
|
|
|
my ( $idx ) = @_; |
239
|
|
|
|
|
|
|
$self->window->expose( Tickit::Rect->new( |
240
|
|
|
|
|
|
|
top => $idx + 1, lines => 1, |
241
|
|
|
|
|
|
|
left => 0, cols => $self->window->cols, |
242
|
|
|
|
|
|
|
) ); |
243
|
|
|
|
|
|
|
} |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
sub render_to_rb |
246
|
|
|
|
|
|
|
{ |
247
|
|
|
|
|
|
|
my $self = shift; |
248
|
|
|
|
|
|
|
my ( $rb, $rect ) = @_; |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
my $lines = $self->window->lines; |
251
|
|
|
|
|
|
|
my $cols = $self->window->cols; |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
$rb->hline_at( 0, 0, $cols-1, LINE_SINGLE ); |
254
|
|
|
|
|
|
|
$rb->hline_at( $lines-1, 0, $cols-1, LINE_SINGLE ); |
255
|
|
|
|
|
|
|
$rb->vline_at( 0, $lines-1, 0, LINE_SINGLE ); |
256
|
|
|
|
|
|
|
$rb->vline_at( 0, $lines-1, $cols-1, LINE_SINGLE ); |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
foreach my $line ( $rect->linerange( 1, $lines-2 ) ) { |
259
|
|
|
|
|
|
|
my $idx = $line - 1; |
260
|
|
|
|
|
|
|
my $item = $self->{items}[$idx]; |
261
|
|
|
|
|
|
|
|
262
|
|
|
|
|
|
|
if( $item == separator ) { |
263
|
|
|
|
|
|
|
$rb->hline_at( $line, 0, $cols-1, LINE_SINGLE ); |
264
|
|
|
|
|
|
|
} |
265
|
|
|
|
|
|
|
else { |
266
|
|
|
|
|
|
|
$rb->erase_at( $line, 1, 1 ); |
267
|
|
|
|
|
|
|
if( $item->isa( "Tickit::Widget::Menu" ) ) { |
268
|
|
|
|
|
|
|
$rb->text_at( $line, $cols-2, ">" ); |
269
|
|
|
|
|
|
|
} |
270
|
|
|
|
|
|
|
else { |
271
|
|
|
|
|
|
|
$rb->erase_at( $line, $cols-2, 1 ); |
272
|
|
|
|
|
|
|
} |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
my $pen = defined $self->{active_idx} && $idx == $self->{active_idx} |
275
|
|
|
|
|
|
|
? $self->get_style_pen( "highlight" ) : undef; |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
$rb->savepen; |
278
|
|
|
|
|
|
|
$rb->setpen( $pen ) if $pen; |
279
|
|
|
|
|
|
|
|
280
|
|
|
|
|
|
|
$rb->erase_at( $line, 2, $cols-4 ); |
281
|
|
|
|
|
|
|
$rb->goto( $line, 2 ); |
282
|
|
|
|
|
|
|
$item->render_label( $rb, $cols-4, $self ); |
283
|
|
|
|
|
|
|
|
284
|
|
|
|
|
|
|
$rb->restore; |
285
|
|
|
|
|
|
|
} |
286
|
|
|
|
|
|
|
} |
287
|
|
|
|
|
|
|
} |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
sub popup_item |
290
|
|
|
|
|
|
|
{ |
291
|
|
|
|
|
|
|
my $self = shift; |
292
|
|
|
|
|
|
|
my ( $idx ) = @_; |
293
|
|
|
|
|
|
|
|
294
|
|
|
|
|
|
|
my $item = $self->{items}[$idx]; |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
$item->popup( $self->window, $idx + 1, $self->window->cols ); |
297
|
|
|
|
|
|
|
} |
298
|
|
|
|
|
|
|
|
299
|
|
|
|
|
|
|
sub activated |
300
|
|
|
|
|
|
|
{ |
301
|
|
|
|
|
|
|
my $self = shift; |
302
|
|
|
|
|
|
|
$self->dismiss; |
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
$self->{supermenu}->activated if $self->{supermenu}; |
305
|
|
|
|
|
|
|
$self->{on_activated}->() if $self->{on_activated}; |
306
|
|
|
|
|
|
|
} |
307
|
|
|
|
|
|
|
|
308
|
|
|
|
|
|
|
sub dismiss |
309
|
|
|
|
|
|
|
{ |
310
|
|
|
|
|
|
|
my $self = shift; |
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
if( $self->window ) { |
313
|
|
|
|
|
|
|
$self->window->hide; |
314
|
|
|
|
|
|
|
$self->set_window( undef ); |
315
|
|
|
|
|
|
|
} |
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
$self->SUPER::dismiss; |
318
|
|
|
|
|
|
|
} |
319
|
|
|
|
|
|
|
|
320
|
|
|
|
|
|
|
sub on_key |
321
|
|
|
|
|
|
|
{ |
322
|
|
|
|
|
|
|
my $self = shift; |
323
|
|
|
|
|
|
|
|
324
|
|
|
|
|
|
|
# Eat keys if there's no supermenu to pass them to |
325
|
|
|
|
|
|
|
return !$self->{supermenu}; |
326
|
|
|
|
|
|
|
} |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
sub on_mouse_item |
329
|
|
|
|
|
|
|
{ |
330
|
|
|
|
|
|
|
my $self = shift; |
331
|
|
|
|
|
|
|
my ( $args, $item, $item_idx, $item_col ) = @_; |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
# Separators do not react to mouse |
334
|
|
|
|
|
|
|
return 1 if $item == separator; |
335
|
|
|
|
|
|
|
|
336
|
|
|
|
|
|
|
my $event = $args->type; |
337
|
|
|
|
|
|
|
if( $event eq "press" || $event eq "drag" and $args->button == 1 ) { |
338
|
|
|
|
|
|
|
$self->expand_item( $item_idx ); |
339
|
|
|
|
|
|
|
} |
340
|
|
|
|
|
|
|
elsif( $event eq "release" ) { |
341
|
|
|
|
|
|
|
if( defined $self->{active_idx} and $self->{active_idx} == $item_idx ) { |
342
|
|
|
|
|
|
|
$self->activate_item( $item_idx ); |
343
|
|
|
|
|
|
|
} |
344
|
|
|
|
|
|
|
} |
345
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
return 1; |
347
|
|
|
|
|
|
|
} |
348
|
|
|
|
|
|
|
|
349
|
|
|
|
|
|
|
=head1 AUTHOR |
350
|
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
Paul Evans |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
=cut |
354
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
0x55AA; |