[479] | 1 | #!/usr/bin/perl |
---|
| 2 | |
---|
| 3 | use strict; |
---|
| 4 | use warnings; |
---|
| 5 | use LATMOS::Accounts; |
---|
| 6 | use Getopt::Long; |
---|
| 7 | use Pod::Usage; |
---|
| 8 | use Term::ReadKey; |
---|
| 9 | |
---|
| 10 | =head1 NAME |
---|
| 11 | |
---|
[483] | 12 | la-qacls - Tools to check ACL |
---|
[479] | 13 | |
---|
| 14 | =head1 SYNOPSIS |
---|
| 15 | |
---|
[483] | 16 | Show a list of attributes with permission allowed to a given user |
---|
[479] | 17 | |
---|
[594] | 18 | la-qacls [option] [objectname] |
---|
[479] | 19 | |
---|
[483] | 20 | If objectname is specified, the acls are checked over this object. |
---|
| 21 | |
---|
[479] | 22 | =cut |
---|
| 23 | |
---|
| 24 | GetOptions( |
---|
[849] | 25 | 'c|config=s' => \my $config, |
---|
| 26 | 'b|base=s' => \my $base, |
---|
| 27 | 'o|object=s' => \my $otype, |
---|
| 28 | 'u|user=s' => \my $user, |
---|
| 29 | 'no-unexp|wo-unexp' => \my $nounexp, |
---|
| 30 | 'exp' => \my $unexp, |
---|
| 31 | 'help' => sub { pod2usage(0) }, |
---|
[479] | 32 | ) or pod2usage(); |
---|
| 33 | |
---|
| 34 | $otype ||= 'user'; |
---|
| 35 | |
---|
| 36 | =head1 OPTIONS |
---|
| 37 | |
---|
[985] | 38 | =over 4 |
---|
| 39 | |
---|
[861] | 40 | =item -c|--config configdir |
---|
[479] | 41 | |
---|
[861] | 42 | Use this configuration directory instead of the default one. |
---|
[479] | 43 | |
---|
| 44 | =item -b|--base basename |
---|
| 45 | |
---|
[594] | 46 | Query this specific base instead of the default one. |
---|
[479] | 47 | |
---|
[849] | 48 | =item --with-unexp |
---|
[664] | 49 | |
---|
[669] | 50 | Take into account all objects (even non propagated ones, with attribute 'exported'=0) |
---|
[664] | 51 | |
---|
[849] | 52 | =item --wo-unexp |
---|
[664] | 53 | |
---|
[669] | 54 | Take into account only propagated objects (attribute 'exported'=1) (default) |
---|
[664] | 55 | |
---|
[594] | 56 | =item -o|object object_type |
---|
[483] | 57 | |
---|
[594] | 58 | Query will be performed on this object. Default is the 'User' object. |
---|
[483] | 59 | |
---|
| 60 | =item u|user username |
---|
| 61 | |
---|
[594] | 62 | Check acls from the point of view of "username". If unset, anonymous is used. |
---|
[483] | 63 | |
---|
[985] | 64 | =back |
---|
| 65 | |
---|
[479] | 66 | =cut |
---|
| 67 | |
---|
| 68 | my $LA = LATMOS::Accounts->new($config, noacl => 0); |
---|
| 69 | |
---|
[1044] | 70 | my $labase = $LA->base($base); |
---|
[479] | 71 | |
---|
[849] | 72 | $labase->unexported($unexp ? 1 : 0); |
---|
[664] | 73 | |
---|
[479] | 74 | if ($user) { |
---|
| 75 | $labase->{_user} = $user; |
---|
| 76 | } |
---|
| 77 | |
---|
| 78 | my $obj = $ARGV[0] ? $labase->get_object($otype, $ARGV[0]) : $otype |
---|
| 79 | or die "No object $otype $ARGV[0]"; |
---|
| 80 | |
---|
| 81 | |
---|
[483] | 82 | printf(" %s %s\n", |
---|
[479] | 83 | ($labase->check_acl($obj, $_, 'w') ? 'w' : ' '), |
---|
| 84 | $_, |
---|
| 85 | ) foreach(qw(@CREATE @DELETE)); |
---|
| 86 | |
---|
| 87 | printf("%s%s %s\n", |
---|
| 88 | ($labase->check_acl($obj, $_, 'r') ? 'r' : ' '), |
---|
| 89 | ($labase->check_acl($obj, $_, 'w') ? 'w' : ' '), |
---|
| 90 | $_, |
---|
| 91 | ) foreach($labase->list_canonical_fields($otype, 'a')); |
---|