File Coverage

blib/lib/Term/ShellKit.pm

Criterion	Covered	Total	%
statement	79	110	71.8
branch	25	60	41.6
condition	2	3	66.6
subroutine	15	17	88.2
pod	0	8	0.0
total	121	198	61.1

#!/usr/bin/perl

# my $self_running = ( ! caller );
# END {  Term::ShellKit::shell if ( $self_running  ); }

######################################################################

package Term::ShellKit;

$VERSION = 1.002;
@EXPORT = qw( shell );
sub import { require Exporter and goto &Exporter::import } # lazy Exporter

use strict;
use Carp;
use Text::ParseWords;

######################################################################

use vars qw( $Prompt $SubReadLine );

$SubReadLine = ( -t STDIN ) ? \&readline_term : \&readline_raw;
$Prompt ||= 'Term::ShellKit> ';

sub readline_raw {
  my $prompt = scalar(@_) ? shift : $Prompt;
  print($prompt);
  $_ = <>;
  chomp if defined $_;
  print($_."\n");
  $_
}

my $TermReadLine;

sub readline_term {
  if ( ! $TermReadLine ) {
    require Term::ReadLine;
    $TermReadLine = Term::ReadLine->new('Term-ShellKit');

    # $ShellReadLine->OUT is autoflushed anyway
    my $odef = select STDERR;
    $| = 1;
    select STDOUT;
    $| = 1;
    select $odef;
  }
  my $prompt = scalar(@_) ? shift : $Prompt;
  $TermReadLine->readline( $prompt )
}

######################################################################

use vars qw( $SubDoCommand $CurrentPackage @CommandPackages );

$SubDoCommand = \&do_command;
$CurrentPackage ||= 'main';

use vars qw( @CommandQueue );

sub do_command {
  my $input = shift;

  length $input or return;

  $input =~ /\A\s*(\S+)(?:\s(?![\)])(.*))?\Z/
    or die "Can't parse command line '$input'\n";

  my ($command, $args) = ( $1, $2 );

  my $sub;
  if ( $command =~ /^(.*)::([^:]+)$/ ) {
    my ($pack, $func) = ($1, $2);
    $sub = UNIVERSAL::can($pack, $func);
  } else {
    foreach my $package ( $CurrentPackage, @CommandPackages ) {
      if ( $sub = UNIVERSAL::can($package, $command) ) {
	last;
      }
    }
  }
  if ( ! $sub ) {
    foreach my $package ( @CommandPackages ) {
      my $rewriter = UNIVERSAL::can($package, '_shell_rewrite') or next;
      my @out = &$rewriter( $input );
      if ( scalar @out ) {
	unshift @CommandQueue, @out;
	return;
      }
    }
    die "Can't find command or function named '$command'\n";
  }

  my $ptype = prototype( $sub );
  my @args;
  if ( ! defined $ptype or $ptype eq '@' ) {
    eval { @args = Text::ParseWords::shellwords($args) };
    croak("Can't parse arguments for $command($ptype): $@") if $@;
  } elsif ( $ptype eq ';$' ) {
    @args = defined($args) ? $args : ();
  } elsif ( $ptype eq '$' ) {
    croak("Missing required argument for $command($ptype)") unless (length $args);
    @args = $args;
  } else {
    eval { @args = Text::ParseWords::shellwords($args) };
    croak("Can't parse arguments for $command($ptype): $@") if $@;
  }
  &$sub( @args );
}

sub command_rewrite {
  unshift @CommandQueue, @_;
  die "Term::ShellKit command completed";
}

######################################################################

use vars qw( $PrintResultsSub );
$PrintResultsSub = \&print_results;

# require Dumpvalue;
# $Dumper = Dumpvalue->new();
# print $Dumper->dumpValue($value);
sub print_results {
  print join '', map { /\n\Z/m ? $_ : "$_\n" } grep { length $_ } @_;
}

######################################################################

use vars qw( @DefaultStartup );
@DefaultStartup = (
  'Term::ShellKit::require_package Term::ShellKit::Commands',
  'Term::ShellKit::Commands::echo Term::ShellKit: Starting interactive shell; commands include help, exit.',
  'Term::ShellKit::load_kit Commands',
  @ARGV,
);

sub shell {
  local $Prompt = $Prompt;
  local @CommandQueue = scalar(@_) ? @_ : @DefaultStartup;

  while ( 1 ) {
    if ( ! scalar @CommandQueue ) {
      my $get_cmd = $SubReadLine or confess "No \$SubReadLine";
      @CommandQueue = &$get_cmd();
    }

    my $cmd = shift @CommandQueue;
    ( defined $cmd ) or last;

    my @results = eval { &$SubDoCommand( $cmd ) };
    if ( $@ ) {
      if ( $@ =~ /Term::ShellKit command completed/ ) {
	next;
      } else {
	warn "Exception: $@";
      }
    }
    &$PrintResultsSub( @results );
  }
}

######################################################################

sub require_package {
  my $package = shift;
  $package =~ s/;\s*$//;

  (my $file = $package . '.pm' ) =~ s|::|/|go;
  return $package if ( $::INC{ $file } );

  eval {
    local $SIG{__DIE__} = '';
    require $file;
  };

  if ( $@ ) {
    die "Unable to dynamically load $package: $@"
  }

  return
}

sub load_kit {
  my $package = shift;
  $package =~ s/;\s*$//;

  $package = "Term::ShellKit::$package" unless $package =~ /::/;

  require_package($package);
  $package->import if ( $package->can('import') );

  push @CommandPackages, $package;
  "Activating $package";
}

######################################################################

package main;
Term::ShellKit::shell unless caller;

######################################################################

1;

__END__