updated shell code to register query commands with Tcl object

[scpubgit/DX.git] / lib / DX / ShellFrontend.pm

package DX::ShellFrontend;

use IO::Handle;
use Caroline;
use DX::Class;

has session => (
  is => 'ro', required => 1,
  handles => [ qw(is_complete_command_string eval_command_string) ]
);

has session_mode => (is => 'rwp', required => 1);

has readline => (is => 'lazy', builder => sub { Caroline->new });

sub BUILD { STDOUT->autoflush(1) }

sub repl {
  my ($self) = @_;
  while (1) {
    last unless $self->rep
  }
}

sub rep {
  my ($self) = @_;
  return unless defined(my $command = $self->read_command);
  my @result = $self->eval_command_string($command);
  $self->process_result(@result);
  return 1;
}

sub read_command {
  my ($self) = @_;
  my $base_prompt = $self->session_mode eq 'shell' ? '$ ' : '? ';
  my $rl = $self->readline;
  return unless defined(my $command = $rl->readline($base_prompt));
  while (not $self->is_complete_command_string($command)) {
    $command .= $rl->readline('> ');
  }
  $rl->history_add($command);
  return $command;
}

sub process_result {
  my ($self, @result) = @_;
  foreach my $res (@result) {
    my ($type, $payload) = @$res;
    $self->${\($self->can("process_${type}_result")||die)}($payload);
  }
}

sub process_mode_result {
  my ($self, $mode) = @_;
  $self->_set_session_mode($mode);
}

sub process_output_result {
  my ($self, $output) = @_;
  $output .= "\n" unless $output =~ /\n$/;
  print $output;
}

1;