package Term::Shell;
use strict;
use warnings;
use Data::Dumper;
use Term::ReadLine;
use vars qw($VERSION);
$VERSION = '0.04';
#=============================================================================
# Term::Shell API methods
#=============================================================================
sub new {
my $cls = shift;
my $o = bless {
term => eval {
# Term::ReadKey throws ugliness all over the place if we're not
# running in a terminal, which we aren't during "make test", at
# least on FreeBSD. Suppress warnings here.
local $SIG{__WARN__} = sub { };
Term::ReadLine->new('shell');
} || undef,
}, ref($cls) || $cls;
# Set up the API hash:
$o->{command} = {};
$o->{API} = {
args => \@_,
case_ignore => ($^O eq 'MSWin32' ? 1 : 0),
check_idle => 0, # changing this isn't supported
class => $cls,
command => $o->{command},
cmd => $o->{command}, # shorthand
match_uniq => 1,
pager => $ENV{PAGER} || 'internal',
readline => eval { $o->{term}->ReadLine } || 'none',
script => (caller(0))[1],
version => $VERSION,
};
# Note: the rl_completion_function doesn't pass an object as the first
# argument, so we have to use a closure. This has the unfortunate effect
# of preventing two instances of Term::ReadLine from coexisting.
my $completion_handler = sub {
$o->rl_complete(@_);
};
if ($o->{API}{readline} eq 'Term::ReadLine::Gnu') {
my $attribs = $o->{term}->Attribs;
$attribs->{completion_function} = $completion_handler;
}
elsif ($o->{API}{readline} eq 'Term::ReadLine::Perl') {
$readline::rl_completion_function =
$readline::rl_completion_function = $completion_handler;
}
$o->find_handlers;
$o->init;
$o;
}
sub DESTROY {
my $o = shift;
$o->fini;
}
sub cmd {
my $o = shift;
$o->{line} = shift;
if ($o->line =~ /\S/) {
my ($cmd, @args) = $o->line_parsed;
$o->run($cmd, @args);
unless ($o->{command}{run}{found}) {
my @c = sort $o->possible_actions($cmd, 'run');
if (@c and $o->{API}{match_uniq}) {
print $o->msg_ambiguous_cmd($cmd, @c);
}
else {
print $o->msg_unknown_cmd($cmd);
}
}
}
else {
$o->run('');
}
}
sub stoploop { $_[0]->{stop}++ }
sub cmdloop {
my $o = shift;
$o->{stop} = 0;
$o->preloop;
while (defined (my $line = $o->readline($o->prompt_str))) {
$o->cmd($line);
last if $o->{stop};
}
$o->postloop;
}
*mainloop = \&cmdloop;
sub readline {
my $o = shift;
my $prompt = shift;
return $o->{term}->readline($prompt)
if $o->{API}{check_idle} == 0
or not defined $o->{term}->IN;
# They've asked for idle-time running of some user command.
local $Term::ReadLine::toloop = 1;
local *Tk::fileevent = sub {
my $cls = shift;
my ($file, $boring, $callback) = @_;
$o->{fh} = $file; # save the filehandle!
$o->{cb} = $callback; # save the callback!
};
local *Tk::DoOneEvent = sub {
# We'll totally cheat and do a select() here -- the timeout will be
# $o->{API}{check_idle}; if the handle is ready, we'll call &$cb;
# otherwise we'll call $o->idle(), which can do some processing.
my $timeout = $o->{API}{check_idle};
use IO::Select;
if (IO::Select->new($o->{fh})->can_read($timeout)) {
# Input is ready: stop the event loop.
$o->{cb}->();
}
else {
$o->idle;
}
};
$o->{term}->readline($prompt);
}
sub term { $_[0]->{term} }
# These are likely candidates for overriding in subclasses
sub init { } # called last in the ctor
sub fini { } # called first in the dtor
sub preloop { }
sub postloop { }
sub precmd { }
sub postcmd { }
sub prompt_str { 'shell> ' }
sub idle { }
sub cmd_prefix { '' }
sub cmd_suffix { '' }
#=============================================================================
# The pager
#=============================================================================
sub page {
my $o = shift;
my $text = shift;
my $maxlines = shift || $o->termsize->{rows};
my $pager = $o->{API}{pager};
# First, count the number of lines in the text:
my $lines = ($text =~ tr/\n//);
# If there are fewer lines than the page-lines, just print it.
if ($lines < $maxlines or $maxlines == 0 or $pager eq 'none') {
print $text;
}
# If there are more, page it, either using the external pager...
elsif ($pager and $pager ne 'internal') {
require File::Temp;
my ($handle, $name) = File::Temp::tempfile();
select((select($handle), $| = 1)[0]);
print $handle $text;
close $handle;
system($pager, $name) == 0
or print <<END;
Warning: can't run external pager '$pager': $!.
END
unlink $name;
}
# ... or the internal one
else {
my $togo = $lines;
my $line = 0;
my @lines = split '^', $text;
while ($togo > 0) {
my @text = @lines[$line .. $#lines];
my $ret = $o->page_internal(\@text, $maxlines, $togo, $line);
last if $ret == -1;
$line += $ret;
$togo -= $ret;
}
return $line;
}
return $lines
}
sub page_internal {
my $o = shift;
my $lines = shift;
my $maxlines = shift;
my $togo = shift;
my $start = shift;
my $line = 1;
while ($_ = shift @$lines) {
print;
last if $line >= ($maxlines - 1); # leave room for the prompt
$line++;
}
my $lines_left = $togo - $line;
my $current_line = $start + $line;
my $total_lines = $togo + $start;
my $instructions;
if ($o->have_readkey) {
$instructions = "any key for more, or q to quit";
}
else {
$instructions = "enter for more, or q to quit";
}
if ($lines_left > 0) {
local $| = 1;
my $l = "---line $current_line/$total_lines ($instructions)---";
my $b = ' ' x length($l);
print $l;
my $ans = $o->readkey;
print "\r$b\r" if $o->have_readkey;
print "\n" if $ans =~ /q/i or not $o->have_readkey;
$line = -1 if $ans =~ /q/i;
}
$line;
}
#=============================================================================
# Run actions
#=============================================================================
sub run {
my $o = shift;
my $action = shift;
my @args = @_;
$o->do_action($action, \@args, 'run')
}
sub complete {
my $o = shift;
my $action = shift;
my @args = @_;
my @compls = $o->do_action($action, \@args, 'comp');
return () unless $o->{command}{comp}{found};
return @compls;
}
sub help {
my $o = shift;
my $topic = shift;
my @subtopics = @_;
$o->do_action($topic, \@subtopics, 'help')
}
sub summary {
my $o = shift;
my $topic = shift;
$o->do_action($topic, [], 'smry')
}
#=============================================================================
# Manually add & remove handlers
#=============================================================================
sub add_handlers {
my $o = shift;
for my $hnd (@_) {
next unless $hnd =~ /^(run|help|smry|comp|catch|alias)_/o;
my $t = $1;
my $a = substr($hnd, length($t) + 1);
# Add on the prefix and suffix if the command is defined
if (length $a) {
substr($a, 0, 0) = $o->cmd_prefix;
$a .= $o->cmd_suffix;
}
$o->{handlers}{$a}{$t} = $hnd;
if ($o->has_aliases($a)) {
my @a = $o->get_aliases($a);
for my $alias (@a) {
substr($alias, 0, 0) = $o->cmd_prefix;
$alias .= $o->cmd_suffix;
$o->{handlers}{$alias}{$t} = $hnd;
}
}
}
}
sub add_commands {
my $o = shift;
while (@_) {
my ($cmd, $hnd) = (shift, shift);
$o->{handlers}{$cmd} = $hnd;
}
}
sub remove_handlers {
my $o = shift;
for my $hnd (@_) {
next unless $hnd =~ /^(run|help|smry|comp|catch|alias)_/o;
my $t = $1;
my $a = substr($hnd, length($t) + 1);
# Add on the prefix and suffix if the command is defined
if (length $a) {
substr($a, 0, 0) = $o->cmd_prefix;
$a .= $o->cmd_suffix;
}
delete $o->{handlers}{$a}{$t};
}
}
sub remove_commands {
my $o = shift;
for my $name (@_) {
delete $o->{handlers}{$name};
}
}
*add_handler = \&add_handlers;
*add_command = \&add_commands;
*remove_handler = \&remove_handlers;
*remove_command = \&remove_commands;
#=============================================================================
# Utility methods
#=============================================================================
sub termsize {
my $o = shift;
my ($rows, $cols) = (24, 78);
# Try several ways to get the terminal size
TERMSIZE:
{
my $TERM = $o->{term};
last TERMSIZE unless $TERM;
my $OUT = $TERM->OUT;
if ($TERM and $o->{API}{readline} eq 'Term::ReadLine::Gnu') {
($rows, $cols) = $TERM->get_screen_size;
last TERMSIZE;
}
if ($^O eq 'MSWin32' and eval { require Win32::Console }) {
Win32::Console->import;
# Win32::Console's DESTROY does a CloseHandle(), so save the object:
$o->{win32_stdout} ||= Win32::Console->new(STD_OUTPUT_HANDLE());
my @info = $o->{win32_stdout}->Info;
$cols = $info[7] - $info[5] + 1; # right - left + 1
$rows = $info[8] - $info[6] + 1; # bottom - top + 1
last TERMSIZE;
}
if (eval { require Term::Size }) {
my @x = Term::Size::chars($OUT);
if (@x == 2 and $x[0]) {
($cols, $rows) = @x;
last TERMSIZE;
}
}
if (eval { require Term::Screen }) {
my $screen = Term::Screen->new;
($rows, $cols) = @$screen{qw(ROWS COLS)};
last TERMSIZE;
}
if (eval { require Term::ReadKey }) {
($cols, $rows) = eval {
local $SIG{__WARN__} = sub {};
Term::ReadKey::GetTerminalSize($OUT);
};
last TERMSIZE unless $@;
}
if ($ENV{LINES} or $ENV{ROWS} or $ENV{COLUMNS}) {
$rows = $ENV{LINES} || $ENV{ROWS} || $rows;
$cols = $ENV{COLUMNS} || $cols;
last TERMSIZE;
}
{
local $^W;
local *STTY;
if (open (STTY, "stty size |")) {
my $l = <STTY>;
($rows, $cols) = split /\s+/, $l;
close STTY;
}
}
}
return { rows => $rows, cols => $cols};
}
sub readkey {
my $o = shift;
$o->have_readkey unless $o->{readkey};
$o->{readkey}->();
}
sub have_readkey {
my $o = shift;
return 1 if $o->{have_readkey};
my $IN = $o->{term}->IN;
if (eval { require Term::InKey }) {
$o->{readkey} = \&Term::InKey::ReadKey;
}
elsif ($^O eq 'MSWin32' and eval { require Win32::Console }) {
$o->{readkey} = sub {
my $c;
# from Term::InKey:
eval {
# Win32::Console's DESTROY does a CloseHandle(), so save it:
Win32::Console->import;
$o->{win32_stdin} ||= Win32::Console->new(STD_INPUT_HANDLE());
my $mode = my $orig = $o->{win32_stdin}->Mode or die $^E;
$mode &= ~(ENABLE_LINE_INPUT() | ENABLE_ECHO_INPUT());
$o->{win32_stdin}->Mode($mode) or die $^E;
$o->{win32_stdin}->Flush or die $^E;
$c = $o->{win32_stdin}->InputChar(1);
die $^E unless defined $c;
$o->{win32_stdin}->Mode($orig) or die $^E;
};
die "Not implemented on $^O: $@" if $@;
$c;
};
}
elsif (eval { require Term::ReadKey }) {
$o->{readkey} = sub {
Term::ReadKey::ReadMode(4, $IN);
my $c = getc($IN);
Term::ReadKey::ReadMode(0, $IN);
$c;
};
}
else {
$o->{readkey} = sub { scalar <$IN> };
return $o->{have_readkey} = 0;
}
return $o->{have_readkey} = 1;
}
*has_readkey = \&have_readkey;
sub prompt {
my $o = shift;
my ($prompt, $default, $completions, $casei) = @_;
my $term = $o->{term};
# A closure to read the line.
my $line;
my $readline = sub {
my ($sh, $gh) = @{$term->Features}{qw(setHistory getHistory)};
my @history = $term->GetHistory if $gh;
$term->SetHistory() if $sh;
$line = $o->readline($prompt);
$line = $default
if ((not defined $line or $line =~ /^\s*$/) and defined $default);
# Restore the history
$term->SetHistory(@history) if $sh;
$line;
};
# A closure to complete the line.
my $complete = sub {
my ($word, $line, $start) = @_;
return $o->completions($word, $completions, $casei);
};
if ($term and $term->ReadLine eq 'Term::ReadLine::Gnu') {
my $attribs = $term->Attribs;
local $attribs->{completion_function} = $complete;
&$readline;
}
elsif ($term and $term->ReadLine eq 'Term::ReadLine::Perl') {
local $readline::rl_completion_function = $complete;
&$readline;
}
else {
&$readline;
}
$line;
}
sub format_pairs {
my $o = shift;
my @keys = @{shift(@_)};
my @vals = @{shift(@_)};
my $sep = shift || ": ";
my $left = shift || 0;
my $ind = shift || "";
my $len = shift || 0;
my $wrap = shift || 0;
if ($wrap) {
eval {
require Text::Autoformat;
Text::Autoformat->import(qw(autoformat));
};
if ($@) {
warn (
"Term::Shell::format_pairs(): Text::Autoformat is required " .
"for wrapping. Wrapping disabled"
) if $^W;
$wrap = 0;
}
}
my $cols = shift || $o->termsize->{cols};
$len < length($_) and $len = length($_) for @keys;
my @text;
for my $i (0 .. $#keys) {
next unless defined $vals[$i];
my $sz = ($len - length($keys[$i]));
my $lpad = $left ? "" : " " x $sz;
my $rpad = $left ? " " x $sz : "";
my $l = "$ind$lpad$keys[$i]$rpad$sep";
my $wrap = $wrap & ($vals[$i] =~ /\s/ and $vals[$i] !~ /^\d/);
my $form = (
$wrap
? autoformat(
"$vals[$i]", # force stringification
{ left => length($l)+1, right => $cols, all => 1 },
)
: "$l$vals[$i]\n"
);
substr($form, 0, length($l), $l);
push @text, $form;
}
my $text = join '', @text;
return wantarray ? ($text, $len) : $text;
}
sub print_pairs {
my $o = shift;
my ($text, $len) = $o->format_pairs(@_);
$o->page($text);
return $len;
}
# Handle backslash translation; doesn't do anything complicated yet.
sub process_esc {
my $o = shift;
my $c = shift;
my $q = shift;
my $n;
return '\\' if $c eq '\\';
return $q if $c eq $q;
return "\\$c";
}
# Parse a quoted string
sub parse_quoted {
my $o = shift;
my $raw = shift;
my $quote = shift;
my $i=1;
my $string = '';
my $c;
while($i <= length($raw) and ($c=substr($raw, $i, 1)) ne $quote) {
if ($c eq '\\') {
$string .= $o->process_esc(substr($raw, $i+1, 1), $quote);
$i++;
}
else {
$string .= substr($raw, $i, 1);
}
$i++;
}
return ($string, $i);
};
sub line {
my $o = shift;
$o->{line}
}
sub line_args {
my $o = shift;
my $line = shift || $o->line;
$o->line_parsed($line);
$o->{line_args} || '';
}
sub line_parsed {
my $o = shift;
my $args = shift || $o->line || return ();
my @args;
# Parse an array of arguments. Whitespace separates, unless quoted.
my $arg = undef;
$o->{line_args} = undef;
for(my $i=0; $i<length($args); $i++) {
my $c = substr($args, $i, 1);
if ($c =~ /\S/ and @args == 1) {
$o->{line_args} ||= substr($args, $i);
}
if ($c =~ /['"]/) {
my ($str, $n) = $o->parse_quoted(substr($args,$i),$c);
$i += $n;
$arg = (defined($arg) ? $arg : '') . $str;
}
# We do not parse outside of strings
# elsif ($c eq '\\') {
# $arg = (defined($arg) ? $arg : '')
# . $o->process_esc(substr($args,$i+1,1));
# $i++;
# }
elsif ($c =~ /\s/) {
push @args, $arg if defined $arg;
$arg = undef
}
else {
$arg .= substr($args,$i,1);
}
}
push @args, $arg if defined($arg);
return @args;
}
sub handler {
my $o = shift;
my ($command, $type, $args, $preserve_args) = @_;
# First try finding the standard handler, then fallback to the
# catch_$type method. The columns represent "action", "type", and "push",
# which control whether the name of the command should be pushed onto the
# args.
my @tries = (
[$command, $type, 0],
[$o->cmd_prefix . $type . $o->cmd_suffix, 'catch', 1],
);
# The user can control whether or not to search for "unique" matches,
# which means calling $o->possible_actions(). We always look for exact
# matches.
my @matches = qw(exact_action);
push @matches, qw(possible_actions) if $o->{API}{match_uniq};
for my $try (@tries) {
my ($cmd, $type, $add_cmd_name) = @$try;
for my $match (@matches) {
my @handlers = $o->$match($cmd, $type);
next unless @handlers == 1;
unshift @$args, $command
if $add_cmd_name and not $preserve_args;
return $o->unalias($handlers[0], $type)
}
}
return undef;
}
sub completions {
my $o = shift;
my $action = shift;
my $compls = shift || [];
my $casei = shift;
$casei = $o->{API}{case_ignore} unless defined $casei;
$casei = $casei ? '(?i)' : '';
return grep { $_ =~ /$casei^\Q$action\E/ } @$compls;
}
#=============================================================================
# Term::Shell error messages
#=============================================================================
sub msg_ambiguous_cmd {
my ($o, $cmd, @c) = @_;
local $" = "\n\t";
<<END;
Ambiguous command '$cmd': possible commands:
@c
END
}
sub msg_unknown_cmd {
my ($o, $cmd) = @_;
<<END;
Unknown command '$cmd'; type 'help' for a list of commands.
END
}
#=============================================================================
# Term::Shell private methods
#=============================================================================
sub do_action {
my $o = shift;
my $cmd = shift;
my $args = shift || [];
my $type = shift || 'run';
my ($fullname, $cmdname, $handler) = $o->handler($cmd, $type, $args);
$o->{command}{$type} = {
cmd => $cmd,
name => $cmd,
found => defined $handler ? 1 : 0,
cmdfull => $fullname,
cmdreal => $cmdname,
handler => $handler,
};
if (defined $handler) {
# We've found a handler. Set up a value which will call the postcmd()
# action as the subroutine leaves. Then call the precmd(), then return
# the result of running the handler.
$o->precmd(\$handler, \$cmd, $args);
my $postcmd = Term::Shell::OnScopeLeave->new(sub {
$o->postcmd(\$handler, \$cmd, $args);
});
return $o->$handler(@$args);
}
}
sub uniq {
my $o = shift;
my %seen;
$seen{$_}++ for @_;
my @ret;
for (@_) { push @ret, $_ if $seen{$_}-- == 1 }
@ret;
}
sub possible_actions {
my $o = shift;
my $action = shift;
my $type = shift;
my $casei = $o->{API}{case_ignore} ? '(?i)' : '';
my @keys = grep { $_ =~ /$casei^\Q$action\E/ }
grep { exists $o->{handlers}{$_}{$type} }
keys %{$o->{handlers}};
return @keys;
}
sub exact_action {
my $o = shift;
my $action = shift;
my $type = shift;
my $casei = $o->{API}{case_ignore} ? '(?i)' : '';
my @key = grep { $action =~ /$casei^\Q$_\E$/ }
grep { exists $o->{handlers}{$_}{$type} }
keys %{$o->{handlers}};
return () unless @key == 1;
return $key[0];
}
sub is_alias {
my $o = shift;
my $action = shift;
exists $o->{handlers}{$action}{alias} ? 1 : 0;
}
sub has_aliases {
my $o = shift;
my $action = shift;
my @a = $o->get_aliases($action);
@a ? 1 : 0;
}
sub get_aliases {
my $o = shift;
my $action = shift;
my @a = eval {
my $hndlr = $o->{handlers}{$action}{alias};
return () unless $hndlr;
$o->$hndlr();
};
$o->{aliases}{$_} = $action for @a;
@a;
}
sub unalias {
my $o = shift;
my $cmd = shift; # i.e 'foozle'
my $type = shift; # i.e 'run'
return () unless $type;
return ($cmd, $cmd, $o->{handlers}{$cmd}{$type})
unless exists $o->{aliases}{$cmd};
my $alias = $o->{aliases}{$cmd};
# I'm allowing aliases to call handlers which have been removed. This
# means I can set up an alias of '!' for 'shell', then delete the 'shell'
# command, so that you can only access it through '!'. That's why I'm
# checking the {handlers} entry _and_ building a string.
my $handler = $o->{handlers}{$alias}{$type} || "${type}_${alias}";
return ($cmd, $alias, $handler);
}
sub find_handlers {
my $o = shift;
my $pkg = shift || $o->{API}{class};
# Find the handlers in the given namespace:
my %handlers;
{
no strict 'refs';
my @r = keys %{ $pkg . "::" };
$o->add_handlers(@r);
}
# Find handlers in its base classes.
{
no strict 'refs';
my @isa = @{ $pkg . "::ISA" };
for my $pkg (@isa) {
$o->find_handlers($pkg);
}
}
}
sub rl_complete {
my $o = shift;
my ($word, $line, $start) = @_;
# If it's a command, complete 'run_':
if ($start == 0 or substr($line, 0, $start) =~ /^\s*$/) {
my @compls = $o->complete('', $word, $line, $start);
return @compls if $o->{command}{comp}{found};
}
# If it's a subcommand, send it to any custom completion function for the
# function:
else {
my $command = ($o->line_parsed($line))[0];
my @compls = $o->complete($command, $word, $line, $start);
return @compls if $o->{command}{comp}{found};
}
()
}
#=============================================================================
# Two action handlers provided by default: help and exit.
#=============================================================================
sub smry_exit { "exits the program" }
sub help_exit {
<<'END';
Exits the program.
END
}
sub run_exit {
my $o = shift;
$o->stoploop;
}
sub smry_help { "prints this screen, or help on 'command'" }
sub help_help {
<<'END'
Provides help on commands...
END
}
sub comp_help {
my ($o, $word, $line, $start) = @_;
my @words = $o->line_parsed($line);
return []
if (@words > 2 or @words == 2 and $start == length($line));
sort $o->possible_actions($word, 'help');
}
sub run_help {
my $o = shift;
my $cmd = shift;
if ($cmd) {
my $txt = $o->help($cmd, @_);
if ($o->{command}{help}{found}) {
$o->page($txt)
}
else {
my @c = sort $o->possible_actions($cmd, 'help');
if (@c and $o->{API}{match_uniq}) {
local $" = "\n\t";
print <<END;
Ambiguous help topic '$cmd': possible help topics:
@c
END
}
else {
print <<END;
Unknown help topic '$cmd'; type 'help' for a list of help topics.
END
}
}
}
else {
print "Type 'help command' for more detailed help on a command.\n";
my (%cmds, %docs);
my %done;
my %handlers;
for my $h (keys %{$o->{handlers}}) {
next unless length($h);
next unless grep{defined$o->{handlers}{$h}{$_}} qw(run smry help);
my $dest = exists $o->{handlers}{$h}{run} ? \%cmds : \%docs;
my $smry = do { my $x = $o->summary($h); $x ? $x : "undocumented" };
my $help = exists $o->{handlers}{$h}{help}
? (exists $o->{handlers}{$h}{smry}
? ""
: " - but help available")
: " - no help available";
$dest->{" $h"} = "$smry$help";
}
my @t;
push @t, " Commands:\n" if %cmds;
push @t, scalar $o->format_pairs(
[sort keys %cmds], [map {$cmds{$_}} sort keys %cmds], ' - ', 1
);
push @t, " Extra Help Topics: (not commands)\n" if %docs;
push @t, scalar $o->format_pairs(
[sort keys %docs], [map {$docs{$_}} sort keys %docs], ' - ', 1
);
$o->page(join '', @t);
}
}
sub run_ { }
sub comp_ {
my ($o, $word, $line, $start) = @_;
my @comp = grep { length($_) } sort $o->possible_actions($word, 'run');
return @comp;
}
package Term::Shell::OnScopeLeave;
use vars qw($VERSION);
$VERSION = '0.04';
sub new {
return bless [@_[1 .. $#_]], ref($_[0]) || $_[0];
}
sub DESTROY {
my $o = shift;
for my $c (@$o) {
$c->();
}
return;
}
1;