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

Last change on this file since 2216 was 2216, checked in by nanardon, 5 years ago

Add ability to call parent Envirronment (../func)
File size: 12.3 KB
Line 
1package LATMOS::Accounts::Cli::Base;
2
3# $Id: Cli.pm 2145 2018-08-29 18:15:46Z nanardon $
4
5use strict;
6use warnings;
7use Moose;
8use LATMOS::Accounts::Cli::Context;
9use LATMOS::Accounts::Log;
10use LATMOS::Accounts::Utils;
11use Term::ReadLine;
12use Text::ParseWords;
13use Getopt::Long;
14use Pod::Select;
15use Pod::Text::Termcap;
16use File::Temp;
17
18=head1 NAME
19
20LATMOS::Accounts::Cli - Command line interface functions
21
22=head1 DESCRIPTION
23
24This module handle envirronment and functons for L<la-cli> tools.
25
26=cut
27
28has Context => ( is => 'ro', isa => 'LATMOS::Accounts::Cli::Context' );
29has Parent  => ( is => 'ro' );
30
31=head1 FUNCTIONS
32
33=cut
34
35=head1 CLI FUNCTIONS
36
37=cut
38
39sub BUILD {
40    my $self = shift;
41
42    my $OUT = $self->Context->Out;
43
44    if ($self->base->is_transactionnal) {
45        $self->add_func(
46            'transaction', {
47                help => 'change transaction mode',
48                code => sub {
49                    $self->Context->TransMode($_[1] eq 'on' ? 1 : 0);
50                },
51                completion => sub {
52                    $self->Context->TransMode == 0 ? 'on' : 'off';
53                },
54            }
55        );
56        $self->add_func(
57            'begin', {
58                help => 'Start transaction',
59                code => sub {
60                    $self->Context->TransStarted(1);
61                },
62            }
63        );
64        $self->add_func(
65            'commit', {
66                help => 'commit pending change',
67                code => sub {
68                    $_[0]->_commit;
69                },
70            }
71        );
72        $self->add_func(
73            'rollback', {
74                help => 'commit pending change',
75                code => sub {
76                    $_[0]->_rollback;
77                },
78            }
79        );
80    }
81    if ($self->base->can('CreateAlias')) {
82        $self->add_func(
83            'newalias', {
84                help => 'Create an alias object',
85                code => sub {
86                    my ($self, $otype, $name, $for) = @_;
87                    if ($self->base->CreateAlias($otype, $name, $for)) {
88                        print $OUT "Alias $otype/$name Created\n";
89                        $self->commit;
90                    }
91                },
92                completion => sub {
93                    if ($_[3]) {
94                        return $_[0]->base->list_objects($_[2]);
95                    } elsif (!$_[2]) {
96                        return $_[0]->base->list_supported_objects;
97                    } else {
98                        return;
99                    }
100                }
101            },
102        );
103        $self->add_func(
104            'rmalias', {
105                help => 'Remove an alias object',
106                code => sub {
107                    my ($self, $otype, $name) = @_;
108                    if ($self->base->RemoveAlias($otype, $name)) {
109                        print $OUT "Alias $otype/$name Removed\n";
110                        $self->commit;
111                    }
112                },
113                completion => sub {
114                    if (!$_[2]) {
115                        return $_[0]->base->list_supported_objects;
116                    } else {
117                        return $_[0]->base->search_objects($_[2], 'oalias=*');
118                    }
119                }
120            },
121        );
122        $self->add_func(
123            'updalias', {
124                help => 'Update an alias object',
125                code => sub {
126                    my ($self, $otype, $name, $for) = @_;
127                    my $obj = $self->base->GetAlias($otype, $name) or do {
128                        print $OUT "No alias $otype/$name found";
129                        return;
130                    };
131                    if ($obj->set_c_fields(oalias => $for)) {
132                        print $OUT "Alias $otype/$name Updated\n";
133                        $self->commit;
134                    }
135                },
136                completion => sub {
137                    if ($_[3]) {
138                        return $_[0]->base->list_objects($_[2]);
139                    } elsif($_[2]) {
140                        return $_[0]->base->search_objects($_[2], 'oalias=*');
141                    } else {
142                        return $_[0]->base->list_supported_objects;
143                    }
144                }
145            },
146        );
147    }
148    $self->add_func('quit', { help => 'quit - exit the tool',
149            code => sub { print "\n"; exit(0) }, });
150    $self->add_func('exit', { help => "exit current mode",
151            code => sub { return "EXIT" }, });
152
153
154=head2 help
155
156    help [command] - print help about command
157
158=cut
159
160    $self->add_func('help', {
161        completion => sub {
162            if (!$_[2]) { return sort keys %{ $_[0]->{funcs} || {}} }
163        },
164        code => sub {
165            my $env = shift;
166
167            $env->Help(@_);
168        },
169    });
170
171    $self->add_func( 'query' => {
172            proxy => '*',
173            help  => 'show attribute',
174            completion => sub { },
175            code => sub {
176                my $env = shift;
177                my @args = $self->getoption(
178                    {
179                        'o|object=s' => \my $otype,
180                        'e|empty'    => \my $empty_attr,
181                        'ro'         => \my $with_ro,
182                        'fmt=s'      => \my $fmt,
183                        'filefmt=s'  => \my $filefmt,
184                    }, @_
185                );
186                $otype ||= 'user';
187
188                my $objs = $self->Context->{objs};
189
190                if (! $objs ) {
191                    foreach my $name (@args) {
192                        my $obj = $self->base->get_object( $otype, $name) or do {
193                            $self->print("Cannot get object $otype/$name\n");
194                            next;
195                        };
196                        push(@{ $objs }, $obj);
197                    }
198                }
199
200                if ($filefmt){
201                    open(my $hfmt, '<', $filefmt) or die "Cannot open $filefmt\n";
202                    $fmt ||= ''; # avoid undef warning
203                    while (<$hfmt>) {
204                        chomp($fmt .= $_);
205                    }
206                    close $hfmt;
207                }
208
209                foreach (@{ $objs }) {
210                    if ($fmt) {
211                        $self->print($_->queryformat($fmt));
212                    } else {
213                        $_->text_dump( $self->Context->Out, {
214                            empty_attr => $empty_attr,
215                            only_rw => !$with_ro,
216                        } );
217                    }
218                }
219            },
220    } );
221
222=head2 log
223
224    log [[-o otype ] object]
225
226Show global log or log for the object given in arguments
227
228=cut
229
230    $self->add_func('log' => {
231        proxy => '*',
232        completion => sub { },
233        code => sub {
234            my $env = shift;
235            my @args = $self->getoption({
236                'o|object=s' => \my $otype,
237            }, @_);
238            $otype ||= 'user';
239
240            my @logs = @args
241                ? $self->base->getobjectlogs($otype, $args[0])
242                : $self->base->getlogs();
243
244            foreach (@logs) {
245                $self->print(
246                    "%s (%d), %s: %s/%s (%d) %s\n",
247                    $_->{logdate},
248                    $_->{irev} || -1,
249                    $_->{username},
250                    $_->{otype},
251                    $_->{name},
252                    $_->{ikey},
253                    $_->{message}
254                );
255            }
256        },
257    } );
258
259}
260
261=head2 base
262
263Return the attached base object.
264
265=cut
266
267sub base { $_[0]->Context->base }
268sub term { $_[0]->Context->Term }
269sub print { shift->Context->print(@_) }
270
271=head2 cli
272
273Start the main loop
274
275=cut
276
277sub cli {
278    my ($self) = @_;
279
280    my $term = $_[0]->Context->Term;
281
282    while (1) {
283        $term->Attribs->{completion_function} = sub {
284            $self->complete($_[0], shellwords(substr($_[1], 0, $_[2])));
285        };
286        defined (my $line = $term->readline($self->prompt)) or do {
287            $self->print("\n");
288            return;
289        };
290        $term->addhistory($line);
291        my $res = $self->run(shellwords($line));
292        $self->rollback if (!$self->Context->TransMode);
293        if ($res && $res eq 'EXIT') { $self->print("\n"); return }
294    }
295}
296
297=head2 prompt
298
299Wait user to input command
300
301=cut
302
303sub promptPrefix { 'LA cli' }
304
305sub prompt {
306    my ($self) = @_;
307    my $pr = $self->promptPrefix;
308    return sprintf(
309        "%s%s%s ",
310        $pr,
311        $self->Context->TransStarted ? '-' : '=',
312        $self->Context->TransMode  ? '#' : '>',
313    );
314}
315
316=head2 add_func ($name, $param)
317
318Add new function in the envirronment
319
320=cut
321
322# TODO: hide this
323
324sub add_func {
325    my ($self, $name, $param) = @_;
326    my (undef, $file) = caller(0);
327    $param->{podfile} = $file;
328    $self->{funcs}{$name} = $param;
329}
330
331=head2 Help
332
333Display help of given function
334
335=cut
336
337sub Help {
338    my ($self, $name) = @_;
339    if (!$name) {
340        $self->print(join(', ', sort keys %{ $self->{funcs} || {}}) . "\n");
341    } elsif ($self->{funcs}{$name}{alias}) {
342        $self->print("$name is an alias for " . join(' ', @{$self->{funcs}{$name}{alias}}) . "\n");
343    } elsif ($self->{funcs}{$name}{help}) {
344        $self->print($self->{funcs}{$name}{help});
345    } else {
346        my $fh = File::Temp->new();
347        my $parser = Pod::Text::Termcap->new( sentence => 0, width => 78 );
348
349        podselect(
350            {-output => $fh, -sections => ["CLI FUNCTIONS/\Q$name"]},
351            $self->{funcs}{$name}{podfile}
352        );
353        seek($fh, 0, 0);
354        $parser->parse_from_filehandle($fh, $self->Context->Out);
355    }
356}
357
358=head2 getoption ($opt, @args)
359
360Parse commmand line
361
362=cut
363
364sub getoption {
365    my ($self, $opt, @args) = @_;
366    local @ARGV = @args;
367    Getopt::Long::Configure("pass_through");
368    GetOptions(%{ $opt });
369
370    return @ARGV;
371}
372
373=head2 complete
374
375Return possible words according current entered words
376
377=cut
378
379sub complete {
380    my ($self, $lastw, $name, @args) = @_;
381    if (!$name) {
382        if ($lastw =~ m!^\.\./?(.*)$!) {
383            if ($self->Parent) {
384                return map { "../$_" } $self->Parent->complete($1, $name, @args);
385            } else {
386                return ();
387            }
388        } else {
389            return grep { /^\Q$lastw\E/ } sort
390                (keys %{ $self->{funcs} || {}});
391        }
392    } elsif ($name =~ m!^../(.*)$!) {
393        if ($self->Parent) {
394            return $self->Parent->complete($lastw, $1, @args);
395        } else {
396            return ();
397        }
398    } elsif ($self->{funcs}{$name}{alias}) {
399        $self->complete($lastw, @{$self->{funcs}{$name}{alias}}, @args);
400    } elsif ($self->{funcs}{$name}{completion}) {
401        return map { my $t = $_; $t =~ s/\s/\\ /g; $t } grep { $_ && /^\Q$lastw\E/ } $self->{funcs}{$name}{completion}->($self, $lastw, @args);
402    } else {
403        return ();
404    }
405}
406
407=head2 run ($name, @args)
408
409Run functions
410
411=cut
412
413sub run {
414    my ($self, $name, @args) = @_;
415    return if (!$name);
416
417    if ($name =~ m!^../(.*)$!) {
418        if ($self->Parent) {
419            $self->Parent->run($1, @args);
420        } else {
421            $self->print("No parent envirronment to call function\n");
422        }
423    } elsif (grep { m/^(-h|--help)$/ } @args) {
424        $self->Help($name);
425    } elsif (!exists($self->{funcs}{$name})) {
426        $self->print("No command $name found\n");
427    } elsif ($self->{funcs}{$name}{alias}) {
428        $self->run(@{$self->{funcs}{$name}{alias}}, @args);
429    } elsif ($self->{funcs}{$name}{code}) {
430        $self->{funcs}{$name}{code}->($self, @args);
431    } else {
432        $self->print("No command $name found\n");
433    }
434}
435
436=head2 commit
437
438Call commit to base unelss in transaction mode
439
440=cut
441
442sub commit {
443    my ($self) = @_;
444    $self->Context->commit;
445}
446
447sub _commit {
448    my ($self) = @_;
449    $self->Context->_commit;
450}
451
452=head2 rollback
453
454Perform rollback unless in transaction mode
455
456=cut
457
458sub rollback {
459    my ($self) = @_;
460    $self->Context->rollback;
461}
462
463sub _rollback {
464    my ($self) = @_;
465    $self->Context->_rollback;
466}
467
4681;
469
470__END__
471
472=head1 SEE ALSO
473
474L<LATMOS::Accounts>
475
476=head1 AUTHOR
477
478Olivier Thauvin, E<lt>olivier.thauvin@latmos.ipsl.frE<gt>
479
480=head1 COPYRIGHT AND LICENSE
481
482Copyright (C) 2008, 2009, 2010, 2011, 2012 CNRS SA/CETP/LATMOS
483
484This library is free software; you can redistribute it and/or modify
485it under the same terms as Perl itself, either Perl version 5.10.0 or,
486at your option, any later version of Perl 5 you may have available.
487
488=cut
Note: See TracBrowser for help on using the repository browser.