source: LATMOS-Accounts/bin/la-attributes @ 494

#!/usr/bin/perl

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

=head1 NAME

    la-attrbiutes - Show summary of supported object and attributes of config bases

=head1 SYNOPSIS

List supported base, synchronisation, objects and attributes

    la-config [option]
    la-config [option] object

=cut

GetOptions(
    'c|config=s' => \my $config,
    'b|base=s'   => \my @qbases,
    'help'       => sub { pod2usage(0) },
) or pod2usage();

=head1 OPTIONS

=item -c|--config configfile

Use this configuration file instead default

=item -b|--base basename

Perform query on this bases (can be set multiple times)

=cut

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

if (!@qbases) { @qbases = $LA->list_bases }

if (my ($otype) = @ARGV) {
    my %supported;
    my @bases;
    my %unsupported;
    foreach my $basename (@qbases) {
        
        my $labase = $LA->base($basename) or next;
        push(@bases, $basename);
        $labase->is_supported_object($otype) or do {
            $unsupported{$basename} = 1;
            next;
        };
        foreach($labase->list_canonical_fields($otype, 'a')) {
            $supported{$_}{$basename} = sprintf('%s%s',
                ($labase->get_field_name($otype, $_, 'r') ? 'r' : ' '),
                ($labase->get_field_name($otype, $_, 'w') ? 'w' : ' '),
            );
        }
    }

    my ($objlen) = sort { $b <=> $a } map { length($_) } keys %supported;
    $objlen+=1;
    my $header = '|' . (' ' x $objlen) . ' | ' . join(' | ', @bases) . ' |';
    print '-' x length($header) . "\n";
    print $header . "\n";
    print '-' x length($header) . "\n";
    foreach my $obj (sort keys %supported) {
        printf("|%${objlen}s |", $obj);
        foreach (@bases) {
            print(' '.
                ($unsupported{$_}
                    ? 'NA'
                    : $supported{$obj}{$_} || '  ')
            );
            print ' ' x (length($_) - 2) . ' |';
        }
        print "\n";
        print '-' x length($header) . "\n";
    }
} else {
    my %supported;
    my @bases;
    foreach my $basename (@qbases) {
        
        my $labase = $LA->base($basename) or next;
        push(@bases, $basename);
        foreach($labase->list_supported_objects) {
            $supported{$_}{$basename} = 1;
        }
    }

    my ($objlen) = sort { $b <=> $a } map { length($_) } keys %supported;
    $objlen+=1;
    my $header = '|' . (' ' x $objlen) . ' | ' . join(' | ', @bases) . ' |';
    print '-' x length($header) . "\n";
    print $header . "\n";
    print '-' x length($header) . "\n";
    foreach my $obj (sort keys %supported) {
        printf("|%${objlen}s |", $obj);
        foreach (@bases) {
            print($supported{$obj}{$_} ? ' x' : '  ');
            print ' ' x (length($_) - 1) . ' |';
        }
        print "\n";
        print '-' x length($header) . "\n";
    }
}

__END__