File Coverage

blib/lib/Tickit/Widget/LinearBox.pm
Criterion Covered Total %
statement 9 9 100.0
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 12 12 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, 2009-2013 -- leonerd@leonerd.org.uk
5              
6             package Tickit::Widget::LinearBox;
7              
8 1     1   4 use strict;
  1         1  
  1         19  
9 1     1   3 use warnings;
  1         1  
  1         18  
10 1     1   3 use base qw( Tickit::ContainerWidget );
  1         1  
  1         96  
11             use Tickit::RenderBuffer;
12              
13             our $VERSION = '0.46';
14              
15             use Carp;
16              
17             use Tickit::Utils qw( distribute );
18              
19             use List::Util qw( sum );
20              
21             =head1 NAME
22              
23             C - abstract base class for C and C
24              
25             =head1 DESCRIPTION
26              
27             This class is a base class for both L and
28             L. It is not intended to be used directly.
29              
30             It maintains an ordered list of child widgets, and implements the following
31             child widget options:
32              
33             =over 8
34              
35             =item expand => NUM
36              
37             A number used to control how extra space is distributed among child widgets,
38             if the window containing this widget has more space available to it than the
39             children need. The actual value is unimportant, but extra space will be
40             distributed among the children in proportion with their C value.
41              
42             For example, if all the children have a C value of 1, extra space is
43             distributed evenly. If one child has a value of 2, it will gain twice as much
44             extra space as its siblings. Any child with a value of 0 will obtain no extra
45             space.
46              
47             =item force_size => NUM
48              
49             If provided, forces the size of this child widget, overriding the value
50             returned by C.
51              
52             =back
53              
54             =cut
55              
56             =head1 CONSTRUCTOR
57              
58             =cut
59              
60             =head2 $widget = Tickit::Widget::LinearBox->new( %args )
61              
62             Returns a new C.
63              
64             Takes the following named argmuents:
65              
66             =over 8
67              
68             =item children => ARRAY[Tickit::Widget]
69              
70             Optional. If provided, the widgets in this array will be added, with no
71             additional options.
72              
73             =back
74              
75             =cut
76              
77             sub new
78             {
79             my $class = shift;
80             my %args = @_;
81              
82             exists $args{$_} and $args{style}{$_} = delete $args{$_} for qw( spacing );
83              
84             my $self = $class->SUPER::new( %args );
85              
86             $self->{children} = [];
87              
88             $self->add( $_ ) for @{ $args{children} };
89              
90             return $self;
91             }
92              
93             =head1 METHODS
94              
95             =cut
96              
97             =head2 @children = $widget->children
98              
99             In scalar context, returns the number of contained children. In list context,
100             returns a list of all the child widgets.
101              
102             =cut
103              
104             sub children
105             {
106             my $self = shift;
107              
108             return @{ $self->{children} };
109             }
110              
111             sub _any2index
112             {
113             my $self = shift;
114              
115             my $children = $self->{children};
116              
117             if( ref $_[0] ) {
118             my $child = shift;
119             $children->[$_] == $child and return $_ for 0 .. $#$children;
120             croak "Unable to find child $child";
121             }
122             else {
123             my $index = shift;
124             return $index if $index >= 0 and $index < scalar @$children;
125             croak "Index $index out of bounds";
126             }
127             }
128              
129             =head2 %opts = $widget->child_opts( $child_or_index )
130              
131             Returns the options currently set for the given child, specified either by
132             reference or by index.
133              
134             =cut
135              
136             sub child_opts
137             {
138             my $self = shift;
139             my $child = ref $_[0] ? shift : $self->{children}[shift];
140              
141             return unless $child;
142              
143             return $self->SUPER::child_opts( $child );
144             }
145              
146             =head2 $widget->set_child( $index, $child )
147              
148             Replaces the child widget at the given index with the given new one;
149             preserving any options that are set on it.
150              
151             =cut
152              
153             sub set_child
154             {
155             my $self = shift;
156             my ( $index, $child ) = @_;
157              
158             my $old_child = $self->{children}[$index];
159              
160             my %opts;
161             if( $old_child ) {
162             %opts = $self->child_opts( $old_child );
163              
164             local $self->{suppress_redistribute} = 1;
165             $self->SUPER::remove( $old_child );
166             }
167              
168             $self->{children}[$index] = $child;
169              
170             $self->SUPER::add( $child, %opts );
171             }
172              
173             =head2 $widget->set_child_opts( $child_or_index, %newopts )
174              
175             Sets new options on the given child, specified either by reference or by
176             index. Any options whose value is given as C are deleted.
177              
178             =cut
179              
180             sub set_child_opts
181             {
182             my $self = shift;
183             my $child = ref $_[0] ? shift : $self->{children}[shift];
184              
185             return unless $child;
186              
187             return $self->SUPER::set_child_opts( $child, @_ );
188             }
189              
190             sub render_to_rb
191             {
192             my $self = shift;
193             my ( $rb, $rect ) = @_;
194              
195             $rb->eraserect( $rect );
196             }
197              
198             =head2 $widget->add( $child, %opts )
199              
200             Adds the widget as a new child of this one, with the given options
201              
202             =cut
203              
204             sub add
205             {
206             my $self = shift;
207             my ( $child, %opts ) = @_;
208              
209             push @{ $self->{children} }, $child;
210              
211             $self->SUPER::add( $child,
212             expand => $opts{expand} || 0,
213             force_size => $opts{force_size},
214             );
215             }
216              
217             =head2 $widget->remove( $child_or_index )
218              
219             Removes the given child widget if present, by reference or index
220              
221             =cut
222              
223             sub remove
224             {
225             my $self = shift;
226             my $index = $self->_any2index( shift );
227              
228             my ( $child ) = splice @{ $self->{children} }, $index, 1, ();
229              
230             $self->SUPER::remove( $child ) if $child;
231             }
232              
233             sub reshape
234             {
235             my $self = shift;
236             $self->{suppress_redistribute} and return;
237              
238             my $window = $self->window;
239              
240             return unless $self->children;
241              
242             my $spacing = $self->get_style_values( "spacing" );
243              
244             my @buckets;
245             foreach my $child ( $self->children ) {
246             my %opts = $self->child_opts( $child );
247              
248             push @buckets, {
249             fixed => $spacing,
250             } if @buckets; # gap
251              
252             my $base = defined $opts{force_size} ? $opts{force_size}
253             : $self->get_child_base( $child );
254             warn "Child $child did not define a base size for $self\n", $base = 0
255             unless defined $base;
256              
257             push @buckets, {
258             base => $base,
259             expand => $opts{expand},
260             child => $child,
261             };
262             }
263              
264             distribute( $self->get_total_quota( $window ), @buckets );
265              
266             foreach my $b ( @buckets ) {
267             my $child = $b->{child} or next;
268              
269             $self->set_child_window( $child, $b->{start}, $b->{value}, $window );
270             }
271              
272             $self->redraw;
273             }
274              
275             =head1 AUTHOR
276              
277             Paul Evans
278              
279             =cut
280              
281             0x55AA;