Mercurial > repo
view interps/clc-intercal/CLC-INTERCAL-UI-Curses-1.-94.-2/INTERCAL/Interface/Curses.pm @ 9309:cc6e0165d321
<oerjan> revert
author | HackBot |
---|---|
date | Mon, 17 Oct 2016 00:38:35 +0000 |
parents | 859f9b4339e6 |
children |
line wrap: on
line source
package Language::INTERCAL::Interface::Curses; # Text (Curses) interface for sick and intercalc # This file is part of CLC-INTERCAL # Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved. # CLC-INTERCAL is copyrighted software. However, permission to use, modify, # and distribute it is granted provided that the conditions set out in the # licence agreement are met. See files README and COPYING in the distribution. use strict; use vars qw($VERSION $PERVERSION); ($VERSION) = ($PERVERSION = "CLC-INTERCAL/UI-Curses INTERCAL/Interface/Curses.pm 1.-94.-2") =~ /\s(\S+)$/; use Carp; use Curses; use Language::INTERCAL::Exporter '1.-94.-2'; use Language::INTERCAL::Interface::common '1.-94.-2'; use vars qw(@ISA); @ISA = qw(Language::INTERCAL::Interface::common); my @savefields = qw(keypress keylist keyrows keycols lastkey menu_byname menu_entries menu_keys menu_index after_act in_menu in_dialog); my %keymap = ( 'Left' => KEY_LEFT, 'BackSpace' => KEY_BACKSPACE, 'Enter' => KEY_ENTER, 'Return' => "\cM", 'Linefeed' => "\cJ", (map { ("F$_" => KEY_F($_)) } (1..12)), (map { ("M-" . chr($_) => chr($_ + 128)) } (1..127)), ); my %reserved = ( &KEY_LEFT => \&_move_left, &KEY_RIGHT => \&_move_right, &KEY_UP => \&_move_up, &KEY_DOWN => \&_move_down, &KEY_ENTER => \&_activate, "\cM" => \&_activate, "\cJ" => \&_activate, ); sub new { @_ == 2 or croak "Usage: Language::INTERCAL::Interface::Curses->new(SERVER)"; my ($class, $server) = @_; $server or croak "Must provide SERVER"; initscr(); clearok(1); noecho(); cbreak(); leaveok(0); eval "END { eval { keypad(0) }; endwin(); print '\n' }"; keypad(1); meta(1); my $curse = bless { keypress => {}, keylist => [], keyrows => [], keycols => [], resize => 0, redraw => 0, windows => [], pending => [], menu_byname => {}, menu_entries => {}, menu_keys => [], menu_index => {}, in_menu => 0, in_dialog => 0, wid => 0, server => $server, }, $class; $server->file_listen(fileno(STDIN), sub { my $k = getch(); while ($k ne ERR) { push @{$curse->{pending}}, $k; nodelay(1); $k = getch(); } nodelay(0); }); $curse->_initialise; $SIG{WINCH} = sub { $curse->{resize} = $curse->{redraw} = 1 }; $curse; } sub has_window { 1 } sub is_interactive { 1 } sub is_terminal { 1 } sub can_paste { 0 } sub stdread { croak "Curses interface should not use stdread directly"; } sub getline { @_ == 2 or croak "Usage: Curses->getline(PROMPT)"; my ($curse, $prompt) = @_; # XXX this is just a draft implementation so there is some way of # XXX executing a WRITE IN - it's not meant to be the final form my $v = ' ' x ($COLS - 10); my @def = ( 'vstack', border => 2, data => ['text', value => $prompt, align => 'c'], ['text', value => $v, align => 'l', name => '__getline'], ); my $window = $curse->window("Program input", undef, \@def); $curse->set_text('__getline', ''); my $line = ''; $curse->{in_dialog} = \$line; my $ok = 1; $curse->{keypress}{"\c["} = { hidden => 1, action => sub { $curse->{running} = 0; $ok = 0 }, enabled => 1, }; $curse->{keypress}{$_} = { hidden => 1, action => sub { $line eq '' and return; chop $line; $curse->set_text('__getline', $line); }, enabled => 1, } for (KEY_BACKSPACE, "\cH"); my $or = $curse->{running}; $curse->run; $curse->close($window); $curse->{running} = $or; $ok ? "$line\n" : undef; } sub file_dialog { @_ == 5 or croak "Usage: Curses->file_dialog(TITLE, NEW?, OK, CANCEL)"; my ($curse, $title, $new, $ok, $cancel) = @_; # XXX this is just a draft implementation so there is some way of # XXX getting a file name - it's not meand to be the final form return $curse->getline($title); } sub alter_data { @_ == 3 or croak "Usage: Curses->alter_data(WINDOW, DATA)"; croak "Augment not implemented for Curses"; # XXX } sub window { @_ == 4 || @_ == 5 || @_ == 6 or croak "Usage: Curses->window(NAME, DESTROY, DEFINITION " . "[, MENUS [, ACT]])"; my ($curse, $name, $destroy, $def, $menus, $act) = @_; $curse->{after_act} = $act; my $window = _window($curse, $name, $def, $menus); _place($window, 0, COLS, 0, LINES); _finish_window($curse, $window); &{$window->{show}}($curse, $window); $window; } sub _window { my ($curse, $name, $def, $menus, $act) = @_; $curse->{menu_byname} = {}; $curse->{menu_entries} = {}; $curse->{menu_keys} = []; $curse->{menu_index} = {}; my $wid = ++$curse->{wid}; if (defined $menus) { $curse->_parse_menus($wid, @$menus); my @def = ( 'vstack', border => 0, data => ['hstack', border => 1, data => @{$curse->{menu_keys}}, ], $def, ); $def = \@def; } $curse->{keypress} = {}; $curse->{keylist} = []; my $window = $curse->_parse_def($wid, @$def); $window->{wid} = $wid; $window; } sub _finish_window { my ($curse, $window) = @_; $curse->{keyrows} = []; $curse->{keycols} = []; $curse->{lastkey} = [0, 0]; if (@{$curse->{keylist}}) { $curse->{keylist} = [ sort { $a->{y} <=> $b->{y} || $a->{x} <=> $b->{x} } @{$curse->{keylist}} ]; for (my $kp = 0; $kp < @{$curse->{keylist}}; $kp++) { my $k = $curse->{keylist}[$kp]; push @{$curse->{keyrows}[$k->{y}]}, $kp; push @{$curse->{keycols}[$k->{x}]}, $kp; } my $nmenu = @{$curse->{menu_keys} || []}; $curse->{lastkey}[1] = $curse->{keylist}[$nmenu]; $curse->{lastkey}[0] = $nmenu; } push @{$curse->{windows}}, [$window, @$curse{@savefields}]; $curse->{in_menu} = 0; $curse->{acter_act} = 0; $window; } sub show { @_ == 2 or croak "Usage: Curses->show(WINDOW)"; my ($curse, $window) = @_; &{$window->{show}}($curse, $window); } sub enable { @_ == 2 or croak "Usage: Curses->enable(WINDOW)"; my ($curse, $window) = @_; $window->{enabled} = 1; $curse->{redraw} = 1; } sub disable { @_ == 2 or croak "Usage: Curses->disable(WINDOW)"; my ($curse, $window) = @_; $window->{enabled} = 0; $curse->{redraw} = 1; } sub update { @_ == 1 or croak "Usage: Curses->update"; my ($curse) = @_; refresh(); } sub start { @_ == 1 or croak "Usage: Curses->start"; refresh(); } sub run { @_ == 1 or croak "Usage: Curses->run"; my ($curse) = @_; $curse->{running} = 1; refresh(); nodelay(0); while ($curse->{running}) { if ($curse->{resize}) { $curse->{resize} = $curse->{redraw} = 0; endwin(); clearok(1); $curse->_redraw(1); } elsif ($curse->{redraw}) { $curse->{redraw} = 0; $curse->_redraw(0); } cbreak(); meta(1); while (! @{$curse->{pending}}) { refresh(); $curse->{server}->progress; } my $key = shift @{$curse->{pending}}; if ($key eq "\c[") { if (@{$curse->{pending}}) { $key = shift @{$curse->{pending}}; $key = chr(ord($key) | 0x80); } } if (exists $reserved{$key}) { &{$reserved{$key}}($curse); next; } if (exists $curse->{keypress}{$key}) { $key = $curse->{keypress}{$key}; next unless $key->{enabled}; if ($curse->{lastkey}[1] != $key && ! $key->{hidden}) { my $ok = $curse->{lastkey}[1]; $curse->{lastkey}[1] = $key; for (my $kp = 0; $kp < @{$curse->{keylist}}; $kp++) { next if $curse->{keylist}[$kp] != $key; $curse->{lastkey}[0] = $kp; } $curse->show($ok); } $curse->show($key) unless $key->{hidden}; $curse->{server}->progress(0) if ! @{$curse->{pending}}; refresh() if ! @{$curse->{pending}}; &{$key->{action}}; $curse->{server}->progress(0) if ! @{$curse->{pending}}; refresh() if ! @{$curse->{pending}}; next; } if ($key =~ /^[[:print:]]$/ && $curse->{in_dialog}) { ${$curse->{in_dialog}} .= $key; $curse->set_text('__getline', ${$curse->{in_dialog}}); $curse->update; next; } } } sub stop { @_ == 1 or croak "Usage: Curses->stop"; my ($curse) = @_; $curse->{running} = 0; } sub pending_events { @_ == 1 or croak "Usage: Curses->pending_events"; my ($curse) = @_; if (! @{$curse->{pending}}) { $curse->{server}->progress(0); cbreak(); } return @{$curse->{pending}} != 0; } sub _activate { my ($curse) = @_; if ($curse->{in_dialog}) { $curse->{running} = 0; return; } return unless $curse->{lastkey}[1]; return unless $curse->{lastkey}[1]->{enabled}; &{$curse->{lastkey}[1]->{action}}; } sub _move_left { my ($curse) = @_; if ($curse->{in_menu}) { # close this menu, then open the one on the left $curse->close($curse->{in_menu}); $curse->{in_menu} = 0; return unless $curse->{lastkey}[1]; _move_left($curse); _activate($curse); return; } return unless $curse->{lastkey}[1]; my $i = $curse->{lastkey}[0]; my $k = $curse->{lastkey}[1]; my $r = $curse->{keyrows}[$k->{y}]; my $ok = $curse->{lastkey}[1]; if ($r->[0] == $i) { $i = $#$r; } else { my $j = 1; $j++ while $j < @$r && $r->[$j] != $i; $j--; $i = $j; } $curse->{lastkey}[0] = $r->[$i]; $curse->{lastkey}[1] = $curse->{keylist}[$r->[$i]]; $curse->show($ok); $curse->show($curse->{lastkey}[1]); } sub _move_right { my ($curse) = @_; if ($curse->{in_menu}) { # close this menu, then open the one on the left $curse->close($curse->{in_menu}); $curse->{in_menu} = 0; return unless $curse->{lastkey}[1]; _move_right($curse); _activate($curse); return; } return unless $curse->{lastkey}[1]; my $i = $curse->{lastkey}[0]; my $k = $curse->{lastkey}[1]; my $r = $curse->{keyrows}[$k->{y}]; my $ok = $curse->{lastkey}[1]; if ($r->[-1] == $i) { $i = 0; } else { my $j = $#$r; $j-- while $j >= 0 && $r->[$j] != $i; $j++; $i = $j; } $curse->{lastkey}[0] = $r->[$i]; $curse->{lastkey}[1] = $curse->{keylist}[$r->[$i]]; $curse->show($ok); $curse->show($curse->{lastkey}[1]); } sub _move_up { my ($curse) = @_; return unless $curse->{lastkey}[1]; my $nmenu = @{$curse->{menu_keys} || []}; my $i = $curse->{lastkey}[0]; return if $i < $nmenu; my $k = $curse->{lastkey}[1]; my $r = $curse->{keycols}[$k->{x}]; my $ok = $curse->{lastkey}[1]; my $idx = 0; $idx++ while $idx < @$r && $r->[$idx] < $nmenu; if ($r->[$idx] == $i) { $i = $#$r; } else { my $j = 1; $j++ while $j < @$r && $r->[$j] != $i; $j--; $i = $j; } $curse->{lastkey}[0] = $r->[$i]; $curse->{lastkey}[1] = $curse->{keylist}[$r->[$i]]; $curse->show($ok); $curse->show($curse->{lastkey}[1]); } sub _down_until { my ($curse, $until) = @_; return unless $curse->{lastkey}[1]; my $i = $curse->{lastkey}[0]; do { _move_down($curse); } until $curse->{lastkey}[0] == $i || $curse->{lastkey}[1]->{value} =~ $until; } sub _move_down { my ($curse) = @_; return unless $curse->{lastkey}[1]; my $i = $curse->{lastkey}[0]; my $nmenu = @{$curse->{menu_keys} || []}; if ($i < $nmenu) { # open this menu _activate($curse); return; } my $k = $curse->{lastkey}[1]; my $r = $curse->{keycols}[$k->{x}]; my $ok = $curse->{lastkey}[1]; my $idx = 0; $idx++ while $idx < @$r && $r->[$idx] < $nmenu; if ($r->[-1] == $i) { $i = $idx; } else { my $j = $#$r; $j-- while $j >= 0 && $r->[$j] != $i; $j++; $i = $j; } $curse->{lastkey}[0] = $r->[$i]; $curse->{lastkey}[1] = $curse->{keylist}[$r->[$i]]; $curse->show($ok); $curse->show($curse->{lastkey}[1]); } sub _redraw { my ($curse, $place) = @_; erase(); $@ = ''; for my $w (@{$curse->{windows}}) { if ($place) { eval { _place($w->[0], 0, $COLS, 0, $LINES) }; last if $@; } &{$w->[0]{show}}($curse, $w->[0]); } if ($@) { clearok(1); erase(); my $line = 0; for my $s (split(/\n/, $@)) { addstr($line++, 0, $s) if $line < $LINES; } } refresh(); } sub _offset { my ($window, $x, $y) = @_; $window->{x} += $x; $window->{y} += $y; return unless exists $window->{children}; for my $child (@{$window->{children}}) { _offset($child, $x, $y); } } sub _place { my ($window, $x, $width, $y, $height) = @_; my $diff = $width - $window->{width}; $diff = 0 if $diff < 0; $x += int($diff / 2); $window->{x} ||= 0; $diff = $height - $window->{height}; $diff = 0 if $diff < 0; $y += int($diff / 2); $window->{y} ||= 0; _offset($window, $x - $window->{x}, $y - $window->{y}); } sub close { @_ == 2 or croak "Usage: Curses->close(WINDOW)"; my ($curse, $window) = @_; $curse->_close($window->{wid}); my @nw = grep { $_->[0] != $window } @{$curse->{windows}}; $curse->{windows} = \@nw; if (@nw) { my $w; ($w, @$curse{@savefields}) = @{$nw[-1]}; } else { @$curse{@savefields} = ({}, {}, [], [], [0, 0], {}, {}, [], {}, 0, undef); clearok(1); $curse->_initialise; } $curse->_redraw(0); } sub _extend_width { my ($e, $cw) = @_; return if $e->{width} >= $cw; my $diff = $cw - $e->{width}; $e->{width} = $cw; return unless exists $e->{children}; my $d0 = int($diff / scalar @{$e->{colwidth}}); my $d1 = $diff % scalar @{$e->{colwidth}}; my $d = 0; my @d = (); for (my $c = 0; $c < @{$e->{colwidth}}; $c++) { $d[$c] = $d; $d += $d0 + (($c < $d1) ? 1 : 0); $e->{colwidth}[$c] += $d0 + (($c < $d1) ? 1 : 0); } for my $child (@{$e->{children}}) { my ($c0, $c1, $r0, $r1) = @{$child->{table}}; $d = -$e->{border}; for (my $c = $c0; $c < $c1; $c++) { $d += $e->{colwidth}[$c] + $e->{border}; } _extend_width($child, $d); _offset($child, $d[$c0], 0); } } sub _extend_height { my ($e, $rh) = @_; return if $e->{height} >= $rh; my $diff = $rh - $e->{height}; $e->{height} = $rh; return unless exists $e->{children}; my $d0 = int($diff / scalar @{$e->{rowheight}}); my $d1 = $diff % scalar @{$e->{rowheight}}; my $d = 0; my @d = (); for (my $r = 0; $r < @{$e->{rowheight}}; $r++) { $d[$r] = $d; $d += $d0 + (($r < $d1) ? 1 : 0); $e->{rowheight}[$r] += $d0 + (($r < $d1) ? 1 : 0); } for my $child (@{$e->{children}}) { my ($c0, $c1, $r0, $r1) = @{$child->{table}}; $d = -$e->{border}; for (my $r = $r0; $r < $r1; $r++) { $d += $e->{rowheight}[$r] + $e->{border}; } _extend_height($child, $d); _offset($child, 0, $d[$r0]); } } sub _make_table { my ($curse, $rows, $cols, $elements, $border, $augment) = @_; my @width = (0) x $cols; my @height = (0) x $rows; $border = $border ? 1 : 0; # try to determine row/column sizes using one cell elements for my $te (@$elements) { my ($e, $c0, $c1, $r0, $r1) = @$te; $width[$c0] = $e->{width} if $c0 + 1 == $c1 && $width[$c0] < $e->{width}; $height[$r0] = $e->{height} if $r0 + 1 == $r1 && $height[$r0] < $e->{height}; } # now adjust it for multirow/multicolumn for my $te (@$elements) { my ($e, $c0, $c1, $r0, $r1) = @$te; if ($c1 - $c0 > 1) { my $cw = ($c1 - $c0 - 1) * $border; for (my $c = $c0; $c < $c1; $c++) { $cw += $width[$c]; } if ($cw < $e->{width}) { my $diff = $e->{width} - $cw; my $d0 = int($diff / ($c1 - $c0)); my $d1 = $diff % ($c1 - $c0); for (my $c = $c0; $c < $c1; $c++) { $width[$c] += $d0; $width[$c] ++ if $c < $d1; } } } if ($r1 - $r0 > 1) { my $rh = ($r1 - $r0 - 1) * $border; for (my $r = $r0; $r < $r1; $r++) { $rh += $height[$r]; } if ($rh < $e->{height}) { my $diff = $e->{height} - $rh; my $d0 = int($diff / ($r1 - $r0)); my $d1 = $diff % ($r1 - $r0); for (my $r = $r0; $r < $r1; $r++) { $height[$r] += $d0; $height[$r] ++ if $r < $d1; } } } } # determine total window size and cell starting points my $width = $border; my @x = (); for (my $c = 0; $c < $cols; $c++) { $x[$c] = $width; $width += $width[$c] + $border; } my $height = $border; my @y = (); for (my $r = 0; $r < $rows; $r++) { $y[$r] = $height; $height += $height[$r] + $border; } # place all elements and extend them to fill cell if required my @children = (); for my $te (@$elements) { my ($e, $c0, $c1, $r0, $r1) = @$te; _offset($e, $x[$c0], $y[$r0]); my $cw = ($c1 - $c0 - 1) * $border; for (my $c = $c0; $c < $c1; $c++) { $cw += $width[$c]; } _extend_width($e, $cw); my $rh = ($r1 - $r0 - 1) * $border; for (my $r = $r0; $r < $r1; $r++) { $rh += $height[$r]; } _extend_height($e, $rh); $e->{table} = [$c0, $c1, $r0, $r1]; push @children, $e; } # ready to go... return { type => 'table', width => $width, height => $height, colwidth => \@width, rowheight => \@height, show => \&_show_table, children => \@children, border => $border, }; } sub _show_table { my ($curse, $table) = @_; $table->{type} eq 'table' or die "Internal error"; # draw border, if required # XXX multirow fields may show '+' where '|' should be if ($table->{border}) { my $y = $table->{y}; my $row = 0; for my $rh (@{$table->{rowheight}}, 0) { move($y, $table->{x}); my $col = 0; for my $cw (@{$table->{colwidth}}, 0) { my $plus = '-'; for my $e (@{$table->{children}}) { next if $e->{table}[0] != $col && $e->{table}[1] != $col; next if $e->{table}[2] != $row && $e->{table}[3] != $row; $plus = '+'; last; } addstr($plus . ('-' x $cw)); $col++; } $y++; for (my $x = 0; $x < $rh; $x++) { move($y, $table->{x}); for my $cw (@{$table->{colwidth}}, 0) { addstr('|' . (' ' x $cw)); } $y++; } $row++; } } # draw elements for my $e (@{$table->{children}}) { &{$e->{show}}($curse, $e); } } sub _make_text { my ($curse, $value, $align, $size) = @_; $size ||= length $value; return { type => 'text', width => $size, height => 1, value => $value, enabled => 1, align => $align, show => \&_show_text_key, }; } sub _show_text_key { my ($curse, $text) = @_; $text->{type} eq 'text' || $text->{type} eq 'key' or die "Internal error"; move($text->{y}, $text->{x}); my $diff0 = $text->{width} - length($text->{value}); my $diff1 = int($diff0 / 2); my $diff2 = $diff0 - $diff1; eval { attrset(A_NORMAL) }; eval { attron(A_BOLD) } if $text->{enabled}; eval { attron(A_REVERSE) } if $text == $curse->{lastkey}[1]; addstr(' ' x $diff0) if $diff0 > 0 && $text->{align} =~ /^r/i; addstr(' ' x $diff1) if $diff1 > 0 && $text->{align} =~ /^c/i; addstr($text->{value}); addstr(' ' x $diff0) if $diff0 > 0 && $text->{align} =~ /^l/i; addstr(' ' x $diff2) if $diff2 > 0 && $text->{align} =~ /^c/i; eval { attrset(A_NORMAL) }; } sub _set_text { my ($curse, $text, $value) = @_; $text->{type} eq 'text' or die "Internal error"; defined $value or $value = ''; $value = substr($value, 0, $text->{width}); $text->{value} = $value; _show_text_key($curse, $text); } sub _get_text { my ($curse, $text) = @_; $text->{type} eq 'text' or die "Internal error"; $text->{value}; } sub _make_key { my ($curse, $label, $action, $keys) = @_; if ($curse->{after_act}) { my $act = $curse->{after_act}; my $cb = $action; $action = sub { $@ = ''; my $res = eval { $cb->(@_); }; if ($act) { $act->($curse, $@ || $res, @_); } elsif ($@) { die $@; } }; } my $key = { type => 'key', width => length $label, height => 1, action => $action, align => ($curse->{keyalign} || 'c'), enabled => 1, value => $label, show => \&_show_text_key, }; push @{$curse->{keylist}}, $key; for my $k (@$keys) { $k = $keymap{$k} if exists $keymap{$k}; next if exists $reserved{$k}; $curse->{keypress}{$k} = $key; }; return $key; } sub _make_menu { my ($curse, $name) = @_; $curse->{menu_byname}{$name} = {}; $curse->{menu_entries}{$name} = []; my $key1 = 'M-' . lc(substr($name, 0, 1)); my $key2 = 'M-' . uc(substr($name, 0, 1)); $curse->{menu_index}{$name} = scalar @{$curse->{menu_keys}}; push @{$curse->{menu_keys}}, [ 'key', name => $name, action => sub { _show_menu($curse, @_) }, key => [$key1, $key2], ]; 1; } sub _show_menu { my ($curse, $name) = @_; # find this menu exists $curse->{menu_index}{$name} or return; my $entry = $curse->{menu_index}{$name}; # check if menu has ticks my $c = $curse->{menu_byname}{$name}; my $ticks = grep { exists $_->{ticked} } values %$c; # get list of entries; my $e = $curse->{menu_entries}{$name}; my @entries = grep { $c->{$_->[0]}{enabled} } @$e; return unless @entries; if ($ticks) { @entries = map { [($c->{$_->[0]}{ticked} ? '*' : ' ') . $_->[0], $_->[0], $_->[1]] } @entries; } else { @entries = map { [$_->[0], $_->[0], $_->[1]] } @entries; } # determine menu size and draw window my $rows = scalar @entries; my $cols = 0; for my $e (@entries) { $cols = length($e->[0]) if $cols < length($e->[0]); } # now open a window under the menu label with the entries as a stack of buttons my $mw; my $act = $curse->{after_act}; my @keys = map { my ($label, $keyname, $action) = @$_; [ 'key', action => sub { $curse->close($mw); $@ = ''; my $res = eval { $action->($curse, $name, @_); }; if ($act) { $act->($curse, $@ || $res, $name, @_); } elsif ($@) { die $@; } }, name => $keyname, label => $label, key => [], ], } @entries; my @wd = ( 'vstack', border => 1, data => [ 'vstack', border => 0, data => @keys, ], ); my $k = $curse->{keylist}[$entry]; $curse->{keyalign} = 'l'; $mw = $curse->_window($name, \@wd); delete $curse->{keyalign}; $curse->{keypress}{"\c["} = { hidden => 1, action => sub { $curse->close($mw) }, enabled => 1, }; for my $ent (@entries) { my $initial = lc(substr($ent->[1], 0, 1)); next if exists $curse->{keypress}{$initial}; $curse->{keypress}{$initial} = { hidden => 1, enabled => 1, action => sub { _down_until($curse, qr/^[\s\*]*$initial/i) }, } } _offset($mw, $k->{x} - 1, $k->{y} + 1); _finish_window($curse, $mw); $curse->{in_menu} = $mw; &{$mw->{show}}($curse, $mw); } sub _make_menu_entry { my ($curse, $action, $menu, $name, $entry, $ticks) = @_; $curse->{menu_byname}{$name}{$entry} = { action => $action, enabled => 1, }; push @{$curse->{menu_entries}{$name}}, [$entry, $action]; 1; } sub _enable_menu { my ($curse, $item, $state, $name, $entry) = @_; $curse->{menu_byname}{$name}{$entry}{enabled} = $state; 1; } sub _tick_menu { my ($curse, $item, $state, $name, $entry) = @_; $curse->{menu_byname}{$name}{$entry}{ticked} = $state; 1; } sub _menu_action { my ($curse, $item, $name, $entry) = @_; exists $curse->{menu_byname}{$name}{$entry} or return 0; $curse->{menu_byname}{$name}{$entry}{enabled} or return 0; my $action = $curse->{menu_byname}{$name}{$entry}{action}; $action or return 0; $action->($curse, $name, $entry); } 1;