source: LATMOS-Accounts/bin/la-qacls @ 669

#!/usr/bin/perl

use strict;
use warnings;
use LATMOS::Accounts;
use Getopt::Long;
use Pod::Usage;
use Term::ReadKey;

=head1 NAME

    la-qacls - Tools to check ACL

=head1 SYNOPSIS

Show a list of attributes with permission allowed to a given user

    la-qacls [option] [objectname]

If objectname is specified, the acls are checked over this object.

=cut

GetOptions(
    'c|config=s' => \my $config,
    'b|base=s'     => \my $base,
    'o|object=s' => \my $otype,
    'u|user=s'   => \my $user,
    'noexp'      => \my $noexp,
    'exp'        => \my $exp,
    'help'       => sub { pod2usage(0) },
) or pod2usage();

$otype ||= 'user';

=head1 OPTIONS

=item -c|--config configfile

Use this configuration file instead of the default one.

=item -b|--base basename

Query this specific base instead of the default one.

=item --noexp

Take into account all objects (even non propagated ones, with attribute 'exported'=0)

=item --exp

Take into account only propagated objects (attribute 'exported'=1) (default)

=item -o|object object_type

Query will be performed on this object. Default is the 'User' object.

=item u|user username

Check acls from the point of view of "username". If unset, anonymous is used.

=cut

my $LA = LATMOS::Accounts->new($config, noacl => 0);

my $labase = $base ? $LA->base($base) : $LA->default_base;

$labase->wexported($noexp ? 0 : 1);

if ($user) {
    $labase->{_user} = $user;
}

my $obj = $ARGV[0] ? $labase->get_object($otype, $ARGV[0]) : $otype
    or die "No object $otype $ARGV[0]";


printf(" %s %s\n",
    ($labase->check_acl($obj, $_, 'w') ? 'w' : ' '),
    $_,
) foreach(qw(@CREATE @DELETE));

printf("%s%s %s\n",
    ($labase->check_acl($obj, $_, 'r') ? 'r' : ' '),
    ($labase->check_acl($obj, $_, 'w') ? 'w' : ' '),
    $_,
) foreach($labase->list_canonical_fields($otype, 'a'));