File Coverage

blib/lib/Tickit/Widget/MenuBar.pm
Criterion Covered Total %
statement 12 12 100.0
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 16 16 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-2013 -- leonerd@leonerd.org.uk
5              
6             package Tickit::Widget::MenuBar;
7              
8 1     1   1078 use strict;
  1         1  
  1         22  
9 1     1   3 use warnings;
  1         1  
  1         20  
10 1     1   2 use feature qw( switch );
  1         2  
  1         48  
11              
12 1     1   3 use base qw( Tickit::Widget::Menu::base );
  1         2  
  1         375  
13             use Tickit::Style;
14              
15             our $VERSION = '0.11';
16              
17             use Carp;
18              
19             use Tickit::RenderBuffer qw( LINE_SINGLE );
20             use List::Util qw( sum max );
21              
22             # Re-import the constant for compiletime use
23             use constant separator => __PACKAGE__->separator;
24              
25             =head1 NAME
26              
27             C - display a menu horizontally
28              
29             =head1 SYNOPSIS
30              
31             use Tickit;
32             use Tickit::Widget::Menu;
33             use Tickit::Widget::Menu::Item;
34             use Tickit::Widget::MenuBar;
35             use Tickit::Widget::VBox;
36              
37             my $tickit = Tickit->new;
38              
39             my $vbox = Tickit::Widget::VBox->new;
40             $tickit->set_root_widget( $vbox );
41              
42             $vbox->add( Tickit::Widget::MenuBar->new(
43             items => [
44             ...
45             ]
46             );
47              
48             $vbox->add( ... );
49              
50             $tickit->run;
51              
52             =head1 DESCRIPTION
53              
54             This widget class acts as a container for menu items similar to
55             L but displays them horizonally in a single line. This
56             widget is intended to display long-term, such as in the top line of the root
57             window, rather than being used only transiently as a pop-up menu.
58              
59             This widget should be used similarly to L, except that
60             its name is never useful, and it should be added to a container widget, such
61             as L, for longterm display. It does not have a C
62             or C method.
63              
64             A single separator object can be added as an item, causing all the items after
65             it to be right-justified.
66              
67             =head1 STYLE
68              
69             The default style pen is used as the widget pen. The following style pen
70             prefixes are also used:
71              
72             =over 4
73              
74             =item highlight => PEN
75              
76             The pen used to highlight the active menu selection
77              
78             =back
79              
80             The following style actions are used:
81              
82             =over 4
83              
84             =item highlight_next ()
85              
86             =item highlight_prev ()
87              
88             Highlight the next or previous item
89              
90             =item highlight_first ()
91              
92             Highlight the first menu item
93              
94             =item activate ()
95              
96             Activate the highlighted item
97              
98             =item dismiss ()
99              
100             Dismiss the menu
101              
102             =back
103              
104             =cut
105              
106             style_definition base =>
107             rv => 1,
108             highlight_rv => 0,
109             highlight_bg => "green",
110             "" => "highlight_next",
111             "" => "highlight_prev",
112             "" => "highlight_first",
113             "" => "activate",
114             "" => "dismiss";
115              
116             use constant KEYPRESSES_FROM_STYLE => 1;
117             use constant WIDGET_PEN_FROM_STYLE => 1;
118              
119             sub lines
120             {
121             return 1;
122             }
123              
124             sub cols
125             {
126             my $self = shift;
127             return sum( map { $self->_itemwidth( $_ ) } 0 .. $self->items-1 ) + 2 * ( $self->items - 1 );
128             }
129              
130             sub push_item
131             {
132             my $self = shift;
133             my ( $item ) = @_;
134              
135             if( $item == separator and grep { $_ == separator } $self->items ) {
136             croak "Cannot have more than one separator in a MenuBar";
137             }
138              
139             $self->SUPER::push_item( $item );
140             }
141              
142             sub reshape
143             {
144             my $self = shift;
145              
146             $self->{itempos} = \my @pos;
147              
148             my $items = $self->{items};
149             my $col = 0;
150             my $separator_at;
151             foreach my $idx ( 0 .. $#$items ) {
152             $separator_at = $idx, next if $items->[$idx] == separator;
153              
154             $pos[$idx] = [ $col, undef ];
155             $col += $self->_itemwidth( $idx );
156             $pos[$idx][1] = $col;
157             $col += 2;
158             }
159              
160             if( defined $separator_at ) {
161             $col -= 2; # undo
162             my $spare = $self->window->cols - $col;
163              
164             $pos[$_][0] += $spare, $pos[$_][1] += $spare for $separator_at+1 .. $#$items;
165             }
166             }
167              
168             sub pos2item
169             {
170             my $self = shift;
171             my ( $line, $col ) = @_;
172              
173             $line == 0 or return ();
174              
175             my $items = $self->{items};
176             my $pos = $self->{itempos};
177              
178             foreach my $idx ( 0 .. $#$items ) {
179             next if !defined $pos->[$idx]; # separator
180             last if $col < $pos->[$idx][0];
181             next unless $col < $pos->[$idx][1];
182              
183             $col -= $pos->[$idx][0];
184              
185             return () if $col < 0;
186             return ( $items->[$idx], $idx, $col );
187             }
188              
189             return ();
190             }
191              
192             sub redraw_item
193             {
194             my $self = shift;
195             my ( $idx ) = @_;
196             $self->window->expose( Tickit::Rect->new(
197             top => 0, lines => 1,
198             left => $self->{itempos}[$idx][0],
199             right => $self->{itempos}[$idx][1],
200             ) );
201             }
202              
203             sub render_to_rb
204             {
205             my $self = shift;
206             my ( $rb, $rect ) = @_;
207              
208             if( $rect->top == 0 ) {
209             $rb->goto( 0, 0 );
210              
211             my @items = $self->items;
212             foreach my $idx ( 0 .. $#items ) {
213             my $item = $items[$idx];
214             next if $item == separator;
215              
216             my ( $left, $right ) = @{ $self->{itempos}[$idx] };
217             last if $left > $rect->right;
218             next if $right < $rect->left;
219              
220             $rb->erase_to( $left );
221              
222             my $pen = defined $self->{active_idx} && $idx == $self->{active_idx}
223             ? $self->get_style_pen( "highlight" ) : undef;
224              
225             $rb->savepen;
226             $rb->setpen( $pen );
227              
228             $item->render_label( $rb, $right - $left, $self );
229              
230             $rb->restore;
231             }
232              
233             $rb->erase_to( $rect->right );
234             }
235              
236             foreach my $line ( $rect->linerange( 1, undef ) ) {
237             $rb->erase_at( $line, $rect->left, $rect->cols );
238             }
239             }
240              
241             sub popup_item
242             {
243             my $self = shift;
244             my ( $idx ) = @_;
245              
246             my $items = $self->{items};
247              
248             my $col = $self->{itempos}[$idx][0];
249              
250             my $rightmost = $self->window->cols - $items->[$idx]->cols;
251             $col = $rightmost if $col > $rightmost;
252              
253             $items->[$idx]->popup( $self->window, 1, $col );
254             }
255              
256             sub activated
257             {
258             my $self = shift;
259             $self->dismiss;
260             }
261              
262             sub dismiss
263             {
264             my $self = shift;
265             $self->SUPER::dismiss;
266              
267             # Still have a window after ->dismiss
268             $self->redraw;
269             }
270              
271             sub on_key
272             {
273             my $self = shift;
274              
275             # Always eat all the keys as there's never anything higher to pass them to
276             return 1;
277             }
278              
279             # MenuBar always expands on highlight
280             sub key_highlight_next
281             {
282             my $self = shift;
283             $self->SUPER::key_highlight_next;
284             $self->expand_item( $self->{active_idx} );
285             }
286              
287             sub key_highlight_prev
288             {
289             my $self = shift;
290             $self->SUPER::key_highlight_prev;
291             $self->expand_item( $self->{active_idx} );
292             }
293              
294             sub key_highlight_first
295             {
296             my $self = shift;
297             defined $self->{active_idx} or $self->expand_item( 0 );
298             return 1;
299             }
300              
301             sub on_mouse_item
302             {
303             my $self = shift;
304             my ( $args, $item, $item_idx, $item_col ) = @_;
305              
306             # We only ever care about button 1
307             return unless $args->button == 1;
308              
309             my $event = $args->type;
310             if( $event eq "press" ) {
311             # A second click on an active item deactivates
312             if( defined $self->{active_idx} and $item_idx == $self->{active_idx} ) {
313             $self->dismiss;
314             }
315             else {
316             $self->expand_item( $item_idx );
317             }
318             }
319             elsif( $event eq "drag" ) {
320             $self->expand_item( $item_idx );
321             }
322              
323             return 1;
324             }
325              
326             =head1 AUTHOR
327              
328             Paul Evans
329              
330             =cut
331              
332             0x55AA;