source: trunk/LATMOS-Accounts/bin/la-attributes @ 2380

#!/usr/bin/perl

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

=head1 NAME

    la-attributes - Show summary of supported objects and attributes of config bases

=head1 SYNOPSIS

List supported objects and attributes

    la-attributes [option]
    la-attributes [option] object

=cut

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

=head1 OPTIONS

=over 4

=item -c|--config configdir

Use this configuration directory instead of thr default one.

=item -b|--base basename

Perform query on this base(s) (can be set multiple times).

=back

=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')) {
            my $attr = $labase->attribute($otype, $_);
            $supported{$_}{$basename} = sprintf('%s',
                $attr ? ($attr->ro ? 'r ' : 'rw') : '  '
            );
        }
    }

    if (! keys %supported) {
        die "No base support this object type $otype\n";
    }

    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__