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

#!/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-config [option] [objectname]

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

=cut

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

$otype ||= 'user';

=head1 OPTIONS

=item -c|--config configfile

Use this configuration file instead default

=item -b|--base basename

Perform query on this base

=item -o|object type

Check acls for this object type

=item u|user username

Check acls as this username were really login. If unset, anonymous is used.

=cut

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

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

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'));