Mercurial > repo

comparison interps/clc-intercal/inst/lib/perl5/Language/INTERCAL/Interface/Curses.pm @ 996:859f9b4339e6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
<Gregor> tar xf egobot.tar.xz
author HackBot
date Sun, 09 Dec 2012 19:30:08 +0000
parents
children
comparison
equal deleted inserted replaced
995:6883f5911eb7 996:859f9b4339e6
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;