Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package CommandTerm::Curses; |
2 | ||
3 | use strict; | |
4 | use Curses; | |
5 | use Term::ReadLine; | |
6 | use FileHandle; | |
7 | use POSIX; | |
8 | # use IO::Pty; | |
9 | use CommandTerm; | |
10 | ||
11 | use vars qw( | |
12 | @ISA | |
13 | %DerivedConfig | |
14 | $PROMPT_LENGTH | |
15 | ); | |
16 | ||
17 | @ISA = qw(CommandTerm); | |
18 | ||
19 | BEGIN { | |
20 | %DerivedConfig = ( | |
21 | 'dataFace' => 0, # normal | |
22 | 'statusFace' => 2, # green | |
23 | 'errorFace' => 1, # red | |
24 | ); | |
25 | ||
26 | $PROMPT_LENGTH = 13; | |
27 | } | |
28 | ||
29 | sub New { | |
30 | my ($class, $name, $cfgfile, $app_config) = @_; | |
31 | my $self = {}; | |
32 | ||
33 | bless $self, $class; | |
34 | ||
35 | $self->InitSignalHandlers; | |
36 | ||
37 | $self->Init($name, $cfgfile, $app_config, \%DerivedConfig); | |
38 | ||
39 | $self->InitReadLine; | |
40 | ||
41 | $self->{'ReadFD'} = ''; | |
42 | $self->{'WriteFD'} = ''; | |
43 | $self->{'ReadCallbacks'} = {}; | |
44 | $self->{'WriteCallbacks'} = {}; | |
45 | $self->{'GotInterrupt'} = 0; | |
46 | # $self->{'Pty'} = undef; | |
47 | ||
48 | # $self->InitPty; | |
49 | ||
50 | my $win = new Curses; | |
51 | $self->{'Win'} = $win; | |
52 | $self->{'ScrollWin'} = $win->subwin($LINES-1, $COLS, 0, 0); | |
53 | $self->{'PromptWin'} = $win->subwin(1, $PROMPT_LENGTH+1, $LINES-1, 0); | |
54 | $self->{'EntryWin'} = $win->subwin(1, $LINES-$PROMPT_LENGTH, $LINES-1, $PROMPT_LENGTH); | |
55 | $self->{'Scroll'} = 0; | |
56 | ||
57 | return $self; | |
58 | } | |
59 | ||
60 | sub MainLoop { | |
61 | my ($self) = @_; | |
62 | ||
63 | my ($fileno, $fd_read, $fd_write); | |
64 | ||
65 | initscr; | |
66 | ||
67 | if( has_colors() ) { | |
68 | start_color(); | |
69 | init_pair(1, COLOR_RED, COLOR_BLACK); | |
70 | init_pair(2, COLOR_GREEN, COLOR_BLACK); | |
71 | init_pair(3, COLOR_YELLOW, COLOR_BLACK); | |
72 | init_pair(4, COLOR_BLUE, COLOR_BLACK); | |
73 | init_pair(5, COLOR_MAGENTA, COLOR_BLACK); | |
74 | init_pair(6, COLOR_CYAN, COLOR_BLACK); | |
75 | init_pair(7, COLOR_WHITE, COLOR_BLACK); | |
76 | } | |
77 | ||
78 | $self->PromptWin->attron(A_BOLD); | |
79 | ||
80 | $self->ScrollWin->scrollok(1); | |
81 | ||
82 | $self->fileevent( | |
83 | *STDIN, | |
84 | 'readable' => sub{ $self->ReadLine->callback_read_char; }, | |
85 | ); | |
86 | $self->ReadLine->CallbackHandlerInstall( | |
87 | ' ' x $PROMPT_LENGTH, | |
88 | sub { $self->ProcessLine(@_); } | |
89 | ); | |
90 | $self->UpdatePrompt; | |
91 | $self->UpdateEntry; | |
92 | ||
93 | while( 1 ) { | |
94 | ||
95 | if( $self->GotInterrupt ) { | |
96 | $self->HandleInterrupt; | |
97 | $self->GotInterrupt(0); | |
98 | } | |
99 | ||
100 | next if select($fd_read = $self->ReadFD, $fd_write = $self->WriteFD, undef, 1.0) < 0; | |
101 | ||
102 | foreach $fileno (keys %{ $self->ReadCallbacks }) { | |
103 | &{ $self->{'ReadCallbacks'}{$fileno} } if vec($fd_read, $fileno, 1); | |
104 | } | |
105 | ||
106 | foreach $fileno (keys %{ $self->WriteCallbacks }) { | |
107 | &{ $self->{'WriteCallbacks'}{$fileno} } if vec($fd_write, $fileno, 1); | |
108 | } | |
109 | ||
110 | doupdate; | |
111 | } | |
112 | } | |
113 | ||
114 | sub fileevent { | |
115 | my ($self, $fh, $readwrite, $func) = @_; | |
116 | ||
117 | return unless defined($fh) and defined($readwrite); | |
118 | ||
119 | my $fileno = fileno($fh); | |
120 | ||
121 | if( $readwrite eq 'readable' ) { | |
122 | if( defined($func) and ref($func) eq 'CODE' ) { | |
123 | vec($self->{'ReadFD'}, $fileno, 1) = 1; | |
124 | $self->{'ReadCallbacks'}{$fileno} = $func; | |
125 | } else { | |
126 | vec($self->{'ReadFD'}, $fileno, 1) = 0; | |
127 | delete $self->{'ReadCallbacks'}{$fileno} | |
128 | } | |
129 | } elsif( $readwrite eq 'writable' ) { | |
130 | if( defined($func) and ref($func) eq 'CODE' ) { | |
131 | vec($self->{'WriteFD'}, $fileno, 1) = 1; | |
132 | $self->{'WriteCallbacks'}{$fileno} = $func; | |
133 | } else { | |
134 | vec($self->{'WriteFD'}, $fileno, 1) = 0; | |
135 | delete $self->{'WriteCallbacks'}{$fileno}; | |
136 | } | |
137 | } else { | |
138 | $self->PrintError("Bad mode to fileevent: '$readwrite'\n"); | |
139 | } | |
140 | } | |
141 | ||
142 | sub history { | |
143 | my ($self, @args) = @_; | |
144 | my ($opt_h, $opt_r, $opt_n); | |
145 | ||
146 | $self->get_options(\@args, ['no_pass_through'], 'h' => \$opt_h, 'r' => \$opt_r) or return; | |
147 | ||
148 | $opt_n = shift @args; | |
149 | ||
150 | if( $opt_n and $opt_n !~ /^\d+$/ ) { | |
151 | $self->PrintError("Argument to history '$opt_n' isn't numeric.\n"); | |
152 | return; | |
153 | } | |
154 | ||
155 | my $str = ''; | |
156 | my @history = $self->ReadLine->GetHistory; | |
157 | if( $opt_r ) { | |
158 | for(my $i=$#history; $i>=0; $i--) { | |
159 | $str .= ($opt_h ? '' : "\t$i\t" . "$history[$i]\n"); | |
160 | last if $opt_n and ($#history - $i + 1) >= $opt_n; | |
161 | } | |
162 | } else { | |
163 | $opt_n = $#history unless defined($opt_n); | |
164 | for(my $i=$#history-$opt_n+1; $i<=$#history; $i++) { | |
165 | $str .= ($opt_h ? '' : "\t$i\t" . "$history[$i]\n"); | |
166 | } | |
167 | } | |
168 | $self->PrintStatus($str); | |
169 | } | |
170 | ||
171 | # sub InitPty { | |
172 | # my ($self) = @_; | |
173 | # | |
174 | # $self->Pty(new IO::Pty); | |
175 | # my $tty = $self->Pty->slave; | |
176 | # | |
177 | # my $termios = POSIX::Termios->new; | |
178 | # $termios->getattr($tty->fileno) or die; | |
179 | # $termios->setiflag(IGNCR); | |
180 | # $termios->setoflag(0); | |
181 | # $termios->setlflag(0); | |
182 | # for(my $i=0; $i<NCCS; $i++) { | |
183 | # $termios->setcc($i, _POSIX_VDISABLE); | |
184 | # } | |
185 | # $termios->setcc(VMIN, 1); | |
186 | # $termios->setcc(VTIME, 0); | |
187 | # $termios->setattr($tty->fileno, TCSANOW) or die; | |
188 | # | |
189 | # close(STDERR); | |
190 | # open(STDERR, ">&" . $tty->fileno) or die "Couldn't re-open STDERR: $!"; | |
191 | # | |
192 | # select($tty); | |
193 | # | |
194 | # $self->fileevent($self->Pty, 'readable' => sub { $self->CaptureOutput }); | |
195 | # } | |
196 | # | |
197 | # sub CaptureOutput { | |
198 | # my ($self) = @_; | |
199 | # | |
200 | # my $Pty = $self->Pty; | |
201 | # my $data; | |
202 | # | |
203 | # unless( POSIX::read($Pty->fileno, $data, 1024) ) { | |
204 | # $self->fileevent($Pty, 'readable' => ''); | |
205 | # $self->Pty->close; | |
206 | # $self->Pty(undef); | |
207 | # select STDOUT; | |
208 | # $self->PrintError("Bad sysread from Pty: $!\n"); | |
209 | # $self->PrintError("Closing Pty and restoring STDOUT.\n"); | |
210 | # return; | |
211 | # } | |
212 | # | |
213 | # $self->PrintData($data); | |
214 | # } | |
215 | ||
216 | sub ShellExec { | |
217 | my ($self, $cmd, @args) = @_; | |
218 | ||
219 | if( $cmd eq 'cd' ) { | |
220 | my ($dir) = @args; | |
221 | ||
222 | $dir = '' unless $dir; | |
223 | ||
224 | $dir = $self->GlobExpand($dir); | |
225 | ||
226 | return unless defined($dir); | |
227 | ||
228 | $dir =~ s/^"(.*)"$/$1/; | |
229 | $dir =~ s/^'(.*)'$/$1/; | |
230 | ||
231 | if( chdir $dir ) { | |
232 | $self->PrintData( getcwd ); | |
233 | } else { | |
234 | $self->PrintError("Couldn't cd to '$dir': $!\n"); | |
235 | } | |
236 | } else { | |
237 | if( $self->Which($cmd) ) { | |
238 | endwin; | |
239 | # my $ttyname = $self->Pty->IO::Pty::ttyname; | |
240 | # system("$cmd @args 2>&1 > $ttyname"); | |
241 | system("$cmd @args"); | |
242 | # $self->PrintStatus( "ttyname: ", $self->Pty->IO::Pty::ttyname, "\n" ); | |
243 | # $self->PrintStatus( `$cmd @args` ); | |
244 | $self->UpdateEntry; | |
245 | } else { | |
246 | $self->PrintError("Command not found: '$cmd'\n"); | |
247 | } | |
248 | } | |
249 | } | |
250 | ||
251 | sub UpdateEntry { | |
252 | my ($self) = @_; | |
253 | my $entry_win = $self->EntryWin; | |
254 | ||
255 | $entry_win->erase; | |
256 | $entry_win->addstr(0, 0, $self->Attribs->{'line_buffer'}); | |
257 | $entry_win->move(0, $self->Attribs->{'point'}); | |
258 | $entry_win->noutrefresh; | |
259 | } | |
260 | ||
261 | sub ProcessLine { | |
262 | my ($self, $line) = @_; | |
263 | my $ReadLine = $self->ReadLine; | |
264 | my $Attribs = $self->Attribs; | |
265 | ||
266 | unless( defined($line) ) { | |
267 | print STDOUT "\n"; | |
268 | $self->quit; | |
269 | } | |
270 | ||
271 | $ReadLine->delete_text; | |
272 | $Attribs->{'point'} = $Attribs->{'end'} = 0; | |
273 | $self->UpdateEntry; | |
274 | ||
275 | $self->PrintStatus("> $line\n"); | |
276 | ||
277 | $self->SUPER::ProcessLine($line); | |
278 | ||
279 | $self->UpdatePrompt; | |
280 | ||
281 | # Since we're not using ReadLine interactively, set the history position | |
282 | # to the end every time through. | |
283 | $ReadLine->history_set_pos( scalar($ReadLine->GetHistory) ); | |
284 | ||
285 | $self->UpdateEntry; | |
286 | } | |
287 | ||
288 | sub UpdatePrompt { | |
289 | my ($self) = @_; | |
290 | ||
291 | $self->PromptWin->erase; | |
292 | $self->PromptWin->addstr(0, 0, $self->GetPrompt); | |
293 | $self->PromptWin->noutrefresh; | |
294 | } | |
295 | ||
296 | sub InitSignalHandlers { | |
297 | my ($self) = @_; | |
298 | ||
299 | $self->SUPER::InitSignalHandlers; | |
300 | $SIG{'INT'} = sub { $self->GotInterrupt(1); }; | |
301 | } | |
302 | ||
303 | sub InitReadLine { | |
304 | my ($self) = @_; | |
305 | ||
306 | $self->SUPER::InitReadLine; | |
307 | ||
308 | my $NULLOUT = FileHandle->new('> /dev/null') or | |
309 | die "Couldn't open '/dev/null': $!\n"; | |
310 | ||
311 | $self->Attribs->{'outstream'} = $NULLOUT; | |
312 | $self->Attribs->{'redisplay_function'} = sub { $self->UpdateEntry(@_); }; | |
313 | ||
314 | #We don't want any dinging at all, it's alarming. :-) | |
315 | $self->ReadLine->parse_and_bind('set bell-style none'); | |
316 | } | |
317 | ||
318 | sub TogglePrompt { | |
319 | my ($self) = @_; | |
320 | ||
321 | &{ $self->TogglePromptCallback }; | |
322 | ||
323 | $self->UpdatePrompt; | |
324 | } | |
325 | ||
326 | sub HandleInterrupt { | |
327 | my ($self) = @_; | |
328 | my $ReadLine = $self->ReadLine; | |
329 | my $Attribs = $self->Attribs; | |
330 | ||
331 | if( $Attribs and $Attribs->{'end'} != 0 ) { | |
332 | $ReadLine->modifying; | |
333 | $ReadLine->delete_text; | |
334 | $Attribs->{'point'} = $Attribs->{'end'} = 0; | |
335 | $self->UpdateEntry; | |
336 | } else { | |
337 | &{ $self->HandleInterruptCallback }; | |
338 | } | |
339 | } | |
340 | ||
341 | sub PrintCompletions { | |
342 | my ($self, $matchlist_ref, $num_matches, $longest, $striplen) = @_; | |
343 | ||
344 | my $match; | |
345 | my @matches = (); | |
346 | my $appended = 0; | |
347 | for(my $i=1; $i<=$num_matches; $i++) { | |
348 | $match = $matchlist_ref->[$i]; | |
349 | if( -d $match ) { | |
350 | $match .= '/'; | |
351 | $appended = 1; | |
352 | } elsif( -l $match ) { | |
353 | $match .= '@'; | |
354 | $appended = 1; | |
355 | } elsif( -x $match ) { | |
356 | $match .= '*'; | |
357 | $appended = 1; | |
358 | } | |
359 | push @matches, substr $match, $striplen; | |
360 | } | |
361 | $longest++ if $appended; | |
362 | ||
363 | my $num_cols = int($COLS/($longest+1)) || 1; | |
364 | my $skip = int($num_matches/$num_cols); | |
365 | $skip++ if ($num_matches/$num_cols) != $skip; | |
366 | ||
367 | my ($i, $j, $index); | |
368 | my $str = ''; | |
369 | for($i=0; $i<$skip; $i++) { | |
370 | for($j=0; $j<$num_cols; $j++) { | |
371 | $index = $i + ($j * $skip); | |
372 | if( $index < $num_matches ) { | |
373 | $str .= sprintf("%-${longest}s ", $matches[$index]); | |
374 | } | |
375 | } | |
376 | $str =~ s/ $/\n/; | |
377 | } | |
378 | $self->PrintData($str); | |
379 | $self->PrintStatus(">\n"); | |
380 | } | |
381 | ||
382 | sub Shutdown { | |
383 | my ($self) = @_; | |
384 | ||
385 | $self->PromptWin->erase; | |
386 | $self->EntryWin->erase; | |
387 | doupdate; | |
388 | endwin; | |
389 | # if( $self->Pty ) { | |
390 | # $self->fileevent($self->Pty, 'readable' => ''); | |
391 | # $self->Pty->close; | |
392 | # $self->Pty(undef); | |
393 | # } | |
394 | } | |
395 | ||
396 | sub Quit { | |
397 | my ($self) = @_; | |
398 | ||
399 | exit(0); | |
400 | } | |
401 | ||
402 | sub Title { | |
403 | } | |
404 | ||
405 | sub Print { | |
406 | my ($self, $how, @what) = @_; | |
407 | my $LogFH = $self->LogFH; | |
408 | my $scroll_win = $self->ScrollWin; | |
409 | my $ReDirFH = $self->ReDirFH; | |
410 | ||
411 | my $what = join '', @what; | |
412 | print $LogFH $what if defined $LogFH; | |
413 | ||
414 | if( $ReDirFH ) { | |
415 | print $ReDirFH $what; | |
416 | } else { | |
417 | return if $self->InExecFile and $how ne $self->ErrorFace; | |
418 | ||
419 | $scroll_win->attron(COLOR_PAIR($how)); | |
420 | ||
421 | my @lines = split(/\n/, $what); | |
422 | while( @lines ) { | |
423 | if( $self->Scroll > $LINES-2 ) { | |
424 | $scroll_win->scroll; | |
425 | $scroll_win->addstr($LINES-2, 0, shift(@lines)); | |
426 | } else { | |
427 | $scroll_win->addstr($self->{'Scroll'}++, 0, shift(@lines)); | |
428 | } | |
429 | } | |
430 | ||
431 | $scroll_win->attroff(COLOR_PAIR($how)); | |
432 | $scroll_win->noutrefresh; | |
433 | $self->UpdateEntry; | |
434 | } | |
435 | } | |
436 | ||
437 | sub DefaultInterruptCallback { | |
438 | my ($self) = @_; | |
439 | ||
440 | $self->PrintStatus(">\n"); | |
441 | } | |
442 | ||
443 | # sub CommandTerm::Curses::clear { | |
444 | # my ($self) = @_; | |
445 | # | |
446 | # $self->ScrollWin->clear; | |
447 | # $self->ScrollWin->refresh; | |
448 | # } | |
449 | ||
450 | 1; |