File Coverage

blib/lib/UI/Various/Box.pm
Criterion Covered Total %
statement 96 96 100.0
branch 44 44 100.0
condition 12 12 100.0
subroutine 20 20 100.0
pod 7 7 100.0
total 179 179 100.0


line stmt bran cond sub pod time code
1             package UI::Various::Box;
2              
3             # Author, Copyright and License: see end of file
4              
5             =head1 NAME
6              
7             UI::Various::Box - general box widget of L
8              
9             =head1 SYNOPSIS
10              
11             use UI::Various;
12             my $main = UI::Various::main();
13             my $box = UI::Various::Box(border => 1, columns => 2, rows => 3);
14             $box->add(0, 0, UI::Various::Text->new(text => 'Hello World!'));
15             ...
16             $box->add(2, 1, UI::Various::Button->new(text => 'Quit',
17             code => sub{ exit(); }));
18             $main->window($box);
19             $main->mainloop();
20              
21             =head1 ABSTRACT
22              
23             This module defines a general box object of an application using
24             L. A box is a container with rows and columns, where each
25             field can contain exactly one other UI element. If more than one UI element
26             must be placed in a field, simply put them in another box inside of it.
27              
28             Note that the L implementation does not display a box
29             but simply prints the fields one after another, as that makes it easier to
30             understand for the visually impaired or software parsing the output. Also
31             note that a box in C is always considered to be an active element,
32             but its own active elements can only be selected after selecting the box
33             itself first. (Exception: If a box contains only one own active element, it
34             is selected directly.)
35              
36             =head1 DESCRIPTION
37              
38             Besides the common attributes inherited from C and
39             C the C widget knows the following additional
40             attributes:
41              
42             =head2 Attributes
43              
44             =over
45              
46             =cut
47              
48             #########################################################################
49              
50 8     8   78 use v5.14;
  8         24  
51 8     8   34 use strictures;
  8         12  
  8         39  
52 8     8   1245 no indirect 'fatal';
  8         33  
  8         36  
53 8     8   423 no multidimensional;
  8         13  
  8         63  
54 8     8   284 use warnings 'once';
  8         12  
  8         410  
55              
56             our $VERSION = '0.24';
57              
58 8     8   55 use UI::Various::core;
  8         9  
  8         67  
59 8     8   2798 use UI::Various::toplevel;
  8         18  
  8         428  
60 8     8   33 BEGIN { require 'UI/Various/' . UI::Various::core::using() . '/Box.pm'; }
61              
62             require Exporter;
63             our @ISA = qw(UI::Various::container);
64             our @EXPORT_OK = qw();
65              
66             #########################################################################
67              
68             =item border [rw, fixed, optional]
69              
70             a flag to indicate if the borders around the box and between its elements
71             are visible or not
72              
73             A reference passed will be dereferenced and all values will be normalised to
74             C<0> or C<1> according Perl's standard true/false conversions.
75              
76             Note that visible borders currently do not work in L as they
77             currently do not use a proper L element.
78              
79             =cut
80              
81             sub border($;$)
82             {
83             return access('border',
84 8 100   8   28 sub{ $_ = $_ ? 1 : 0; },
85 50     50 1 1683 @_);
86             }
87              
88             =item columns [rw, fixed, recommended]
89              
90             the number of columns the box contains (numbering starts with 0)
91              
92             =cut
93              
94             sub columns($;$)
95             {
96             return access('columns',
97             sub{
98 8 100 100 8   53 unless (m/^\d+$/ and $_ > 0)
99             {
100 3         10 error('parameter__1_must_be_a_positive_integer',
101             'columns');
102 3         14 $_ = 1;
103             }
104             },
105 103     103 1 359 @_);
106             }
107              
108             =item rows [rw, fixed, recommended]
109              
110             the number of rows the box contains (numbering starts with 0)
111              
112             =cut
113              
114             sub rows($;$)
115             {
116             return access('rows',
117             sub{
118 7 100 100 7   68 unless (m/^\d+$/ and $_ > 0)
119             {
120 3         9 error('parameter__1_must_be_a_positive_integer',
121             'rows');
122 3         15 $_ = 1;
123             }
124             },
125 90     90 1 352 @_);
126             }
127              
128             #########################################################################
129             #
130             # internal constants and data:
131              
132 8         589 use constant ALLOWED_PARAMETERS =>
133 8     8   51 (UI::Various::widget::COMMON_PARAMETERS, qw(border columns rows));
  8         20  
134 8     8   45 use constant DEFAULT_ATTRIBUTES => (border => 0, columns => 1, rows => 1);
  8         13  
  8         8466  
135              
136             #########################################################################
137             #########################################################################
138              
139             =back
140              
141             =head1 METHODS
142              
143             Besides the accessors (attributes) described above and the attributes and
144             methods of L and L, the
145             following additional methods are provided by the C class itself (note
146             the overloaded L method):
147              
148             =cut
149              
150             #########################################################################
151              
152             =head2 B - constructor
153              
154             see L
155             constructor for UI elements>
156              
157             =cut
158              
159             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
160              
161             sub new($;\[@$])
162             {
163 15     15 1 5979 debug(3, __PACKAGE__, '::new');
164 15         151 return construct({ DEFAULT_ATTRIBUTES },
165             '^(?:' . join('|', ALLOWED_PARAMETERS) . ')$',
166             @_);
167             }
168              
169             #########################################################################
170              
171             =head2 B - access child in specific field
172              
173             $ui_element = $box->field($row, $column);
174              
175             =head3 example:
176              
177             $element_1 = $box->field(0, 0);
178              
179             =head3 parameters:
180              
181             $row the UI element's row
182             $column the UI element's column
183              
184             =head3 description:
185              
186             This method allows accessing the UI element of a specific field of the box.
187              
188             =head3 returns:
189              
190             the UI element in the specified field of the box
191              
192             =cut
193              
194             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
195              
196             sub field($$$)
197             {
198 106     106 1 2198 my ($self, $row, $column) = @_;
199 106 100       190 exists $self->{field} or return undef;
200 104         243 return $self->{field}[$row][$column];
201             }
202              
203             #########################################################################
204              
205             =head2 B - add new children
206              
207             $ui_container->add([$row, [$column,]] $other_ui_element, ...);
208              
209             =head3 example:
210              
211             # example box using 2x2 fields:
212             $self->add(0, 0, $this);
213             $self->add($that); # using next free position 0, 1
214             $self->add(1, 0, $foo, 1, 1, $bar);
215             $self->add(1, 0, $foo, $bar); # the same but shorter
216              
217             # first three example commands combined in one using defaults:
218             $self->add($this, $that, $foo, $bar);
219              
220             =head3 parameters:
221              
222             $row the row of the box for the next UI element
223             $column the column of the box for the next UI element
224             $other_ui_element one ore more UI elements to be added to the box
225              
226             =head3 description:
227              
228             This method overloads the standard L
229             UI::Various::container|UI::Various::container/add - add new children>. It
230             adds one or more to the box. If a specific field is given (row and column),
231             this is used (unless it already contains something which produces an error).
232             Otherwise the next free field after the "current" one in the same or a later
233             row is used. Both row and column start counting with C<0>. Basically the
234             algorithm fills a box row by row from left to right. If a UI element can
235             not be placed, this is reported as error and the UI element is ignored.
236              
237             Note that as in the standard L
238             UI::Various::container|UI::Various::container/add - add new children>
239             children already having a parent are removed from their old parent first.
240              
241             =head3 returns:
242              
243             number of elements added
244              
245             =cut
246              
247             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
248              
249             sub add($@)
250             {
251 20     20 1 8343 my $self = shift;
252              
253             # sanity checks:
254 20 100       97 $self->isa(__PACKAGE__)
255             or fatal('invalid_object__1_in_call_to__2__3',
256             ref($self), __PACKAGE__, 'add');
257              
258 19         28 local $_;
259 19 100       46 unless (defined $self->{field})
260             {
261 9         21 $self->{field} = [];
262 13         38 push @{$self->{field}}, [(undef) x $self->columns]
263 9         23 foreach 1..$self->rows;
264             }
265 19         54 my ($row, $column, $number, $n) = (0, 0, 0, 0);
266 19         45 while (@_)
267             {
268 37         52 $_ = shift;
269 37 100       107 if (ref($_) eq '')
    100          
270             {
271 19 100       40 unless ($number < 2)
272             {
273 1         4 error('invalid_scalar__1_in_call_to__2__3',
274             $_, __PACKAGE__, 'add');
275 1         5 return $n;
276             }
277 18 100       83 unless (m/^\d+$/)
278             {
279 2 100       12 error('parameter__1_must_be_a_positive_integer_in_call_to__2__3',
280             $number == 0 ? 'row' : 'column', __PACKAGE__, 'add');
281 2         9 return $n;
282             }
283 16 100       61 unless ($_ < ($number == 0 ? $self->rows : $self->columns))
    100          
284             {
285 2 100       9 error('invalid_value__1_for_parameter__2_in_call_to__3__4',
286             $_, $number == 0 ? 'row' : 'column', __PACKAGE__, 'add');
287 2         14 return $n;
288             }
289 14 100       56 if ($number++ == 0)
290 9         16 { $row = $_; $column = 0; }
  9         23  
291             else
292 5         13 { $column = $_; }
293             }
294             elsif ($_->isa('UI::Various::widget'))
295             {
296 17 100 100     67 if ($number > 1 and defined $self->{field}[$row][$column])
297             {
298 1         7 error('element__1_in_call_to__2__3_already_exists',
299             $row . '/' . $column, __PACKAGE__, 'add');
300             # reset "scanner" to continue after failed explicit row/column:
301 1         2 $number = 0;
302 1         4 next;
303             }
304             # find next free field:
305 16         53 while (defined $self->{field}[$row][$column])
306             {
307 10 100       21 unless (++$column < $self->columns)
308             {
309 4         6 $column = 0;
310 4 100       10 ++$row < $self->rows or last;
311             }
312             }
313 16 100       41 unless ($row < $self->rows)
314             {
315 1         6 error('no_free_position_for__1_in_call_to__2__3',
316             ref($_), __PACKAGE__, 'add');
317 1         4 ($row, $column, $number) = (0, 0, 0);
318 1         7 next;
319             }
320 15 100       74 if ($self->SUPER::add($_))
321             {
322 14         26 $self->{field}[$row][$column] = $_;
323 14         17 $n++;
324             }
325 15         38 $number = 0; # reset "scanner" for explicit row/column
326             }
327             else
328             {
329 1         5 fatal('invalid_object__1_in_call_to__2__3',
330             ref($_), __PACKAGE__, 'add');
331             }
332             }
333 13         34 return $n;
334             }
335              
336             #########################################################################
337              
338             =head2 B - remove children
339              
340             This method overloads the standard L
341             UI::Various::container|UI::Various::container/remove - remove children>
342             using the identical interface.
343              
344             =cut
345              
346             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
347              
348             sub remove($@)
349             {
350 4     4 1 1629 my $self = shift;
351              
352 4         11 my $removed = undef;
353 4         13 foreach my $child (@_)
354             {
355 4 100       20 if (defined $self->SUPER::remove($child))
356             {
357 3         8 my $row = $self->rows;
358 3         14 while (--$row >= 0)
359             {
360 6         13 my $column = $self->columns;
361 6         20 while (--$column >= 0)
362             {
363 12 100 100     53 if (defined $self->{field}[$row][$column] and
364             $child eq $self->{field}[$row][$column])
365             {
366 3         7 $self->{field}[$row][$column] = undef;
367 3         7 $removed = $child;
368             }
369             }
370             }
371             }
372             }
373 4         14 return $removed;
374             }
375              
376             1;
377              
378             #########################################################################
379             #########################################################################
380              
381             =head1 SEE ALSO
382              
383             L
384              
385             =head1 LICENSE
386              
387             Copyright (C) Thomas Dorner.
388              
389             This library is free software; you can redistribute it and/or modify it
390             under the same terms as Perl itself. See LICENSE file for more details.
391              
392             =head1 AUTHOR
393              
394             Thomas Dorner Edorner (at) cpan (dot) orgE
395              
396             =cut