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

Last change on this file was 2599, checked in by nanardon, 3 months ago

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