package CursesChatMainwindow; use strict; use Curses; use Term::ReadKey; use Exporter; our @ISA = qw/Exporter/; our @EXPORT = qw/printline select_buffer current_buffer list_buffers clear_buffer clear_buffer_temporaries/; our $wins; our $HEIGHT; our $WIDTH; our $MAINWIN; our $stdiowatcher; our $winchwatcher; our $current_buffer_scroll = 0; our $current_buffer = "status"; our $winbuffers = {}; our $complete_cb = sub {}; our $input_cb = sub {}; our %completions; our @history; our $hist_ptr = -1; our $inputbuffer; our $inputoffset = 0; our $cursor = 0; our $statusline; our $msgline; sub handle_resize { my ($wc, $hc, $wpx, $hpx) = GetTerminalSize (); resizeterm ($hc, $wc); $MAINWIN->resize ($hc, $wc); $HEIGHT = $hc; $WIDTH = $wc; $MAINWIN->erase; refresh (); } sub complete { my ($line) = @_; my @words; while ($line ne '') { $line =~ s/^(\S+)// or $line =~ s/^(\s+)//; push @words, $1; } my $widx = @words - 1; unless (@words) { $words[0] = ''; $widx = 0; } my $word = $complete_cb->($words[$widx], $widx, @words); $words[$widx] = defined $word ? $word : $words[$widx]; return join '', @words; } sub color2attr { my $c = $_[0]; my $attr; if ($c <= 63) { $attr = COLOR_PAIR($c); } elsif ($c <= 127) { $c -= 64; $attr = COLOR_PAIR($c) | A_BOLD; } elsif ($c <= 191) { $c -= 128; $attr = COLOR_PAIR($c) | A_UNDERLINE; } else { $c -= 192; $attr = COLOR_PAIR($c) | A_UNDERLINE | A_BOLD; } $attr } sub register_input_cb { my ($cb) = @_; $input_cb = $cb; } sub register_complete_cb { my ($cb) = @_; $complete_cb = $cb; } sub _draw_attr_line_at { my ($line, $attrline) = @_; my @lcont = @$attrline; my $li = 0; while (@lcont > 0) { my ($color, $str) = (shift @lcont, shift @lcont); while ($color eq 'f' or $color eq 't') { if ($color eq 'f') { ($color, $str) = ($str, shift @lcont); $str .= " " x ($WIDTH - length ($str)); } elsif ($color eq 't') { ($color, $str) = ($str, shift @lcont); } } $MAINWIN->attron (color2attr ($color)); my $sl = length $str; if (($li + $sl) > $WIDTH) { $sl = $WIDTH - $li; last if $sl < 0; } $MAINWIN->addnstr ($line, $li, (substr $str, 0, $sl), $sl); $li += $sl; $MAINWIN->attroff (color2attr ($color)); } } sub clog { open LOG, ">>/tmp/debuglog"; print LOG @_; close LOG; } sub wrap_attr_lines { my ($width, @lines) = @_; my @outlines; for my $line (@lines) { my $wrap_padding = 0; my @cline = @$line; my @oline; my $outc = 0; while (@cline) { my ($color, $str) = (shift @cline, shift @cline); while ($color =~ m/^p/ or $color eq 't') { if ($color =~ m/^p\s*(\d+)\s*$/) { $wrap_padding = $1; ($color, $str) = ($str, shift @cline); } elsif ($color eq 't') { ($color, $str) = ($str, shift @cline); } } my $strlen = length $str; if (($outc + $strlen) > $width) { my $thisl = $width - $outc; push @oline, ($color, substr $str, 0, $thisl); push @outlines, [@oline]; @oline = (); unshift @cline, ($color, substr $str, $thisl); if ($wrap_padding && ($wrap_padding + 7) < $width) { # 7 too few cols to display a sentence nicely unshift @cline, (0, ' ' x $wrap_padding); } $outc = 0; } else { push @oline, ($color, $str); $outc += $strlen; } } push @outlines, [@oline]; } # my $i = 0; # for my $line (@outlines) { # clog ("LINE$i: ".join ('|',@$line)."\n"); # $i++; # } @outlines; } sub refresh_lines { $MAINWIN->erase; # TODO: cache the wrapped lines until something in the buffer # or the window size changes # NOTE: cache doesn't have to be invalidated for adding new lines! my @revwin = @{$winbuffers->{$current_buffer} || []}; my (@out_lines) = reverse wrap_attr_lines ($WIDTH, @revwin); if ($current_buffer_scroll > 0) { if ($current_buffer_scroll > scalar (@out_lines)) { $current_buffer_scroll = scalar (@out_lines); } @out_lines = splice @out_lines, $current_buffer_scroll; clog ("SPLICE$current_buffer_scroll [".(scalar @out_lines)."]\n"); } _draw_attr_line_at (0, $msgline || [0, 'nothing']); _draw_attr_line_at ($HEIGHT - 2, $statusline || [0, 'nothing']); my $line = $HEIGHT - 3; while ($line >= 1) { my $l = shift @out_lines; last unless defined $l; _draw_attr_line_at ($line--, $l); } } sub refresh { my ($onlyinput) = @_; refresh_lines unless $onlyinput; $MAINWIN->move ($HEIGHT - 1, 0); $MAINWIN->clrtoeol (); my $padding = $WIDTH - int ($WIDTH / 1.2); if ($cursor >= ($WIDTH - $padding)) { my $iobuf = $inputbuffer; my $il = length $iobuf; my $ncursor = $cursor; my $lcursor = $cursor - int ($WIDTH / 1.2); $ncursor -= $lcursor; substr $iobuf, 0, $lcursor, ''; $MAINWIN->addstr ($HEIGHT - 1, 0, (substr $iobuf, 0, $WIDTH)); $MAINWIN->move ($HEIGHT - 1, $ncursor); } else { $MAINWIN->addstr ($HEIGHT - 1, 0, (substr $inputbuffer, 0, $WIDTH)); $MAINWIN->move ($HEIGHT - 1, $cursor); } $MAINWIN->refresh; } sub select_buffer { $current_buffer = $_[0]; $current_buffer_scroll = 0; refresh (); } sub current_buffer { $current_buffer } sub clear_buffer { my ($buffer) = @_; delete $winbuffers->{$buffer}; } sub clear_buffer_temporaries { my ($buffer) = @_; @{$winbuffers->{$buffer}} = grep { $_->[0] ne 't' } @{$winbuffers->{$buffer}}; refresh () if $buffer eq current_buffer (); } sub list_buffers { keys %$winbuffers; } sub printline { if ($_[0] eq 'statusline') { $statusline = $_[1]; } elsif ($_[0] eq 'msgline') { $msgline = $_[1]; } else { push @{$winbuffers->{(defined $_[0] ? $_[0] : $current_buffer)}}, $_[1]; } refresh (); } sub input { my $c = $MAINWIN->getch; my $only_input = 1; if ($c == KEY_BACKSPACE) { if ($cursor > 0) { substr $inputbuffer, --$cursor, 1, ''; } } elsif ($c == KEY_DC) { substr $inputbuffer, $cursor, 1, ''; } elsif ($c == KEY_LEFT) { $cursor-- if $cursor > 0; } elsif ($c == KEY_RIGHT) { $cursor++ if (($cursor + 1) <= (length $inputbuffer)); } elsif ($c == KEY_PPAGE) { $current_buffer_scroll += int ($HEIGHT / 2); $only_input = 0; } elsif ($c == KEY_NPAGE) { $current_buffer_scroll -= int ($HEIGHT / 2); $current_buffer_scroll = 0 if $current_buffer_scroll < 0; $only_input = 0; } elsif ($c == KEY_END) { $cursor = length $inputbuffer; } elsif ($c == KEY_HOME) { $cursor = 0; } elsif ($c eq "\t") { my $compl_line = substr $inputbuffer, 0, $cursor; $compl_line = complete ($compl_line); substr $inputbuffer, 0, $cursor, $compl_line; $cursor = length $compl_line; } elsif ($c eq "\n") { unshift @history, $inputbuffer; $input_cb->($inputbuffer); $inputbuffer = ""; $cursor = 0; $hist_ptr = -1; } elsif ($c == KEY_UP) { if (($hist_ptr + 1) < scalar (@history)) { if ($hist_ptr < 0 or $history[$hist_ptr] ne $inputbuffer) { if ($inputbuffer =~ /\S/) { unshift @history, $inputbuffer; $hist_ptr++; } } $hist_ptr++; $inputbuffer = $history[$hist_ptr]; $cursor = length $inputbuffer; } } elsif ($c == KEY_DOWN) { if ($hist_ptr - 1 <= -1) { $inputbuffer = ""; $cursor = 0; $hist_ptr = -1; } elsif (($hist_ptr - 1) >= 0) { if ($hist_ptr < 0 or $history[$hist_ptr] ne $inputbuffer) { if ($inputbuffer =~ /\S/) { unshift @history, $inputbuffer; $hist_ptr++; } } $inputbuffer = $history[--$hist_ptr]; $cursor = length $inputbuffer; } } else { if ($c > 255) { #d# printline (status => [0, "SPECIAL[$c]"]); } else { if (ord ($c) == 27) { my $nxt = $MAINWIN->getch; $input_cb->(undef, $nxt); return; } else { substr $inputbuffer, $cursor++, 0, $c; } } } refresh ($only_input); } sub init { my $win = $MAINWIN = Curses->new; cbreak; noecho; clear; $win->keypad (1); ($HEIGHT, $WIDTH) = ($LINES, $COLS); if (has_colors ()) { start_color (); use_default_colors (); my $colors = ""; my (@ansi_tab) = qw/0 4 2 6 1 5 3 7/; for (my $i = 1; $i < $COLOR_PAIRS; $i++) { init_pair ($i, $ansi_tab[$i & 7], $i <= 7 ? -1 : $ansi_tab[$i >> 3]); } } $win->attron (A_NORMAL); $winchwatcher = AnyEvent->signal (signal => 'WINCH', cb => sub { handle_resize }); $stdiowatcher = AnyEvent->io (fh => \*STDIN, poll => "r", cb => sub { input; }); } sub end { endwin; } sub print_colors { my $l = []; for (my $i = 0; $i <= 256; $i++) { push @$l, $i, (sprintf "[%3d]", $i); if (($i + 1) % 8 == 0) { printline ($current_buffer => $l); $l = []; } } printline ($current_buffer => $l); } #printline ("TESTE!!!"); 1;