3 =head1 NAME $RCSfile: CmdLine.pm,v $
5 Library to implement generic command line interface
13 Andrew DeFaria <Andrew@ClearSCM.com>
21 Fri May 13 15:23:37 PDT 2011
25 $Date: 2011/12/23 01:02:49 $
31 Provides an interface to a command line utilizing Term::ReadLine and
32 Term::ReadLine::Gnu. Note, the latter is not part of Perl core and
33 must be downloaded from CPAN. Without Term::ReadLine::Gnu a lot of
34 functionality doesn't work.
36 CmdLine uses a hash to describe what your valid commands are along
37 with help and longer help, i.e. description strings. If you do not
38 define your commands then no command name completion nor help will be
46 help => 'help [<cmd>]'
47 description => 'This is a longer description
51 help => 'execute <cmd>',
52 description => 'Longer description of the execute command',
56 # Create a new cmdline:
57 my $cmdline = CmdLine->new ($FindBin::Script, %cmds);
59 while (my $cmd = $cmdline->get) {
65 This module implements a command line stack using Term::ReadLine and
66 Term::ReadLine::Gnu. If Term::ReadLine::Gnu is not installed then many
67 of the functions do not work. Command completion if commands are
68 defined with a hash as shown above.
70 =head1 DEFAULT COMMANDS
72 The for a list of the builtin commands see %builtin_cmds below
74 Additionally !<n> will re-exeucte a comand from history and !<cmd>
75 will execute <cmd as a shell command.
79 The following routines are exported:
96 use Term::ANSIColor qw(color);
102 my $promptColor = color('bold yellow');
103 my $inputColor = color('underline');
104 my $resetColor = color('reset');
106 my (%_cmds, $_attribs);
111 # See if we can load Term::ReadLine::Gnu
112 eval { require Term::ReadLine::Gnu };
115 warning "Unable to load Term::ReadLine::Gnu\nCmdLine functionality will be limited!";
129 help => 'history [<start> <end>]',
130 description => 'Displays cmd history. You can specify where to <start> and where to <end>.
131 Default is to list only the last screen full lines of history
132 (as denoted by $LINES).'
136 help => 'help [<cmd>]',
137 description => 'Displays help.',
141 help => 'savehist <file> [<start> <end>]',
142 description => 'Saves a section of the history to a file. You can specify where to <start>
143 and where to <end>. Default is to save all of the history to
144 the specified file.',
149 description => 'Gets a variable.',
153 help => 'set <var>=<expression>',
154 description => 'Sets a variable. Note that expression can be any valid expression.',
159 description => 'Displays all known variables.',
163 help => 'source <file>',
164 description => 'Run commands from a file.',
168 help => 'color [<on|off>]',
169 description => 'Turn on|off color. With no options displays status of color.',
173 help => 'trace [<on|off>]',
174 description => 'Turn on|off tracing. With no options displays status of trace.',
178 sub _cmdCompletion($$) {
179 my ($text, $state) = @_;
181 return unless %_cmds;
183 $_pos = 0 unless $state;
185 my @cmds = keys %_cmds;
187 for (; $_pos < @cmds;) {
188 return $cmds[$_pos - 1]
189 if $cmds[$_pos++] =~ /^$text/i;
195 sub _complete($$$$) {
196 my ($text, $line, $start, $end) = @_;
198 return $_cmdline->completion_matches ($text, \&CmdLine::_cmdCompletion);
204 return unless %_cmds;
206 my $line = $_cmdline->{line_buffer};
214 # Sometimes we are called by ReadLine's callback and can't pass $self
215 if (ref $self eq 'CmdLine') {
218 $CmdLine::cmdline->help($line);
221 $_cmdline->on_new_line;
224 sub _interpolate ($) {
225 my ($self, $str) = @_;
227 # Skip interpolation for the perl command (Note this is raid specific)
228 return $str if $str =~ /^\s*perl\s*/i;
230 while ($str =~ /\$/) {
231 if ($str =~ /\$(\w+)/) {
234 if ($self->{vars}{$varname}) {
235 if ($self->{vars}{$varname} =~ / /) {
236 $str =~ s/\$$varname/\'$self->{vars}{$varname}\'/;
238 $str =~ s/\$$varname/$self->{vars}{$varname}/;
241 $str =~ s/\$$varname//;
249 sub _builtinCmds($) {
250 my ($self, $line) = @_;
252 unless (defined $line) {
259 # Short circut "psuedo" commands of !<n> and !<shellcmd>
260 if ($line =~ /^\s*!\s*(\d+)/) {
261 $line = $self->history ('redo', $1);
262 } elsif ($line =~ /^\s*!\s*(\S+)\s*(.*)/) {
269 #$_cmdline->remove_history($_cmdline->where_history);
274 if ($line =~ /^\s*(\S+)/) {
282 # Search for matches of partial commands
285 for (keys %builtin_cmds) {
287 # Exact match - honor it
291 # Command matched partially
293 # Found first instance of a match
296 # Found second instance of a match - $cmd is not unique
303 # If we found a command, substitute it into line
305 $line =~ s/^\s*$cmd\s*/$foundCmd /;
309 if ($builtin_cmds{$cmd}) {
310 if ($line =~ /^\s*help\s*(.*)/i) {
316 } elsif ($line =~ /^\s*history\s*(.*)/i) {
317 if ($1 =~ /(\d+)\s+(\d+)\s*$/) {
318 $self->history ('list', $1, $2);
319 } elsif ($1 =~ /^\s*$/) {
320 $self->history('list');
322 error "Invalid usage";
323 $self->help('history');
325 } elsif ($line =~ /^\s*savehist\s*(.*)/i) {
326 if ($1 =~ /(\S+)\s+(\d+)\s+(\d+)\s*$/) {
327 $self->history('save', $1, $2, $3);
329 error 'Invalid usage';
330 $self->help('savehist');
332 } elsif ($line =~ /^\s*get\s*(.*)/i) {
333 if ($1 =~ (/^\$*(\S+)\s*$/)) {
334 my $value = $self->_get($1);
337 display "$1 = $value";
339 error "$1 is not set";
342 error 'Invalid usage';
345 } elsif ($line =~ /^\s*set\s*(.*)/i) {
346 if ($1 =~ /^\$*(\S+)\s*=\s*(.*)/) {
349 error 'Invalid usage';
352 } elsif ($line =~ /^\s*source\s+(\S+)/i) {
353 $result = $self->source ($1);
354 } elsif ($line =~ /^\s*vars\s*/) {
356 } elsif ($line =~ /^\s*color\s*(.*)/i) {
357 if ($1 =~ /(1|on)/i) {
359 delete $ENV{ANSI_COLORS_DISABLED} if $ENV{ANSI_COLORS_DISABLED};
361 } elsif ($1 =~ /(0|off)/i) {
363 $ENV{ANSI_COLORS_DISABLED} = 1;
365 } elsif ($1 =~ /\s*$/) {
366 if ($ENV{ANSI_COLORS_DISABLED}) {
367 display 'Color is currently off';
369 display 'Color is currently on';
372 error 'Invalid usage';
373 $self->help('color');
375 } elsif ($line =~ /^\s*trace\s*(.*)/i) {
376 if ($1 =~ /(1|on)/i) {
378 } elsif ($1 =~ /(0|off)/i) {
380 } elsif ($1 =~ /\s*$/) {
382 display 'Trace is currently on';
384 display 'Trace is currently off';
387 error 'Invalid usage';
388 $self->help('trace');
393 return ($cmd, $line, $result);
397 # Announce that we have hit an interrupt
398 print color('yellow') . "<Control-C>\n" . color('reset');
400 # Free up all of the line state info
401 $_cmdline->free_line_state;
403 # Allow readline to clean up
404 $_cmdline->cleanup_after_signal;
406 # Redisplay prompt on a new line
407 $_cmdline->on_new_line;
408 $_cmdline->{line_buffer} = '';
409 $_cmdline->redisplay;
414 sub _displayMatches($$$) {
415 my ($matches, $numMatches, $maxLength) = @_;
417 # Work on a copy... (Otherwise we were getting "Attempt to free unreferenced
418 # scalar" internal errors from perl)
421 push @Matches, $_ for (@$matches);
423 my $match = shift @Matches;
425 if ($match =~/^\s*(.*) /) {
427 } elsif ($match =~ /^\s*(\S+)$/) {
438 $newMatches{$1} = $1;
442 my @newMatches = sort keys %newMatches;
444 unshift @newMatches, $match;
446 $_cmdline->display_match_list(\@newMatches);
447 $_cmdline->on_new_line;
448 $_cmdline->redisplay;
454 my ($class, $histfile, $eval, %cmds) = @_;
460 Construct a new CmdLine object. Note there is already a default
461 CmdLine object created named $cmdline. You should use that unless you
462 have good reason to instantiate another CmdLine object.
466 =for html <blockquote>
472 Set to a file name where to write the history file. If not defined no
477 A hash describing the valid commands and their help/description
482 help => 'List all known commands',
483 description => 'This is a longer description
484 of the list command',
487 help => 'This is a help command',
488 description => 'help <cmd>
489 Longer description of help',
495 =for html </blockquote>
499 =for html <blockquote>
507 =for html </blockquote>
512 histfile => $histfile,
517 $histfile ||= "$ENV{HOME}/.${me}_hist";
519 error "Creating bogus .${me}_hist file!"
520 if $me eq '-' or $me eq '';
522 unless (-f $histfile) {
523 open my $hist, '>', $histfile
524 or error "Unable to open $histfile for writing - $!", 1;
529 # Instantiate a commandline
530 $_cmdline = Term::ReadLine->new($me);
532 # Store the function pointer of what to call when sourcing a file or
533 # evaluating an expression.
535 if (ref $eval eq 'CODE') {
536 $self->{eval} = $eval;
538 error "Invalid function pointer\nUsage: CmdLine->new ($histfile, $eval, %cmds)", 1;
542 $self->{promptColor} = $promptColor;
543 $self->{inputColor} = $inputColor;
544 $self->{resetColor} = $resetColor;
546 # Default prompt is "$me:"
547 $self->set_prompt("$me:");
550 $self->set_cmds(%cmds);
552 # Set some ornamentation
553 $_cmdline->ornaments('e,,u') unless $Config{cppflags} =~ /win32/i;
556 $self->set_histfile($histfile);
558 # Generator function for completion matches
559 $_attribs = $_cmdline->Attribs;
561 $_attribs->{attempted_completion_function} = \&CmdLine::_complete;
562 $_attribs->{completion_display_matches_hook} = \&CmdLine::_displayMatches;
563 $_attribs->{completer_word_break_characters} =~ s/ //
564 if $_attribs->{completer_word_break_characters};
566 # The following functionality requires Term::ReadLine::Gnu
568 # Bind a key to display completion
569 $_cmdline->add_defun('help-on-command', \&CmdLine::_gethelp, ord ("\cl"));
571 # Save a handy copy of RL_PROMPT_[START|END]_IGNORE
572 $self->{ignstart} = $_cmdline->RL_PROMPT_START_IGNORE;
573 $self->{ignstop} = $_cmdline->RL_PROMPT_END_IGNORE;
576 if ($Config{cppflags} =~ /win32/i) {
578 $ENV{ANSI_COLORS_DISABLED} = 1;
591 Retrieves a command line
595 =for html <blockquote>
603 =for html </blockquote>
607 =for html <blockquote>
615 =for html </blockquote>
619 my ($cmd, $line, $result);
622 # Substitute cmdnbr into prompt if we find a '\#'
623 my $prompt = $self->{prompt};
625 $prompt =~ s/\\\#/$self->{cmdnbr}/g;
627 # Now color it if color is on
628 $prompt = "$self->{resetColor}$self->{promptColor}$prompt$self->{resetColor}$self->{inputColor}" if $self->{promptColor};
632 # Term::ReadLine::Gnu restarts whatever system call it is using, such that
633 # once we ctrl C, we don't get back to Perl until the user presses enter,
634 # finally whereupon we get our signal handler called. We use sigaction
635 # instead to use the old perl unsafe signal handling, but only in this read
636 # routine. Sure, sigaction poses race conditions, but you'd either be at a
637 # prompt or executing whatever command your prompt prompted for. The user
638 # has said "Abort that!" with his ctrl-C and we're attempting to honor that.
640 # Damn Windows can't do any of this
643 if ($Config{cppflags} !~ /win32/i) {
644 my $sigset = POSIX::SigSet->new;
645 my $sigaction = POSIX::SigAction->new (\&_interrupt, $sigset, 0);
647 $oldaction = POSIX::SigAction->new;
649 # Set up our unsafe signal handler
650 POSIX::sigaction(&POSIX::SIGINT, $sigaction, $oldaction);
653 $line = $_cmdline->readline($prompt);
655 display_nolf $resetColor;
657 # Restore the old signal handler
658 if ($Config{cppflags} !~ /win32/i) {
659 POSIX::sigaction(&POSIX::SIGINT, $oldaction);
662 $line = $self->_interpolate($line) if $line;
664 $self->{cmdnbr}++ unless $self->{sourcing};
666 ($cmd, $line, $result) = $self->_builtinCmds($line);
668 $line = '' unless $cmd;
669 } while ($cmd and $builtin_cmds{$cmd});
672 return ($line, $result);
674 return $result || $line;
679 my ($self, %cmds) = @_;
689 =for html <blockquote>
699 =for html </blockquote>
703 =for html <blockquote>
711 =for html </blockquote>
718 for (keys %builtin_cmds) {
719 $_cmds{$_}{help} = $builtin_cmds{$_}{help};
720 $_cmds{$_}{description} = $builtin_cmds{$_}{description};
727 my ($self, $prompt) = @_;
737 =for html <blockquote>
747 =for html </blockquote>
751 =for html <blockquote>
759 =for html </blockquote>
763 my $oldPrompt = $self->{prompt};
765 $self->{prompt} = $prompt if $prompt;
768 $self->{promptColor} = $promptColor;
769 $self->{resetColor} = $resetColor;
771 undef $self->{promptColor};
772 undef $self->{resetColor};
778 sub set_histfile($) {
779 my ($self, $histfile) = @_;
789 =for html <blockquote>
799 =for html </blockquote>
803 =for html <blockquote>
811 =for html </blockquote>
815 if ($histfile and -f $histfile) {
816 $self->{histfile} = $histfile;
819 # Clear old history (if any);
820 $_cmdline->clear_history;
823 $_cmdline->ReadHistory($histfile);
826 # Determine the number of lines in the history file
827 open my $hist, '<', $histfile;
831 $self->{cmdnbr} = $. + 1;
840 my ($self, $eval) = @_;
846 Sets the eval function pointer
850 =for html <blockquote>
856 Function to set eval to. This function will be called with the command
857 line as the only paramter and it should return a result.
861 =for html </blockquote>
865 =for html <blockquote>
873 =for html </blockquote>
877 my $returnEval = $self->{eval};
879 $self->{eval} = $eval;
885 my ($self, $cmd) = @_;
893 Note that the user does not need to explicitly call help - CmdLine's
894 get method will already sense that the builtin help command was
895 invoked and handle it. This method is provided if the caller wishes to
896 call this internally for some reason.
900 =for html <blockquote>
906 Optional command help
910 =for html </blockquote>
914 =for html <blockquote>
922 =for html </blockquote>
932 if ($cmd =~ /^\s*(.+)/) {
933 my ($searchStr, $helpFound);
937 for (sort keys %_cmds) {
941 my $cmdcolor = $builtin_cmds{$_} ? color('cyan') : color ('magenta');
942 my $boldOn = $builtin_cmds{$_} ? color('white on_cyan') : color ('white on_magenta');
943 my $boldOff = color('reset') . $cmdcolor;
945 $cmd = "$cmdcolor$_";
946 $cmd =~ s/($searchStr)/$boldOn$1$boldOff/g;
947 $cmd .= " $_cmds{$_}{parms}" if $_cmds{$_}{parms};
948 $cmd .= color ('reset');
949 $cmd .= " - $_cmds{$_}{help}" if $_cmds{$_}{help};
953 if ($_cmds{$_}{description}) {
955 for (split /\n/, $_cmds{$_}{description});
960 unless ($helpFound) {
961 display "I don't know about $cmd";
966 for (sort keys %_cmds) {
967 my $cmdcolor = $builtin_cmds{$_} ? color ('cyan') : color ('magenta');
969 my $cmd = "$cmdcolor$_";
970 $cmd .= " $_cmds{$_}{parms}" if $_cmds{$_}{parms};
971 $cmd .= color ('reset');
972 $cmd .= " - $_cmds{$_}{help}" if $_cmds{$_}{help};
976 if ($_cmds{$_}{description}) {
978 for (split /\n/, $_cmds{$_}{description});
983 $self->handleOutput($cmd, @help);
989 my ($self, $action) = @_;
993 =head2 history <action> [<file>] [<start> <end>]
995 This method lists, saves or executes (redo) a command from the history
996 stack. <action> can be one of 'list', 'save' or 'redo'. If listing
997 history one can specify the optional <start> and <end> parameters. If
998 saving then <file> must be specified and optionally <start> and
999 <end>. If redoing a command then only <start> or the command number
1000 should be specified.
1002 Note that the user does not need to explicitly call history -
1003 CmdLine's get method will already sense that the builtin history
1004 command was invoked and handle it. This method is provided if the
1005 caller wishes to call this internally for some reason.
1009 =for html <blockquote>
1015 One of 'list', 'save' or 'redo'
1019 =for html </blockquote>
1023 =for html <blockquote>
1031 =for html </blockquote>
1035 if ($Config{cppflags} =~ /win32/i) {
1036 warning 'The history command does not work on Windows (sorry)';
1041 my ($file, $start, $end);
1043 if ($action eq 'list') {
1046 } elsif ($action eq 'save') {
1050 } elsif ($action eq 'redo') {
1051 $_cmdline->remove_history($_cmdline->where_history);
1054 my $line = $_cmdline->history_get($nbr);
1056 $_cmdline->add_history($line);
1059 my ($cmd, $result) = $self->_builtinCmds($line);
1061 if ($builtin_cmds{$cmd}) {
1067 error "Unknown action $action in history";
1071 my $current = $_cmdline->where_history;
1073 my $lines = ($ENV{LINES} ? $ENV{LINES} : 24) - 2;
1075 $start = $current - $lines
1076 unless defined $start;
1080 unless defined $end;
1084 if ($start > $end) {
1085 error "Start ($start) is > end ($end)";
1090 if ($action eq 'save') {
1092 error "Usage: savehist <file> [<start> <end>]";
1097 display_nolf "Overwrite $file (yN)? ";
1099 my $response = <STDIN>;
1101 unless ($response =~ /(y|yes)/i) {
1102 display "Not overwritten";
1107 my $success = open $savefile, '>', $file;
1110 error "Unable to open history file $file - $!";
1115 for (my $pos = $start; $pos <= $end; $pos++) {
1116 my $histline = $_cmdline->history_get ($pos);
1118 last unless $histline;
1120 if ($action eq 'list') {
1121 display "$pos) $histline";
1123 print $savefile "$histline\n";
1128 if $action eq 'save';
1135 my ($self, $name) = @_;
1141 This method gets a variable to a value stored in the CmdLine
1146 =for html <blockquote>
1152 Name of the variable
1156 =for html </blockquote>
1160 =for html <blockquote>
1168 =for html </blockquote>
1172 return $self->{vars}{$name}
1176 my ($self, $name, $value) = @_;
1180 =head2 _set ($name, $value)
1182 This method sets a variable to a value stored in the CmdLine
1183 object. Note $value will be evaluated if eval is set.
1187 =for html <blockquote>
1193 Name of the variable
1197 Value of the variable
1201 =for html </blockquote>
1205 =for html <blockquote>
1213 =for html </blockquote>
1217 my $returnValue = $self->{vars}{$name};
1220 $value = $self->_interpolate($value);
1222 # Do not call eval if we are setting result - otherwise we recurse
1224 unless ($name eq 'result') {
1226 $value = $self->{eval}($value)
1231 $self->{vars}{$name} = $value;
1233 delete $self->{vars}{$name};
1236 return $returnValue;
1240 my ($self, $cmd) = @_;
1246 This method will print out all known variables
1250 =for html <blockquote>
1258 =for html </blockquote>
1262 =for html <blockquote>
1270 =for html </blockquote>
1276 push @output, "$_ = $self->{vars}{$_}"
1277 for (keys %{$self->{vars}});
1279 $self->handleOutput($cmd, @output);
1282 sub handleOutput($@) {
1283 my ($self, $line, @output) = @_;
1287 =head2 handleOutput ($line, @output)
1289 This method will handle outputing the array @output. It also handles redirection
1290 (currently only output redirection) and piping
1294 =for html <blockquote>
1300 The command line used to produce @output. This method parses out redirection
1301 (i.e. > and >>) and piping (|) from $cmd
1305 The output produced by the command to redirect or pipe. (Note this isn't true
1306 piping in that command must run first and produce all of @output before we are
1307 called. Need to look into how to use Perl's pipe command here).
1311 =for html </blockquote>
1315 =for html <blockquote>
1323 =for html </blockquote>
1327 my ($outToFile, $pipeToCmd);
1329 # Handle piping and redirection
1330 if ($line =~ /(.*)\>{2}\s*(.*)/) {
1333 } elsif ($line =~ /(.*)\>{1}\s*(.*)/) {
1336 } elsif ($line =~ /(.*?)\|\s*(.*)/) {
1342 $self->{output} = \@output;
1347 local $SIG{PIPE} = 'IGNORE';
1349 open $pipe, '|', $pipeToCmd or undef $pipe;
1351 # TODO: Not handling the output here. Need open2 and then recursively call
1354 print $pipe "$_\n" for (@output);
1356 close $pipe or error "Unable to close pipe for $pipeToCmd - $!";
1358 error "Unable to open pipe for $pipeToCmd - $!";
1361 unless ($outToFile) {
1364 open my $output, '>', $outToFile;
1367 print $output "$_\n" for (@output);
1373 error "Unable to open $outToFile for writing - $!"
1382 my ($self, $file) = @_;
1386 =head2 source <file>
1388 This method opens a file and sources it's content by executing each
1389 line. Note that the user must have set $self->{eval} to a function
1390 pointer. The function will be called with one parameter - the command
1391 line to execute. The function will return the result from the
1392 execution of the final command.
1394 Note that the user does not need to explicitly call source -
1395 CmdLine's get method will already sense that the builtin source
1396 command was invoked and handle it. This method is provided if the
1397 caller wishes to call this internally for some reason.
1401 =for html <blockquote>
1411 =for html </blockquote>
1415 =for html <blockquote>
1419 =item Returns the result of the last command executed
1423 =for html </blockquote>
1428 error "Unable to open file $file - $!";
1432 open my $source, '<', $file;
1436 $self->{sourcing} = 1;
1445 my $prompt = $self->{prompt};
1447 $prompt =~ s/\\\#/$file:$i/;
1449 display "$prompt$_" if $CmdLine::opts{trace};
1451 next if /^\s*($|\#)/;
1453 $_ = $self->_interpolate ($_);
1455 # Check to see if it's a builtin
1456 my ($cmd, $line, $result) = $self->_builtinCmds($_);
1458 next if $builtin_cmds{$cmd};
1461 $result = $self->{eval}($line);
1464 if (defined $result) {
1465 if (ref \$result eq 'SCALAR') {
1466 PageOutput (split /\n/, $result);
1468 display "Sorry but I cannot display structured results";
1473 $self->{sourcing} = 0;
1483 $_cmdline->WriteHistory($self->{histfile})
1484 if $_cmdline and $_haveGnu;
1489 our $cmdline = CmdLine->new;
1499 =head2 ClearSCM Perl Modules
1501 =for html <p><a href="/php/scm_man.php?file=lib/Display.pm">Display</a></p>
1503 =head1 BUGS AND LIMITATIONS
1505 There are no known bugs in this module
1507 Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
1509 =head1 LICENSE AND COPYRIGHT
1511 Copyright (c) 2007, ClearSCM, Inc. All rights reserved.