# Shell.pm
#
# General extendable command shell with programmable command completion.
#
# Author: Nat Lanza
#
# Copyright (c) of Carnegie Mellon University, 1999.
#
# Permission to reproduce, use, and prepare derivative works of
# this software for internal use is granted provided the copyright
# and "No Warranty" statements are included with all reproductions
# and derivative works. This software may also be redistributed
# without charge provided that the copyright and "No Warranty"
# statements are included in all redistributions.
#
# NO WARRANTY. THIS SOFTWARE IS FURNISHED ON AN "AS IS" BASIS.
# CARNEGIE MELLON UNIVERSITY MAKES NO WARRANTIES OF ANY KIND, EITHER
# EXPRESSED OR IMPLIED AS TO THE MATTER INCLUDING, BUT NOT LIMITED
# TO: WARRANTY OF FITNESS FOR PURPOSE OR MERCHANTABILITY, EXCLUSIVITY
# OF RESULTS OR RESULTS OBTAINED FROM USE OF THIS SOFTWARE. CARNEGIE
# MELLON UNIVERSITY DOES NOT MAKE ANY WARRANTY OF ANY KIND WITH RESPECT
# TO FREEDOM FROM PATENT, TRADEMARK, OR COPYRIGHT INFRINGEMENT.
#

package NASD::Shell;

$ENV{PERL_RL} = 'Perl'; # I don't want to deal with GNU.

use strict;
use Term::ReadLine;
use Text::Abbrev;
use Text::ParseWords qw(shellwords);

use Exporter;
use vars qw(@ISA @EXPORT);
@ISA = 'Exporter';
@EXPORT = qw(&register_commands &register_completions
	     &set_prompt_func &shell_loop
	     &get_variable &set_variable);

my %commands = (echo => \&shell_echo,
		help => \&shell_help,
		quit => \&shell_quit,
		set  => \&shell_set,
		show => \&shell_show);

my %completions = (
		   set  => \&cpl_set,
		   show => \&cpl_show,
		  );

my $abbr_ref = abbrev keys %commands;
my %shell_vars = ();

my $term = new Term::ReadLine 'NASD Shell';
$readline::rl_completion_function =
  $readline::rl_completion_function = 'NASD::Shell::cpl';

$term->addhistory("");

my $OUT  = $term->OUT || *STDOUT;

my $shell_done = 0; # set to 1 to quit the shell loop

my $prompt = "> ";
my $prompt_func = undef;

sub register_commands {
  my ($cref) = @_;
  for (keys %$cref) { $commands{$_} = $cref->{$_}; }  
  $abbr_ref = abbrev keys %commands;
}

sub register_completions {
  my ($cref) = @_;
  for (keys %$cref) { $completions{$_} = $cref->{$_}; }  
}

sub set_prompt_func {
  my ($pfref) = @_;
  $prompt_func = $pfref;
}


sub set_variable {
  my ($var, $value) = @_;
  $shell_vars{$var} = $value;
}


sub get_variable {
  my ($var) = @_;
  if (defined $shell_vars{$var}) { return $shell_vars{$var}; }
  else { return undef; }
}


sub shell_loop {
  while ( !$shell_done ) {	
    $prompt = &$prompt_func() if defined $prompt_func;

    if (!defined ($_ = $term->readline($prompt))) {
      print $OUT "\n"; &{$commands{quit}}; next;
    }

    next unless /\S/;

    $term->addhistory($_);
    
    my @args = &shell_substitute(shellwords($_));
    next unless @args; # this happens if there's a bad variable subsitution

    my $command = shift @args;
    
    $command = $abbr_ref->{lc $command} if defined $abbr_ref->{lc $command};
    
    { 
      if (defined $commands{$command}) {
	&{$commands{$command}}($command, @args);
      } else {
	&shell_unknown($command, @args);
      }
    }
  }
  print "\n";
}

######################################################################
# shell utility functions

sub shell_substitute {
  my (@words) = @_;
  
  for (@words) {
    next unless /^\$/;
    s/^\$//;
    if (defined $shell_vars{$_}) { $_ = $shell_vars{$_}; }
    else { print "Unknown variable \$$_\n"; return (); }
  }

  return @words;
}

######################################################################
# shell command functions

sub shell_unknown {
  my ($command, @args) = @_;

  print "Unknown command '$command'!\n";
}


sub shell_help {
  my ($command, @args) = @_;

  print "Recognized commands:\n";
  for (sort keys %commands) {
    print "\t$_\n";
  }
}


sub shell_quit {
  my ($command, @args) = @_;
#  print "Bye!";
  $shell_done = 1;
}


sub shell_echo {
  my ($command, @args) = @_;

  return unless @args;

  print join(' ', @args), "\n";
}


sub shell_set {
  my ($command, @args) = @_;
  
  if    (@args == 2) { set_variable(@args);                     }
  elsif (@args == 1) { shell_show("show", @args);               }
  else               { print "usage: set <variable> [value]\n"; }
}


sub shell_show {
  my ($command, @args) = @_;
  
  if (@args < 1) { print "usage: show <variable list>\n"; return; }

  for (@args) {
    my $var = get_variable($_);
    if (defined $var) { print "$_ = '$var'\n";       }
    else              { print "$_ is not defined\n"; }
  }
}


######################################################################
# hand-rolled completion support.
sub cpl {
  my ($word, $line, $pos) = @_;
  $word ||= ""; $line ||= ""; $pos ||= 0;

  $word =~ s!([\[\]\/\\\(\)\|\{\}])!\\$1!g; # argh

  if ($pos == 0) { return grep(/^$word/, sort keys %commands); }
  else {
    my @words = shellwords($line);
    
    # substitute in variables
    for (@words) {
      next unless /^\$(.*)$/;
      my $word = $1;
      $word =~ s!([\[\]\/\\\(\)\|\{\}])!\\$1!g; # argh
      return grep (/^$word/, sort keys %shell_vars);
    }

    my $command = shift @words;

    if (defined $completions{$command}) {
      my $wordno = 1;
      for (@words) { last if ($word eq $_); $wordno++; }

      return &{$completions{$command}}($word, $pos, $wordno, @words);
    }
  }

  return ();
}


sub cpl_set {
  my ($word, $pos, @words) = @_;
  $word ||= ""; $pos ||= 0;

  $word =~ s!([\[\]\/\\\(\)\|\{\}])!\\$1!g; # argh

  my $wordno = 1; for (@words) { last if $_ eq $word; $wordno++; }

  if ($wordno % 2) { return grep (/^$word/, sort keys %shell_vars); }
  else             { return (); } # we only complete variable names
}


sub cpl_show {
  my ($word, $pos, @words) = @_;
  $word ||= ""; $pos ||= 0;

  $word =~ s!([\[\]\/\\\(\)\|\{\}])!\\$1!g; # argh

  return grep (/^$word/, sort keys %shell_vars);
}


1;
