Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package CommandTerm; |
2 | ||
3 | use strict; | |
4 | use Getopt::Long; | |
5 | use POSIX; | |
6 | ||
7 | use vars qw( | |
8 | $AUTOLOAD | |
9 | $VERSION | |
10 | $COMMAND_MODE | |
11 | $PERL_MODE | |
12 | @Commands | |
13 | @Filename_Completers | |
14 | %BaseConfig | |
15 | ); | |
16 | ||
17 | BEGIN { | |
18 | $VERSION = '1.05'; | |
19 | ||
20 | $COMMAND_MODE = 1; | |
21 | $PERL_MODE = 2; | |
22 | ||
23 | @Commands = qw( | |
24 | clear | |
25 | do | |
26 | history | |
27 | logfile | |
28 | help | |
29 | quit | |
30 | exit | |
31 | setenv | |
32 | ); | |
33 | ||
34 | @Filename_Completers = qw( | |
35 | do | |
36 | logfile | |
37 | ); | |
38 | ||
39 | %BaseConfig = ( | |
40 | 'dataFace' => 'data', | |
41 | 'statusFace' => 'status', | |
42 | 'errorFace' => 'error', | |
43 | 'historyFile' => '.commandterm_history', | |
44 | 'historySaveLength' => -1, | |
45 | ); | |
46 | } | |
47 | ||
48 | sub Commands { | |
49 | return @Commands; | |
50 | } | |
51 | ||
52 | sub Filename_Completers { | |
53 | return @Filename_Completers; | |
54 | } | |
55 | ||
56 | sub Init { | |
57 | my ($self, $name, $cfgfile, $app_config, $derived_config) = @_; | |
58 | ||
59 | $self->{'Name'} = $name || 'commandterm'; | |
60 | $self->{'Help'} = CommandTerm::Help->New; | |
61 | $self->{'EvalBuffer'} = ''; | |
62 | $self->{'MLC'} = 0; | |
63 | $self->{'EMLC'} = 0; | |
64 | $self->{'InputMode'} = 1; | |
65 | $self->{'GetPromptCallback'} = sub { return $self->DefaultGetPrompt; }; | |
66 | $self->{'TogglePromptCallback'} = sub { return $self->DefaultTogglePrompt; }; | |
67 | $self->{'ExecCommandCallback'} = sub { $self->DefaultCommandExec(@_); }; | |
68 | $self->{'UpdatePrompt'} = 1; | |
69 | $self->{'HandleInterruptCallback'} = sub { $self->DefaultInterruptCallback; }; | |
70 | $self->{'QuitCallback'} = undef; | |
71 | $self->{'ReadLine'} = undef; | |
72 | $self->{'Attribs'} = undef; | |
73 | $self->{'ReDirFH'} = undef; | |
74 | $self->{'NoPipes'} = 0; | |
75 | $self->{'DefaultPager'} = undef; | |
76 | $self->{'PagerCommands'} = []; | |
77 | $self->{'LogFH'} = undef; | |
78 | $self->{'LogFileName'} = ''; | |
79 | $self->{'EnvVars'} = []; | |
80 | $self->{'PerlIndex'} = 0; | |
81 | $self->{'PerlMatches'} = []; | |
82 | ||
83 | $self->{'Config'} = $self->GetConfig($cfgfile, $app_config, $derived_config); | |
84 | ||
85 | $self->{'StatusFace'} = $self->{'Config'}{'statusFace'}; | |
86 | $self->{'DataFace'} = $self->{'Config'}{'dataFace'}; | |
87 | $self->{'ErrorFace'} = $self->{'Config'}{'errorFace'}; | |
88 | $self->{'HistoryFile'} = $self->{'Config'}{'historyFile'}; | |
89 | $self->{'HistorySaveLength'} = $self->{'Config'}{'historySaveLength'}; | |
90 | } | |
91 | ||
92 | sub AUTOLOAD { | |
93 | my ($self, $val) = @_; | |
94 | my $method = $AUTOLOAD; | |
95 | ||
96 | $method =~ s/.*://; | |
97 | ||
98 | return undef if $method eq 'DESTROY'; | |
99 | ||
100 | if( exists($self->{$method}) ) { | |
101 | my $old_val = $self->{$method}; | |
102 | if( scalar(@_) > 1 ) { | |
103 | $self->{$method} = $val; | |
104 | } | |
105 | return $old_val; | |
106 | } else { | |
107 | print STDERR "Bad method '$method' for class ", ref($self), "\n"; | |
108 | return undef; | |
109 | } | |
110 | } | |
111 | ||
112 | sub GetConfig { | |
113 | my ($self, $cfgfile, $app_config, $derived_config) = @_; | |
114 | ||
115 | my $config = {}; | |
116 | ||
117 | # Base Class Defaults | |
118 | foreach my $key (keys %BaseConfig) { | |
119 | $config->{$key} = $BaseConfig{$key}; | |
120 | } | |
121 | ||
122 | # Derived Class Defaults | |
123 | if( $derived_config and ref($derived_config) eq 'HASH' ) { | |
124 | foreach my $key (keys %$derived_config) { | |
125 | $config->{$key} = $derived_config->{$key}; | |
126 | } | |
127 | } | |
128 | ||
129 | # Application defaults | |
130 | if( $app_config and ref($app_config) eq 'HASH' ) { | |
131 | foreach my $key (keys %$app_config) { | |
132 | $config->{$key} = $app_config->{$key}; | |
133 | } | |
134 | } | |
135 | ||
136 | # User defaults | |
137 | if( $cfgfile ) { | |
138 | my $fh = FileHandle->new("< $cfgfile"); | |
139 | if( $fh ) { | |
140 | while( <$fh> ) { | |
141 | next if /^\s*#/; | |
142 | next if /^\s*$/; | |
143 | my ($name, $value) = /(\w+)\s*:\s*([^\s].*[^\s])\s*$/; | |
144 | $config->{$name} = $value; | |
145 | } | |
146 | $fh->close; | |
147 | } | |
148 | } | |
149 | ||
150 | return $config; | |
151 | } | |
152 | ||
153 | sub InitSignalHandlers { | |
154 | my ($self) = @_; | |
155 | ||
156 | $SIG{'INT'} = sub { $self->quit; }; | |
157 | $SIG{'TERM'} = sub { $self->quit; }; | |
158 | $SIG{'QUIT'} = sub { $self->quit; }; | |
159 | $SIG{'PIPE'} = 'IGNORE'; | |
160 | } | |
161 | ||
162 | sub DefaultInterruptCallback {} | |
163 | ||
164 | sub PrintData { | |
165 | my ($self, @what) = @_; | |
166 | ||
167 | $self->Print($self->DataFace, @what); | |
168 | } | |
169 | ||
170 | sub PrintStatus { | |
171 | my ($self, @what) = @_; | |
172 | ||
173 | $self->Print($self->StatusFace, @what); | |
174 | } | |
175 | ||
176 | sub PrintError { | |
177 | my ($self, @what) = @_; | |
178 | ||
179 | $self->Print($self->ErrorFace, @what); | |
180 | } | |
181 | ||
182 | sub Print { | |
183 | my ($self, $how, @what) = @_; | |
184 | my $what = join '', @what; | |
185 | ||
186 | my $LOGFILE = $self->LogFH; | |
187 | ||
188 | print $LOGFILE $what if defined($LOGFILE); | |
189 | ||
190 | print "$how: $what"; | |
191 | } | |
192 | ||
193 | sub DefaultCompleter { | |
194 | my ($self, $text, $line, $start, $end) = @_; | |
195 | my ($first) = (substr($line, 0, $start) =~ /;?([^;\[]*)$/); | |
196 | my $command = ($first =~ /^\s*(\S+)\s+/)[0] || ''; | |
197 | my $ReadLine = $self->ReadLine; | |
198 | my $Attribs = $self->Attribs; | |
199 | ||
200 | return $self->PerlCustomCompleter($text, $line, $start, $end) | |
201 | if ($self->InputMode == $PERL_MODE) or | |
202 | grep(/1/, map($command =~ /^$_$/, $self->GetPerlSubs)); | |
203 | ||
204 | my $completer; | |
205 | ||
206 | $Attribs->{'completion_append_character'} = ' '; | |
207 | $Attribs->{'ignore_some_completions_function'} = undef; | |
208 | ||
209 | if( $first =~ /^\s*$/ ) { | |
210 | $Attribs->{'completion_word'} = [ ($self->GetPerlSubs, @Commands) ]; | |
211 | $completer = 'list_completion_function'; | |
212 | } elsif( $first =~ /\|\s*$/ ) { | |
213 | } elsif( $command eq 'setenv' or $command eq 'printenv' ) { | |
214 | $Attribs->{'completion_word'} = [ map { s/\$//; $_ } keys %ENV ]; | |
215 | $completer = 'list_completion_function'; | |
216 | } elsif( $command eq 'help' ) { | |
217 | $Attribs->{'completion_word'} = [ @Commands ]; | |
218 | $completer = 'list_completion_function'; | |
219 | } elsif( $text =~ /\// ) { | |
220 | $completer = 'filename_completion_function'; | |
221 | $Attribs->{'ignore_some_completions_function'} = | |
222 | sub { $self->IgnoreSomeCompletions($text, @_); }; | |
223 | } elsif( $text =~ /^\$/ ) { | |
224 | $Attribs->{'completion_append_character'} = ''; | |
225 | $Attribs->{'completion_word'} = [ @{ $self->EnvVars } ]; | |
226 | $completer = 'list_completion_function'; | |
227 | } elsif( $text =~ /^~/ ) { | |
228 | $completer = 'username_completion_function'; | |
229 | } else { | |
230 | $completer = 'filename_completion_function'; | |
231 | $Attribs->{'ignore_some_completions_function'} = | |
232 | sub { $self->IgnoreSomeCompletions($text, @_); }; | |
233 | } | |
234 | ||
235 | return $completer ? $ReadLine->completion_matches($text, $Attribs->{$completer}) : (); | |
236 | } | |
237 | ||
238 | sub GlobExpand { | |
239 | my ($self, $arg) = @_; | |
240 | ||
241 | $arg = $self->TildeExpand($arg); | |
242 | ||
243 | return undef unless defined($arg); | |
244 | ||
245 | return $self->EnvVarExpand($arg); | |
246 | } | |
247 | ||
248 | sub EnvVarExpand { | |
249 | my ($self, $arg) = @_; | |
250 | ||
251 | while( $arg =~ /\$([^\$\/]+)/ ) { | |
252 | if( defined($ENV{$1}) ) { | |
253 | $arg =~ s/\$([^\$\/]+)/$ENV{$1}/e; | |
254 | } else { | |
255 | $self->PrintError("Undefined variable: '$1'\n"); | |
256 | return undef; | |
257 | } | |
258 | } | |
259 | return $arg; | |
260 | } | |
261 | ||
262 | sub TildeExpand { | |
263 | my ($self, $arg) = @_; | |
264 | ||
265 | if( $arg =~ /^~([^\/]*)(.*)/ ) { | |
266 | my $username = $1; | |
267 | my $rest = $2; | |
268 | if( $username ) { | |
269 | my @pwnam = getpwnam($username); | |
270 | if( @pwnam > 0 ) { | |
271 | $arg = $pwnam[7] . $rest; | |
272 | } else { | |
273 | $self->PrintError("No user '$username' exists.\n"); | |
274 | return undef; | |
275 | } | |
276 | } else { | |
277 | $arg = ($ENV{'HOME'} || $ENV{'LOGDIR'}) . $rest; | |
278 | } | |
279 | } | |
280 | return $arg; | |
281 | } | |
282 | ||
283 | sub UnEscape { | |
284 | my ($self, $arg) = @_; | |
285 | ||
286 | return undef unless defined $arg; | |
287 | ||
288 | $arg =~ s/\\t/\t/g; | |
289 | $arg =~ s/\\n/\n/g; | |
290 | $arg =~ s/\\r/\r/g; | |
291 | $arg =~ s/\\f/\f/g; | |
292 | $arg =~ s/\\a/\a/g; | |
293 | $arg =~ s/\\e/\e/g; | |
294 | $arg =~ s/\\c(.)/pack('C*', ord(uc($1))^64)/eg; | |
295 | $arg =~ s/\\x([\da-fA-F]{1,2})/pack 'C*', hex($1)/eg; | |
296 | $arg =~ s/\\([01][0-7]{2})/pack 'C*', oct($1)/eg; | |
297 | $arg =~ s/\\0/\0/g; | |
298 | $arg =~ s/\\(.)/$1/g; | |
299 | ||
300 | return $arg; | |
301 | } | |
302 | ||
303 | sub Tokenize { | |
304 | my ($self, $command) = @_; | |
305 | ||
306 | my @command = (); | |
307 | ||
308 | foreach my $arg ($self->ReadLine->history_tokenize($command)) { | |
309 | ||
310 | $arg = $self->TildeExpand($arg); | |
311 | ||
312 | return () unless defined($arg); | |
313 | ||
314 | $arg = $self->UnEscape($arg) if $arg =~ /\\/ and $arg !~ /^["']/; | |
315 | ||
316 | push @command, $arg; | |
317 | } | |
318 | return @command; | |
319 | } | |
320 | ||
321 | sub DefaultCommandExec { | |
322 | my ($self, $command) = @_; | |
323 | ||
324 | if( defined($command) ) { | |
325 | if( $self->InputMode == $PERL_MODE and $command !~ /^\s*$/ ) { | |
326 | $self->EvalPerl($command); | |
327 | } else { | |
328 | my @command = $self->Tokenize($command); | |
329 | ||
330 | if( @command > 0 ) { | |
331 | my @redir_command = @command; | |
332 | if( $self->InitRedirection(\@redir_command) ) { | |
333 | my ($cmd, @args) = @redir_command; | |
334 | my $qm = quotemeta($cmd); | |
335 | ||
336 | if( grep(/^$qm$/, $self->GetPerlSubs) ) { | |
337 | $self->RunPerlSub($cmd, @args); | |
338 | } elsif( grep(/^$qm$/, $self->Commands) ) { | |
339 | $self->$cmd(@args); | |
340 | } else { | |
341 | $self->ShellExec(@command); | |
342 | } | |
343 | } | |
344 | } | |
345 | } | |
346 | } | |
347 | } | |
348 | ||
349 | # Setup output redirection, if any. If the command has a '|', '>', or | |
350 | # '>>' token in it, use that token and the rest of the args as the redirection . | |
351 | sub InitRedirection { | |
352 | my ($self, $command) = @_; | |
353 | my @redir_cmd; | |
354 | ||
355 | for(my $i=0; $i<=$#$command; $i++) { | |
356 | if( $self->NoPipes and $command->[$i] =~ /^\|$/ ) { | |
357 | $self->PrintError("pipe redirection not supported in this commandterm :- (.\n"); | |
358 | return undef; | |
359 | } elsif( $command->[$i] =~ /^(\|)|(>>?)$/ ) { | |
360 | @redir_cmd = splice @$command, $i; | |
361 | last; | |
362 | } | |
363 | } | |
364 | ||
365 | if( @redir_cmd > 0 ) { | |
366 | if( @redir_cmd == 1 ) { | |
367 | $self->PrintError("syntax error: redirection to nowhere.\n"); | |
368 | return undef; | |
369 | } elsif( $redir_cmd[0] =~ /^>/ and @redir_cmd > 2 ) { | |
370 | $self->PrintError("syntax error: too many arguments after redirection .\ n"); | |
371 | return undef; | |
372 | } | |
373 | } elsif( grep(/1/, map($command->[0] =~ /^$_$/, @{ $self->PagerCommands })) ) { | |
374 | @redir_cmd = ('|', $self->DefaultPager) if $self->DefaultPager; | |
375 | } | |
376 | ||
377 | ||
378 | if( @redir_cmd ) { | |
379 | if( my $fh = FileHandle->new("@redir_cmd") ) { | |
380 | $self->ReDirFH($fh); | |
381 | $self->ReDirFH->autoflush(1); | |
382 | return 1; | |
383 | } else { | |
384 | $self->PrintError("Error opening '$redir_cmd[1]': $!\n"); | |
385 | return undef; | |
386 | } | |
387 | } else { | |
388 | return 1; | |
389 | } | |
390 | } | |
391 | ||
392 | sub CloseRedirection { | |
393 | my ($self) = @_; | |
394 | ||
395 | if( $self->ReDirFH ) { | |
396 | $self->ReDirFH->close; | |
397 | $self->ReDirFH(undef); | |
398 | } | |
399 | } | |
400 | ||
401 | sub SetDefaultPagerCommands { | |
402 | my ($self, @pager_commands) = @_; | |
403 | ||
404 | $self->{'PagerCommands'} = [ @pager_commands ]; | |
405 | ||
406 | my $default_pager = undef; | |
407 | ||
408 | $default_pager = $self->Which($ENV{'PAGER'}) if exists($ENV{'PAGER'}); | |
409 | $default_pager = $self->Which('less') unless $default_pager; | |
410 | $default_pager = $self->Which('more') unless $default_pager; | |
411 | ||
412 | unless( $default_pager ) { | |
413 | $self->PrintError("Cannot find a default pager.\n"); | |
414 | if( exists($ENV{'PAGER'}) ) { | |
415 | $self->PrintError("You have the \$PAGER environment variable set to '$ENV{'PAGER'}', ", | |
416 | "but it couldn't be found.\n"); | |
417 | } else { | |
418 | $self->PrintError("The \$PAGER environment variable isn't defined.\n"); | |
419 | } | |
420 | $self->PrintError("The programs 'less' and 'more' couldn't be found either.\n"); | |
421 | $self->PrintError("Use the '|' command to send command output to a pager.\n"); | |
422 | } | |
423 | ||
424 | $self->DefaultPager($default_pager); | |
425 | } | |
426 | ||
427 | sub Which { | |
428 | my ($self, $file) = @_; | |
429 | my @dirs; | |
430 | ||
431 | if( $file =~ m(^/) ) { | |
432 | if( -f $file and -x _ ) { | |
433 | return $file; | |
434 | } else { | |
435 | return undef; | |
436 | } | |
437 | } elsif( $file =~ m(/) ) { | |
438 | @dirs = (POSIX::getcwd); | |
439 | } else { | |
440 | @dirs = (split ':', $ENV{'PATH'}); | |
441 | } | |
442 | ||
443 | foreach my $dir (@dirs) { | |
444 | my $path = "$dir/$file"; | |
445 | return $path if( -f $path and -x _ ); | |
446 | } | |
447 | ||
448 | return undef; | |
449 | } | |
450 | ||
451 | sub GetPrompt { | |
452 | my ($self) = @_; | |
453 | ||
454 | return &{ $self->GetPromptCallback } . ($self->MLC ? '? ' : '> '); | |
455 | } | |
456 | ||
457 | sub DefaultGetPrompt { | |
458 | my ($self) = @_; | |
459 | ||
460 | return ($self->InputMode == $COMMAND_MODE ? 'command' : 'perl mode' ); | |
461 | } | |
462 | ||
463 | sub TogglePrompt { | |
464 | my ($self) = @_; | |
465 | ||
466 | &{ $self->TogglePromptCallback }; | |
467 | } | |
468 | ||
469 | sub DefaultTogglePrompt { | |
470 | my ($self) = @_; | |
471 | ||
472 | my $input_mode = $self->InputMode; | |
473 | ||
474 | if( $input_mode == $COMMAND_MODE ) { | |
475 | $input_mode = $PERL_MODE; | |
476 | } elsif( $input_mode == $PERL_MODE ) { | |
477 | $input_mode = $COMMAND_MODE; | |
478 | } else { | |
479 | $input_mode = $COMMAND_MODE; | |
480 | } | |
481 | ||
482 | $self->InputMode($input_mode); | |
483 | } | |
484 | ||
485 | sub ProcessLine { | |
486 | my ($self, $line) = @_; | |
487 | ||
488 | if( $line =~ /^\s*\\$/ ) { | |
489 | $self->MLC(1); | |
490 | $self->EMLC(1); | |
491 | } elsif( $self->EMLC and $line !~ /^\s*\.\s*$/ ) { | |
492 | $line =~ s/\s*\\$//; | |
493 | $self->{'EvalBuffer'} .= "$line "; | |
494 | } elsif( $line =~ s/\\$/ / ) { | |
495 | $self->{'EvalBuffer'} .= $line; | |
496 | $self->MLC(1); | |
497 | } else { | |
498 | $line =~ s/^\s*\.\s*$//; | |
499 | $line = $self->EvalBuffer . $line; | |
500 | $self->EvalBuffer(''); | |
501 | $self->EMLC(0); | |
502 | $self->MLC(0); | |
503 | $line = $self->DoHistory($line) unless $line =~ /^(quit|exit)\s?/; | |
504 | &{ $self->ExecCommandCallback }($line) if defined($line); | |
505 | } | |
506 | } | |
507 | ||
508 | sub DoHistory { | |
509 | my ($self, $line) = @_; | |
510 | ||
511 | my $ReadLine = $self->ReadLine; | |
512 | ||
513 | # The history_expand() function from Readline can return 4 values: | |
514 | # -1 - There was an error in expansion. Command not added to history. | |
515 | # This is the same behavior as tcsh. | |
516 | # 0 - No expansion possible. Just a normal command. Add command to history, | |
517 | # return and execute. | |
518 | # 1 - Expansion took place. Assign $command to expansion and proceed. | |
519 | # 2 - Expansion took place (eg. :p modifier was used). Display exspansion | |
520 | # but don't execute. Expanded command implicitly added to history by | |
521 | # history_expand(). | |
522 | my ($res, $str) = $ReadLine->history_expand($line); | |
523 | ||
524 | if( $res == -1 ) { | |
525 | $self->PrintError("$str\n"); | |
526 | $line = undef; | |
527 | } elsif( $res == 0 ) { | |
528 | if( $line !~ /^\s*$/ ) { | |
529 | $ReadLine->add_history($line); | |
530 | $ReadLine->append_history(1, $self->HistoryFile); | |
531 | } | |
532 | } elsif( $res == 1 ) { | |
533 | $line = $str; | |
534 | $ReadLine->add_history($line); | |
535 | $ReadLine->append_history(1, $self->HistoryFile); | |
536 | $self->PrintStatus("$line\n"); | |
537 | } elsif( $res == 2 ) { | |
538 | $self->PrintStatus("$str\n"); | |
539 | $ReadLine->append_history(1, $self->HistoryFile); | |
540 | $line = undef; | |
541 | } | |
542 | ||
543 | return $line; | |
544 | } | |
545 | ||
546 | sub InitReadLine { | |
547 | my ($self) = @_; | |
548 | ||
549 | my $ReadLine = new Term::ReadLine $self->Name; | |
550 | my $Attribs = $ReadLine->Attribs; | |
551 | ||
552 | $self->ReadLine($ReadLine); | |
553 | $self->Attribs($Attribs); | |
554 | ||
555 | # so perl variables can be <TAB> completed | |
556 | $Attribs->{'special_prefixes'} = '$@&%'; | |
557 | $Attribs->{'attempted_completion_function'} = sub { $self->DefaultCompleter(@_); }; | |
558 | $Attribs->{'completion_entry_function'} = sub {}; | |
559 | $Attribs->{'directory_completion_hook'} = sub { $self->ExpandDirectory(@_); }; | |
560 | $Attribs->{'completion_display_matches_hook'} = sub { $self->MungeCompletions(@_); }; | |
561 | ||
562 | # Control-T will toggle the prompt | |
563 | $ReadLine->add_defun('toggle-prompt', sub { $self->TogglePrompt; }, ord "\ct"); | |
564 | ||
565 | # inhibit the implicit call to add_history() since we do our own. | |
566 | $ReadLine->MinLine(0); | |
567 | ||
568 | # unlimited history kept | |
569 | $ReadLine->stifle_history(undef); | |
570 | my $history_file = $self->GlobExpand($self->HistoryFile); | |
571 | unless( $history_file ) { | |
572 | $history_file = '/dev/null'; | |
573 | $self->PrintError( "Bad history file: '", $self->HistoryFile, "'\n" ); | |
574 | } | |
575 | $history_file = getcwd . '/' . $history_file unless $history_file =~ /^\//; | |
576 | $self->HistoryFile($history_file); | |
577 | $ReadLine->ReadHistory($self->HistoryFile); | |
578 | $ReadLine->WriteHistory($self->HistoryFile); | |
579 | $ReadLine->history_truncate_file($self->HistoryFile, $self->HistorySaveLength) if | |
580 | $self->HistorySaveLength >= 0; | |
581 | $ReadLine->history_set_pos( scalar($ReadLine->GetHistory) ); | |
582 | ||
583 | $ReadLine->parse_and_bind('set visible-stats on'); | |
584 | ||
585 | # read the user's init file (~/.inputrc) to override default bindings | |
586 | $ReadLine->read_init_file; | |
587 | ||
588 | foreach my $env (keys %ENV) { | |
589 | my $value = $ENV{$env}; | |
590 | $value =~ s/\n/ /g; | |
591 | push @{ $self->{'EnvVars'} }, '$' . $env . (-d $value ? '/' : ' '); | |
592 | } | |
593 | } | |
594 | ||
595 | sub ExpandDirectory { | |
596 | if( $_[1] =~ /\$([^\$\/]+)/ ) { | |
597 | if( $ENV{$1} ) { | |
598 | $_[1] =~ s/\$([^\$\/]+)/$ENV{$1}/e; | |
599 | } | |
600 | } | |
601 | return 1; | |
602 | }; | |
603 | ||
604 | sub IgnoreSomeCompletions { | |
605 | my ($self, $text, $longest_match, @matchlist) = @_; | |
606 | ||
607 | # remove the dot files only when the user hasn't typed a dot. | |
608 | my $longest_matchlen = length($longest_match); | |
609 | my @matches = ($longest_match); | |
610 | foreach my $match (@matchlist) { | |
611 | if( substr($match, $longest_matchlen-1, 2) ne '/.' or $text =~ /\.[^\/]*$/ ) { | |
612 | push @matches, $match; | |
613 | } | |
614 | } | |
615 | return @matches; | |
616 | } | |
617 | ||
618 | sub MungeCompletions { | |
619 | my ($self, $matchlist_ref, $num_matches, $longest) = @_; | |
620 | ||
621 | # Strip leading tildes, dollar signs | |
622 | $longest = 0; | |
623 | my $match; | |
624 | for(my $i=1; $i<=$num_matches; $i++) { | |
625 | $match = $matchlist_ref->[$i]; | |
626 | $match =~ s/^[~\$\s]+//; | |
627 | $match =~ s/\s+$//; | |
628 | $longest = length($match) if length($match) > $longest; | |
629 | $matchlist_ref->[$i] = $match; | |
630 | } | |
631 | ||
632 | my $striplen = 0; | |
633 | if( $matchlist_ref->[0] =~ /^(.*\/)/ ) { | |
634 | $striplen = length($1); | |
635 | $longest -= $striplen; | |
636 | } | |
637 | ||
638 | $self->PrintCompletions($matchlist_ref, $num_matches, $longest, $striplen); | |
639 | } | |
640 | ||
641 | sub PrintCompletions { | |
642 | my($self, $matches, $num_matches, $longest, $striplen) = @_; | |
643 | my $show_matches = 1; | |
644 | ||
645 | if( $num_matches >= $self->Attribs->{'completion_query_items'} ) { | |
646 | $self->PrintStatus("\nDisplay all $num_matches possibilities? (y or n)"); | |
647 | for(;;) { | |
648 | my $char = chr($self->ReadLine->read_key); | |
649 | if( $char eq 'Y' or $char eq 'y' or $char eq ' ' ) { | |
650 | last; | |
651 | } elsif( $char eq 'N' or $char eq 'n' ) { | |
652 | $show_matches = 0; | |
653 | $self->PrintData("\n"); | |
654 | last; | |
655 | } | |
656 | } | |
657 | } | |
658 | ||
659 | if( $show_matches ) { | |
660 | $self->ReadLine->display_match_list($matches, $num_matches, $longest); | |
661 | } | |
662 | $self->ReadLine->forced_update_display; | |
663 | } | |
664 | ||
665 | sub CompleterCallback { | |
666 | my ($self, $func) = @_; | |
667 | my $Attribs = $self->Attribs; | |
668 | ||
669 | if( defined($func) and ref($func) eq 'CODE' ) { | |
670 | $Attribs->{'attempted_completion_function'} = sub { &{ $func }(@_); }; | |
671 | $Attribs->{'completion_entry_function'} = sub {}; | |
672 | } else { | |
673 | $Attribs->{'attempted_completion_function'} = undef; | |
674 | $Attribs->{'completion_entry_function'} = undef; | |
675 | } | |
676 | } | |
677 | ||
678 | sub ShellExec { | |
679 | my ($self, $cmd, @args) = @_; | |
680 | ||
681 | if( $cmd eq 'cd' ) { | |
682 | my ($dir) = @args; | |
683 | ||
684 | $dir = '' unless $dir; | |
685 | ||
686 | $dir = $self->GlobExpand($dir); | |
687 | ||
688 | return unless defined($dir); | |
689 | ||
690 | $dir =~ s/^"(.*)"$/$1/; | |
691 | $dir =~ s/^'(.*)'$/$1/; | |
692 | ||
693 | if( chdir $dir ) { | |
694 | $self->PrintData( getcwd . "\n" ); | |
695 | } else { | |
696 | $self->PrintError("Couldn't cd to '$dir': $!\n"); | |
697 | } | |
698 | } else { | |
699 | if( $self->Which($cmd) ) { | |
700 | system("$cmd @args"); | |
701 | } else { | |
702 | $self->PrintError("$cmd: Command not found.\n"); | |
703 | } | |
704 | } | |
705 | } | |
706 | ||
707 | sub GetPerlSubs { | |
708 | my ($self) = @_; | |
709 | my @retval = (); | |
710 | ||
711 | foreach my $sym (keys %sandbox::) { | |
712 | local *s = $sandbox::{$sym}; | |
713 | push @retval, "$sym" if defined &s; | |
714 | } | |
715 | ||
716 | return @retval; | |
717 | } | |
718 | ||
719 | sub RunPerlSub { | |
720 | my ($self, $cmd, @args) = @_; | |
721 | ||
722 | foreach my $arg (@args) { | |
723 | $arg =~ s/(.*)/'$1'/ if $arg =~ /^\w+$/; | |
724 | $arg =~ s/$/,/; | |
725 | } | |
726 | $self->EvalPerl("$cmd(@args);"); | |
727 | } | |
728 | ||
729 | sub EvalPerl { | |
730 | my ($self, $code, $verbose) = @_; | |
731 | ||
732 | $verbose = 1 unless defined($verbose); | |
733 | ||
734 | package sandbox; | |
735 | ||
736 | no strict; | |
737 | my $eval = eval $code; | |
738 | $self->PrintError( $@ ) if $@; | |
739 | use strict; | |
740 | ||
741 | $eval = 'undef' unless defined($eval); | |
742 | $eval = '(null)' if $eval eq ''; | |
743 | print "$eval\n" if $verbose; | |
744 | return $eval; | |
745 | } | |
746 | ||
747 | sub PerlCustomCompleter { | |
748 | my ($self, $text, $line, $start, $end) = @_; | |
749 | my $ReadLine = $self->ReadLine; | |
750 | my $Attribs = $self->Attribs; | |
751 | ||
752 | my $first = substr($line, 0, $start); | |
753 | ||
754 | # $foo{key, $foo->{key | |
755 | if( $first =~ /\$([\w:]+)\s*(->)?\s*{\s*['"]?$/ ) { | |
756 | $Attribs->{'completion_append_character'} = '}'; | |
757 | return $ReadLine->completion_matches($text, sub { $self->PerlHashCompletion(@_); }); | |
758 | ||
759 | # $foo[index $foo->[index | |
760 | } elsif( $first =~ /\$([\w:]+)\s*(->)?\s*\[\s*['"]?$/ ) { | |
761 | $Attribs->{'completion_append_character'} = ']'; | |
762 | return $ReadLine->completion_matches($text, sub { $self->PerlListCompletion(@_); }); | |
763 | ||
764 | # symbol completion | |
765 | } else { | |
766 | $Attribs->{'completion_append_character'} = ''; | |
767 | return $ReadLine->completion_matches($text, sub { $self->PerlSymbolCompletion(@_); }); | |
768 | } | |
769 | } | |
770 | ||
771 | sub PerlListCompletion { | |
772 | my($self, $text, $state) = @_; | |
773 | my $Attribs = $self->Attribs; | |
774 | my ($index, @matches); | |
775 | ||
776 | if( $state == 0 ) { | |
777 | $index = 0; | |
778 | my ($var,$arrow) = (substr($Attribs->{line_buffer}, | |
779 | 0, $Attribs->{point} - length($text)) | |
780 | =~ /\$([\w:]+)\s*(->)?\s*\[\s*['"]?$/); | |
781 | no strict 'refs'; | |
782 | $var = "sandbox::$var" unless ($var =~ /::/); | |
783 | if( $arrow ) { | |
784 | my $listref = eval "\$$var"; | |
785 | @matches = UNIVERSAL::isa($listref, 'ARRAY') ? (0 .. $#$listref) : (); | |
786 | } else { | |
787 | @matches = (0 .. $#$var); | |
788 | } | |
789 | use strict 'refs'; | |
790 | $self->PerlIndex($index); | |
791 | @{ $self->{'PerlMatches'} } = @matches; | |
792 | } else { | |
793 | $index = $self->PerlIndex + 1; | |
794 | @matches = @{ $self->PerlMatches }; | |
795 | $self->PerlIndex($index); | |
796 | } | |
797 | ||
798 | for (; $index <= $#matches; $index++) { | |
799 | $self->PerlIndex($index); | |
800 | return $matches[$index] if ($matches[$index] =~ /^\Q$text/); | |
801 | } | |
802 | return undef; | |
803 | } | |
804 | ||
805 | sub PerlHashCompletion { | |
806 | my ($self, $text, $state) = @_; | |
807 | my $Attribs = $self->Attribs; | |
808 | my ($index, @matches); | |
809 | ||
810 | if( $state == 0 ) { | |
811 | $index = 0; | |
812 | my ($var,$arrow) = (substr($Attribs->{'line_buffer'}, | |
813 | 0, $Attribs->{'point'} - length($text)) | |
814 | =~ /\$([\w:]+)\s*(->)?\s*{\s*['"]?$/); | |
815 | no strict 'refs'; | |
816 | $var = "sandbox::$var" unless ($var =~ /::/); | |
817 | if( $arrow ) { | |
818 | my $hashref = eval "\$$var"; | |
819 | @matches = UNIVERSAL::isa($hashref, 'HASH') ? keys %$hashref : (); | |
820 | } else { | |
821 | @matches = keys %$var; | |
822 | } | |
823 | use strict 'refs'; | |
824 | $self->PerlIndex($index); | |
825 | @{ $self->{'PerlMatches'} } = @matches; | |
826 | } else { | |
827 | $index = $self->PerlIndex + 1; | |
828 | @matches = @{ $self->PerlMatches }; | |
829 | $self->PerlIndex($index); | |
830 | } | |
831 | ||
832 | for (; $index <= $#matches; $index++) { | |
833 | $self->PerlIndex($index); | |
834 | return $matches[$index] if ($matches[$index] =~ /^\Q$text/); | |
835 | } | |
836 | return undef; | |
837 | } | |
838 | ||
839 | sub PerlSymbolCompletion { | |
840 | my ($self, $text, $state) = @_; | |
841 | my ($index, @matches); | |
842 | ||
843 | if( $state == 0 ) { | |
844 | @matches = (); | |
845 | $index = 0; | |
846 | my ($prefix) = ($text =~ /^(\$#|[\@\$%&])/); | |
847 | ||
848 | $prefix = '' unless defined $prefix; | |
849 | ||
850 | no strict; | |
851 | local *s; | |
852 | foreach my $var (keys %sandbox::) { | |
853 | *s = $sandbox::{$var}; | |
854 | if( defined(&s) ) { | |
855 | push @matches, ($prefix eq '&') ? "\&$var" : "$var"; | |
856 | } | |
857 | if( defined($s) ) { | |
858 | push @matches, UNIVERSAL::isa($s, 'HASH') ? "\$$var->\{" : | |
859 | UNIVERSAL::isa($s, 'ARRAY') ? "\$$var->\[" : "\$$var"; | |
860 | } | |
861 | if( defined(@s) ) { | |
862 | push @matches, ($prefix eq '$') ? "\$$var\[" : | |
863 | ($prefix eq '@') ? "\@$var" : | |
864 | ($prefix eq '$#') ? "\$#$var" : "\@$var"; | |
865 | } | |
866 | if( defined(%s) ) { | |
867 | push @matches, ($prefix eq '%' or $prefix eq '') ? "\%$var" : "\$$var\{"; | |
868 | } | |
869 | } | |
870 | use strict; | |
871 | $self->PerlIndex($index); | |
872 | @{ $self->{'PerlMatches'} } = @matches; | |
873 | } else { | |
874 | $index = $self->PerlIndex + 1; | |
875 | @matches = @{ $self->PerlMatches }; | |
876 | $self->PerlIndex($index); | |
877 | } | |
878 | ||
879 | for (; $index <= $#matches; $index++) { | |
880 | $self->PerlIndex($index); | |
881 | return $matches[$index] if ($matches[$index] =~ /^\Q$text/); | |
882 | } | |
883 | return undef; | |
884 | } | |
885 | ||
886 | sub get_options { | |
887 | my ($self, $argv_ref, $config_ref, @opts) = @_; | |
888 | ||
889 | local (@ARGV) = @$argv_ref; | |
890 | Getopt::Long::config(@$config_ref) if @$config_ref > 0; | |
891 | my $ret = GetOptions(@opts); | |
892 | Getopt::Long::config('default'); | |
893 | @$argv_ref = @ARGV; | |
894 | return $ret; | |
895 | } | |
896 | ||
897 | # Builtin Commands below here | |
898 | ||
899 | sub logfile { | |
900 | my ($self, $onoff, $logfile) = @_; | |
901 | ||
902 | if( not defined $onoff ) { | |
903 | if( defined $self->LogFH ) { | |
904 | $self->PrintStatus( "Currently logging output to '", $self->LogFileName, "'.\n" ); | |
905 | } else { | |
906 | $self->PrintStatus( "Logging output is off.\n" ); | |
907 | } | |
908 | } elsif( $onoff eq "off" ) { | |
909 | if( defined $self->LogFH ) { | |
910 | $self->PrintStatus( "Closing logfile '", $self->LogFileName, "'.\n" ); | |
911 | $self->LogFH->close; | |
912 | $self->LogFH(undef); | |
913 | $self->LogFileName(undef); | |
914 | } else { | |
915 | $self->PrintStatus( "Logging output is already off.\n" ); | |
916 | } | |
917 | } elsif( $onoff eq "on" and defined $logfile ) { | |
918 | if( defined $self->LogFH ) { | |
919 | $self->PrintStatus( "Closing logfile '", $self->LogFileName, "'.\n" ); | |
920 | $self->LogFH->close; | |
921 | $self->LogFH(undef); | |
922 | $self->LogFileName(undef); | |
923 | } | |
924 | $self->LogFH(new FileHandle "> $logfile"); | |
925 | if( not defined $self->LogFH ) { | |
926 | $self->PrintError( "Couldn't open '$logfile': $!\n" ); | |
927 | } else { | |
928 | $self->LogFileName($logfile); | |
929 | $self->LogFH->autoflush(1); | |
930 | $self->PrintStatus( "Logging output to '", $self->LogFileName, "'.\n" ); | |
931 | } | |
932 | } else { | |
933 | $self->PrintError( "Bad args to logfile '$onoff'.\n" ); | |
934 | $self->PrintStatus( $self->Help->logfile ); | |
935 | } | |
936 | return $self->LogFH; | |
937 | } | |
938 | ||
939 | sub history { | |
940 | my ($self, @args) = @_; | |
941 | my ($opt_h, $opt_r, $opt_n); | |
942 | ||
943 | $self->get_options(\@args, ['no_pass_through'], 'h' => \$opt_h, 'r' => \$opt_r) or return; | |
944 | ||
945 | $opt_n = shift @args; | |
946 | ||
947 | if( $opt_n and $opt_n !~ /^\d+$/ ) { | |
948 | $self->PrintError("Argument to history '$opt_n' isn't numeric.\n"); | |
949 | return; | |
950 | } | |
951 | ||
952 | my @history = $self->ReadLine->GetHistory; | |
953 | if( $opt_r ) { | |
954 | for(my $i=$#history; $i>=0; $i--) { | |
955 | $self->PrintData( $opt_h ? '' : "\t" . $i+1 . "\t", "$history[$i]\n" ); | |
956 | last if $opt_n and ($#history - $i + 1) >= $opt_n; | |
957 | } | |
958 | } else { | |
959 | $opt_n = $#history unless defined($opt_n); | |
960 | for(my $i=$#history-$opt_n; $i<=$#history; $i++) { | |
961 | $self->PrintData( $opt_h ? '' : "\t" . $i+1 . "\t", "$history[$i]\n" ); | |
962 | } | |
963 | } | |
964 | } | |
965 | ||
966 | sub help { | |
967 | my ($self, $command) = @_; | |
968 | ||
969 | if( $command ) { | |
970 | $self->PrintStatus( $self->Help->$command() ); | |
971 | } else { | |
972 | $self->PrintStatus( $self->Help->help ); | |
973 | } | |
974 | } | |
975 | ||
976 | sub exit { | |
977 | my ($self) = @_; | |
978 | ||
979 | $self->quit(@_); | |
980 | } | |
981 | ||
982 | sub quit { | |
983 | my ($self) = @_; | |
984 | ||
985 | if( defined($self->QuitCallback) ) { | |
986 | &{ $self->QuitCallback }; | |
987 | } else { | |
988 | $self->Shutdown; | |
989 | $self->Quit; | |
990 | } | |
991 | } | |
992 | ||
993 | sub Shutdown {} | |
994 | ||
995 | sub Quit { | |
996 | CORE::exit; | |
997 | } | |
998 | ||
999 | sub clear { | |
1000 | my ($self) = @_; | |
1001 | ||
1002 | $self->PrintError("Derived class '", ref($self), "' defined no 'clear' command.\n"); | |
1003 | } | |
1004 | ||
1005 | sub do { | |
1006 | my ($self, $file) = @_; | |
1007 | ||
1008 | unless( $file ) { | |
1009 | $self->PrintStatus( $self->Help->do ); | |
1010 | return; | |
1011 | } | |
1012 | ||
1013 | $file = $self->GlobExpand($file); | |
1014 | ||
1015 | return unless $file; | |
1016 | ||
1017 | $self->EvalPerl("do '$file';"); | |
1018 | } | |
1019 | ||
1020 | sub setenv { | |
1021 | my ($self, $env, $val) = @_; | |
1022 | ||
1023 | if( defined($env) and defined($val) ) { | |
1024 | $ENV{$env} = $val; | |
1025 | } elsif( defined($env) ) { | |
1026 | $ENV{$env} = ''; | |
1027 | } else { | |
1028 | foreach (keys %ENV) { | |
1029 | $self->PrintData("$_=$ENV{$_}\n"); | |
1030 | } | |
1031 | } | |
1032 | } | |
1033 | ||
1034 | package CommandTerm::Help; | |
1035 | ||
1036 | use strict; | |
1037 | use vars qw( $AUTOLOAD ); | |
1038 | ||
1039 | sub New { | |
1040 | my $class = shift(@_); | |
1041 | my $help = {}; | |
1042 | ||
1043 | bless $help, $class; | |
1044 | return $help; | |
1045 | } | |
1046 | ||
1047 | sub AUTOLOAD { | |
1048 | my $method = $AUTOLOAD; | |
1049 | ||
1050 | $method =~ s/.*://; | |
1051 | ||
1052 | return if $method eq 'DESTROY'; | |
1053 | ||
1054 | return "No help available for \'$method\'\n"; | |
1055 | } | |
1056 | ||
1057 | sub do { | |
1058 | return <<'EOF'; | |
1059 | do <file> | |
1060 | Read the <file> into the perl sandbox package. | |
1061 | EOF | |
1062 | } | |
1063 | ||
1064 | sub clear { | |
1065 | return <<'EOF'; | |
1066 | clear -- clear the screen | |
1067 | EOF | |
1068 | } | |
1069 | ||
1070 | sub logfile { | |
1071 | return <<'EOF'; | |
1072 | logfile [on|off [<logfile>]] | |
1073 | This command enables or disables logging of all output to <logfile>. | |
1074 | With no arguments, 'logfile' will report the current logging status. | |
1075 | With the argument 'off', the command will close the current <logfile>, | |
1076 | if one exists. With the 'on' argument, the <logfile> will be opened | |
1077 | to receive all text window output. The <logfile> will contain ALL | |
1078 | output. This includes user commands. | |
1079 | EOF | |
1080 | } | |
1081 | ||
1082 | sub history { | |
1083 | return <<'EOF'; | |
1084 | history [-h] [-r] [<num>] | |
1085 | Print out the history list. If -h is supplied, don't print out the | |
1086 | leading numbers. If -r is supplied print the history list in | |
1087 | reverse order. If a <num> is supplied, only output <num> commands | |
1088 | in the history list. | |
1089 | EOF | |
1090 | } | |
1091 | ||
1092 | sub setenv { | |
1093 | return <<'EOF'; | |
1094 | setenv [<env_var> [<value>]] | |
1095 | Set the environment variable <env_var> to <value>. If <value> is | |
1096 | not specified <env_var> is set to the empty string. If neither | |
1097 | <env_var> nor <value> is specified, the values of all environment | |
1098 | variables are printed, similar to the shell ``printenv'' command. | |
1099 | EOF | |
1100 | } | |
1101 | ||
1102 | sub help { | |
1103 | return <<'EOF'; | |
1104 | help command | |
1105 | Prints out the help message for a given command. | |
1106 | ||
1107 | Type <TAB><TAB> at a blank line for a list of avaiable commands. | |
1108 | ||
1109 | Up/Down arrow cycle through previous/next commands. | |
1110 | ||
1111 | Username and environment variable expansion is supported. | |
1112 | EOF | |
1113 | } | |
1114 | ||
1115 | sub exit { | |
1116 | return <<'EOF'; | |
1117 | exit | |
1118 | Exit the application | |
1119 | EOF | |
1120 | } | |
1121 | ||
1122 | sub quit { | |
1123 | return <<'EOF'; | |
1124 | quit | |
1125 | Quit the application | |
1126 | EOF | |
1127 | } | |
1128 | ||
1129 | 1; |