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

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;

=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' );

=head1 FUNCTIONS

=cut

=head1 CLI FUNCTIONS

=cut

sub BUILD {
    my $self = shift;

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

    if ($self->base->is_transactionnal) {
        $self->add_func(
            'transaction', {
                help => 'change transaction mode',
                code => sub {
                    $self->Context->TransMode($_[1] eq 'on' ? 1 : 0);
                },
                completion => sub {
                    $self->Context->TransMode == 0 ? 'on' : 'off';
                },
            }
        );
        $self->add_func(
            'begin', {
                help => 'Start transaction',
                code => sub {
                    $self->Context->TransStarted(1);
                },
            }
        );
        $self->add_func(
            'commit', {
                help => 'commit pending change',
                code => sub {
                    $_[0]->_commit;
                },
            }
        );
        $self->add_func(
            'rollback', {
                help => 'commit pending change',
                code => sub {
                    $_[0]->_rollback;
                },
            }
        );
    }
    if ($self->base->can('CreateAlias')) {
        $self->add_func(
            'newalias', {
                help => 'Create an alias object',
                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;
                    }
                }
            },
        );
        $self->add_func(
            'rmalias', {
                help => 'Remove an alias object',
                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=*');
                    }
                }
            },
        );
        $self->add_func(
            'updalias', {
                help => 'Update an alias object',
                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;
                    }
                }
            },
        );
    }
    $self->add_func('quit', { help => 'quit - exit the tool',
            code => sub { print "\n"; exit(0) }, });
    $self->add_func('exit', { help => "exit current mode",
            code => sub { return "EXIT" }, });
    $self->add_func('help', {
        help => 'help [command] - print help about command',
        completion => sub {
            if (!$_[2]) { return sort keys %{ $_[0]->{funcs} || {}} }
        },
        code => sub {
            my ($self, $name) = @_;
            if (!$name) {
                print $OUT join(', ', sort keys %{ $self->{funcs} || {}}) . "\n";
            } elsif ($self->{funcs}{$name}{alias}) {
                print $OUT "$name is an alias for " . join(' ',
                    @{$self->{funcs}{$name}{alias}}) . "\n";
            } elsif ($self->{funcs}{$name}{help}) {
                print $OUT $self->{funcs}{$name}{help} . "\n";
            } else {
                print $OUT "No help availlable\n";
            }
        },
    });

    $self->add_func( 'query' => {
            proxy => '*',
            help  => 'show attribute',
            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,
                    }, @_
                );
                $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, {
                            empty_attr => $empty_attr,
                            only_rw => !$with_ro,
                        } );
                    }
                }
            },
    } );
}

=head2 base

Return the attached base object.

=cut

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

=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;
        };
        $term->addhistory($line);
        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) = @_;
    $self->{funcs}{$name} = $param;
}

=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) {
        return grep { /^\Q$lastw\E/ } sort
            (keys %{ $self->{funcs} || {}});
    } 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 (!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