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

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

la-cli: add collection command (save object list)
File size: 23.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(
97                            "%s   %s%s\n",
98                            ($attr ? ($attr->ro ? 'r ' : 'rw') : '  '),
99                            $_,
100                            $attr->reference ? ' (=> ' . $attr->reference . ')' : '',
101                        );
102                    }
103                } else {
104                    $self->print("Supported objects type: ");
105                    $self->print(join(', ', $self->base->list_supported_objects));
106                    $self->print("\n");
107                }
108            } else {
109                $self->print("wrong argument\n");
110            }
111        },
112    });
113
114=head3 unexported
115
116    unexported yes|no|show
117
118switch or show base mode regarding' unexported objects behavior
119
120=cut
121
122    $self->add_func('unexported', {
123        completion => sub {
124            if (!$_[2]) {
125                return qw(yes no show);
126            }
127        },
128        code => sub {
129            my ($self, $arg) = @_;
130            if (!$arg) {
131                $self->print( "Unexported objects is" . 
132                    ($self->base->unexported ? "enable" : "disable") . "\n"
133                );
134            } elsif ($arg eq 'yes') {
135                $self->base->unexported(1);
136                $self->print("Unexported are now show\n");
137            } elsif ($arg eq 'no') {
138                $self->base->unexported(0);
139                $self->print("Unexported are no longer show\n");
140            } elsif ($arg eq 'show') {
141                $self->print("Unexported objects is" .
142                    ($self->base->unexported ? "enable" : "disable") . "\n"
143                );
144            } else {
145                $self->print("wrong argument\n");
146            }
147        },
148    });
149
150=head3 quit
151
152Exit from C<CLI> tools
153
154=cut
155
156    $self->add_func('quit', {
157            code => sub { $self->print("\n"); exit(0) }, });
158
159=head3 exit
160
161Exit from current selection context
162
163=cut
164
165    $self->add_func('exit', {
166            code => sub { return "EXIT" }, });
167
168=head3 !
169
170    ! [command [arg]]
171
172Open a shell command or run command under shell
173
174=cut
175
176    $self->add_func('!', {
177            code => sub {
178                my ($env, $name, @args) = @_;
179                if ($name) {
180                    system('/bin/bash', '-ic', $env->Context->{_line});
181                } else {
182                    system('/bin/bash', '-i');
183                }
184            },
185    } );
186
187    if ($self->base->is_transactionnal) {
188
189=head2 TRANSACTIONS FUNCTIONS
190
191    transaction [on|off]
192
193Enable or disable the transaction mode: ie automatic commit
194
195=cut
196
197        $self->add_func(
198            'transaction', {
199                code => sub {
200                    $self->Context->TransMode($_[1] eq 'on' ? 1 : 0);
201                },
202                completion => sub {
203                    $self->Context->TransMode == 0 ? 'on' : 'off';
204                },
205            }
206        );
207
208=head3 begin
209
210Start a transaction, meaning changes will be saved only by C<commit> and canceled by C<rollback>
211
212=cut
213
214        $self->add_func(
215            'begin', {
216                code => sub {
217                    $self->Context->TransStarted(1);
218                },
219            }
220        );
221
222=head3 commit
223
224Save pending changes in transaction mode or following C<begin>
225
226=cut
227
228        $self->add_func(
229            'commit', {
230                code => sub {
231                    $_[0]->_commit;
232                },
233            }
234        );
235
236=head3 rollback
237
238Cancel pending changes following a C<begin> or in transaction mode
239
240=cut
241
242        $self->add_func(
243            'rollback', {
244                code => sub {
245                    $_[0]->_rollback;
246                },
247            }
248        );
249    }
250
251=head3 collection
252
253Manage saved objects list:
254
255    collection list
256    collection save
257    collection load
258    collection delete
259
260=cut
261
262    $self->add_func( 'collection',
263        {
264            code => sub {
265                my ( $self, $subcommand, @args ) = @_;
266                $subcommand ||= '';
267                $self->Context->Preferences->{Collections} ||= {};
268                my $Collections = $self->Context->Preferences->{Collections};
269                if ( $subcommand eq 'list' || !$subcommand ) {
270                    foreach my $c ( sort keys %{ $Collections } ) {
271                        my @objlist = @{ $Collections->{$c}{objs} || []};
272                        $self->printf(
273                            "%s: %s, %s\n",
274                            $c,
275                            $Collections->{$c}{otype},
276                            (@objlist >= 1 ? scalar(@objlist) . ' objs.' : $objlist[0]),
277                        );
278                    }
279                } elsif ($subcommand eq 'load') {
280                    my $c = $args[0] or do {
281                        $self->print("No collection name given\n");
282                        return;
283                    };
284                    if (! $Collections->{$c} ) {
285                        $self->print("This collection does not exists\n");
286                        return;
287                    }
288                    my $otype = $Collections->{ $c }{otype};
289                    my @objs;
290                    foreach (@{ $Collections->{ $c }{ objs } || []}) {
291                        my $obj = $self->base->get_object($otype, $_) or do {
292                            $self->print("Cannot get $otype $_\n");
293                            return;
294                        };
295                        push(@objs, $obj);
296                    }
297                    if (@objs) {
298                        $self->print("Selecting $otype " . join(', ', map { $_->id } @objs) . "\n");
299                        LATMOS::Accounts::Cli::Object->new(
300                            Parent  => $self,
301                            Context => $self->Context,
302                            otype   => $otype,
303                            objs    => \@objs,
304                        )->cli();
305                    } else {
306                        $self->print("No objects to load\n");
307                    }
308                } elsif ($subcommand eq 'clear') {
309                    $self->Context->Preferences->{Collections} = {};
310                } elsif ($subcommand =~ m/^(delete|del)$/) {
311                    my ( $name ) = @args;
312                    delete( $Collections->{$name} );
313                } elsif ($subcommand eq 'save' ) {
314                    my ( $name, $what ) = @args;
315                    $what ||= '';
316
317                    if ( $what eq '@' ) {
318                        if (! $self->{_lastsearch} ) {
319                            $self->print("No previous search found, nothing saved\n");
320                            return;
321                        }
322                        $Collections->{ $name } = {
323                            otype => $self->{_lastsearchtype},
324                            objs =>  [ @{$self->{_lastsearch}} ],
325                        }
326                    } elsif ($self->can('otype')) {
327                        $Collections->{ $name } = {
328                            otype => $self->otype,
329                            objs =>  [ map { $_->id } @{ $self->objs || [] } ],
330                        };
331                    } else {
332                        $self->print("No objects to save");
333                    }
334                }
335            },
336            completion => sub {
337                my ($self, undef, $command, $name, $what) = @_;
338                $command ||= '';
339                my $Collections = $self->Context->Preferences->{Collections} || {};
340                if ( ! $command ) {
341                    return qw(list load save delete clear);
342                } elsif ( $command =~ /^(load|delete|del)$/ ) {
343                    return sort keys %{ $Collections };
344                } elsif ( $command eq 'save' ) {
345                    if ($name) {
346                        return qw( @ );
347                    }
348                } else {
349                    return;
350                }
351            },
352        }
353    );
354
355=head2 GLOBAL and OBJECTS FUNCTION
356
357=head3 query
358
359    query objectname [attribute]
360    query [attribute]
361
362Show attribute
363
364options:
365
366=over 4
367
368=item -o|--otype objecttype
369
370In global context specify the object type (default: user)
371
372=item -e|--empty
373
374Show empty/unset attributes
375
376=item --ro
377
378Show readonly attributes
379
380=item --fmt format
381
382Instead displaying attribute list use C<format> as formating string
383
384=item --recur
385
386Dump object and all related objects
387
388=back
389
390=cut
391
392    $self->add_func( 'query' => {
393            proxy => '*',
394            completion => sub { },
395            code => sub {
396                my $env = shift;
397                my @args = $self->getoption(
398                    {
399                        'o|object=s' => \my $otype,
400                        'e|empty'    => \my $empty_attr,
401                        'ro'         => \my $with_ro,
402                        'fmt=s'      => \my $fmt,
403                        'filefmt=s'  => \my $filefmt,
404                        'recur'      => \my $recur,
405                        'subotype=s' => \my @SubOtype,
406                    }, @_
407                );
408                $otype ||= 'user';
409
410                my $objs = $self->Context->{objs};
411
412                if (! $objs ) {
413                    foreach my $name (@args) {
414                        my $obj = $self->base->get_object( $otype, $name) or do {
415                            $self->print("Cannot get object $otype/$name\n");
416                            next;
417                        };
418                        push(@{ $objs }, $obj);
419                    }
420                }
421
422                if ($filefmt){
423                    open(my $hfmt, '<', $filefmt) or die "Cannot open $filefmt\n";
424                    $fmt ||= ''; # avoid undef warning
425                    while (<$hfmt>) {
426                        chomp($fmt .= $_);
427                    }
428                    close $hfmt;
429                }
430
431                foreach (@{ $objs }) {
432                    if ($fmt) {
433                        $self->print($_->queryformat($fmt));
434                    } else {
435                        $_->text_dump( $self->Context->Out, {
436                            recur => $recur,
437                            empty_attr => $empty_attr,
438                            only_rw => !$with_ro,
439                            SubOtype => \@SubOtype,
440                        } );
441                    }
442                }
443            },
444    } );
445
446=head3 log
447
448    log [[-o otype ] object [object [...]]]
449
450Show global log or log for the object given in arguments
451
452=cut
453
454    $self->add_func('log' => {
455        proxy => '*',
456        completion => sub { },
457        code => sub {
458            my $env = shift;
459            my @args = $self->getoption({
460                'o|object=s' => \my $otype,
461            }, @_);
462            $otype ||= 'user';
463
464            if (!@args && $env->Context->{objs}) {
465                @args = map { $_->id } @{ $env->Context->{objs} };
466                $otype = $env->Context->{objs}[0]->type;
467            }
468
469            my @logs = @args
470                ? $self->base->getobjectlogs($otype, @args)
471                : $self->base->getlogs();
472
473            foreach (@logs) {
474                $self->print(
475                    "%s (%d), %s: %s/%s (%d) %s\n",
476                    $_->{logdate},
477                    $_->{irev} || -1,
478                    $_->{username},
479                    $_->{otype},
480                    $_->{name},
481                    $_->{ikey},
482                    $_->{message}
483                );
484            }
485        },
486    } ) if ($self->base->can('getobjectlogs'));
487
488    if ($self->base->can('CreateAlias')) {
489
490=head2 OBJECT ALIASES FUNCTION
491
492=head3 newalias
493
494    newalias objectType Name Object
495
496Create an object alias named C<Name> for object C<Object>.
497
498=cut
499
500        $self->add_func(
501            'newalias', {
502                code => sub {
503                    my ($self, $otype, $name, $for) = @_;
504                    if ($self->base->CreateAlias($otype, $name, $for)) {
505                        $self->print( "Alias $otype/$name Created\n" );
506                        $self->commit;
507                    }
508                },
509                completion => sub {
510                    if ($_[3]) {
511                        return $_[0]->base->list_objects($_[2]);
512                    } elsif (!$_[2]) {
513                        return $_[0]->base->list_supported_objects;
514                    } else {
515                        return;
516                    }
517                }
518            },
519        );
520
521=head3 rmalias
522
523    rmalias objectType Name
524
525Delete alias named C<Name>.
526
527=cut
528
529        $self->add_func(
530            'rmalias', {
531                code => sub {
532                    my ($self, $otype, $name) = @_;
533                    if ($self->base->RemoveAlias($otype, $name)) {
534                        $self->print("Alias $otype/$name Removed\n");
535                        $self->commit;
536                    }
537                },
538                completion => sub {
539                    if (!$_[2]) {
540                        return $_[0]->base->list_supported_objects;
541                    } else {
542                        return $_[0]->base->search_objects($_[2], 'oalias=*');
543                    }
544                }
545            },
546        );
547
548=head3 updalias
549
550    updalias objectType Name Object
551
552Change the destination of an existing object alias
553
554=cut
555
556        $self->add_func(
557            'updalias', {
558                code => sub {
559                    my ($self, $otype, $name, $for) = @_;
560                    my $obj = $self->base->GetAlias($otype, $name) or do {
561                        $self->print( "No alias $otype/$name found" );
562                        return;
563                    };
564                    if ($obj->set_c_fields(oalias => $for)) {
565                        $self->print( "Alias $otype/$name Updated\n" );
566                        $self->commit;
567                    }
568                },
569                completion => sub {
570                    if ($_[3]) {
571                        return $_[0]->base->list_objects($_[2]);
572                    } elsif($_[2]) {
573                        return $_[0]->base->search_objects($_[2], 'oalias=*');
574                    } else {
575                        return $_[0]->base->list_supported_objects;
576                    }
577                }
578            },
579        );
580    }
581}
582
583=head2 base
584
585Return the attached base object.
586
587=cut
588
589sub La           { $_[0]->Context->La   }
590sub base         { $_[0]->Context->base }
591sub term         { $_[0]->Context->Term }
592sub Interractive { $_[0]->Context->Interactive }
593sub print        { shift->Context->print (@_) }
594sub printf       { shift->Context->printf(@_) }
595
596sub Top {
597    my ( $self ) = @_;
598
599    if ($self->Parent) {
600        return $self->Parent->Top;
601    } else {
602        return $self;
603    }
604}
605
606sub Traverse {
607    my ( $self, $Before, $After ) = @_;
608
609    $Before->($self) if ($Before);
610    if ($self->Parent) {
611        $self->Parent->Traverse($Before, $After);
612    }
613    $After->($self) if ($After);
614}
615
616sub _parse_cmd_line {
617    my ( $self, $cmdLine ) = @_;
618
619    my ($op, $shellLine, $internalLine);
620
621    if ($cmdLine =~ /^(.*?)(?<![\S\\|])([\|\>])\s*([^\|].*)?$/) {
622        $internalLine = $1;
623        $op = $2;
624        $shellLine = $3;
625    } else {
626        $internalLine = $cmdLine;
627    }
628
629    return ( $op, $shellLine, shellwords($internalLine) );
630
631}
632
633=head2 topCli
634
635Entry point for cli
636
637=cut
638
639sub topCli {
640    my ( $self ) = @_;
641
642    $self->Context->ReadHistory();
643    $self->Context->ReadPreferences();
644    $self->cli();
645    if (! $self->Context->WriteHistory() ) {
646        warn "Cannot write history:  $!\n";
647    }
648    $self->Context->WritePreferences();
649}
650
651=head2 cli
652
653Start the main loop
654
655=cut
656
657sub cli {
658    my ($self) = @_;
659
660    my $term = $_[0]->Context->Term;
661
662    while (1) {
663        $term->Attribs->{completion_function} = sub {
664            my ($Op, $Shell, @args) = $self->_parse_cmd_line(substr($_[1], 0, $_[2]));
665            $Op ||= '';
666            my $attribs = $self->Context->Term->Attribs;
667            if ($Op eq '>') {
668                $term->completion_matches($Shell, $attribs->{'filename_completion_function'});
669            } elsif ($Op eq '|') {
670                $term->completion_matches($Shell, $attribs->{'filename_completion_function'});
671            } else  {
672                $self->complete($_[0], @args);
673            }
674        };
675        defined (my $line = $term->readline($self->prompt)) or do {
676            $self->print("\n");
677            return;
678        };
679        $_[0]->Context->{_line} = $line;
680        $term->addhistory($line) if ($line =~ /\S/);
681        my ($Op, $Shell, @args) = $self->_parse_cmd_line($line);
682        my $Handle;
683        if ($Op) {
684            open($Handle, "$Op $Shell") or next;
685            $self->Context->TempOut($Handle);
686        }
687        my $res = $self->run(@args);
688        if ($Handle) {
689            $self->Context->TempOut(undef);
690            close($Handle);
691        }
692        $self->rollback if (!$self->Context->TransMode);
693        if ($res && $res eq 'EXIT') { $self->print("\n"); return }
694    }
695}
696
697=head2 prompt
698
699Wait user to input command
700
701=cut
702
703sub promptPrefix {
704    my $self = shift;
705    return sprintf('%s cli', $self->base->label)
706}
707
708sub prompt {
709    my ($self) = @_;
710    my $pr = $self->promptPrefix;
711    return sprintf(
712        "%s%s%s ",
713        $pr,
714        $self->Context->TransStarted ? '-' : '=',
715        $self->Context->TransMode  ? '#' : '>',
716    );
717}
718
719=head2 add_func ($name, $param)
720
721Add new function in the envirronment
722
723=cut
724
725# TODO: hide this
726
727sub add_func {
728    my ($self, $name, $param) = @_;
729    my (undef, $file) = caller(0);
730    $param->{podfile} = $file;
731    $self->{funcs}{$name} = $param;
732}
733
734=head2 Help
735
736Display help of given function
737
738=cut
739
740sub Help {
741    my ($self, $name) = @_;
742    if (!$name) {
743        $self->print(join(', ', sort keys %{ $self->{funcs} || {}}) . "\n");
744    } elsif ($self->{funcs}{$name}{alias}) {
745        $self->print("$name is an alias for " . join(' ', @{$self->{funcs}{$name}{alias}}) . "\n");
746    } elsif ($self->{funcs}{$name}{help}) {
747        $self->print($self->{funcs}{$name}{help} . "\n");
748    } else {
749        my $fh = File::Temp->new();
750        my $parser = Pod::Text::Termcap->new( sentence => 0, width => 78 );
751
752        podselect(
753            {-output => $fh, -sections => ["CLI FUNCTIONS/.*/\Q$name"]},
754            $self->{funcs}{$name}{podfile}
755        );
756        seek($fh, 0, 0);
757        $parser->parse_from_filehandle($fh, $self->Context->Out);
758    }
759}
760
761=head2 getoption ($opt, @args)
762
763Parse commmand line
764
765=cut
766
767sub getoption {
768    my ($self, $opt, @args) = @_;
769    local @ARGV = @args;
770    Getopt::Long::Configure("pass_through");
771    GetOptions(%{ $opt });
772
773    return @ARGV;
774}
775
776=head2 complete
777
778Return possible words according current entered words
779
780=cut
781
782sub complete {
783    my ($self, $lastw, $name, @args) = @_;
784    if (!$name) {
785        $lastw ||= ''; # avoid undef warning
786        if ($lastw =~ m!^(\.\./*)(.*)$!) {
787            if ($self->Parent) {
788                my $dot = $1;
789                $dot .= '/' unless($dot =~ m!/$!);
790                return map { "$dot$_" } $self->Parent->complete($2, $name, @args);
791            } else {
792                return ();
793            }
794        } elsif ($lastw =~ m!(^/+)(.*)$!) {
795            return map { "$1$_" } $self->Top->complete($2, $name, @args);
796        } else {
797            return grep { /^\Q$lastw\E/ } sort
798                (keys %{ $self->{funcs} || {}});
799        }
800    } elsif ($name =~ m!^\.\./(.*)$!) {
801        if ($self->Parent) {
802            return $self->Parent->complete($lastw, $1, @args);
803        } else {
804            return ();
805        }
806    } elsif ($name =~ m!^/+(.*)$!) {
807        return $self->Top->complete($lastw, $1, @args);
808    } elsif ($self->{funcs}{$name}{alias}) {
809        $self->complete($lastw, @{$self->{funcs}{$name}{alias}}, @args);
810    } elsif ($self->{funcs}{$name}{completion}) {
811        return map { my $t = $_; $t =~ s/\s/\\ /g; $t } grep { $_ && /^\Q$lastw\E/ } $self->{funcs}{$name}{completion}->($self, $lastw, @args);
812    } else {
813        return ();
814    }
815}
816
817=head2 run ($name, @args)
818
819Run functions
820
821=cut
822
823sub run {
824    my ($self, $name, @args) = @_;
825    return if (!$name);
826
827    if ($name =~ m!^\.\./+(.*)$!) {
828        if ($self->Parent) {
829            $self->Parent->run($1, @args);
830        } else {
831            $self->print("No parent envirronment to call function\n");
832        }
833    } elsif ($name =~ m!^/+(.*)$!) {
834        $self->Top->run($1, @args);
835    } elsif (grep { m/^(-h|--help)$/ } @args) {
836        $self->Help($name);
837    } elsif (!exists($self->{funcs}{$name})) {
838        $self->print("No command $name found\n");
839    } elsif ($self->{funcs}{$name}{alias}) {
840        $self->run(@{$self->{funcs}{$name}{alias}}, @args);
841    } elsif ($self->{funcs}{$name}{code}) {
842        $self->{funcs}{$name}{code}->($self, @args);
843    } else {
844        $self->print("No command $name found\n");
845    }
846}
847
848=head2 commit
849
850Call commit to base unelss in transaction mode
851
852=cut
853
854sub commit {
855    my ($self) = @_;
856    $self->Context->commit;
857}
858
859sub _commit {
860    my ($self) = @_;
861    $self->Context->_commit;
862}
863
864=head2 rollback
865
866Perform rollback unless in transaction mode
867
868=cut
869
870sub rollback {
871    my ($self) = @_;
872    $self->Context->rollback;
873}
874
875sub _rollback {
876    my ($self) = @_;
877    $self->Context->_rollback;
878}
879
8801;
881
882__END__
883
884=head1 SEE ALSO
885
886L<LATMOS::Accounts>
887
888=head1 AUTHOR
889
890Olivier Thauvin, E<lt>olivier.thauvin@latmos.ipsl.frE<gt>
891
892=head1 COPYRIGHT AND LICENSE
893
894Copyright (C) 2008, 2009, 2010, 2011, 2012 CNRS SA/CETP/LATMOS
895
896This library is free software; you can redistribute it and/or modify
897it under the same terms as Perl itself, either Perl version 5.10.0 or,
898at your option, any later version of Perl 5 you may have available.
899
900=cut
Note: See TracBrowser for help on using the repository browser.