File Coverage

blib/lib/Shell/Base.pm

Criterion	Covered	Total	%
statement	176	257	68.4
branch	45	78	57.6
condition	14	31	45.1
subroutine	36	50	72.0
pod	24	34	70.5
total	295	450	65.5

package Shell::Base;

# ----------------------------------------------------------------------
# Shell::Base - A generic class to build line-oriented command interpreters.
# $Id: Base.pm,v 1.5 2004/08/26 20:01:47 dlc Exp $
# ----------------------------------------------------------------------
# Copyright (C) 2003 darren chamberlain
#
# This module is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
# ----------------------------------------------------------------------

use strict;
use vars qw( $VERSION $REVISION $PROMPT
             $RE_QUIT $RE_HELP $RE_SHEBANG
            );

use Carp qw(carp croak);
use Env qw($PAGER $SHELL $COLUMNS);
use IO::File;
use File::Basename qw(basename);
use Term::Size qw(chars);
use Text::Shellwords qw(shellwords);

$VERSION      = 0.05;   # $Date: 2004/08/26 20:01:47 $
$REVISION     = sprintf "%d.%02d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/;
$RE_QUIT      = '(?i)^\s*(exit|quit|logout)' unless defined $RE_QUIT;
$RE_HELP      = '(?i)^\s*(help|\?)'          unless defined $RE_HELP;
$RE_SHEBANG   = '^\s*!\s*$'                  unless defined $RE_SHEBANG;

# ----------------------------------------------------------------------
# import()
#
# The default import method, called when the class is use'd.  This
# sets the default prompt, which can be overridden by a subclass as
# necessary.
#
# There is a pseudo-function called "shell" that can be imported by
# classes which use a Shell::Base-originated class:
#
#   use My::Shell qw(shell);
#
#   shell();
#
# Tests: t/import.t
# ----------------------------------------------------------------------
sub import {
    my $class = shift;

    if (@_ && grep /^shell$/, @_) {
        # Requested as use Shell::Base qw(shell), or
        # from the command line as -MShell::Base=shell
        # Install the shell function into the caller's
        # namespace.  However, there is no shell
        # function; we create one here.  shell would
        # be invoked by the caller as:
        #
        #   shell(@args);
        #
        # i.e., without a package, so we need to pass
        # a package in.  A closure will do nicely.

        no strict qw(refs);
        my $caller = caller;
        *{"$caller\::shell"} = sub {
            $class->new(@_)->run();
        };
    }

    $PROMPT = "($class) \$ " unless defined $PROMPT;
}

# ----------------------------------------------------------------------
# new(\%args)
#
# Basic constructor.
#
# new() calls initialization methods:
#
#   - init_rl
#
#     o Initializes the Term::ReadLine instance
#
#   - init_rcfiles
#
#     o Initializes rc files (anything in RCFILES)
#
#   - init_help
#
#     o Initializes the list of help methods
#
#   - init_completions
#
#     o Initializes the list of tab-completable commands
#
#   - init
#
#     o Subclass-specific intializations.
#
# Tests: t/new.t
#        All tests instantiate objects, so new is tested indirectly
#        by all tests.
# ----------------------------------------------------------------------
sub new {
    my $class = shift;
    my $args  = UNIVERSAL::isa($_[0], 'HASH') ? shift : { @_ };

    my @size = chars();
    my $self  = bless {
        ARGS        => $args,
        COMPLETIONS => undef,           # tab completion
        CONFIG      => { },
        HELPS       => undef,           # help methods
        HISTFILE    => undef,           # history file
        PAGER       => undef,           # pager
        PROMPT      => $PROMPT,         # default prompt
        TERM        => undef,           # Term::ReadLine instance
        SIZE        => \@size,          # Terminal size
        COLUMNS     => $size[0],
        ROWS        => $size[1],
    } => $class;

    $self->init_rl($args);
    $self->init_rcfiles($args);
    $self->init_completions($args);
    $self->init_help($args);
    $self->init($args);

    return $self;
}

# ----------------------------------------------------------------------
# init_rl(\%args)
#
# Initialize Term::ReadLine.  Subclasses can override this method if
# readline support is not needed or wanted.
#
# Tests: t/init_rl.t
# ----------------------------------------------------------------------
sub init_rl {
    my ($self, $args) = @_;
    my ($term, $attr);

    require Term::ReadLine;
    $self->term($term = Term::ReadLine->new(ref $self));

    # Setup default tab-completion function.
    $attr = $term->Attribs;
    $attr->{completion_function} = sub { $self->complete(@_) };

    if (my $histfile = $args->{ HISTFILE }) {
        $self->histfile($histfile);
        $term->ReadHistory($histfile);
    }

    return $self;
}

# ----------------------------------------------------------------------
# init_rcfiles(\%args)
#
# Initialize rc files, which are in name = value format.  The RCFILES
# member of %args should contain a reference to a rc files.  These
# will be read in the order defined, and all elements defined within
# will be present in $self->{ CONFIG }, and accessible via $self->config.
#
# test: t/init_rcfiles.t
# XXX Refactor this into init_rcfiles and parse_rcfile!
# ----------------------------------------------------------------------
sub init_rcfiles {
    my ($self, $args) = @_;
    my (@rcfiles, $rcfile);

    return unless defined $args->{ RCFILES };

    # Ensure we have an array
    $args->{ RCFILES } = [ $args->{ RCFILES } ]
        unless ref($args->{ RCFILES }) eq 'ARRAY';

    @rcfiles = @{ $args->{ RCFILES } };

    for $rcfile (@rcfiles) {
        _merge_hash($self->{ CONFIG },
             scalar $self->parse_rcfile($rcfile));
    }
}

# ----------------------------------------------------------------------
# parse_rcfile($filename)
#
# Parses a config file, and returns a hash of config values.
#
# test: t/parse_rcfile.t
# ----------------------------------------------------------------------
sub parse_rcfile {
    my ($self, $rcfile) = @_;
    my %config = ();

    my $buffer = "";
    my $rc = IO::File->new($rcfile)
        or next;

    while (defined(my $line = <$rc>)) {
        chomp $line;
        $line =~ s/#.*$//;

        if (length $buffer && length $line) {
            $line = $buffer . $line;
        }

        # Line continuation
        if ($line =~ s/\\$//) {
            $buffer = $line;
            next;
        } else {
            $buffer = '';
        }

        next unless length $line;

        my ($name, $value) = $line =~ /^\s*(.*?)\s*(?:=>?\s*(.*))?$/;
        $name = lc $name;
        unless (defined $value) {
            if ($name =~ s/^no//) {
                $value = 0;
            }
            else {
                $value = 1;
            }
        }
        $config{ $name } = $value;
    }

    return wantarray ? %config : \%config;
}

# ----------------------------------------------------------------------
# init_help()
#
# Initializes the internal HELPS list, which is a list of all the
# help_foo methods defined within the current class, and all the
# classes from which the current class inherits from.
#
# Tests: t/init_help.t
# ----------------------------------------------------------------------
sub init_help {
    my $self = shift;
    my $class = ref $self || $self;
    my %uniq = ();

    no strict qw(refs);
    $self->helps(
        grep { ++$uniq{$_} == 1 }
        map { s/^help_//; $_ }
        grep /^help_/,
        map({ %{"$_\::"} } @{"$class\::ISA"}),
        keys  %{"$class\::"});
}

# ----------------------------------------------------------------------
# init_completions()
#
# Initializes the internal COMPLETIONS list, which is used by the
# complete method, which is, in turn, used by Term::ReadLine to
# do tab-compleion.
#
# Tests: t/init_completions.t
# ----------------------------------------------------------------------
sub init_completions {
    my $self = shift;
    my $class = ref $self || $self;
    my %uniq = ();

    no strict qw(refs);
    $self->completions(
        sort
        "help",
        grep { ++$uniq{$_} == 1 }
        map { s/^do_//; $_ }
        grep /^do_/,
        map({ %{"$_\::"} } @{"$class\::ISA"}),
        keys  %{"$class\::"});
}

# ----------------------------------------------------------------------
# init(\%args)
#
# Basic init method; subclasses can override this as needed.  This is
# the place to do any subclass-specific initialization.
#
# Command completion is initialized here, so subclasses should call
# $self->SUPER::init(@_) within overridden init methods if they want
# this completion to be setup.
#
# Tests: none (why?)
# ----------------------------------------------------------------------
sub init {
    my ($self, $args) = @_;

    return $self;
}

# ----------------------------------------------------------------------
# run()
#
# run is the main() of the interpreter.  Its duties are:
#
#   - Print the results of $self->intro(), if defined,
#     via $self->print()
#
#   - Get a line of input, via $self->term->readline.
#     This begins the run loop.
#
#     o Pass this line to $self->precmd for massaging
#
#     o Pass this line to $self->parseline for splitting into
#       (command_name, variable assignments, arguments)
#
#     o Check contents of command_name; there are a few special
#       cases:
#
#         + If the line is a help line (matches $RE_HELP), then
#           call $self->help(@args)
#
#         + If the line is a quit line (matches $RE_QUIT), then
#           call $self->quit()
#
#         + If the line is a bang (matches $RE_SHEBANG), then
#           invoke $self->do_shell()
#
#         + Otherwise, attempt to invoke $self->do_$command_name
#
#     o The output from whichever of the above is chosen will be
#       passed to $self->postcmd for final processing
#
#     o If the output from $self->postcmd is not undefined, it
#       will be printed via $self->print()
#
#     o The prompt is reset, and control returns to the top of
#       the run loop.
#
# Tests: none (Dunno how, without requiring Expect (yuck))
# ----------------------------------------------------------------------
sub run {
    my $self = shift;
    my ($prompt, $blurb);

    $prompt = $self->prompt;
    $blurb = $self->intro;


    if (defined $blurb) {
        chomp $blurb;
        $self->print("$blurb\n");
    }

    while (defined (my $line = $self->readline($prompt))) {
        my (@args, $cmd, $env, $output);

        $line = $self->precmd($line);

        ($cmd, $env, @args) = $self->parseline($line);
        local %ENV = (%ENV, %$env);

        if (! length($cmd)) {
            $output = $self->emptycommand();
        }
        elsif ($cmd =~ /$RE_HELP/) {
            $output = $self->help(@args);
        }
        elsif ($cmd =~ /$RE_QUIT/) {
            $self->quit;
        }
        else {
            if ($cmd =~ /$RE_SHEBANG/) {
                $cmd = "shell";
            }
            eval {
                my $meth = "do_$cmd";
                $output = $self->$meth(@args);
            };
            if ($@) {
                $output = sprintf "%s: Bad command or filename", $self->progname;
                my $err = $@;
                chomp $err;
                warn "$output ($err)\n";
                eval {
                    $output = $self->default($cmd, @args);
                };
            }
        }

        $output = $self->postcmd($output);
        $output =~ s/\n*$//;

        chomp $output;
        $self->print("$output\n") if defined $output;

        # In case precmd or postcmd modified the prompt,
        # we recollect it before displaying it.
        $prompt = $self->prompt();
    }

    $self->quit();
}

# ----------------------------------------------------------------------
# readline()
#
# Calls readline on the internal Term::ReadLine instance.  Provided
# as a separate method within Shell::Base so that subclasses which
# do not want to use Term::ReadLine don't have to.
#
# Tests: none (how?)
# ----------------------------------------------------------------------
sub readline {
    my ($self, $prompt) = @_;
    return $self->term->readline($prompt);
}

# ----------------------------------------------------------------------
# print(@data)
#
# This method is here to that subclasses can redirect their output
# stream without having to do silly things like tie STDOUT (although
# they still can if they want, by overriding this method).
#
# Tests: none
# ----------------------------------------------------------------------
sub print {
    my ($self, @stuff) = @_;
    my $OUT = $self->term->Attribs->{'outstream'};

    CORE::print $OUT @stuff;
}

# ----------------------------------------------------------------------
# quit([$status])
#
# Exits the interpreter with $status as the exit status (0 by default).
# If $self->outro() returns a defined value, it is printed here.
#
# Tests: none
# ----------------------------------------------------------------------
sub quit {
    my ($self, $status) = @_;
    $status = 0 unless defined $status;

    my $blurb = $self->outro();
    $self->print("$blurb\n") if defined $blurb;

    if (my $h = $self->histfile) {
        # XXX Can this be better encapsulated?
        $self->term->WriteHistory($h);
    }

    exit($status);
}


# ----------------------------------------------------------------------
# precmd($line)
#
# This is called immediately before parseline(), to give the subclass
# first crack at manipulating the input line.  This might be a good
# place to do, for example, tilde-expansion, or some other kind of
# variable pre-processing.
#
# Tests: t/pre,postcmd.t
# ----------------------------------------------------------------------
sub precmd {
    my ($self, $line) = @_;
    return $line;
}

# ----------------------------------------------------------------------
# postcmd($output)
#
# This is called immediately before $output is passed to print, to
# give the class one last chance to manipulate the text before it is
# sent to the output stream.
#
# Tests: t/pre,postcmd.t
# ----------------------------------------------------------------------
sub postcmd {
    my ($self, $output) = @_;
    return $output;
}

# ----------------------------------------------------------------------
# default($cmd, @args)
#
# What to do by default, i.e., when there is no matching do_foo method.
#
# Tests: t/default.t
# ----------------------------------------------------------------------
sub default {
    my ($self, $cmd, @args) = @_;
    my $class = ref $self || $self;
    return "$class->$cmd(@args) called, but do_$cmd is not defined!";
}

# ----------------------------------------------------------------------
# emptycommand()
#
# What to do when an empty command is issued
# ----------------------------------------------------------------------
sub emptycommand {
    my $self = shift;
    return;
}

# ----------------------------------------------------------------------
# prompt_no()
#
# Returns the command number in the history.
#
# Tests: t/prompt_no.t
# ----------------------------------------------------------------------
sub prompt_no {
    my $self = shift;
    return $self->term->where_history();
}

# -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
# Some general purpose methods.  Subclasses may wish to override some
# of these, but many of them (version, progname) are probably ok as is.
# -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

# ----------------------------------------------------------------------
# version()
#
# Returns the version number.
# ----------------------------------------------------------------------
sub version {
    return $VERSION;
}

# ----------------------------------------------------------------------
# do_version()
#
# Example command method.
#
# Tests: t/version.t
# ----------------------------------------------------------------------
sub do_version {
    my $self = shift;
    return sprintf "%s v%s", $self->progname, $self->version;
}

sub help_version {
    return "Display the version."
}

# ----------------------------------------------------------------------
# progname()
#
# Returns the name of the program in question.  Defaults to
# basename($0) or the classname of the caller.
#
# Tests: t/progname.t
# ----------------------------------------------------------------------
sub progname {
    my $self = shift;
    return basename($0) || ref $self || $self;
}

# ----------------------------------------------------------------------
# intro()
#
# Introduction text, printed when the interpreter starts up.  The
# default is to print the GPL-recommended introduction.  I would
# hope that modules that utilize Shell::Base would create intro()
# methods that incorporate this, if possible:
#
#   sub intro {
#       my $self = shift;
#       my $default_intro = $self->SUPER::intro();
#
#       return "My Intro\n$default_intro";
#   }
#
# Tests: t/intro.t
# ----------------------------------------------------------------------
sub intro {
    # No default intro
    return ""
}

# ----------------------------------------------------------------------
# outro()
#
# Similar to intro(), but called from within quit(), immediately
# before exit is called.
#
# Tests: t/outro.t
# ----------------------------------------------------------------------
sub outro {
    my $self = shift;
    return sprintf "Thanks for using %s!", $self->progname;
}

# ----------------------------------------------------------------------
# parseline($line)
#
# parseline splits a line into three components:
#
#    1. Command
#
#    2. Environment variable additions
#
#    3. Arguments
#
# returns an array that looks like:
#
#   ($cmd, \%env, @args)
#
# %env comes from environment variable assignments that occur at
# the beginning of the line:
#
#   FOO=bar cmd opt1 opt2
#
# In this case $env{FOO} = "bar".
#
# This parseline method doesn't handle pipelines gracefully; pipes
# ill treated like any other token.
#
# Tests: t/parseline.t
# ----------------------------------------------------------------------
sub parseline {
    my ($self, $line) = @_;
    my ($cmd, %env, @args);

    @args = shellwords($line);
    %env = ();

    while (@args) {
        if ($args[0] =~ /=/) {
            my ($n, $v) = split /=/, shift(@args), 2;
            $env{$n} = $v || "";
        }
        else {
            $cmd = shift @args;
            last;
        }
    }

    return (($cmd or ""), \%env, @args);
}

# -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
# Generic accessors
# -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

# ----------------------------------------------------------------------
# args([$arg])
#
# Returns the hash ref of configuration arguments.  If passed a single
# value, then that configuration value will be returned.
#
# Tests: t/args.t
# ----------------------------------------------------------------------
sub args {
    my $self = shift;
    if (@_) {
        return $self->{ ARGS }->{ $_[0] }
            || $self->{ ARGS }->{ uc $_[0] };
    }
    return $self->{ ARGS };
}

# ----------------------------------------------------------------------
# config([$arg])
#
# Returns the hash reference of configuration parameters read from
# the rc file(s).
#
# Tests: t/init_rcfiles.t
# ----------------------------------------------------------------------
sub config {
    my $self = shift;
    if (@_) {
        return $self->{ CONFIG }->{ $_[0] };
    }
    return $self->{ CONFIG };
}


# ----------------------------------------------------------------------
# term()
#
# Returns the Term::ReadLine instance.  Useful if the subclass needs
# do something like modify attributes on the instance.
#
# Tests: t/term.t
# ----------------------------------------------------------------------
sub term {
    my $self = shift;
    $self->{ TERM } = shift if (@_);
    return $self->{ TERM };
}

# ----------------------------------------------------------------------
# histfile([$histfile])
#
# Gets/set the history file.
#
# Tests: t/histfile.t
# ----------------------------------------------------------------------
sub histfile {
    my $self = shift;
    $self->{ HISTFILE } = shift if (@_);
    return $self->{ HISTFILE };
}


# ----------------------------------------------------------------------
# prompt([$prompt[, @args]])
#
# The prompt can be modified using this method.  For example, multiline
# commands (which much be handled by the subclass) might modify the
# prompt, e.g., PS1 and PS2 in bash.  If $prompt is a coderef, it is
# executed with $self and @args:
#
#   $self->{ PROMPT } = &$prompt($self, @args);
#
# Tests: t/prompt.t
# ----------------------------------------------------------------------
sub prompt {
    my $self = shift;
    if (@_) {
        my $p = shift;
        if (ref($p) eq 'CODE') {
            $self->{ PROMPT } = &$p($self, @_);
        }
        else {
            $self->{ PROMPT } = $p;
        }
    }
    return $self->{ PROMPT };
}

# ----------------------------------------------------------------------
# pager([$pager])
#
# It is possible that each time through the loop in run() might need
# to be passed through a pager; this method exists to figure out what
# that pager should be.
#
# Tests: t/pager.t
# ----------------------------------------------------------------------
sub pager {
    my $self = shift;

    if (@_) {
        $self->{ PAGER } = shift;
    }

    unless (defined $self->{ PAGER }) {
        $self->{ PAGER } = $PAGER || "less";
        $self->{ PAGER } = "more" unless -x $self->{ PAGER };
    }

    return $self->{ PAGER };
}


# ----------------------------------------------------------------------
# help([$topic[, @args]])
#
# Displays help. With $topic, it attempts to call $self->help_$topic,
# which is expected to return a string.  Without $topic, it lists the
# available help topics, which is a list of methods that begin with
# help_; these names are massaged with s/^help_// before being displayed.
# ----------------------------------------------------------------------
sub help {
    my ($self, $topic, @args) = @_;
    my @ret;

    if ($topic) {
        if (my $sub = $self->can("help_$topic")) {
            push @ret,  $self->$sub(@_);
        }
        else {
            push @ret,
                "Sorry, no help available for `$topic'.";
        }
    }

    else {
        my @helps = $self->helps;
        if (@helps) {
            push @ret,
                "Help is available for the following topics:",
                "===========================================",
                map({ "  * $_" } @helps),
                "===========================================";
        }
        else {
            my $me = $self->progname;
            push @ret, "No help available for $me.",
                    "Please complain to the author!";
        }
    }

    return join "\n", @ret;
}


# ----------------------------------------------------------------------
# helps([@helps])
#
# Returns or sets a list of possible help functions.
# ----------------------------------------------------------------------
sub helps {
    my $self = shift;

    if (@_) {
        $self->{ HELPS } = \@_;
    }

    return @{ $self->{ HELPS } };
}

# ----------------------------------------------------------------------
# complete(@_)
#
# Command completion -- this method is designed to be assigned as:
#
#   $term->Attribs->{completion_function} = sub { $self->complete(@_) };
#
# Note the silly setup -- it will be called as a function, without
# any references to $self, so we need to force $self into the equation
# using a closure.
# ----------------------------------------------------------------------
sub complete {
    my ($self, $word, $line, $pos) = @_;
    #warn "Completing '$word' in '$line' (pos $pos)";

    # This is grossly suboptimal, and only completes on
    # defined keywords.  A better idea is to:
    #  1. If subtr($line, ' ') is less than $pos,
    #     then we are completing a command
    #     (the current method does this correctly)
    #  2. Otherwise, we are completing something else.
    #     By default, this should defer to regular filename
    #     completion.
    return grep { /$word/ } $self->completions;
}

sub completions {
    my $self = shift;

    if (@_) {
        $self->{ COMPLETIONS } = \@_;
    }

    return @{ $self->{ COMPLETIONS } };
}

# ----------------------------------------------------------------------
# _do_shell
#
# An example do_shell method.  This can be used in subclasses like:
# sub do_shell { shift->_do_shell(@_) }
# ----------------------------------------------------------------------
sub _do_shell {
    my ($self, @args) = @_;
    my $sh = $SHELL || '/bin/sh';

    unless (system($sh, @args) == 0) {
        carp "Problem executing $sh: $!";
    }

    # No return value!
    return;
}

# ----------------------------------------------------------------------
# An example predefined command: warranty.  This also,
# incidentally, fulfills the GPL recommended requirements.
# ----------------------------------------------------------------------
sub do_warranty {
    my $self = shift;

    require Text::Wrap;
    # To prevent "used only once" warnings.
    local $Text::Wrap::columns =
          $Text::Wrap::columns = $COLUMNS || '72';

    return Text::Wrap::wrap('', '', sprintf
'Because %s is licensed free of charge, there is no warranty for the ' .
'program, to the extent permitted by applicable law.  Except when ' .
'otherwise stated in writing the copyright holders and/or other parties ' .
'provide the program "as is" without warranty of any kind, either ' .
'expressed or implied, including, but not limited to, the implied ' .
'warranties of merchantability and fitness for a particular purpose. ' .
'The entire risk as to the quality and performance of the program is ' .
'with you.  Should the program prove defective, you assume the cost of ' .
'all necessary servicing, repair or correction.', $self->progname);
}

# Helper function
sub _merge_hash {
    my ($merge_to, $merge_from) = @_;
    $merge_to->{$_} = $merge_from->{$_}
        for keys %$merge_from;
}

__END__