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