libimvirt-perl 0.9.6-3 / usr / share / perl5 / ImVirt.pm

# ImVirt - I'm virtualized?
#
# Authors:
#   Thomas Liske <liske@ibh.de>
#
# Copyright Holder:
#   2009 - 2012 (C) IBH IT-Service GmbH [http://www.ibh.de/]
#
# License:
#   This program is free software; you can redistribute it and/or modify
#   it under the terms of the GNU General Public License as published by
#   the Free Software Foundation; either version 2 of the License, or
#   (at your option) any later version.
#
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#
#   You should have received a copy of the GNU General Public License
#   along with this package; if not, write to the Free Software
#   Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
#

package ImVirt;

=head1 NAME

ImVirt - detects several virtualizations

=head1 SYNOPSIS

    use ImVirt;
    print imv_get(IMV_PROB_DEFAULT, imv_detect()),"\n";

=head1 DESCRIPTION

The C<ImVirt> package tries to detect if it is run in a
virtualization container. At least the following container
should be detected:

=over

=item ARAnyM

=item KVM

=item lguest

=item LXC

=item OpenVZ

=item QEMU

=item UML

=item VirtualBox

=item Virtual PC/Server

=item VMware

=item Xen

=back

=head1 DETECTION HEURISTIC

The detection is based on a heuristic - you should not trust the result at all.

ImVirt probes for different well-known characteristics of different
virtualization containers. Any characteristics found or not found are weighted
by their significance.

The result of the heuristic is a weighted tree. The leaves are the (not)
detected containers.

=head1 FUNCTIONS

The following functions should be used to retrieve the detected virtualization
containers:

=over 4

=item imv_get($prob)
Returns exactly one string describing the detected container. If the detected
container has a smaller match probability than $prob the string 'Unknown' is
returned.

=item imv_get_all()
Returns a hash any positive detected containers as keys and their corresponding
match probability as value.

=item imv_get_pos_results()
Returns a list of all possible results which might be returned by all detection
modules. The list entries might be appended by some additional data like version
numbers etc.

=back

=cut

use strict;
use warnings;
use Module::Find;
use List::Util qw(sum);
use Data::Dumper;

use constant {
    KV_POINTS		=> 'points',
    KV_SUBPRODS		=> 'prods',
    KV_PROB		=> 'prob',

    IMV_PHYSICAL	=> 'Physical',
    IMV_VIRTUAL		=> 'Virtual',
    IMV_EMULATOR	=> 'Emulator',
    IMV_CONTAINER	=> 'Container',
    IMV_UNKNOWN		=> 'Unknown',

    IMV_PROB_DEFAULT	=> 0.9,

    IMV_PTS_MINOR	=> 1,
    IMV_PTS_NORMAL	=> 3,
    IMV_PTS_MAJOR	=> 6,
    IMV_PTS_DRASTIC	=> 12,
};

require Exporter;
our @ISA = qw(Exporter);

our @EXPORT = qw(
    imv_detect
    imv_get
    imv_get_all
    imv_get_pos_results
    IMV_PROB_DEFAULT
    IMV_PHYSICAL
    IMV_VIRTUAL
    IMV_UNKNOWN
    IMV_PTS_MINOR
    IMV_PTS_NORMAL
    IMV_PTS_MAJOR
    IMV_PTS_DRASTIC
);

our $VERSION = '0.9.6';

sub get_libexecdir() {
    return '/usr/lib/imvirt';
}

my @vmds = ();
my $debug = 0;
my %detected = ();
my %rtree;

sub register_vmd($) {
    my $vmd = shift || return;

    push(@vmds, $vmd);
}

sub _rtree_vm($$$@) {
    my $dref = shift;
    my $cref = shift;
    my $pts = shift;

    foreach my $prod (keys %{$dref}) {
	my $href = ${$dref}{$prod};

	if(keys %{${$href}{KV_SUBPRODS}}) {
	    &_rtree_vm(${$href}{KV_SUBPRODS}, $cref, $pts + ${$href}{KV_POINTS}, @_, $prod);
	}
	else {
	    if(${$href}{KV_POINTS} > 0) {
		my $n = join(' ', @_, $prod);
		$n =~ s/^.*\|([^\|]+)/$1/ if($n =~ /\|/);
		${$cref}{$n} = $pts + ${$href}{KV_POINTS};
	    }
	}
    }
}

sub imv_detect() {
    imv_init() unless (@vmds);

    %detected = (ImVirt::IMV_PHYSICAL => {KV_POINTS => IMV_PTS_MINOR});

    foreach my $vmd (@vmds) {
	eval "${vmd}::detect(\\\%detected);";
	warn "Error in ${vmd}::detect(): $@\n" if $@;
    }

    %rtree = ();

    _rtree_vm(\%detected, \%rtree, 0);

    my $psum = sum grep { $_ > 0 } values %rtree;

    foreach my $prod (keys %rtree) {
	my $pts = $rtree{$prod};

	if($pts > 0) {
	    $rtree{$prod} = $pts/$psum;
	}
	else {
	    $rtree{$prod} = 0;
	}
    }

    debug(__PACKAGE__, "imvirt_detect():\n".Dumper(\%rtree));
}

sub inc_pts($$@) {
    debug(__PACKAGE__, 'inc_pts('.join(', ',@_).')');

    my $dref = shift;
    my $prop = shift;

    _change_pts($prop, $dref, @_);
}

sub dec_pts($$@) {
    debug(__PACKAGE__, 'dec_pts('.join(', ',@_).')');

    my $dref = shift;
    my $prop = shift;

    _change_pts(-$prop, $dref, @_);
}

sub _change_pts($\%@) {
    my $prop = shift;
    my $ref = shift;
    my $key = shift;

    my $href = ${$ref}{$key};
    unless($href) {
        $href = ${$ref}{$key} = {KV_POINTS => 0, KV_SUBPRODS => {}};
    }

    if($#_ != -1) {
	&_change_pts($prop, ${$href}{KV_SUBPRODS}, @_);
    }
    else {
	${$href}{KV_POINTS} += $prop;
    }
}
sub imv_get_all() {
    imv_detect() unless (%detected);

    return %rtree;
}

sub imv_get($) {
    imv_detect() unless (%detected);

    my $prob = shift;

    my @res = sort { $rtree{$b} > $rtree{$a} } keys %rtree;
    my $vm = shift @res;

    return $vm if(eval {
	my $m = (sum values %rtree)/($#res+2);
	debug(__PACKAGE__, "imv_get: m = $m");

	my $s = 0;
	foreach my $v (values %rtree) {
	    $s += ($v - $m)**2;
	}
	$s /=($#res+1);
	debug(__PACKAGE__, "imv_get: s² = $s");

	my $vm2 = shift @res;
	debug(__PACKAGE__, "imv_get: $rtree{$vm} - sqrt($s) > $rtree{$vm2}");
	$rtree{$vm} - sqrt($s) > $rtree{$vm2};
    });

    return $vm if($rtree{$vm} >= $prob);

    return IMV_UNKNOWN;
}

sub imv_get_pos_results {
    imv_init() unless (@vmds);

    my @pres;

    foreach my $vmd (@vmds) {
	eval "\@pres = (\@pres, ${vmd}::pres());";
    }

    my %pres = map { $_, 1 } map { s/^.*\|([^|]+)$/$1/; $_; } @pres;
    return sort {uc($a) cmp uc($b)} keys %pres;
}

sub set_debug($) {
    $debug = shift;
}

sub get_debug() {
    return $debug;
}

sub debug($$) {
    printf STDERR "%s: %s\n", @_ if($debug);
}

sub imv_init() {
    # autoload VMD modules
    foreach my $module (findsubmod ImVirt::VMD) {
	eval "use $module;";
	die "Error loading $module: $@\n" if $@;
    }
}

1;