File Coverage

blib/lib/Sys/Detect/Virtualization/linux.pm
Criterion Covered Total %
statement 42 56 75.0
branch 9 16 56.2
condition 8 17 47.0
subroutine 8 13 61.5
pod 9 9 100.0
total 76 111 68.4


line stmt bran cond sub pod time code
1             package Sys::Detect::Virtualization::linux;
2 4     4   52653 use warnings;
  4         19  
  4         176  
3 4     4   25 use strict;
  4         10  
  4         165  
4              
5 4     4   35 use base qw( Sys::Detect::Virtualization );
  4         10  
  4         6257  
6              
7             =head1 NAME
8              
9             Sys::Detect::Virtualization::linux - Detection of virtualization under a Linux system
10              
11             =head1 DESCRIPTION
12              
13             See L for usage information.
14              
15             =head1 METHODS
16              
17             =head2 Internal Methods
18              
19             =over 4
20              
21             =item new ( )
22              
23             Constructor. You should not invoke this directly. Instead, use L.
24              
25             =cut
26              
27             sub new
28             {
29 3     3 1 858 my ($class) = @_;
30 3         7 my $self = {};
31 3         12 bless $self, $class;
32 3         11 return $self;
33             }
34              
35             =item detect_dmesg ( )
36              
37             Check the output of the 'dmesg' command for telltales.
38              
39             =cut
40              
41             sub detect_dmesg
42             {
43 4     4 1 4881 my ($self) = @_;
44              
45 4         39 return $self->_check_command_output(
46             $self->_find_bin('dmesg'),
47             [
48             # VMWare
49             qr/vmxnet virtual NIC/i => [ $self->VIRT_VMWARE ],
50             qr/vmware virtual ide cdrom/i => [ $self->VIRT_VMWARE ],
51              
52             # Qemu / KVM
53             qr/qemu virtual cpu/i => [ $self->VIRT_KVM, $self->VIRT_QEMU ],
54              
55             # Microsoft virtual PC
56             qr/Virtual HD, ATA DISK drive/i => [ $self->VIRT_VIRTUALPC ],
57             qr/Virtual CD, ATAPI CD/i => [ $self->VIRT_VIRTUALPC ],
58              
59             # Xen
60             qr/Xen virtual console/ => [ $self->VIRT_XEN ],
61              
62             # Newer kernels are enlightened...
63             qr/booting paravirtualized kernel on kvm/i => [ $self->VIRT_KVM ],
64             qr/booting paravirtualized kernel on lguest/i => [ $self->VIRT_LGUEST ],
65             qr/booting paravirtualized kernel on vmi/i => [ $self->VIRT_VMWARE ],
66             qr/booting paravirtualized kernel on xen/i => [ $self->VIRT_XEN ],
67              
68             # Virtualbox (probably)
69             qr/VBOX (?:CD-ROM|HARDDISK)/ => [ $self->VIRT_VIRTUALBOX ],
70             ],
71             );
72              
73             }
74              
75             =item detect_dmidecode ( )
76              
77             Check the output of the 'dmidecode' command for telltales.
78              
79             =cut
80              
81             sub detect_dmidecode
82             {
83 4     4 1 18380 my ($self, $args ) = @_;
84              
85              
86 4         10 eval { require Parse::DMIDecode };
  4         862  
87 4 50       13872 if( $@ ) {
88 0         0 die "Cannot run dmidecode detection without Parse::DMIDecode: $@";
89             }
90              
91              
92 4         34 my $dmi_bin = $self->_find_bin( 'dmidecode' );
93 4 50       24 if( ! $dmi_bin ) {
94 0         0 die 'dmidecode binary not found';
95             }
96              
97             # Hack! Parse::DMIDecode doesn't handle dmidecode failures very well,
98             # so we first make sure we can run it.
99 4         249233 my $rc = system("$dmi_bin >/dev/null 2>&1");
100 4 100       139 if( $rc != 0 ) {
101 1         105 die "Could not run $dmi_bin: Command exited with " . ($rc >> 8);
102             }
103              
104 3         17 my $decoder;
105             {
106 3         39 local $SIG{__WARN__} = sub {
107 0 0   0   0 print "$_[0]\n" if $self->{verbose};
108 3         388 };
109 3         141 $decoder = Parse::DMIDecode->new(
110             dmidecode => $dmi_bin,
111             nowarnings => 1
112             );
113 3         1854 $decoder->probe();
114             }
115              
116             # First, check BIOS vendor
117             # BIOS Information
118             # Vendor: QEMU
119 3         325655 my $vendor = $decoder->keyword('bios-vendor');
120 3 100 66     508 if( $vendor && $vendor eq 'QEMU' ) {
121             return [
122 1         55 $self->VIRT_QEMU,
123             $self->VIRT_KVM,
124             ];
125             }
126              
127             # VMWare:
128             # System Information
129             # Manufacturer: VMware, Inc.
130 2         15 my $mfgr = $decoder->keyword('system-manufacturer');
131 2 100 66     859 if( $mfgr && $mfgr =~ /VMWare/i ) {
132 1         30 return [ $self->VIRT_VMWARE ];
133             }
134              
135             # System Information
136             # Manufacturer: Microsoft Corporation
137             # Product Name: Virtual Machine
138 1   50     10 my $product = $decoder->keyword('system-product-name') || '';
139 1 50 33     197 if( $mfgr && $product && $mfgr =~ /microsoft/i
      33        
      33        
140             && $product =~ /virtual machine/i ) {
141 1         19 return [ $self->VIRT_VIRTUALPC ];
142             }
143              
144             # VirtualBox
145 0 0       0 if ($product =~ /virtualbox/i) {
146 0         0 return [ $self->VIRT_VIRTUALBOX ];
147             }
148              
149 0         0 return [];
150             }
151              
152             =item detect_ide_devices ( )
153              
154             Check /proc/ide/hd*/model for telltale model information.
155              
156             =cut
157              
158             sub detect_ide_devices
159             {
160 0     0 1 0 my ($self) = @_;
161              
162 0         0 return $self->_check_file_contents(
163             '/proc/ide/hd*/model',
164             [
165             # VMWare
166             qr/vmware virtual/ => [ $self->VIRT_VMWARE ],
167              
168             # VirtualPC
169             qr/Virtual [HC]D/i => [ $self->VIRT_VIRTUALPC ],
170              
171             # Qemu / KVM
172             qr/QEMU (?:HARDDISK|DVD-ROM)/i => [
173             $self->VIRT_QEMU,
174             $self->VIRT_KVM,
175             ],
176             ]
177             );
178             }
179              
180             =item detect_mtab ( )
181              
182             Check /etc/mtab for telltale devices
183              
184             =cut
185              
186             sub detect_mtab
187             {
188 4     4 1 10282 my ($self) = @_;
189              
190 4         171 return $self->_check_file_contents(
191             '/etc/mtab',
192             [
193             # vserver
194             qr{^/dev/hdv1 } => [ $self->VIRT_VSERVER ],
195             qr{^simfs } => [ $self->VIRT_OPENVZ ],
196             ]
197             );
198             }
199              
200             =item detect_init_envvars ( )
201              
202             Check /proc/1/environ for LXC environment variables
203              
204             =cut
205              
206             sub detect_init_envvars
207             {
208 0     0 1 0 my ($self) = @_;
209 0         0 return $self->_check_file_contents(
210             '/proc/1/environ',
211             [
212             qr/LIBVIRT_LXC_NAME/ => [ $self->VIRT_LXC ],
213             qr/LIBVIRT_LXC_UUID/ => [ $self->VIRT_LXC ],
214             qr/LIBVIRT_LXC_CMDLINE/ => [ $self->VIRT_LXC ],
215             qr/container=lxc/ => [ $self->VIRT_LXC ],
216             ]
217             );
218             }
219              
220             =item detect_scsi_devices ( )
221              
222             Check /proc/scsi/scsi for telltale model/vendor information.
223              
224             =cut
225              
226             sub detect_scsi_devices
227             {
228 0     0 1 0 my ($self) = @_;
229              
230 0         0 return $self->_check_file_contents(
231             '/proc/scsi/scsi',
232             [
233             # VMWare
234             qr/Vendor: VMware Model: Virtual disk/ => [ $self->VIRT_VMWARE ],
235             ]
236             );
237             }
238              
239             =item detect_paths ( )
240              
241             Check for particular paths that only exist under virtualization.
242              
243             =cut
244              
245             sub detect_paths
246             {
247 0     0 1 0 my ($self) = @_;
248 0         0 return $self->_check_path_exists([
249             '/dev/vzfs' => [ $self->VIRT_OPENVZ ],
250             '/dev/vzctl' => [ $self->VIRT_OPENVZ_HOST ],
251             '/proc/vz' => [ $self->VIRT_OPENVZ ],
252             '/proc/xen' => [ $self->VIRT_XEN ],
253             '/proc/sys/xen/independent_wallclock' => [ $self->VIRT_XEN ],
254             ]);
255             }
256              
257             =item detect_modules ( )
258              
259             Check for telltale guest modules
260              
261             =cut
262              
263             sub detect_modules
264             {
265 4     4 1 14286 my ($self) = @_;
266              
267 4         49 return $self->_check_command_output(
268             $self->_find_bin( 'lsmod' ),
269             [
270             # virtio support exists for kvm and lguest
271             qr/^virtio_(?:blk|pci|net|balloon)/ => [ $self->VIRT_KVM, $self->VIRT_LGUEST ],
272              
273             # similarly, for VMWare
274             qr/^(?:vmmemctl|vmxnet)/ => [ $self->VIRT_VMWARE ],
275              
276             qr/^vboxadd/ => [ $self->VIRT_VIRTUALBOX ],
277             ]
278             );
279             }
280              
281             =back
282              
283             =head1 LICENSE AND COPYRIGHT
284              
285             Copyright (C) 2009 Roaring Penguin Software Inc.
286              
287             This program is free software; you can redistribute it and/or modify it
288             under the terms of either: the GNU General Public License as published
289             by the Free Software Foundation; or the Artistic License.
290              
291             See http://dev.perl.org/licenses/ for more information.
292              
293              
294             =cut
295              
296             1;