File Coverage

blib/lib/Sys/Detect/Virtualization.pm

Criterion	Covered	Total	%
statement	75	116	64.6
branch	16	46	34.7
condition	3	13	23.0
subroutine	13	17	76.4
pod	4	4	100.0
total	111	196	56.6

package Sys::Detect::Virtualization;

use warnings;
use strict;
use 5.008;

=head1 NAME

Sys::Detect::Virtualization - Detect if a UNIX system is running as a virtual machine

=head1 VERSION

Version 0.107

=cut

our $VERSION = '0.107';

use constant {
	VIRT_KVM       => 'Linux KVM',
	VIRT_LGUEST    => 'Linux lguest',
	VIRT_OPENVZ    => 'OpenVZ',
	VIRT_QEMU      => 'Qemu',
	VIRT_VIRTUALPC => 'Microsoft Virtual PC',
	VIRT_VMWARE    => 'VMWare',
	VIRT_VSERVER   => 'linux-vserver',
	VIRT_XEN       => 'Xen',

	VIRT_FREEBSD_JAIL => 'FreeBSD Jail',

	VIRT_OPENVZ_HOST    => 'OpenVZ Host',

	VIRT_VIRTUALBOX => 'VirtualBox',
	VIRT_LXC       => 'Linux Containers (LXC)',
};

my %_hosts = (
	VIRT_OPENVZ_HOST() => VIRT_OPENVZ(),
);

# used for secondary sort where detector finds similar solutions
my %_priorities = (
	VIRT_OPENVZ_HOST()    => '1.2',
	VIRT_OPENVZ()         => '1.1',

	VIRT_KVM()            => '1.1',
	VIRT_QEMU()           => '1.0',

	VIRT_LGUEST()         => '1.0',
	VIRT_VIRTUALPC()      => '1.0',
	VIRT_VMWARE()         => '1.0',
	VIRT_VSERVER()        => '1.0',
	VIRT_XEN()            => '1.0',
);

=head1 SYNOPSIS

    use Sys::Detect::Virtualization;

    my $detector = eval { Sys::Detect::Virtualization->new() };
    if( $@ ) {
	print "Detector may not be supported for your platform.  Error was: $@\n";
    }

    my @found = $detector->detect();
    if( @found ) {
	print "Possible virtualized system.  May be running under:\n";
	print "\t$_\n" for @found;
    }

=head1 DESCRIPTION

This module attempts to detect whether or not a system is running as a guest
under virtualization, using various heuristics.

=head1 METHODS

=head2 Class Methods

=over 4

=item new ( $args )

Construct a new detector object.  On success, returns the object.  On failure, dies.

This constructor will fail if the system is not running a supported OS.
Currently, only Linux is supported.

$args is an optional hash reference containing additional arguments for the
constructor.  Currently supported are:

=over 4

=item verbose

Set to 1 if we should output verbose debugging, 0 otherwise.  Defaults to 0.

=item ignore_host

Set to 1 if we should report no virtualization if a virtualization host (as opposed to guest) is detected.  Defaults to 1.

=back

=back

=cut

sub new
{
	my ($class, $extra_args) = @_;

	die q{Perl doesn't know what OS you're on!} unless $^O;
	my $submodule = join('::', __PACKAGE__, lc $^O);

	eval "use $submodule";
	my $local_err = $@;
	if( $local_err =~ m{Can't locate Sys/Detect/Virtualization/.*?\.pm} ) {
		die "Virtualization detection not supported for '$^O' platform";
	} elsif( $local_err ) {
		die "Constructor failure: $local_err";
	}

	my $self = $submodule->new($extra_args);

	$self->{verbose}     = exists $extra_args->{verbose}     ? $extra_args->{verbose}     : 0;
	$self->{ignore_host} = exists $extra_args->{ignore_host} ? $extra_args->{ignore_host} : 1;

	return $self;
}

=head2 Instance Methods

=over 4

=item detect ( )

Runs detection heuristics.  Returns a list of possible virtualization systems,
or an empty list if none were detected.

Possible hits are returned in order of most likely to least likely.

Note that the failure to detect does NOT mean the system is not virtualized --
it simply means we couldn't detect it.

=cut

sub detect
{
	my ($self) = @_;

	my $guesses = $self->_detect();

	if( ! $guesses ) {
		return;
	}

	return
		sort { ($guesses->{$b} <=> $guesses->{$a}) ||
		       (($_priorities{$b} || 1.0)  <=> ($_priorities{$a} || 1.0))
		} keys %$guesses;
}

sub _detect
{
	my ($self) = @_;

	my @detectors = $self->get_detectors();

	my %guesses;
	for my $name ( @detectors ) {
		print "Running detector $name\n" if $self->{verbose};

		my $found = eval { $self->$name; };
		if( ! $found || !scalar(@$found) ) {
			if( $@ ) {
				warn "Callback $name failed: $@" if $self->{verbose};
			}
			print "$name callback did not detect virtualization\n" if $self->{verbose};
			next;
		}

		for my $guess (@$found) {
			$guesses{$guess}++;
			print "$name callback detected $guess\n" if $self->{verbose};
		}
	}

	# Can't be both host and guest at the same time
	foreach my $host_type (keys %_hosts) {
		if( exists $guesses{$host_type} ) {
			delete $guesses{ $_hosts{$host_type} };
		}
	}

	if( $self->{ignore_host} ) {
		delete $guesses{$_} for keys %_hosts;
	}

	return \%guesses
}

=item guess ( )

Runs detection heuristics and returns a single answer based on the "best guess" available.

Currently, this is defined as the virt platform with the most heuristic hits.

=back

=cut

sub guess
{
	my ($self) = @_;

	my ($best, @rest) = $self->detect();

	return $best;
}

=head2 Internal Methods

You probably shouldn't ever need to call these

=over 4

=item get_detectors ( )

Returns a list of all detector subroutines for the given instance.

=cut

sub get_detectors
{
	my ($thingy) = @_;

	my $class = ref $thingy || $thingy;

	no strict 'refs';

	# Note: This does not consider parent classes.  This is intentional.
	return grep { /^detect_/ } keys %{"${class}::"};
}

=item _find_bin ( $command )

Returns full path to given command by searching $ENV{PATH}.  If not present in
the path variable, the directories /usr/sbin, /usr/bin, /sbin, and /bin are
appended.

=cut

my @basic_paths = qw( /usr/sbin /usr/bin /sbin /bin );
sub _find_bin
{
	my ($self, $command) = @_;

	my @paths = split(/:/, $ENV{PATH});
	foreach my $path (@basic_paths) {
		if( ! grep { $_ eq $path } @paths ) {
			push @paths, $path;
		}
	}

	my $cmd = ( grep { -x $_ } map { "$_/$command" } @paths )[0];
	if (!defined($cmd) || ($cmd eq '')) {
		$cmd = '/bin/false';
	}
	return $cmd;
}

=item _fh_apply_patterns ( $fh, $patterns )

Check, linewise, the data from $fh against the patterns in $patterns.

$patterns is a listref read pairwise.  The first item of each pair is the
pattern, and the second item of each pair is a list of names of virt solutions
detected by the pattern.

=cut

sub _fh_apply_patterns
{
	my ($self, $fh, $patterns) = @_;

	my @hits;

	while(my $line = <$fh>) {
		for(my $i = 0; $i < scalar @$patterns; $i+=2) {
			my ($pattern, $name) = @{$patterns}[$i, $i+1];
			if( $line =~ /$pattern/ ) {
				push @hits, @{$name};
			}
		}
	}

	return \@hits;
}

=item _check_command_output ( $command, $patterns )

Check, linewise, the output of $command against the patterns in $patterns.

$patterns is a listref read pairwise.  The first item of each pair is the
pattern, and the second item of each pair is the name of the virt solution
detected by the pattern.

=cut

sub _check_command_output
{
	my($self, $command, $patterns) = @_;

	# TODO: open3 or roll our own fork/exec?
	# TODO: error code of command
	open( my $fh, "$command 2>/dev/null |") or die $!;
	my $result = $self->_fh_apply_patterns( $fh, $patterns );
	close $fh;

	return $result;
}

=item _check_file_contents ( $fileglob, $patterns )

Check, linewise, the content of each filename in $fileglob against the
patterns in $patterns.

$fileglob is a glob that returns zero or more filenames.

$patterns is a listref read pairwise.  The first item of each pair is the
pattern, and the second item of each pair is the name of the virt solution
detected by the pattern.

=cut

sub _check_file_contents
{
	my ($self, $fileglob, $patterns) = @_;

	# TODO: caller does globbing, passes listref of filenames?
	my @hits;
	while( my $filename = glob($fileglob) ) {
		my $fh;
		if( ! open( $fh, "<$filename") ) {
			warn "skipping $filename: $!" if $self->{verbose};
			next;
		}
		my $result = $self->_fh_apply_patterns( $fh, $patterns );
		close $fh;
		if( $result ) {
			push @hits, @$result;
		}
	}
	return \@hits;
}

=item _check_path_exists ( $paths )

Checks for the existence of each path in $paths.

$paths is a listref read pairwise.  The first item of each pair is the path
name, and the second item of each pair is the name of the virt solution
detected by the existence of that $path.

=cut

sub _check_path_exists
{
	my ($self, $paths) = @_;

	my @hits;
	for(my $i = 0; $i < scalar @{$paths}; $i+=2) {
		my ($path, $name) = @{$paths}[$i, $i+1];
		if( -e $path ) {
			push @hits, @$name;
		}
	}

	return \@hits;
}

=back

=head1 AUTHOR

Dave O'Neill,

=head1 BUGS

Known issues:

=over 4

=item *

No support for non-Linux platforms.  Feel free to contribute an appropriate
Sys::Detect::Virtualization::foo class for your platform.

=item *

No weighting of tests so that high-confidence checks can be done first.
Patches welcome.

=back

Please report any bugs or feature requests to C
at rt.cpan.org>, or through the web interface at
L.  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 Sys::Detect::Virtualization


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * Search CPAN

L

=item * The author's blog

L

=back

=head1 LICENSE AND COPYRIGHT

Copyright (C) 2009 Roaring Penguin Software Inc.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.


=cut

1; # End of Sys::Detect::Virtualization