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

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

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