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;