source: trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Cli/Base.pm @ 2267

package LATMOS::Accounts::Cli::Base;

# $Id: Cli.pm 2145 2018-08-29 18:15:46Z nanardon $

use strict;
use warnings;
use Moose;
use LATMOS::Accounts::Cli::Context;
use LATMOS::Accounts::Log;
use LATMOS::Accounts::Utils;
use Term::ReadLine;
use Text::ParseWords;
use Getopt::Long;
use Pod::Select;
use Pod::Text::Termcap;
use File::Temp;

=head1 NAME

LATMOS::Accounts::Cli - Command line interface functions

=head1 DESCRIPTION

This module handle envirronment and functons for L<la-cli> tools.

=cut

has Context => ( is => 'ro', isa => 'LATMOS::Accounts::Cli::Context' );
has Parent  => ( is => 'ro' );

=head1 FUNCTIONS

=cut

=head1 CLI FUNCTIONS

=head2 GLOBAL FUNCTIONS

=cut

sub BUILD {
    my $self = shift;

    my $OUT = $self->Context->Out;

=head3 help

    help [command] - print help about command

=cut

    $self->add_func('help', {
        completion => sub {
            if (!$_[2]) { return sort keys %{ $_[0]->{funcs} || {}} }
        },
        code => sub {
            my $env = shift;

            $env->Help(@_);
        },
    });

=head3 unexported

    unexported yes|no|show

switch or show base mode regarding' unexported objects behavior

=cut

    $self->add_func('unexported', {
        completion => sub {
            if (!$_[2]) {
                return qw(yes no show);
            }
        },
        code => sub {
            my ($self, $arg) = @_;
            if (!$arg) {
                print $OUT "Unexported objects is" . ($self->base->unexported ?
                "enable" : "disable") . "\n";
            } elsif ($arg eq 'yes') {
                $self->base->unexported(1);
                print $OUT "Unexported are now show\n";
            } elsif ($arg eq 'no') {
                $self->base->unexported(0);
                print $OUT "Unexported are no longer show\n";
            } elsif ($arg eq 'show') {
                print $OUT "Unexported objects is" . ($self->base->unexported ?
                "enable" : "disable") . "\n";
            } else {
                print $OUT "wrong argument\n";
            }
        },
    });

=head3 quit

Exit from C<CLI> tools

=cut

    $self->add_func('quit', {
            code => sub { print "\n"; exit(0) }, });

=head3 exit

Exit from current selection context

=cut

    $self->add_func('exit', {
            code => sub { return "EXIT" }, });

=head3 !

    ! [command [arg]]

Open a shell command or run command under shell

=cut

    $self->add_func('!', {
            code => sub {
                my ($env, $name, @args) = @_;
                if ($name) {
                    system('/bin/bash', '-ic', $env->Context->{_line});
                } else {
                    system('/bin/bash', '-i');
                }
            },
    } );

    if ($self->base->is_transactionnal) {

=head2 TRANSACTIONS FUNCTIONS

    transaction [on|off]

Enable or disable the transaction mode: ie automatic commit

=cut

        $self->add_func(
            'transaction', {
                code => sub {
                    $self->Context->TransMode($_[1] eq 'on' ? 1 : 0);
                },
                completion => sub {
                    $self->Context->TransMode == 0 ? 'on' : 'off';
                },
            }
        );

=head3 begin

Start a transaction, meaning changes will be saved only by C<commit> and canceled by C<rollback>

=cut

        $self->add_func(
            'begin', {
                code => sub {
                    $self->Context->TransStarted(1);
                },
            }
        );

=head3 commit

Save pending changes in transaction mode or following C<begin>

=cut

        $self->add_func(
            'commit', {
                code => sub {
                    $_[0]->_commit;
                },
            }
        );

=head3 rollback

Cancel pending changes following a C<begin> or in transaction mode

=cut

        $self->add_func(
            'rollback', {
                code => sub {
                    $_[0]->_rollback;
                },
            }
        );
    }

=head2 GLOBAL and OBJECTS FUNCTION

=head3 query

    query objectname [attribute]
    query [attribute]

Show attribute

options:

=over 4

=item -o|--otype objecttype

In global context specify the object type (default: user)

=item -e|--empty

Show empty/unset attributes

=item --ro

Show readonly attributes

=item --fmt format

Instead displaying attribute list use C<format> as formating string

=item recur

Dump object and all related objects

=back

=cut

    $self->add_func( 'query' => {
            proxy => '*',
            completion => sub { },
            code => sub {
                my $env = shift;
                my @args = $self->getoption(
                    {
                        'o|object=s' => \my $otype,
                        'e|empty'    => \my $empty_attr,
                        'ro'         => \my $with_ro,
                        'fmt=s'      => \my $fmt,
                        'filefmt=s'  => \my $filefmt,
                        'recur'      => \my $recur,
                    }, @_
                );
                $otype ||= 'user';

                my $objs = $self->Context->{objs};

                if (! $objs ) {
                    foreach my $name (@args) {
                        my $obj = $self->base->get_object( $otype, $name) or do {
                            $self->print("Cannot get object $otype/$name\n");
                            next;
                        };
                        push(@{ $objs }, $obj);
                    }
                }

                if ($filefmt){
                    open(my $hfmt, '<', $filefmt) or die "Cannot open $filefmt\n";
                    $fmt ||= ''; # avoid undef warning
                    while (<$hfmt>) {
                        chomp($fmt .= $_);
                    }
                    close $hfmt;
                }

                foreach (@{ $objs }) {
                    if ($fmt) {
                        $self->print($_->queryformat($fmt));
                    } else {
                        $_->text_dump( $self->Context->Out, {
                            recur => $recur,
                            empty_attr => $empty_attr,
                            only_rw => !$with_ro,
                        } );
                    }
                }
            },
    } );

=head3 log

    log [[-o otype ] object [object [...]]]

Show global log or log for the object given in arguments

=cut

    $self->add_func('log' => {
        proxy => '*',
        completion => sub { },
        code => sub {
            my $env = shift;
            my @args = $self->getoption({
                'o|object=s' => \my $otype,
            }, @_);
            $otype ||= 'user';

            if (!@args && $env->Context->{objs}) {
                @args = map { $_->id } @{ $env->Context->{objs} };
                $otype = $env->Context->{objs}[0]->type;
            }

            my @logs = @args
                ? $self->base->getobjectlogs($otype, @args)
                : $self->base->getlogs();

            foreach (@logs) {
                $self->print(
                    "%s (%d), %s: %s/%s (%d) %s\n",
                    $_->{logdate},
                    $_->{irev} || -1,
                    $_->{username},
                    $_->{otype},
                    $_->{name},
                    $_->{ikey},
                    $_->{message}
                );
            }
        },
    } ) if ($self->base->can('getobjectlogs'));

    if ($self->base->can('CreateAlias')) {

=head2 OBJECT ALIASES FUNCTION

=head3 newalias

    newalias objectType Name Object

Create an object alias named C<Name> for object C<Object>.

=cut

        $self->add_func(
            'newalias', {
                code => sub {
                    my ($self, $otype, $name, $for) = @_;
                    if ($self->base->CreateAlias($otype, $name, $for)) {
                        print $OUT "Alias $otype/$name Created\n";
                        $self->commit;
                    }
                },
                completion => sub {
                    if ($_[3]) {
                        return $_[0]->base->list_objects($_[2]);
                    } elsif (!$_[2]) {
                        return $_[0]->base->list_supported_objects;
                    } else {
                        return;
                    }
                }
            },
        );

=head3 rmalias

    rmalias objectType Name

Delete alias named C<Name>.

=cut

        $self->add_func(
            'rmalias', {
                code => sub {
                    my ($self, $otype, $name) = @_;
                    if ($self->base->RemoveAlias($otype, $name)) {
                        print $OUT "Alias $otype/$name Removed\n";
                        $self->commit;
                    }
                },
                completion => sub {
                    if (!$_[2]) {
                        return $_[0]->base->list_supported_objects;
                    } else {
                        return $_[0]->base->search_objects($_[2], 'oalias=*');
                    }
                }
            },
        );

=head3 updalias

    updalias objectType Name Object

Change the destination of an existing object alias

=cut

        $self->add_func(
            'updalias', {
                code => sub {
                    my ($self, $otype, $name, $for) = @_;
                    my $obj = $self->base->GetAlias($otype, $name) or do {
                        print $OUT "No alias $otype/$name found";
                        return;
                    };
                    if ($obj->set_c_fields(oalias => $for)) {
                        print $OUT "Alias $otype/$name Updated\n";
                        $self->commit;
                    }
                },
                completion => sub {
                    if ($_[3]) {
                        return $_[0]->base->list_objects($_[2]);
                    } elsif($_[2]) {
                        return $_[0]->base->search_objects($_[2], 'oalias=*');
                    } else {
                        return $_[0]->base->list_supported_objects;
                    }
                }
            },
        );
    }
}

=head2 base

Return the attached base object.

=cut

sub base { $_[0]->Context->base }
sub term { $_[0]->Context->Term }
sub print { shift->Context->print(@_) }

sub Top {
    my ( $self ) = @_;

    if ($self->Parent) {
        return $self->Parent->Top;
    } else {
        return $self;
    }
}

=head2 cli

Start the main loop

=cut

sub cli {
    my ($self) = @_;

    my $term = $_[0]->Context->Term;

    while (1) {
        $term->Attribs->{completion_function} = sub {
            $self->complete($_[0], shellwords(substr($_[1], 0, $_[2])));
        };
        defined (my $line = $term->readline($self->prompt)) or do {
            $self->print("\n");
            return;
        };
        $_[0]->Context->{_line} = $line;
        $term->addhistory($line) if ($line =~ /\S/);
        my $res = $self->run(shellwords($line));
        $self->rollback if (!$self->Context->TransMode);
        if ($res && $res eq 'EXIT') { $self->print("\n"); return }
    }
}

=head2 prompt

Wait user to input command

=cut

sub promptPrefix { 'LA cli' }

sub prompt {
    my ($self) = @_;
    my $pr = $self->promptPrefix;
    return sprintf(
        "%s%s%s ",
        $pr,
        $self->Context->TransStarted ? '-' : '=',
        $self->Context->TransMode  ? '#' : '>',
    );
}

=head2 add_func ($name, $param)

Add new function in the envirronment

=cut

# TODO: hide this

sub add_func {
    my ($self, $name, $param) = @_;
    my (undef, $file) = caller(0);
    $param->{podfile} = $file;
    $self->{funcs}{$name} = $param;
}

=head2 Help

Display help of given function

=cut

sub Help {
    my ($self, $name) = @_;
    if (!$name) {
        $self->print(join(', ', sort keys %{ $self->{funcs} || {}}) . "\n");
    } elsif ($self->{funcs}{$name}{alias}) {
        $self->print("$name is an alias for " . join(' ', @{$self->{funcs}{$name}{alias}}) . "\n");
    } elsif ($self->{funcs}{$name}{help}) {
        $self->print($self->{funcs}{$name}{help} . "\n");
    } else {
        my $fh = File::Temp->new();
        my $parser = Pod::Text::Termcap->new( sentence => 0, width => 78 );

        podselect(
            {-output => $fh, -sections => ["CLI FUNCTIONS/.*/\Q$name"]},
            $self->{funcs}{$name}{podfile}
        );
        seek($fh, 0, 0);
        $parser->parse_from_filehandle($fh, $self->Context->Out);
    }
}

=head2 getoption ($opt, @args)

Parse commmand line

=cut

sub getoption {
    my ($self, $opt, @args) = @_;
    local @ARGV = @args;
    Getopt::Long::Configure("pass_through");
    GetOptions(%{ $opt });

    return @ARGV;
}

=head2 complete

Return possible words according current entered words

=cut

sub complete {
    my ($self, $lastw, $name, @args) = @_;
    if (!$name) {
        $lastw ||= ''; # avoid undef warning
        if ($lastw =~ m!^(\.\./*)(.*)$!) {
            if ($self->Parent) {
                my $dot = $1;
                $dot .= '/' unless($dot =~ m!/$!);
                return map { "$dot$_" } $self->Parent->complete($2, $name, @args);
            } else {
                return ();
            }
        } elsif ($lastw =~ m!(^/+)(.*)$!) {
            return map { "$1$_" } $self->Top->complete($2, $name, @args);
        } else {
            return grep { /^\Q$lastw\E/ } sort
                (keys %{ $self->{funcs} || {}});
        }
    } elsif ($name =~ m!^\.\./(.*)$!) {
        if ($self->Parent) {
            return $self->Parent->complete($lastw, $1, @args);
        } else {
            return ();
        }
    } elsif ($name =~ m!^/+(.*)$!) {
        return $self->Top->complete($lastw, $1, @args);
    } elsif ($self->{funcs}{$name}{alias}) {
        $self->complete($lastw, @{$self->{funcs}{$name}{alias}}, @args);
    } elsif ($self->{funcs}{$name}{completion}) {
        return map { my $t = $_; $t =~ s/\s/\\ /g; $t } grep { $_ && /^\Q$lastw\E/ } $self->{funcs}{$name}{completion}->($self, $lastw, @args);
    } else {
        return ();
    }
}

=head2 run ($name, @args)

Run functions

=cut

sub run {
    my ($self, $name, @args) = @_;
    return if (!$name);

    if ($name =~ m!^\.\./+(.*)$!) {
        if ($self->Parent) {
            $self->Parent->run($1, @args);
        } else {
            $self->print("No parent envirronment to call function\n");
        }
    } elsif ($name =~ m!^/+(.*)$!) {
        $self->Top->run($1, @args);
    } elsif (grep { m/^(-h|--help)$/ } @args) {
        $self->Help($name);
    } elsif (!exists($self->{funcs}{$name})) {
        $self->print("No command $name found\n");
    } elsif ($self->{funcs}{$name}{alias}) {
        $self->run(@{$self->{funcs}{$name}{alias}}, @args);
    } elsif ($self->{funcs}{$name}{code}) {
        $self->{funcs}{$name}{code}->($self, @args);
    } else {
        $self->print("No command $name found\n");
    }
}

=head2 commit

Call commit to base unelss in transaction mode

=cut

sub commit {
    my ($self) = @_;
    $self->Context->commit;
}

sub _commit {
    my ($self) = @_;
    $self->Context->_commit;
}

=head2 rollback

Perform rollback unless in transaction mode

=cut

sub rollback {
    my ($self) = @_;
    $self->Context->rollback;
}

sub _rollback {
    my ($self) = @_;
    $self->Context->_rollback;
}

1;

__END__

=head1 SEE ALSO

L<LATMOS::Accounts>

=head1 AUTHOR

Olivier Thauvin, E<lt>olivier.thauvin@latmos.ipsl.frE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2008, 2009, 2010, 2011, 2012 CNRS SA/CETP/LATMOS

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.10.0 or,
at your option, any later version of Perl 5 you may have available.

=cut