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

Last change on this file since 2397 was 2397, checked in by nanardon, 4 years ago

Replace print by ->print()
File size: 17.1 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=head2 GLOBAL FUNCTIONS
38
39=cut
40
41sub BUILD {
42    my $self = shift;
43
44=head3 help
45
46    help [command] - print help about command
47
48=cut
49
50    $self->add_func('help', {
51        completion => sub {
52            if (!$_[2]) { return sort keys %{ $_[0]->{funcs} || {}} }
53        },
54        code => sub {
55            my $env = shift;
56
57            $env->Help(@_);
58        },
59    });
60
61=head3 config
62
63=over 4
64
65=item config objects
66
67List supported objects type
68
69=item config objects OTYPE
70
71List attribute for OTYPE
72
73=back
74
75=cut
76
77    $self->add_func('config', {
78        completion => sub {
79            if (!$_[2]) {
80                return qw(objects);
81            } elsif ( $_[2] eq 'objects' ) {
82                if (! $_[3] ) {
83                    return $_[0]->base->list_supported_objects;
84                }
85            }
86        },
87        code => sub {
88            my ($self, $cmd, @args) = @_;
89            if (!$cmd) {
90                $self->print("No command given\n");
91            } elsif ($cmd eq 'objects') {
92                if ( $args[0] ) {
93                    my $labase = $_[0]->base;
94                    foreach(sort $labase->list_canonical_fields($args[0], 'a')) {
95                        my $attr = $labase->attribute($args[0], $_);
96                        $self->printf("%s   %s\n", ($attr ? ($attr->ro ? 'r ' : 'rw') : '  '), $_);
97                    }
98                } else {
99                    $self->print("Supported objects type: ");
100                    $self->print(join(', ', $self->base->list_supported_objects));
101                    $self->print("\n");
102                }
103            } else {
104                $self->print("wrong argument\n");
105            }
106        },
107    });
108
109=head3 unexported
110
111    unexported yes|no|show
112
113switch or show base mode regarding' unexported objects behavior
114
115=cut
116
117    $self->add_func('unexported', {
118        completion => sub {
119            if (!$_[2]) {
120                return qw(yes no show);
121            }
122        },
123        code => sub {
124            my ($self, $arg) = @_;
125            if (!$arg) {
126                $self->print( "Unexported objects is" . 
127                    ($self->base->unexported ? "enable" : "disable") . "\n"
128                );
129            } elsif ($arg eq 'yes') {
130                $self->base->unexported(1);
131                $self->print("Unexported are now show\n");
132            } elsif ($arg eq 'no') {
133                $self->base->unexported(0);
134                $self->print("Unexported are no longer show\n");
135            } elsif ($arg eq 'show') {
136                $self->print("Unexported objects is" .
137                    ($self->base->unexported ? "enable" : "disable") . "\n"
138                );
139            } else {
140                $self->print("wrong argument\n");
141            }
142        },
143    });
144
145=head3 quit
146
147Exit from C<CLI> tools
148
149=cut
150
151    $self->add_func('quit', {
152            code => sub { $self->print("\n"); exit(0) }, });
153
154=head3 exit
155
156Exit from current selection context
157
158=cut
159
160    $self->add_func('exit', {
161            code => sub { return "EXIT" }, });
162
163=head3 !
164
165    ! [command [arg]]
166
167Open a shell command or run command under shell
168
169=cut
170
171    $self->add_func('!', {
172            code => sub {
173                my ($env, $name, @args) = @_;
174                if ($name) {
175                    system('/bin/bash', '-ic', $env->Context->{_line});
176                } else {
177                    system('/bin/bash', '-i');
178                }
179            },
180    } );
181
182    if ($self->base->is_transactionnal) {
183
184=head2 TRANSACTIONS FUNCTIONS
185
186    transaction [on|off]
187
188Enable or disable the transaction mode: ie automatic commit
189
190=cut
191
192        $self->add_func(
193            'transaction', {
194                code => sub {
195                    $self->Context->TransMode($_[1] eq 'on' ? 1 : 0);
196                },
197                completion => sub {
198                    $self->Context->TransMode == 0 ? 'on' : 'off';
199                },
200            }
201        );
202
203=head3 begin
204
205Start a transaction, meaning changes will be saved only by C<commit> and canceled by C<rollback>
206
207=cut
208
209        $self->add_func(
210            'begin', {
211                code => sub {
212                    $self->Context->TransStarted(1);
213                },
214            }
215        );
216
217=head3 commit
218
219Save pending changes in transaction mode or following C<begin>
220
221=cut
222
223        $self->add_func(
224            'commit', {
225                code => sub {
226                    $_[0]->_commit;
227                },
228            }
229        );
230
231=head3 rollback
232
233Cancel pending changes following a C<begin> or in transaction mode
234
235=cut
236
237        $self->add_func(
238            'rollback', {
239                code => sub {
240                    $_[0]->_rollback;
241                },
242            }
243        );
244    }
245
246=head2 GLOBAL and OBJECTS FUNCTION
247
248=head3 query
249
250    query objectname [attribute]
251    query [attribute]
252
253Show attribute
254
255options:
256
257=over 4
258
259=item -o|--otype objecttype
260
261In global context specify the object type (default: user)
262
263=item -e|--empty
264
265Show empty/unset attributes
266
267=item --ro
268
269Show readonly attributes
270
271=item --fmt format
272
273Instead displaying attribute list use C<format> as formating string
274
275=item --recur
276
277Dump object and all related objects
278
279=back
280
281=cut
282
283    $self->add_func( 'query' => {
284            proxy => '*',
285            completion => sub { },
286            code => sub {
287                my $env = shift;
288                my @args = $self->getoption(
289                    {
290                        'o|object=s' => \my $otype,
291                        'e|empty'    => \my $empty_attr,
292                        'ro'         => \my $with_ro,
293                        'fmt=s'      => \my $fmt,
294                        'filefmt=s'  => \my $filefmt,
295                        'recur'      => \my $recur,
296                        'subotype=s' => \my @SubOtype,
297                    }, @_
298                );
299                $otype ||= 'user';
300
301                my $objs = $self->Context->{objs};
302
303                if (! $objs ) {
304                    foreach my $name (@args) {
305                        my $obj = $self->base->get_object( $otype, $name) or do {
306                            $self->print("Cannot get object $otype/$name\n");
307                            next;
308                        };
309                        push(@{ $objs }, $obj);
310                    }
311                }
312
313                if ($filefmt){
314                    open(my $hfmt, '<', $filefmt) or die "Cannot open $filefmt\n";
315                    $fmt ||= ''; # avoid undef warning
316                    while (<$hfmt>) {
317                        chomp($fmt .= $_);
318                    }
319                    close $hfmt;
320                }
321
322                foreach (@{ $objs }) {
323                    if ($fmt) {
324                        $self->print($_->queryformat($fmt));
325                    } else {
326                        $_->text_dump( $self->Context->Out, {
327                            recur => $recur,
328                            empty_attr => $empty_attr,
329                            only_rw => !$with_ro,
330                            SubOtype => \@SubOtype,
331                        } );
332                    }
333                }
334            },
335    } );
336
337=head3 log
338
339    log [[-o otype ] object [object [...]]]
340
341Show global log or log for the object given in arguments
342
343=cut
344
345    $self->add_func('log' => {
346        proxy => '*',
347        completion => sub { },
348        code => sub {
349            my $env = shift;
350            my @args = $self->getoption({
351                'o|object=s' => \my $otype,
352            }, @_);
353            $otype ||= 'user';
354
355            if (!@args && $env->Context->{objs}) {
356                @args = map { $_->id } @{ $env->Context->{objs} };
357                $otype = $env->Context->{objs}[0]->type;
358            }
359
360            my @logs = @args
361                ? $self->base->getobjectlogs($otype, @args)
362                : $self->base->getlogs();
363
364            foreach (@logs) {
365                $self->print(
366                    "%s (%d), %s: %s/%s (%d) %s\n",
367                    $_->{logdate},
368                    $_->{irev} || -1,
369                    $_->{username},
370                    $_->{otype},
371                    $_->{name},
372                    $_->{ikey},
373                    $_->{message}
374                );
375            }
376        },
377    } ) if ($self->base->can('getobjectlogs'));
378
379    if ($self->base->can('CreateAlias')) {
380
381=head2 OBJECT ALIASES FUNCTION
382
383=head3 newalias
384
385    newalias objectType Name Object
386
387Create an object alias named C<Name> for object C<Object>.
388
389=cut
390
391        $self->add_func(
392            'newalias', {
393                code => sub {
394                    my ($self, $otype, $name, $for) = @_;
395                    if ($self->base->CreateAlias($otype, $name, $for)) {
396                        $self->print( "Alias $otype/$name Created\n" );
397                        $self->commit;
398                    }
399                },
400                completion => sub {
401                    if ($_[3]) {
402                        return $_[0]->base->list_objects($_[2]);
403                    } elsif (!$_[2]) {
404                        return $_[0]->base->list_supported_objects;
405                    } else {
406                        return;
407                    }
408                }
409            },
410        );
411
412=head3 rmalias
413
414    rmalias objectType Name
415
416Delete alias named C<Name>.
417
418=cut
419
420        $self->add_func(
421            'rmalias', {
422                code => sub {
423                    my ($self, $otype, $name) = @_;
424                    if ($self->base->RemoveAlias($otype, $name)) {
425                        $self->print("Alias $otype/$name Removed\n");
426                        $self->commit;
427                    }
428                },
429                completion => sub {
430                    if (!$_[2]) {
431                        return $_[0]->base->list_supported_objects;
432                    } else {
433                        return $_[0]->base->search_objects($_[2], 'oalias=*');
434                    }
435                }
436            },
437        );
438
439=head3 updalias
440
441    updalias objectType Name Object
442
443Change the destination of an existing object alias
444
445=cut
446
447        $self->add_func(
448            'updalias', {
449                code => sub {
450                    my ($self, $otype, $name, $for) = @_;
451                    my $obj = $self->base->GetAlias($otype, $name) or do {
452                        $self->print( "No alias $otype/$name found" );
453                        return;
454                    };
455                    if ($obj->set_c_fields(oalias => $for)) {
456                        $self->print( "Alias $otype/$name Updated\n" );
457                        $self->commit;
458                    }
459                },
460                completion => sub {
461                    if ($_[3]) {
462                        return $_[0]->base->list_objects($_[2]);
463                    } elsif($_[2]) {
464                        return $_[0]->base->search_objects($_[2], 'oalias=*');
465                    } else {
466                        return $_[0]->base->list_supported_objects;
467                    }
468                }
469            },
470        );
471    }
472}
473
474=head2 base
475
476Return the attached base object.
477
478=cut
479
480sub La           { $_[0]->Context->La   }
481sub base         { $_[0]->Context->base }
482sub term         { $_[0]->Context->Term }
483sub Interractive { $_[0]->Context->Interactive }
484sub print        { shift->Context->print(@_) }
485
486sub Top {
487    my ( $self ) = @_;
488
489    if ($self->Parent) {
490        return $self->Parent->Top;
491    } else {
492        return $self;
493    }
494}
495
496=head2 cli
497
498Start the main loop
499
500=cut
501
502sub cli {
503    my ($self) = @_;
504
505    my $term = $_[0]->Context->Term;
506
507    while (1) {
508        $term->Attribs->{completion_function} = sub {
509            $self->complete($_[0], shellwords(substr($_[1], 0, $_[2])));
510        };
511        defined (my $line = $term->readline($self->prompt)) or do {
512            $self->print("\n");
513            return;
514        };
515        $_[0]->Context->{_line} = $line;
516        $term->addhistory($line) if ($line =~ /\S/);
517        my $res = $self->run(shellwords($line));
518        $self->rollback if (!$self->Context->TransMode);
519        if ($res && $res eq 'EXIT') { $self->print("\n"); return }
520    }
521}
522
523=head2 prompt
524
525Wait user to input command
526
527=cut
528
529sub promptPrefix { 'LA cli' }
530
531sub prompt {
532    my ($self) = @_;
533    my $pr = $self->promptPrefix;
534    return sprintf(
535        "%s%s%s ",
536        $pr,
537        $self->Context->TransStarted ? '-' : '=',
538        $self->Context->TransMode  ? '#' : '>',
539    );
540}
541
542=head2 add_func ($name, $param)
543
544Add new function in the envirronment
545
546=cut
547
548# TODO: hide this
549
550sub add_func {
551    my ($self, $name, $param) = @_;
552    my (undef, $file) = caller(0);
553    $param->{podfile} = $file;
554    $self->{funcs}{$name} = $param;
555}
556
557=head2 Help
558
559Display help of given function
560
561=cut
562
563sub Help {
564    my ($self, $name) = @_;
565    if (!$name) {
566        $self->print(join(', ', sort keys %{ $self->{funcs} || {}}) . "\n");
567    } elsif ($self->{funcs}{$name}{alias}) {
568        $self->print("$name is an alias for " . join(' ', @{$self->{funcs}{$name}{alias}}) . "\n");
569    } elsif ($self->{funcs}{$name}{help}) {
570        $self->print($self->{funcs}{$name}{help} . "\n");
571    } else {
572        my $fh = File::Temp->new();
573        my $parser = Pod::Text::Termcap->new( sentence => 0, width => 78 );
574
575        podselect(
576            {-output => $fh, -sections => ["CLI FUNCTIONS/.*/\Q$name"]},
577            $self->{funcs}{$name}{podfile}
578        );
579        seek($fh, 0, 0);
580        $parser->parse_from_filehandle($fh, $self->Context->Out);
581    }
582}
583
584=head2 getoption ($opt, @args)
585
586Parse commmand line
587
588=cut
589
590sub getoption {
591    my ($self, $opt, @args) = @_;
592    local @ARGV = @args;
593    Getopt::Long::Configure("pass_through");
594    GetOptions(%{ $opt });
595
596    return @ARGV;
597}
598
599=head2 complete
600
601Return possible words according current entered words
602
603=cut
604
605sub complete {
606    my ($self, $lastw, $name, @args) = @_;
607    if (!$name) {
608        $lastw ||= ''; # avoid undef warning
609        if ($lastw =~ m!^(\.\./*)(.*)$!) {
610            if ($self->Parent) {
611                my $dot = $1;
612                $dot .= '/' unless($dot =~ m!/$!);
613                return map { "$dot$_" } $self->Parent->complete($2, $name, @args);
614            } else {
615                return ();
616            }
617        } elsif ($lastw =~ m!(^/+)(.*)$!) {
618            return map { "$1$_" } $self->Top->complete($2, $name, @args);
619        } else {
620            return grep { /^\Q$lastw\E/ } sort
621                (keys %{ $self->{funcs} || {}});
622        }
623    } elsif ($name =~ m!^\.\./(.*)$!) {
624        if ($self->Parent) {
625            return $self->Parent->complete($lastw, $1, @args);
626        } else {
627            return ();
628        }
629    } elsif ($name =~ m!^/+(.*)$!) {
630        return $self->Top->complete($lastw, $1, @args);
631    } elsif ($self->{funcs}{$name}{alias}) {
632        $self->complete($lastw, @{$self->{funcs}{$name}{alias}}, @args);
633    } elsif ($self->{funcs}{$name}{completion}) {
634        return map { my $t = $_; $t =~ s/\s/\\ /g; $t } grep { $_ && /^\Q$lastw\E/ } $self->{funcs}{$name}{completion}->($self, $lastw, @args);
635    } else {
636        return ();
637    }
638}
639
640=head2 run ($name, @args)
641
642Run functions
643
644=cut
645
646sub run {
647    my ($self, $name, @args) = @_;
648    return if (!$name);
649
650    if ($name =~ m!^\.\./+(.*)$!) {
651        if ($self->Parent) {
652            $self->Parent->run($1, @args);
653        } else {
654            $self->print("No parent envirronment to call function\n");
655        }
656    } elsif ($name =~ m!^/+(.*)$!) {
657        $self->Top->run($1, @args);
658    } elsif (grep { m/^(-h|--help)$/ } @args) {
659        $self->Help($name);
660    } elsif (!exists($self->{funcs}{$name})) {
661        $self->print("No command $name found\n");
662    } elsif ($self->{funcs}{$name}{alias}) {
663        $self->run(@{$self->{funcs}{$name}{alias}}, @args);
664    } elsif ($self->{funcs}{$name}{code}) {
665        $self->{funcs}{$name}{code}->($self, @args);
666    } else {
667        $self->print("No command $name found\n");
668    }
669}
670
671=head2 commit
672
673Call commit to base unelss in transaction mode
674
675=cut
676
677sub commit {
678    my ($self) = @_;
679    $self->Context->commit;
680}
681
682sub _commit {
683    my ($self) = @_;
684    $self->Context->_commit;
685}
686
687=head2 rollback
688
689Perform rollback unless in transaction mode
690
691=cut
692
693sub rollback {
694    my ($self) = @_;
695    $self->Context->rollback;
696}
697
698sub _rollback {
699    my ($self) = @_;
700    $self->Context->_rollback;
701}
702
7031;
704
705__END__
706
707=head1 SEE ALSO
708
709L<LATMOS::Accounts>
710
711=head1 AUTHOR
712
713Olivier Thauvin, E<lt>olivier.thauvin@latmos.ipsl.frE<gt>
714
715=head1 COPYRIGHT AND LICENSE
716
717Copyright (C) 2008, 2009, 2010, 2011, 2012 CNRS SA/CETP/LATMOS
718
719This library is free software; you can redistribute it and/or modify
720it under the same terms as Perl itself, either Perl version 5.10.0 or,
721at your option, any later version of Perl 5 you may have available.
722
723=cut
Note: See TracBrowser for help on using the repository browser.