1 |
package CursesChatMainwindow; |
2 |
use strict; |
3 |
use Curses; |
4 |
use Term::ReadKey; |
5 |
use Exporter; |
6 |
our @ISA = qw/Exporter/; |
7 |
our @EXPORT = qw/printline select_buffer current_buffer list_buffers clear_buffer clear_buffer_temporaries/; |
8 |
|
9 |
our $wins; |
10 |
|
11 |
our $HEIGHT; |
12 |
our $WIDTH; |
13 |
our $MAINWIN; |
14 |
our $stdiowatcher; |
15 |
our $winchwatcher; |
16 |
|
17 |
our $current_buffer_scroll = 0; |
18 |
our $current_buffer = "status"; |
19 |
our $winbuffers = {}; |
20 |
|
21 |
our $complete_cb = sub {}; |
22 |
our $input_cb = sub {}; |
23 |
|
24 |
our %completions; |
25 |
our @history; |
26 |
our $hist_ptr = -1; |
27 |
our $inputbuffer; |
28 |
our $inputoffset = 0; |
29 |
our $cursor = 0; |
30 |
our $statusline; |
31 |
our $msgline; |
32 |
|
33 |
sub handle_resize { |
34 |
my ($wc, $hc, $wpx, $hpx) = GetTerminalSize (); |
35 |
resizeterm ($hc, $wc); |
36 |
$MAINWIN->resize ($hc, $wc); |
37 |
$HEIGHT = $hc; |
38 |
$WIDTH = $wc; |
39 |
$MAINWIN->erase; |
40 |
refresh (); |
41 |
} |
42 |
|
43 |
sub complete { |
44 |
my ($line) = @_; |
45 |
my @words; |
46 |
while ($line ne '') { |
47 |
$line =~ s/^(\S+)// |
48 |
or $line =~ s/^(\s+)//; |
49 |
push @words, $1; |
50 |
} |
51 |
my $widx = @words - 1; |
52 |
unless (@words) { $words[0] = ''; $widx = 0; } |
53 |
|
54 |
my $word = $complete_cb->($words[$widx], $widx, @words); |
55 |
$words[$widx] = defined $word ? $word : $words[$widx]; |
56 |
|
57 |
return join '', @words; |
58 |
} |
59 |
|
60 |
sub color2attr { |
61 |
my $c = $_[0]; |
62 |
my $attr; |
63 |
if ($c <= 63) { |
64 |
$attr = COLOR_PAIR($c); |
65 |
} elsif ($c <= 127) { |
66 |
$c -= 64; |
67 |
$attr = COLOR_PAIR($c) | A_BOLD; |
68 |
} elsif ($c <= 191) { |
69 |
$c -= 128; |
70 |
$attr = COLOR_PAIR($c) | A_UNDERLINE; |
71 |
} else { |
72 |
$c -= 192; |
73 |
$attr = COLOR_PAIR($c) | A_UNDERLINE | A_BOLD; |
74 |
} |
75 |
$attr |
76 |
} |
77 |
|
78 |
sub register_input_cb { |
79 |
my ($cb) = @_; |
80 |
$input_cb = $cb; |
81 |
} |
82 |
|
83 |
sub register_complete_cb { |
84 |
my ($cb) = @_; |
85 |
$complete_cb = $cb; |
86 |
} |
87 |
|
88 |
sub _draw_attr_line_at { |
89 |
my ($line, $attrline) = @_; |
90 |
|
91 |
my @lcont = @$attrline; |
92 |
my $li = 0; |
93 |
|
94 |
while (@lcont > 0) { |
95 |
my ($color, $str) = (shift @lcont, shift @lcont); |
96 |
while ($color eq 'f' or $color eq 't') { |
97 |
if ($color eq 'f') { |
98 |
($color, $str) = ($str, shift @lcont); |
99 |
$str .= " " x ($WIDTH - length ($str)); |
100 |
} elsif ($color eq 't') { |
101 |
($color, $str) = ($str, shift @lcont); |
102 |
} |
103 |
} |
104 |
|
105 |
$MAINWIN->attron (color2attr ($color)); |
106 |
|
107 |
my $sl = length $str; |
108 |
if (($li + $sl) > $WIDTH) { |
109 |
$sl = $WIDTH - $li; |
110 |
last if $sl < 0; |
111 |
} |
112 |
|
113 |
$MAINWIN->addnstr ($line, $li, (substr $str, 0, $sl), $sl); |
114 |
|
115 |
$li += $sl; |
116 |
|
117 |
$MAINWIN->attroff (color2attr ($color)); |
118 |
} |
119 |
} |
120 |
|
121 |
sub clog { |
122 |
open LOG, ">>/tmp/debuglog"; |
123 |
print LOG @_; |
124 |
close LOG; |
125 |
} |
126 |
|
127 |
sub wrap_attr_lines { |
128 |
my ($width, @lines) = @_; |
129 |
|
130 |
my @outlines; |
131 |
|
132 |
for my $line (@lines) { |
133 |
my $wrap_padding = 0; |
134 |
my @cline = @$line; |
135 |
my @oline; |
136 |
|
137 |
my $outc = 0; |
138 |
|
139 |
while (@cline) { |
140 |
my ($color, $str) = (shift @cline, shift @cline); |
141 |
while ($color =~ m/^p/ or $color eq 't') { |
142 |
if ($color =~ m/^p\s*(\d+)\s*$/) { |
143 |
$wrap_padding = $1; |
144 |
($color, $str) = ($str, shift @cline); |
145 |
} elsif ($color eq 't') { |
146 |
($color, $str) = ($str, shift @cline); |
147 |
} |
148 |
} |
149 |
|
150 |
my $strlen = length $str; |
151 |
|
152 |
if (($outc + $strlen) > $width) { |
153 |
my $thisl = $width - $outc; |
154 |
push @oline, ($color, substr $str, 0, $thisl); |
155 |
push @outlines, [@oline]; |
156 |
@oline = (); |
157 |
unshift @cline, ($color, substr $str, $thisl); |
158 |
if ($wrap_padding && ($wrap_padding + 7) < $width) { # 7 too few cols to display a sentence nicely |
159 |
unshift @cline, (0, ' ' x $wrap_padding); |
160 |
} |
161 |
$outc = 0; |
162 |
} else { |
163 |
push @oline, ($color, $str); |
164 |
$outc += $strlen; |
165 |
} |
166 |
} |
167 |
|
168 |
push @outlines, [@oline]; |
169 |
} |
170 |
|
171 |
# my $i = 0; |
172 |
# for my $line (@outlines) { |
173 |
# clog ("LINE$i: ".join ('|',@$line)."\n"); |
174 |
# $i++; |
175 |
# } |
176 |
|
177 |
@outlines; |
178 |
} |
179 |
|
180 |
sub refresh_lines { |
181 |
$MAINWIN->erase; |
182 |
|
183 |
# TODO: cache the wrapped lines until something in the buffer |
184 |
# or the window size changes |
185 |
# NOTE: cache doesn't have to be invalidated for adding new lines! |
186 |
my @revwin = @{$winbuffers->{$current_buffer} || []}; |
187 |
my (@out_lines) = reverse wrap_attr_lines ($WIDTH, @revwin); |
188 |
|
189 |
if ($current_buffer_scroll > 0) { |
190 |
if ($current_buffer_scroll > scalar (@out_lines)) { |
191 |
$current_buffer_scroll = scalar (@out_lines); |
192 |
} |
193 |
@out_lines = splice @out_lines, $current_buffer_scroll; |
194 |
clog ("SPLICE$current_buffer_scroll [".(scalar @out_lines)."]\n"); |
195 |
} |
196 |
|
197 |
_draw_attr_line_at (0, $msgline || [0, 'nothing']); |
198 |
_draw_attr_line_at ($HEIGHT - 2, $statusline || [0, 'nothing']); |
199 |
|
200 |
my $line = $HEIGHT - 3; |
201 |
while ($line >= 1) { |
202 |
my $l = shift @out_lines; |
203 |
last unless defined $l; |
204 |
_draw_attr_line_at ($line--, $l); |
205 |
} |
206 |
} |
207 |
|
208 |
sub refresh { |
209 |
my ($onlyinput) = @_; |
210 |
|
211 |
refresh_lines unless $onlyinput; |
212 |
|
213 |
$MAINWIN->move ($HEIGHT - 1, 0); |
214 |
$MAINWIN->clrtoeol (); |
215 |
|
216 |
my $padding = $WIDTH - int ($WIDTH / 1.2); |
217 |
|
218 |
if ($cursor >= ($WIDTH - $padding)) { |
219 |
my $iobuf = $inputbuffer; |
220 |
my $il = length $iobuf; |
221 |
my $ncursor = $cursor; |
222 |
my $lcursor = $cursor - int ($WIDTH / 1.2); |
223 |
$ncursor -= $lcursor; |
224 |
substr $iobuf, 0, $lcursor, ''; |
225 |
$MAINWIN->addstr ($HEIGHT - 1, 0, (substr $iobuf, 0, $WIDTH)); |
226 |
$MAINWIN->move ($HEIGHT - 1, $ncursor); |
227 |
} else { |
228 |
$MAINWIN->addstr ($HEIGHT - 1, 0, (substr $inputbuffer, 0, $WIDTH)); |
229 |
$MAINWIN->move ($HEIGHT - 1, $cursor); |
230 |
} |
231 |
$MAINWIN->refresh; |
232 |
} |
233 |
|
234 |
sub select_buffer { |
235 |
$current_buffer = $_[0]; |
236 |
$current_buffer_scroll = 0; |
237 |
refresh (); |
238 |
} |
239 |
|
240 |
sub current_buffer { |
241 |
$current_buffer |
242 |
} |
243 |
|
244 |
sub clear_buffer { |
245 |
my ($buffer) = @_; |
246 |
delete $winbuffers->{$buffer}; |
247 |
} |
248 |
|
249 |
sub clear_buffer_temporaries { |
250 |
my ($buffer) = @_; |
251 |
@{$winbuffers->{$buffer}} = grep { $_->[0] ne 't' } @{$winbuffers->{$buffer}}; |
252 |
refresh () if $buffer eq current_buffer (); |
253 |
} |
254 |
|
255 |
sub list_buffers { |
256 |
keys %$winbuffers; |
257 |
} |
258 |
|
259 |
sub printline { |
260 |
if ($_[0] eq 'statusline') { |
261 |
$statusline = $_[1]; |
262 |
} elsif ($_[0] eq 'msgline') { |
263 |
$msgline = $_[1]; |
264 |
} else { |
265 |
push @{$winbuffers->{(defined $_[0] ? $_[0] : $current_buffer)}}, $_[1]; |
266 |
} |
267 |
refresh (); |
268 |
} |
269 |
|
270 |
sub input { |
271 |
my $c = $MAINWIN->getch; |
272 |
|
273 |
my $only_input = 1; |
274 |
|
275 |
if ($c == KEY_BACKSPACE) { |
276 |
if ($cursor > 0) { |
277 |
substr $inputbuffer, --$cursor, 1, ''; |
278 |
} |
279 |
} elsif ($c == KEY_DC) { |
280 |
substr $inputbuffer, $cursor, 1, ''; |
281 |
} elsif ($c == KEY_LEFT) { |
282 |
$cursor-- if $cursor > 0; |
283 |
} elsif ($c == KEY_RIGHT) { |
284 |
$cursor++ if (($cursor + 1) <= (length $inputbuffer)); |
285 |
} elsif ($c == KEY_PPAGE) { |
286 |
$current_buffer_scroll += int ($HEIGHT / 2); |
287 |
$only_input = 0; |
288 |
} elsif ($c == KEY_NPAGE) { |
289 |
$current_buffer_scroll -= int ($HEIGHT / 2); |
290 |
$current_buffer_scroll = 0 if $current_buffer_scroll < 0; |
291 |
$only_input = 0; |
292 |
} elsif ($c == KEY_END) { |
293 |
$cursor = length $inputbuffer; |
294 |
} elsif ($c == KEY_HOME) { |
295 |
$cursor = 0; |
296 |
} elsif ($c eq "\t") { |
297 |
my $compl_line = substr $inputbuffer, 0, $cursor; |
298 |
$compl_line = complete ($compl_line); |
299 |
substr $inputbuffer, 0, $cursor, $compl_line; |
300 |
$cursor = length $compl_line; |
301 |
} elsif ($c eq "\n") { |
302 |
unshift @history, $inputbuffer; |
303 |
$input_cb->($inputbuffer); |
304 |
$inputbuffer = ""; |
305 |
$cursor = 0; |
306 |
$hist_ptr = -1; |
307 |
} elsif ($c == KEY_UP) { |
308 |
if (($hist_ptr + 1) < scalar (@history)) { |
309 |
if ($hist_ptr < 0 or $history[$hist_ptr] ne $inputbuffer) { |
310 |
if ($inputbuffer =~ /\S/) { |
311 |
unshift @history, $inputbuffer; |
312 |
$hist_ptr++; |
313 |
} |
314 |
} |
315 |
|
316 |
$hist_ptr++; |
317 |
|
318 |
$inputbuffer = $history[$hist_ptr]; |
319 |
$cursor = length $inputbuffer; |
320 |
} |
321 |
} elsif ($c == KEY_DOWN) { |
322 |
if ($hist_ptr - 1 <= -1) { |
323 |
$inputbuffer = ""; |
324 |
$cursor = 0; |
325 |
$hist_ptr = -1; |
326 |
|
327 |
} elsif (($hist_ptr - 1) >= 0) { |
328 |
if ($hist_ptr < 0 or $history[$hist_ptr] ne $inputbuffer) { |
329 |
if ($inputbuffer =~ /\S/) { |
330 |
unshift @history, $inputbuffer; |
331 |
$hist_ptr++; |
332 |
} |
333 |
} |
334 |
|
335 |
$inputbuffer = $history[--$hist_ptr]; |
336 |
$cursor = length $inputbuffer; |
337 |
} |
338 |
} else { |
339 |
if ($c > 255) { |
340 |
#d# printline (status => [0, "SPECIAL[$c]"]); |
341 |
} else { |
342 |
if (ord ($c) == 27) { |
343 |
my $nxt = $MAINWIN->getch; |
344 |
$input_cb->(undef, $nxt); |
345 |
return; |
346 |
} else { |
347 |
substr $inputbuffer, $cursor++, 0, $c; |
348 |
} |
349 |
} |
350 |
} |
351 |
|
352 |
refresh ($only_input); |
353 |
} |
354 |
|
355 |
sub init { |
356 |
my $win = $MAINWIN = Curses->new; |
357 |
cbreak; |
358 |
noecho; |
359 |
clear; |
360 |
$win->keypad (1); |
361 |
($HEIGHT, $WIDTH) = ($LINES, $COLS); |
362 |
if (has_colors ()) { |
363 |
start_color (); |
364 |
use_default_colors (); |
365 |
my $colors = ""; |
366 |
my (@ansi_tab) = qw/0 4 2 6 1 5 3 7/; |
367 |
for (my $i = 1; $i < $COLOR_PAIRS; $i++) { |
368 |
init_pair ($i, $ansi_tab[$i & 7], $i <= 7 ? -1 : $ansi_tab[$i >> 3]); |
369 |
} |
370 |
} |
371 |
$win->attron (A_NORMAL); |
372 |
$winchwatcher = AnyEvent->signal (signal => 'WINCH', cb => sub { handle_resize }); |
373 |
$stdiowatcher = AnyEvent->io (fh => \*STDIN, poll => "r", cb => sub { |
374 |
input; |
375 |
}); |
376 |
} |
377 |
|
378 |
sub end { |
379 |
endwin; |
380 |
} |
381 |
|
382 |
sub print_colors { |
383 |
my $l = []; |
384 |
for (my $i = 0; $i <= 256; $i++) { |
385 |
push @$l, $i, (sprintf "[%3d]", $i); |
386 |
if (($i + 1) % 8 == 0) { |
387 |
printline ($current_buffer => $l); |
388 |
$l = []; |
389 |
} |
390 |
} |
391 |
printline ($current_buffer => $l); |
392 |
} |
393 |
#printline ("TESTE!!!"); |
394 |
|
395 |
1; |