File Coverage

blib/lib/Tickit/Console.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, 2011-2014 -- leonerd@leonerd.org.uk
5              
6             package Tickit::Console;
7              
8 1     1   891 use strict;
  1         1  
  1         46  
9 1     1   7 use warnings;
  1         2  
  1         37  
10 1     1   40 use 5.010; # //
  1         5  
  1         43  
11 1     1   6 use base qw( Tickit::Widget::VBox );
  1         2  
  1         967  
12              
13             our $VERSION = '0.07';
14              
15             use Tickit::Widget::Entry;
16             use Tickit::Widget::Scroller 0.04;
17             use Tickit::Widget::Tabbed 0.003;
18              
19             use Tickit::Console::Tab;
20              
21             use Scalar::Util qw( weaken );
22              
23             =head1 NAME
24              
25             C - build full-screen console-style applications
26              
27             =head1 SYNOPSIS
28              
29             my $console = Tickit::Console->new;
30              
31             Tickit->new( root => $console )->run;
32              
33             =head1 DESCRIPTION
34              
35             A C instance is a subclass of L
36             intended to help building a full-screen console-style application which
37             presents the user with one or more scrollable text areas, selectable as tabs
38             on a ribbon, with a text entry area at the bottom of the screen for entering
39             commands or other data. As a L subclass it can be added
40             anywhere within a widget tree, though normally it would be used as the root
41             widget for a L instance.
42              
43             =cut
44              
45             =head1 CONSTRUCTOR
46              
47             =cut
48              
49             =head2 $console = Tickit::Console->new( %args )
50              
51             Returns a new instance of a C. Takes the following named
52             arguments:
53              
54             =over 8
55              
56             =item on_line => CODE
57              
58             Callback to invoke when a line of text is entered in the entry widget.
59              
60             $on_line->( $active_tab, $text )
61              
62             =item tab_class => STRING
63              
64             Optional. If set, gives a class name (which should be a subclass of
65             L) to construct newly-added tabs with. This setting
66             allows an application to provide new methods in tabs to change behaviours.
67              
68             =item timestamp_format, datestamp_format
69              
70             Optional. If supplied, these will be stored as default values to pass to the
71             tab constructor in the C method.
72              
73             =back
74              
75             =cut
76              
77             sub new
78             {
79             my $class = shift;
80             my %args = @_;
81              
82             my $on_line = delete $args{on_line};
83              
84             my %default_tab_opts;
85             $default_tab_opts{$_} = delete $args{$_} for
86             qw( timestamp_format datestamp_format );
87              
88             my $self = $class->SUPER::new( %args );
89              
90             $self->{default_tab_opts} = \%default_tab_opts;
91              
92             $self->add(
93             $self->{tabbed} = Tickit::Widget::Tabbed->new(
94             tab_position => "bottom",
95             tab_class => $args{tab_class} // "Tickit::Console::Tab",
96             ),
97             expand => 1,
98             );
99              
100             $self->add(
101             $self->{entry} = Tickit::Widget::Entry->new
102             );
103              
104             weaken( my $weakself = $self );
105             $self->{entry}->set_on_enter( sub {
106             return unless $weakself;
107             my ( $entry ) = @_;
108             my $line = $entry->text;
109             $entry->set_text( "" );
110              
111             my $tab = $weakself->active_tab;
112             if( $tab->{on_line} ) {
113             $tab->{on_line}->( $tab, $line );
114             }
115             else {
116             $on_line->( $tab, $line );
117             }
118             } );
119              
120             return $self;
121             }
122              
123             =head1 METHODS
124              
125             =cut
126              
127             =head2 $tab = $console->add_tab( %args )
128              
129             Adds a new tab to the console, and returns a L object
130             representing it.
131              
132             Takes the following named arguments:
133              
134             =over 8
135              
136             =item name => STRING
137              
138             Name for the tab.
139              
140             =item on_line => CODE
141              
142             Optional. Provides a different callback to invoke when a line of text is
143             entered while this tab is active. Invoked the same way as above.
144              
145             =item make_widget => CODE
146              
147             Optional. Gives a piece of code used to construct the actual L
148             used as this tab's child in the ribbon. A C to hold
149             the tab's content will be passed in to this code, which should construct some
150             sort of widget tree with that inside it, and return it. This can be used to
151             apply a decorative frame, place the scroller in a split box or other layout
152             along with other widgets, or various other effects.
153              
154             $tab_widget = $make_widget->( $scroller )
155              
156             =back
157              
158             Any other named arguments are passed to the tab's constructor.
159              
160             =cut
161              
162             sub add_tab
163             {
164             my $self = shift;
165             my %args = @_;
166              
167             my $make_widget = delete $args{make_widget};
168             my $on_line = delete $args{on_line};
169              
170             my $scroller = Tickit::Widget::Scroller->new( gravity => "bottom" );
171              
172             my $widget = $make_widget ? $make_widget->( $scroller ) : $scroller;
173              
174             my $tab = $self->{tabbed}->add_tab(
175             $widget,
176             label => delete $args{name},
177             %{ $self->{default_tab_opts} },
178             %args,
179             );
180              
181             $tab->{on_line} = $on_line;
182              
183             # Cheating
184             $tab->{scroller} = $scroller;
185             weaken( $tab->{console} = $self );
186              
187             return $tab;
188             }
189              
190             =head2 $index = $console->active_tab_index
191              
192             =head2 $tab = $console->active_tab
193              
194             =head2 $console->remove_tab( $tab_or_index )
195              
196             =head2 $console->move_tab( $tab_or_index, $delta )
197              
198             =head2 $console->activate_tab( $tab_or_index )
199              
200             =head2 $console->next_tab
201              
202             =head2 $console->prev_tab
203              
204             These methods are all passed through to the underlying
205             L object.
206              
207             =cut
208              
209             foreach my $method (qw( active_tab_index active_tab
210             remove_tab move_tab activate_tab next_tab prev_tab )) {
211             no strict 'refs';
212             *$method = sub {
213             my $self = shift;
214             $self->{tabbed}->$method( @_ );
215             };
216             }
217              
218             =head2 $console->bind_key( $key, $code )
219              
220             Installs a callback to invoke if the given key is pressed, overwriting any
221             previous callback for the same key. The code block is invoked as
222              
223             $code->( $console, $key )
224              
225             If C<$code> is missing or C, any existing callback is removed.
226              
227             =cut
228              
229             sub bind_key
230             {
231             my $self = shift;
232             my ( $key, $code ) = @_;
233              
234             $self->{keybindings}{$key}[0] = $code;
235              
236             $self->_update_key_binding( $key );
237             }
238              
239             sub _update_key_binding
240             {
241             my $self = shift;
242             my ( $key ) = @_;
243              
244             my $bindings = $self->{keybindings}{$key};
245              
246             if( $bindings->[0] or $bindings->[1] ) {
247             $self->{entry}->bind_keys( $key => sub {
248             my ( $entry, $key ) = @_;
249             $entry->parent->_on_key( $key );
250             });
251             }
252             else {
253             $self->{entry}->bind_key( $key => undef );
254             }
255             }
256              
257             sub _on_key
258             {
259             my $self = shift;
260             my ( $key ) = @_;
261              
262             if( my $tab = $self->active_tab ) {
263             return 1 if $tab->{keybindings}{$key} and
264             $tab->{keybindings}{$key}->( $tab, $key );
265             }
266              
267             my $code = $self->{keybindings}{$key}[0] or return 0;
268             return $code->( $self, $key );
269             }
270              
271             =head1 AUTHOR
272              
273             Paul Evans
274              
275             =cut
276              
277             0x55AA;