File Coverage

blib/lib/StorageDisplay/Collect.pm

Criterion	Covered	Total	%
statement	146	1098	13.3
branch	21	386	5.4
condition	1	119	0.8
subroutine	39	124	31.4
pod	3	30	10.0
total	210	1757	11.9

#
# This file is part of StorageDisplay
#
# This software is copyright (c) 2014-2023 by Vincent Danjean.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#
use strict;
use warnings;

# Implementation note: this file must contains all required modules
# required to collect data, but modules included in perl itself.
# This file can be sent to remote machine through SSH, this is why
# it must be self-contained.

package StorageDisplay::Collect;
# ABSTRACT: modules required to collect data.
# No dependencies (but perl itself and its basic modules)

our $VERSION = '2.04'; # VERSION


sub collectors {
    my $self = shift;
    return @{$self->{_attr_collectors}};
}

sub collector {
    my $self = shift;
    my $name = shift;
    return $self->{_attr_collectors_by_provide}->{$name};
}

sub registerCollector {
    my $self = shift;
    my $collector = shift;

    die "$collector not a StorageDisplay::Collect::Collector"
        if not $collector->isa("StorageDisplay::Collect::Collector");

    push @{$self->{_attr_collectors}}, $collector;
    foreach my $cn ($collector->provides) {
        if (exists($self->{_attr_collectors_by_provide}->{$cn})) {
            die "$cn provided by both ".$collector->module." and ".
                $self->{_attr_collectors_by_provide}->{$cn}->module;
        }
        $self->{_attr_collectors_by_provide}->{$cn} = $collector;
    }
}

sub open_cmd_pipe {
    my $self = shift;
    return $self->cmdreader->open_cmd_pipe(@_);
}

sub open_cmd_pipe_root {
    my $self = shift;
    return $self->cmdreader->open_cmd_pipe_root(@_);
}

sub open_file {
    my $self = shift;
    return $self->cmdreader->open_file(@_);
}

sub has_file {
    my $self = shift;
    return $self->cmdreader->has_file(@_);
}

sub cmdreader {
    my $self = shift;
    return $self->{_attr_cmdreader};
}

my @collectors;

sub new {
    my $class = shift;
    my $reader = shift // 'Local';

    if (ref($reader) eq '') {
        my $fullreadername = 'StorageDisplay::Collect::CMD::'.$reader;
        $reader = $fullreadername->new(@_);
    }

    my $self = {
        _attr_cmdreader => $reader,
        _attr_collectors => [],
        _attr_collectors_by_provide => {},
    };

    bless $self, $class;

    foreach my $cdata (@collectors) {
        my $cn = $cdata->{name};
        $cn->new($cdata, $self);
    }
    return $self;
}

sub registerCollectorModule {
    my $class = shift;
    my $collector = shift;

    #my $collector = caller 0;
    #print STDERR "Registering $collector from ".(caller 0)."\n";
    my $info = { name => $collector, @_ };
    foreach my $entry (qw(provides requires)) {
        next if not exists($info->{$entry});
        if (ref($info->{$entry}) eq "") {
            $info->{$entry} = [ $info->{$entry} ];
        }
    }
    push @collectors, $info;
}

# Main collect function
#
# It will iterate on the collectors, respecting dependencies.
sub collect {
    my $self = shift;
    my $req = shift;
    my $infos = {};

    $infos = $self->cmdreader->data_init($infos);

    # 0/undef : not computed
    # 1 : computed
    # 2 : computing
    # 3 : N/A
    my $collector_state = {};

    my $load;
    $load = sub {
        my $col = shift;
        $collector_state->{$_} = 2 for $col->provides;
        foreach my $cname ($col->requires) {
            #print STDERR "  preloading $cname\n";
            my $state = $collector_state->{$cname};
            if (not defined($state)) {
                my $collector = $self->collector($cname);
                die "E: No $cname collector available for ".$col->module."\n"
                    if not defined($collector);
                $load->($collector);
            } elsif ($collector_state->{$cname} == 1) {
                next
            } else {
                die "Loop in collectors requires ($cname required in $col->name)";
            }
        }
        # are files present?
        my @missing_files =
            grep {
                not $self->has_file($_);
            } $col->depends('files');
        if (scalar(@missing_files)) {
            print STDERR "I: skipping ", $col->module, " due to missing file(s): '",
                join("', '", @missing_files), "'\n";
            $collector_state->{$_} = 3 for $col->provides;
            return;
        }
        my $opencmd = $col->depends('root') ?
            'open_cmd_pipe_root' : 'open_cmd_pipe';
        # are programs present?
        my @missing_progs =
            grep {
                my @cmd=('which', $_);
                my $dh = $col->$opencmd(@cmd);
                my $path = <$dh>;
                close($dh);
                not defined($path);
            } $col->depends('progs');
        if (scalar(@missing_progs)) {
            print STDERR "I: skipping ", $col->module, " due to missing program(s): '",
                join("', '", @missing_progs), "'\n";
            $collector_state->{$_} = 3 for $col->provides;
            return;
        }
        # collecting data while providing required data
        my $collected_infos = $col->collect(
            {
                map { $_ => $infos->{$_} } $col->requires
            }, $req);
        # registering provided data
        $infos->{$_} = $collected_infos->{$_} for $col->provides;
        $collector_state->{$_} = 1 for $col->provides;
        #print STDERR "loaded $cn\n";
    };
    # Be sure to collect all collectors
    foreach my $col ($self->collectors) {
        $load->($col);
    }

    return $self->cmdreader->data_finish($infos);
}

1;

###########################################################################
package StorageDisplay::Collect::JSON;

BEGIN {
    # Mark current package as loaded;
    # else, we cannot use 'use StorageDisplay::Collect::JSON;' latter
    my $p = __PACKAGE__;
    $p =~ s,::,/,g;
    chomp(my $cwd = `pwd`);
    $INC{$p.'.pm'} = $cwd.'/'.__FILE__;#k"current file";
}

# This package contains
# - two public subroutines
#   - `use_pp_parser` to know if JSON:PP makes all the work alone
#   - `decode_json` to decode a json text with the $json_parser object
# - a public `new` class method that returns
#   - a plain JSON::PP object (if boolean_values method exists)
#   - a __PACKAGE__ object (if not) that inherit from JSON::PP
# - an overrided `decode` method that
#   - calls SUPER::decode
#   - manually transforms JSON:::PP::Boolean into plain scalar
# $json_parser is
# - either a JSON::PP object (if boolean_values method exists)
# - or a StorageDisplay::Collect::JSON that inherit of JSON::PP
#   but override the decode method

use base 'JSON::PP';

my $has_boolean_values;

sub new {
    my $class = shift;
    my $json_pp_parser;
    if (!defined($has_boolean_values)) {
	$json_pp_parser = JSON::PP->new;
	$has_boolean_values = 0;
	eval {
	    # workaround if not supported
	    $json_pp_parser->boolean_values(0, 1);
	    $has_boolean_values = 1;
	};
    }
    my $parser;
    if ($has_boolean_values) {
	$parser = JSON::PP->new(@_);
	$parser->boolean_values(0, 1);
    } else {
	$parser = JSON::PP::new(__PACKAGE__, @_);
    }
    eval {
	# ignore if not supported
	$parser->allow_bignum;
    };
    return $parser;
}

sub decode {
    my $self = shift;

    my $data = $self->SUPER::decode(@_);

    my %unrecognized;

    local *_convert_bools = sub {
        my $ref_type = ref($_[0]);
        if (!$ref_type) {
            # Nothing.
        }
        elsif ($ref_type eq 'HASH') {
            _convert_bools($_) for values(%{ $_[0] });
        }
        elsif ($ref_type eq 'ARRAY') {
            _convert_bools($_) for @{ $_[0] };
        }
        elsif ($ref_type eq 'JSON::PP::Boolean') {
            $_[0] = $_[0] ? 1 : 0;
        }
	elsif ($ref_type eq 'Math::BigInt') {
	    if ($_[0]->beq($_[0]->numify())) {
		# old versions of JSON::PP always use Math::Big*
		# even if this is not required
		$_[0] = $_[0]->numify();
	    }
	}
	elsif ($ref_type eq 'Math::BigFloat') {
	    if ($_[0]->is_int()
		&& $_[0]->beq($_[0]->numify())) {
		$_[0] = $_[0]->numify();
	    }
	}
        else {
            ++$unrecognized{$ref_type};
        }
    };

    &_convert_bools($data);

    warn("Encountered an object of unrecognized type $_")
        for sort values(%unrecognized);

    return $data;
}

my $json_parser;

sub decode_json {
    if (not defined($json_parser)) {
	$json_parser = __PACKAGE__->new();
    }

    $json_parser->decode(@_);
}

sub pp_parser_has_boolean_values {
    return $has_boolean_values;
}

sub jsonarray2perlhash {
    my $json = shift;
    my $root = shift;
    my $key = shift;
    my $info = {
        map { $_->{$key} => $_ }
	(@{decode_json($json)->{$root}})
    };
    return $info;
}

1;

###########################################################################
package StorageDisplay::Collect::CMD;

sub new {
    my $class = shift;
    my $self = {};
    bless $self, $class;
    return $self;
}

sub cmd2str {
    my $self = shift;
    my @cmd = @_;
    my $str = join(' ', map {
        my $s = $_;
        $s =~ s/(['\\])/\\$1/g;
        if ($s !~ /^[0-9a-zA-Z_@,:\/=-]+$/) {
            $s="'".$s."'";
        }
        $s;
    } @cmd);
    return $str;
}

sub data_init {
    my $self = shift;
    my $data = shift;

    return $data;
}

sub data_finish {
    my $self = shift;
    my $data = shift;

    return $data;
}

sub open_file {
    my $self = shift;
    my $filename = shift;

    return $self->open_cmd_pipe('cat', $filename);

    my $dh;
    open($dh, '<', $filename) or die "Cannot open $filename: $!";
    return $dh;
}

sub has_file {
    my $self = shift;
    my $filename = shift;

    return -e $filename;
}

1;

###########################################################################
package StorageDisplay::Collect::CMD::Local;

use parent -norequire => "StorageDisplay::Collect::CMD";

sub open_cmd_pipe {
    my $self = shift;
    my @cmd = @_;
    print STDERR "Running: ", $self->cmd2str(@cmd)."\n";
    open(my $dh, '-|', @cmd) or
        die "Cannot run ".$self->cmd2str(@cmd).": $!\n";
    return $dh;
}

sub open_cmd_pipe_root {
    my $self = shift;
    if ($> != 0) {
        return $self->open_cmd_pipe('sudo', @_);
    } else {
        return $self->open_cmd_pipe(@_);
    }
}

1;

###########################################################################
package StorageDisplay::Collect::CMD::LocalBySSH;

use parent -norequire => "StorageDisplay::Collect::CMD";

sub open_cmd_pipe {
    my $self = shift;
    my @cmd = @_;
    my $cmd = $self->cmd2str(@cmd);
    $cmd =~ s/sudo password:\n/sudo password:/;
    print STDERR "Running: $cmd\n";
    open(my $dh, '-|', @cmd) or
        die "Cannot run $cmd: $!\n";
    return $dh;
}

sub open_cmd_pipe_root {
    my $self = shift;
    if ($> != 0) {
        return $self->open_cmd_pipe(qw(sudo -S -p), 'sudo password:'."\n", '--', @_);
    } else {
        return $self->open_cmd_pipe(@_);
    }
}

1;

###########################################################################
package StorageDisplay::Collect::CMD::Proxy::Recorder;

use parent -norequire => "StorageDisplay::Collect::CMD";
use Scalar::Util 'blessed';

sub new {
    my $class = shift;
    my %args = ( @_ );
    if (not exists($args{'recorder-reader'})) {
        die 'recorder-reader argument required';
    }
    my $reader = $args{'recorder-reader'};
    if (ref($reader) eq '') {
        my $fullreadername = 'StorageDisplay::Collect::CMD::'.$reader;
        $reader = $fullreadername->new(@_, %{$args{'recorder-args-pass'} // {}});
    }
    die "Invalid reader" if not blessed($reader) or not $reader->isa("StorageDisplay::Collect::CMD");
    my $self = $class->SUPER::new(@_);
    $self->{'_attr_reader'} = $reader;
    return $self;
}

sub reader {
    my $self = shift;
    return $self->{_attr_reader};
}

sub data_finish {
    my $self = shift;
    my $infos = shift;
    $infos = $self->SUPER::data_finish($infos);
    $infos->{'recorder'} = $self->{_attr_records};
    return $infos;
}

sub _record {
    my $self = shift;
    my $args = { @_ };
    my $dh = $args->{'dh'};
    delete($args->{'dh'});
    my @infos = <$dh>;
    @infos = map { chomp; $_ } @infos;
    close($dh);
    $args->{'stdout'} = \@infos;
    push @{$self->{'_attr_records'}}, $args;
    my $infos = join("\n", @infos);
    if (scalar(@infos)) {
        $infos .= "\n";
    }
    open(my $fh, "<",  \$infos);
    return $fh;
}

sub open_cmd_pipe {
    my $self = shift;
    return $self->_record(
        'root' => 0,
        'cmd' => [ @_ ],
        'dh' => $self->reader->open_cmd_pipe(@_),
        );
}

sub open_cmd_pipe_root {
    my $self = shift;
    return $self->_record(
        'root' => 1,
        'cmd' => [ @_ ],
        'dh' => $self->reader->open_cmd_pipe_root(@_),
        );
}

sub has_file {
    my $self = shift;
    my $filename = shift;
    my $ret = $self->reader->has_file($filename);
    push @{$self->{'_attr_records'}}, {
        'filename' => $filename,
            'value' => $ret,
    };
    return $ret;
}

1;

###########################################################################
package is_collector;

our $CALLER;

sub import {
    my $class = shift;

    my $inheritor = caller(0);

    {
        no strict 'refs'; ## no critic
        push @{"$inheritor\::ISA"}, 'StorageDisplay::Collect::Collector'; # dies if a loop is detected
        $CALLER = $inheritor;
        StorageDisplay::Collect->registerCollectorModule($inheritor, @_);
    };
};

BEGIN {
    # Mark current package as loaded;
    my $p = __PACKAGE__;
    $p =~ s,::,/,g;
    chomp(my $cwd = `pwd`);
    $INC{$p.'.pm'} = $cwd.'/'.__FILE__;#k"current file";
}

1;

###########################################################################
package StorageDisplay::Collect::Collector;

use Storable;

sub open_cmd_pipe {
    my $self = shift;
    return $self->proxy->open_cmd_pipe(@_);
}

sub open_cmd_pipe_root {
    my $self = shift;
    return $self->proxy->open_cmd_pipe_root(@_);
}

sub open_file {
    my $self = shift;
    return $self->proxy->open_file(@_);
}

sub has_file {
    my $self = shift;
    return $self->proxy->has_file(@_);
}

sub collect {
    my $self = shift;
    print STDERR "collect must be implemented in $self\n";
}

sub names_avail {
    my $self = shift;
    print STDERR "names_avail must be implemented in $self\n";
}

sub import {
    print STDERR __PACKAGE__." imported from ".(caller 0)."\n";
}

BEGIN {
    # Mark current package as loaded;
    my $p = __PACKAGE__;
    $p =~ s,::,/,g;
    $INC{$p.'.pm'} = "current file";
}

sub module {
    my $self = shift;
    return $self->{_attr_module};
}

sub requires {
    my $self = shift;
    return @{$self->{_attr_requires}};
}

sub depends {
    my $self = shift;
    my $kind = shift;
    return wantarray
        ? @{$self->{_attr_depends}->{$kind} // []}
        : $self->{_attr_depends}->{$kind};
}

sub provides {
    my $self = shift;
    return @{$self->{_attr_provides}};
}

sub proxy {
    my $self = shift;
    return $self->{_attr_collect};
}

sub select {
    my $self = shift;
    my $infos = shift;
    my $request = shift // {};
    return $self->names_avail;
}

sub new {
    my $class = shift;
    my $infos = shift;
    my $collect = shift;

    my $self = {};
    bless $self, $class;

    $self->{_attr_module} = $infos->{name};
    $self->{_attr_collect} = $collect;
    $self->{_attr_requires} = Storable::dclone($infos->{requires}//[]);
    $self->{_attr_provides} = Storable::dclone($infos->{provides}//[]);
    $self->{_attr_depends} = Storable::dclone($infos->{depends}//{});
    $collect->registerCollector($self);

    return $self;
}

1;

###########################################################################
###########################################################################
###########################################################################
###########################################################################
package StorageDisplay::Collect::Host;

use is_collector
    provides => [ qw(hostname) ],
    no_names => 1,
    depends => {
        progs => [ 'hostname', 'date' ],
};

sub collect {
    my $self = shift;
    my $infos = {};
    my $dh;

    $dh=$self->open_cmd_pipe(qw(hostname));
    my $hostname = <$dh>;
    close $dh;
    chomp($hostname);
    $dh=$self->open_cmd_pipe(qw(hostname --fqdn));
    my $fqdn_hostname = <$dh>;
    close $dh;
    chomp($fqdn_hostname);
    $dh=$self->open_cmd_pipe(qw(date --rfc-3339=s));
    my $date = <$dh>;
    close $dh;
    chomp($date);
    $dh=$self->open_cmd_pipe(qw(uname -a));
    my $uname = <$dh>;
    close $dh;
    chomp($uname);

    return {
	hostname => $hostname,
	fqdn_hostname => $fqdn_hostname,
	date => $date,
	uname => $uname,
    };
}

1;

###########################################################################
package StorageDisplay::Collect::SystemBlocks;

use is_collector
    provides => [ qw(lsblk lsblk-hierarchy udev) ],
    no_names => 1,
    depends => {
        progs => [ 'lsblk', 'udevadm' ],
};

use StorageDisplay::Collect::JSON;

sub lsblkjson2perl {
    my $self = shift;
    my $json = shift;
    return StorageDisplay::Collect::JSON::jsonarray2perlhash($json, 'blockdevices', 'kname');
}

sub collect {
    my $self = shift;
    my $infos = {};
    my $dh;
    my $json;

    # Get all infos on system blocks
    # 'lsblk-json-hierarchy' -> Str(json)
    #my $dh=open_cmd_pipe(qw(lsblk --json --bytes --output-all));
    $dh=$self->open_cmd_pipe(qw(lsblk --all --json --output), 'name,kname');
    $json=join("\n", <$dh>);
    close $dh;
    $infos->{'lsblk-hierarchy'}=$self->lsblkjson2perl($json);

    # And keep json infos
    # 'lsblk-json' -> kn -> Str(json)
    $dh=$self->open_cmd_pipe(qw(lsblk --all --json --bytes --output-all --list));
    $infos->{'lsblk'}=$self->lsblkjson2perl(join("\n", <$dh>));
    close $dh;

    # Get all infos with udev
    # 'udev' -> kn ->
    #   - 'path' -> Str(P:)
    #   - 'name' -> Str(N:)
    #   - 'names' -> [ N:, S:... ]
    #   - '_udev_infos' -> id -> Str(val)
    $dh=$self->open_cmd_pipe(qw(udevadm info --query all --export-db));
    my $data={'_udev_infos' => {}};
    my $dname;
    my $lastline;
    while (defined(my $line=<$dh>)) {
        chomp($line);
        $lastline=$line;
        if ($line eq '') {
            if (defined($dname)) {
                if (exists($data->{'names'})) {
                    my @sorted_names=sort @{$data->{'names'}};
                    $data->{'names'}=\@sorted_names;
                }
                $infos->{'udev'}->{$dname}=$data;
            } else {
                #print STDERR "No 'N:' tag in udev entry ".($data->[0]//"")."\n";
            }
            $data={'_udev_infos' => {}};
            $dname=undef;
        } else {
            if ($line =~ /^P: (.*)$/) {
                $data->{'path'}=$1;
            } elsif ($line =~ /^N: (.*)$/) {
                $dname=$1;
                $data->{'name'}=$1;
                push @{$data->{'names'}}, $1;
            } elsif ($line =~ /^S: (.*)$/) {
                push @{$data->{'names'}}, $1;
            } elsif ($line =~ /^E: (DEVLINKS)=(.*)$/) {
                $data->{'_udev_infos'}->{$1}=join(' ', sort(split(' ',$2)));
            } elsif ($line =~ /^E: ([^=]*)=(.*)$/) {
                $data->{'_udev_infos'}->{$1}=$2;
            } elsif ($line =~ /^[MRUTDILQV]: .*$/) {
                # Unused info. See udevadm(8) / Table 1 for more info
            } else {
                print STDERR "Ignoring '$line'".(defined($dname)?(' for '.$dname):'')."\n";
            }
        }
    }
    close $dh;
    if(defined($dname)) {
        die "E: pb avec $dname ($lastline)", "\n";
    }
    return $infos;
}

1;

###########################################################################
package StorageDisplay::Collect::DeviceMapper;

use is_collector
    provides => qw(dm),
    depends => {
        progs => [ 'dmsetup' ],
        root => 1,
};

sub collect {
    my $self = shift;
    my $dm={};
    my $dh;

    # Get all infos with dmsetup
    # 'dm' -> kn ->
    #   DM_NAME
    #   DM_BLKDEVNAME
    #   DM_BLKDEVS_USED
    #   DM_SUBSYSTEM
    #   DM_DEVS_USED
    $dh=$self->open_cmd_pipe_root(qw(dmsetup info -c --nameprefix --noheadings -o),
                                  'name,blkdevname,blkdevs_used,subsystem,devs_used',
                                  '--separator', "\n ");
    my $data={};
    my $dname;
    while (defined(my $line=<$dh>)) {
        chomp($line);
        next if $line eq 'No devices found';
        if ($line =~ /^DM_/) {
            if (defined($dname)) {
                $dm->{$dname}=$data;
            } else {
                #print STDERR "No 'N:' tag in udev entry ".($data->[0]//"")."\n";
            }
            $data={};
            $dname=undef;
        }
        if ($line =~ /^ ?(DM_[^=]*)='(.*)'$/) {
            if ($2 ne '') {
                $data->{$1} = $2;
            }
            if ($1 eq 'DM_BLKDEVNAME') {
                $dname = $2;
            }
        } else {
            print STDERR "Ignoring '$line'".(defined($dname)?(' for '.$dname):'')."\n";
        }
    }
    if (defined($dname)) {
        $dm->{$dname}=$data;
    }
    close $dh;
    return { 'dm' => $dm };
}

1;

###########################################################################
package StorageDisplay::Collect::Partitions;

use is_collector
    provides => [ qw(partitions disks-no-part)],
    requires => [ qw(lsblk udev) ],
    depends => {
        progs => [ 'parted' ],
        root => 1,
};

sub select {
    my $self = shift;
    my $infos = shift;
    my $request = shift // {};
    my @devs=();

    foreach my $kn (sort keys %{$infos->{'lsblk'}}) {
        my $udev_info = $infos->{'udev'}->{$kn};
        my $lsblk_info = $infos->{'lsblk'}->{$kn};
        next if not defined($udev_info);
        if (($udev_info->{'_udev_infos'}->{DEVTYPE} // '') ne 'disk') {
            next;
        }
        if (($udev_info->{'_udev_infos'}->{ID_PART_TABLE_TYPE} // '') eq '') {
            if (($lsblk_info->{'rm'} // 0) == 1) {
                # removed disk (cd, ...), skipping
                next;
            }
            if (($lsblk_info->{'type'} // '') eq 'loop'
		&& ($lsblk_info->{'size'} // 0) == 0) {
                # loop device not attached
                next;
            }
            if (($lsblk_info->{'type'} // '') eq 'lvm') {
                # handled by lvm subsystem
                next;
            }
            # disk with no partition, just get it
            push @devs, $kn;
            next;
        }
        if (
            ($udev_info->{'_udev_infos'}->{ID_PART_TABLE_TYPE} // '') eq 'dos'
            && ($udev_info->{'_udev_infos'}->{ID_PART_ENTRY_NUMBER} // '') ne ''
            && ($udev_info->{'_udev_infos'}->{DM_TYPE} // '') eq 'raid'
            ) {
            print STDERR "I: $kn seems to be a dm-mapped extended dos partition. Skipping it as disk\n";
            #$partitions->{$kn}->{"dos-extended"}=1;
            next;
        }
        push @devs, $kn;
    }
    return @devs;
}

sub collect {
    my $self = shift;
    my $infos = shift;
    my $partitions;
    my $noparts;
    my $dh;

    my @devs=$self->select($infos);

    foreach my $kn (@devs) {
        my $udev_info = $infos->{'udev'}->{$kn};
        if (($udev_info->{'_udev_infos'}->{ID_PART_TABLE_TYPE} // '') eq '') {
            $noparts->{$kn}={'no partitions' => 1};
            next;
        }
        $dh=$self->open_cmd_pipe_root(qw(parted -m -s), "/dev/".$kn, qw(unit B print free));
        my $state=0;
        my $parted={ 'parts' => [] };
        my $startline = '';
        while(defined(my $line=<$dh>)) {
            chomp($line);
            my $multiline = 0;
            if ($startline ne '') {
                $line = $startline . $line;
                $multiline = 1;
            }
            if ($line !~ /;$/) {
                $startline = $line;
                next;
            }
            $startline = '';
            if ($state == 0) {
                if ($line eq "BYT;") {
                    $state = 1;
                    next;
                }
            } elsif ($state == 1) {
                if ($line =~ /.*:([0-9]+)B:[^:]*:[0-9]+:[0-9]+:([^:]*):(.*):;/) {
                    $parted->{size} = $1;
                    $parted->{type} = $2;
                    $parted->{label} = $3;
                    $state = 2;
                    next;
                }
            } elsif ($state == 2) {
                if ($line =~ m/^1:([0-9]+)B:[0-9]+B:([0-9]+)B:free;$/) {
                    push @{$parted->{parts}}, {
                        'kind' => 'free',
                            'start' => $1,
                            'size' => $2,
                    };
                    next;
                } elsif ($line =~ m/^([0-9]+):([0-9]+)B:[0-9]+B:([0-9]+)B:[^:]*:(.*):([^:]*);$/) {
                    push @{$parted->{parts}}, {
                        'kind' => 'part',
                            'id' => $1,
                            'start' => $2,
                            'size' => $3,
                            'label' => $4,
                            'flags' => $5,
                    };
                    if ($multiline) {
                        my $label = $4;
                        if ($label =~ /^Project-Id.*Content-Transfer-Encoding: 8bit$/) {
                            # workaround a parted bug with xfs partitions (at least)
                            $parted->{parts}->[-1]->{'label'}='';
                        }
                    }
                    next;
                }
            }
            print STDERR "W: parted on $kn: Unknown line '$line'\n";
        }
        close($dh);
        if ($state != 2) {
            print STDERR "W: parted on $kn: invalid data (skipping device)\n";
            next;
        }
        if ($udev_info->{'_udev_infos'}->{ID_PART_TABLE_TYPE} eq 'dos') {
            $dh=$self->open_cmd_pipe_root(qw(parted -s), "/dev/".$kn, qw(print));
            $state=0;
            while(defined(my $line=<$dh>)) {
                chomp($line);
                if ($line =~ /^\s([1234]) .* extended( .*)?$/) {
                    $parted->{extended} = $1;
                    last;
                }
            }
        }
        $partitions->{$kn}=$parted;
    }
    return {
        'partitions' => $partitions,
            'disks-no-part' => $noparts,
    };
}

1;

###########################################################################
package StorageDisplay::Collect::LVM;

use is_collector
    provides => 'lvm',
    depends => {
        progs => [ 'lvm' ],
        root => 1,
};

use StorageDisplay::Collect::JSON;

sub lvmjson2perl {
    my $self = shift;
    my $kind = shift;
    my $kstore = shift;
    my $uniq = shift;
    my $keys = shift;
    my $info = shift // {};
    my $json = shift;
    my $alldata = StorageDisplay::Collect::JSON::decode_json($json)
	->{'report'}->[0]->{$kind};
    foreach my $data (@$alldata) {
        my $vg=$data->{vg_name} // die "no vg_name in data!";
        my $base = $info->{$vg}->{$kstore};
        my $hashs = [ [$info->{$vg}, $kstore] ];
        if (scalar(@$keys) == 1) {
            # force creation of $info->{$vg}->{$kstore} hash if needed
            my $dummy=$info->{$vg}->{$kstore}->{$data->{$keys->[0]}};
            $hashs = [ [ $info->{$vg}->{$kstore},
                         $data->{$keys->[0]} ] ];
        } elsif (scalar(@$keys) > 1) {
            $hashs = [
                map {
                    # force creation of $info->{$vg}->{$kstore}->{$_} hash if needed
                    my $dummy=$info->{$vg}->{$kstore}->{$_}->{$data->{$_}};
                    [ $info->{$vg}->{$kstore}->{$_},
                      $data->{$_} ]
                } @$keys
                ];
        }
        foreach my $i (@$hashs) {
            my ($h, $k) = @$i;
            if ($uniq) {
                die "duplicate info" if defined($h->{$k});
                $h->{$k} = $data;
            } else {
                push @{$h->{$k}}, $data;
            }
        }
    }
    return $info;
}

sub collect {
    my $self = shift;
    my $dh;
    my $lvm = {};

   # Get all infos on LVM
    # 'lvm' -> 'pv'| -> Str(json)
    $dh=$self->open_cmd_pipe_root(
        qw(lvm pvs --units B --reportformat json --all -o),
        'pv_name,pv_size,pv_free,pv_used,seg_size,seg_start,segtype,pvseg_start,pvseg_size,lv_name,lv_role,vg_name',
        '--select', 'pv_size > 0 || vg_name != ""');
    $self->lvmjson2perl('pv', 'pvs', 0, [], $lvm, join("\n", <$dh>));
    close $dh;

    $dh=$self->open_cmd_pipe_root(
        qw(lvm lvs --units B --reportformat json --all -o),
        'lv_name,seg_size,segtype,seg_start,seg_pe_ranges,seg_le_ranges,vgname,devices,pool_lv,lv_parent');
    $self->lvmjson2perl('lv', 'lvs', 0, [], $lvm, join("\n", <$dh>));
    close $dh;

    $dh=$self->open_cmd_pipe_root(
        qw(lvm vgs --units B --reportformat json --all -o),
        'vg_name,vg_size,vg_free');
    $self->lvmjson2perl('vg', 'vgs-vg', 1, [], $lvm, join("\n", <$dh>));
    close $dh;

    $dh=$self->open_cmd_pipe_root(
        qw(lvm vgs --units B --reportformat json --all -o),
        'vg_name,pv_name,pv_size,pv_free,pv_used');
    $self->lvmjson2perl('vg', 'vgs-pv', 1, ['pv_name'], $lvm, join("\n", <$dh>));
    close $dh;

    $dh=$self->open_cmd_pipe_root(
        qw(lvm vgs --units B --reportformat json --all -o),
        'vg_name,lv_name,lv_size,data_percent,origin,pool_lv,lv_role');
    $self->lvmjson2perl('vg', 'vgs-lv', 1, ['lv_name'], $lvm, join("\n", <$dh>));
    close $dh;

    return {'lvm' => $lvm };
}

1;

###########################################################################
package StorageDisplay::Collect::FS;

use is_collector
    provides => 'fs',
    no_names => 1,
    depends => {
        progs => [ '/sbin/swapon', 'findmnt', 'stat' ],
	root => 1,
};

use StorageDisplay::Collect::JSON;

sub collect {
    my $self = shift;
    my $dh;

    # Swap and mounted FS
    $dh=$self->open_cmd_pipe(qw(/sbin/swapon --noheadings --raw --bytes),
                             '--show=NAME,TYPE,SIZE,USED');
    my $fs={};
    while(defined(my $line=<$dh>)) {
        chomp($line);
        if ($line =~ m,([^ ]+) (partition|file) ([0-9]+) ([0-9]+)$,) {
            my $info={
		filesystem => $1,
                size => $3,
                used => $4,
                free => ''.($3-$4),
                fstype => $2,
		mountpoint => 'SWAP',
            };
            my $dev = $1;
            if ($2 eq 'file') {
                my $dh2=$self->open_cmd_pipe_root(qw(findmnt -n -o TARGET --target), $1);
                my $mountpoint = <$dh2>;
                chomp($mountpoint) if defined($mountpoint);
                close $dh2;
                $info->{'file-mountpoint'}=$mountpoint;
		$dh2=$self->open_cmd_pipe_root(qw(stat -c %s), $1);
                my $size = <$dh2>;
                chomp($size);
                close $dh2;
                $info->{'file-size'}=$size;
            }
            $fs->{swap}->{$dev} = $info;
        } elsif ($line =~ m,([^ ]+) ([^ ]+) ([0-9]+) ([0-9]+)$,) {
            # skipping other kind of swap
        } else {
            print STDERR "W: swapon: Unknown line '$line'\n";
        }
    }
    close $dh;

    #$dh=$self->open_cmd_pipe_root(qw(findmnt --all --output-all --json --bytes --list));
    #my @json=<$dh>;
    #close $dh;
    #$fs->{flatfull} = StorageDisplay::Collect::JSON::jsonarray2perlhash(join("",@json), 'filesystems', 'id');

    $dh=$self->open_cmd_pipe_root(qw(findmnt --all --output-all --json --bytes));
    my @json=<$dh>;
    close $dh;
    my $data = StorageDisplay::Collect::JSON::decode_json(join("",@json))->{"filesystems"}->[0];
    my $rec;
    $rec = sub {
	my $node = shift;
	my $res = {
	    id => $node->{id},
	    target => $node->{target},
	};
	if (exists($node->{children})) {
	    $res->{children} = [ map { $rec->($_) } @{$node->{children}} ];
	}
	return $res;
    };
    $fs->{hierarchy} = $rec->($data);

    $rec = sub {
	my $node = shift;
	my $id = $node->{id};
	$fs->{flatfull}->{$id} = $node;
	if (exists($node->{children})) {
	    for my $child (@{$node->{children}}) {
		$rec->($child);
	    }
	    delete $node->{children};
	}
    };
    $rec->($data);

    return { 'fs' => $fs };
}

1;

###########################################################################
package StorageDisplay::Collect::LUKS;

use is_collector
    provides => 'luks',
    requires => [ qw(dm lsblk udev) ],
    depends => {
        progs => [ 'cryptsetup' ],
        root => 1,
};

sub select {
    my $self = shift;
    my $infos = shift;
    my $request = shift // {};
    my @devs=();

    my $dh;
    foreach my $kn (sort keys %{$infos->{'lsblk'}}) {
        my $udev_info = $infos->{'udev'}->{$kn};
        next if not defined($udev_info);
        if (($udev_info->{'_udev_infos'}->{ID_FS_TYPE} // '') ne 'crypto_LUKS') {
            next;
        }
        push @devs, $kn;
    }
    return @devs;
}

sub collect {
    my $self = shift;
    my $infos = shift;
    my $dh;
    my $luks={};

    my @devs=$self->select($infos);

    my $decrypted={
        map {
            $_->{DM_BLKDEVS_USED} => $_->{DM_BLKDEVNAME}
        } grep {
            ($_->{DM_SUBSYSTEM} // '') eq 'CRYPT'
        } values(%{$infos->{dm}})
    };

    foreach my $dev (@devs) {
        $dh=$self->open_cmd_pipe_root(
            qw(cryptsetup luksDump), '/dev/'.$dev);
        my $l={};
        my $luks_header=0;
        while(defined(my $line=<$dh>)) {
            chomp($line);
            if ($line =~ /^LUKS header information/) {
                $luks_header=1;
            } elsif ($line =~ /^Version:\s*([^\s]*)$/) {
                $l->{VERSION} = $1;
            }
        }
        close $dh;
        if ($luks_header) {
            $l->{decrypted} = $decrypted->{$dev};
            $luks->{$dev} = $l;
        }
    }

    return { 'luks' => $luks };
}

1;

###########################################################################
package StorageDisplay::Collect::MD;

use is_collector
    provides => 'md',
    requires => [ qw(dm lsblk udev) ],
    depends => {
        files => [ '/proc/mdstat' ],
        progs => [ 'mdadm' ],
        root => 1,
};

sub names_avail {
    my $self = shift;
    my $infos = shift;
    my @devs=();

    my $dh=$self->open_file('/proc/mdstat');
    while (defined(my $line=<$dh>)) {
        chomp($line);
        next if ($line =~ /^Personalities/);
        next if ($line =~ /^unused devices/);
        next if ($line =~ /^\s/);
        push @devs, ((split(/\s/, $line))[0]);
    }
    close $dh;
    return @devs;
}

sub collect {
    my $self = shift;
    my $infos = shift;
    my @devs = @{ shift // [ $self->select($infos) ]  };
    my $dh;
    my $md={};

    foreach my $dev (@devs) {
        $dh=$self->open_cmd_pipe_root(
            qw(mdadm --misc --detail), '/dev/'.$dev);
        my $l={};
        my $container=0;
        while(defined(my $line=<$dh>)) {
            chomp($line);
            if ($line =~ /^\s*Array Size :\s*([0-9]+)\s*\(/) {
                $l->{'array-size'} = $1*1024;
            } elsif ($line =~ /^\s*Used Dev Size :\s*([0-9]+)\s*\(/) {
                $l->{'used-dev-size'} = $1*1024;
            } elsif ($line =~ /^\s*Raid Level :\s*([^\s].*)/) {
                $l->{'raid-level'} = $1;
                if ($1 eq 'container') {
                    $l->{'raid-container'} = 1;
                    $container = 1;
                }
            } elsif ($line =~ /^\s*State : \s*([^\s].*)/) {
                $l->{'raid-state'} = $1;
            } elsif ($line =~ /^\s*Version : \s*([^\s].*)/) {
                $l->{'raid-version'} = $1;
            } elsif ($line =~ /^\s*Name : \s*([^\s]+)\s*/) {
                $l->{'raid-name'} = $1;
            } elsif ($line =~ /^\s*Member Arrays : \s*([^\s]+.*[^\s])\s*/) {
                $l->{'raid-member-arrays'} = [ split(/ +/, $1) ];
            } elsif ($line =~ /^\s*Container : \s*([^\s]+), member ([0-9]+)\s*/) {
                $l->{'raid-container-device'} = $1;
                $l->{'raid-container-member'} = $2;
            } elsif ($line =~ /^\s*Number\s*Major\s*Minor\s*RaidDevice(\s*State)?/) {
                last;
            }
        }

        my $raid_id = 0;
        while(defined(my $line=<$dh>)) {
            chomp($line);
            if ((! $container)
                && $line =~ /^\s*([0-9]+)\s+([0-9]+)\s+([0-9]+)\s+([0-9-]+)\s+([^\s].*[^\s])\s+([^\s]+)$/) {
                $l->{'devices'}->{$6} = {
                    state => $5,
                    raiddevice => $4,
                };
            } elsif ($container
                     && $line =~ /^\s*(-)\s+([0-9]+)\s+([0-9]+)\s+(-)\s+([^\s]+)$/) {
                $l->{'devices'}->{$5} = {
                    raiddevice => $raid_id++,
                };
            } elsif ($line =~ /^\s*$/) {
            } else {
                print STDERR "W: mdadm on $dev: Unknown line '$line'\n";
            }
        }
        close $dh;
        $md->{$dev} = $l;
    }

    return { 'md' => $md };
}

1;

###########################################################################
package StorageDisplay::Collect::LSI::Sas2ircu;

use is_collector
    provides => 'lsi-sas-ircu',
    depends => {
        progs => [ 'sas2ircu' ],
        root => 1,
};

sub select {
    my $self = shift;
    my $infos = shift;
    my $request = shift // {};
    my @devs=();

    my $dh;
    $dh=$self->open_cmd_pipe_root(qw(sas2ircu LIST));
    my $state=0;
    my $nodata=0;
    while (defined(my $line=<$dh>)) {
        chomp($line);
        if ($state == 0) {
            $nodata=1 if $line eq 'SAS2IRCU: MPTLib2 Error 1';
            next if $line !~ /^[\s-]*-[\s-]*$/;
            $state = 1;
        } elsif ($state == 1) {
            if ($line =~ /^SAS2IRCU:/) {
                if ($line ne 'SAS2IRCU: Utility Completed Successfully.') {
                    print STDERR "W: sas2ircu: $line\n";
                }
                $state = 2;
            } elsif ($line =~ /^\s*([0-9]+)\s+/) {
                push @devs, $1;
            } else {
                print STDERR "E: sas2ircu: unknown line: $line\n";
            }
        } elsif ($state == 2) {
            print STDERR "W: sas2ircu: $line\n";
        }
    }
    if ($state != 2) {
        if ($state != 0 || $nodata != 1) {
            print STDERR "E: sas2ircu: Cannot parse data\n";
        }
    }
    close $dh;
    return @devs;
}

sub parse {
    my $parser = shift;
    my $closure = shift;
    my $res = shift // {};

}

my %name = (
    'Size (in MB)' => 'size-mb',
    'Volume ID' => 'id',
    'Volume wwid' => 'wwid',
    'Status of volume' => 'status',
    );

sub collect {
    my $self = shift;
    my $infos = shift;
    my $dh;
    my $lsi={};

    my @devs=$self->select($infos);


    my $parse_section = sub {
        my $self = shift;
        my $line = shift;
        if ($line eq 'Controller information') {
            #$self->push_new_section->($parse_controller, $closure_controller);
        } elsif ($line eq 'IR Volume information') {
            #return (1, $parse_volumes);
        } elsif ($line eq 'Physical device information') {
            #return (1, $parse_phydev);
        } elsif ($line eq 'Enclosure information') {
            #return (1, $parse_phydev);
        } elsif ($line =~ /SAS2IRCU:/) {
            if ($line eq 'SAS2IRCU: Command DISPLAY Completed Successfully.'
                or $line eq 'SAS2IRCU: Utility Completed Successfully.') {
            } else {
                print STDERR "W: sas2ircu: $line\n";
            }
        } else {
            #if (scalar(keys %$l) != 0) {
            #    print  STDERR "W: sas2ircu: unknown line: $line\n";
            #}
        }
        return 1;
    };


    foreach my $dev (@devs) {
        $dh=$self->open_cmd_pipe_root('sas2ircu', $dev, 'DISPLAY');
        my $l={};
        my $state = 0;
        my $wwid = {};
        my $guid = {};

        my $data = undef;
        my $secdata = undef;

        my $closure=sub {} ;
        my $subclosure=sub {} ;
        while(defined(my $line=<$dh>)) {
            chomp($line);
            next if $line =~ /^[\s-]*$/;
            if ($line =~ /^(Controller) information$/
                || $line =~ /^(Enclosure) information$/) {
                my $section = lc($1);
                $subclosure->($data);
                $closure->($data);
                $data = {};
                $subclosure = sub {};
                $closure = sub {
                    my $curdata = shift;
                    if (exists($l->{$section})) {
                        print STDERR "E: sas2ircu: duplicate section: $line\n";
                    }
                    $l->{$section}=$curdata;
                    return {};
                };
                $state=10;
            } elsif ($line =~ /^IR (Volume) information$/
                     || $line =~ /^Physical (device) information$/) {
                my $section = lc($1).'s';
                $subclosure->($data);
                $closure->($data);
                $secdata=[];
                $subclosure = sub { };
                $closure=sub {
                    my $data = shift;
                    if (exists($l->{$section})) {
                        print STDERR "E: sas2ircu: duplicate section: $line\n";
                    }
                    $l->{$section}=$secdata;
                    return
                };
            } elsif ($line =~ /^IR volume ([^\s])+$/) {
                my $name = $1;
                $subclosure->($data);
                $data = {
                    name => $name,
                };
                $subclosure = sub {
                    my $data = shift;
                    push @$secdata, $data;
                };
            } elsif ($line =~ /^Device is a Hard disk$/) {
                $subclosure->($data);
                $data = {};
                $subclosure = sub {
                    my $data = shift;
                    push @$secdata, $data;
                };
            } elsif ($line =~ /^Initiator at ID .*$/) {
            } elsif ($line =~ /^SAS2IRCU: .* Completed Successfully.$/) {
            } elsif ($line =~ /^[^\s]/) {
                if ($state != 0) {
                    print STDERR "W: sas2ircu: unknown line: $line\n";
                }
            } elsif ($line =~ /^\s+([^\s][^:]*[^\s])\s*:\s+([^\s].*)$/) {
                my $k = $1;
                my $v = $2;
                if ($k =~ m,^PHY\[([^\]]+)\] Enclosure#/Slot#,) {
                    my $phy=$1;
                    my ($e, $s) = split(':', $v);
                    $data->{PHY}->{$phy} = { enclosure => $e, slot => $s };
                    next;
                } elsif ($k eq 'Size (in MB)/(in sectors)') {
                    my ($s1, $s2) = split('/', $v);
                    $data->{'size-mb'}=$s1;
                    $data->{'size-s'}=$s2;
                    $data->{'size'}=$s2 * 512;
                    next;
                }
                $k = $name{$k} // $k;
                $k =~ s/\s*[#]//;
                $k = lc($k);
                $k =~ s/\s+/-/g;
                if ($k eq 'guid') {
                    $guid->{$v}=1;
                } elsif ($k eq 'wwid') {
                    $wwid->{$v}=1;
                }
                $data->{$k}=$v;
            }
        }
        $subclosure->($data);
        $closure->($data);
        close $dh;
        $dh=$self->open_cmd_pipe(qw(find /sys/devices -name sas_address));
        my @lines=<$dh>;
        for my $line (sort @lines) {
            chomp($line);
            my $dh2 = $self->open_file($line)
                or die "Cannot open $line: $!\n";
            my $addr=<$dh2>;
            close $dh2;
            chomp($addr);
            $addr =~ s/^0x//;
            if (defined($wwid->{$addr})) {
                my $dir = $line;
                $dir =~ s/sas_address/block/;
                my $dh3 = $self->open_cmd_pipe('ls', '-1', $dir);
                my @dirs=<$dh3>;
                close($dh3);
                if (scalar(@dirs) != 1) {
                    print STDERR "E: sas2ircu: bad number of block devices for $addr\n";
                } else {
                    chomp($l->{wwid}->{$addr} = $dirs[0]);
                }
            }
        }
        $lsi->{$dev} = $l;
    }

    return { 'lsi-sas-ircu' => $lsi };
}

1;

###########################################################################
package StorageDisplay::Collect::LSI::Megacli;

use is_collector
    provides => 'lsi-megacli',
    depends => {
        progs => [ 'megaclisas-status', 'megacli' ],
        root => 1,
};

sub select {
    my $self = shift;
    my $infos = shift;
    my $request = shift // {};
    my @devs=();

    my $dh;
    $dh=$self->open_cmd_pipe_root(qw(megacli -adpCount -NoLog));
    while (defined(my $line=<$dh>)) {
        chomp($line);
        next if $line !~ /^Controller Count:\s*([0-9]+)\.?\s*$/;
        my $nb_controllers = $1;
        for (my $i=0; $i<$nb_controllers; $i++) {
            push @devs, $i;
        }
        close $dh;
        return @devs;
    }
    print STDERR "E: megacli: cannot find the number of controllers, assuming 0\n";
    close $dh;
    return @devs;
}

sub parse {
    my $parser = shift;
    my $closure = shift;
    my $res = shift // {};

}

sub interleave {
  my @lists = map [@$_], @_;
  my @res;
  while (my $list = shift @lists) {
    if (@$list) {
      push @res, shift @$list;
      push @lists, $list;
    }
  }
  wantarray ? @res : \@res;
}

sub collect {
    my $self = shift;
    my $infos = shift;
    my $dh;

    my @devs=$self->select($infos);

    my $megacli={ map { $_ => {} } @devs };

    $dh=$self->open_cmd_pipe_root('megaclisas-status');

    my $section_name;
    my @headers;
    while(defined(my $line=<$dh>)) {
        chomp($line);
        next if $line =~ /^\s*$/;
        if ($line =~ /^-- (.*) [Ii]nformation(s)?(\s*--)?\s*$/) {
            $section_name=$1;
            if ($section_name =~ /Disk/) {
                $section_name = 'Disk';
            }
        } elsif ($line =~ /^--\s*(ID\s*|.*[^\s])\s*$/) {
            @headers = split(/\s*[|]\s*/, $1);
        } elsif ($line =~ /^(c([0-9]+)(\s|u).*[^\s])\s*$/) {
            my $idc = $2;
            next if not exists($megacli->{$idc});
            my @infos = split(/\s*[|]\s*/, $1);
            if (scalar(@infos) != scalar(@headers)) {
                print STDERR "E: megaclisas-status: invalid number of information: $line\n";
                next;
            }
            my $infos = { interleave(\@headers, \@infos) };
            my $id = $infos->{ID};
            if ($section_name eq 'Disk') {
                $id = $infos->{'Slot ID'};
            }
            if (exists($megacli->{$idc}->{$section_name}->{$id})) {
                print STDERR "E: megaclisas-status: duplicate info for $id: $line\n";
            }
            $megacli->{$idc}->{$section_name}->{$id}=$infos;
        } elsif ($line =~ /^There is at least one disk\/array in a NOT OPTIMAL state.$/) {
            # skip
        } elsif ($line =~ /^RAID ERROR - Arrays: OK:[0-9]+ Bad:[0-9]+ - Disks: OK:[0-9]+ Bad:[0-9]+$/) {
            # skip
        } elsif ($line =~ /^No MegaRAID or PERC adapter detected on your system!$/) {
	    # skip
        } else {
            print STDERR "E: megaclisas-status: invalid line: $line\n";
        }
    }
    close($dh);

    for my $dev (@devs) {
        $dh=$self->open_cmd_pipe_root(qw(megacli -PDList), "-a$dev");
        my $cur_enc;
        my $cur_slot;
        my $cur_size;
        my $get_cur_disk=sub {
            my $slot_id = "[$cur_enc:$cur_slot]";
            if (not exists($megacli->{$dev}->{'Disk'}->{$slot_id})) {
                print STDERR "E: missing disk with slot $slot_id\n";
                return;
            }
            return $megacli->{$dev}->{'Disk'}->{$slot_id};
        };
        while(defined(my $line=<$dh>)) {
            chomp($line);
            next if $line =~ /^\s*$/;
            next if $line eq "Adapter #$dev";
            if ($line eq "^Adapter") {
                print STDERR "W: megacli: strange adapter for #$dev: $line\n";
                next;
            }
            if ($line =~ /^Enclosure Device ID: *([0-9]+|N\/A) *$/) {
                $cur_enc=$1;
		$cur_enc='' if $cur_enc eq 'N/A';
                $cur_slot=undef;
                next;
            }
            if ($line =~ /^Enclosure Device ID: *(.*) *$/) {
                print STDERR "W: megacli: strange enclosure device ID '$1'\n";
	    }
            if ($line =~ /^Slot Number: *([0-9]+) *$/) {
                if (defined($cur_slot) || not defined($cur_enc)) {
                    print STDERR "W: megacli: strange state when finding slot number $1\n";
                }
                $cur_slot=$1;
                next;
            }
            if ($line =~ /^Array *#: *([0-9]+) *$/) {
                my $d=$get_cur_disk->() // next;
                if ($d->{'ID'} !~ /^c[0-9]+uXpY$/) {
                    my $slot_id = $d->{'Slot ID'};
                    print STDERR "E: slot $slot_id has a strange ID\n";
                    next;
                }
                $d->{'ID'} =~ s/X/$dev/;
            }
            if ($line =~ /^Coerced Size:.*\[(0x[0-9a-f]+) *Sectors\]/i) {
                my $d=$get_cur_disk->() // next;
                $d->{'# sectors'} = $1;
            }
            if ($line =~ /^Sector Size: *([0-9]+)$/i) {
                my $d=$get_cur_disk->() // next;
                $d->{'sector size'} = ($1==0)?512:$1;
            }
        }
        close($dh);
    }

    return { 'lsi-megacli' => $megacli };
}

1;

###########################################################################
package StorageDisplay::Collect::Libvirt;

use is_collector
    provides => 'libvirt',
    depends => {
        progs => [ 'virsh' ],
        root => 1,
};

sub select {
    my $self = shift;
    my $infos = shift;
    my $request = shift // {};
    my @vms=();

    my $dh=$self->open_cmd_pipe_root(qw(virsh list --all --name));
    while(defined(my $line=<$dh>)) {
        chomp($line);
        next if $line =~ /^\s*$/;
        push @vms, $line;
    }
    close $dh;
    @vms = sort @vms;
    return @vms;
}

sub collect {
    my $self = shift;
    my $infos = shift;
    my $dh;
    my $libvirt={};

    my @vms=$self->select($infos);

    foreach my $vm (@vms) {
        $dh=$self->open_cmd_pipe_root(qw(virsh domstate), $vm);
        my $v={ name => $vm };
        while(defined(my $line=<$dh>)) {
            chomp($line);
            if ($line =~ /running/) {
                $v->{state} = 'running';
                last;
            }
        }
        close $dh;
        $dh=$self->open_cmd_pipe_root(qw(virsh domblklist --details), $vm);
        while(defined(my $line=<$dh>)) {
            chomp($line);
            next if $line =~ /^[\s-]*$/;
            my @info=split(' ', $line);
            next if ($info[0]//'') eq 'Type';
            #next if ($info[0]//'') ne 'block';
            next if $info[3] eq '-';
            if (scalar(@info) != 4) {
                print STDERR "W: libvirt on $vm: Unknown line '$line'\n";
                next;
            }
            $v->{'blocks'}->{$info[3]} = {
                type => $info[0],
                device => $info[1],
                target => $info[2],
                source => $info[3],
            };
            if ($info[0] eq 'file') {
		StorageDisplay::Collect::File::select_file($info[3]);
            } elsif ($info[0] eq 'block') {
	    } else {
		print STDERR "W: unknown VM device type: $info[0]\n";
	    }
        }
        close $dh;
	if ($v->{state}//'' eq 'running') {
	    # trying to get infos from QEMU guest agent
	    $dh=$self->open_cmd_pipe_root(qw(virsh guestinfo --hostname --disk), $vm);
	    my $curdisk='';
	    my $curdiskinfo={};
	    while(defined(my $line=<$dh>)) {
		chomp($line);
		if ($curdisk ne '' && $line !~ /^disk\.$curdisk\./) {
		    if (exists($curdiskinfo->{name}) && exists($curdiskinfo->{alias})) {
			#print STDERR "W: libvirt guestagent on $vm: adding ".$curdiskinfo->{alias}."\n";
			$v->{ga}->{disks}->{$curdiskinfo->{alias}}=$curdiskinfo;
		    }
		    $curdiskinfo={};
		    $curdisk = '';
		}
		next if $line =~ /^[\s-]*$/;
		if ($line !~ m/^([^:\s]+)\s*: (.*)$/) {
		    print STDERR "W: libvirt guestagent on $vm: Unknown line '$line'\n";
		}
		my $key=$1;
		my $value=$2;
		if ($key eq 'hostname') {
		    $v->{ga}->{hostname} = $value;
		    next;
		}
		if ($key =~ /^disk\.([0-9]+)\./) {
		    $curdisk = $1;
		    if ($key =~ /\.(name|alias)$/) {
			$curdiskinfo->{$1} = $value;
		    }
		}
	    }
	    close $dh;
	    if ($curdisk ne '') {
		# the last empty line should have set $curdisk to ''
		print STDERR "W: libvirt guestagent on $vm: end-before-end '$curdisk'\n";
	    }
	}
        $libvirt->{$vm} = $v;
    }

    return { 'libvirt' => $libvirt };
}

1;

###########################################################################
package StorageDisplay::Collect::Loops;

use is_collector
    provides => 'loops',
    depends => {
        progs => [ 'losetup' ],
        root => 1,
};

use StorageDisplay::Collect::JSON;
sub losetupjson2perl {
    my $self = shift;
    my $json = shift;
    return StorageDisplay::Collect::JSON::jsonarray2perlhash($json, 'loopdevices', 'name');
}

sub select {
    my $self = shift;
    my $infos = shift;
    my $request = shift // {};
    my @loops;

    my $dh=$self->open_cmd_pipe_root(qw(losetup --output NAME));
    while(defined(my $line=<$dh>)) {
        chomp($line);
        next if $line =~ /^NAME$/;
        push @loops, $line;
    }
    close $dh;
    @loops = sort @loops;
    return @loops;
}

sub collect {
    my $self = shift;
    my $infos = shift;
    my $files={};

    my @loops=$self->select($infos);

    my $dh=$self->open_cmd_pipe_root(qw(losetup --output-all --list --json));
    my $all_loops = $self->losetupjson2perl(join(' ', <$dh>));
    close $dh;

    my $loops={};
    foreach my $loop (@loops) {
	$loops->{$loop} = $all_loops->{$loop};
	my $filename = $loops->{$loop}->{'back-file'};
	StorageDisplay::Collect::File::select_file($filename);
	if ($filename =~ /(.*) \(deleted\)/) {
	    StorageDisplay::Collect::File::select_file($1);
	}
    }
    return { 'loops' => $loops };
}

1;

###########################################################################
package StorageDisplay::Collect::File;

# This collector must be the last one as it collects info on requested
# files by other collectors.

use is_collector
    provides => 'files',
    depends => {
        progs => [ 'findmnt' ],
        root => 1,
};

use StorageDisplay::Collect::JSON;
use Data::Dumper;
sub statjson2perl {
    my $self = shift;
    my $json = shift;
    return StorageDisplay::Collect::JSON::jsonarray2perlhash($json, 'stats', 'name');
}

my $files = {};

sub select_file {
    my $filename = shift;
    $files->{$filename} = 1;
}

sub select {
    my $self = shift;
    my $infos = shift;
    my $request = shift // {};
    my @files = sort keys %{$files};
    return @files;
}

sub collect {
    my $self = shift;
    my $infos = shift;
    my $files={};

    my @files=$self->select($infos);
    my @json;
    my @present;

    if (scalar(@files) == 0) {
	return { 'files' => [] };
    }
    my $dh0=$self->open_cmd_pipe_root(
	qw(perl -e),
	'my '.Dumper(\@files).
	'grep { if (-e $_) { print "OK\n" } else { print "NACK\n" }; 1 } @{$VAR1};');
    my @res = <$dh0>;
    close $dh0;
    if (scalar(@files) != scalar(@res)) {
	print STDERR "WARNING: Something goes wrong with stat files\n";
    } else {
	for(my $i=0; $i<scalar(@res); $i++) {
	    if ($res[$i] =~ /^OK/) {
		push @present, $files[$i];
	    } else {
		push @json, '{ "name":"'.$files[$i].'", "deleted":true },'."\n";
	    }
	}
    }
    if (scalar(@present) > 0) {
	my $dh=$self->open_cmd_pipe_root(
	    # '%[LH][rd]' do not exist on old stat tool
	    qw(stat -c),
	    '{ "name":"%n", "deleted":false, "size":%s, "inode":%i,'.
	    ' "permission":"0%a", "mode":"0x%f", "blocks":%b,'.
	    ' "blocksize":%B, "st_dev":%d, "hardlinks":%h,'.
	    ' "mountpoint":"%m", "st_rdev":"%r", "st_special":"%t:%T" },',
	    @present);
	push @json, <$dh>;
    }
    my $json=join("", @json);
    chomp($json);
    $json =~ s/,$//;
    #print STDERR "json=$json\n";
    return { 'files' => $self->statjson2perl('{ "stats": [  '.$json."\n] }") };
}

# This collector must be the last one as it collects info on requested
# files by other collectors.

1;

###########################################################################
###########################################################################
###########################################################################
###########################################################################
package StorageDisplay::Collect;

sub dump_collect {
    my $reader = shift // 'Local';
    my $collector = __PACKAGE__->new($reader, @_);

    my $info = $collector->collect();

    use Data::Dumper;
    # sort keys
    $Data::Dumper::Sortkeys = 1;
    $Data::Dumper::Purity = 1;

    print Dumper($info);
    #print Dumper(\%INC);
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

StorageDisplay::Collect - modules required to collect data.

=head1 VERSION

version 2.04

Main class, allows one to register collectors and run them
(through the collect method)

Collectors will be registered when their class is loaded

Wrapper around JSON:PP as old versions do not support the
boolean_value method.

Base (abstract) class to run command to collect infos

Only one instance should be created

# sub classes must implement open_cmd_pipe and open_cmd_pipe_root

Run commands locally

Run commands through SSH

Record commands

Used to declare a class to be a collector.

The collector will be registered

Base class for collectors

=head1 AUTHOR

Vincent Danjean <[e-mail]>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2014-2023 by Vincent Danjean.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut