|
996
|
1 package Language::INTERCAL::Interface::Curses;
|
|
|
2
|
|
|
3 # Text (Curses) interface for sick and intercalc
|
|
|
4
|
|
|
5 # This file is part of CLC-INTERCAL
|
|
|
6
|
|
|
7 # Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved.
|
|
|
8
|
|
|
9 # CLC-INTERCAL is copyrighted software. However, permission to use, modify,
|
|
|
10 # and distribute it is granted provided that the conditions set out in the
|
|
|
11 # licence agreement are met. See files README and COPYING in the distribution.
|
|
|
12
|
|
|
13 use strict;
|
|
|
14 use vars qw($VERSION $PERVERSION);
|
|
|
15 ($VERSION) = ($PERVERSION = "CLC-INTERCAL/UI-Curses INTERCAL/Interface/Curses.pm 1.-94.-2") =~ /\s(\S+)$/;
|
|
|
16
|
|
|
17 use Carp;
|
|
|
18 use Curses;
|
|
|
19 use Language::INTERCAL::Exporter '1.-94.-2';
|
|
|
20 use Language::INTERCAL::Interface::common '1.-94.-2';
|
|
|
21 use vars qw(@ISA);
|
|
|
22 @ISA = qw(Language::INTERCAL::Interface::common);
|
|
|
23
|
|
|
24 my @savefields = qw(keypress keylist keyrows keycols lastkey
|
|
|
25 menu_byname menu_entries menu_keys menu_index
|
|
|
26 after_act in_menu in_dialog);
|
|
|
27
|
|
|
28 my %keymap = (
|
|
|
29 'Left' => KEY_LEFT,
|
|
|
30 'BackSpace' => KEY_BACKSPACE,
|
|
|
31 'Enter' => KEY_ENTER,
|
|
|
32 'Return' => "\cM",
|
|
|
33 'Linefeed' => "\cJ",
|
|
|
34 (map { ("F$_" => KEY_F($_)) } (1..12)),
|
|
|
35 (map { ("M-" . chr($_) => chr($_ + 128)) } (1..127)),
|
|
|
36 );
|
|
|
37
|
|
|
38 my %reserved = (
|
|
|
39 &KEY_LEFT => \&_move_left,
|
|
|
40 &KEY_RIGHT => \&_move_right,
|
|
|
41 &KEY_UP => \&_move_up,
|
|
|
42 &KEY_DOWN => \&_move_down,
|
|
|
43 &KEY_ENTER => \&_activate,
|
|
|
44 "\cM" => \&_activate,
|
|
|
45 "\cJ" => \&_activate,
|
|
|
46 );
|
|
|
47
|
|
|
48 sub new {
|
|
|
49 @_ == 2
|
|
|
50 or croak "Usage: Language::INTERCAL::Interface::Curses->new(SERVER)";
|
|
|
51 my ($class, $server) = @_;
|
|
|
52 $server or croak "Must provide SERVER";
|
|
|
53 initscr();
|
|
|
54 clearok(1);
|
|
|
55 noecho();
|
|
|
56 cbreak();
|
|
|
57 leaveok(0);
|
|
|
58 eval "END { eval { keypad(0) }; endwin(); print '\n' }";
|
|
|
59 keypad(1);
|
|
|
60 meta(1);
|
|
|
61 my $curse = bless {
|
|
|
62 keypress => {},
|
|
|
63 keylist => [],
|
|
|
64 keyrows => [],
|
|
|
65 keycols => [],
|
|
|
66 resize => 0,
|
|
|
67 redraw => 0,
|
|
|
68 windows => [],
|
|
|
69 pending => [],
|
|
|
70 menu_byname => {},
|
|
|
71 menu_entries => {},
|
|
|
72 menu_keys => [],
|
|
|
73 menu_index => {},
|
|
|
74 in_menu => 0,
|
|
|
75 in_dialog => 0,
|
|
|
76 wid => 0,
|
|
|
77 server => $server,
|
|
|
78 }, $class;
|
|
|
79 $server->file_listen(fileno(STDIN), sub {
|
|
|
80 my $k = getch();
|
|
|
81 while ($k ne ERR) {
|
|
|
82 push @{$curse->{pending}}, $k;
|
|
|
83 nodelay(1);
|
|
|
84 $k = getch();
|
|
|
85 }
|
|
|
86 nodelay(0);
|
|
|
87 });
|
|
|
88 $curse->_initialise;
|
|
|
89 $SIG{WINCH} = sub { $curse->{resize} = $curse->{redraw} = 1 };
|
|
|
90 $curse;
|
|
|
91 }
|
|
|
92
|
|
|
93 sub has_window { 1 }
|
|
|
94 sub is_interactive { 1 }
|
|
|
95 sub is_terminal { 1 }
|
|
|
96 sub can_paste { 0 }
|
|
|
97
|
|
|
98 sub stdread {
|
|
|
99 croak "Curses interface should not use stdread directly";
|
|
|
100 }
|
|
|
101
|
|
|
102 sub getline {
|
|
|
103 @_ == 2 or croak "Usage: Curses->getline(PROMPT)";
|
|
|
104 my ($curse, $prompt) = @_;
|
|
|
105 # XXX this is just a draft implementation so there is some way of
|
|
|
106 # XXX executing a WRITE IN - it's not meant to be the final form
|
|
|
107 my $v = ' ' x ($COLS - 10);
|
|
|
108 my @def = (
|
|
|
109 'vstack', border => 2, data =>
|
|
|
110 ['text', value => $prompt, align => 'c'],
|
|
|
111 ['text', value => $v, align => 'l', name => '__getline'],
|
|
|
112 );
|
|
|
113 my $window = $curse->window("Program input", undef, \@def);
|
|
|
114 $curse->set_text('__getline', '');
|
|
|
115 my $line = '';
|
|
|
116 $curse->{in_dialog} = \$line;
|
|
|
117 my $ok = 1;
|
|
|
118 $curse->{keypress}{"\c["} = {
|
|
|
119 hidden => 1,
|
|
|
120 action => sub { $curse->{running} = 0; $ok = 0 },
|
|
|
121 enabled => 1,
|
|
|
122 };
|
|
|
123 $curse->{keypress}{$_} = {
|
|
|
124 hidden => 1,
|
|
|
125 action => sub {
|
|
|
126 $line eq '' and return;
|
|
|
127 chop $line;
|
|
|
128 $curse->set_text('__getline', $line);
|
|
|
129 },
|
|
|
130 enabled => 1,
|
|
|
131 } for (KEY_BACKSPACE, "\cH");
|
|
|
132 my $or = $curse->{running};
|
|
|
133 $curse->run;
|
|
|
134 $curse->close($window);
|
|
|
135 $curse->{running} = $or;
|
|
|
136 $ok ? "$line\n" : undef;
|
|
|
137 }
|
|
|
138
|
|
|
139 sub file_dialog {
|
|
|
140 @_ == 5 or croak "Usage: Curses->file_dialog(TITLE, NEW?, OK, CANCEL)";
|
|
|
141 my ($curse, $title, $new, $ok, $cancel) = @_;
|
|
|
142 # XXX this is just a draft implementation so there is some way of
|
|
|
143 # XXX getting a file name - it's not meand to be the final form
|
|
|
144 return $curse->getline($title);
|
|
|
145 }
|
|
|
146
|
|
|
147 sub alter_data {
|
|
|
148 @_ == 3 or croak "Usage: Curses->alter_data(WINDOW, DATA)";
|
|
|
149 croak "Augment not implemented for Curses"; # XXX
|
|
|
150 }
|
|
|
151
|
|
|
152 sub window {
|
|
|
153 @_ == 4 || @_ == 5 || @_ == 6
|
|
|
154 or croak "Usage: Curses->window(NAME, DESTROY, DEFINITION "
|
|
|
155 . "[, MENUS [, ACT]])";
|
|
|
156 my ($curse, $name, $destroy, $def, $menus, $act) = @_;
|
|
|
157 $curse->{after_act} = $act;
|
|
|
158 my $window = _window($curse, $name, $def, $menus);
|
|
|
159 _place($window, 0, COLS, 0, LINES);
|
|
|
160 _finish_window($curse, $window);
|
|
|
161 &{$window->{show}}($curse, $window);
|
|
|
162 $window;
|
|
|
163 }
|
|
|
164
|
|
|
165 sub _window {
|
|
|
166 my ($curse, $name, $def, $menus, $act) = @_;
|
|
|
167 $curse->{menu_byname} = {};
|
|
|
168 $curse->{menu_entries} = {};
|
|
|
169 $curse->{menu_keys} = [];
|
|
|
170 $curse->{menu_index} = {};
|
|
|
171 my $wid = ++$curse->{wid};
|
|
|
172 if (defined $menus) {
|
|
|
173 $curse->_parse_menus($wid, @$menus);
|
|
|
174 my @def = (
|
|
|
175 'vstack', border => 0, data =>
|
|
|
176 ['hstack', border => 1, data => @{$curse->{menu_keys}}, ],
|
|
|
177 $def,
|
|
|
178 );
|
|
|
179 $def = \@def;
|
|
|
180 }
|
|
|
181 $curse->{keypress} = {};
|
|
|
182 $curse->{keylist} = [];
|
|
|
183 my $window = $curse->_parse_def($wid, @$def);
|
|
|
184 $window->{wid} = $wid;
|
|
|
185 $window;
|
|
|
186 }
|
|
|
187
|
|
|
188 sub _finish_window {
|
|
|
189 my ($curse, $window) = @_;
|
|
|
190 $curse->{keyrows} = [];
|
|
|
191 $curse->{keycols} = [];
|
|
|
192 $curse->{lastkey} = [0, 0];
|
|
|
193 if (@{$curse->{keylist}}) {
|
|
|
194 $curse->{keylist} =
|
|
|
195 [ sort { $a->{y} <=> $b->{y} || $a->{x} <=> $b->{x} }
|
|
|
196 @{$curse->{keylist}} ];
|
|
|
197 for (my $kp = 0; $kp < @{$curse->{keylist}}; $kp++) {
|
|
|
198 my $k = $curse->{keylist}[$kp];
|
|
|
199 push @{$curse->{keyrows}[$k->{y}]}, $kp;
|
|
|
200 push @{$curse->{keycols}[$k->{x}]}, $kp;
|
|
|
201 }
|
|
|
202 my $nmenu = @{$curse->{menu_keys} || []};
|
|
|
203 $curse->{lastkey}[1] = $curse->{keylist}[$nmenu];
|
|
|
204 $curse->{lastkey}[0] = $nmenu;
|
|
|
205 }
|
|
|
206 push @{$curse->{windows}}, [$window, @$curse{@savefields}];
|
|
|
207 $curse->{in_menu} = 0;
|
|
|
208 $curse->{acter_act} = 0;
|
|
|
209 $window;
|
|
|
210 }
|
|
|
211
|
|
|
212 sub show {
|
|
|
213 @_ == 2 or croak "Usage: Curses->show(WINDOW)";
|
|
|
214 my ($curse, $window) = @_;
|
|
|
215 &{$window->{show}}($curse, $window);
|
|
|
216 }
|
|
|
217
|
|
|
218 sub enable {
|
|
|
219 @_ == 2 or croak "Usage: Curses->enable(WINDOW)";
|
|
|
220 my ($curse, $window) = @_;
|
|
|
221 $window->{enabled} = 1;
|
|
|
222 $curse->{redraw} = 1;
|
|
|
223 }
|
|
|
224
|
|
|
225 sub disable {
|
|
|
226 @_ == 2 or croak "Usage: Curses->disable(WINDOW)";
|
|
|
227 my ($curse, $window) = @_;
|
|
|
228 $window->{enabled} = 0;
|
|
|
229 $curse->{redraw} = 1;
|
|
|
230 }
|
|
|
231
|
|
|
232 sub update {
|
|
|
233 @_ == 1 or croak "Usage: Curses->update";
|
|
|
234 my ($curse) = @_;
|
|
|
235 refresh();
|
|
|
236 }
|
|
|
237
|
|
|
238 sub start {
|
|
|
239 @_ == 1 or croak "Usage: Curses->start";
|
|
|
240 refresh();
|
|
|
241 }
|
|
|
242
|
|
|
243 sub run {
|
|
|
244 @_ == 1 or croak "Usage: Curses->run";
|
|
|
245 my ($curse) = @_;
|
|
|
246 $curse->{running} = 1;
|
|
|
247 refresh();
|
|
|
248 nodelay(0);
|
|
|
249 while ($curse->{running}) {
|
|
|
250 if ($curse->{resize}) {
|
|
|
251 $curse->{resize} = $curse->{redraw} = 0;
|
|
|
252 endwin();
|
|
|
253 clearok(1);
|
|
|
254 $curse->_redraw(1);
|
|
|
255 } elsif ($curse->{redraw}) {
|
|
|
256 $curse->{redraw} = 0;
|
|
|
257 $curse->_redraw(0);
|
|
|
258 }
|
|
|
259 cbreak();
|
|
|
260 meta(1);
|
|
|
261 while (! @{$curse->{pending}}) {
|
|
|
262 refresh();
|
|
|
263 $curse->{server}->progress;
|
|
|
264 }
|
|
|
265 my $key = shift @{$curse->{pending}};
|
|
|
266 if ($key eq "\c[") {
|
|
|
267 if (@{$curse->{pending}}) {
|
|
|
268 $key = shift @{$curse->{pending}};
|
|
|
269 $key = chr(ord($key) | 0x80);
|
|
|
270 }
|
|
|
271 }
|
|
|
272 if (exists $reserved{$key}) {
|
|
|
273 &{$reserved{$key}}($curse);
|
|
|
274 next;
|
|
|
275 }
|
|
|
276 if (exists $curse->{keypress}{$key}) {
|
|
|
277 $key = $curse->{keypress}{$key};
|
|
|
278 next unless $key->{enabled};
|
|
|
279 if ($curse->{lastkey}[1] != $key && ! $key->{hidden}) {
|
|
|
280 my $ok = $curse->{lastkey}[1];
|
|
|
281 $curse->{lastkey}[1] = $key;
|
|
|
282 for (my $kp = 0; $kp < @{$curse->{keylist}}; $kp++) {
|
|
|
283 next if $curse->{keylist}[$kp] != $key;
|
|
|
284 $curse->{lastkey}[0] = $kp;
|
|
|
285 }
|
|
|
286 $curse->show($ok);
|
|
|
287 }
|
|
|
288 $curse->show($key) unless $key->{hidden};
|
|
|
289 $curse->{server}->progress(0) if ! @{$curse->{pending}};
|
|
|
290 refresh() if ! @{$curse->{pending}};
|
|
|
291 &{$key->{action}};
|
|
|
292 $curse->{server}->progress(0) if ! @{$curse->{pending}};
|
|
|
293 refresh() if ! @{$curse->{pending}};
|
|
|
294 next;
|
|
|
295 }
|
|
|
296 if ($key =~ /^[[:print:]]$/ && $curse->{in_dialog}) {
|
|
|
297 ${$curse->{in_dialog}} .= $key;
|
|
|
298 $curse->set_text('__getline', ${$curse->{in_dialog}});
|
|
|
299 $curse->update;
|
|
|
300 next;
|
|
|
301 }
|
|
|
302 }
|
|
|
303 }
|
|
|
304
|
|
|
305 sub stop {
|
|
|
306 @_ == 1 or croak "Usage: Curses->stop";
|
|
|
307 my ($curse) = @_;
|
|
|
308 $curse->{running} = 0;
|
|
|
309 }
|
|
|
310
|
|
|
311 sub pending_events {
|
|
|
312 @_ == 1 or croak "Usage: Curses->pending_events";
|
|
|
313 my ($curse) = @_;
|
|
|
314 if (! @{$curse->{pending}}) {
|
|
|
315 $curse->{server}->progress(0);
|
|
|
316 cbreak();
|
|
|
317 }
|
|
|
318 return @{$curse->{pending}} != 0;
|
|
|
319 }
|
|
|
320
|
|
|
321 sub _activate {
|
|
|
322 my ($curse) = @_;
|
|
|
323 if ($curse->{in_dialog}) {
|
|
|
324 $curse->{running} = 0;
|
|
|
325 return;
|
|
|
326 }
|
|
|
327 return unless $curse->{lastkey}[1];
|
|
|
328 return unless $curse->{lastkey}[1]->{enabled};
|
|
|
329 &{$curse->{lastkey}[1]->{action}};
|
|
|
330 }
|
|
|
331
|
|
|
332 sub _move_left {
|
|
|
333 my ($curse) = @_;
|
|
|
334 if ($curse->{in_menu}) {
|
|
|
335 # close this menu, then open the one on the left
|
|
|
336 $curse->close($curse->{in_menu});
|
|
|
337 $curse->{in_menu} = 0;
|
|
|
338 return unless $curse->{lastkey}[1];
|
|
|
339 _move_left($curse);
|
|
|
340 _activate($curse);
|
|
|
341 return;
|
|
|
342 }
|
|
|
343 return unless $curse->{lastkey}[1];
|
|
|
344 my $i = $curse->{lastkey}[0];
|
|
|
345 my $k = $curse->{lastkey}[1];
|
|
|
346 my $r = $curse->{keyrows}[$k->{y}];
|
|
|
347 my $ok = $curse->{lastkey}[1];
|
|
|
348 if ($r->[0] == $i) {
|
|
|
349 $i = $#$r;
|
|
|
350 } else {
|
|
|
351 my $j = 1;
|
|
|
352 $j++ while $j < @$r && $r->[$j] != $i;
|
|
|
353 $j--;
|
|
|
354 $i = $j;
|
|
|
355 }
|
|
|
356 $curse->{lastkey}[0] = $r->[$i];
|
|
|
357 $curse->{lastkey}[1] = $curse->{keylist}[$r->[$i]];
|
|
|
358 $curse->show($ok);
|
|
|
359 $curse->show($curse->{lastkey}[1]);
|
|
|
360 }
|
|
|
361
|
|
|
362 sub _move_right {
|
|
|
363 my ($curse) = @_;
|
|
|
364 if ($curse->{in_menu}) {
|
|
|
365 # close this menu, then open the one on the left
|
|
|
366 $curse->close($curse->{in_menu});
|
|
|
367 $curse->{in_menu} = 0;
|
|
|
368 return unless $curse->{lastkey}[1];
|
|
|
369 _move_right($curse);
|
|
|
370 _activate($curse);
|
|
|
371 return;
|
|
|
372 }
|
|
|
373 return unless $curse->{lastkey}[1];
|
|
|
374 my $i = $curse->{lastkey}[0];
|
|
|
375 my $k = $curse->{lastkey}[1];
|
|
|
376 my $r = $curse->{keyrows}[$k->{y}];
|
|
|
377 my $ok = $curse->{lastkey}[1];
|
|
|
378 if ($r->[-1] == $i) {
|
|
|
379 $i = 0;
|
|
|
380 } else {
|
|
|
381 my $j = $#$r;
|
|
|
382 $j-- while $j >= 0 && $r->[$j] != $i;
|
|
|
383 $j++;
|
|
|
384 $i = $j;
|
|
|
385 }
|
|
|
386 $curse->{lastkey}[0] = $r->[$i];
|
|
|
387 $curse->{lastkey}[1] = $curse->{keylist}[$r->[$i]];
|
|
|
388 $curse->show($ok);
|
|
|
389 $curse->show($curse->{lastkey}[1]);
|
|
|
390 }
|
|
|
391
|
|
|
392 sub _move_up {
|
|
|
393 my ($curse) = @_;
|
|
|
394 return unless $curse->{lastkey}[1];
|
|
|
395 my $nmenu = @{$curse->{menu_keys} || []};
|
|
|
396 my $i = $curse->{lastkey}[0];
|
|
|
397 return if $i < $nmenu;
|
|
|
398 my $k = $curse->{lastkey}[1];
|
|
|
399 my $r = $curse->{keycols}[$k->{x}];
|
|
|
400 my $ok = $curse->{lastkey}[1];
|
|
|
401 my $idx = 0;
|
|
|
402 $idx++ while $idx < @$r && $r->[$idx] < $nmenu;
|
|
|
403 if ($r->[$idx] == $i) {
|
|
|
404 $i = $#$r;
|
|
|
405 } else {
|
|
|
406 my $j = 1;
|
|
|
407 $j++ while $j < @$r && $r->[$j] != $i;
|
|
|
408 $j--;
|
|
|
409 $i = $j;
|
|
|
410 }
|
|
|
411 $curse->{lastkey}[0] = $r->[$i];
|
|
|
412 $curse->{lastkey}[1] = $curse->{keylist}[$r->[$i]];
|
|
|
413 $curse->show($ok);
|
|
|
414 $curse->show($curse->{lastkey}[1]);
|
|
|
415 }
|
|
|
416
|
|
|
417 sub _down_until {
|
|
|
418 my ($curse, $until) = @_;
|
|
|
419 return unless $curse->{lastkey}[1];
|
|
|
420 my $i = $curse->{lastkey}[0];
|
|
|
421 do {
|
|
|
422 _move_down($curse);
|
|
|
423 } until $curse->{lastkey}[0] == $i
|
|
|
424 || $curse->{lastkey}[1]->{value} =~ $until;
|
|
|
425 }
|
|
|
426
|
|
|
427 sub _move_down {
|
|
|
428 my ($curse) = @_;
|
|
|
429 return unless $curse->{lastkey}[1];
|
|
|
430 my $i = $curse->{lastkey}[0];
|
|
|
431 my $nmenu = @{$curse->{menu_keys} || []};
|
|
|
432 if ($i < $nmenu) {
|
|
|
433 # open this menu
|
|
|
434 _activate($curse);
|
|
|
435 return;
|
|
|
436 }
|
|
|
437 my $k = $curse->{lastkey}[1];
|
|
|
438 my $r = $curse->{keycols}[$k->{x}];
|
|
|
439 my $ok = $curse->{lastkey}[1];
|
|
|
440 my $idx = 0;
|
|
|
441 $idx++ while $idx < @$r && $r->[$idx] < $nmenu;
|
|
|
442 if ($r->[-1] == $i) {
|
|
|
443 $i = $idx;
|
|
|
444 } else {
|
|
|
445 my $j = $#$r;
|
|
|
446 $j-- while $j >= 0 && $r->[$j] != $i;
|
|
|
447 $j++;
|
|
|
448 $i = $j;
|
|
|
449 }
|
|
|
450 $curse->{lastkey}[0] = $r->[$i];
|
|
|
451 $curse->{lastkey}[1] = $curse->{keylist}[$r->[$i]];
|
|
|
452 $curse->show($ok);
|
|
|
453 $curse->show($curse->{lastkey}[1]);
|
|
|
454 }
|
|
|
455
|
|
|
456 sub _redraw {
|
|
|
457 my ($curse, $place) = @_;
|
|
|
458 erase();
|
|
|
459 $@ = '';
|
|
|
460 for my $w (@{$curse->{windows}}) {
|
|
|
461 if ($place) {
|
|
|
462 eval { _place($w->[0], 0, $COLS, 0, $LINES) };
|
|
|
463 last if $@;
|
|
|
464 }
|
|
|
465 &{$w->[0]{show}}($curse, $w->[0]);
|
|
|
466 }
|
|
|
467 if ($@) {
|
|
|
468 clearok(1);
|
|
|
469 erase();
|
|
|
470 my $line = 0;
|
|
|
471 for my $s (split(/\n/, $@)) {
|
|
|
472 addstr($line++, 0, $s) if $line < $LINES;
|
|
|
473 }
|
|
|
474 }
|
|
|
475 refresh();
|
|
|
476 }
|
|
|
477
|
|
|
478 sub _offset {
|
|
|
479 my ($window, $x, $y) = @_;
|
|
|
480 $window->{x} += $x;
|
|
|
481 $window->{y} += $y;
|
|
|
482 return unless exists $window->{children};
|
|
|
483 for my $child (@{$window->{children}}) {
|
|
|
484 _offset($child, $x, $y);
|
|
|
485 }
|
|
|
486 }
|
|
|
487
|
|
|
488 sub _place {
|
|
|
489 my ($window, $x, $width, $y, $height) = @_;
|
|
|
490 my $diff = $width - $window->{width};
|
|
|
491 $diff = 0 if $diff < 0;
|
|
|
492 $x += int($diff / 2);
|
|
|
493 $window->{x} ||= 0;
|
|
|
494 $diff = $height - $window->{height};
|
|
|
495 $diff = 0 if $diff < 0;
|
|
|
496 $y += int($diff / 2);
|
|
|
497 $window->{y} ||= 0;
|
|
|
498 _offset($window, $x - $window->{x}, $y - $window->{y});
|
|
|
499 }
|
|
|
500
|
|
|
501 sub close {
|
|
|
502 @_ == 2 or croak "Usage: Curses->close(WINDOW)";
|
|
|
503 my ($curse, $window) = @_;
|
|
|
504 $curse->_close($window->{wid});
|
|
|
505 my @nw = grep { $_->[0] != $window } @{$curse->{windows}};
|
|
|
506 $curse->{windows} = \@nw;
|
|
|
507 if (@nw) {
|
|
|
508 my $w;
|
|
|
509 ($w, @$curse{@savefields}) = @{$nw[-1]};
|
|
|
510 } else {
|
|
|
511 @$curse{@savefields} =
|
|
|
512 ({}, {}, [], [], [0, 0], {}, {}, [], {}, 0, undef);
|
|
|
513 clearok(1);
|
|
|
514 $curse->_initialise;
|
|
|
515 }
|
|
|
516 $curse->_redraw(0);
|
|
|
517 }
|
|
|
518
|
|
|
519 sub _extend_width {
|
|
|
520 my ($e, $cw) = @_;
|
|
|
521 return if $e->{width} >= $cw;
|
|
|
522 my $diff = $cw - $e->{width};
|
|
|
523 $e->{width} = $cw;
|
|
|
524 return unless exists $e->{children};
|
|
|
525 my $d0 = int($diff / scalar @{$e->{colwidth}});
|
|
|
526 my $d1 = $diff % scalar @{$e->{colwidth}};
|
|
|
527 my $d = 0;
|
|
|
528 my @d = ();
|
|
|
529 for (my $c = 0; $c < @{$e->{colwidth}}; $c++) {
|
|
|
530 $d[$c] = $d;
|
|
|
531 $d += $d0 + (($c < $d1) ? 1 : 0);
|
|
|
532 $e->{colwidth}[$c] += $d0 + (($c < $d1) ? 1 : 0);
|
|
|
533 }
|
|
|
534 for my $child (@{$e->{children}}) {
|
|
|
535 my ($c0, $c1, $r0, $r1) = @{$child->{table}};
|
|
|
536 $d = -$e->{border};
|
|
|
537 for (my $c = $c0; $c < $c1; $c++) {
|
|
|
538 $d += $e->{colwidth}[$c] + $e->{border};
|
|
|
539 }
|
|
|
540 _extend_width($child, $d);
|
|
|
541 _offset($child, $d[$c0], 0);
|
|
|
542 }
|
|
|
543 }
|
|
|
544
|
|
|
545 sub _extend_height {
|
|
|
546 my ($e, $rh) = @_;
|
|
|
547 return if $e->{height} >= $rh;
|
|
|
548 my $diff = $rh - $e->{height};
|
|
|
549 $e->{height} = $rh;
|
|
|
550 return unless exists $e->{children};
|
|
|
551 my $d0 = int($diff / scalar @{$e->{rowheight}});
|
|
|
552 my $d1 = $diff % scalar @{$e->{rowheight}};
|
|
|
553 my $d = 0;
|
|
|
554 my @d = ();
|
|
|
555 for (my $r = 0; $r < @{$e->{rowheight}}; $r++) {
|
|
|
556 $d[$r] = $d;
|
|
|
557 $d += $d0 + (($r < $d1) ? 1 : 0);
|
|
|
558 $e->{rowheight}[$r] += $d0 + (($r < $d1) ? 1 : 0);
|
|
|
559 }
|
|
|
560 for my $child (@{$e->{children}}) {
|
|
|
561 my ($c0, $c1, $r0, $r1) = @{$child->{table}};
|
|
|
562 $d = -$e->{border};
|
|
|
563 for (my $r = $r0; $r < $r1; $r++) {
|
|
|
564 $d += $e->{rowheight}[$r] + $e->{border};
|
|
|
565 }
|
|
|
566 _extend_height($child, $d);
|
|
|
567 _offset($child, 0, $d[$r0]);
|
|
|
568 }
|
|
|
569 }
|
|
|
570
|
|
|
571 sub _make_table {
|
|
|
572 my ($curse, $rows, $cols, $elements, $border, $augment) = @_;
|
|
|
573 my @width = (0) x $cols;
|
|
|
574 my @height = (0) x $rows;
|
|
|
575 $border = $border ? 1 : 0;
|
|
|
576 # try to determine row/column sizes using one cell elements
|
|
|
577 for my $te (@$elements) {
|
|
|
578 my ($e, $c0, $c1, $r0, $r1) = @$te;
|
|
|
579 $width[$c0] = $e->{width}
|
|
|
580 if $c0 + 1 == $c1 && $width[$c0] < $e->{width};
|
|
|
581 $height[$r0] = $e->{height}
|
|
|
582 if $r0 + 1 == $r1 && $height[$r0] < $e->{height};
|
|
|
583 }
|
|
|
584 # now adjust it for multirow/multicolumn
|
|
|
585 for my $te (@$elements) {
|
|
|
586 my ($e, $c0, $c1, $r0, $r1) = @$te;
|
|
|
587 if ($c1 - $c0 > 1) {
|
|
|
588 my $cw = ($c1 - $c0 - 1) * $border;
|
|
|
589 for (my $c = $c0; $c < $c1; $c++) {
|
|
|
590 $cw += $width[$c];
|
|
|
591 }
|
|
|
592 if ($cw < $e->{width}) {
|
|
|
593 my $diff = $e->{width} - $cw;
|
|
|
594 my $d0 = int($diff / ($c1 - $c0));
|
|
|
595 my $d1 = $diff % ($c1 - $c0);
|
|
|
596 for (my $c = $c0; $c < $c1; $c++) {
|
|
|
597 $width[$c] += $d0;
|
|
|
598 $width[$c] ++ if $c < $d1;
|
|
|
599 }
|
|
|
600 }
|
|
|
601 }
|
|
|
602 if ($r1 - $r0 > 1) {
|
|
|
603 my $rh = ($r1 - $r0 - 1) * $border;
|
|
|
604 for (my $r = $r0; $r < $r1; $r++) {
|
|
|
605 $rh += $height[$r];
|
|
|
606 }
|
|
|
607 if ($rh < $e->{height}) {
|
|
|
608 my $diff = $e->{height} - $rh;
|
|
|
609 my $d0 = int($diff / ($r1 - $r0));
|
|
|
610 my $d1 = $diff % ($r1 - $r0);
|
|
|
611 for (my $r = $r0; $r < $r1; $r++) {
|
|
|
612 $height[$r] += $d0;
|
|
|
613 $height[$r] ++ if $r < $d1;
|
|
|
614 }
|
|
|
615 }
|
|
|
616 }
|
|
|
617 }
|
|
|
618 # determine total window size and cell starting points
|
|
|
619 my $width = $border;
|
|
|
620 my @x = ();
|
|
|
621 for (my $c = 0; $c < $cols; $c++) {
|
|
|
622 $x[$c] = $width;
|
|
|
623 $width += $width[$c] + $border;
|
|
|
624 }
|
|
|
625 my $height = $border;
|
|
|
626 my @y = ();
|
|
|
627 for (my $r = 0; $r < $rows; $r++) {
|
|
|
628 $y[$r] = $height;
|
|
|
629 $height += $height[$r] + $border;
|
|
|
630 }
|
|
|
631 # place all elements and extend them to fill cell if required
|
|
|
632 my @children = ();
|
|
|
633 for my $te (@$elements) {
|
|
|
634 my ($e, $c0, $c1, $r0, $r1) = @$te;
|
|
|
635 _offset($e, $x[$c0], $y[$r0]);
|
|
|
636 my $cw = ($c1 - $c0 - 1) * $border;
|
|
|
637 for (my $c = $c0; $c < $c1; $c++) {
|
|
|
638 $cw += $width[$c];
|
|
|
639 }
|
|
|
640 _extend_width($e, $cw);
|
|
|
641 my $rh = ($r1 - $r0 - 1) * $border;
|
|
|
642 for (my $r = $r0; $r < $r1; $r++) {
|
|
|
643 $rh += $height[$r];
|
|
|
644 }
|
|
|
645 _extend_height($e, $rh);
|
|
|
646 $e->{table} = [$c0, $c1, $r0, $r1];
|
|
|
647 push @children, $e;
|
|
|
648 }
|
|
|
649 # ready to go...
|
|
|
650 return {
|
|
|
651 type => 'table',
|
|
|
652 width => $width,
|
|
|
653 height => $height,
|
|
|
654 colwidth => \@width,
|
|
|
655 rowheight => \@height,
|
|
|
656 show => \&_show_table,
|
|
|
657 children => \@children,
|
|
|
658 border => $border,
|
|
|
659 };
|
|
|
660 }
|
|
|
661
|
|
|
662 sub _show_table {
|
|
|
663 my ($curse, $table) = @_;
|
|
|
664 $table->{type} eq 'table' or die "Internal error";
|
|
|
665 # draw border, if required
|
|
|
666 # XXX multirow fields may show '+' where '|' should be
|
|
|
667 if ($table->{border}) {
|
|
|
668 my $y = $table->{y};
|
|
|
669 my $row = 0;
|
|
|
670 for my $rh (@{$table->{rowheight}}, 0) {
|
|
|
671 move($y, $table->{x});
|
|
|
672 my $col = 0;
|
|
|
673 for my $cw (@{$table->{colwidth}}, 0) {
|
|
|
674 my $plus = '-';
|
|
|
675 for my $e (@{$table->{children}}) {
|
|
|
676 next if $e->{table}[0] != $col && $e->{table}[1] != $col;
|
|
|
677 next if $e->{table}[2] != $row && $e->{table}[3] != $row;
|
|
|
678 $plus = '+';
|
|
|
679 last;
|
|
|
680 }
|
|
|
681 addstr($plus . ('-' x $cw));
|
|
|
682 $col++;
|
|
|
683 }
|
|
|
684 $y++;
|
|
|
685 for (my $x = 0; $x < $rh; $x++) {
|
|
|
686 move($y, $table->{x});
|
|
|
687 for my $cw (@{$table->{colwidth}}, 0) {
|
|
|
688 addstr('|' . (' ' x $cw));
|
|
|
689 }
|
|
|
690 $y++;
|
|
|
691 }
|
|
|
692 $row++;
|
|
|
693 }
|
|
|
694 }
|
|
|
695 # draw elements
|
|
|
696 for my $e (@{$table->{children}}) {
|
|
|
697 &{$e->{show}}($curse, $e);
|
|
|
698 }
|
|
|
699 }
|
|
|
700
|
|
|
701 sub _make_text {
|
|
|
702 my ($curse, $value, $align, $size) = @_;
|
|
|
703 $size ||= length $value;
|
|
|
704 return {
|
|
|
705 type => 'text',
|
|
|
706 width => $size,
|
|
|
707 height => 1,
|
|
|
708 value => $value,
|
|
|
709 enabled => 1,
|
|
|
710 align => $align,
|
|
|
711 show => \&_show_text_key,
|
|
|
712 };
|
|
|
713 }
|
|
|
714
|
|
|
715 sub _show_text_key {
|
|
|
716 my ($curse, $text) = @_;
|
|
|
717 $text->{type} eq 'text' || $text->{type} eq 'key'
|
|
|
718 or die "Internal error";
|
|
|
719 move($text->{y}, $text->{x});
|
|
|
720 my $diff0 = $text->{width} - length($text->{value});
|
|
|
721 my $diff1 = int($diff0 / 2);
|
|
|
722 my $diff2 = $diff0 - $diff1;
|
|
|
723 eval { attrset(A_NORMAL) };
|
|
|
724 eval { attron(A_BOLD) } if $text->{enabled};
|
|
|
725 eval { attron(A_REVERSE) } if $text == $curse->{lastkey}[1];
|
|
|
726 addstr(' ' x $diff0) if $diff0 > 0 && $text->{align} =~ /^r/i;
|
|
|
727 addstr(' ' x $diff1) if $diff1 > 0 && $text->{align} =~ /^c/i;
|
|
|
728 addstr($text->{value});
|
|
|
729 addstr(' ' x $diff0) if $diff0 > 0 && $text->{align} =~ /^l/i;
|
|
|
730 addstr(' ' x $diff2) if $diff2 > 0 && $text->{align} =~ /^c/i;
|
|
|
731 eval { attrset(A_NORMAL) };
|
|
|
732 }
|
|
|
733
|
|
|
734 sub _set_text {
|
|
|
735 my ($curse, $text, $value) = @_;
|
|
|
736 $text->{type} eq 'text' or die "Internal error";
|
|
|
737 defined $value or $value = '';
|
|
|
738 $value = substr($value, 0, $text->{width});
|
|
|
739 $text->{value} = $value;
|
|
|
740 _show_text_key($curse, $text);
|
|
|
741 }
|
|
|
742
|
|
|
743 sub _get_text {
|
|
|
744 my ($curse, $text) = @_;
|
|
|
745 $text->{type} eq 'text' or die "Internal error";
|
|
|
746 $text->{value};
|
|
|
747 }
|
|
|
748
|
|
|
749 sub _make_key {
|
|
|
750 my ($curse, $label, $action, $keys) = @_;
|
|
|
751 if ($curse->{after_act}) {
|
|
|
752 my $act = $curse->{after_act};
|
|
|
753 my $cb = $action;
|
|
|
754 $action = sub {
|
|
|
755 $@ = '';
|
|
|
756 my $res = eval { $cb->(@_); };
|
|
|
757 if ($act) {
|
|
|
758 $act->($curse, $@ || $res, @_);
|
|
|
759 } elsif ($@) {
|
|
|
760 die $@;
|
|
|
761 }
|
|
|
762 };
|
|
|
763 }
|
|
|
764 my $key = {
|
|
|
765 type => 'key',
|
|
|
766 width => length $label,
|
|
|
767 height => 1,
|
|
|
768 action => $action,
|
|
|
769 align => ($curse->{keyalign} || 'c'),
|
|
|
770 enabled => 1,
|
|
|
771 value => $label,
|
|
|
772 show => \&_show_text_key,
|
|
|
773 };
|
|
|
774 push @{$curse->{keylist}}, $key;
|
|
|
775 for my $k (@$keys) {
|
|
|
776 $k = $keymap{$k} if exists $keymap{$k};
|
|
|
777 next if exists $reserved{$k};
|
|
|
778 $curse->{keypress}{$k} = $key;
|
|
|
779 };
|
|
|
780 return $key;
|
|
|
781 }
|
|
|
782
|
|
|
783 sub _make_menu {
|
|
|
784 my ($curse, $name) = @_;
|
|
|
785 $curse->{menu_byname}{$name} = {};
|
|
|
786 $curse->{menu_entries}{$name} = [];
|
|
|
787 my $key1 = 'M-' . lc(substr($name, 0, 1));
|
|
|
788 my $key2 = 'M-' . uc(substr($name, 0, 1));
|
|
|
789 $curse->{menu_index}{$name} = scalar @{$curse->{menu_keys}};
|
|
|
790 push @{$curse->{menu_keys}}, [
|
|
|
791 'key',
|
|
|
792 name => $name,
|
|
|
793 action => sub { _show_menu($curse, @_) },
|
|
|
794 key => [$key1, $key2],
|
|
|
795 ];
|
|
|
796 1;
|
|
|
797 }
|
|
|
798
|
|
|
799 sub _show_menu {
|
|
|
800 my ($curse, $name) = @_;
|
|
|
801 # find this menu
|
|
|
802 exists $curse->{menu_index}{$name} or return;
|
|
|
803 my $entry = $curse->{menu_index}{$name};
|
|
|
804 # check if menu has ticks
|
|
|
805 my $c = $curse->{menu_byname}{$name};
|
|
|
806 my $ticks = grep { exists $_->{ticked} } values %$c;
|
|
|
807 # get list of entries;
|
|
|
808 my $e = $curse->{menu_entries}{$name};
|
|
|
809 my @entries = grep { $c->{$_->[0]}{enabled} } @$e;
|
|
|
810 return unless @entries;
|
|
|
811 if ($ticks) {
|
|
|
812 @entries =
|
|
|
813 map { [($c->{$_->[0]}{ticked} ? '*' : ' ') . $_->[0],
|
|
|
814 $_->[0],
|
|
|
815 $_->[1]]
|
|
|
816 } @entries;
|
|
|
817 } else {
|
|
|
818 @entries = map { [$_->[0], $_->[0], $_->[1]] } @entries;
|
|
|
819 }
|
|
|
820 # determine menu size and draw window
|
|
|
821 my $rows = scalar @entries;
|
|
|
822 my $cols = 0;
|
|
|
823 for my $e (@entries) {
|
|
|
824 $cols = length($e->[0]) if $cols < length($e->[0]);
|
|
|
825 }
|
|
|
826 # now open a window under the menu label with the entries as a stack of buttons
|
|
|
827 my $mw;
|
|
|
828 my $act = $curse->{after_act};
|
|
|
829 my @keys = map {
|
|
|
830 my ($label, $keyname, $action) = @$_;
|
|
|
831 [ 'key',
|
|
|
832 action => sub {
|
|
|
833 $curse->close($mw);
|
|
|
834 $@ = '';
|
|
|
835 my $res = eval { $action->($curse, $name, @_); };
|
|
|
836 if ($act) {
|
|
|
837 $act->($curse, $@ || $res, $name, @_);
|
|
|
838 } elsif ($@) {
|
|
|
839 die $@;
|
|
|
840 }
|
|
|
841 },
|
|
|
842 name => $keyname,
|
|
|
843 label => $label,
|
|
|
844 key => [],
|
|
|
845 ],
|
|
|
846 } @entries;
|
|
|
847 my @wd = (
|
|
|
848 'vstack',
|
|
|
849 border => 1,
|
|
|
850 data => [
|
|
|
851 'vstack',
|
|
|
852 border => 0,
|
|
|
853 data => @keys,
|
|
|
854 ],
|
|
|
855 );
|
|
|
856 my $k = $curse->{keylist}[$entry];
|
|
|
857 $curse->{keyalign} = 'l';
|
|
|
858 $mw = $curse->_window($name, \@wd);
|
|
|
859 delete $curse->{keyalign};
|
|
|
860 $curse->{keypress}{"\c["} = {
|
|
|
861 hidden => 1,
|
|
|
862 action => sub { $curse->close($mw) },
|
|
|
863 enabled => 1,
|
|
|
864 };
|
|
|
865 for my $ent (@entries) {
|
|
|
866 my $initial = lc(substr($ent->[1], 0, 1));
|
|
|
867 next if exists $curse->{keypress}{$initial};
|
|
|
868 $curse->{keypress}{$initial} = {
|
|
|
869 hidden => 1,
|
|
|
870 enabled => 1,
|
|
|
871 action => sub { _down_until($curse, qr/^[\s\*]*$initial/i) },
|
|
|
872 }
|
|
|
873 }
|
|
|
874 _offset($mw, $k->{x} - 1, $k->{y} + 1);
|
|
|
875 _finish_window($curse, $mw);
|
|
|
876 $curse->{in_menu} = $mw;
|
|
|
877 &{$mw->{show}}($curse, $mw);
|
|
|
878 }
|
|
|
879
|
|
|
880 sub _make_menu_entry {
|
|
|
881 my ($curse, $action, $menu, $name, $entry, $ticks) = @_;
|
|
|
882 $curse->{menu_byname}{$name}{$entry} = {
|
|
|
883 action => $action,
|
|
|
884 enabled => 1,
|
|
|
885 };
|
|
|
886 push @{$curse->{menu_entries}{$name}}, [$entry, $action];
|
|
|
887 1;
|
|
|
888 }
|
|
|
889
|
|
|
890 sub _enable_menu {
|
|
|
891 my ($curse, $item, $state, $name, $entry) = @_;
|
|
|
892 $curse->{menu_byname}{$name}{$entry}{enabled} = $state;
|
|
|
893 1;
|
|
|
894 }
|
|
|
895
|
|
|
896 sub _tick_menu {
|
|
|
897 my ($curse, $item, $state, $name, $entry) = @_;
|
|
|
898 $curse->{menu_byname}{$name}{$entry}{ticked} = $state;
|
|
|
899 1;
|
|
|
900 }
|
|
|
901
|
|
|
902 sub _menu_action {
|
|
|
903 my ($curse, $item, $name, $entry) = @_;
|
|
|
904 exists $curse->{menu_byname}{$name}{$entry} or return 0;
|
|
|
905 $curse->{menu_byname}{$name}{$entry}{enabled} or return 0;
|
|
|
906 my $action = $curse->{menu_byname}{$name}{$entry}{action};
|
|
|
907 $action or return 0;
|
|
|
908 $action->($curse, $name, $entry);
|
|
|
909 }
|
|
|
910
|
|
|
911 1;
|
