lib/CmdLine.pm

   1 =pod
   2
   3 =head1 NAME $RCSfile: CmdLine.pm,v $
   4
   5 Library to implement generic command line interface
   6
   7 =head1 VERSION
   8
   9 =over
  10
  11 =item Author
  12
  13 Andrew DeFaria <Andrew@ClearSCM.com>
  14
  15 =item Revision
  16
  17 $Revision: 1.13 $
  18
  19 =item Created
  20
  21 Fri May 13 15:23:37 PDT 2011
  22
  23 =item Modified
  24
  25 $Date: 2011/12/23 01:02:49 $
  26
  27 =back
  28
  29 =head1 SYNOPSIS
  30
  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.
  35
  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
  39 available.
  40
  41  use FindBin;
  42  use CmdLine;
  43
  44  my %cmds = (
  45   list => (
  46      help        => 'help [<cmd>]'
  47      description => 'This is a longer description
  48 of the list command',
  49   ),
  50   execute => (
  51      help        => 'execute <cmd>',
  52      description => 'Longer description of the execute command',
  53   ),
  54  );
  55
  56  # Create a new cmdline:
  57  my $cmdline = CmdLine->new ($FindBin::Script, %cmds);
  58
  59  while (my $cmd = $cmdline->get) {
  60    ...
  61  } # while
  62
  63 =head1 DESCRIPTION
  64
  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.
  69
  70 =head1 DEFAULT COMMANDS
  71
  72 The for a list of the builtin commands see %builtin_cmds below
  73
  74 Additionally !<n> will re-exeucte a comand from history and !<cmd>
  75 will execute <cmd as a shell command.
  76
  77 =head1 ROUTINES
  78
  79 The following routines are exported:
  80
  81 =cut
  82
  83 package CmdLine;
  84
  85 use strict;
  86 use warnings;
  87
  88 use base 'Exporter';
  89
  90 use Carp;
  91 use Config;
  92 use Display;
  93 use Utils;
  94
  95 use Term::ReadLine;
  96 use Term::ANSIColor qw (color);
  97
  98 # Package globals
  99 my $_pos = 0;
 100 my $_haveGnu;
 101
 102 my (%_cmds, $_cmdline, $_attribs);
 103
 104 BEGIN {
 105   # See if we can load Term::ReadLine::Gnu
 106   eval { require Term::ReadLine::Gnu };
 107
 108   if ($@) {
 109     warning "Unable to load Term::ReadLine::Gnu\nCmdLine functionality will be limited!";
 110     $_haveGnu = 0;
 111   } else {
 112     $_haveGnu = 1;
 113   } # if
 114 } # BEGIN
 115
 116 # Share %opts
 117 our %opts;
 118
 119 my %builtin_cmds = (
 120   history       => {
 121     help        => 'history [[start] [end]]',
 122     description =>
 123       "Displays cmd history. You can specify where to <start> and where to <end>\n"
 124     . "Default is to list only the last screen full lines of history (as denoted\n"
 125     . "by \$LINES).",
 126   },
 127
 128   help          => {
 129     help        => 'help [<cmd>]',
 130     description => 'Displays help.',
 131   },
 132
 133   helpall       => {
 134     help        => 'helpall',
 135     description => 'Display all help, including builtin commands',
 136   },
 137
 138   savehist      => {
 139     help        => 'savehist [file] [[start] [end]]',
 140     description =>
 141       "Saves a section of the history to a file. You can specify where to <start>\n"
 142     . "and where to <end>. Default is to save all of the history to the specified\n"
 143     . "file.",
 144   },
 145
 146   get           => {
 147     help        => 'get [var]',
 148     description => 'Gets a variable.',
 149   },
 150
 151   set           => {
 152     help        => 'set [var]=[expression]',
 153     description =>
 154       'Sets a variable. Note that expression can be any valid expression.',
 155   },
 156
 157   vars          => {
 158     help        => 'vars',
 159     description =>
 160       'Displays all known variables.',
 161   },
 162
 163   source        => {
 164     help        => 'source [file]',
 165     description =>
 166       'Run commands from a file.',
 167   },
 168
 169   color         => {
 170     help        => 'color [(on|off)]',
 171     description =>
 172       'Turn on|off color. With no options displays status of color.',
 173   },
 174
 175   trace         => {
 176     help        => 'trace [(on|off)]',
 177     description =>
 178       'Turn on|off tracing. With no options displays status of trace.',
 179   },
 180 );
 181
 182 sub _cmdCompletion($$) {
 183   my ($text, $state) = @_;
 184
 185   return unless %_cmds;
 186
 187   $_pos = 0 unless $state;
 188
 189   my @cmds = keys %_cmds;
 190
 191   for (; $_pos < @cmds;) {
 192     return $cmds[$_pos - 1]
 193       if $cmds[$_pos++] =~ /^$text/i;
 194   } # for
 195
 196   return;
 197 } # _cmdCompletion
 198
 199 sub _complete($$$$) {
 200   my ($text, $line, $start, $end) = @_;
 201
 202   return $_cmdline->completion_matches($text, \&CmdLine::_cmdCompletion);
 203 } # _complete
 204
 205 sub _gethelp() {
 206   my ($self) = @_;
 207
 208   return unless %_cmds;
 209
 210   my $line = $_cmdline->{line_buffer};
 211
 212   # Trim
 213   $line =~ s/^\s+//;
 214   $line =~ s/\s+$//;
 215
 216   display '';
 217
 218   # Sometimes we are called by ReadLine's callback and can't pass $self
 219   if (ref $self eq 'CmdLine') {
 220     $self->help($line);
 221   } else {
 222     $CmdLine::cmdline->help($line);
 223   } # if
 224
 225   $_cmdline->on_new_line;
 226
 227   return;
 228 } # _gethelp
 229
 230 sub _interpolate($) {
 231   my ($self, $str) = @_;
 232
 233   # Skip interpolation for the perl command (Note this is raid specific)
 234   return $str
 235     if $str =~ /^\s*perl\s*/i;
 236
 237   while ($str =~ /\$/) {
 238     if ($str =~ /\$(\w+)/) {
 239       my $varname = $1;
 240
 241       if (defined $self->{vars}{$varname}) {
 242         if ($self->{vars}{$varname} =~ / /) {
 243           $str =~ s/\$$varname/\'$self->{vars}{$varname}\'/;
 244         } else {
 245           $str =~ s/\$$varname/$self->{vars}{$varname}/;
 246         } # if
 247       } else {
 248        $str =~ s/\$$varname//;
 249       } # if
 250     } # if
 251   } # while
 252
 253   return $str;
 254 } # _interpolate
 255
 256 sub _builtinCmds($) {
 257   my ($self, $line) = @_;
 258
 259   unless ($line) {
 260     display '';
 261     return 'exit';
 262   } # unless
 263
 264   my ($cmd, $result);
 265
 266   # Short circut "psuedo" commands of !<n> and !<shellcmd>
 267   if ($line =~ /^\s*!\s*(\d+)/) {
 268     $line = $self->history ('redo', $1);
 269   } elsif ($line =~ /^\s*!\s*(\S+)\s*(.*)/) {
 270     if ($2) {
 271       system "$1 $2";
 272     } else {
 273       system $1;
 274     } # if
 275
 276     #$_cmdline->remove_history ($_cmdline->where_history);
 277
 278     return;
 279   } # if
 280
 281   if ($line =~ /^\s*(\S+)/) {
 282     $cmd = $1;
 283   } # if
 284
 285   return
 286     unless $cmd;
 287
 288   # Search for matches of partial commands
 289   my $foundCmd;
 290
 291   for (keys %builtin_cmds) {
 292     if ($_ eq $cmd) {
 293       # Exact match - honor it
 294       $foundCmd = $cmd;
 295       last;
 296     } elsif (/^$cmd/) {
 297       # Command matched partially
 298       unless ($foundCmd) {
 299         # Found first instance of a match
 300         $foundCmd = $_;
 301       } else {
 302         # Found second instance of a match - $cmd is not unique
 303         undef $foundCmd;
 304         last;
 305       } # unless
 306     } # if
 307   } # for
 308
 309   # If we found a command, substitute it into line
 310   if ($foundCmd) {
 311     $line =~ s/^\s*$cmd\s*/$foundCmd /;
 312     $cmd = $foundCmd;
 313   } # if
 314
 315   if ($builtin_cmds{$cmd}) {
 316     if ($line =~ /^\s*helpall\s*$/i) {
 317       $self->help('', 1);
 318     } elsif ($line =~ /^\s*help\s*(.*)/i) {
 319       if ($1 =~ /(.+)$/) {
 320         $self->help($1);
 321       } else {
 322         $self->help;
 323       } # if
 324     } elsif ($line =~ /^\s*history\s*(.*)/i) {
 325       if ($1 =~ /(\d+)\s+(\d+)\s*$/) {
 326         $self->history('list', $1, $2);
 327       } elsif ($1 =~ /^\s*$/) {
 328         $self->history('list');
 329       } else {
 330         error "Invalid usage";
 331         $self->help('history');
 332       } # if
 333     } elsif ($line =~ /^\s*savehist\s*(.*)/i) {
 334       if ($1 =~ /(\S+)\s+(\d+)\s+(\d+)\s*$/) {
 335         $self->history('save', $1, $2, $3);
 336       } else {
 337         error 'Invalid usage';
 338         $self->help('savehist');
 339       } # if
 340     } elsif ($line =~ /^\s*get\s*(.*)/i) {
 341       if ($1 =~ (/^\$*(\S+)\s*$/)) {
 342         my $value = $self->_get($1);
 343
 344         if ($value) {
 345           display "$1 = $value";
 346         } else {
 347           error "$1 is not set";
 348         } # if
 349       } else {
 350         error 'Invalid usage';
 351         $self->help('get');
 352       } # if
 353     } elsif ($line =~ /^\s*set\s*(.*)/i) {
 354       if ($1 =~ /^\$*(\S+)\s*=\s*(.*)/) {
 355         $self->_set($1, $2)
 356       } else {
 357         error 'Invalid usage';
 358         $self->help('set');
 359       } # if
 360     } elsif ($line =~ /^\s*source\s+(\S+)/i) {
 361       $result = $self->source($1);
 362     } elsif ($line =~ /^\s*vars\s*/) {
 363       $self->vars($line);
 364     } elsif ($line =~ /^\s*color\s*(.*)/i) {
 365       if ($1 =~ /(1|on)/i) {
 366         $opts{color} = 1;
 367         delete $ENV{ANSI_COLORS_DISABLED}
 368           if $ENV{ANSI_COLORS_DISABLED};
 369       } elsif ($1 =~ /(0|off)/i) {
 370         $opts{trace} = 0;
 371         local $ENV{ANSI_COLORS_DISABLED} = 1;
 372       } elsif ($1 =~ /\s*$/) {
 373         if ($ENV{ANSI_COLORS_DISABLED}) {
 374           display 'Color is currently off';
 375         } else {
 376           display 'Color is currently on';
 377         } # if
 378       } else {
 379         error 'Invalid usage';
 380         $self->help('color');
 381       } # if
 382     } elsif ($line =~ /^\s*trace\s*(.*)/i) {
 383       if ($1 =~ /(1|on)/i) {
 384         $opts{trace} = 1;
 385       } elsif ($1 =~ /(0|off)/i) {
 386         $opts{trace} = 0;
 387       } elsif ($1 =~ /\s*$/) {
 388         if ($opts{trace}) {
 389           display 'Trace is currently on';
 390         } else {
 391           display 'Trace is currently off';
 392         } # if
 393       } else {
 394         error 'Invalid usage';
 395         $self->help('trace');
 396       } # if
 397     } # if
 398   } # if
 399
 400   return ($cmd, $line, $result);
 401 } # _builtinCmds
 402
 403 sub _interrupt() {
 404   # Announce that we have hit an interrupt
 405   print color ('yellow') . "<Control-C>\n" . color ('reset');
 406
 407   # Free up all of the line state info
 408   $_cmdline->free_line_state;
 409
 410   # Allow readline to clean up
 411   $_cmdline->cleanup_after_signal;
 412
 413   # Redisplay prompt on a new line
 414   $_cmdline->on_new_line;
 415   $_cmdline->{line_buffer} = '';
 416   $_cmdline->redisplay;
 417
 418   return;
 419 } # _interrupt
 420
 421 sub _displayMatches($$$) {
 422   my ($matches, $numMatches, $maxLength) = @_;
 423
 424   # Work on a copy... (Otherwise we were getting "Attempt to free unreferenced
 425   # scalar" internal errors from perl)
 426   my @Matches;
 427
 428   push @Matches, $_ for (@$matches);
 429
 430   my $match = shift @Matches;
 431
 432   if ($match =~/^\s*(.*) /) {
 433     $match = $1;
 434   } elsif ($match =~ /^\s*(\S+)$/) {
 435     $match = '';
 436   } # if
 437
 438   my %newMatches;
 439
 440   for (@Matches) {
 441     # Get next word
 442     s/^$match//;
 443
 444     if (/(\w+)/) {
 445       $newMatches{$1} = $1;
 446     } # if
 447   } # for
 448
 449   my @newMatches = sort keys %newMatches;
 450
 451   unshift @newMatches, $match;
 452
 453   $_cmdline->display_match_list (\@newMatches);
 454   $_cmdline->on_new_line;
 455   $_cmdline->redisplay;
 456
 457   return;
 458 } # _displayMatches
 459
 460 sub new(;$$%) {
 461   my ($class, $histfile, $eval, %cmds) = @_;
 462
 463 =pod
 464
 465 =head2 new ()
 466
 467 Construct a new CmdLine object. Note there is already a default
 468 CmdLine object created named $cmdline. You should use that unless you
 469 have good reason to instantiate another CmdLine object.
 470
 471 Parameters:
 472
 473 =for html <blockquote>
 474
 475 =over
 476
 477 =item $histfile
 478
 479 Set to a file name where to write the history file. If not defined no
 480 history is kept.
 481
 482 =item %cmds
 483
 484 A hash describing the valid commands and their help/description
 485 strings.
 486
 487  my %cmds = (
 488   'list' => {
 489      help        => 'List all known commands',
 490      description => 'This is a longer description
 491                      of the list command',
 492   },
 493   'help' => {
 494      help        => 'This is a help command',
 495      description => 'help <cmd>
 496                      Longer description of help',
 497   },
 498  );
 499
 500 =back
 501
 502 =for html </blockquote>
 503
 504 Returns:
 505
 506 =for html <blockquote>
 507
 508 =over
 509
 510 =item CmdLine object
 511
 512 =back
 513
 514 =for html </blockquote>
 515
 516 =cut
 517
 518   my $me = get_me;
 519
 520   $histfile ||= "$ENV{HOME}/.${me}_hist";
 521
 522   my $self = bless {
 523     histfile => $histfile,
 524   }, $class;
 525
 526   error "Creating bogus .${me}_hist file!"
 527     if $me eq '-' or $me eq '';
 528
 529   unless (-f $histfile) {
 530     open my $hist, '>', $histfile
 531       or error "Unable to open $histfile for writing - $!", 1;
 532
 533     close $hist;
 534   } # unless
 535
 536   # Instantiate a commandline
 537   $_cmdline = Term::ReadLine->new ($me);
 538
 539   # Store the function pointer of what to call when sourcing a file or
 540   # evaluating an expression.
 541   if ($eval) {
 542     if (ref $eval eq 'CODE') {
 543       $self->{eval} = $eval;
 544     } else {
 545       error "Invalid function pointer\nUsage: CmdLine->new ($histfile, $eval, %cmds)", 1;
 546     } # if
 547   } # if
 548
 549   # Default prompt is "$me:"
 550   $self->{prompt} = "$me:";
 551
 552   # Set commands
 553   $self->set_cmds(%cmds);
 554
 555   # Set some ornamentation
 556   $_cmdline->ornaments ('s,e,u,') unless $Config{cppflags} =~ /win32/i;
 557
 558   # Read in history
 559   $self->set_histfile($histfile);
 560
 561   # Generator function for completion matches
 562   $_attribs = $_cmdline->Attribs;
 563
 564   $_attribs->{attempted_completion_function} = \&CmdLine::_complete;
 565   $_attribs->{completion_display_matches_hook} = \&CmdLine::_displayMatches;
 566   $_attribs->{completer_word_break_characters} =~ s/ //
 567     if $_attribs->{completer_word_break_characters};
 568
 569   # The following functionality requires Term::ReadLine::Gnu
 570   if ($_haveGnu) {
 571     # Bind a key to display completion
 572     $_cmdline->add_defun('help-on-command', \&CmdLine::_gethelp, ord ("\cl"));
 573
 574     # Save a handy copy of RL_PROMPT_[START|END]_IGNORE
 575     $self->{ignstart} = $_cmdline->RL_PROMPT_START_IGNORE;
 576     $self->{ignstop}  = $_cmdline->RL_PROMPT_END_IGNORE;
 577   } # if
 578
 579   if ($Config{cppflags} =~ /win32/i) {
 580     $opts{trace} = 0;
 581     local $ENV{ANSI_COLORS_DISABLED} = 1;
 582   } # if
 583
 584   return $self;
 585 } # new
 586
 587 sub get() {
 588   my ($self) = @_;
 589
 590 =pod
 591
 592 =head2 get
 593
 594 Retrieves a command line
 595
 596 Parameters:
 597
 598 =for html <blockquote>
 599
 600 =over
 601
 602 =item None
 603
 604 =back
 605
 606 =for html </blockquote>
 607
 608 Returns:
 609
 610 =for html <blockquote>
 611
 612 =over
 613
 614 =item $cmds
 615
 616 =back
 617
 618 =for html </blockquote>
 619
 620 =cut
 621
 622   my ($cmd, $line, $result);
 623
 624   do {
 625     # Substitute cmdnbr into prompt if we find a '\#'
 626     my $prompt = $self->{prompt};
 627
 628     $prompt =~ s/\\\#/$self->{cmdnbr}/g;
 629
 630     use POSIX;
 631
 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.
 639
 640     # Damn Windows can't do any of this
 641     my $oldaction;
 642
 643     if ($Config{cppflags} !~ /win32/i) {
 644       my $sigset    = POSIX::SigSet->new;
 645       my $sigaction = POSIX::SigAction->new (\&_interrupt, $sigset, 0);
 646
 647       $oldaction = POSIX::SigAction->new;
 648
 649       # Set up our unsafe signal handler
 650       POSIX::sigaction (&POSIX::SIGINT, $sigaction, $oldaction);
 651     } # if
 652
 653     $line = $_cmdline->readline ($prompt);
 654
 655     # Restore the old signal handler
 656     if ($Config{cppflags} !~ /win32/i) {
 657       POSIX::sigaction (&POSIX::SIGINT, $oldaction);
 658     } # if
 659
 660     $line = $self->_interpolate($line)
 661       if $line;
 662
 663     $self->{cmdnbr}++ unless $self->{sourcing};
 664
 665     ($cmd, $line, $result) = $self->_builtinCmds($line);
 666
 667     $line = '' unless $cmd;
 668   } while ($cmd and $builtin_cmds{$cmd});
 669
 670   return ($line, $result);
 671 } # get
 672
 673 sub set_cmds(%) {
 674   my ($self, %cmds) = @_;
 675
 676 =pod
 677
 678 =head2 set_cmds
 679
 680 Sets the cmds
 681
 682 Parameters:
 683
 684 =for html <blockquote>
 685
 686 =over
 687
 688 =item %cmds
 689
 690 New commands to use
 691
 692 =back
 693
 694 =for html </blockquote>
 695
 696 Returns:
 697
 698 =for html <blockquote>
 699
 700 =over
 701
 702 =item Nothing
 703
 704 =back
 705
 706 =for html </blockquote>
 707
 708 =cut
 709
 710   %_cmds = %cmds;
 711
 712   # Add in builtins
 713   for (keys %builtin_cmds) {
 714     $_cmds{$_}{help}        = $builtin_cmds{$_}{help};
 715     $_cmds{$_}{description} = $builtin_cmds{$_}{description};
 716   } # for
 717
 718   return;
 719 } # set_cmds
 720
 721 sub set_prompt($) {
 722   my ($self, $prompt) = @_;
 723
 724 =pod
 725
 726 =head2 set_prompt
 727
 728 Sets the prompt
 729
 730 Parameters:
 731
 732 =for html <blockquote>
 733
 734 =over
 735
 736 =item $new_prompt
 737
 738 New commands to use
 739
 740 =back
 741
 742 =for html </blockquote>
 743
 744 Returns:
 745
 746 =for html <blockquote>
 747
 748 =over
 749
 750 =item $old_prompt
 751
 752 =back
 753
 754 =for html </blockquote>
 755
 756 =cut
 757
 758   my $return = $self->{prompt};
 759
 760   $self->{prompt} = $prompt;
 761
 762   return $return;
 763 } # set_prompt
 764
 765 sub set_histfile($) {
 766   my ($self, $histfile) = @_;
 767
 768 =pod
 769
 770 =head2 set_histfile
 771
 772 Sets the histfile
 773
 774 Parameters:
 775
 776 =for html <blockquote>
 777
 778 =over
 779
 780 =item $histfile
 781
 782 New commands to use
 783
 784 =back
 785
 786 =for html </blockquote>
 787
 788 Returns:
 789
 790 =for html <blockquote>
 791
 792 =over
 793
 794 =item Nothing
 795
 796 =back
 797
 798 =for html </blockquote>
 799
 800 =cut
 801
 802   if ($histfile and -f $histfile) {
 803     $self->{histfile} = $histfile;
 804
 805     if ($_haveGnu) {
 806       # Clear old history (if any);
 807       $_cmdline->clear_history;
 808
 809       # Now read histfile
 810       $_cmdline->ReadHistory ($histfile);
 811     } # if
 812
 813     # Determine the number of lines in the history file
 814     open my $hist, '<', $histfile
 815       or croak "Unable to open history file $histfile";
 816
 817     # Set cmdnbr
 818     for (<$hist>) {}
 819     $self->{cmdnbr} = $. + 1;
 820
 821     close $hist;
 822   } # if
 823
 824   return;
 825 } # set_histfile
 826
 827 sub set_eval(;\&) {
 828   my ($self, $eval) = @_;
 829
 830 =pod
 831
 832 =head2 set_eval
 833
 834 Sets the eval function pointer
 835
 836 Parameters:
 837
 838 =for html <blockquote>
 839
 840 =over
 841
 842 =item [\&function]
 843
 844 Function to set eval to. This function will be called with the command
 845 line as the only paramter and it should return a result.
 846
 847 =back
 848
 849 =for html </blockquote>
 850
 851 Returns:
 852
 853 =for html <blockquote>
 854
 855 =over
 856
 857 =item \&old_eval
 858
 859 =back
 860
 861 =for html </blockquote>
 862
 863 =cut
 864
 865   my $returnEval = $self->{eval};
 866
 867   $self->{eval} = $eval;
 868
 869   return $returnEval;
 870 } # set_eval
 871
 872 sub help(;$$) {
 873   my ($self, $cmd, $builtins) = @_;
 874
 875 =pod
 876
 877 =head2 help [<cmd>]
 878
 879 Displays help
 880
 881 Note that the user does not need to explicitly call help - CmdLine's
 882 get method will already sense that the builtin help command was
 883 invoked and handle it. This method is provided if the caller wishes to
 884 call this internally for some reason.
 885
 886 Parameters:
 887
 888 =for html <blockquote>
 889
 890 =over
 891
 892 =item $cmd
 893
 894 Optional command help
 895
 896 =back
 897
 898 =for html </blockquote>
 899
 900 Returns:
 901
 902 =for html <blockquote>
 903
 904 =over
 905
 906 =item Nothing
 907
 908 =back
 909
 910 =for html </blockquote>
 911
 912 =cut
 913
 914   my @help;
 915
 916   $builtins ||= 0;
 917
 918   $cmd ||= '';
 919   $cmd =~ s/^\s+//;
 920   $cmd =~ s/\s+$//;
 921
 922   if ($cmd =~ /^\s*(.+)/) {
 923     my ($searchStr, $helpFound);
 924
 925     $searchStr = $1;
 926
 927     for (sort keys %_cmds) {
 928       if (/$searchStr/i) {
 929         $helpFound = 1;
 930
 931         my $cmdcolor = $builtin_cmds{$_} ? color('cyan') : color('magenta');
 932
 933         $cmd  = "$cmdcolor$_";
 934         $cmd .= " $_cmds{$_}{parms}"  if $_cmds{$_}{parms};
 935         $cmd .= color('reset');
 936         $cmd .= " - $_cmds{$_}{help}" if $_cmds{$_}{help};
 937
 938         push @help, $cmd;
 939
 940         if ($_cmds{$_}{description}) {
 941           push @help, "  $_"
 942             for (split /\n/, $_cmds{$_}{description});
 943         } # if
 944       } # if
 945     } # for
 946
 947     unless ($helpFound) {
 948       display "I don't know about $cmd";
 949
 950       return;
 951     } # if
 952   } else {
 953     for (sort keys %_cmds) {
 954       next if $builtin_cmds{$_} and not $builtins;
 955
 956       my $cmdcolor = $builtin_cmds{$_} ? color ('cyan') : color ('magenta');
 957
 958       my $cmd  = "$cmdcolor$_";
 959          $cmd .= " $_cmds{$_}{parms}"  if $_cmds{$_}{parms};
 960          $cmd .= color ('reset');
 961          $cmd .= " - $_cmds{$_}{help}" if $_cmds{$_}{help};
 962
 963       push @help, $cmd;
 964
 965       if ($_cmds{$_}{description}) {
 966         push @help, "  $_"
 967         for (split /\n/, $_cmds{$_}{description});
 968       } # if
 969     } # for
 970   } # if
 971
 972   $self->handleOutput($cmd, @help);
 973
 974   return;
 975 } # help
 976
 977 sub history(;$) {
 978   my ($self, $action) = @_;
 979
 980 =pod
 981
 982 =head2 history <action> [<file>] [<start> <end>]
 983
 984 This method lists, saves or executes (redo) a command from the history
 985 stack. <action> can be one of 'list', 'save' or 'redo'. If listing
 986 history one can specify the optional <start> and <end> parameters. If
 987 saving then <file> must be specified and optionally <start> and
 988 <end>. If redoing a command then only <start> or the command number
 989 should be specified.
 990
 991 Note that the user does not need to explicitly call history -
 992 CmdLine's get method will already sense that the builtin history
 993 command was invoked and handle it. This method is provided if the
 994 caller wishes to call this internally for some reason.
 995
 996 Parameters:
 997
 998 =for html <blockquote>
 999
1000 =over
1001
1002 =item $action
1003
1004 One of 'list', 'save' or 'redo'
1005
1006 =back
1007
1008 =for html </blockquote>
1009
1010 Returns:
1011
1012 =for html <blockquote>
1013
1014 =over
1015
1016 =item Nothing
1017
1018 =back
1019
1020 =for html </blockquote>
1021
1022 =cut
1023
1024   if ($Config{cppflags} =~ /win32/i) {
1025     warning 'The history command does not work on Windows (sorry)';
1026
1027     return;
1028   } # if
1029
1030   my ($file, $start, $end);
1031
1032   if ($action eq 'list') {
1033     $start = $_[2];
1034     $end   = $_[3];
1035   } elsif ($action eq 'save') {
1036     $file  = $_[2];
1037     $start = $_[3];
1038     $end   = $_[4];
1039   } elsif ($action eq 'redo') {
1040     $_cmdline->remove_history ($_cmdline->where_history);
1041
1042     my $nbr  = $_[2];
1043     my $line = $_cmdline->history_get ($nbr);
1044
1045     $_cmdline->add_history ($line);
1046     display $line;
1047
1048     my ($cmd, $result) = $self->_builtinCmds($line);
1049
1050     if ($builtin_cmds{$cmd}) {
1051       return;
1052     } else {
1053       return $line;
1054     } # if
1055   } else {
1056     error "Unknown action $action in history";
1057     return;
1058   } # if
1059
1060   my $current = $_cmdline->where_history;
1061
1062   my $lines = ($ENV{LINES} ? $ENV{LINES} : 24) - 2;
1063
1064   $start = $current - $lines
1065     unless defined $start;
1066   $start = 1
1067     if $start < 1;
1068   $end   = $current
1069     unless defined $end;
1070   $end   = 1
1071     if $end < 1;
1072
1073   if ($start > $end) {
1074     error "Start ($start) is > end ($end)";
1075     help ('history');
1076   } else {
1077     my $savefile;
1078
1079     if ($action eq 'save') {
1080       unless ($file) {
1081         error "Usage: savehist <file> [<start> <end>]";
1082         return;
1083       } # unless
1084
1085       if (-f $file) {
1086         display_nolf "Overwrite $file (yN)? ";
1087
1088         my $response = <STDIN>;
1089
1090         unless ($response =~ /(y|yes)/i) {
1091           display "Not overwritten";
1092           return;
1093         } # unless
1094       } # if
1095
1096       my $success = open $savefile, '>', $file;
1097
1098       unless ($success) {
1099         error "Unable to open history file $file - $!";
1100         return;
1101       } # unless
1102     } # if
1103
1104     for (my $pos = $start; $pos <= $end; $pos++) {
1105       my $histline = $_cmdline->history_get ($pos);
1106
1107       last unless $histline;
1108
1109       if ($action eq 'list') {
1110         display "$pos) $histline";
1111       } else {
1112         print $savefile "$histline\n";
1113       } # if
1114     } # for
1115
1116     close $savefile
1117       if $action eq 'save';
1118   } # if
1119
1120   return;
1121 } # history
1122
1123 sub _get($$) {
1124   my ($self, $name) = @_;
1125
1126 =pod
1127
1128 =head2 _get ($name)
1129
1130 This method gets a variable to a value stored in the CmdLine
1131 object.
1132
1133 Parameters:
1134
1135 =for html <blockquote>
1136
1137 =over
1138
1139 =item $name
1140
1141 Name of the variable
1142
1143 =back
1144
1145 =for html </blockquote>
1146
1147 Returns:
1148
1149 =for html <blockquote>
1150
1151 =over
1152
1153 =item $value
1154
1155 =back
1156
1157 =for html </blockquote>
1158
1159 =cut
1160
1161   return $self->{vars}{$name}
1162 } # _get
1163
1164 sub _set($$) {
1165   my ($self, $name, $value) = @_;
1166
1167 =pod
1168
1169 =head2 _set ($name, $value)
1170
1171 This method sets a variable to a value stored in the CmdLine
1172 object. Note $value will be evaluated if eval is set.
1173
1174 Parameters:
1175
1176 =for html <blockquote>
1177
1178 =over
1179
1180 =item $name
1181
1182 Name of the variable
1183
1184 =item $value
1185
1186 Value of the variable
1187
1188 =back
1189
1190 =for html </blockquote>
1191
1192 Returns:
1193
1194 =for html <blockquote>
1195
1196 =over
1197
1198 =item $oldvalue
1199
1200 =back
1201
1202 =for html </blockquote>
1203
1204 =cut
1205
1206   my $returnValue = $self->{vars}{$name};
1207
1208   if (defined $value) {
1209     $value = $self->_interpolate($value);
1210
1211     # Do not call eval if we are setting result - otherwise we recurse
1212     # infinitely.
1213     unless ($name eq 'result') {
1214       no strict;
1215       $value = $self->{eval}($value) if $self->{eval};
1216       use strict;
1217     } # unless
1218
1219     $self->{vars}{$name} = $value;
1220   } else {
1221     delete $self->{vars}{$name};
1222   } # if
1223
1224   return $returnValue;
1225 } # _set
1226
1227 sub vars($) {
1228   my ($self, $cmd) = @_;
1229
1230 =pod
1231
1232 =head2 vars ($name)
1233
1234 This method will print out all known variables
1235
1236 Parameters:
1237
1238 =for html <blockquote>
1239
1240 =over
1241
1242 =item none
1243
1244 =back
1245
1246 =for html </blockquote>
1247
1248 Returns:
1249
1250 =for html <blockquote>
1251
1252 =over
1253
1254 =item Nothing
1255
1256 =back
1257
1258 =for html </blockquote>
1259
1260 =cut
1261
1262   my @output;
1263
1264   push @output, "$_ = $self->{vars}{$_}"
1265     for (keys %{$self->{vars}});
1266
1267   $self->handleOutput($cmd, @output);
1268
1269   return;
1270 } # vars
1271
1272 sub handleOutput($@) {
1273   my ($self, $line, @output) = @_;
1274
1275 =pod
1276
1277 =head2 handleOutput ($line, @output)
1278
1279 This method will handle outputing the array @output. It also handles redirection
1280 (currently only output redirection) and piping
1281
1282 Parameters:
1283
1284 =for html <blockquote>
1285
1286 =over
1287
1288 =item $line
1289
1290 The command line used to produce @output. This method parses out redirection
1291 (i.e. > and >>) and piping (|) from $cmd
1292
1293 =item @output
1294
1295 The output produced by the command to redirect or pipe. (Note this isn't true
1296 piping in that command must run first and produce all of @output before we are
1297 called. Need to look into how to use Perl's pipe command here).
1298
1299 =back
1300
1301 =for html </blockquote>
1302
1303 Returns:
1304
1305 =for html <blockquote>
1306
1307 =over
1308
1309 =item Nothing
1310
1311 =back
1312
1313 =for html </blockquote>
1314
1315 =cut
1316
1317   my ($outToFile, $pipeToCmd);
1318
1319   # Handle piping and redirection
1320   if ($line =~ /(.*)\>{2}\s*(.*)/) {
1321     $line      = $1;
1322     $outToFile = ">$2";
1323   } elsif ($line =~ /(.*)\>{1}\s*(.*)/) {
1324     $line      = $1;
1325     $outToFile = $2;
1326   } elsif ($line =~ /(.*?)\|\s*(.*)/) {
1327     $line      = $1;
1328     $pipeToCmd = $2;
1329   } # if
1330
1331   # Store @output
1332   $self->{output} = \@output;
1333
1334   if ($pipeToCmd) {
1335     my $pipe;
1336
1337     local $SIG{PIPE} = 'IGNORE';
1338
1339     open $pipe, '|', $pipeToCmd
1340       or undef $pipe;
1341
1342     # TODO: Not handling the output here. Need open2 and then recursively call
1343     # handleOutput.
1344     if ($pipe) {
1345       print $pipe "$_\n"
1346         for (@output);
1347
1348       close $pipe
1349         or error "Unable to close pipe for $pipeToCmd - $!";
1350     } else {
1351       error "Unable to open pipe for $pipeToCmd - $!";
1352     } # if
1353   } else {
1354     unless ($outToFile) {
1355       PageOutput @output;
1356     } else {
1357       open my $output, '>', $outToFile;
1358
1359       if ($output) {
1360         print $output "$_\n"
1361           for (@output);
1362
1363         close $output;
1364
1365         undef $outToFile;
1366       } else {
1367         error "Unable to open $outToFile for writing - $!"
1368       } # if
1369     } # unless
1370   } # if
1371
1372   return;
1373 } # handleOutput
1374
1375 sub source($) {
1376   my ($self, $file) = @_;
1377
1378 =pod
1379
1380 =head2 source <file>
1381
1382 This method opens a file and sources it's content by executing each
1383 line. Note that the user must have set $self->{eval} to a function
1384 pointer. The function will be called with one parameter - the command
1385 line to execute. The function will return the result from the
1386 execution of the final command.
1387
1388 Note that the user does not need to explicitly call source -
1389 CmdLine's get method will already sense that the builtin source
1390 command was invoked and handle it. This method is provided if the
1391 caller wishes to call this internally for some reason.
1392
1393 Parameters:
1394
1395 =for html <blockquote>
1396
1397 =over
1398
1399 =item $file
1400
1401 Filename to source
1402
1403 =back
1404
1405 =for html </blockquote>
1406
1407 Returns:
1408
1409 =for html <blockquote>
1410
1411 =over
1412
1413 =item Returns the result of the last command executed
1414
1415 =back
1416
1417 =for html </blockquote>
1418
1419 =cut
1420
1421   unless (-f $file) {
1422     error "Unable to open file $file - $!";
1423     return;
1424   } # unless
1425
1426   open my $source, '<', $file;
1427
1428   my $result;
1429
1430   $self->{sourcing} = 1;
1431
1432   my $i = 0;
1433
1434   while (<$source>) {
1435     chomp;
1436
1437     $i++;
1438
1439     my $prompt = $self->{prompt};
1440
1441     $prompt =~ s/\\\#/$file:$i/;
1442
1443     display "$prompt$_" if $CmdLine::opts{trace};
1444
1445     next if /^\s*($|\#)/;
1446
1447     $_ = $self->_interpolate ($_);
1448
1449     # Check to see if it's a builtin
1450     my ($cmd, $line, $result) = $self->_builtinCmds ($_);
1451
1452     next if $builtin_cmds{$cmd};
1453
1454     no strict;
1455     $result = $self->{eval}($line);
1456     use strict;
1457
1458     if (defined $result) {
1459       if (ref \$result eq 'SCALAR') {
1460         PageOutput (split /\n/, $result);
1461       } else {
1462         display "Sorry but I cannot display structured results";
1463       } #  if
1464     } # if
1465   } # while
1466
1467   $self->{sourcing} = 0;
1468
1469   close $source;
1470
1471   return $result;
1472 } # source
1473
1474 sub DESTROY {
1475   my ($self) = @_;
1476
1477   $_cmdline->WriteHistory($self->{histfile})
1478     if $_cmdline and $_haveGnu;
1479
1480   return;
1481 } # DESTROY
1482
1483 our $cmdline = CmdLine->new;
1484
1485 1;
1486
1487 =pod
1488
1489 =head1 DEPENDENCIES
1490
1491 =head2 Perl Modules
1492
1493 =head2 ClearSCM Perl Modules
1494
1495 =for html <p><a href="/php/scm_man.php?file=lib/Display.pm">Display</a></p>
1496
1497 =head1 BUGS AND LIMITATIONS
1498
1499 There are no known bugs in this module
1500
1501 Please report problems to Andrew DeFaria <Andrew@ClearSCM.com>.
1502
1503 =head1 LICENSE AND COPYRIGHT
1504
1505 Copyright (c) 2007, ClearSCM, Inc. All rights reserved.
1506
1507 =cut