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 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, 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