Net-IRC3/samples/CursesChatMainwindow.pm

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/;

our $HEIGHT;
our $WIDTH;
our $MAINWIN;
our $stdiowatcher;

our $current_buffer_scroll = 0;
our $current_buffer = "status";
our $winbuffers = {};

our $complete_cb = sub {};
our $input_cb = sub {};

our %completions;
our $first_compl;
our @history;
our $inputbuffer;
our $inputoffset = 0;
our $cursor = 0;
our $statusline;

$SIG{WINCH} = sub {
   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; }
#   while ($widx >= 0 && $words[$widx] =~ /^\s*$/) {
#      $widx--;
#   }
#   return $line unless $widx >= 0;

   $first_compl = defined $first_compl ? $first_compl : $words[$widx];
   my $word = $complete_cb->($words[$widx], $first_compl, $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);

       $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);
         if ($color =~ m/^p\s*(\d+)\s*$/) {
            $wrap_padding = $1;
            ($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 < $width) {
               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 ($HEIGHT - 2, $statusline || [0, 'nothing']);

   my $line = $HEIGHT - 3;
   while ($line >= 0) {
      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 list_buffers {
   keys %$winbuffers;
}

sub printline {
   if ($_[0] eq 'statusline') {
      $statusline = $_[1];
   } else {
      push @{$winbuffers->{(defined $_[0] ? $_[0] : $current_buffer)}}, $_[1];
   }
   refresh ();
}

sub clear_completion_state {
   # erase completion state
   $first_compl = undef;
}

sub input {
   my $c = $MAINWIN->getch;

   if ($c == KEY_BACKSPACE) {
      if ($cursor > 0) {
         substr $inputbuffer, --$cursor, 1, '';
      }
      clear_completion_state;
   } elsif ($c == KEY_DC) {
      substr $inputbuffer, $cursor, 1, '';
      clear_completion_state;
   } elsif ($c == KEY_LEFT) {
      $cursor-- if $cursor > 0;
      clear_completion_state;
   } elsif ($c == KEY_RIGHT) {
      $cursor++ if (($cursor + 1) <= (length $inputbuffer));
      clear_completion_state;
   } elsif ($c == KEY_PPAGE) {
      $current_buffer_scroll += int ($HEIGHT / 2);
   } elsif ($c == KEY_NPAGE) {
      $current_buffer_scroll -= int ($HEIGHT / 2);
      $current_buffer_scroll = 0 if $current_buffer_scroll < 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") {
      push @history, $inputbuffer;
      $input_cb->($inputbuffer);
      $inputbuffer = "";
      $cursor = 0;
      clear_completion_state;
   } else {
      if ($c > 255) {
         printline (status => [0, "SPECIAL[$c]"]);
      } else {
         if (ord ($c) == 27) {
            my $nxt = $MAINWIN->getch;
            $input_cb->(undef, $nxt);
            return;
         } else {
            clear_completion_state;
            substr $inputbuffer, $cursor++, 0, $c;
         }
      }
   }
   refresh ();
}

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);
   $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;
Revision:	1.3
Committed:	Mon Dec 25 21:54:46 2006 UTC (19 years, 9 months ago) by elmex
Branch:	MAIN
Changes since 1.2:	+56 -6 lines
Log Message:	improved the json chat client: fixed scrolling a bit, implemented completion and fixed other weird behaviour
#	User	Rev	Content
1	elmex	1.1	package CursesChatMainwindow;
2			use strict;
3			use Curses;
4			use Term::ReadKey;
5			use Exporter;
6			our @ISA = qw/Exporter/;
7	elmex	1.3	our @EXPORT = qw/printline select_buffer current_buffer list_buffers/;
8	elmex	1.1
9			our $HEIGHT;
10			our $WIDTH;
11			our $MAINWIN;
12			our $stdiowatcher;
13
14			our $current_buffer_scroll = 0;
15			our $current_buffer = "status";
16			our $winbuffers = {};
17
18	elmex	1.3	our $complete_cb = sub {};
19	elmex	1.1	our $input_cb = sub {};
20
21	elmex	1.3	our %completions;
22			our $first_compl;
23	elmex	1.1	our @history;
24			our $inputbuffer;
25			our $inputoffset = 0;
26			our $cursor = 0;
27			our $statusline;
28
29			$SIG{WINCH} = sub {
30			my ($wc, $hc, $wpx, $hpx) = GetTerminalSize ();
31			resizeterm ($hc, $wc);
32			$MAINWIN->resize ($hc, $wc);
33			$HEIGHT = $hc;
34			$WIDTH = $wc;
35			$MAINWIN->erase;
36			refresh ();
37			};
38
39	elmex	1.3	sub complete {
40			my ($line) = @_;
41			my @words;
42			while ($line ne '') {
43			$line =~ s/^(\S+)//
44			or $line =~ s/^(\s+)//;
45			push @words, $1;
46			}
47			my $widx = @words - 1;
48			unless (@words) { $words[0] = ''; $widx = 0; }
49			# while ($widx >= 0 && $words[$widx] =~ /^\s*$/) {
50			# $widx--;
51			# }
52			# return $line unless $widx >= 0;
53
54			$first_compl = defined $first_compl ? $first_compl : $words[$widx];
55			my $word = $complete_cb->($words[$widx], $first_compl, $widx, @words);
56			$words[$widx] = defined $word ? $word : $words[$widx];
57
58			return join '', @words;
59			}
60
61	elmex	1.1	sub color2attr {
62			my $c = $_[0];
63			my $attr;
64			if ($c <= 63) {
65			$attr = COLOR_PAIR($c);
66			} elsif ($c <= 127) {
67			$c -= 64;
68			$attr = COLOR_PAIR($c) \| A_BOLD;
69			} elsif ($c <= 191) {
70			$c -= 128;
71			$attr = COLOR_PAIR($c) \| A_UNDERLINE;
72			} else {
73			$c -= 192;
74			$attr = COLOR_PAIR($c) \| A_UNDERLINE \| A_BOLD;
75			}
76			$attr
77			}
78
79			sub register_input_cb {
80			my ($cb) = @_;
81			$input_cb = $cb;
82			}
83
84	elmex	1.3	sub register_complete_cb {
85			my ($cb) = @_;
86			$complete_cb = $cb;
87			}
88
89	elmex	1.1	sub _draw_attr_line_at {
90			my ($line, $attrline) = @_;
91
92			my @lcont = @$attrline;
93			my $li = 0;
94
95			while (@lcont > 0) {
96			my ($color, $str) = (shift @lcont, shift @lcont);
97
98			$MAINWIN->attron (color2attr ($color));
99
100			my $sl = length $str;
101			if (($li + $sl) > $WIDTH) {
102			$sl = $WIDTH - $li;
103			last if $sl < 0;
104			}
105
106			$MAINWIN->addnstr ($line, $li, (substr $str, 0, $sl), $sl);
107
108			$li += $sl;
109
110			$MAINWIN->attroff (color2attr ($color));
111			}
112			}
113
114			sub clog {
115			open LOG, ">>/tmp/debuglog";
116			print LOG @_;
117			close LOG;
118			}
119
120			sub wrap_attr_lines {
121			my ($width, @lines) = @_;
122
123			my @outlines;
124
125			for my $line (@lines) {
126			my $wrap_padding = 0;
127			my @cline = @$line;
128			my @oline;
129
130			my $outc = 0;
131
132			while (@cline) {
133			my ($color, $str) = (shift @cline, shift @cline);
134			if ($color =~ m/^p\s(\d+)\s$/) {
135			$wrap_padding = $1;
136			($color, $str) = ($str, shift @cline);
137			}
138
139			my $strlen = length $str;
140
141			if (($outc + $strlen) > $width) {
142			my $thisl = $width - $outc;
143			push @oline, ($color, substr $str, 0, $thisl);
144			push @outlines, [@oline];
145			@oline = ();
146			unshift @cline, ($color, substr $str, $thisl);
147			if ($wrap_padding && $wrap_padding < $width) {
148			unshift @cline, (0, ' ' x $wrap_padding);
149			}
150			$outc = 0;
151			} else {
152			push @oline, ($color, $str);
153			$outc += $strlen;
154			}
155			}
156
157			push @outlines, [@oline];
158			}
159
160			# my $i = 0;
161			# for my $line (@outlines) {
162			# clog ("LINE$i: ".join ('\|',@$line)."\n");
163			# $i++;
164			# }
165
166			@outlines;
167			}
168
169			sub refresh_lines {
170			$MAINWIN->erase;
171
172	elmex	1.3	# TODO: cache the wrapped lines until something in the buffer
173			# or the window size changes
174			# NOTE: cache doesn't have to be invalidated for adding new lines!
175	elmex	1.1	my @revwin = @{$winbuffers->{$current_buffer} \|\| []};
176			my (@out_lines) = reverse wrap_attr_lines ($WIDTH, @revwin);
177
178			if ($current_buffer_scroll > 0) {
179			if ($current_buffer_scroll > scalar (@out_lines)) {
180			$current_buffer_scroll = scalar (@out_lines);
181			}
182			@out_lines = splice @out_lines, $current_buffer_scroll;
183			clog ("SPLICE$current_buffer_scroll [".(scalar @out_lines)."]\n");
184			}
185
186			_draw_attr_line_at ($HEIGHT - 2, $statusline \|\| [0, 'nothing']);
187
188			my $line = $HEIGHT - 3;
189			while ($line >= 0) {
190			my $l = shift @out_lines;
191			last unless defined $l;
192			_draw_attr_line_at ($line--, $l);
193			}
194			}
195
196			sub refresh {
197			my ($onlyinput) = @_;
198
199			refresh_lines unless $onlyinput;
200
201			$MAINWIN->move ($HEIGHT - 1, 0);
202			$MAINWIN->clrtoeol ();
203
204			my $padding = $WIDTH - int ($WIDTH / 1.2);
205
206			if ($cursor >= ($WIDTH - $padding)) {
207			my $iobuf = $inputbuffer;
208			my $il = length $iobuf;
209			my $ncursor = $cursor;
210			my $lcursor = $cursor - int ($WIDTH / 1.2);
211			$ncursor -= $lcursor;
212			substr $iobuf, 0, $lcursor, '';
213			$MAINWIN->addstr ($HEIGHT - 1, 0, (substr $iobuf, 0, $WIDTH));
214			$MAINWIN->move ($HEIGHT - 1, $ncursor);
215			} else {
216			$MAINWIN->addstr ($HEIGHT - 1, 0, (substr $inputbuffer, 0, $WIDTH));
217			$MAINWIN->move ($HEIGHT - 1, $cursor);
218			}
219			$MAINWIN->refresh;
220			}
221
222			sub select_buffer {
223			$current_buffer = $_[0];
224			$current_buffer_scroll = 0;
225			refresh ();
226			}
227
228	elmex	1.2	sub current_buffer {
229			$current_buffer
230			}
231
232	elmex	1.3	sub list_buffers {
233			keys %$winbuffers;
234			}
235
236	elmex	1.1	sub printline {
237			if ($_[0] eq 'statusline') {
238			$statusline = $_[1];
239			} else {
240	elmex	1.3	push @{$winbuffers->{(defined $_[0] ? $_[0] : $current_buffer)}}, $_[1];
241	elmex	1.1	}
242			refresh ();
243			}
244
245	elmex	1.3	sub clear_completion_state {
246			# erase completion state
247			$first_compl = undef;
248			}
249
250	elmex	1.1	sub input {
251			my $c = $MAINWIN->getch;
252	elmex	1.3
253	elmex	1.1	if ($c == KEY_BACKSPACE) {
254			if ($cursor > 0) {
255			substr $inputbuffer, --$cursor, 1, '';
256			}
257	elmex	1.3	clear_completion_state;
258	elmex	1.1	} elsif ($c == KEY_DC) {
259			substr $inputbuffer, $cursor, 1, '';
260	elmex	1.3	clear_completion_state;
261	elmex	1.1	} elsif ($c == KEY_LEFT) {
262			$cursor-- if $cursor > 0;
263	elmex	1.3	clear_completion_state;
264	elmex	1.1	} elsif ($c == KEY_RIGHT) {
265			$cursor++ if (($cursor + 1) <= (length $inputbuffer));
266	elmex	1.3	clear_completion_state;
267	elmex	1.1	} elsif ($c == KEY_PPAGE) {
268			$current_buffer_scroll += int ($HEIGHT / 2);
269			} elsif ($c == KEY_NPAGE) {
270			$current_buffer_scroll -= int ($HEIGHT / 2);
271			$current_buffer_scroll = 0 if $current_buffer_scroll < 0;
272	elmex	1.3	} elsif ($c eq "\t") {
273			my $compl_line = substr $inputbuffer, 0, $cursor;
274			$compl_line = complete ($compl_line);
275			substr $inputbuffer, 0, $cursor, $compl_line;
276			$cursor = length $compl_line;
277	elmex	1.1	} elsif ($c eq "\n") {
278			push @history, $inputbuffer;
279			$input_cb->($inputbuffer);
280			$inputbuffer = "";
281			$cursor = 0;
282	elmex	1.3	clear_completion_state;
283	elmex	1.1	} else {
284			if ($c > 255) {
285			printline (status => [0, "SPECIAL[$c]"]);
286			} else {
287	elmex	1.2	if (ord ($c) == 27) {
288			my $nxt = $MAINWIN->getch;
289			$input_cb->(undef, $nxt);
290			return;
291			} else {
292	elmex	1.3	clear_completion_state;
293	elmex	1.2	substr $inputbuffer, $cursor++, 0, $c;
294			}
295	elmex	1.1	}
296			}
297			refresh ();
298			}
299
300			sub init {
301			my $win = $MAINWIN = Curses->new;
302			cbreak;
303			noecho;
304			clear;
305			$win->keypad (1);
306			($HEIGHT, $WIDTH) = ($LINES, $COLS);
307			if (has_colors ()) {
308			start_color ();
309			use_default_colors ();
310			my $colors = "";
311			my (@ansi_tab) = qw/0 4 2 6 1 5 3 7/;
312			for (my $i = 1; $i < $COLOR_PAIRS; $i++) {
313			init_pair ($i, $ansi_tab[$i & 7], $i <= 7 ? -1 : $ansi_tab[$i >> 3]);
314			}
315			}
316			$win->attron (A_NORMAL);
317			$stdiowatcher = AnyEvent->io (fh => \*STDIN, poll => "r", cb => sub {
318			input;
319			});
320			}
321
322			sub end {
323			endwin;
324			}
325
326			sub print_colors {
327			my $l = [];
328			for (my $i = 0; $i <= 256; $i++) {
329			push @$l, $i, (sprintf "[%3d]", $i);
330			if (($i + 1) % 8 == 0) {
331			printline ($current_buffer => $l);
332			$l = [];
333			}
334			}
335			printline ($current_buffer => $l);
336			}
337			#printline ("TESTE!!!");
338
339			1;