File Coverage

blib/lib/UI/Various/RichTerm/Main.pm
Criterion Covered Total %
statement 23 69 33.3
branch 0 24 4.1
condition 0 3 33.3
subroutine 8 11 72.7
pod 2 2 100.0
total 33 109 32.1


line stmt bran cond sub pod time code
1             package UI::Various::RichTerm::Main;
2              
3             # Author, Copyright and License: see end of file
4              
5             =head1 NAME
6              
7             UI::Various::RichTerm::Main - 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::Main;
14              
15             =head1 ABSTRACT
16              
17             This module is the specific implementation of the rich terminal UI. It
18             manages and hides everything specific to it.
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 7     7   69 use v5.14;
  7         25  
30 7     7   30 use strictures;
  7         11  
  7         31  
31 7     7   994 no indirect 'fatal';
  7         17  
  7         31  
32 7     7   339 no multidimensional;
  7         13  
  7         31  
33 7     7   226 use warnings 'once';
  7         11  
  7         301  
34              
35             our $VERSION = '0.23';
36              
37 7     7   2821 use Term::ReadLine;
  7         15557  
  7         211  
38              
39 7     7   39 use UI::Various::core;
  7         11  
  7         45  
40 7     7   38 use UI::Various::Main;
  7         12  
  7         5043  
41              
42             require Exporter;
43             our @ISA = qw(UI::Various::Main);
44             our @EXPORT_OK = qw();
45              
46             #########################################################################
47             #########################################################################
48              
49             =head1 FUNCTIONS
50              
51             =cut
52              
53             #########################################################################
54              
55             =head2 B<_init> - initialisation
56              
57             UI::Various::RichTerm::Main::_init($self);
58              
59             =head3 example:
60              
61             $_ = UI::Various::core::ui . '::Main::_init';
62             { no strict 'refs'; &$_($self); }
63              
64             =head3 parameters:
65              
66             $self reference to object of abstract parent class
67              
68             =head3 description:
69              
70             Set-up the rich terminal UI. (It's under L as it's
71             called before the object is re-blessed as C.)
72              
73             =cut
74              
75             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
76              
77             sub _init($)
78             {
79 0     0     my ($self) = @_;
80 0           local $_;
81 0 0         ref($self) eq __PACKAGE__ or
82             fatal('_1_may_only_be_called_from_itself', __PACKAGE__);
83              
84             # initialise ReadLine:
85 0           my $rl = Term::ReadLine->new('UI::Various', *STDIN, *STDOUT);
86 0           debug(1, __PACKAGE__, '::_init: ReadLine is ', $rl->ReadLine);
87 0           $self->{_rl} = $rl;
88 0           $rl->MinLine(3);
89              
90             # get terminal size from (GNU) ReadLine, Unix stty or fallback size 24x80:
91 0           my ($rows, $columns) = (undef, undef);
92 0           local $_;
93 0           eval { ($rows, $columns) = $rl->get_screen_size };
  0            
94             # We check both conditions even though they are both either undef or valid:
95             # uncoverable condition right
96 0 0 0       unless ($rows and $columns)
97             {
98 0           ($rows, $columns) = (24, 80);
99 0           $_ = '' . `stty -a 2>/dev/null`; # -a is POSIX, --all is not
100 0 0         m/;\s*rows\s+(\d+);\s*columns\s+(\d+);/ and
101             ($rows, $columns) = ($1, $2);
102             }
103             # can't use accessors as we're not yet correctly blessed:
104 0           $self->{max_height} = $rows;
105 0           $self->{max_width} = $columns;
106             }
107              
108             #########################################################################
109              
110             =head1 METHODS
111              
112             =cut
113              
114             #########################################################################
115              
116             =head2 B - main event loop of an application
117              
118             C's concrete implementation of
119             L
120             of an application>
121              
122             =cut
123              
124             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
125              
126             sub mainloop($)
127             {
128 0     0 1   my ($self) = @_;
129 0           my $n = $self->children;
130 0           my $i = 0; # behave like Curses::UI and Tk: 1st comes 1st
131 0           debug(1, __PACKAGE__, '::mainloop: ', $i, ' / ', $n);
132              
133 0           local $_;
134 0           while ($n > 0)
135             {
136 0           $_ = $self->child($i)->_process;
137 0           $n = $self->children;
138             # uncoverable branch false count:4
139 0 0         if (not defined $_)
    0          
    0          
    0          
140 0           { $i = $n - 1; }
141             elsif ($_ eq '+')
142 0           { $i++; }
143             elsif ($_ eq '-')
144 0           { $i--; }
145             elsif ($_ eq '0')
146 0           { $i = $n - 1; }
147 0 0         if ($i >= $n)
    0          
148 0           { $i = 0; }
149             elsif ($i < 0)
150 0           { $i = $n - 1; }
151             }
152             }
153              
154             #########################################################################
155              
156             =head2 B - get readline input
157              
158             $_ = $self->top->readline($prompt, $re_allowed, $initial_value);
159              
160             =head3 parameters:
161              
162             $self reference to object
163             $prompt string for the prompt
164             $re_allowed regular expression for allowed values
165             $initial_value initial value for input and flag for RL history
166              
167             =head3 description:
168              
169             Prompt for input and get line from L. The line will be
170             checked against the regular expression. Input is read over again until a
171             valid input is obtained, which is then returned. If the optional initial
172             value is set, it will be used passed as 2nd parameter to C
173             (I argument). It also activates storing a valid input in
174             L history.
175              
176             =head3 returns:
177              
178             valid input
179              
180             =cut
181              
182             # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
183              
184             sub readline($$$;$)
185             {
186 0     0 1   my ($self, $prompt, $re_allowed, $initial_value) = @_;
187 0           local $_ = undef;
188              
189             do
190 0           {{
191 0           $_ = $self->{_rl}->readline($prompt, $initial_value);
  0            
192             # This can only happen with non-interactive input, therefore we use
193             # die instead of fatal:
194 0 0         defined $_ or die msg('undefined_input');
195 0 0         unless (m/$re_allowed/)
196 0           { error('invalid_selection'); next; }
  0            
197 0 0         if ($initial_value)
198 0           { $self->{_rl}->addhistory($_); }
199 0           s/\r?\n$//;
200             }} until m/$re_allowed/;
201 0           return $_;
202             }
203              
204             1;
205              
206             #########################################################################
207             #########################################################################
208              
209             =head1 SEE ALSO
210              
211             L, L
212              
213             =head1 LICENSE
214              
215             Copyright (C) Thomas Dorner.
216              
217             This library is free software; you can redistribute it and/or modify it
218             under the same terms as Perl itself. See LICENSE file for more details.
219              
220             =head1 AUTHOR
221              
222             Thomas Dorner Edorner (at) cpan (dot) orgE
223              
224             =cut