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

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

Allow to function on top env (/func)
File size: 12.7 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
271sub Top {
272    my ( $self ) = @_;
273
274    if ($self->Parent) {
275        return $self->Parent->Top;
276    } else {
277        return $self;
278    }
279}
280
281=head2 cli
282
283Start the main loop
284
285=cut
286
287sub cli {
288    my ($self) = @_;
289
290    my $term = $_[0]->Context->Term;
291
292    while (1) {
293        $term->Attribs->{completion_function} = sub {
294            $self->complete($_[0], shellwords(substr($_[1], 0, $_[2])));
295        };
296        defined (my $line = $term->readline($self->prompt)) or do {
297            $self->print("\n");
298            return;
299        };
300        $term->addhistory($line);
301        my $res = $self->run(shellwords($line));
302        $self->rollback if (!$self->Context->TransMode);
303        if ($res && $res eq 'EXIT') { $self->print("\n"); return }
304    }
305}
306
307=head2 prompt
308
309Wait user to input command
310
311=cut
312
313sub promptPrefix { 'LA cli' }
314
315sub prompt {
316    my ($self) = @_;
317    my $pr = $self->promptPrefix;
318    return sprintf(
319        "%s%s%s ",
320        $pr,
321        $self->Context->TransStarted ? '-' : '=',
322        $self->Context->TransMode  ? '#' : '>',
323    );
324}
325
326=head2 add_func ($name, $param)
327
328Add new function in the envirronment
329
330=cut
331
332# TODO: hide this
333
334sub add_func {
335    my ($self, $name, $param) = @_;
336    my (undef, $file) = caller(0);
337    $param->{podfile} = $file;
338    $self->{funcs}{$name} = $param;
339}
340
341=head2 Help
342
343Display help of given function
344
345=cut
346
347sub Help {
348    my ($self, $name) = @_;
349    if (!$name) {
350        $self->print(join(', ', sort keys %{ $self->{funcs} || {}}) . "\n");
351    } elsif ($self->{funcs}{$name}{alias}) {
352        $self->print("$name is an alias for " . join(' ', @{$self->{funcs}{$name}{alias}}) . "\n");
353    } elsif ($self->{funcs}{$name}{help}) {
354        $self->print($self->{funcs}{$name}{help});
355    } else {
356        my $fh = File::Temp->new();
357        my $parser = Pod::Text::Termcap->new( sentence => 0, width => 78 );
358
359        podselect(
360            {-output => $fh, -sections => ["CLI FUNCTIONS/\Q$name"]},
361            $self->{funcs}{$name}{podfile}
362        );
363        seek($fh, 0, 0);
364        $parser->parse_from_filehandle($fh, $self->Context->Out);
365    }
366}
367
368=head2 getoption ($opt, @args)
369
370Parse commmand line
371
372=cut
373
374sub getoption {
375    my ($self, $opt, @args) = @_;
376    local @ARGV = @args;
377    Getopt::Long::Configure("pass_through");
378    GetOptions(%{ $opt });
379
380    return @ARGV;
381}
382
383=head2 complete
384
385Return possible words according current entered words
386
387=cut
388
389sub complete {
390    my ($self, $lastw, $name, @args) = @_;
391    if (!$name) {
392        if ($lastw =~ m!^(\.\./*)(.*)$!) {
393            if ($self->Parent) {
394                return map { "$1/$_" } $self->Parent->complete($2, $name, @args);
395            } else {
396                return ();
397            }
398        } elsif ($lastw =~ m!(^/+)(.*)$!) {
399            return map { "$1$_" } $self->Top->complete($2, $name, @args);
400        } else {
401            return grep { /^\Q$lastw\E/ } sort
402                (keys %{ $self->{funcs} || {}});
403        }
404    } elsif ($name =~ m!^\.\./(.*)$!) {
405        if ($self->Parent) {
406            return $self->Parent->complete($lastw, $1, @args);
407        } else {
408            return ();
409        }
410    } elsif ($name =~ m!^/+(.*)$!) {
411        return $self->Top->complete($lastw, $1, @args);
412    } elsif ($self->{funcs}{$name}{alias}) {
413        $self->complete($lastw, @{$self->{funcs}{$name}{alias}}, @args);
414    } elsif ($self->{funcs}{$name}{completion}) {
415        return map { my $t = $_; $t =~ s/\s/\\ /g; $t } grep { $_ && /^\Q$lastw\E/ } $self->{funcs}{$name}{completion}->($self, $lastw, @args);
416    } else {
417        return ();
418    }
419}
420
421=head2 run ($name, @args)
422
423Run functions
424
425=cut
426
427sub run {
428    my ($self, $name, @args) = @_;
429    return if (!$name);
430
431    if ($name =~ m!^\.\./+(.*)$!) {
432        if ($self->Parent) {
433            $self->Parent->run($1, @args);
434        } else {
435            $self->print("No parent envirronment to call function\n");
436        }
437    } elsif ($name =~ m!^/+(.*)$!) {
438        $self->Top->run($1, @args);
439    } elsif (grep { m/^(-h|--help)$/ } @args) {
440        $self->Help($name);
441    } elsif (!exists($self->{funcs}{$name})) {
442        $self->print("No command $name found\n");
443    } elsif ($self->{funcs}{$name}{alias}) {
444        $self->run(@{$self->{funcs}{$name}{alias}}, @args);
445    } elsif ($self->{funcs}{$name}{code}) {
446        $self->{funcs}{$name}{code}->($self, @args);
447    } else {
448        $self->print("No command $name found\n");
449    }
450}
451
452=head2 commit
453
454Call commit to base unelss in transaction mode
455
456=cut
457
458sub commit {
459    my ($self) = @_;
460    $self->Context->commit;
461}
462
463sub _commit {
464    my ($self) = @_;
465    $self->Context->_commit;
466}
467
468=head2 rollback
469
470Perform rollback unless in transaction mode
471
472=cut
473
474sub rollback {
475    my ($self) = @_;
476    $self->Context->rollback;
477}
478
479sub _rollback {
480    my ($self) = @_;
481    $self->Context->_rollback;
482}
483
4841;
485
486__END__
487
488=head1 SEE ALSO
489
490L<LATMOS::Accounts>
491
492=head1 AUTHOR
493
494Olivier Thauvin, E<lt>olivier.thauvin@latmos.ipsl.frE<gt>
495
496=head1 COPYRIGHT AND LICENSE
497
498Copyright (C) 2008, 2009, 2010, 2011, 2012 CNRS SA/CETP/LATMOS
499
500This library is free software; you can redistribute it and/or modify
501it under the same terms as Perl itself, either Perl version 5.10.0 or,
502at your option, any later version of Perl 5 you may have available.
503
504=cut
Note: See TracBrowser for help on using the repository browser.