File Coverage

blib/lib/UI/Various/RichTerm/Dialog.pm
Criterion Covered Total %
statement 26 106 24.5
branch 0 34 0.0
condition n/a
subroutine 9 12 75.0
pod 1 1 100.0
total 36 153 23.5


line stmt bran cond sub pod time code
1             package UI::Various::RichTerm::Dialog;
2              
3             # Author, Copyright and License: see end of file
4              
5             =head1 NAME
6              
7             UI::Various::RichTerm::Dialog - 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::Dialog;
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   59 use v5.14;
  6         16  
30 6     6   26 use strictures;
  6         10  
  6         32  
31 6     6   817 no indirect 'fatal';
  6         11  
  6         34  
32 6     6   347 no multidimensional;
  6         11  
  6         22  
33 6     6   216 use warnings 'once';
  6         14  
  6         320  
34              
35             our $VERSION = '0.24';
36              
37 6     6   39 use UI::Various::core;
  6         8  
  6         46  
38 6     6   31 use UI::Various::Dialog;
  6         12  
  6         150  
39 6     6   44 use UI::Various::RichTerm::container;
  6         22  
  6         283  
40 6     6   30 use UI::Various::RichTerm::base qw(%D);
  6         9  
  6         8372  
41              
42             require Exporter;
43             our @ISA = qw(UI::Various::Dialog 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<_show> - print UI element
56              
57             $ui_element->_show;
58              
59             =head3 description:
60              
61             Show the complete dialogue by printing its title and its elements. Active
62             elements (basically everything not just simple C>)
63             are numbered to allow later interaction with them. I
64             be called from C>!>
65              
66             =cut
67              
68             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
69              
70             sub _show($)
71             {
72 0     0     debug(3, __PACKAGE__, '::_show');
73 0           my ($self) = @_;
74 0           local $_;
75              
76             # 1. gather active children:
77 0           my @active = $self->_all_active;
78 0           $self->{_active} = [ @active ];
79 0           my %reverse = ();
80 0           $reverse{$active[$_]} = $_ + 1 foreach 0..$#active;
81 0           $self->{_active_index} = \%reverse;
82              
83             # 2. determine prefixes (format string plus empty one), if applicable:
84 0           my ($pre_active, $pre_passive) = ('', '');
85 0           my $active = @active;
86 0           my $pre_len = 0;
87 0 0         if (0 < $active)
88             {
89 0           $pre_len = length($active);
90 0           $pre_active = '<%' . $pre_len . 'd> ';
91 0           $pre_len += 3;
92 0           $pre_passive = ' ' x $pre_len;
93             }
94 0           my $own_active = 0;
95 0           while ($_ = $self->child)
96 0 0         { $own_active++ if $_->can('_process'); }
97              
98             # 3. determine space requirements of children:
99 0           my $my_width = $self->{width}; # Don't use inheritance here!
100 0 0         my $content_width = defined $my_width ? $my_width : $self->max_width;
101 0           $content_width -= (2 + $pre_len); # - 2 chars border decoration
102 0 0         defined $my_width or $my_width = 1;
103 0           my $title_len = length($self->title) + 3; # + 1 decoration + 2 blanks
104 0 0         $my_width >= $title_len or $my_width = $title_len + 2;
105 0           $my_width -= (2 + $pre_len); # - 2 chars border decoration
106 0           $self->{_space} = [];
107 0           $self->{_total_height} = 2;
108 0           while ($_ = $self->child)
109             {
110 0           my ($w, $h) = $_->_prepare($content_width, $pre_len);
111 0 0         $my_width >= $w or $my_width = $w;
112 0           $self->{_total_height} += $h;
113 0           push @{$self->{_space}}, [$w, $h];
  0            
114             }
115              
116             # 4. concatenate text boxes of all children:
117 0           my $i = 0;
118 0           my @output = ();
119 0           while ($_ = $self->child)
120             {
121 0           my ($w, $h) = @{$self->{_space}[$i++]};
  0            
122 0           my $prefix = '';
123 0 0         if (0 < $own_active)
124             {
125 0           $prefix = $pre_passive;
126 0 0         if ($_->can('_process'))
127 0           { $prefix = sprintf($pre_active, $self->{_active_index}{$_}); }
128             }
129 0           push @output, split(m/\n/, $_->_show($prefix, $w, $h, $pre_active));
130             }
131              
132             # 5. print full dialogue (text box plus frame):
133 0 0         $my_width += $pre_len if $own_active;
134 0 0         my $title = $self->title ? ' ' . $self->title . ' ' : $D{W8} x 2;
135 0           print $D{W7}, $D{W8}, $title;
136 0           $_ = $my_width - $title_len;
137 0 0         print $D{W8} x ($_ > 3 ? $_ - 3 : $_), ($_ > 3 ? '<0>' : '');
    0          
138 0           print $D{W9}, "\n";
139 0           print($self->_format('', $D{W4}, '', \@output, '', $D{W6}, $my_width, 0),
140             "\n");
141 0           my $h = $self->height;
142 0 0         defined $h or $h = 0;
143 0 0         $h < $self->max_height or $h = $self->max_height;
144 0           while ($h-- > $self->{_total_height})
145 0           { print $D{W4}, ' ' x $my_width, $D{W6}, "\n"; }
146 0           print $D{W1}, $D{W2} x $my_width, $D{W3}, "\n";
147             }
148              
149             #########################################################################
150              
151             =head2 B<_process> - handle action of UI element
152              
153             $return_code = $ui_element->_process;
154              
155             =head3 description:
156              
157             Handle the action of the UI element. For a C's dialogue this means
158             a loop of printing the dialogue's elements and allowing to select one of the
159             active ones for processing until the dialogue is exited, changed or destroyed.
160              
161             =head3 returns:
162              
163             C<0> for simple exit and C after destruction
164              
165             =cut
166              
167             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
168              
169             sub _process($)
170             {
171 0     0     debug(3, __PACKAGE__, '::_process');
172 0           my ($self) = @_;
173              
174 0           my $prompt = msg('enter_selection') . ': ';
175 0           while (1)
176             {
177 0 0         if (defined $self->{_self_destruct})
178 0           { $self->_self_destruct; return undef; }
  0            
179 0           $self->_show;
180 0           local $_ = undef;
181 0           until ($_) # loop until selection of active child
182             {
183 0           $_ = $self->top->readline($prompt, qr/^(\d+)$/s);
184 0 0         if ($_ eq '0')
185 0           { $self->destroy; return 0; }
  0            
186 0 0         if ($_ > @{$self->{_active}})
  0            
187 0           { error('invalid_selection'); redo; }
  0            
188             }
189 0           $self->{_active}->[$_-1]->_process;
190             }
191             }
192              
193             #########################################################################
194              
195             =head2 B - remove dialogue from application
196              
197             C's concrete implementation of
198             L
199             from application> sets a flag for auto-destruction in C
200             - handle action of UI element>>.
201              
202             =cut
203              
204             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
205              
206             sub destroy($)
207             {
208 0     0 1   debug(2, __PACKAGE__, '::destroy');
209 0           my ($self) = @_;
210 0           $self->{_self_destruct} = 1;
211             }
212              
213             1;
214              
215             #########################################################################
216             #########################################################################
217              
218             =head1 SEE ALSO
219              
220             L, L
221              
222             =head1 LICENSE
223              
224             Copyright (C) Thomas Dorner.
225              
226             This library is free software; you can redistribute it and/or modify it
227             under the same terms as Perl itself. See LICENSE file for more details.
228              
229             =head1 AUTHOR
230              
231             Thomas Dorner Edorner (at) cpan (dot) orgE
232              
233             =cut