HV-Monitor/lib/HV/Monitor/Backends/Libvirt.pm
package HV::Monitor::Backends::Libvirt;
use 5.006;
use strict;
use warnings;
use JSON;
use File::Slurp qw(read_file);
=head1 NAME
HV::Monitor::Backends::Libvirt - Libvirt support for HV::Monitor
=head1 VERSION
Version 0.0.4
=cut
our $VERSION = '0.0.4';
=head1 SYNOPSIS
use HV::MOnitor::Backend::Libvirt;
my $backend=HV::MOnitor::Backend::CBSD->new;
my $usable=$backend->usable;
if ( $usable ){
$return_hash_ref=$backend->run;
}
=head1 METHODS
=head2 new
Initiates the backend object.
my $backend=HV::MOnitor::Backend::Libvirt->new;
=cut
sub new {
my $self = { version => 1, };
bless $self;
return $self;
}
=head2 run
$return_hash_ref=$backend->run;
=cut
sub run {
my $self = $_[0];
my $hz = `getconf CLK_TCK`;
chomp($hz);
my $list_raw = `virsh list --all --name`;
if ( $? != 0 ) {
return {
data => { hv => 'libvirt' },
version => $self->{version},
error => 2,
errorString => '"virsh list --all --name" exited non-zero',
};
}
#
# build a indexed mapping of netdev to bridge mappings
#
my @net_list;
foreach my $net_name (
grep( !/[\ \t]*Name[\ \t]+State[\ \t]+Autostart[\ \t]+Persistent$/,
grep( !/^-+$/, split( /\n/, `virsh net-list --all` ) ) )
)
{
$net_name =~ s/^[\ \t]*//;
$net_name =~ s/[\ \t]+.*$//;
push( @net_list, $net_name );
}
my $net_cache = {};
foreach my $net_name (@net_list) {
my ($bridge_dev) = grep( /^Bridge\:/, `virsh net-info $net_name` );
$bridge_dev =~ s/^Bridge\:[\ \t]+//;
chomp($bridge_dev);
$bridge_dev =~ s/[\ \t].*$//;
$net_cache->{$net_name} = $bridge_dev;
}
my @VMs = grep( !/^[\ \t]*$/, split( /\n/, $list_raw ) );
my $ifs_raw = `ifconfig | grep '^[A-Za-z]' | cut -d: -f 1`;
my @ifs = split( /\n/, $ifs_raw );
my $return_hash = {
VMs => {},
hv => 'libvirt',
totals => {
'usertime' => 0,
'pmem' => 0,
'oublk' => 0,
'minflt' => 0,
'pcpu' => 0,
'mem_alloc' => 0,
'nvcsw' => 0,
'snaps' => 0,
'rss' => 0,
'snaps_size' => 0,
'cpus' => 0,
'cow' => 0,
'nivcsw' => 0,
'systime' => 0,
'vsz' => 0,
'etimes' => 0,
'majflt' => 0,
'inblk' => 0,
'nswap' => 0,
'on' => 0,
'off' => 0,
'off_hard' => 0,
'off_soft' => 0,
'unknown' => 0,
'paused' => 0,
'crashed' => 0,
'blocked' => 0,
'nostate' => 0,
'pmsuspended' => 0,
'freqs' => 0,
'ftime' => 0,
'ipkts' => 0,
'ierrs' => 0,
'ibytes' => 0,
'idrop' => 0,
'opkts' => 0,
'oerrs' => 0,
'obytes' => 0,
'coll' => 0,
'odrop' => 0,
}
};
# values that should be totaled
my @total = (
'usertime', 'pmem', 'oublk', 'minflt', 'pcpu', 'mem_alloc',
'nvcsw', 'snaps', 'rss', 'snaps_size', 'cpus', 'cow',
'nivcsw', 'systime', 'vsz', 'etimes', 'majflt', 'inblk',
'nswap', 'disk_alloc', 'disk_in_use', 'rbytes', 'rtime', 'rreqs',
'wbytes', 'wreqs', 'ftime', 'freqs', 'wtime', 'disk_on_disk',
'snaps', 'freqs', 'ftime', 'ipkts', 'ierrs', 'ibytes',
'idrop', 'opkts', 'oerrs', 'obytes', 'coll', 'odrop'
);
foreach my $vm (@VMs) {
my $domstats_raw = `virsh domstats $vm`;
my $domstats = {};
my @domstats_split = grep( !/^Domain/, grep( !/^[\ \t]*$/, split( /\n/, $domstats_raw ) ) );
foreach my $line (@domstats_split) {
chomp($line);
$line =~ s/^[\ \t]+//;
my ( $stat, $value ) = split( /=/, $line, 2 );
$domstats->{$stat} = $value;
}
# The ones below are linux only, so just zeroing here.
# syscw syscw rchar wchar rbytes wbytes cwbytes
my $vm_info = {
mem_alloc => $domstats->{'balloon.maximum'},
cpus => $domstats->{'vcpu.maximum'},
pcpu => 0,
os_type => 0,
ip => '',
status_int => $domstats->{'state.state'},
console_type => '',
console => '',
snaps_size => 0,
ifs => {},
rbytes => 0,
wbytes => 0,
etimes => 0,
pmem => 0,
cow => 0,
majflt => 0,
minflt => 0,
nice => 0,
nivcsw => 0,
nswap => 0,
nvcsw => 0,
inblk => 0,
oublk => 0,
pri => 0,
rss => 0,
systime => 0,
usertime => 0,
vsz => 0,
disk_alloc => 0,
disk_in_use => 0,
disk_on_disk => 0,
disks => {},
freqs => 0,
ftime => 0,
ipkts => 0,
ierrs => 0,
ibytes => 0,
idrop => 0,
opkts => 0,
oerrs => 0,
obytes => 0,
coll => 0,
odrop => 0,
};
$vm_info->{mem_alloc} = $vm_info->{mem_alloc} * 1024;
# https://libvirt.org/html/libvirt-libvirt-domain.html#virDomainState
# VIR_DOMAIN_NOSTATE = 0 (0x0) no state
# VIR_DOMAIN_RUNNING = 1 (0x1) the domain is running
# VIR_DOMAIN_BLOCKED = 2 (0x2) the domain is blocked on resource
# VIR_DOMAIN_PAUSED = 3 (0x3) the domain is paused by user
# VIR_DOMAIN_SHUTDOWN = 4 (0x4) the domain is being shut down
# VIR_DOMAIN_SHUTOFF = 5 (0x5) the domain is shut off
# VIR_DOMAIN_CRASHED = 6 (0x6) the domain is crashed
# VIR_DOMAIN_PMSUSPENDED = 7 (0x7) the domain is suspended by guest power management
my @hv_args;
if ( $domstats->{'state.state'} eq 1
|| $domstats->{'state.state'} eq 3
|| $domstats->{'state.state'} eq 4 )
{
my $pid = `ps ax o pid,args | grep qemu | grep ' -name '| grep 'guest='$vm','`;
$pid =~ s/^[\ \t]*//;
chomp($pid);
$pid =~ s/^[\ \t]*//;
my $command = $pid;
$pid =~ s/[\ \t]+.*$//;
$command =~ s/^[0-9]+[\ \t]+//;
@hv_args = split( /\n/, `cat /proc/$pid/cmdline | strings` );
my $ps_info = `ps -q $pid --no-headers -o pcpu,pmem,etimes,vsz,pri,nice`;
$ps_info =~ s/^[\ \t]*//;
chomp($ps_info);
$ps_info =~ s/^[\ \t]*//;
$ps_info =~ s/[\ \t]*$//;
( $vm_info->{pcpu}, $vm_info->{pmem}, $vm_info->{etimes}, $vm_info->{vsz}, $vm_info->{nice} )
= split( /[\ \t]+/, $ps_info );
my $console_type = 'unknown';
my $console_options = $command;
if ( $command =~ s/[\ \t]-vnc[\t\ ]// ) {
$console_type = 'vnc';
$console_options =~ s/.*\-vnc[\t\ ]+//;
}
elsif ( $command =~ s/[\ \t]-spice[\t\ ]// ) {
$console_type = 'spice';
$console_options =~ s/.*\-spice[\t\ ]+//;
}
$console_options =~ s/[\t\ ].*$//;
$vm_info->{console_type} = $console_type;
$vm_info->{console} = $console_options;
eval {
my $proc_stat_raw = read_file( '/proc/' . $pid . '/stat' );
my @proc_stat = split( /[\ \t]+/, $proc_stat_raw );
$vm_info->{majflt} = $proc_stat[10];
$vm_info->{minflt} = $proc_stat[9];
$vm_info->{usertime} = $proc_stat[13] / $hz;
$vm_info->{systime} = $proc_stat[14] / $hz;
};
eval {
my $proc_status_raw = read_file( '/proc/' . $pid . '/status' );
my $proc_status = {};
foreach my $line ( split( /\n/, $proc_status_raw ) ) {
my ( $status_key, $status_value ) = split( /\:/, $line );
$status_value =~ s/^[\ \t]*//;
$status_value =~ s/[\ \t]*$//;
$proc_status->{$status_key} = $status_value;
}
$vm_info->{nvcsw} = $proc_status->{voluntary_ctxt_switches};
$vm_info->{nivcsw} = $proc_status->{nonvoluntary_ctxt_switches};
};
$vm_info->{rss} = $domstats->{'balloon.rss'};
# convert to bytes for easier display
if ( defined( $vm_info->{rss} ) ) {
$vm_info->{rss} = $vm_info->{rss} * 1024;
}
else {
$vm_info->{rss} = 0;
}
$vm_info->{vsz} = $vm_info->{rss} * 1024;
}
#
# process interfaces
#
my $nic_int = 0;
while ( defined( $domstats->{ 'net.' . $nic_int . '.name' } ) ) {
my $nic_info = {
mac => '',
parent => '',
if => $domstats->{ 'net.' . $nic_int . '.name' },
ipkts => $domstats->{ 'net.' . $nic_int . '.rx.pkts' },
ierrs => $domstats->{ 'net.' . $nic_int . '.rx.errs' },
ibytes => $domstats->{ 'net.' . $nic_int . '.rx.bytes' },
idrop => $domstats->{ 'net.' . $nic_int . '.rx.drop' },
opkts => $domstats->{ 'net.' . $nic_int . '.tx.pkts' },
oerrs => $domstats->{ 'net.' . $nic_int . '.tx.errs' },
obytes => $domstats->{ 'net.' . $nic_int . '.tx.bytes' },
odrop => $domstats->{ 'net.' . $nic_int . '.tx.drop' },
coll => 0,
};
$vm_info->{ipkts} = $nic_info->{ipkts};
$vm_info->{ierrs} = $nic_info->{ierrs};
$vm_info->{ibytes} = $nic_info->{ibytes};
$vm_info->{idrop} = $nic_info->{odrop};
$vm_info->{opkts} = $nic_info->{opkts};
$vm_info->{oerrs} = $nic_info->{oerrs};
$vm_info->{obytes} = $nic_info->{obytes};
$vm_info->{odrop} = $nic_info->{odrop};
$vm_info->{coll} = $nic_info->{coll};
# get the mac and parent
my $netdev = 'net' . $nic_int;
my @net_line
= grep( /\"mac\"/, grep( /\"netdev\"/, grep( /^[\ \t]*{.*\"$netdev\".*\}[\ \t]*$/, @hv_args ) ) );
if ( defined( $net_line[0] ) ) {
eval {
my $json = decode_json( $net_line[0] );
$nic_info->{mac} = $json->{mac};
$json->{netdev} =~ s/^[a-zA-Z]+//;
if ( defined( $net_list[ $json->{netdev} ] ) ) {
if ( defined( $net_cache->{ $net_list[ $json->{netdev} ] } ) ) {
$nic_info->{parent} = $net_cache->{ $net_list[ $json->{netdev} ] };
}
}
}
}
else {
# looks like we did not find one that appears to be a JSON style one, so now try for the CSV style
@net_line
= grep( /virtio-net-pci/, grep( /mac/, grep( /\=$netdev\,/, @hv_args ) ) );
# if we failed, now check for it with $netdev at the end of the arg
if ( !defined( $net_line[0] ) ) {
@net_line
= grep( /virtio-net-pci/, grep( /mac/, grep( /\=$netdev$/, @hv_args ) ) );
}
if ( defined( $net_line[0] ) ) {
my @net_line_split = split( /\,/, $net_line[0] );
foreach my $net_line_arg (@net_line_split) {
my ( $net_line_key, $net_line_value ) = split( /\=/, $net_line_arg, 2 );
if ( defined($net_line_key)
&& defined($net_line_value)
&& $net_line_value ne ''
&& $net_line_key ne '' )
{
if ( $net_line_key eq 'mac' ) {
$nic_info->{mac} = $net_line_value;
}
}
}
}
}
$vm_info->{ifs}{ 'nic' . $nic_int } = $nic_info;
$nic_int++;
}
#
# process block devices
#
my $block_int = 0;
while ( defined( $domstats->{ 'block.' . $block_int . '.name' } ) ) {
my $disk_info = {
in_use => $domstats->{ 'block.' . $block_int . '.allocation' },
on_disk => $domstats->{ 'block.' . $block_int . '.physical' },
alloc => $domstats->{ 'block.' . $block_int . '.capacity' },
rbytes => 0,
rtime => 0,
rreqs => 0,
wbytes => 0,
wtime => 0,
wreqs => 0,
freqs => 0,
ftime => 0,
};
if ( defined( $domstats->{ 'block.' . $block_int . '.rd.bytes' } ) ) {
$disk_info->{rbytes} = $domstats->{ 'block.' . $block_int . '.rd.bytes' };
$disk_info->{rtime} = $domstats->{ 'block.' . $block_int . '.rd.times' } / 1000000;
$disk_info->{rreqs} = $domstats->{ 'block.' . $block_int . '.rd.reqs' };
$disk_info->{wbytes} = $domstats->{ 'block.' . $block_int . '.wr.bytes' };
$disk_info->{wtime} = $domstats->{ 'block.' . $block_int . '.wr.times' } / 1000000;
$disk_info->{wreqs} = $domstats->{ 'block.' . $block_int . '.wr.reqs' };
$disk_info->{ftime} = $domstats->{ 'block.' . $block_int . '.fl.times' } / 1000000;
$disk_info->{freqs} = $domstats->{ 'block.' . $block_int . '.fl.reqs' };
$vm_info->{rbytes} += $domstats->{ 'block.' . $block_int . '.rd.bytes' };
$vm_info->{rtime} += $disk_info->{rtime};
$vm_info->{rreqs} += $domstats->{ 'block.' . $block_int . '.rd.reqs' };
$vm_info->{wbytes} += $domstats->{ 'block.' . $block_int . '.wr.bytes' };
$vm_info->{wtime} += $disk_info->{wtime};
$vm_info->{wreqs} += $domstats->{ 'block.' . $block_int . '.wr.reqs' };
$vm_info->{ftime} += $disk_info->{ftime};
$vm_info->{freqs} += $domstats->{ 'block.' . $block_int . '.fl.reqs' };
}
$vm_info->{disks}{ $domstats->{ 'block.' . $block_int . '.name' } } = $disk_info;
# skip adding ISO files to the VM total, these are likely used multiple times
if ( defined( $domstats->{ 'block.' . $block_int . '.path' } )
&& $domstats->{ 'block.' . $block_int . '.path' } !~ /\.[Ii][Ss][Oo]$/
&& defined( $disk_info->{alloc} )
&& defined( $disk_info->{in_use} )
&& defined( $disk_info->{on_disk} ) )
{
$vm_info->{disk_alloc} += $disk_info->{alloc};
$vm_info->{disk_in_use} += $disk_info->{in_use};
$vm_info->{disk_on_disk} += $disk_info->{on_disk};
}
$block_int++;
}
#
# get the snapshot count
#
my @snaps = split( /\n/, `virsh snapshot-list $vm` );
$vm_info->{snaps} = $#snaps - 1;
#
# total the status totals
#
if ( $vm_info->{status_int} == 0 ) {
$return_hash->{totals}{nostate}++;
}
elsif ( $vm_info->{status_int} == 1 ) {
$return_hash->{totals}{on}++;
}
elsif ( $vm_info->{status_int} == 2 ) {
$return_hash->{totals}{blocked}++;
}
elsif ( $vm_info->{status_int} == 3 ) {
$return_hash->{totals}{paused}++;
}
elsif ( $vm_info->{status_int} == 4 ) {
$return_hash->{totals}{off_soft}++;
}
elsif ( $vm_info->{status_int} == 5 ) {
$return_hash->{totals}{off_hard}++;
}
elsif ( $vm_info->{status_int} == 6 ) {
$return_hash->{totals}{crashed}++;
}
elsif ( $vm_info->{status_int} == 7 ) {
$return_hash->{totals}{pmsuspended}++;
}
#
# compute other totals
#
foreach my $to_total (@total) {
if ( defined( $vm_info->{$to_total} ) ) {
if ( defined( $return_hash->{totals}{$to_total} ) ) {
$return_hash->{totals}{$to_total} = $return_hash->{totals}{$to_total} + $vm_info->{$to_total};
}
else {
$return_hash->{totals}{$to_total} = $vm_info->{$to_total};
}
}
}
# save it and go on
$return_hash->{VMs}{$vm} = $vm_info;
}
return {
version => $self->{version},
error => 0,
errorString => '',
data => $return_hash,
};
}
=head2 usable
Dies if not usable.
eval{ $backend->usable; };
if ( $@ ){
print 'Not usable because... '.$@."\n";
}
=cut
sub usable {
my $self = $_[0];
# Make sure we are on a OS on which ZFS is usable on.
if ( $^O !~ 'linux' ) {
die '$^O is "' . $^O . '" and not "linux"';
}
# make sure we can locate cbsd
# Written like this as which on some Linux distros such as CentOS 7 is broken.
my $cmd_bin = `/bin/sh -c 'which virsh 2> /dev/null'`;
if ( $? != 0 ) {
die 'The command "virsh" is not in the path... ' . $ENV{PATH};
}
return 1;
}
=head1 AUTHOR
Zane C. Bowers-Hadley, C<< <vvelox at vvelox.net> >>
=head1 BUGS
Please report any bugs or feature requests to C<bug-hv-monitor at rt.cpan.org>, or through
the web interface at L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=HV-Monitor>. I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc HV::Monitor
You can also look for information at:
=over 4
=item * RT: CPAN's request tracker (report bugs here)
L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=HV-Monitor>
=item * CPAN Ratings
L<https://cpanratings.perl.org/d/HV-Monitor>
=item * Search CPAN
L<https://metacpan.org/release/HV-Monitor>
=back
=head1 ACKNOWLEDGEMENTS
=head1 LICENSE AND COPYRIGHT
This software is Copyright (c) 2022 by Zane C. Bowers-Hadley.
This is free software, licensed under:
The Artistic License 2.0 (GPL Compatible)
=cut
1;