File Coverage

blib/lib/Tickit/Widget.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

line	stmt	sub	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, 2009-2016 -- leonerd@leonerd.org.uk
5
6				package Tickit::Widget;
7
8	1	1	4	use strict;
	1		2
	1		22
9	1	1	3	use warnings;
	1		0
	1		29
10
11				our $VERSION = '0.52';
12
13	1	1	3	use Carp;
	1		1
	1		64
14	1	1	4	use Scalar::Util qw( weaken );
	1		1
	1		64
15	1	1	4	use List::Util 1.33 qw( all );
	1		19
	1		62
16
17	1	1	350	use Tickit::Pen;
	0
	0
18				use Tickit::Style;
19				use Tickit::Utils qw( textwidth );
20				use Tickit::Window 0.57; # $win->bind_event
21
22				use constant PEN_ATTR_MAP => { map { $_ => 1 } @Tickit::Pen::ALL_ATTRS };
23
24				use constant KEYPRESSES_FROM_STYLE => 0;
25
26				use constant CAN_FOCUS => 0;
27
28				=head1 NAME
29
30				C - abstract base class for on-screen widgets
31
32				=head1 DESCRIPTION
33
34				This class acts as an abstract base class for on-screen widget objects. It
35				provides the lower-level machinery required by most or all widget types.
36
37				Objects cannot be directly constructed in this class. Instead, a subclass of
38				this class which provides a suitable implementation of the C and
39				other provided methods is derived. Instances in that class are then
40				constructed.
41
42				See the C section below.
43
44				The core F distribution only contains a couple of simple widget
45				classes. Many more widget types are available on CPAN. Almost certainly for
46				any widget-based program you will want to at least install the
47				L distribution, which provides many of the basic UI types of
48				widget.
49
50				=head1 STYLE
51
52				The following style tags are used on all widget classes that use Style:
53
54				=over 4
55
56				=item :focus
57
58				Set when this widget has the input focus
59
60				=back
61
62				The following style actions are used:
63
64				=over 4
65
66				=item focus_next_before ()
67
68				=item focus_next_after ()
69
70				Requests the focus move to the next or previous focusable widget in display
71				order.
72
73				=back
74
75				=cut
76
77				=head1 CONSTRUCTOR
78
79				=cut
80
81				=head2 $widget = Tickit::Widget->new( %args )
82
83				Constructs a new C object. Must be called on a subclass that
84				implements the required methods; see the B section below.
85
86				Any pen attributes present in C<%args> will be used to set the default values
87				on the widget's pen object, other than the following:
88
89				=over 8
90
91				=item class => STRING
92
93				=item classes => ARRAY of STRING
94
95				If present, gives the C class name or names applied to this
96				widget.
97
98				=item style => HASH
99
100				If present, gives a set of "direct applied" style to the Widget. This is
101				treated as an extra set of style definitions that apply more directly than any
102				of the style classes or the default definitions.
103
104				The hash should contain style keys, optionally suffixed by style tags, giving
105				values.
106
107				style => {
108				'fg' => 3,
109				'fg:active' => 5,
110				}
111
112				=back
113
114				=cut
115
116				sub new
117				{
118				my $class = shift;
119				my %args = @_;
120
121				foreach my $method (qw( lines cols render_to_rb )) {
122				$class->can( $method ) or
123				croak "$class cannot ->$method - do you subclass and implement it?";
124				}
125
126				my $self = bless {
127				classes => delete $args{classes} // [ delete $args{class} ],
128				}, $class;
129
130				# Legacy direct-applied-style argument support
131				$args{$_} and $args{style}{$_} = delete $args{$_} for @Tickit::Pen::ALL_ATTRS;
132
133				if( my $style = delete $args{style} ) {
134				my $tagset = $self->{style_direct} = Tickit::Style::_Tagset->new;
135				foreach my $key ( keys %$style ) {
136				$tagset->add( $key, $style->{$key} );
137				}
138				}
139
140				$self->_update_pen( $self->get_style_pen );
141
142				return $self;
143				}
144
145				=head1 METHODS
146
147				=cut
148
149				=head2 @classes = $widget->style_classes
150
151				Returns a list of the style class names this Widget has.
152
153				=cut
154
155				sub style_classes
156				{
157				my $self = shift;
158				return @{ $self->{classes} };
159				}
160
161				=head2 $widget->set_style_tag( $tag, $value )
162
163				Sets the (boolean) state of the named style tag. After calling this method,
164				the C methods may return different results. No resizing or
165				redrawing is necessarily performed; but the widget can use
166				C, C or C
167				to declare which style keys should cause automatic reshaping or redrawing. In
168				addition it can override the C method to inspect the
169				changes and decide for itself.
170
171				=cut
172
173				# This is cached, so will need invalidating on style loads
174				my %KEYS_BY_TYPE_CLASS_TAG;
175				Tickit::Style::on_style_load( sub { undef %KEYS_BY_TYPE_CLASS_TAG } );
176
177				sub set_style_tag
178				{
179				my $self = shift;
180				my ( $tag, $value ) = @_;
181
182				# Early-return on no change
183				return if !$self->{style_tag}{$tag} == !$value;
184
185				# Work out what style keys might depend on this tag
186				my %values;
187
188				if( $self->{style_direct} ) {
189				KEYSET: foreach my $keyset ( $self->{style_direct}->keysets ) {
190				$keyset->tags->{$tag} or next KEYSET;
191
192				$values{$_} \|\|= [] for keys %{ $keyset->style };
193				}
194				}
195
196				my $type = $self->_widget_style_type;
197				foreach my $class ( $self->style_classes, undef ) {
198				my $keys = $KEYS_BY_TYPE_CLASS_TAG{$type}{$class//""}{$tag} \|\|= do {
199				my $tagset = Tickit::Style::_ref_tagset( $type, $class );
200
201				my %keys;
202				KEYSET: foreach my $keyset ( $tagset->keysets ) {
203				$keyset->tags->{$tag} or next KEYSET;
204
205				$keys{$_}++ for keys %{ $keyset->style };
206				}
207
208				[ keys %keys ];
209				};
210
211				$values{$_} \|\|= [] for @$keys;
212				}
213
214				my @keys = keys %values;
215
216				my @old_values = $self->get_style_values( @keys );
217				$values{$keys[$_]}[0] = $old_values[$_] for 0 .. $#keys;
218
219				$self->{style_tag}{$tag} = !!$value;
220
221				$self->_style_changed_values( \%values );
222				}
223
224				sub _style_tags
225				{
226				my $self = shift;
227				my $tags = $self->{style_tag};
228				return join "\|", sort grep { $tags->{$_} } keys %$tags;
229				}
230
231				=head2 @values = $widget->get_style_values( @keys )
232
233				=head2 $value = $widget->get_style_values( $key )
234
235				Returns a list of values for the given keys of the currently-applied style.
236				For more detail see the L documentation. Returns just one value
237				in scalar context.
238
239				=cut
240
241				sub get_style_values
242				{
243				my $self = shift;
244				my @keys = @_;
245
246				my $type = $self->_widget_style_type;
247
248				my @set = ( 0 ) x @keys;
249				my @values = ( undef ) x @keys;
250
251				my $tags = $self->{style_tag};
252				my $cache = $self->{style_cache}{$self->_style_tags} \|\|= {};
253
254				foreach my $i ( 0 .. $#keys ) {
255				next unless exists $cache->{$keys[$i]};
256
257				$set[$i] = 1;
258				$values[$i] = $cache->{$keys[$i]};
259				}
260
261				my @classes = ( $self->style_classes, undef );
262				my $tagset = $self->{style_direct};
263
264				while( !all { $_ } @set and @classes ) {
265				# First time around this uses the direct style, if set. Thereafter uses
266				# the style classes in order, finally the unclassed base.
267				defined $tagset or $tagset = Tickit::Style::_ref_tagset( $type, shift @classes );
268
269				KEYSET: foreach my $keyset ( $tagset->keysets ) {
270				$tags->{$_} or next KEYSET for keys %{ $keyset->tags };
271
272				my $style = $keyset->style;
273
274				foreach ( 0 .. $#keys ) {
275				exists $style->{$keys[$_]} or next;
276				$set[$_] and next;
277
278				$values[$_] = $style->{$keys[$_]};
279				$set[$_] = 1;
280				}
281				}
282
283				undef $tagset;
284				}
285
286				foreach my $i ( 0 .. $#keys ) {
287				next if exists $cache->{$keys[$i]};
288
289				$cache->{$keys[$i]} = $values[$i];
290				}
291
292				return @values if wantarray;
293				return $values[0];
294				}
295
296				=head2 $pen = $widget->get_style_pen( $prefix )
297
298				A shortcut to calling C to collect up the pen attributes,
299				and form a L object from them. If C<$prefix> is
300				supplied, it will be prefixed on the pen attribute names with an underscore
301				(which would be read from the stylesheet file as a hypen). Note that the
302				returned pen instance is immutable, and may be cached.
303
304				=cut
305
306				sub get_style_pen
307				{
308				my $self = shift;
309				my $class = ref $self;
310				my ( $prefix ) = @_;
311
312				return $self->{style_pen_cache}{$self->_style_tags}{$prefix//""} \|\|= do {
313				my @keys = map { defined $prefix ? "${prefix}_$_" : $_ } @Tickit::Pen::ALL_ATTRS;
314
315				my %attrs;
316				@attrs{@Tickit::Pen::ALL_ATTRS} = $self->get_style_values( @keys );
317
318				Tickit::Pen::Immutable->new( %attrs );
319				};
320				}
321
322				=head2 $text = $widget->get_style_text
323
324				A shortcut to calling C for a single key called C<"text">.
325
326				=cut
327
328				sub get_style_text
329				{
330				my $self = shift;
331				my $class = ref $self;
332
333				return $self->get_style_values( "text" ) // croak "$class style does not define text";
334				}
335
336				=head2 $widget->set_style( %defs )
337
338				Changes the widget's direct-applied style.
339
340				C<%defs> should contain style keys optionally suffixed with tags in the same
341				form as that given to the C