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

Last change on this file since 1315 was 1313, checked in by nanardon, 9 years ago

Fix call to rollback
  • Property svn:keywords set to Id
File size: 29.9 KB
Line 
1package LATMOS::Accounts::Cli;
2
3# $Id$
4
5use strict;
6use warnings;
7use LATMOS::Accounts::Log;
8use LATMOS::Accounts::Utils;
9use Term::ReadLine;
10use Text::ParseWords;
11use Getopt::Long;
12
13=head1 NAME
14
15LATMOS::Accounts::Cli - Command line interface functions
16
17=head1 DESCRIPTION
18
19This module handle envirronment and functons for L<la-cli> tools.
20
21=cut
22
23{
24    open (my $fh, "/dev/tty" )
25        or eval 'sub Term::ReadLine::findConsole { ("&STDIN", "&STDERR") }';
26    die $@ if $@;
27    close ($fh);
28}
29
30my $term = Term::ReadLine->new('LA CLI');
31$term->MinLine(99999);
32my $OUT = $term->OUT || \*STDOUT;
33
34my $trans_mode = 0;
35
36=head1 FUNCTIONS
37
38=cut
39
40=head2 globalenv
41
42Return the main envirronement object
43
44=cut
45
46sub globalenv {
47    my ($labase) = @_;
48    my $env = LATMOS::Accounts::Cli->new({ prompt => sub { $_[0]->base->label . " cli > " }, },
49        $labase);
50    $env->add_func('unexported', {
51        help => 'unexported yes|no|show - switch or show base mode regarding' .
52            ' unexported objects',
53        completion => sub {
54            if (!$_[2]) {
55                return qw(yes no show);
56            }
57        },
58        code => sub {
59            my ($env, $arg) = @_;
60            if ($arg eq 'yes') {
61                $env->base->unexported(1);
62                print $OUT "Unexported are now show\n";
63            } elsif ($arg eq 'no') {
64                $env->base->unexported(0);
65                print $OUT "Unexported are no longer show\n";
66            } elsif ($arg eq 'show') {
67                print $OUT "Unexported objects " . ($env->base->unexported ?
68                "enable" : "disable") . "\n";
69            } else {
70                print $OUT "wrong argument\n";
71            }
72        },
73    });
74    $env->add_func('ls', {
75            help => 'ls object_type - list object of type object_type', 
76            completion => sub {
77                if(!$_[2]) {
78                    return $_[0]->base->list_supported_objects
79                } else { () }
80            },
81            code => sub {
82                if ($_[1]) {
83                    print $OUT map { "$_\n" } $_[0]->base->list_objects($_[1]);
84                } else {
85                    print $OUT "Object type missing\n";
86                }
87            },
88        });
89    $env->add_func('search', {
90            help => 'search objecttype filter1 [filter2...] - search object according filter',
91            completion => sub {
92                if(!$_[2]) {
93                    return $_[0]->base->list_supported_objects
94                } else { return() }
95            },
96            code => sub {
97                my ($env, @args) = @_;
98                if ($_[1]) {
99                    my @res = $env->base->search_objects(@args);
100                    print $OUT map { "$_\n" } @res;
101                    $env->{_lastsearch} = \@res;
102                    $env->{_lastsearchtype} = $args[0];
103                } else {
104                    print $OUT "Object type missing\n";
105                }
106            },
107        });
108    $env->add_func('expired', {
109        help => 'expired [delay] - list expired account more than delay (default is now)',
110        code => sub {
111            my ($env, $expire) = @_;
112            my @users = $env->base->find_expired_users($expire);
113            print $OUT map { "$_\n" } @users;
114            $env->{_lastsearchtype} = 'user';
115            $env->{_lastsearch} = \@users;
116        },
117    }) if ($env->base->can('find_expired_users'));
118    $env->add_func('expires', {
119        help => 'expires [delay] - list account expiring before delay (default is 1 month)',
120        code => sub {
121            my ($env, $expire) = @_;
122            my @users = $env->base->find_next_expire_users($expire);
123            print $OUT map { "$_\n" } @users;
124            $env->{_lastsearchtype} = 'user';
125            $env->{_lastsearch} = \@users;
126        },
127    }) if ($env->base->can('find_next_expire_users'));
128    $env->add_func('select', {
129            help => 'select object_type - select objects to perform action on it',
130            completion => sub {
131                if ($_[2]) {
132                    return $_[0]->base->list_objects($_[2]);
133                } else {
134                    return '@', $_[0]->base->list_supported_objects;
135                }
136            },
137            code => sub {
138                my ($env, $otype, @ids) = @_;
139                my @objs;
140                if ($otype eq '@') {
141                    if (@{$env->{_lastsearch}}) {
142                        $otype = $env->{_lastsearchtype};
143                        @ids = @{$env->{_lastsearch}};
144                    } else {
145                        print $OUT "No results store from previous search\n";
146                        return;
147                    }
148                }
149                if (!@ids) {
150                    print $OUT 'not enough arguments' . "\n";
151                    return;
152                }
153                foreach (@ids) {
154                    my $obj = $env->base->get_object($otype, $_) or do {
155                        print $OUT "Cannot get $otype $_\n";
156                        return;
157                    };
158                    push(@objs, $obj);
159                }
160                print $OUT "Selecting $otype " . join(', ', @ids) . "\n";
161                objenv($_[0]->base, $otype, @objs)->cli();
162            },
163        });
164    $env->add_func('create', {
165            code => sub {
166                my ($env, $otype) = @_;
167                my $helper = $env->base->ochelper($otype);
168                my $info = undef;
169                while (1) {
170                    my $status;
171                    ($status, $info) = $helper->step($info);
172
173                    if ($status ne 'NEEDINFO') {
174                        if ($status eq 'CREATED') {
175                            print $OUT "Object created\n";
176                            $env->commit;
177                        } else {
178                            print $OUT "Nothing done\n";
179                            $env->rollback;
180                        }
181                        return;
182                    }
183
184                    if ($info->{name}{ask}) {
185                        my $line = $term->readline("Name of the object ?");
186                        $info->{name}{content} = $line;
187                    }
188                    foreach my $attr (@{$info->{ask} || []}) {
189                        $term->Attribs->{completion_function} = sub {
190                            $info->{contents}{$attr}
191                        };
192                        my $line = $term->readline(sprintf('  %s %s? ',
193                                $attr,
194                                $info->{contents}{$attr}
195                                ? '(' . $info->{contents}{$attr} . ') '
196                                : ''
197                            ));
198                        $info->{contents}{$attr} = $line if($line);
199                    }
200                }
201            },
202        }
203    );
204    $env->add_func('exchangeip', 
205        {
206            help => 'Exchange two IP on host',
207            code => sub {
208                my ($env, @args) = @_;
209                my ($ip1, $ip2) =
210                    grep { $_ && $_ =~ /\d+\.\d+\.\d+\.\d+/ } @args;
211                if (!$ip2) {
212                    print $OUT "Need two ip to exchange\n";
213                    return;
214                }
215                if ($env->base->nethost_exchange_ip($ip1, $ip2)) {
216                    print $OUT "$ip1 and $ip2 get exchange\n";
217                    $env->commit;
218                } else {
219                    $env->rollback;
220                }   
221            },
222            completion => sub {
223                my ($env, $carg, @args) = @_;
224                if ($args[-1] && $args[-1] !~ m/\d+\.\d+\.\d+\.\d+/) {
225                    if (my $obj = $env->base->get_object('nethost', $args[-1])) {
226                        return $obj->get_attributes('ip');
227                    }
228                } else {
229                    my @list = 
230                    ($env->base->attributes_summary('nethost', 'ip'),
231                        $env->base->list_objects('nethost'));
232                    return @list;
233                }
234            },
235        }
236    );
237    $env->add_func('user',  { alias => [qw'select user' ] });
238    $env->add_func('group', { alias => [qw'select group'] });
239    return $env
240}
241
242=head2 objenv ($labase, $otype, @objs)
243
244Return a C<cli> envirronment over object.
245
246=cut
247
248sub objenv {
249    my ($labase, $otype, @objs) = @_;
250    my $objenv = LATMOS::Accounts::Cli->new(
251        {
252            prompt => sub {
253                sprintf("%s %s/%s > ",
254                    $_[0]->base->label,
255                    $_[0]->{_otype},
256                    @{$_[0]->{_objects}} > 1 ? '(' .
257                    scalar(@{$_[0]->{_objects}}) . ' obj.)' : $_[0]->{_objects}[0]->id,
258                );
259            },
260        },
261        $labase
262    );
263    $objenv->{_otype} = $otype;
264    $objenv->{_objects} = [ @objs ];
265    $objenv->add_func('+', {
266        help => 'add item to selection',
267        code => sub {
268            my ($env, @ids) = @_;
269            my %ids = map { $_->id => 1 } @{$env->{_objects}};
270            foreach (@ids) {
271                $ids{$_} and next;
272                my $o = $env->base->get_object($env->{_otype}, $_) or next;
273                push(@{$env->{_objects}}, $o);
274            }
275            printf $OUT "select is now %s: %s\n", $env->{_otype}, join(', ', map {
276                $_->id } @{$env->{_objects}});
277        },
278        completion => sub {
279            my ($env, undef, @ids) = @_;
280            my %ids = map { $_->id => 1 } @{$env->{_objects}};
281            return ( grep { ! $ids{$_} } $env->base->list_objects($env->{_otype}));
282        },
283        }
284    );
285    $objenv->add_func('-', {
286        help => 'add item to selection',
287        code => sub {
288            my ($env, @ids) = @_;
289            my %ids = map { $_ => 1 } @ids;
290            my @newobjs = grep { !$ids{$_->id} } @{$env->{_objects}};
291
292            if (!@newobjs) {
293                print $OUT "This would remove all objects from the list...\n";
294                return;
295            } else {
296                @{$env->{_objects}} = @newobjs;
297            }
298            printf $OUT "select is now %s: %s\n", $env->{_otype}, join(', ', map {
299                $_->id } @{$env->{_objects}});
300        },
301        completion => sub {
302            my ($env, undef, @ids) = @_;
303            my %ids = map { $_ => 1 } @ids;
304            grep { !$ids{$_} } map { $_->id } @{$env->{_objects}};
305        },
306        }
307    );
308    $objenv->add_func('show', {
309        help => 'show attributes - show an attributes of object',
310        code => sub {
311            my ($env, $attr) = @_;
312            if (!$attr) {
313                foreach (@{$env->{_objects}}) {
314                    print $OUT $_->dump;
315                }
316            } else {
317                foreach my $u (@{$env->{_objects}}) {
318                    print $OUT sort map { $u->id . ': ' .($_ || '') . "\n" } $u->get_attributes($attr);
319                }
320            }
321        },
322        completion => sub {
323            if (!$_[2]) {
324                return $_[0]->base->list_canonical_fields($_[0]->{_otype}, 'r')
325            }
326        },
327    });
328    $objenv->add_func('print', {
329        help => 'print fmt - show attributes using template',
330        code => sub {
331            my ($env, $fmt) = @_;
332            if (!defined($fmt)) {
333                print $OUT "no format given";
334                return;
335            }
336            foreach (@{$env->{_objects}}) {
337                print $OUT $_->queryformat($fmt) . "\n";
338            }
339        },
340    });
341    $objenv->add_func('unset', {
342        help => 'unset attribute - unset specified attribute',
343        code => sub {
344            my ($env, $attr) = @_;
345            $attr or do {
346                print $OUT "Attributes must be specified";
347                return;
348            };
349            foreach (@{$env->{_objects}}) {
350                defined $_->set_c_fields($attr => undef) or do {
351                    print $OUT "cannot unset attributes $attr for " . $_->id .
352                    "\n";
353                    return;
354                };
355            }
356            $env->commit;
357            print $OUT "Changes applied\n";
358        },
359        completion => sub {
360            my ($env, $lastw, @args) = @_;
361            if (!$args[0]) {
362                return $env->base->list_canonical_fields($env->{_otype}, 'w')
363            }
364        },
365    });
366    $objenv->add_func('set', {
367        help => 'set attribute value - set an attributes to single value "value"',
368        code => sub {
369            my ($env, $attr, @value) = @_;
370            @value or do {
371                print $OUT "attribute and value must be specified\n";
372                return;
373            };
374            foreach (@{$env->{_objects}}) {
375                defined $_->set_c_fields($attr => @value <= 1 ? $value[0] :
376                    \@value) or do {
377                    $_->base->rollback;
378                    printf $OUT "Cannot set $attr to %s for %s\n", join(', ',
379                        @value), $_->id;
380                    return;
381                };
382            }
383            $env->commit;
384            print $OUT "Done.\n";
385        },
386        completion => sub {
387            my ($env, $lastw, @args) = @_;
388            if (!$args[0]) {
389                return $env->base->list_canonical_fields($env->{_otype}, 'w')
390            } else {
391                my $attr = $env->base->attribute($env->{_otype}, $args[0]);
392                if ($attr->has_values_list) {
393                    $attr->can_values;
394                } elsif (@{$env->{_objects}} == 1) {
395                    return
396                    $env->{_objects}[0]->get_attributes($args[0]);
397                }
398            }
399        },
400    });
401    $objenv->add_func('add', {
402        help => 'add a value to an attribute',
403        code => sub {
404            my ($env, $attr, @value) = @_;
405            @value or do {
406                print $OUT "attribute and value must be specified\n";
407                return;
408            };
409            foreach (@{$env->{_objects}}) {
410                my @attrv = grep { $_ } $_->get_attributes($attr);
411                defined $_->set_c_fields($attr => [ @attrv, @value ]) or do {
412                    $_->base->rollback;
413                    printf $OUT "Cannot set $attr to %s for %s\n", join(', ',
414                        @value), $_->id;
415                    return;
416                };
417            }
418            $env->commit;
419            print $OUT "done\n";
420        },
421        completion => sub {
422            my ($env, $lastw, @args) = @_;
423            if (!$args[0]) {
424                return grep {
425                    $env->base->attribute($env->{_otype}, $_)->{multiple}
426                } $env->base->list_canonical_fields($env->{_otype}, 'w')
427            } else {
428                my $attr = $env->base->attribute($env->{_otype}, $args[0]);
429                if ($attr->has_values_list) {
430                    $attr->can_values;
431                } elsif (@{$env->{_objects}} == 1) {
432                    return
433                    $env->{_objects}[0]->get_attributes($args[0]);
434                }
435            }
436        },
437    });
438    $objenv->add_func('remove', {
439        help => 'remove a value from an attribute',
440        code => sub {
441            my ($env, $attr, @value) = @_;
442            @value or do {
443                print $OUT "attribute and value must be specified\n";
444                return;
445            };
446            foreach (@{$env->{_objects}}) {
447                my @attrv = grep { $_ } $_->get_attributes($attr);
448                foreach my $r (@value) {
449                    @attrv = grep { $_ ne $r } @attrv;
450                }
451                defined $_->set_c_fields($attr => @attrv ? [ @attrv ] : undef) or do {
452                    $_->rollback;
453                    printf $OUT "Cannot set $attr to %s for %s\n", join(', ',
454                        @value), $_->id;
455                    return;
456                };
457            }
458            $env->commit;
459            print $OUT "done\n";
460        },
461        completion => sub {
462            my ($env, $lastw, @args) = @_;
463            if (!$args[0]) {
464                return grep {
465                    $env->base->attribute($env->{_otype}, $_)->{multiple}
466                } $env->base->list_canonical_fields($env->{_otype}, 'w')
467            } else {
468                my $attr = $env->base->attribute($env->{_otype}, $args[0]);
469                if (@{$env->{_objects}} == 1) {
470                    return
471                    $env->{_objects}[0]->get_attributes($args[0]);
472                }
473            }
474        },
475    });
476    $objenv->add_func('list', {
477        help => 'list current selected objects',
478        code => sub {
479            printf $OUT "%s: %s\n", $_[0]->{_otype}, join(', ', map { $_->id }
480            @{$_[0]->{_objects}});
481        }
482    });
483    $objenv->add_func('edit', {
484            help => 'edit [object] - edit selected object using vi',
485            completion => sub {
486                return map { $_->id } @{$_[0]->{_objects}}
487            },
488            code => sub {
489                my ($env, $id) = @_;
490                my $obj;
491                if ($id) {
492                    $obj = grep { $_->id = $id } @{$env->{_objects}} or do {
493                        print $OUT "$id is not part of selected objects\n";
494                        return;
495                    };
496                } elsif (@{$env->{_objects}} == 1) {
497                    $obj = $env->{_objects}[0]
498                } else {
499                    print $OUT "multiple objects selected but can edit only one,"
500                    . "please specify which one\n";
501                    return;
502                }
503                my $res = LATMOS::Accounts::Utils::dump_read_temp_file(
504                    sub {
505                        my ($fh) = @_;
506                        $obj->text_dump($fh,
507                            {
508                                empty_attr => 1,
509                                only_rw => 1,
510                            }
511                        );
512                    },
513                    sub {
514                        my ($fh) = @_;
515                        my %attr = LATMOS::Accounts::Utils::parse_obj_file($fh);
516                        my $res = $obj->set_c_fields(%attr);
517                        if ($res) {
518                            print $OUT "Changes applied\n";
519                            $env->commit;
520                        }
521                        else { print $OUT "Error applying changes\n" }
522                        return $res ? 1 : 0;
523                    }
524                );
525            },
526        });
527    $objenv->add_func('delete', {
528        help => 'delete - delete selected object',
529        code => sub {
530            my ($env) = @_;
531            printf $OUT "%s: %s\ndelete selected objects ? (yes/NO)\n",
532            $env->{_otype}, join(', ', map { $_->id } @{$env->{_objects}});
533            my $reply = <STDIN> || ''; chomp($reply);
534            if ($reply eq 'yes') {
535                foreach (@{$env->{_objects}}) {
536                    $env->base->delete_object($env->{_otype}, $_->id) or do {
537                        print $OUT "Cannot delete " . $_->id . "\n";
538                        return;
539                    };
540                }
541                $env->commit;
542                return "EXIT";
543            } else {
544                print $OUT "cancel !\n"
545            }
546        },
547    });
548    if (grep { $objenv->base->attribute($otype, $_)->reference }
549        $objenv->base->list_canonical_fields($otype, 'r')) {
550        $objenv->add_func('select', {
551            help => 'select attribute [object]',
552            code => sub {
553                my ($env, $attrname, @objects) = @_;
554                my $totype = $env->base->attribute($env->{_otype},
555                    $attrname)->reference or return;
556
557                if (! @objects) {
558                    @objects = grep { $_ } 
559                      map { $_->get_attributes($attrname) } @{$env->{_objects}};
560                }
561                {
562                    my %uniq = map { $_ => 1 } @objects;
563                    @objects = keys %uniq;
564                }
565                my @objs = (grep { $_ } map { $env->base->get_object($totype, $_) }
566                        @objects);
567                return if (!@objs);
568                print $OUT "Selecting $otype " . join(', ', map { $_->id } @objs) . "\n";
569                objenv($_[0]->base, $totype, @objs)->cli();
570            },
571            completion => sub {
572                if ($_[2]) {
573                    my $totype = $_[0]->base->attribute($_[0]->{_otype},
574                        $_[2])->reference or return;
575                    return grep { $_ }
576                           map { $_->get_attributes($_[2]) }
577                           @{$_[0]->{_objects}};
578                } else {
579                    return grep { $_[0]->base->attribute($otype, $_)->reference }
580                    $_[0]->base->list_canonical_fields($otype, 'r');
581                }
582            },
583            }
584        );
585    }
586
587    if (lc($otype) eq 'user') {
588        $objenv->add_func('group', {
589            help => 'group add|remove|primary goupname',
590            code => sub {
591                my ($env, $action, @groups) = @_;
592                foreach my $obj (@{$env->{_objects}}) {
593                    if ($action eq 'primary') {
594                        my $gid = $groups[0];
595                        if ($gid !~ /^\d/) {
596                            my $gobj = $env->base->get_object('group', $gid) or
597                            do {
598                                print $OUT "Cannot find group $gid\n";
599                                return;
600                            };
601                            $gid = $gobj->get_attributes('gidNumber');
602                        }
603                        $obj->set_c_fields('gidNumber', $gid);
604                    } else {
605                        my %gr;
606                        foreach ($obj->get_attributes('memberOf')) {
607                            $gr{$_} = 1;
608                        }
609                        if ($action eq 'add') {
610                            $gr{$_} = 1 foreach(@groups);
611                        } elsif ($action eq 'remove') {
612                            delete($gr{$_}) foreach(@groups);
613                        } else {
614                            print $OUT 'invalid action' . "\n";
615                            return;
616                        }
617                        defined $obj->set_c_fields('memberOf' => [ keys %gr ]) or do {
618                            print $OUT "cannot set memberOf attributes for " .
619                            $obj->id . "\n";
620                            return;
621                        };
622                    }
623                }
624                $env->commit;
625            },
626            completion => sub {
627                if (!$_[2]) {
628                    return (qw(add remove primary));
629                } else {
630                    if ($_[2] eq 'remove') {
631                        my %uniq = map { $_ => 1 }
632                            grep { $_ }
633                            map { $_->get_attributes('memberOf') }
634                            @{$_[0]->{_objects}};
635                        return sort keys %uniq;
636                    } else {
637                        return $_[0]->base->search_objects('group');
638                    }
639                }
640            },
641        });
642    } elsif ($otype eq 'group') {
643        $objenv->add_func('member', {
644            help => 'member add|remove user',
645            code => sub {
646                my ($env, $action, @groups) = @_;
647                foreach my $obj (@{$env->{_objects}}) {
648                    my %gr;
649                    foreach ($obj->get_attributes('memberUID')) {
650                        $gr{$_} = 1;
651                    }
652                    if ($action eq 'add') {
653                        $gr{$_} = 1 foreach(@groups);
654                    } elsif ($action eq 'remove') {
655                        delete($gr{$_}) foreach(@groups);
656                    } else {
657                        print $OUT 'invalid action' . "\n";
658                        return;
659                    }
660                    defined $obj->set_c_fields('memberUID' => [ keys %gr ]) or do {
661                        print $OUT "cannot set memberUID attributes for " .
662                        $obj->id . "\n";
663                        return;
664                    };
665                }
666                $env->commit;
667            },
668            completion => sub {
669                if (!$_[2]) {
670                    return (qw(add remove));
671                } else {
672                    if ($_[2] eq 'remove') {
673                        my %uniq = map { $_ => 1 }
674                            grep { $_ }
675                            map { $_->get_attributes('member') }
676                            @{$_[0]->{_objects}};
677                        return sort keys %uniq;
678                    } else {
679                        return $_[0]->base->search_objects('user');
680                    }
681                }
682            },
683        });
684    }
685
686    return $objenv;
687}
688
689=head1 OBJECT FUNCTIONS
690
691=head2 new ($env, $labase)
692
693Create an envirronment object.
694
695C<$env> is functions descriptions.
696
697=cut
698
699sub new {
700    my ($class, $env, $labase) = @_;
701    bless($env, $class);
702    $env->{_labase} = $labase;
703
704    if ($labase->is_transactionnal) {
705        $env->add_func(
706            'transaction', {
707                help => 'change transaction mode',
708                code => sub {
709                    $trans_mode = $_[1] eq 'on' ? 1 : 0;
710                },
711                completion => sub {
712                    $trans_mode == 0 ? 'on' : 'off';
713                },
714            }
715        );
716        $env->add_func(
717            'commit', {
718                help => 'commit pending change',
719                code => sub {
720                    $_[0]->_commit;
721                },
722            }
723        );
724        $env->add_func(
725            'rollback', {
726                help => 'commit pending change',
727                code => sub {
728                    $_[0]->_rollback;
729                },
730            }
731        );
732    }
733    $env->add_func('quit', { help => 'quit - exit the tool',
734            code => sub { print "\n"; exit(0) }, });
735    $env->add_func('exit', { help => "exit current mode",
736            code => sub { return "EXIT" }, });
737    $env->add_func('help', {
738        help => 'help [command] - print help about command',
739        completion => sub {
740            if (!$_[2]) { return sort keys %{ $_[0]->{funcs} || {}} }
741        },
742        code => sub {
743            my ($self, $name) = @_;
744            if (!$name) {
745                print $OUT join(', ', sort keys %{ $self->{funcs} || {}}) . "\n";
746            } elsif ($self->{funcs}{$name}{alias}) {
747                print $OUT "$name is an alias for " . join(' ',
748                    @{$self->{funcs}{$name}{alias}}) . "\n";
749            } elsif ($self->{funcs}{$name}{help}) {
750                print $OUT $self->{funcs}{$name}{help} . "\n";
751            } else {
752                print $OUT "No help availlable\n";
753            }
754        },
755    });
756
757    $env;
758}
759
760=head2 base
761
762Return the attached base object.
763
764=cut
765
766sub base { $_[0]->{_labase} }
767
768=head2 cli
769
770Start the main loop
771
772=cut
773
774sub cli {
775    my ($self) = @_;
776    while (1) {
777        $term->Attribs->{completion_function} = sub {
778            $self->complete($_[0], shellwords(substr($_[1], 0, $_[2])));
779        };
780        defined (my $line = $term->readline($self->prompt)) or do {
781            print $OUT "\n";
782            return;
783        };
784        $term->addhistory($line);
785        my $res = $self->run(shellwords($line));
786        $self->rollback if (!$trans_mode);
787        if ($res && $res eq 'EXIT') { print $OUT "\n"; return }
788    }
789}
790
791=head2 prompt
792
793Wait user to input command
794
795=cut
796
797sub prompt {
798    my ($self) = @_;
799    if (!$self->{prompt}) {
800        return "LA cli > ";
801    } else {
802        $self->{prompt}->($self);
803    }
804}
805
806=head2 add_func ($name, $param)
807
808Add new function in the envirronment
809
810=cut
811
812# TODO: hide this
813
814sub add_func {
815    my ($self, $name, $param) = @_;
816    $self->{funcs}{$name} = $param;
817}
818
819=head2 getoption ($opt, @args)
820
821Parse commmand line
822
823=cut
824
825# TODO: hide this
826
827sub getoption {
828    my ($self, $opt, @args) = @_;
829    local @ARGV = @args;
830    Getopt::Long::Configure("pass_through");
831    GetOptions(%{ $opt });
832
833    return @ARGV;
834}
835
836# TODO: useless ?
837
838sub _parse_arg {
839    my ($self, $name, @args) = @_;
840    return @args;
841}
842
843=head2 complete
844
845Return possible words according current entered words
846
847=cut
848
849sub complete {
850    my ($self, $lastw, $name, @args) = @_;
851    if (!$name) {
852        return grep { /^\Q$lastw\E/ } sort
853            (keys %{ $self->{funcs} || {}});
854    } elsif ($self->{funcs}{$name}{alias}) {
855        $self->complete($lastw, @{$self->{funcs}{$name}{alias}}, @args);
856    } elsif ($self->{funcs}{$name}{completion}) {
857        my @pargs = $self->_parse_arg($name, @args);
858        return map { my $t = $_; $t =~ s/\s/\\ /g; $t } grep { $_ && /^\Q$lastw\E/ } $self->{funcs}{$name}{completion}->($self, $lastw, @pargs);
859    } else {
860        return ();
861    }
862}
863
864=head2 run ($name, @args)
865
866Run functions
867
868=cut
869
870sub run {
871    my ($self, $name, @args) = @_;
872    return if (!$name);
873    if (!exists($self->{funcs}{$name})) {
874        print $OUT "No command $name found\n";
875    } elsif ($self->{funcs}{$name}{alias}) {
876        $self->run(@{$self->{funcs}{$name}{alias}}, @args);
877    } elsif ($self->{funcs}{$name}{code}) {
878        my @pargs = $self->_parse_arg($name, @args);
879        $self->{funcs}{$name}{code}->($self, @args);
880    } else {
881        print $OUT "No command $name found\n";
882    }
883}
884
885=head2 commit
886
887Call commit to base unelss in transaction mode
888
889=cut
890
891sub commit {
892    my ($self) = @_;
893    if ($trans_mode) {
894    } else {
895        $self->_commit;
896    }
897}
898
899sub _commit {
900    my ($self) = @_;
901    $self->base->commit;
902}
903
904=head2 rollback
905
906Perform rollback unless in transaction mode
907
908=cut
909
910sub rollback {
911    my ($self) = @_;
912    if ($trans_mode) {
913        print $OUT "All pending changes get rollback\n";
914    }
915    $self->_rollback;
916}
917
918sub _rollback {
919    my ($self) = @_;
920    $self->base->rollback;
921}
922
9231;
924
925__END__
926
927=head1 SEE ALSO
928
929L<LATMOS::Accounts>
930
931=head1 AUTHOR
932
933Olivier Thauvin, E<lt>olivier.thauvin@latmos.ipsl.frE<gt>
934
935=head1 COPYRIGHT AND LICENSE
936
937Copyright (C) 2008, 2009, 2010, 2011, 2012 CNRS SA/CETP/LATMOS
938
939This library is free software; you can redistribute it and/or modify
940it under the same terms as Perl itself, either Perl version 5.10.0 or,
941at your option, any later version of Perl 5 you may have available.
942
943=cut
Note: See TracBrowser for help on using the repository browser.