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;

=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 config

=over 4

=item config objects

List supported objects type

=item config objects OTYPE

List attribute for OTYPE

=back

=cut

    $self->add_func('config', {
        completion => sub {
            if (!$_[2]) {
                return qw(objects);
            } elsif ( $_[2] eq 'objects' ) {
                if (! $_[3] ) {
                    return $_[0]->base->list_supported_objects;
                }
            }
        },
        code => sub {
            my ($self, $cmd, @args) = @_;
            if (!$cmd) {
                $self->print("No command given\n");
            } elsif ($cmd eq 'objects') {
                if ( $args[0] ) {
                    my $labase = $_[0]->base;
                    foreach(sort $labase->list_canonical_fields($args[0], 'a')) {
                        my $attr = $labase->attribute($args[0], $_);
                        $self->printf(
                            "%s   %s%s\n",
                            ($attr ? ($attr->ro ? 'r ' : 'rw') : '  '),
                            $_,
                            $attr->reference ? ' (=> ' . $attr->reference . ')' : '',
                        );
                    }
                } else {
                    $self->print("Supported objects type: ");
                    $self->print(join(', ', $self->base->list_supported_objects));
                    $self->print("\n");
                }
            } else {
                $self->print("wrong argument\n");
            }
        },
    });

=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) {
                $self->print( "Unexported objects is" . 
                    ($self->base->unexported ? "enable" : "disable") . "\n"
                );
            } elsif ($arg eq 'yes') {
                $self->base->unexported(1);
                $self->print("Unexported are now show\n");
            } elsif ($arg eq 'no') {
                $self->base->unexported(0);
                $self->print("Unexported are no longer show\n");
            } elsif ($arg eq 'show') {
                $self->print("Unexported objects is" .
                    ($self->base->unexported ? "enable" : "disable") . "\n"
                );
            } else {
                $self->print("wrong argument\n");
            }
        },
    });

=head3 quit

Exit from C<CLI> tools

=cut

    $self->add_func('quit', {
            code => sub { $self->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;
                },
            }
        );
    }

=head3 collection

Manage saved objects list:

    collection list
    collection save
    collection load
    collection delete

=cut

    $self->add_func( 'collection',
        {
            code => sub {
                my ( $self, $subcommand, @args ) = @_;
                $subcommand ||= '';
                $self->Context->Preferences->{Collections} ||= {};
                my $Collections = $self->Context->Preferences->{Collections};
                if ( $subcommand eq 'list' || !$subcommand ) {
                    foreach my $c ( sort keys %{ $Collections } ) {
                        my @objlist = @{ $Collections->{$c}{objs} || []};
                        $self->printf(
                            "%s: %s, %s\n",
                            $c,
                            $Collections->{$c}{otype},
                            (@objlist >= 1 ? scalar(@objlist) . ' objs.' : $objlist[0]),
                        );
                    }
                } elsif ($subcommand eq 'load') {
                    my $c = $args[0] or do {
                        $self->print("No collection name given\n");
                        return;
                    };
                    if (! $Collections->{$c} ) {
                        $self->print("This collection does not exists\n");
                        return;
                    }
                    my $otype = $Collections->{ $c }{otype};
                    my @objs;
                    foreach (@{ $Collections->{ $c }{ objs } || []}) {
                        my $obj = $self->base->get_object($otype, $_) or do {
                            $self->print("Cannot get $otype $_\n");
                            return;
                        };
                        push(@objs, $obj);
                    }
                    if (@objs) {
                        $self->print("Selecting $otype " . join(', ', map { $_->id } @objs) . "\n");
                        LATMOS::Accounts::Cli::Object->new(
                            Parent  => $self,
                            Context => $self->Context,
                            otype   => $otype,
                            objs    => \@objs,
                        )->cli();
                    } else {
                        $self->print("No objects to load\n");
                    }
                } elsif ($subcommand eq 'clear') {
                    $self->Context->Preferences->{Collections} = {};
                } elsif ($subcommand =~ m/^(delete|del)$/) {
                    my ( $name ) = @args;
                    delete( $Collections->{$name} );
                } elsif ($subcommand eq 'save' ) {
                    my ( $name, $what ) = @args;
                    $what ||= '';

                    if ( $what eq '@' ) {
                        if (! $self->{_lastsearch} ) {
                            $self->print("No previous search found, nothing saved\n");
                            return;
                        }
                        $Collections->{ $name } = {
                            otype => $self->{_lastsearchtype},
                            objs =>  [ @{$self->{_lastsearch}} ],
                        }
                    } elsif ($self->can('otype')) {
                        $Collections->{ $name } = {
                            otype => $self->otype,
                            objs =>  [ map { $_->id } @{ $self->objs || [] } ],
                        };
                    } else {
                        $self->print("No objects to save");
                    }
                }
            },
            completion => sub {
                my ($self, undef, $command, $name, $what) = @_;
                $command ||= '';
                my $Collections = $self->Context->Preferences->{Collections} || {};
                if ( ! $command ) {
                    return qw(list load save delete clear);
                } elsif ( $command =~ /^(load|delete|del)$/ ) {
                    return sort keys %{ $Collections };
                } elsif ( $command eq 'save' ) {
                    if ($name) {
                        return qw( @ );
                    }
                } else {
                    return;
                }
            },
        }
    );

=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,
                        'subotype=s' => \my @SubOtype,
                    }, @_
                );
                $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,
                            SubOtype => \@SubOtype,
                        } );
                    }
                }
            },
    } );

=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)) {
                        $self->print( "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)) {
                        $self->print("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 {
                        $self->print( "No alias $otype/$name found" );
                        return;
                    };
                    if ($obj->set_c_fields(oalias => $for)) {
                        $self->print( "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 La           { $_[0]->Context->La   }
sub base         { $_[0]->Context->base }
sub term         { $_[0]->Context->Term }
sub Interractive { $_[0]->Context->Interactive }
sub print        { shift->Context->print (@_) }
sub printf       { shift->Context->printf(@_) }

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

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

sub Traverse {
    my ( $self, $Before, $After ) = @_;

    $Before->($self) if ($Before);
    if ($self->Parent) {
        $self->Parent->Traverse($Before, $After);
    }
    $After->($self) if ($After);
}

sub _parse_cmd_line {
    my ( $self, $cmdLine ) = @_;

    my ($op, $shellLine, $internalLine);

    if ($cmdLine =~ /^(.*?)(?<![\S\\|])([\|\>])\s*([^\|].*)?$/) {
        $internalLine = $1;
        $op = $2;
        $shellLine = $3;
    } else {
        $internalLine = $cmdLine;
    }

    return ( $op, $shellLine, shellwords($internalLine) );

}

=head2 topCli

Entry point for cli

=cut

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

    $self->Context->ReadHistory();
    $self->Context->ReadPreferences();
    $self->cli();
    if (! $self->Context->WriteHistory() ) {
        warn "Cannot write history:  $!\n";
    }
    $self->Context->WritePreferences();
}

=head2 cli

Start the main loop

=cut

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

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

    while (1) {
        $term->Attribs->{completion_function} = sub {
            my ($Op, $Shell, @args) = $self->_parse_cmd_line(substr($_[1], 0, $_[2]));
            $Op ||= '';
            my $attribs = $self->Context->Term->Attribs;
            if ($Op eq '>') {
                $term->completion_matches($Shell, $attribs->{'filename_completion_function'});
            } elsif ($Op eq '|') {
                $term->completion_matches($Shell, $attribs->{'filename_completion_function'});
            } else  {
                $self->complete($_[0], @args);
            }
        };
        defined (my $line = $term->readline($self->prompt)) or do {
            $self->print("\n");
            return;
        };
        $_[0]->Context->{_line} = $line;
        $term->addhistory($line) if ($line =~ /\S/);
        my ($Op, $Shell, @args) = $self->_parse_cmd_line($line);
        my $Handle;
        if ($Op) {
            open($Handle, "$Op $Shell") or next;
            $self->Context->TempOut($Handle);
        }
        my $res = $self->run(@args);
        if ($Handle) {
            $self->Context->TempOut(undef);
            close($Handle);
        }
        $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 {
    my $self = shift;
    return sprintf('%s cli', $self->base->label)
}

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