File Coverage

blib/lib/Tickit/Widget/Border.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, 2011-2013 -- leonerd@leonerd.org.uk
5              
6             package Tickit::Widget::Border;
7              
8 1     1   749 use strict;
  1         2  
  1         23  
9 1     1   2 use warnings;
  1         1  
  1         21  
10 1     1   3 use base qw( Tickit::SingleChildWidget );
  1         1  
  1         332  
11             use Tickit::Style;
12              
13             our $VERSION = '0.26';
14              
15             use constant WIDGET_PEN_FROM_STYLE => 1;
16              
17             =head1 NAME
18              
19             C - draw a fixed-size border around a widget
20              
21             =head1 SYNOPSIS
22              
23             use Tickit;
24             use Tickit::Widget::Border;
25             use Tickit::Widget::Static;
26              
27             my $hello = Tickit::Widget::Static->new(
28             text => "Hello, world",
29             align => "centre",
30             valign => "middle",
31             );
32              
33             my $border = Tickit::Widget::Border->new;
34              
35             $border->set_child( $hello );
36              
37             Tickit->new( root => $border )->run;
38              
39             =head1 DESCRIPTION
40              
41             This container widget holds a single child widget and implements a border by
42             using L.
43              
44             =head1 STYLE
45              
46             The default style pen is used as the widget pen.
47              
48             =cut
49              
50             =head1 CONSTRUCTOR
51              
52             =cut
53              
54             =head2 $border = Tickit::Widget::Border->new( %args )
55              
56             Constructs a new C object.
57              
58             Takes arguments having the names of any of the C methods listed below,
59             without the C prefix.
60              
61             =cut
62              
63             sub new
64             {
65             my $class = shift;
66             my %args = @_;
67             my $self = $class->SUPER::new( %args );
68              
69             $self->{"${_}_border"} = 0 for qw( top bottom left right );
70              
71             defined $args{$_} and $self->${\"set_$_"}( delete $args{$_} ) for qw(
72             border
73             h_border v_border
74             top_border bottom_border left_border right_border
75             );
76              
77             return $self;
78             }
79              
80             sub lines
81             {
82             my $self = shift;
83             my $child = $self->child;
84             return $self->top_border +
85             ( $child ? $child->requested_lines : 0 ) +
86             $self->bottom_border;
87             }
88              
89             sub cols
90             {
91             my $self = shift;
92             my $child = $self->child;
93             return $self->left_border +
94             ( $child ? $child->requested_cols : 0 ) +
95             $self->right_border;
96             }
97              
98             =head1 ACCESSSORS
99              
100             =cut
101              
102             =head2 $lines = $border->top_border
103              
104             =head2 $border->set_top_border( $lines )
105              
106             Return or set the number of lines of border at the top of the widget
107              
108             =cut
109              
110             sub top_border
111             {
112             my $self = shift;
113             return $self->{top_border};
114             }
115              
116             sub set_top_border
117             {
118             my $self = shift;
119             $self->{top_border} = $_[0];
120             $self->resized;
121             }
122              
123             =head2 $lines = $border->bottom_border
124              
125             =head2 $border->set_bottom_border( $lines )
126              
127             Return or set the number of lines of border at the bottom of the widget
128              
129             =cut
130              
131             sub bottom_border
132             {
133             my $self = shift;
134             return $self->{bottom_border};
135             }
136              
137             sub set_bottom_border
138             {
139             my $self = shift;
140             $self->{bottom_border} = $_[0];
141             $self->resized;
142             }
143              
144             =head2 $cols = $border->left_border
145              
146             =head2 $border->set_left_border( $cols )
147              
148             Return or set the number of cols of border at the left of the widget
149              
150             =cut
151              
152             sub left_border
153             {
154             my $self = shift;
155             return $self->{left_border};
156             }
157              
158             sub set_left_border
159             {
160             my $self = shift;
161             $self->{left_border} = $_[0];
162             $self->resized;
163             }
164              
165             =head2 $cols = $border->right_border
166              
167             =head2 $border->set_right_border( $cols )
168              
169             Return or set the number of cols of border at the right of the widget
170              
171             =cut
172              
173             sub right_border
174             {
175             my $self = shift;
176             return $self->{right_border};
177             }
178              
179             sub set_right_border
180             {
181             my $self = shift;
182             $self->{right_border} = $_[0];
183             $self->resized;
184             }
185              
186             =head2 $border->set_h_border( $cols )
187              
188             Set the number of cols of both horizontal (left and right) borders simultaneously
189              
190             =cut
191              
192             sub set_h_border
193             {
194             my $self = shift;
195             $self->{left_border} = $self->{right_border} = $_[0];
196             $self->resized;
197             }
198              
199             =head2 $border->set_v_border( $cols )
200              
201             Set the number of lines of both vertical (top and bottom) borders simultaneously
202              
203             =cut
204              
205             sub set_v_border
206             {
207             my $self = shift;
208             $self->{top_border} = $self->{bottom_border} = $_[0];
209             $self->resized;
210             }
211              
212             =head2 $border->set_border( $count )
213              
214             Set the number of cols or lines in all four borders simultaneously
215              
216             =cut
217              
218             sub set_border
219             {
220             my $self = shift;
221             $self->{top_border} = $self->{bottom_border} = $self->{left_border} = $self->{right_border} = $_[0];
222             $self->resized;
223             }
224              
225             ## This should come from Tickit::ContainerWidget
226             sub children_changed { shift->reshape }
227              
228             sub reshape
229             {
230             my $self = shift;
231              
232             my $window = $self->window or return;
233             my $child = $self->child or return;
234              
235             my $top = $self->top_border;
236             my $left = $self->left_border;
237              
238             my $lines = $window->lines - $top - $self->bottom_border;
239             my $cols = $window->cols - $left - $self->right_border;
240              
241             if( $lines > 0 and $cols > 0 ) {
242             if( my $childwin = $child->window ) {
243             $childwin->change_geometry( $top, $left, $lines, $cols );
244             }
245             else {
246             my $childwin = $window->make_sub( $top, $left, $lines, $cols );
247             $child->set_window( $childwin );
248             }
249             }
250             else {
251             if( $child->window ) {
252             $child->set_window( undef );
253             }
254             }
255             }
256              
257             sub render_to_rb
258             {
259             my $self = shift;
260             my ( $rb, $rect ) = @_;
261              
262             my $win = $self->window or return;
263             my $lines = $win->lines;
264             my $cols = $win->cols;
265              
266             foreach my $line ( $rect->top .. $self->top_border - 1 ) {
267             $rb->erase_at( $line, 0, $cols );
268             }
269              
270             my $left_border = $self->left_border;
271             my $right_border = $self->right_border;
272             my $right_border_at = $cols - $right_border;
273             my $bottom_border_at = $lines - $self->bottom_border;
274              
275             if( $self->child and $left_border + $right_border < $cols ) {
276             foreach my $line ( $self->top_border .. $bottom_border_at ) {
277             if( $left_border > 0 ) {
278             $rb->erase_at( $line, 0, $left_border );
279             }
280              
281             if( $right_border > 0 ) {
282             $rb->erase_at( $line, $right_border_at, $right_border );
283             }
284             }
285             }
286             else {
287             foreach my $line ( $self->top_border .. $lines - $self->bottom_border - 1 ) {
288             $rb->erase_at( $line, 0, $cols );
289             }
290             }
291              
292             foreach my $line ( $lines - $self->bottom_border .. $rect->bottom - 1 ) {
293             $rb->erase_at( $line, 0, $cols );
294             }
295             }
296              
297             =head1 AUTHOR
298              
299             Paul Evans
300              
301             =cut
302              
303             0x55AA;