Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package CommandTerm::Tk; |
2 | ||
3 | use strict; | |
4 | use Tk; | |
5 | use Tk::LabEntry; | |
6 | use Term::ReadLine; | |
7 | use FileHandle; | |
8 | use POSIX; | |
9 | use CommandTerm; | |
10 | ||
11 | @CommandTerm::Tk::ISA = qw(CommandTerm Tk::Frame); | |
12 | Tk::Widget->Construct('CommandTermTk'); | |
13 | ||
14 | use vars qw( | |
15 | %DerivedConfig | |
16 | ); | |
17 | ||
18 | BEGIN { | |
19 | %DerivedConfig = ( | |
20 | 'width' => '80', | |
21 | 'height' => '24', | |
22 | 'textFont' => '-*-courier-medium-r-*-*-12-*-*-*-*-*-*-*', | |
23 | 'entryFont' => '-*-courier-medium-r-*-*-12-*-*-*-*-*-*-*', | |
24 | 'promptFont' => '-*-courier-bold-r-*-*-12-*-*-*-*-*-*-*', | |
25 | 'saveTextLines' => '5000', | |
26 | 'dataFace' => 'normal', | |
27 | 'statusFace' => 'italic', | |
28 | 'errorFace' => 'bold', | |
29 | ); | |
30 | } | |
31 | ||
32 | sub Populate { | |
33 | my ($self, $args) = @_; | |
34 | ||
35 | my $name = delete $args->{'-name'}; | |
36 | my $toplevel = delete $args->{'-toplevel'}; | |
37 | my $cfgfile = delete $args->{'-cfgfile'}; | |
38 | my $app_config = delete $args->{'-app_config'}; | |
39 | ||
40 | $self->InitSignalHandlers; | |
41 | $self->Init($name, $cfgfile, $app_config, \%DerivedConfig); | |
42 | $self->NoPipes(1); | |
43 | ||
44 | my $prompt = delete $args->{'-prompt'} || $self->GetPrompt; | |
45 | ||
46 | my $width = $self->{'Config'}{'width'}; | |
47 | my $height = $self->{'Config'}{'height'}; | |
48 | my $textFont = $self->{'Config'}{'textFont'}; | |
49 | my $entryFont = $self->{'Config'}{'entryFont'}; | |
50 | my $promptFont = $self->{'Config'}{'promptFont'}; | |
51 | my $italicFont = '-*-courier-medium-o-*-*-12-*-*-*-*-*-*-*'; | |
52 | ||
53 | $self->{'TopLevel'} = $toplevel; | |
54 | $self->{'RealWidth'} = $width; | |
55 | $self->{'SaveTextLines'} = $self->{'Config'}{'saveTextLines'}; | |
56 | $self->{'DataFace'} = $self->{'Config'}{'dataFace'}; | |
57 | $self->{'StatusFace'} = $self->{'Config'}{'statusFace'}; | |
58 | $self->{'ErrorFace'} = $self->{'Config'}{'errorFace'}; | |
59 | ||
60 | $self->SUPER::Populate($args); | |
61 | ||
62 | my $TextFrame = $self->Frame; | |
63 | my $Text = $TextFrame->Text( | |
64 | -relief => 'sunken', | |
65 | -wrap => 'word', | |
66 | -state => 'disabled', | |
67 | -font => $textFont, | |
68 | -width => $width, | |
69 | -height => $height, | |
70 | ); | |
71 | $Text->bind( "<Configure>" => sub { $self->FigureOutWidth } ); | |
72 | $Text->tagConfigure( $self->DataFace, -font => $textFont ); | |
73 | $Text->tagConfigure( $self->StatusFace, -font => $italicFont ); | |
74 | $Text->tagConfigure( $self->ErrorFace, -font => $promptFont ); | |
75 | ||
76 | my $ScrollBar = $self->Scrollbar( -command => [$Text => 'yview']); | |
77 | $Text->configure( -yscrollcommand => [$ScrollBar => 'set'] ); | |
78 | my %nopad = ( -pady => 0, -ipady => 0, -padx => 0, -ipadx => 0 ); | |
79 | $ScrollBar->pack( %nopad, -side => 'right', -fill => 'y' ); | |
80 | $Text->pack( %nopad, -side => 'left', -expand => 'both', -fill => 'both' ); | |
81 | ||
82 | my $EntryFrame = $self->Frame; | |
83 | my $Entry = $EntryFrame->Component( | |
84 | LabEntry => 'labEntry', | |
85 | -label => $prompt, | |
86 | -labelPack => [ -side => 'left' ], | |
87 | -relief => 'sunken', | |
88 | -font => $entryFont, | |
89 | ); | |
90 | $Entry->Subwidget('label')->configure( -font => $promptFont ); | |
91 | $Entry->pack( -fill => 'x' ); | |
92 | $Entry->bind( '<Delete>' => 'Backspace' ); | |
93 | $Entry->bind( '<Return>' => sub { $self->ProcessEntry; } ); | |
94 | $Entry->bind( '<Tab>' => sub { $self->Complete; } ); | |
95 | $Entry->bind( '<Control-t>' => sub { $self->TogglePrompt; } ); | |
96 | $Entry->bind( '<Up>' => sub { $self->UpHistory; } ); | |
97 | $Entry->bind( '<Control-p>' => sub { $self->UpHistory; } ); | |
98 | $Entry->bind( '<Down>' => sub { $self->DownHistory; } ); | |
99 | $Entry->bind( '<Control-n>' => sub { $self->DownHistory; } ); | |
100 | $Entry->bind( '<Control-l>' => sub { $self->clear; } ); | |
101 | $Entry->bind( '<Control-u>' => sub { $Entry->delete(0, 'end'); } ); | |
102 | $Entry->bind( '<Control-c>' => sub { $self->HandleInterrupt; } ); | |
103 | $Entry->bind( '<Home>' => sub { $self->Home; } ); | |
104 | $Entry->bind( '<End>' => sub { $self->End; } ); | |
105 | $Entry->bind( '<Prior>' => sub { $self->ScrollUp; } ); | |
106 | $Entry->bind( '<Next>' => sub { $self->ScrollDown; } ); | |
107 | $Entry->Subwidget('entry')->bindtags( | |
108 | [$Entry->Subwidget('entry'), | |
109 | ref($Entry->Subwidget('entry')), 'all'] | |
110 | ); | |
111 | ||
112 | # Button 2 release events will paste the X selection into the | |
113 | # entry widget no matter where the cursor is over $self | |
114 | $self->bind( 'Tk::Entry', '<ButtonRelease-2>', undef); | |
115 | $self->bind( 'Tk::Text', '<ButtonRelease-2>', undef); | |
116 | $self->bind( 'all', '<ButtonRelease-2>' => | |
117 | sub { | |
118 | Tk::catch { | |
119 | $Entry->insert($Entry->index('insert'), $self->SelectionGet) | |
120 | }; | |
121 | $Entry->SeeInsert; | |
122 | } | |
123 | ); | |
124 | ||
125 | $EntryFrame->pack( -side => 'bottom' , -fill => 'x' ); | |
126 | $TextFrame->pack( -side => 'top' , -fill => 'both', -expand => 'both' ); | |
127 | ||
128 | $self->Advertise('Text' => $Text ); | |
129 | $self->Advertise('Entry' => $Entry ); | |
130 | ||
131 | $self->InitReadLine; | |
132 | ||
133 | $Entry->Subwidget('entry')->focus; | |
134 | } | |
135 | ||
136 | sub history { | |
137 | my ($self, @args) = @_; | |
138 | my ($opt_h, $opt_r, $opt_n); | |
139 | ||
140 | $self->get_options(\@args, ['no_pass_through'], 'h' => \$opt_h, 'r' => \$opt_r) or return; | |
141 | ||
142 | $opt_n = shift @args; | |
143 | ||
144 | if( $opt_n and $opt_n !~ /^\d+$/ ) { | |
145 | $self->PrintError("Argument to history '$opt_n' isn't numeric.\n"); | |
146 | return; | |
147 | } | |
148 | ||
149 | my $str = ''; | |
150 | my @history = $self->ReadLine->GetHistory; | |
151 | if( $opt_r ) { | |
152 | for(my $i=$#history; $i>=0; $i--) { | |
153 | $str .= ($opt_h ? '' : "\t$i\t" . "$history[$i]\n"); | |
154 | last if $opt_n and ($#history - $i + 1) >= $opt_n; | |
155 | } | |
156 | } else { | |
157 | $opt_n = $#history unless defined($opt_n); | |
158 | for(my $i=$#history-$opt_n+1; $i<=$#history; $i++) { | |
159 | $str .= ($opt_h ? '' : "\t$i\t" . "$history[$i]\n"); | |
160 | } | |
161 | } | |
162 | $self->PrintStatus($str); | |
163 | } | |
164 | ||
165 | sub ShellExec { | |
166 | my ($self, $cmd, @args) = @_; | |
167 | ||
168 | if( $cmd eq 'cd' ) { | |
169 | my ($dir) = @args; | |
170 | ||
171 | $dir = '' unless $dir; | |
172 | ||
173 | $dir = $self->GlobExpand($dir); | |
174 | ||
175 | return unless defined($dir); | |
176 | ||
177 | $dir =~ s/^"(.*)"$/$1/; | |
178 | $dir =~ s/^'(.*)'$/$1/; | |
179 | ||
180 | if( chdir $dir ) { | |
181 | $self->PrintData( getcwd . "\n" ); | |
182 | } else { | |
183 | $self->PrintError("Couldn't cd to '$dir': $!\n"); | |
184 | } | |
185 | } else { | |
186 | if( $self->Which($cmd) ) { | |
187 | $self->PrintData( `$cmd @args` ); | |
188 | } else { | |
189 | $self->PrintError("Command not found: '$cmd'\n"); | |
190 | } | |
191 | } | |
192 | } | |
193 | ||
194 | sub ProcessEntry { | |
195 | my ($self) = @_; | |
196 | my $Entry = $self->Subwidget('Entry'); | |
197 | my $line = $Entry->get; | |
198 | ||
199 | chomp($line); | |
200 | ||
201 | $Entry->delete(0, 'end'); | |
202 | ||
203 | $self->ProcessLine($line); | |
204 | } | |
205 | ||
206 | sub ProcessLine { | |
207 | my ($self, $line) = @_; | |
208 | my $ReadLine = $self->ReadLine; | |
209 | ||
210 | $self->CloseRedirection; | |
211 | ||
212 | $self->PrintError("> $line\n"); | |
213 | ||
214 | $self->SUPER::ProcessLine($line); | |
215 | ||
216 | $self->Subwidget('Entry')->configure( -label => $self->GetPrompt ); | |
217 | ||
218 | # Since we're not using ReadLine interactively, set the history position | |
219 | # to the end every time through. | |
220 | $ReadLine->history_set_pos( scalar($ReadLine->GetHistory()) ); | |
221 | } | |
222 | ||
223 | sub InitReadLine { | |
224 | my ($self) = @_; | |
225 | ||
226 | $self->SUPER::InitReadLine; | |
227 | ||
228 | my $NULLOUT = FileHandle->new('> /dev/null') or | |
229 | die "Couldn't open '/dev/null': $!\n"; | |
230 | ||
231 | $self->Attribs->{'outstream'} = $NULLOUT; | |
232 | ||
233 | #In Tk mode, don't want any dinging at all, it's alarming. :-) | |
234 | $self->ReadLine->parse_and_bind('set bell-style none'); | |
235 | } | |
236 | ||
237 | sub TogglePrompt { | |
238 | my ($self) = @_; | |
239 | ||
240 | &{ $self->TogglePromptCallback }; | |
241 | ||
242 | $self->Subwidget('Entry')->configure( -label => $self->GetPrompt ); | |
243 | ||
244 | Tk->break; | |
245 | } | |
246 | ||
247 | sub Complete { | |
248 | my ($self) = @_; | |
249 | my $ReadLine = $self->ReadLine; | |
250 | my $Attribs = $self->Attribs; | |
251 | my $Entry = $self->Subwidget('Entry'); | |
252 | my $line = $Entry->get; | |
253 | ||
254 | $Attribs->{'line_buffer'} = $line; | |
255 | $Attribs->{'point'} = $Entry->index('insert'); | |
256 | $Attribs->{'end'} = length($Attribs->{'line_buffer'}); | |
257 | ||
258 | $ReadLine->complete_internal(ord("\t")); | |
259 | ||
260 | if( $line ne $Attribs->{'line_buffer'} ) { | |
261 | # completion took place | |
262 | $Entry->delete(0, 'end'); | |
263 | $Entry->insert(0, $Attribs->{'line_buffer'}); | |
264 | $Entry->icursor($Attribs->{'point'}); | |
265 | $Entry->SeeInsert; | |
266 | } else { | |
267 | # no completion took place, list possible completions | |
268 | $ReadLine->complete_internal(ord('?')); | |
269 | } | |
270 | ||
271 | Tk->break; | |
272 | } | |
273 | ||
274 | sub PrintCompletions { | |
275 | my ($self, $matchlist_ref, $num_matches, $longest, $striplen) = @_; | |
276 | ||
277 | my $match; | |
278 | my @matches = (); | |
279 | my $appended = 0; | |
280 | for(my $i=1; $i<=$num_matches; $i++) { | |
281 | $match = $matchlist_ref->[$i]; | |
282 | if( -d $match ) { | |
283 | $match .= '/'; | |
284 | $appended = 1; | |
285 | } elsif( -l $match ) { | |
286 | $match .= '@'; | |
287 | $appended = 1; | |
288 | } elsif( -x $match ) { | |
289 | $match .= '*'; | |
290 | $appended = 1; | |
291 | } | |
292 | push @matches, substr $match, $striplen; | |
293 | } | |
294 | $longest++ if $appended; | |
295 | ||
296 | my $width = $self->RealWidth; | |
297 | my $num_cols = int($width/($longest+1)) || 1; | |
298 | my $skip = int($num_matches/$num_cols); | |
299 | $skip++ if ($num_matches/$num_cols) != $skip; | |
300 | ||
301 | my ($i, $j, $index); | |
302 | my $str = ''; | |
303 | for($i=0; $i<$skip; $i++) { | |
304 | for($j=0; $j<$num_cols; $j++) { | |
305 | $index = $i + ($j * $skip); | |
306 | if( $index < $num_matches ) { | |
307 | $str .= sprintf("%-${longest}s ", $matches[$index]); | |
308 | } | |
309 | } | |
310 | $str =~ s/ $/\n/; | |
311 | } | |
312 | $self->PrintStatus($str); | |
313 | $self->PrintError(">\n"); | |
314 | } | |
315 | ||
316 | sub Shutdown { } | |
317 | ||
318 | sub Quit { | |
319 | Tk::exit; | |
320 | } | |
321 | ||
322 | sub Title { | |
323 | my ($self, $titlestr) = @_; | |
324 | ||
325 | $self->TopLevel->title($titlestr) if $self->TopLevel; | |
326 | } | |
327 | ||
328 | sub Icon { | |
329 | my ($self, $iconstr) = @_; | |
330 | ||
331 | $self->TopLevel->iconname($iconstr) if $self->TopLevel; | |
332 | } | |
333 | ||
334 | sub Print { | |
335 | my ($self, $how, @what) = @_; | |
336 | my $Text = $self->Subwidget('Text'); | |
337 | my ($top, $bottom) = $Text->yview; | |
338 | my $LogFH = $self->LogFH; | |
339 | my $ReDirFH = $self->ReDirFH; | |
340 | ||
341 | my $what = join '', @what; | |
342 | print $LogFH $what if defined $LogFH; | |
343 | ||
344 | if( $ReDirFH ) { | |
345 | print $ReDirFH $what; | |
346 | } else { | |
347 | ||
348 | $Text->configure( -state => 'normal' ); | |
349 | if( $what =~ /[\b]/ ) { | |
350 | foreach my $bsline (split("(\b)", $what)) { | |
351 | if( $bsline eq "\b" ) { | |
352 | $Text->delete('end -2 chars'); | |
353 | } else { | |
354 | $Text->insert('end', $bsline, $how ); | |
355 | } | |
356 | } | |
357 | } else { | |
358 | $Text->insert('end', $what, $how ); | |
359 | } | |
360 | ||
361 | my $deletelines = ($Text->index('end') - 2.0) - $self->SaveTextLines; | |
362 | $Text->delete( '1.0', $deletelines . ".0" ) if $deletelines > 1; | |
363 | ||
364 | $Text->see( 'end' ) if $bottom == 1.0; | |
365 | ||
366 | $Text->configure( -state => 'disabled' ); | |
367 | ||
368 | $self->idletasks; | |
369 | } | |
370 | } | |
371 | ||
372 | sub UpHistory { | |
373 | my ($self) = @_; | |
374 | my $Entry = $self->Subwidget('Entry'); | |
375 | ||
376 | my $line = $self->ReadLine->previous_history; | |
377 | ||
378 | if( $line ne '' ) { | |
379 | $Entry->delete(0, 'end'); | |
380 | $Entry->insert(0, $line ); | |
381 | } | |
382 | } | |
383 | ||
384 | sub DownHistory { | |
385 | my ($self) = @_; | |
386 | my $Entry = $self->Subwidget('Entry'); | |
387 | ||
388 | my $line = $self->ReadLine->next_history; | |
389 | ||
390 | $Entry->delete(0, 'end'); | |
391 | $Entry->insert(0, $line ); | |
392 | } | |
393 | ||
394 | sub HandleInterrupt { | |
395 | my ($self) = @_; | |
396 | my $Entry = $self->Subwidget('Entry'); | |
397 | ||
398 | if( $Entry->get ne '' ) { | |
399 | $Entry->delete(0, 'end'); | |
400 | } else { | |
401 | &{ $self->HandleInterruptCallback }; | |
402 | } | |
403 | } | |
404 | ||
405 | sub DefaultInterruptCallback { | |
406 | my ($self) = @_; | |
407 | ||
408 | $self->PrintError(">\n"); | |
409 | $self->UpdatePrompt(1); | |
410 | } | |
411 | ||
412 | sub FigureOutWidth { | |
413 | my ($self) = @_; | |
414 | my ($i, $xleft, $xright, $ytop, $ybot, $line); | |
415 | my $Text = $self->Subwidget('Text'); | |
416 | ||
417 | ($ytop, $ybot) = $Text->yview; | |
418 | $line = $Text->index( 'end' ) - 1; | |
419 | $Text->configure( -state => 'normal', -wrap => 'none' ); | |
420 | $Text->see( 'end' ); | |
421 | $i = 0; | |
422 | ($xleft, $xright) = $Text->xview; | |
423 | while( $xleft == 0.0 and $xright == 1.0 ) { | |
424 | $Text->insert( 'end' => 'O', 'italic' ); | |
425 | ($xleft, $xright) = $Text->xview; | |
426 | $i++; | |
427 | } | |
428 | $Text->delete( "$line.0", 'end -1 chars' ); | |
429 | $Text->yview( 'moveto' => $ytop ); | |
430 | $Text->configure( -state => 'disabled', -wrap => 'word' ); | |
431 | $self->RealWidth($i--); | |
432 | } | |
433 | ||
434 | sub clear { | |
435 | my ($self) = @_; | |
436 | my $Text = $self->Subwidget('Text'); | |
437 | ||
438 | $Text->configure( -state => 'normal' ); | |
439 | $Text->delete( '1.0', 'end' ); | |
440 | $Text->see( '1.0' ); | |
441 | $Text->configure( -state => 'disabled' ); | |
442 | } | |
443 | ||
444 | sub Home { | |
445 | my ($self) = @_; | |
446 | my $Text = $self->Subwidget('Text'); | |
447 | ||
448 | $Text->configure( -state => 'normal' ); | |
449 | $Text->see( '1.0' ); | |
450 | $Text->configure( -state => 'disabled' ); | |
451 | } | |
452 | ||
453 | sub End { | |
454 | my ($self) = @_; | |
455 | my $Text = $self->Subwidget('Text'); | |
456 | ||
457 | $Text->configure( -state => 'normal' ); | |
458 | $Text->see( 'end' ); | |
459 | $Text->configure( -state => 'disabled' ); | |
460 | } | |
461 | ||
462 | sub ScrollUp { | |
463 | my ($self) = @_; | |
464 | my $Text = $self->Subwidget('Text'); | |
465 | ||
466 | $Text->configure( -state => 'normal' ); | |
467 | $Text->yview( 'scroll' => -1, 'pages'); | |
468 | $Text->configure( -state => 'disabled' ); | |
469 | } | |
470 | ||
471 | sub ScrollDown { | |
472 | my ($self) = @_; | |
473 | my $Text = $self->Subwidget('Text'); | |
474 | ||
475 | $Text->configure( -state => 'normal' ); | |
476 | $Text->yview( 'scroll' => 1, 'pages'); | |
477 | $Text->configure( -state => 'disabled' ); | |
478 | } | |
479 | ||
480 | 1; |