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