File Coverage

blib/lib/Term/Shell/MultiCmd.pm

Criterion	Covered	Total	%
statement	143	360	39.7
branch	43	246	17.4
condition	22	114	19.3
subroutine	25	50	50.0
pod	10	10	100.0
total	243	780	31.1

package Term::Shell::MultiCmd;

use warnings;
use strict;
use Carp ;

=head1 NAME

Term::Shell::MultiCmd -  Nested Commands Tree in Shell Interface

=cut

our $VERSION = '2.03';

=head1 SYNOPSIS

    # Examples are available with the distribution, under directory 'examples/'
    # This one is named examples/synopsis.pl

    use Term::Shell::MultiCmd;
    my @command_tree =
     ( 'multi word command' =>
             { help => "Help title.",
               opts => 'force repeat=i',
               exec => sub {
                   my ($o, %p) = @_ ;
                   print "$p{ARG0} was called with force=$p{force} and repeat=$p{repeat}\n"
               },
             },
       'multi word another command' =>
             { help => 'Another help title.
  Help my have multi lines, the top one
  would be used when one linear needed.',
               comp => sub {
                   # this function would be called when use hits tab completion at arguments
                   my ($o, $word, $line, $start, $op, $opts) = @_ ;
                   # .. do something, then
                   return qw/a list of completion words/ ;
               },
               exec => sub { my ($o, %p) = @_ ; print "$p{ARG0} was called\n"},
             },
       'multi word third command' =>
             { help => 'same idea',
               comp => [qw/a list of words/], # this is also possible
               exec => sub { my ($o, %p) = @_ ; print "$p{ARG0} was called. Isn't that fun?\n"},
             },
       'multi word' => 'You can add general help title to a path',
     ) ;

     Term::Shell::MultiCmd
      -> new()
      -> populate( @command_tree )
      -> loop ;

    print "All done, see you later\n" ;

=head1 NOTE

To get the most from a command line, it might be a good idea to get the latest versions of
Term::ReadLine and Term::ReadKey.
There are numberless ways of doing it, one of them is running 'cpan update Bundle::CPAN' (with a proper write permission).

=cut
# some of my common utility functions:
sub _params($@) {

    # convert parameter to hash table, at this point,
    # I wish perl would have followed python's function
    # parameters scheme, or made Params::Smart standard.
    # (Had anybody mentioned perl6?)

    # Note 1: this parameter processing takes time, and wouldn't
    # be a good choise for frequently called functions.

    # Note 2: as parameters are suplied by developer, a bad
    # would terminate the program - this is not a sandbox.

    my %ret ;
    my $str = shift ;
    for (split ' ', $str) {
        /(\w+)([\=\:](.*))?/ or confess "_params can only take simple instructions
like key (must be provided), or key=value (value becomes default), or key= (default empty string)
" ;
        $ret{$1} = $2 ? $3 : undef ;
    }
    # when called as OO, itemize self
    # Note: this one wouldn't work with classes (as in Term::Shell::MultiCmd -> new )
    $ret{self} = shift if $_[0] and ref $_[0] ;
    while (@_) {
        my ($k, $v) = (shift, shift) ;
        $k =~ s/^\-?\-?// unless ref $k ;
        croak "unknown parameter: '$k'\n expected params: $str\n" unless exists $ret{$k} ;
        $ret{$k} = $v ;
    } ;
    while (my ($k, $v) = each %ret) {
        croak "missing parameter: '$k'\n expected params: $str\n" unless defined $v ;
    }
    %ret
}

sub _options {
    # Parsing user's options, this function is more forgiving than _params
    my $p = shift ;
    my @p = ref $p ? @$p : split ' ', $p ;
    my %p ; # now we have a complete set

    # use Getopt::Long 'GetOptionsFromArray' ; -- didn't work as I expected ..
    use Getopt::Long ;
    local @ARGV = @_ ;
    if (@p and not eval { GetOptions( \%p, @p ) }) {
        $p{_ERR_} = "$@ Expected " . join ', ', map {/(\w+)/ ; '-' . ($1 || $_)} sort @p ;
        $p{_ERR_} .= "\n" ;
    }
    $p{ARGV} ||= [@ARGV] ; # all the leftover, in order
    %p
}

# we can't limit ourselves by 'use :5.10', not yet.
sub _say(@) { print join ('', @_) =~ /^\n*(.*?)\s*$/s, "\n" }


# module specific functions

# Important Note:
# Do manipulate $o->{delimiter} and $o->{delimiterRE} ONLY if you know what you're doing ...

sub _split($$) {
    my ($o, $l) = @_ ;
    use Text::ParseWords 'quotewords';
    # grep {defined $_ and $_ ne ''} quotewords $o->{delimiterRE} || '\s+', 0, $l
    grep {defined and length } quotewords $o->{delimiterRE} || '\s+', 0, $l
}

sub _join($@) {
    my $o = shift ;
    join $o->{delimiter} || ' ', @_
}

sub _travela($@) {              # explicit array
    my ($o) = shift ;
    my ($c, $d, @w, @path) = ($o->{root} || $o->{cmds}, $o->{delimiter} || ' ', @_ );
    while ( @w and 'HASH' eq ref $c ) {
        my $w = shift @w ;
        if (exists $c->{$w}) {
            $c = $c->{$w} ;
            push @path , $w ;# $path .= "$w ";
            next ;
        }
        my @c = grep /^$w/, keys %$c ;
        if(@c == 1) {
            $c = $c->{$c[0]} ;
            push @path, $c[0] ; # $path .= "$c[0] " ;
            next ;
        }
        if (@c > 1 ) {
            my $cmd = join $d, @path, $w ;
            return "Ambiguous command: '$cmd'\n $w could mean: @c\n" ;
        }

        # if @c == 0 : should I state the obvious? well, not with perl
        unshift @w, $w ;
        last ;
    }
    ($c, join ($d, @path), @w)
}

sub _travel($$) {
    my ($o, $c) = &_check_pager ; # clear $c pager sign, let cmd know about it.
    $c = _check_silent_aliases($o, $c);
    _travela( $o, _split $o, $c )
}

sub _expect_param_comp {
    my($o, $word, $line, $pos, $op, $opt) = @_;
    # This is ugly, Getopt::Long has many options, and
    # caller can use any of them. However, my parsing would
    # be limited.
    # print "$opt\n" ;
    my ($eq, $t) = $opt =~ /([\=\:])(\w)\W*$/ ;
    my $type = ($t ?
                $t eq 'i' ? 'Integer':
                $t eq 'o' ? 'Extended Integer':
                $t eq 's' ? 'String' :
                $t eq 'f' ? 'Real Number' :
                $t : $t ) ;
    $type = "(optional) $type" if $eq eq ':' ;
    ("$opt\nParameter Expected for -$op, type '$type'", $word)
}

my $dlm = $; ; # cache this value, in case the developer changes it on the fly.
               # Should I make it explicit '\034' value?

sub _filter($@) {
    my $w = shift ;
    my $qr = qr/^\Q$w/ ;
    grep /$qr/, sort grep {$_ ne $dlm}
      'ARRAY'  eq ref $_[0] ? @{$_[0]} :
        'HASH' eq ref $_[0] ? (keys %{$_[0]}) :
          @_   ;
}

=head1 SUBROUTINES/METHODS

=head2 new

    my $cli = new Term::Shell::MultiCmd ;
   - or -
    my $cli = Term::Shell::MultiCmd->new( [optional parameters ...] ) ;

The parameters to the constructor are passed in hash form, preceding dash is optional.

Optional Parameters for the new command:

=over 4

=item * -prompt

    my $cli = new Term::Shell::MultiCmd ( -prompt => 'myprompt') ;
- or -
    my $cli = mew Term::Shell::MultiCmd ( -prompt => \&myprompt) ;

Overwrite the default prompt 'shell'.
Rules are:

 If prompt is a CODE reference, call it in each loop cycle and display the results.
 if it ends with a non-word character, display it as is.
 Else, display it with the root-path (if exists) and '> ' characters.

=item * -help_cmd

Overwrite the default 'help' command, empty string would disable this command.

=item * -quit_cmd

Overwrite the default 'quit' command, empty string would disable this command.

=item * -root_cmd

    my $cli = new Term::Shell::MultiCmd ( -root_cmd => 'root' ) ;

This would enable the root command and set it to root.

Unlike 'quit' and 'help', the 'root' command is a little unexpected. Therefore it is disabled by default. I
strongly recommend enabling this command when implementing a big, deep command tree. This allows the user rooting
in a node, then referring to this node thereafter. After enabling, use 'help root' (or whatever names you've chosen)
for usage manual.

=item * -history_file

    my $cli = new Term::Shell::MultiCmd ( -history_file => "$ENV{HOME}/.my_progarms_data" ) ;

This is the history file name. If present, try to load history from this file just
before the loop command, and try saving history in this file after the loop command.
Default is an empty string (i.e. no history preserved between sessions). Please note that
things might get tricky if that if multiple sessions are running at the same time.

=item * -history_size

Overwrite the default 100 history entries to save in hisotry_file (if exists).

=item * -history_more

If the history_file exists, try to load this data from the file during initialization, and save it at loop end.
For Example:

   my %user_defaults ;
   my $cli = new Term::Shell::MultiCmd ( -history_file => "$ENV{HOME}/.my_saved_data",
                                         -history_size => 200,
                                         -history_more => \%user_defaults,
                                        ) ;
   # ....
   $cli -> loop ;

This would load shell's history and %user_defaults from the file .my_saved_data before the loop, and
store 200 history entries and %user_defaults in the file after the loop.

Note that the value of history_more must be a reference for HASH, ARRAY, or SCALAR. And
no warnings would be provided if any of the operations fail. It wouldn't be a good idea
to use it for sensitive data.

=item * -pager

As pager's value, this module would expect a string or a sub that returns a FileHandle. If the value is a string,
it would be converted to:

   sub { use FileHandle ; new FileHandle "| $value_of_pager" }

When appropriate, the returned file handle would be selected before user's command execution, the old
one would be restored afterward. The next example should work on most posix system:

   my $cli = new Term::Shell::MultiCmd ( -pager => 'less -rX',
                                         ...

The default pager's value is empty string, which means no pager manipulations.

=item * -pager_re

Taking after perldb, the default value is '^\|' (i.e. a regular expression that matches '|' prefix, as in
the user's command "| help"). If the value is set to an empty string, every command would trigger
the pager.

The next example would print any output to a given filehandle:

   my $ret_value ;
   my $cli = new Term::Shell::MultiCmd ( -pager => sub {
                                               open my $fh, '>', \$ret_value or die "can't open FileHandle to string (no PerlIO?)\n" ;
                                               $fh
                                          },
                                         -pager_re => '',
                                       ) ;
  # ...
  $cli -> cmd ('help -t') ;
  print "ret_value is:\n $ret_value" ;

=item * -record_cmd

If it's a function ref, call it with an echo of the user's command


   my $cli = new Term::Shell::MultiCmd ( -record_cmd => sub {
                                            my $user_cmd = shift;
                                            system "echo '$user_cmd' >> /tmp/history"
                                          }
                                       ) ;


=item * -empty_cmd

Function ref only, call it when user hits 'Return' with no command or args (not even spaces)

   my $cli = new Term::Shell::MultiCmd ( -empty_cmd => sub {
                                                # Assuming some commands are recorded in $last_repeatable_cmd
                                                if ( $last_repeatable_cmd ) {
                                                    # repeat it
                                                }
                                          }
                                       ) ;


=back

=cut

sub _new_readline($) {
    my $o = shift ;
    use Term::ReadLine;
    my $t = eval { local $SIG{__WARN__} = 'IGNORE' ;
                   Term::ReadLine->new($o->prompt)} ;
    if (not $t ) {
        die "Can't create Term::ReadLine: $@\n" if -t select ;
    }
    elsif (defined $readline::rl_completion_function) {
        $readline::rl_completion_function =
          sub { $o -> _complete_cli(@_)} ;
    }
    elsif ( defined (my $attr = $t -> Attribs())) {
        $attr->{attempted_completion_function} =
          $attr->{completion_function} =
            sub { $o -> _complete_gnu(@_) } ;
    }
    else {
        warn __PACKAGE__ . ": no tab completion support for this system. Sorry.\n" ;
    }
    $t
}

sub new {
    my $class = shift ;
    my %p = _params 'help_cmd=help quit_cmd=quit root_cmd= prompt=shell>
                     history_file= history_size=100 history_more= pager= pager_re=^\|
                     record_cmd= empty_cmd=
                     ', @_ ;

    # structure rules:
    # hash ref is a path, keys are items (commands or paths) special item $dlm is one liner help
    # array ref is command's data as [help, command, options, completion]
    #  where: first help line is the one liner, default completion might be good enough

    my $o = bless { cmds => { },
                    map {($_, $p{$_})} qw/prompt pager history_file history_size history_more
                                          help_cmd quit_cmd root_cmd pager pager_re record_cmd empty_cmd
                                         /
                  }, ref ( $class ) || $class ;

    $o -> {delimiter  } = ' '   ; # now, programmers can manipulate the next two values after creating the object,
    $o -> {delimiterRE} = '\s+' ; # but they must be smart enough to read this code. - jezra
    $o -> _root_cmds_set() ;
    # _new_readline $o unless $DB::VERSION ; # Should I add parameter to prevent it?
    #                                        # it could be useful when coder doesn't plan to use the loop
    #   - on second thought, create it when you have to.
    _last_setting_load $o ;
    $o
}

sub _root_cmds_clr($) {
    my $o = shift ;
    my $root = $o->{root};
    return unless $root and $o->{cmds} != $root ;
    for ([$o->{help_cmd}, \&_help_command],
         [$o->{quit_cmd}, \&_quit_command],
         [$o->{root_cmd}, \&_root_command],
        ) {
        delete $root->{$_->[0]} if exists $root->{$_->[0]} and $root->{$_->[0]}[1] eq $_->[1]
    }
    delete $o->{root} ;
    delete $o->{root_path} ;
}

sub _root_cmds_set($;$$) {
    my ($o, $root, $path) = @_ ;
    ($root, $o->{cmds}) = ($o->{cmds}, $root) if $root ;
    $o -> add_exec ( path => $o->{help_cmd},
                     exec => \&_help_command,
                     comp => \&_help_command_comp,
                     opts => 'recursive tree',
                     help => 'help [command or prefix]
Options:
$PATH -t --tree      : Show commands tree
$PATH -r --recursive : Show full help instead of title, recursively'
                   ) ;

    $o -> add_exec ( path => $o->{quit_cmd},
                     exec => \&_quit_command,
                     help => 'Exit this shell',
                   ) ;

    $o -> add_exec ( path => $o->{root_cmd},
                     exec => \&_root_command,
                     comp => \&_root_command_comp,
                     # opts => 'set display clear', - use its own completion
                     help => 'Execute from, or Set, the root node
Usage:
$PATH -set a path to node: set the current root at \'a path to node\'
$PATH -clear             : set the root to real root (alias to -set without parameters)
$PATH -display           : display the current root (if any)
$PATH a path to command -with options
                         : execute command from real root, options would be forwarded
                         : to the command.
'
                   ) ;
    ($o->{root}, $o->{cmds}, $o->{root_path}) = ($o->{cmds}, $root, $path) if $root ;
}

=head2 add_exec

   $cli -> add_exec ( -path => 'full command path',
                      -exec => \&my_command,
                      -help => 'some help',
                      -opts => 'options',
                      -comp => \&my_completion_function,
                    ) ;

This function adds an command item to the command tree. It is a little complicated, but useful (or so I hope).

=over

=item * -path

B
This string would be parsed as multi-words command.

Note: by default, this module expects whitespaces delimiter. If you'll read the module's code, you can find
an easy way to change it - in unlikely case you'll find it useful.

=item * -exec

B
This code would be called when the user types a unique path for this command (with optional
options and arguments). Parameters sent to this code are:

   my ($cli, %p) = @_ ;
   #  where:
   # $cli     - self object.
   # $p{ARG0} - the command's full path (user might have used partial but unique path. This is the explicit path)
   # $p{ARGV} - all user arguments, in order (ARRAY ref)
   # %p       - contains other options (see 'opts' below)

=item * -help

B
The top line would be presented when a one line title is needed (for example, when 'help -tree'
is called), the whole string would be presented as the full help for this item.

=item * -comp

B
If Array, when the user hits tab completion for this command, try to complete his input with words
from this list.
If Hash, using the hash keys as array, following the rule above.
If Code, call this function with the next parameters:

   my ($cli, $word, $line, $start) = @_ ;
   #  where:
   # $cli is the Term::Shell::MultiCmd object.
   # $word is the curent word
   # $line is the whole line
   # $start is the current location

This code should return a list of strings. Term::ReadLine would complete user's line to the longest
common part, and display the list (unless unique). In other words - it would do what you expect.

For more information, see Term::ReadLine.

=item * -opts

B
If a string, split it to words by whitespaces. Those words are parsed as
standard Getopt::Long options. For example:

     -opts => 'force name=s flag=i@'

This would populating the previously described %p hash, correspond to user command:

     shell> user command -name="Some String" -flag 2 -flag 3 -flag 4 -force


For more information, see Getopt::Long. Also see examples/multi_option.pl in distribution.

As ARRAY ref, caller can also add a complete 'instruction' after each non-flag option (i.e. an option that
expects parameters). Like the 'comp' above, this 'instruction' must be an ARRAY or CODE ref, and follow
the same roles. When omitted, a default function would be called and ask the user for input.
For example:

    -opts => [ 'verbose' =>
               'file=s'  => \&my_filename_completion,
               'level=i' => [qw/1 2 3 4/],
               'type=s'  => \%my_hash_of_types,
             ],

=back

=cut

sub add_exec {
    my $o = shift ;
    my %p = _params 'path exec help= comp= opts=', @_ ;
    return unless $p{path};     # let user's empty string prevent this command
    my $r = $o ->{cmds} ;
    my $p = '' ;
    die "command must be CODE refferance\n" unless 'CODE' eq ref $p{exec} ;
    my @w = _split $o, $p{path} ;
    my $new = pop @w or return ;
    for my $w (@w) {
        $p .= _join $o, $p, $w ;
        if ('ARRAY' eq ref $r ->{$w} ) {
            carp "Overwrite command '$p'\n" ;
            delete $r -> {$w} ;
        }
        $r = ($r->{$w} ||= {}) ;
    }
    my ($opts, %opts) = '' ;    # now calculate options
    if ($p{opts}) {
        my @opts = ref $p{opts} ? @{$p{opts}} : split ' ', $p{opts} ;
        # croak "options -opts must be ARRAY ref\n" unless 'ARRAY' eq ref $p{opts} ;
        while (@opts) {
            my $op = shift @opts ;
            croak "unexpected option completion\n" if ref $op ;
            $opts .= "$op " ;
            my $expecting = $op =~ s/[\=\:].*$// ;
            $opts{$op} = ( $expecting  ?
                           ref $opts[0] ?
                           shift @opts :
                           \&_expect_param_comp :
                           '' ) ;
        }
    }
    #                   0    1    2       3      4..
    $r->{$new} = [@p{qw/help exec comp/}, $opts, %opts]
}


=head2 add_help

Although help string can set in add_exec, this command is useful when he wishes to
add title (or hint) to a part of the command path. For example:

   # assume $cli with commands 'feature set', 'feature get', etc.
   $cli -> add_help ( -path => 'feature' ,
                      -help => 'This feature is about something') ;

=cut

sub add_help {
    my $o = shift ;
    my %p = _params "path help", @_ ;
    my ($cmd, $path, @args, $ret) = _travel $o, $p{path} ; # _split $o, $p{path} ;
    if ('HASH' eq ref $cmd) {
        for my $w (@args) {
            $cmd = ($cmd->{$w} = {});
        }
        ($ret, $cmd->{$dlm}) = ($cmd->{$dlm}, $p{help})
    }
    else {
        croak "command '$p{path}' does not exists.\n For sanity reasons, will not add help to non-existing commands\n" if @args;
        ($ret, $cmd->[0 ]) = ($cmd->[0 ], $p{help})
    }
    $ret # Was it worth the trouble?
}

=head2 populate

A convenient way to define a chain of add_exec and add_help commands. This function expects hash, where
the key is the command path and the value might be HASH ref (calling add_exec), or a string (calling add_help).
For example:

    $cli -> populate
       ( 'feature' => 'This feature is a secret',
         'feature set' => { help => 'help for feature set',
                            exec => \&my_feature_set,
                            opts => 'level=i',
                            comp => \&my_feature_set_completion_function,
                          },
         'feature get' => { help => 'help for feature get',
                            exec => \&my_feature_get
                          },
       ) ;

    # Note:
    # - Since the key is the path, '-path' is omitted from parameters.
    # - This function returns the self object, for easy chaining (as the synopsis demonstrates).

=cut

sub populate {
    my ($o, %p) = @_ ;
    while (my ($k, $v) = each %p) {
        if (not ref $v) {
            $o->add_help(-path => $k, -help => $v) ;
        }
        elsif ('HASH' eq ref $v) {
            $o->add_exec(-path => $k, %$v)
        }
        else {
            croak "unknow item for '$k': $v\n" ;
        }
    }
    $o
}

sub _last_setting_load($) {
    my $o = shift ;
    my $f = $o->{history_file} or return ;
    return unless -f $f ;
    my $d = $o->{history_more} ;
    eval {
        my $setting = eval { use Storable ; retrieve $f } ;
        return print "Failed to load configuration from $f: $@\n" if $@ ;
        my ($hist, $more) = @$setting ;
        $o->{history_data} = $hist if 'ARRAY' eq ref $hist and @$hist ;
        return unless ref $d and ref $more and ref($d) eq ref($more) ;
        %$d = %$more if 'HASH'   eq ref $d ;
        @$d = @$more if 'ARRAY'  eq ref $d ;
        $$d = $$more if 'SCALAR' eq ref $d ;
    } ;
}

sub _last_setting_save($) {
    my $o = shift ;
    my $f = $o->{history_file} or return ;
    my @his = $o -> history();
    splice @his, 0,  @his - $o->{history_size} ;
    print
      eval {use Storable ; store ([[@his], $o->{history_more}], $f)} ? # Note: For backward compatibly, this array can only grow
        "Configuration saved in $f\n" :
          "Failed to save configuration in $f: $@\n" ;
}

=head2 loop

  $cli -> loop ;

Prompt, parse, and invoke in an endless loop

('endless loop' should never be taken literally. Users quit, systems crash, universes collapse -
 and the loop reaches its last cycle)

=cut

sub loop {
    local $| = 1 ;
    my $o = shift ;

    $o-> {term} ||= _new_readline $o ;
    $o-> history($o->{history_data}) if $o->{history_data};
    while ( not $o -> {stop} and
            defined (my $line = $o->{term}->readline($o->prompt)) ) {
        $o->cmd( $line ) ;
    }
    _last_setting_save $o ;
}

sub _complete_gnu {
    my($o, $text, $line, $start, $end) = @_;
    $text, &_complete_cli       # apparently, this should work
}

sub _complete_cli {
    my($o, $word, $line, $start) = @_;
    #   1. complete command
    #   2. if current word starts with '-', complete option
    #   3. if previous word starts with '-', try arg completion
    #   4. try cmd completion (should it overwrite 3 for default _expect_param_comp?)
    #   5. show help, keep the line

    # my @w = _split $o ,        # should I ignore the rest of the line?
    #   substr $line, 0, $start ; # well, Term::ReadLine expects words list.

    my ($cmd, $path, @args) = _travel $o, substr $line, 0, $start ; # @w ;
    return ($cmd, $word) unless ref $cmd ;
    return (@args ? "\a" : _filter $word, $cmd) if 'HASH' eq ref $cmd ;

    my ($help, $exec, $comp, $opts, %opts) = @{ $cmd } ; # avoid confusion
    return &_root_command_comp if $comp and $comp == \&_root_command_comp ; # very special case: root 'imports' its options.
    return map {"$1$_"} _filter $2,\%opts if $word =~ /^(\-\-?)(.*)/ ;
    if ( @args and $args[-1] =~ /^\-\-?(.*)/) {
        my ($op, @op) = _filter $1, \%opts ;
        return ("Option $args[-1] is ambiguous: $op @op?", $word) if @op ;
        return ("Option $args[-1] is unknown", $word) unless $op ;
        my $cb = $opts{$op} ;
        return _filter $word, $cb if 'ARRAY' eq ref $cb or 'HASH' eq ref $cb ;
        return $cb->($o, $word, $line, $start, $op, $opts =~ /$op(\S*)/ ) if 'CODE' eq ref $cb ;
    }
    return _filter $word, $comp if 'ARRAY' eq ref $comp or 'HASH' eq ref $comp ;
    return $comp->($o, $word, $line, $start) if 'CODE' eq ref $comp ;
    return ($help, $word)       # so be it
}

sub _help_message_tree {        # inspired by Unix 'tree' command
                                # Should I add ANSI colors?
    my ($h, $cmd, $pre, $last) = @_ ;
    print $pre . ($last ? '`' : '|') if $pre ;
    return _say "- $cmd : ", $h->[0] =~ /^(.*)/m if 'ARRAY' eq ref $h ;
    _say "-- $cmd" ;
    my @c = sort keys %$h ;
    for my $c (@c) {
        _help_message_tree( $h->{$c},
                            $c,
                            $pre ? $pre . ($last ? '    ' : '|   ') : ' ' ,
                            $c eq ($c[-1]||'')
                          ) unless $c eq $dlm ;
    }
}

sub _help_message {
    my $o = shift ;
    my %p = _params "node path full= recursive= tree= ARGV= ARG0=", @_ ;
    my ($h, $p) = @p{'node', 'path'} ;
    $p =~ s/^\s*(.*?)\s*$/$1/ ;
    sub _align2($$) {
        my ($a, $b) = @_;
        _say $a, (' ' x (20 - length $a)), ': ', $b
    }

    if ('ARRAY' eq ref $h) {    # simple command, full help
        my $help = $h->[0] ;
        $help =~ s/\$PATH/$p{path}/g ;
        _say "$p:\n $help" ;
        $help
    }
    elsif ('HASH' ne ref $h) {  # this one shouldn't happen
        confess "bad item in help message: $h"
    }
    elsif ($p{recursive}) {     # show everything
        my $xxx = "----------------------\n" ;
        _say $xxx, $p, ":\t", $h->{$dlm} if exists $h->{$dlm};

        for my $k (sort keys %$h) {
            next if $k eq $dlm ;
            _say $xxx ;
            _help_message( $o, %p, -node => $h->{$k}, -path => _join $o, $p, $k) ;
        }
    }
    elsif ($p{tree}) {          # tree - one linear for each one
        _help_message_tree ($h, $p)
    }
    elsif ($p{full}) {          # prefix, full list

        _say "$p:\t", $h->{$dlm} if exists $h->{$dlm} ;

        for my $k (sort keys %$h) {
            next if $k eq $dlm ;
            my ($l) = (('ARRAY' eq ref $h->{$k}) ?
                       ($h->{$k}[0]    || 'a command') :
                       ($h->{$k}{$dlm} || 'a prefix' ) ) =~ /^(.*)$/m ;
            _align2 _join($o, $p, $k), $l;
        }
    }
    else {                      # just show the prefix with optional help
        _say "$p: \t", $h->{$dlm} || 'A command prefix' ;
    }
}

sub _help_command {
    my ($o, %p) = @_ ;
    my ($cmd, $path, @args) = _travela $o, @{$p{ARGV}} ;
    return _say $cmd unless ref $cmd ;
    return _say "No such command or prefix: " . _join $o, $path, @args if @args ;
    return _help_message($o, -node => $cmd, -path => $path, -full => 1, %p) ;
}

sub _help_command_comp {
    my($o, $word, $line, $start) = @_;
    my @w = _split $o , substr $line, 0, $start ;
    shift @w ;
    my ($cmd, $path, @args) = _travela $o, grep {!/\-\-?r(?:ecursive)?|\-\-?t(?:ree)?/} @w ;
                             # potential issue: 'help -r some path' wouldn't be a valid path, is DWIM the solution?
    return ($cmd, $word) unless ref $cmd ;
    return _filter $word, $cmd if 'HASH' eq ref $cmd ;
    ('', $word)
}

sub _quit_command { $_[0]->{stop} = 1 }

sub _root_command_comp {
    my($o, $word, $line, $start) = @_;
    $line =~ s/^(\s*\S+\s*(?:(\-\-?)(\w*))?)// ; # todo: delimiterRE
    my ($prolog, $par, $param) = ($1, $2, $3) ;
    return unless $prolog ;     # error, avoid recursion
    return map {"$par$_"} _filter $param, qw/clear set display/ if $par and not $line ;
    $line =~ s/^(\s*)// ;
    $prolog .= $1 ;
    my $root = delete $o -> {root} ;
    my @res = _complete_cli($o, $word, $line, $start - length $prolog) ;
    $o->{root} = $root if $root ;
    @res
}

sub _root_command {
    # root -display   : display current path
    # root -set  path : set path
    # root -clear     : alias to root -set  (without a path)
    # root path params: execute path  from real command root

    my ($o, %p) = @_ ;
    my @argv = @{$p{ARGV}} ;
    @argv  or return $o->cmd("help $p{ARG0}") ;
    # algo: can't parse those options automaticaly, as it would prevent user's options to optional root commnad
    $argv[0] =~ /^\-\-?d/ and return _say $o->{root} ? "root is set to '$o->{root_path}'" : "root is clear." ;
    $argv[0] =~ /^\-\-?c/ and @argv = ('-set') ;
    $argv[0] =~ /^\-\-?s/ or do {
        # just do it, do it!
        my $root = delete $o->{root} ;
        my @res = $o->cmd(_join $o, @argv) ;
        $o->{root} = $root if $root ;
        return @res ;
    } ;
    shift @argv ; # -set, it is
    my ($cmd, $path, @args) ;
    if (@argv) {
        my $root = delete $o->{root} ;
        ($cmd, $path, @args) = _travela $o, @argv ;
        $o->{root} = $root if $root ;
        return _say $cmd unless ref $cmd ;
        return _say "No such prefix: " . _join $o, $path, @args if @args ;
        return _say "$path: is a command. Only a node can be set as root." if 'ARRAY' eq ref $cmd ;
    }
    if ( $o->{root}) {
        _say "clear root '$o->{root_path}'" ;
        _root_cmds_clr $o ;
    }
    if ( $cmd ) {
        _root_cmds_set $o, $cmd, $path ;
        _say "set new root: '$path'" ;
    }
}

sub _check_pager {
    my ($o, $c) = @_ ;
    my $p = $o->{pager} or return (@_, $o->{piper}=undef); # just in case programmer delete {pager} during run
    ref $p or $o->{pager} = sub { use FileHandle ; new FileHandle "| $p" };
    my $r = $o->{pager_re} ;
    !$r or ref $r or $r = do{ my $d = "$r($o->{delimiterRE})*" ; $o->{pager_re} = qr/$d/};
    $o->{piper} = !$r || $c =~ s/$r// ;
    ($o, $c)
}

sub _check_silent_aliases {
    my ($o, $cmd) = @_ ;
    return  $cmd unless $cmd;
    my $r = $o->{root} || $o->{cmds};
    my ($c, @a) = _split $o, $cmd;

    return _join $o, $o->{root_cmd}, (@a ? (-set => @a ) : ('-clear'))
      if ( $c eq 'cd' and
           $o->{root_cmd} and
           not exists $r->{cd});

    return _join $o, $o->{help_cmd}, @a
      if $o->{help_cmd} and
        ( ($c eq 'ls'   and not exists $r->{ls}  ) or
          ($c eq 'help' and not exists $r->{help}) );

    $cmd
}

=head2 cmd

 $cli -> cmd ( "help -tree" ) ;

Execute the given string parameter, similarly to user input. This one might be useful to execute
commands in a script, or testing.

=cut

sub cmd {
    my ($o, $clt) = @_;
    $o->{record_cmd}->($clt) if 'CODE' eq ref $o->{record_cmd};

    my ($cmd, $path, @args, $fh) = _travel $o, $clt or return ;
    local %SIG ;

    if ($o->{piper} and $fh = $o->{pager}->()) {
        $o->{stdout} = select ;
        select $fh ;
        $SIG{PIPE} = sub {} ;
    }

    my $res = $o->_cmd ($cmd, $path, @args) ;

    if ($fh) {
        select $o->{stdout} ;
    }
    $res
}

sub _cmd {
    my ($o, $cmd, $path, @args) = @_ ;
    return print $cmd unless ref $cmd ;
    return $o->{empty_cmd}->() if $o->{empty_cmd} and $cmd eq ($o -> {root} || $o->{cmds}) and 0 == length join '', @args;
    return _say "No such command or prefix: " . _join $o, @args if $cmd eq $o->{cmds} ;
    return _help_message($o, -node => $cmd, -path => $path) unless 'ARRAY' eq ref $cmd ; # help message
    my %p = _options $cmd->[3] || '', @args ;
    return print $p{_ERR_} if $p{_ERR_} ;
    return $cmd->[1]->($o, ARG0 => $path, %p) ;
}

=head2 command

 $cli -> command ( "help -tree") ;
Is the same as cmd, but echos the command before execution

=cut

sub command {
    my ($o, $cmd) = @_ ;
    print "$cmd ..\n" ;
    &cmd
}

=head2 complete

  my ($base_line, @word_list) = $cli -> complete ($a_line) ;

given a line, this function would return a base line (i.e. truncated to the beginning of the last word), and a list of potential
completions. Added to the 'cmd' command, this might be useful when module user implements his own 'loop' command in a non-terminal
application

=cut

sub complete {
    # line, pos ==> line, list of words
    my ($o, $line, $pos) = @_ ;
    my $lo = substr $line, $pos, -1, '' if defined $pos ;
    my $lu = $line ;
    my $qd = $o -> {delimiterRE} ;
    $lu =~ s/([^$qd]*)$// ;
    my $w = $1 ||  '' ;
    my (@list) = _complete_cli($o, $w, $line, $pos || length $lu) ;
    # if ($lu =~ /^(.*)($qd+)$/) {
    #     # this is duplicating what is done in _complete_cli, TODO: optimize
    #     my ($l, $s) = ($1, $2 ) ;
    #     my ($cmd, $path, @args) = _travel $o, $l ;
    #     $lu = "$path$s" if $path and not @args ;
    # }
    ($lu, @list)
}

=head2 prompt

  my $prompt = $cli -> prompt() ;

accepts no parameters, return current prompt.

=cut


sub prompt() {
    my $o = shift ;
    my $p = $o->{prompt} || 'shell' ;
    return $p->()  if 'CODE' eq ref $p ;
    return $p      if $p =~ /\W$/ ;
    $p .= ':' . $o->{root_path} if $o->{root_path} ;
    $p .  '> '
}

=head2 history

set/get history

  my @hist = $cli -> history() ;            # get history
  $cli -> history( @alternative_history ) ; # set history
  $cli -> history([@alternative_history]) ; # the very same, by ptr
  $cli -> history([]) ;                     # clear history

=cut

sub history {
    my $o = shift ;
    return unless $o->{term} ;
    return $o->{term}->SetHistory(map {('ARRAY' eq ref $_) ? (@$_) : ($_)} @_ ) if @_ ;
    return $o->{term}->GetHistory
}


# =head2 pager

#     my $old_pager = $o->pager($new_pager);  # set new pager
#     my $old_pager = $o->pager('') ;         # clear pager
#     my $cur_pager = $o->pager() ;           # keep current pager

# =cut

# sub pager {
#     my ($o, $new) = @_ ;
#     my $old = $o->{pager} ;
#     $o->{pager} = $new if defined $new ;
#     $old
# }

=head1 ALSO SEE

Term::ReadLine, Term::ReadKey, Getopt::Long

=head1 AUTHOR

Josef Ezra, C<<  >>

=head1 BUGS

Please report any bugs or feature requests to me, or to C, or through
the web interface at L.
I am grateful for your feedback.

=head2 TODO list

nImplement pager.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Term::Shell::MultiCmd

You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * Search CPAN

L

=back


=head1 ACKNOWLEDGMENTS

This module was inspired by the excellent modules Term::Shell, CPAN, and CPANPLUS::Shell.

=head1 LICENSE AND COPYRIGHT

Copyright 2010 Josef Ezra.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.


=cut

'end'