File Coverage

blib/lib/Tickit/Widget/Menu.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


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;