File Coverage

blib/lib/UI/Various/RichTerm/Box.pm
Criterion Covered Total %
statement 26 159 16.3
branch 0 78 0.0
condition 0 12 0.0
subroutine 9 11 81.8
pod n/a
total 35 260 13.4


line stmt bran cond sub pod time code
1             package UI::Various::RichTerm::Box;
2              
3             # Author, Copyright and License: see end of file
4              
5             =head1 NAME
6              
7             UI::Various::RichTerm::Box - concrete implementation of L
8              
9             =head1 SYNOPSIS
10              
11             # This module should never be used directly!
12             # It is used indirectly via the following:
13             use UI::Various::Box;
14              
15             =head1 ABSTRACT
16              
17             This module is the specific implementation of L using
18             the rich terminal UI.
19              
20             =head1 DESCRIPTION
21              
22             The documentation of this module is only intended for developers of the
23             package itself.
24              
25             =cut
26              
27             #########################################################################
28              
29 6     6   60 use v5.14;
  6         16  
30 6     6   28 use strictures;
  6         9  
  6         28  
31 6     6   1056 no indirect 'fatal';
  6         11  
  6         25  
32 6     6   288 no multidimensional;
  6         9  
  6         24  
33 6     6   196 use warnings 'once';
  6         10  
  6         262  
34              
35             our $VERSION = '0.24';
36              
37 6     6   30 use UI::Various::core;
  6         9  
  6         40  
38 6     6   31 use UI::Various::Box;
  6         16  
  6         187  
39 6     6   2097 use UI::Various::RichTerm::container;
  6         13  
  6         295  
40 6     6   32 use UI::Various::RichTerm::base qw(%D);
  6         10  
  6         13971  
41              
42             require Exporter;
43             our @ISA = qw(UI::Various::Box UI::Various::RichTerm::container);
44             our @EXPORT_OK = qw();
45              
46             #########################################################################
47             #########################################################################
48              
49             =head1 METHODS
50              
51             =cut
52              
53             #########################################################################
54              
55             =head2 B<_prepare> - prepare UI element
56              
57             ($width, $height) = $ui_element->_prepare($content_width, $prefix_length);
58              
59             =head3 example:
60              
61             my ($w, $h) = $_->_prepare($content_width, $pre_len);
62             $width < $w and $width = $w;
63             $height += $h;
64              
65             =head3 parameters:
66              
67             $content_width preferred width of content
68             $prefix_length the length of a prefix for active UI elements
69              
70             =head3 description:
71              
72             Prepare output of the UI element by determining and returning the space it
73             wants or needs. I
74             C container elements!>
75              
76             Note that C<$content_width> initially already includes one prefix length as
77             that's the standard needed by all other UI elements.
78              
79             =head3 returns:
80              
81             width and height the UI element will require or need when printed
82              
83             =cut
84              
85             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
86              
87             sub _prepare($$$)
88             {
89 0     0     my ($self, $content_width, $prefix_length) = @_;
90 0           my ($rows, $columns) = ($self->rows, $self->columns);
91 0           local $_;
92              
93             # 1. reduce width if we have an explicit one;
94             # also include border, if applicable:
95             $content_width = $self->{width} - $prefix_length
96             if defined $self->{width}
97 0 0 0       and $content_width > $self->{width} - $prefix_length;
98 0 0         $content_width -= 2 if $self->border;
99              
100             # 2. determine active and/or marked (checkbox or radio button) columns
101             # (which need prefixes somewhere):
102 0           my @active_column = (0) x $columns;
103 0           my @marked_column = (0) x $columns;
104 0           my $active_columns = 0;
105 0           my $marked_width = 0;
106 0           foreach my $column (0..($columns - 1))
107             {
108 0           foreach (0..($rows - 1))
109             {
110 0           $_ = $self->field($_, $column);
111 0 0         if (defined $_)
112             {
113 0 0         $active_column[$column] = 1 if $_->can('_process');
114 0           my $type = ref($_);
115 0 0         my $mw = ($type =~ m/::(?:Check|Radio)$/ ? 4 :
116             0);
117 0 0         $marked_column[$column] > $mw
118             or $marked_column[$column] = $mw;
119             }
120             }
121 0 0         $active_columns++ if $active_column[$column];
122 0           $marked_width += $marked_column[$column];
123             }
124 0           $self->{_active} = \@active_column; # keep list of active columns for _show
125 0           $self->{_marked} = \@marked_column; # keep list of marked columns for _show
126              
127             # 3. determine needed width of each column for even distribution of widths:
128 0           my $text_width =
129             $content_width
130             - $prefix_length * ($active_columns - 1)
131             - $marked_width
132             - $columns + 1; # borders between columns (visible or not)
133 0 0         $text_width > $columns or $text_width = $columns;
134 0           my $even_width = int($text_width / $columns);
135 0           my @widths = ($even_width) x $columns;
136 0           my $free_space = $text_width - $even_width * $columns;
137 0           my $need_max = 0;
138 0           foreach my $column (0..($columns - 1))
139             {
140 0           my ($width, $max_width) = ($even_width, 0);
141 0           foreach my $row (0..($rows - 1))
142             {
143 0           $_ = $self->field($row, $column);
144 0 0         defined $_ or next;
145 0           my ($w, $h) = $_->_prepare($width, $prefix_length);
146 0 0         $max_width = $w if $max_width < $w;
147             }
148 0 0         if ($max_width < $even_width)
149             {
150 0           $widths[$column] = $max_width;
151 0           $free_space += $even_width - $max_width;
152             }
153             else
154 0           { $need_max++; }
155             }
156              
157             # 4. if applicable additional free space gets added to those currently
158             # needing maximum width:
159 0 0         if ($need_max < $columns)
160             {
161             # 4. (a) if no column uses even maximum grant widest one the space:
162 0 0         if (0 == $need_max)
163             {
164 0           my ($biggest, $big_width) = (0, 0);
165 0           foreach (reverse(0..($columns - 1)))
166             {
167 0 0         if ($big_width < $widths[$_])
168 0           { $biggest = $_; $big_width = $widths[$_]; }
  0            
169             }
170 0           $free_space -= ($even_width - $widths[$biggest]);
171 0           $widths[$biggest] = $even_width;
172 0           $need_max = 1;
173             }
174             # 4. (b) grant free space to one or more widest columns:
175 0           $free_space = int($free_space / $need_max);
176 0           foreach my $column (0..($columns - 1))
177             {
178 0 0         next unless $widths[$column] == $even_width;
179 0           my ($width, $max_width) = ($even_width + $free_space, 0);
180 0           foreach my $row (0..($rows - 1))
181             {
182 0           $_ = $self->field($row, $column);
183 0 0         defined $_ or next;
184 0           my ($w, $h) = $_->_prepare($width, $prefix_length);
185 0 0         $max_width = $w if $max_width < $w;
186             }
187 0           $widths[$column] = $max_width;
188             }
189             }
190 0           $self->{_widths} = \@widths; # keep computed widths for _show
191              
192             # 5. now the height of each row can be computed:
193 0           my @heights = ();
194 0           foreach my $row (0..($rows - 1))
195             {
196 0           my $max_height = 0;
197 0           foreach my $column (0..($columns - 1))
198             {
199 0           $_ = $self->field($row, $column);
200 0 0         defined $_ or next;
201 0           my ($w, $h) = $_->_prepare($widths[$column], $prefix_length);
202 0 0         $max_height = $h if $max_height < $h;
203             }
204 0           push @heights, $max_height;
205             }
206 0           $self->{_heights} = \@heights; # keep computed heights for _show
207              
208             # 6. compute the sum of each widths and heights (including prefixes and
209             # borders):
210 0           my ($w, $h) = (0, 0);
211 0           --$columns;
212 0           $w += $widths[$_] foreach (0..$columns);
213 0           $w += $prefix_length * $active_columns; # here we need the real count!
214 0           $w += $marked_width;
215 0           $w += $columns;
216 0 0         $w += 2 if $self->border;
217 0           $h += $heights[$_] foreach (0..($rows - 1));
218 0 0         $h += 2 + $rows - 1 if $self->border;
219 0           return ($w, $h);
220             }
221              
222             #########################################################################
223              
224             =head2 B<_show> - return formatted UI element
225              
226             $string = $ui_element->_show($prefix, $width, $height, $pre_active);
227              
228             =head3 example:
229              
230             my ($w, $h) = $_->_prepare($content_width, $pre_len);
231             ...
232             $_->_show(' ', $w, $h, $pre_active);
233              
234             =head3 parameters:
235              
236             $prefix text in front of first line
237             $width the width returned by _prepare above
238             $height the height returned by _prepare above
239             $pre_active format string for prefixes
240              
241             =head3 description:
242              
243             Return the formatted (rectangular) text box of the UI element. Its height
244             will be exactly as specified, unless there hasn't been enough space. The
245             weight is similarly as specified (as the widths of all possible prefixes
246             already have been returned by C
247             element>>). I
248             UI::Various::RichTerm container elements!>
249              
250             =head3 returns:
251              
252             the rectangular text box for UI element
253              
254             =cut
255              
256             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
257              
258             sub _show($$$$$)
259             {
260 0     0     my ($self, $outer_prefix, $width, $height, $pre_active) = @_;
261 0 0         my $blank = $pre_active eq '' ? '' : ' ' x length(sprintf($pre_active, 0));
262 0           local $_;
263              
264             # 1. top border:
265 0           my $text = '';
266 0 0         if ($self->border)
267             {
268 0           $text .= $D{B7};
269 0           foreach my $column (0..($self->columns - 1))
270             {
271 0 0         $text .= $D{b8} if $column > 0;
272 0           $text .= $D{B8} x $self->{_widths}[$column];
273 0           $text .= $D{B8} x $self->{_marked}[$column];
274 0 0         $text .= $D{B8} x length($blank) if $self->{_active}[$column];
275             }
276 0           $text .= $D{B9} . "\n";
277             }
278              
279 0           foreach my $row (0..($self->rows - 1))
280             {
281             # 2. intermediate border:
282 0 0 0       if ($self->border and $row > 0)
283             {
284 0           $text .= $D{b4};
285 0           foreach my $column (0..($self->columns - 1))
286             {
287 0 0         $text .= $D{b5} if $column > 0;
288 0           $text .= $D{c5} x $self->{_widths}[$column];
289 0           $text .= $D{c5} x $self->{_marked}[$column];
290 0 0         $text .= $D{c5} x length($blank) if $self->{_active}[$column];
291             }
292 0           $text .= $D{b6} . "\n";
293             }
294              
295             # now for the content of the fields, which are returned in correct
296             # size by _show (and _format):
297 0           my $h = $self->{_heights}[$row];
298             # 3. concatenate fields of columns line by line in temporary array:
299 0           my @output = ();
300 0 0         my $border = $self->border ? $D{B5} : ' ';
301 0           foreach my $column (0..($self->columns - 1))
302             {
303 0           my $w = $self->{_widths}[$column];
304 0           $_ = $self->field($row, $column);
305 0           my $prefix = '';
306 0 0         if ($self->{_active}[$column])
307             {
308 0 0 0       if (defined $_ and $_->can('_process'))
309             {
310 0           my $tl = $self->_toplevel;
311 0 0 0       if ($tl and defined $tl->{_active_index}{$_})
312             {
313 0           my $i = $tl->{_active_index}{$_};
314 0           $prefix = sprintf($pre_active, $i);
315             }
316             }
317             else
318 0           { $prefix = $blank; }
319             }
320 0 0         my @field =
321             split(m/\n/,
322             defined $_
323             ? $_->_show($prefix, $w, $h, $pre_active)
324             : $self->_format($prefix, '', '', ' ', '', '', $w, $h));
325 0 0         if ($column > 0)
326 0           { $output[$_] .= $border . $field[$_] foreach (0..$#field); }
327             else
328 0           { $output[$_] = $field[$_] foreach (0..$#field); }
329             }
330              
331             # 4. build complete row:
332 0 0         my $bl = $self->border ? $D{B4} : '';
333 0 0         my $br = $self->border ? $D{B6} : '';
334 0           $text .= $self->_format('', $bl, '', \@output, '', $br, 0, 0);
335 0           $text .= "\n";
336             }
337              
338             # 5. bottom border:
339 0 0         if ($self->border)
340             {
341 0           $text .= $D{B1};
342 0           foreach my $column (0..($self->columns - 1))
343             {
344 0 0         $text .= $D{b2} if $column > 0;
345 0           $text .= $D{B2} x $self->{_widths}[$column];
346 0           $text .= $D{B2} x $self->{_marked}[$column];
347 0 0         $text .= $D{B2} x length($blank) if $self->{_active}[$column];
348             }
349 0           $text .= $D{B3} . "\n";
350             }
351              
352             # 6. final reformatting of whole block:
353 0           $outer_prefix = ' ' x length($outer_prefix);
354 0           my @text = split m/\n/, $text;
355             return
356 0           $self->_format($outer_prefix, '', '', \@text, '', '', $width, $height);
357             }
358              
359             1;
360              
361             #########################################################################
362             #########################################################################
363              
364             =head1 SEE ALSO
365              
366             L, L
367              
368             =head1 LICENSE
369              
370             Copyright (C) Thomas Dorner.
371              
372             This library is free software; you can redistribute it and/or modify it
373             under the same terms as Perl itself. See LICENSE file for more details.
374              
375             =head1 AUTHOR
376              
377             Thomas Dorner Edorner (at) cpan (dot) orgE
378              
379             =cut