inspector: Determine guest architecture.
[libguestfs.git] / perl / lib / Sys / Guestfs / Lib.pm
1 # Sys::Guestfs::Lib
2 # Copyright (C) 2009 Red Hat Inc.
3 #
4 # This library is free software; you can redistribute it and/or
5 # modify it under the terms of the GNU Lesser General Public
6 # License as published by the Free Software Foundation; either
7 # version 2 of the License, or (at your option) any later version.
8 #
9 # This library is distributed in the hope that it will be useful,
10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
12 # Lesser General Public License for more details.
13 #
14 # You should have received a copy of the GNU Lesser General Public
15 # License along with this library; if not, write to the Free Software
16 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
17
18 package Sys::Guestfs::Lib;
19
20 use strict;
21 use warnings;
22
23 use Sys::Guestfs;
24 use File::Temp qw/tempdir/;
25 use Locale::TextDomain 'libguestfs';
26
27 # Optional:
28 eval "use Sys::Virt;";
29 eval "use XML::XPath;";
30 eval "use XML::XPath::XMLParser;";
31
32 =pod
33
34 =head1 NAME
35
36 Sys::Guestfs::Lib - Useful functions for using libguestfs from Perl
37
38 =head1 SYNOPSIS
39
40  use Sys::Guestfs::Lib qw(open_guest inspect_all_partitions ...);
41
42  $g = open_guest ($name);
43
44  %fses = inspect_all_partitions ($g, \@partitions);
45
46 (and many more calls - see the rest of this manpage)
47
48 =head1 DESCRIPTION
49
50 C<Sys::Guestfs::Lib> is an extra library of useful functions for using
51 the libguestfs API from Perl.  It also provides tighter integration
52 with libvirt.
53
54 The basic libguestfs API is not covered by this manpage.  Please refer
55 instead to L<Sys::Guestfs(3)> and L<guestfs(3)>.  The libvirt API is
56 also not covered.  For that, see L<Sys::Virt(3)>.
57
58 =head1 BASIC FUNCTIONS
59
60 =cut
61
62 require Exporter;
63
64 use vars qw(@EXPORT_OK @ISA);
65
66 @ISA = qw(Exporter);
67 @EXPORT_OK = qw(open_guest get_partitions resolve_windows_path
68   inspect_all_partitions inspect_partition
69   inspect_operating_systems mount_operating_system inspect_in_detail);
70
71 =head2 open_guest
72
73  $g = open_guest ($name);
74
75  $g = open_guest ($name, rw => 1, ...);
76
77  $g = open_guest ($name, address => $uri, ...);
78
79  $g = open_guest ([$img1, $img2, ...], address => $uri, ...);
80
81  ($g, $conn, $dom, @images) = open_guest ($name);
82
83 This function opens a libguestfs handle for either the libvirt domain
84 called C<$name>, or the disk image called C<$name>.  Any disk images
85 found through libvirt or specified explicitly are attached to the
86 libguestfs handle.
87
88 The C<Sys::Guestfs> handle C<$g> is returned, or if there was an error
89 it throws an exception.  To catch errors, wrap the call in an eval
90 block.
91
92 The first parameter is either a string referring to a libvirt domain
93 or a disk image, or (if a guest has several disk images) an arrayref
94 C<[$img1, $img2, ...]>.
95
96 The handle is I<read-only> by default.  Use the optional parameter
97 C<rw =E<gt> 1> to open a read-write handle.  However if you open a
98 read-write handle, this function will refuse to use active libvirt
99 domains.
100
101 The handle is still in the config state when it is returned, so you
102 have to call C<$g-E<gt>launch ()> and C<$g-E<gt>wait_ready>.
103
104 The optional C<address> parameter can be added to specify the libvirt
105 URI.  In addition, L<Sys::Virt(3)> lists other parameters which are
106 passed through to C<Sys::Virt-E<gt>new> unchanged.
107
108 The implicit libvirt handle is closed after this function, I<unless>
109 you call the function in C<wantarray> context, in which case the
110 function returns a tuple of: the open libguestfs handle, the open
111 libvirt handle, and the open libvirt domain handle, and a list of
112 images.  (This is useful if you want to do other things like pulling
113 the XML description of the guest).  Note that if this is a straight
114 disk image, then C<$conn> and C<$dom> will be C<undef>.
115
116 If the C<Sys::Virt> module is not available, then libvirt is bypassed,
117 and this function can only open disk images.
118
119 =cut
120
121 sub open_guest
122 {
123     local $_;
124     my $first = shift;
125     my %params = @_;
126
127     my $readwrite = $params{rw};
128
129     my @images = ();
130     if (ref ($first) eq "ARRAY") {
131         @images = @$first;
132     } elsif (ref ($first) eq "SCALAR") {
133         @images = ($first);
134     } else {
135         die __"open_guest: first parameter must be a string or an arrayref"
136     }
137
138     my ($conn, $dom);
139
140     if (-e $images[0]) {
141         foreach (@images) {
142             die __x("guest image {imagename} does not exist or is not readable",
143                     imagename => $_)
144                 unless -r $_;
145         }
146     } else {
147         die __"open_guest: no libvirt support (install Sys::Virt, XML::XPath and XML::XPath::XMLParser)"
148             unless exists $INC{"Sys/Virt.pm"} &&
149             exists $INC{"XML/XPath.pm"} &&
150             exists $INC{"XML/XPath/XMLParser.pm"};
151
152         die __"open_guest: too many domains listed on command line"
153             if @images > 1;
154
155         $conn = Sys::Virt->new (readonly => 1, @_);
156         die __"open_guest: cannot connect to libvirt" unless $conn;
157
158         my @doms = $conn->list_defined_domains ();
159         my $isitinactive = 1;
160         unless ($readwrite) {
161             # In the case where we want read-only access to a domain,
162             # allow the user to specify an active domain too.
163             push @doms, $conn->list_domains ();
164             $isitinactive = 0;
165         }
166         foreach (@doms) {
167             if ($_->get_name () eq $images[0]) {
168                 $dom = $_;
169                 last;
170             }
171         }
172
173         unless ($dom) {
174             if ($isitinactive) {
175                 die __x("{imagename} is not the name of an inactive libvirt domain\n",
176                         imagename => $images[0]);
177             } else {
178                 die __x("{imagename} is not the name of a libvirt domain\n",
179                         imagename => $images[0]);
180             }
181         }
182
183         # Get the names of the image(s).
184         my $xml = $dom->get_xml_description ();
185
186         my $p = XML::XPath->new (xml => $xml);
187         my @disks = $p->findnodes ('//devices/disk/source/@dev');
188         push (@disks, $p->findnodes ('//devices/disk/source/@file'));
189
190         die __x("{imagename} seems to have no disk devices\n",
191                 imagename => $images[0])
192             unless @disks;
193
194         @images = map { $_->getData } @disks;
195     }
196
197     # We've now got the list of @images, so feed them to libguestfs.
198     my $g = Sys::Guestfs->new ();
199     foreach (@images) {
200         if ($readwrite) {
201             $g->add_drive ($_);
202         } else {
203             $g->add_drive_ro ($_);
204         }
205     }
206
207     return wantarray ? ($g, $conn, $dom, @images) : $g
208 }
209
210 =head2 get_partitions
211
212  @partitions = get_partitions ($g);
213
214 This function takes an open libguestfs handle C<$g> and returns all
215 partitions and logical volumes found on it.
216
217 What is returned is everything that could contain a filesystem (or
218 swap).  Physical volumes are excluded from the list, and so are any
219 devices which are partitioned (eg. C</dev/sda> would not be returned
220 if C</dev/sda1> exists).
221
222 =cut
223
224 sub get_partitions
225 {
226     my $g = shift;
227
228     my @partitions = $g->list_partitions ();
229     my @pvs = $g->pvs ();
230     @partitions = grep { ! _is_pv ($_, @pvs) } @partitions;
231
232     my @lvs = $g->lvs ();
233
234     return sort (@lvs, @partitions);
235 }
236
237 sub _is_pv {
238     local $_;
239     my $t = shift;
240
241     foreach (@_) {
242         return 1 if $_ eq $t;
243     }
244     0;
245 }
246
247 =head2 resolve_windows_path
248
249  $path = resolve_windows_path ($g, $path);
250
251  $path = resolve_windows_path ($g, "/windows/system");
252    ==> "/WINDOWS/System"
253        or undef if no path exists
254
255 This function, which is specific to FAT/NTFS filesystems (ie.  Windows
256 guests), lets you look up a case insensitive C<$path> in the
257 filesystem and returns the true, case sensitive path as required by
258 the underlying kernel or NTFS-3g driver.
259
260 If C<$path> does not exist then this function returns C<undef>.
261
262 The C<$path> parameter must begin with C</> character and be separated
263 by C</> characters.  Do not use C<\>, drive names, etc.
264
265 =cut
266
267 sub resolve_windows_path
268 {
269     local $_;
270     my $g = shift;
271     my $path = shift;
272
273     if (substr ($path, 0, 1) ne "/") {
274         warn __"resolve_windows_path: path must start with a / character";
275         return undef;
276     }
277
278     my @elems = split (/\//, $path);
279     shift @elems;
280
281     # Start reconstructing the path at the top.
282     $path = "/";
283
284     foreach my $dir (@elems) {
285         my $found = 0;
286         foreach ($g->ls ($path)) {
287             if (lc ($_) eq lc ($dir)) {
288                 if ($path eq "/") {
289                     $path = "/$_";
290                     $found = 1;
291                 } else {
292                     $path = "$path/$_";
293                     $found = 1;
294                 }
295             }
296         }
297         return undef unless $found;
298     }
299
300     return $path;
301 }
302
303 =head2 file_architecture
304
305  $arch = file_architecture ($g, $path)
306
307 The C<file_architecture> function lets you get the architecture for a
308 particular binary or library in the guest.  By "architecture" we mean
309 what processor it is compiled for (eg. C<i586> or C<x86_64>).
310
311 The function works on at least the following types of files:
312
313 =over 4
314
315 =item *
316
317 many types of Un*x binary
318
319 =item *
320
321 many types of Un*x shared library
322
323 =item *
324
325 Windows Win32 and Win64 binaries
326
327 =item *
328
329 Windows Win32 and Win64 DLLs
330
331 Win32 binaries and DLLs return C<i386>.
332
333 Win64 binaries and DLLs return C<x86_64>.
334
335 =item *
336
337 Linux kernel modules
338
339 =item *
340
341 Linux new-style initrd images
342
343 =item *
344
345 some non-x86 Linux vmlinuz kernels
346
347 =back
348
349 What it can't do currently:
350
351 =over 4
352
353 =item *
354
355 static libraries (libfoo.a)
356
357 =item *
358
359 Linux old-style initrd as compressed ext2 filesystem (RHEL 3)
360
361 =item *
362
363 x86 Linux vmlinuz kernels
364
365 x86 vmlinuz images (bzImage format) consist of a mix of 16-, 32- and
366 compressed code, and are horribly hard to unpack.  If you want to find
367 the architecture of a kernel, use the architecture of the associated
368 initrd or kernel module(s) instead.
369
370 =back
371
372 =cut
373
374 sub _elf_arch_to_canonical
375 {
376     local $_ = shift;
377
378     if ($_ eq "Intel 80386") {
379         return "i386";
380     } elsif ($_ eq "Intel 80486") {
381         return "i486";  # probably not in the wild
382     } elsif ($_ eq "x86-64") {
383         return "x86_64";
384     } elsif (/SPARC32/) {
385         return "sparc";
386     } elsif (/SPARC V9/) {
387         return "sparc64";
388     } elsif ($_ eq "IA-64") {
389         return "ia64";
390     } elsif (/64.*PowerPC/) {
391         return "ppc64";
392     } elsif (/PowerPC/) {
393         return "ppc";
394     } else {
395         warn __x("returning non-canonical architecture type '{arch}'",
396                  arch => $_);
397         return $_;
398     }
399 }
400
401 my @_initrd_binaries = ("nash", "modprobe", "sh", "bash");
402
403 sub file_architecture
404 {
405     local $_;
406     my $g = shift;
407     my $path = shift;
408
409     # Our basic tool is 'file' ...
410     my $file = $g->file ($path);
411
412     if ($file =~ /ELF.*(?:executable|shared object|relocatable), (.+?),/) {
413         # ELF executable or shared object.  We need to convert
414         # what file(1) prints into the canonical form.
415         return _elf_arch_to_canonical ($1);
416     } elsif ($file =~ /PE32 executable/) {
417         return "i386";          # Win32 executable or DLL
418     } elsif ($file =~ /PE32\+ executable/) {
419         return "x86_64";        # Win64 executable or DLL
420     }
421
422     elsif ($file =~ /cpio archive/) {
423         # Probably an initrd.
424         my $zcat = "cat";
425         if ($file =~ /gzip/) {
426             $zcat = "zcat";
427         } elsif ($file =~ /bzip2/) {
428             $zcat = "bzcat";
429         }
430
431         # Download and unpack it to find a binary file.
432         my $dir = tempdir (CLEANUP => 1);
433         $g->download ($path, "$dir/initrd");
434
435         my $bins = join " ", map { "bin/$_" } @_initrd_binaries;
436         my $cmd = "cd $dir && $zcat initrd | cpio -id $bins";
437         my $r = system ($cmd);
438         die __x("cpio command failed: {error}", error => $?)
439             unless $r == 0;
440
441         foreach my $bin (@_initrd_binaries) {
442             if (-f "$dir/bin/$bin") {
443                 open PIPE, "file $dir/bin/$bin |";
444                 local $/ = undef;
445                 $_ = <PIPE>;
446                 if (/ELF.*executable, (.+?),/) {
447                     return _elf_arch_to_canonical ($1);
448                 }
449             }
450         }
451
452         die __x("file_architecture: no known binaries found in initrd image: {path}",
453                 path => $path);
454     }
455
456     die __x("file_architecture: unknown architecture: {path}",
457             path => $path);
458 }
459
460 =head1 OPERATING SYSTEM INSPECTION FUNCTIONS
461
462 The functions in this section can be used to inspect the operating
463 system(s) available inside a virtual machine image.  For example, you
464 can find out if the VM is Linux or Windows, how the partitions are
465 meant to be mounted, and what applications are installed.
466
467 If you just want a simple command-line interface to this
468 functionality, use the L<virt-inspector(1)> tool.  The documentation
469 below covers the case where you want to access this functionality from
470 a Perl program.
471
472 Once you have the list of partitions (from C<get_partitions>) there
473 are several steps involved:
474
475 =over 4
476
477 =item 1.
478
479 Look at each partition separately and find out what is on it.
480
481 The information you get back includes whether the partition contains a
482 filesystem or swapspace, what sort of filesystem (eg. ext3, ntfs), and
483 a first pass guess at the content of the filesystem (eg. Linux boot,
484 Windows root).
485
486 The result of this step is a C<%fs> hash of information, one hash for
487 each partition.
488
489 See: C<inspect_partition>, C<inspect_all_partitions>
490
491 =item 2.
492
493 Work out the relationship between partitions.
494
495 In this step we work out how partitions are related to each other.  In
496 the case of a single-boot VM, we work out how the partitions are
497 mounted in respect of each other (eg. C</dev/sda1> is mounted as
498 C</boot>).  In the case of a multi-boot VM where there are several
499 roots, we may identify several operating system roots, and mountpoints
500 can even be shared.
501
502 The result of this step is a single hash called C<%oses> which is
503 described in more detail below, but at the top level looks like:
504
505  %oses = {
506    '/dev/VG/Root1' => \%os1,
507    '/dev/VG/Root2' => \%os2,
508  }
509  
510  %os1 = {
511    os => 'linux',
512    mounts => {
513      '/' => '/dev/VG/Root1',
514      '/boot' => '/dev/sda1',
515    },
516    ...
517  }
518
519 (example shows a multi-boot VM containing two root partitions).
520
521 See: C<inspect_operating_systems>
522
523 =item 3.
524
525 Mount up the disks.
526
527 Previous to this point we've essentially been looking at each
528 partition in isolation.  Now we construct a true guest filesystem by
529 mounting up all of the disks.  Only once everything is mounted up can
530 we run commands in the OS context to do more detailed inspection.
531
532 See: C<mount_operating_system>
533
534 =item 4.
535
536 Check for kernels and applications.
537
538 This step now does more detailed inspection, where we can look for
539 kernels, applications and more installed in the guest.
540
541 The result of this is an enhanced C<%os> hash.
542
543 See: C<inspect_in_detail>
544
545 =item 5.
546
547 Generate output.
548
549 This library does not contain functions for generating output based on
550 the analysis steps above.  Use a command line tool such as
551 L<virt-inspector(1)> to get useful output.
552
553 =back
554
555 =head2 inspect_all_partitions
556
557  %fses = inspect_all_partitions ($g, \@partitions);
558
559  %fses = inspect_all_partitions ($g, \@partitions, use_windows_registry => 1);
560
561 This calls C<inspect_partition> for each partition in the list
562 C<@partitions>.
563
564 The result is a hash which maps partition name to C<\%fs> hashref.
565
566 The contents of the C<%fs> hash and the meaning of the
567 C<use_windows_registry> flag are explained below.
568
569 =cut
570
571 sub inspect_all_partitions
572 {
573     local $_;
574     my $g = shift;
575     my $parts = shift;
576     my @parts = @$parts;
577     return map { $_ => inspect_partition ($g, $_, @_) } @parts;
578 }
579
580 =head2 inspect_partition
581
582  \%fs = inspect_partition ($g, $partition);
583
584  \%fs = inspect_partition ($g, $partition, use_windows_registry => 1);
585
586 This function inspects the device named C<$partition> in isolation and
587 tries to determine what it is.  It returns information such as whether
588 the partition is formatted, and with what, whether it is mountable,
589 and what it appears to contain (eg. a Windows root, or a Linux /usr).
590
591 If C<use_windows_registry> is set to 1, then we will try to download
592 and parse the content of the Windows registry (for Windows root
593 devices).  However since this is an expensive and error-prone
594 operation, we don't do this by default.  It also requires the external
595 program C<reged>, patched to remove numerous crashing bugs in the
596 upstream version.
597
598 The returned value is a hashref C<\%fs> which may contain the
599 following top-level keys (any key can be missing):
600
601 =over 4
602
603 =item fstype
604
605 Filesystem type, eg. "ext2" or "ntfs"
606
607 =item fsos
608
609 Apparent filesystem OS, eg. "linux" or "windows"
610
611 =item is_swap
612
613 If set, the partition is a swap partition.
614
615 =item uuid
616
617 Filesystem UUID.
618
619 =item label
620
621 Filesystem label.
622
623 =item is_mountable
624
625 If set, the partition could be mounted by libguestfs.
626
627 =item content
628
629 Filesystem content, if we could determine it.  One of: "linux-grub",
630 "linux-root", "linux-usrlocal", "linux-usr", "windows-root".
631
632 =item osdistro
633
634 (For Linux root partitions only).
635 Operating system distribution.  One of: "fedora", "rhel", "centos",
636 "scientific", "debian".
637
638 =item package_format
639
640 (For Linux root partitions only)
641 The package format used by the guest distribution. One of: "rpm", "dpkg".
642
643 =item package_management
644
645 (For Linux root partitions only)
646 The package management tool used by the guest distribution. One of: "rhn",
647 "yum", "apt".
648
649 =item os_major_version
650
651 (For root partitions only).
652 Operating system major version number.
653
654 =item os_minor_version
655
656 (For root partitions only).
657 Operating system minor version number.
658
659 =item fstab
660
661 (For Linux root partitions only).
662 The contents of the C</etc/fstab> file.
663
664 =item boot_ini
665
666 (For Windows root partitions only).
667 The contents of the C</boot.ini> (NTLDR) file.
668
669 =item registry
670
671 The value is an arrayref, which is a list of Windows registry
672 file contents, in Windows C<.REG> format.
673
674 =back
675
676 =cut
677
678 sub inspect_partition
679 {
680     local $_;
681     my $g = shift;
682     my $dev = shift;            # LV or partition name.
683     my %params = @_;
684
685     my $use_windows_registry = $params{use_windows_registry};
686
687     my %r;                      # Result hash.
688
689     # First try 'file(1)' on it.
690     my $file = $g->file ($dev);
691     if ($file =~ /ext2 filesystem data/) {
692         $r{fstype} = "ext2";
693         $r{fsos} = "linux";
694     } elsif ($file =~ /ext3 filesystem data/) {
695         $r{fstype} = "ext3";
696         $r{fsos} = "linux";
697     } elsif ($file =~ /ext4 filesystem data/) {
698         $r{fstype} = "ext4";
699         $r{fsos} = "linux";
700     } elsif ($file =~ m{Linux/i386 swap file}) {
701         $r{fstype} = "swap";
702         $r{fsos} = "linux";
703         $r{is_swap} = 1;
704     }
705
706     # If it's ext2/3/4, then we want the UUID and label.
707     if (exists $r{fstype} && $r{fstype} =~ /^ext/) {
708         $r{uuid} = $g->get_e2uuid ($dev);
709         $r{label} = $g->get_e2label ($dev);
710     }
711
712     # Try mounting it, fnarrr.
713     if (!$r{is_swap}) {
714         $r{is_mountable} = 1;
715         eval { $g->mount_ro ($dev, "/") };
716         if ($@) {
717             # It's not mountable, probably empty or some format
718             # we don't understand.
719             $r{is_mountable} = 0;
720             goto OUT;
721         }
722
723         # Grub /boot?
724         if ($g->is_file ("/grub/menu.lst") ||
725             $g->is_file ("/grub/grub.conf")) {
726             $r{content} = "linux-grub";
727             _check_grub ($g, \%r);
728             goto OUT;
729         }
730
731         # Linux root?
732         if ($g->is_dir ("/etc") && $g->is_dir ("/bin") &&
733             $g->is_file ("/etc/fstab")) {
734             $r{content} = "linux-root";
735             $r{is_root} = 1;
736             _check_linux_root ($g, \%r);
737             goto OUT;
738         }
739
740         # Linux /usr/local.
741         if ($g->is_dir ("/etc") && $g->is_dir ("/bin") &&
742             $g->is_dir ("/share") && !$g->exists ("/local") &&
743             !$g->is_file ("/etc/fstab")) {
744             $r{content} = "linux-usrlocal";
745             goto OUT;
746         }
747
748         # Linux /usr.
749         if ($g->is_dir ("/etc") && $g->is_dir ("/bin") &&
750             $g->is_dir ("/share") && $g->exists ("/local") &&
751             !$g->is_file ("/etc/fstab")) {
752             $r{content} = "linux-usr";
753             goto OUT;
754         }
755
756         # Windows root?
757         if ($g->is_file ("/AUTOEXEC.BAT") ||
758             $g->is_file ("/autoexec.bat") ||
759             $g->is_dir ("/Program Files") ||
760             $g->is_dir ("/WINDOWS") ||
761             $g->is_file ("/boot.ini") ||
762             $g->is_file ("/ntldr")) {
763             $r{fstype} = "ntfs"; # XXX this is a guess
764             $r{fsos} = "windows";
765             $r{content} = "windows-root";
766             $r{is_root} = 1;
767             _check_windows_root ($g, \%r, $use_windows_registry);
768             goto OUT;
769         }
770     }
771
772   OUT:
773     $g->umount_all ();
774     return \%r;
775 }
776
777 sub _check_linux_root
778 {
779     local $_;
780     my $g = shift;
781     my $r = shift;
782
783     # Look into /etc to see if we recognise the operating system.
784     # N.B. don't use $g->is_file here, because it might be a symlink
785     if ($g->exists ("/etc/redhat-release")) {
786         $r->{package_format} = "rpm";
787
788         $_ = $g->cat ("/etc/redhat-release");
789         if (/Fedora release (\d+)(?:\.(\d+))?/) {
790             $r->{osdistro} = "fedora";
791             $r->{os_major_version} = "$1";
792             $r->{os_minor_version} = "$2" if(defined($2));
793             $r->{package_management} = "yum";
794         }
795         
796         elsif (/(Red Hat Enterprise Linux|CentOS|Scientific Linux)/) {
797             my $distro = $1;
798
799             if($distro eq "Red Hat Enterprise Linux") {
800                 $r->{osdistro} = "rhel";
801             }
802
803             elsif($distro eq "CentOS") {
804                 $r->{osdistro} = "centos";
805                 $r->{package_management} = "yum";
806             }
807
808             elsif($distro eq "Scientific Linux") {
809                 $r->{osdistro} = "scientific";
810                 $r->{package_management} = "yum";
811             }
812
813             # Shouldn't be possible
814             else { die };
815
816             if (/$distro.*release (\d+).*Update (\d+)/) {
817                 $r->{os_major_version} = "$1";
818                 $r->{os_minor_version} = "$2";
819             }
820
821             elsif (/$distro.*release (\d+)(?:\.(\d+))?/) {
822                 $r->{os_major_version} = "$1";
823
824                 if(defined($2)) {
825                     $r->{os_minor_version} = "$2";
826                 } else {
827                     $r->{os_minor_version} = "0";
828                 }
829             }
830
831             # Package management in RHEL changed in version 5
832             if ($r->{osdistro} eq "rhel") {
833                 if ($r->{os_major_version} >= 5) {
834                     $r->{package_management} = "yum";
835                 } else {
836                     $r->{package_management} = "rhn";
837                 }
838             }
839         }
840
841         else {
842             $r->{osdistro} = "redhat-based";
843         }
844     } elsif ($g->is_file ("/etc/debian_version")) {
845         $r->{package_format} = "dpkg";
846         $r->{package_management} = "apt";
847
848         $_ = $g->cat ("/etc/debian_version");
849         if (/(\d+)\.(\d+)/) {
850             $r->{osdistro} = "debian";
851             $r->{os_major_version} = "$1";
852             $r->{os_minor_version} = "$2";
853         } else {
854             $r->{osdistro} = "debian";
855         }
856     }
857
858     # Parse the contents of /etc/fstab.  This is pretty vital so
859     # we can determine where filesystems are supposed to be mounted.
860     eval "\$_ = \$g->cat ('/etc/fstab');";
861     if (!$@ && $_) {
862         my @lines = split /\n/;
863         my @fstab;
864         foreach (@lines) {
865             my @fields = split /[ \t]+/;
866             if (@fields >= 2) {
867                 my $spec = $fields[0]; # first column (dev/label/uuid)
868                 my $file = $fields[1]; # second column (mountpoint)
869                 if ($spec =~ m{^/} ||
870                     $spec =~ m{^LABEL=} ||
871                     $spec =~ m{^UUID=} ||
872                     $file eq "swap") {
873                     push @fstab, [$spec, $file]
874                 }
875             }
876         }
877         $r->{fstab} = \@fstab if @fstab;
878     }
879
880     # Determine the architecture of this root.
881     my $arch;
882     foreach ("/bin/bash", "/bin/ls", "/bin/echo", "/bin/rm", "/bin/sh") {
883         if ($g->is_file ($_)) {
884             $arch = file_architecture ($g, $_);
885             last;
886         }
887     }
888
889     $r->{arch} = $arch if defined $arch;
890 }
891
892 # We only support NT.  The control file /boot.ini contains a list of
893 # Windows installations and their %systemroot%s in a simple text
894 # format.
895 #
896 # XXX We could parse this better.  This won't work if /boot.ini is on
897 # a different drive from the %systemroot%, and in other unusual cases.
898
899 sub _check_windows_root
900 {
901     local $_;
902     my $g = shift;
903     my $r = shift;
904     my $use_windows_registry = shift;
905
906     my $boot_ini = resolve_windows_path ($g, "/boot.ini");
907     $r->{boot_ini} = $boot_ini;
908
909     if (defined $r->{boot_ini}) {
910         $_ = $g->cat ($boot_ini);
911         my @lines = split /\n/;
912         my $section;
913         my $systemroot;
914         foreach (@lines) {
915             if (m/\[.*\]/) {
916                 $section = $1;
917             } elsif (m/^default=.*?\\(\w+)$/i) {
918                 $systemroot = $1;
919                 last;
920             } elsif (m/\\(\w+)=/) {
921                 $systemroot = $1;
922                 last;
923             }
924         }
925
926         if (defined $systemroot) {
927             $r->{systemroot} = resolve_windows_path ($g, "/$systemroot");
928             if (defined $r->{systemroot}) {
929                 _check_windows_arch ($g, $r, $r->{systemroot});
930                 if ($use_windows_registry) {
931                     _check_windows_registry ($g, $r, $r->{systemroot});
932                 }
933             }
934         }
935     }
936 }
937
938 # Find Windows userspace arch.
939
940 sub _check_windows_arch
941 {
942     local $_;
943     my $g = shift;
944     my $r = shift;
945     my $systemroot = shift;
946
947     my $cmd_exe =
948         resolve_windows_path ($g, $r->{systemroot} . "/system32/cmd.exe");
949     $r->{arch} = file_architecture ($g, $cmd_exe) if $cmd_exe;
950 }
951
952 sub _check_windows_registry
953 {
954     local $_;
955     my $g = shift;
956     my $r = shift;
957     my $systemroot = shift;
958
959     # Download the system registry files.  Only download the
960     # interesting ones, and we don't bother with user profiles at all.
961
962     my $configdir = resolve_windows_path ($g, "$systemroot/system32/config");
963     if (defined $configdir) {
964         my $softwaredir = resolve_windows_path ($g, "$configdir/software");
965         if (defined $softwaredir) {
966             _load_windows_registry ($g, $r, $softwaredir,
967                                     "HKEY_LOCAL_MACHINE\\SOFTWARE");
968         }
969         my $systemdir = resolve_windows_path ($g, "$configdir/system");
970         if (defined $systemdir) {
971             _load_windows_registry ($g, $r, $systemdir,
972                                     "HKEY_LOCAL_MACHINE\\System");
973         }
974     }
975 }
976
977 sub _load_windows_registry
978 {
979     local $_;
980     my $g = shift;
981     my $r = shift;
982     my $regfile = shift;
983     my $prefix = shift;
984
985     my $dir = tempdir (CLEANUP => 1);
986
987     $g->download ($regfile, "$dir/reg");
988
989     # 'reged' command is particularly noisy.  Redirect stdout and
990     # stderr to /dev/null temporarily.
991     open SAVEOUT, ">&STDOUT";
992     open SAVEERR, ">&STDERR";
993     open STDOUT, ">/dev/null";
994     open STDERR, ">/dev/null";
995
996     my @cmd = ("reged", "-x", "$dir/reg", "$prefix", "\\", "$dir/out");
997     my $res = system (@cmd);
998
999     close STDOUT;
1000     close STDERR;
1001     open STDOUT, ">&SAVEOUT";
1002     open STDERR, ">&SAVEERR";
1003     close SAVEOUT;
1004     close SAVEERR;
1005
1006     unless ($res == 0) {
1007         warn __x("reged command failed: {errormsg}", errormsg => $?);
1008         return;
1009     }
1010
1011     # Some versions of reged segfault on inputs.  If that happens we
1012     # may get no / partial output file.  Anyway, if it exists, load
1013     # it.
1014     my $content;
1015     unless (open F, "$dir/out") {
1016         warn __x("no output from reged command: {errormsg}", errormsg => $!);
1017         return;
1018     }
1019     { local $/ = undef; $content = <F>; }
1020     close F;
1021
1022     my @registry = ();
1023     @registry = @{$r->{registry}} if exists $r->{registry};
1024     push @registry, $content;
1025     $r->{registry} = \@registry;
1026 }
1027
1028 sub _check_grub
1029 {
1030     local $_;
1031     my $g = shift;
1032     my $r = shift;
1033
1034     # Grub version, if we care.
1035 }
1036
1037 =head2 inspect_operating_systems
1038
1039  \%oses = inspect_operating_systems ($g, \%fses);
1040
1041 This function works out how partitions are related to each other.  In
1042 the case of a single-boot VM, we work out how the partitions are
1043 mounted in respect of each other (eg. C</dev/sda1> is mounted as
1044 C</boot>).  In the case of a multi-boot VM where there are several
1045 roots, we may identify several operating system roots, and mountpoints
1046 can even be shared.
1047
1048 This function returns a hashref C<\%oses> which at the top level looks
1049 like:
1050
1051  %oses = {
1052    '/dev/VG/Root' => \%os,
1053  }
1054  
1055 (There can be multiple roots for a multi-boot VM).
1056
1057 The C<\%os> hash contains the following keys (any can be omitted):
1058
1059 =over 4
1060
1061 =item os
1062
1063 Operating system type, eg. "linux", "windows".
1064
1065 =item arch
1066
1067 Operating system userspace architecture, eg. "i386", "x86_64".
1068
1069 =item distro
1070
1071 Operating system distribution, eg. "debian".
1072
1073 =item major_version
1074
1075 Operating system major version, eg. "4".
1076
1077 =item minor_version
1078
1079 Operating system minor version, eg "3".
1080
1081 =item root
1082
1083 The value is a reference to the root partition C<%fs> hash.
1084
1085 =item root_device
1086
1087 The value is the name of the root partition (as a string).
1088
1089 =item mounts
1090
1091 Mountpoints.
1092 The value is a hashref like this:
1093
1094  mounts => {
1095    '/' => '/dev/VG/Root',
1096    '/boot' => '/dev/sda1',
1097  }
1098
1099 =item filesystems
1100
1101 Filesystems (including swap devices and unmounted partitions).
1102 The value is a hashref like this:
1103
1104  filesystems => {
1105    '/dev/sda1' => \%fs,
1106    '/dev/VG/Root' => \%fs,
1107    '/dev/VG/Swap' => \%fs,
1108  }
1109
1110 =back
1111
1112 =cut
1113
1114 sub inspect_operating_systems
1115 {
1116     local $_;
1117     my $g = shift;
1118     my $fses = shift;
1119
1120     my %oses = ();
1121
1122     foreach (sort keys %$fses) {
1123         if ($fses->{$_}->{is_root}) {
1124             my %r = (
1125                 root => $fses->{$_},
1126                 root_device => $_
1127                 );
1128             _get_os_version ($g, \%r);
1129             _assign_mount_points ($g, $fses, \%r);
1130             $oses{$_} = \%r;
1131         }
1132     }
1133
1134     return \%oses;
1135 }
1136
1137 sub _get_os_version
1138 {
1139     local $_;
1140     my $g = shift;
1141     my $r = shift;
1142
1143     $r->{os} = $r->{root}->{fsos} if exists $r->{root}->{fsos};
1144     $r->{distro} = $r->{root}->{osdistro} if exists $r->{root}->{osdistro};
1145     $r->{major_version} = $r->{root}->{os_major_version}
1146         if exists $r->{root}->{os_major_version};
1147     $r->{minor_version} = $r->{root}->{os_minor_version}
1148         if exists $r->{root}->{os_minor_version};
1149     $r->{package_format} = $r->{root}->{package_format}
1150         if exists $r->{root}->{package_format};
1151     $r->{package_management} = $r->{root}->{package_management}
1152         if exists $r->{root}->{package_management};
1153     $r->{arch} = $r->{root}->{arch} if exists $r->{root}->{arch};
1154 }
1155
1156 sub _assign_mount_points
1157 {
1158     local $_;
1159     my $g = shift;
1160     my $fses = shift;
1161     my $r = shift;
1162
1163     $r->{mounts} = { "/" => $r->{root_device} };
1164     $r->{filesystems} = { $r->{root_device} => $r->{root} };
1165
1166     # Use /etc/fstab if we have it to mount the rest.
1167     if (exists $r->{root}->{fstab}) {
1168         my @fstab = @{$r->{root}->{fstab}};
1169         foreach (@fstab) {
1170             my ($spec, $file) = @$_;
1171
1172             my ($dev, $fs) = _find_filesystem ($g, $fses, $spec);
1173             if ($dev) {
1174                 $r->{mounts}->{$file} = $dev;
1175                 $r->{filesystems}->{$dev} = $fs;
1176                 if (exists $fs->{used}) {
1177                     $fs->{used}++
1178                 } else {
1179                     $fs->{used} = 1
1180                 }
1181                 $fs->{spec} = $spec;
1182             }
1183         }
1184     }
1185 }
1186
1187 # Find filesystem by device name, LABEL=.. or UUID=..
1188 sub _find_filesystem
1189 {
1190     my $g = shift;
1191     my $fses = shift;
1192     local $_ = shift;
1193
1194     if (/^LABEL=(.*)/) {
1195         my $label = $1;
1196         foreach (sort keys %$fses) {
1197             if (exists $fses->{$_}->{label} &&
1198                 $fses->{$_}->{label} eq $label) {
1199                 return ($_, $fses->{$_});
1200             }
1201         }
1202         warn __x("unknown filesystem label {label}\n", label => $label);
1203         return ();
1204     } elsif (/^UUID=(.*)/) {
1205         my $uuid = $1;
1206         foreach (sort keys %$fses) {
1207             if (exists $fses->{$_}->{uuid} &&
1208                 $fses->{$_}->{uuid} eq $uuid) {
1209                 return ($_, $fses->{$_});
1210             }
1211         }
1212         warn __x("unknown filesystem UUID {uuid}\n", uuid => $uuid);
1213         return ();
1214     } else {
1215         return ($_, $fses->{$_}) if exists $fses->{$_};
1216
1217         # The following is to handle the case where an fstab entry specifies a
1218         # specific device rather than its label or uuid, and the libguestfs
1219         # appliance has named the device differently due to the use of a
1220         # different driver.
1221         # This will work as long as the underlying drivers recognise devices in
1222         # the same order.
1223         if (m{^/dev/hd(.*)} && exists $fses->{"/dev/sd$1"}) {
1224             return ("/dev/sd$1", $fses->{"/dev/sd$1"});
1225         }
1226         if (m{^/dev/xvd(.*)} && exists $fses->{"/dev/sd$1"}) {
1227             return ("/dev/sd$1", $fses->{"/dev/sd$1"});
1228         }
1229         if (m{^/dev/mapper/(.*)-(.*)$} && exists $fses->{"/dev/$1/$2"}) {
1230             return ("/dev/$1/$2", $fses->{"/dev/$1/$2"});
1231         }
1232
1233         return () if m{/dev/cdrom};
1234
1235         warn __x("unknown filesystem {fs}\n", fs => $_);
1236         return ();
1237     }
1238 }
1239
1240 =head2 mount_operating_system
1241
1242  mount_operating_system ($g, \%os, [$ro]);
1243
1244 This function mounts the operating system described in the
1245 C<%os> hash according to the C<mounts> table in that hash (see
1246 C<inspect_operating_systems>).
1247
1248 The partitions are mounted read-only unless the third parameter
1249 is specified as zero explicitly.
1250
1251 To reverse the effect of this call, use the standard
1252 libguestfs API call C<$g-E<gt>umount_all ()>.
1253
1254 =cut
1255
1256 sub mount_operating_system
1257 {
1258     local $_;
1259     my $g = shift;
1260     my $os = shift;
1261     my $ro = shift;             # Read-only?
1262
1263     $ro = 1 unless defined $ro; # ro defaults to 1 if unspecified
1264
1265     my $mounts = $os->{mounts};
1266
1267     # Have to mount / first.  Luckily '/' is early in the ASCII
1268     # character set, so this should be OK.
1269     foreach (sort keys %$mounts) {
1270         if($_ ne "swap" && $_ ne "none" && ($_ eq '/' || $g->is_dir ($_))) {
1271             if($ro) {
1272                 $g->mount_ro ($mounts->{$_}, $_)
1273             } else {
1274                 $g->mount ($mounts->{$_}, $_)
1275             }
1276         }
1277     }
1278 }
1279
1280 =head2 inspect_in_detail
1281
1282  mount_operating_system ($g, \%os);
1283  inspect_in_detail ($g, \%os);
1284  $g->umount_all ();
1285
1286 The C<inspect_in_detail> function inspects the mounted operating
1287 system for installed applications, installed kernels, kernel modules,
1288 system architecture, and more.
1289
1290 It adds extra keys to the existing C<%os> hash reflecting what it
1291 finds.  These extra keys are:
1292
1293 =over 4
1294
1295 =item apps
1296
1297 List of applications.
1298
1299 =item kernels
1300
1301 List of kernels.
1302
1303 This is a hash of kernel version =E<gt> a hash with the following keys:
1304
1305 =over 4
1306
1307 =item version
1308
1309 Kernel version.
1310
1311 =item arch
1312
1313 Kernel architecture (eg. C<x86-64>).
1314
1315 =item modules
1316
1317 List of modules.
1318
1319 =back
1320
1321 =item modprobe_aliases
1322
1323 (For Linux VMs).
1324 The contents of the modprobe configuration.
1325
1326 =item initrd_modules
1327
1328 (For Linux VMs).
1329 The kernel modules installed in the initrd.  The value is
1330 a hashref of kernel version to list of modules.
1331
1332 =back
1333
1334 =cut
1335
1336 sub inspect_in_detail
1337 {
1338     local $_;
1339     my $g = shift;
1340     my $os = shift;
1341
1342     _check_for_applications ($g, $os);
1343     _check_for_kernels ($g, $os);
1344     if ($os->{os} eq "linux") {
1345         _check_for_modprobe_aliases ($g, $os);
1346         _check_for_initrd ($g, $os);
1347     }
1348 }
1349
1350 sub _check_for_applications
1351 {
1352     local $_;
1353     my $g = shift;
1354     my $os = shift;
1355
1356     my @apps;
1357
1358     my $osn = $os->{os};
1359     if ($osn eq "linux") {
1360         my $package_format = $os->{package_format};
1361         if (defined $package_format && $package_format eq "rpm") {
1362             my @lines = $g->command_lines
1363                 (["rpm",
1364                   "-q", "-a",
1365                   "--qf", "%{name} %{epoch} %{version} %{release} %{arch}\n"]);
1366             foreach (@lines) {
1367                 if (m/^(.*) (.*) (.*) (.*) (.*)$/) {
1368                     my $epoch = $2;
1369                     $epoch = "" if $epoch eq "(none)";
1370                     my $app = {
1371                         name => $1,
1372                         epoch => $epoch,
1373                         version => $3,
1374                         release => $4,
1375                         arch => $5
1376                     };
1377                     push @apps, $app
1378                 }
1379             }
1380         }
1381     } elsif ($osn eq "windows") {
1382         # XXX
1383         # I worked out a general plan for this, but haven't
1384         # implemented it yet.  We can iterate over /Program Files
1385         # looking for *.EXE files, which we download, then use
1386         # i686-pc-mingw32-windres on, to find the VERSIONINFO
1387         # section, which has a lot of useful information.
1388     }
1389
1390     $os->{apps} = \@apps;
1391 }
1392
1393 sub _check_for_kernels
1394 {
1395     local $_;
1396     my $g = shift;
1397     my $os = shift;
1398
1399     my @kernels;
1400
1401     my $osn = $os->{os};
1402     if ($osn eq "linux") {
1403         # Installed kernels will have a corresponding /lib/modules/<version>
1404         # directory, which is the easiest way to find out what kernels
1405         # are installed, and what modules are available.
1406         foreach ($g->ls ("/lib/modules")) {
1407             if ($g->is_dir ("/lib/modules/$_")) {
1408                 my %kernel;
1409                 $kernel{version} = $_;
1410
1411                 # List modules.
1412                 my @modules;
1413                 my $any_module;
1414                 my $prefix = "/lib/modules/$_";
1415                 foreach ($g->find ($prefix)) {
1416                     if (m,/([^/]+)\.ko$, || m,([^/]+)\.o$,) {
1417                         $any_module = "$prefix$_" unless defined $any_module;
1418                         push @modules, $1;
1419                     }
1420                 }
1421
1422                 $kernel{modules} = \@modules;
1423
1424                 # Determine kernel architecture by looking at the arch
1425                 # of any kernel module.
1426                 $kernel{arch} = file_architecture ($g, $any_module);
1427
1428                 push @kernels, \%kernel;
1429             }
1430         }
1431
1432     } elsif ($osn eq "windows") {
1433         # XXX
1434     }
1435
1436     $os->{kernels} = \@kernels;
1437 }
1438
1439 # Check /etc/modprobe.conf to see if there are any specified
1440 # drivers associated with network (ethX) or hard drives.  Normally
1441 # one might find something like:
1442 #
1443 #  alias eth0 xennet
1444 #  alias scsi_hostadapter xenblk
1445 #
1446 # XXX This doesn't look beyond /etc/modprobe.conf, eg. in /etc/modprobe.d/
1447
1448 sub _check_for_modprobe_aliases
1449 {
1450     local $_;
1451     my $g = shift;
1452     my $os = shift;
1453
1454     # Initialise augeas
1455     my $success = 0;
1456     $success = $g->aug_init("/", 16);
1457
1458     # Register /etc/modules.conf and /etc/conf.modules to the Modprobe lens
1459     my @results;
1460     @results = $g->aug_match("/augeas/load/Modprobe/incl");
1461
1462     # Calculate the next index of /augeas/load/Modprobe/incl
1463     my $i = 1;
1464     foreach ( @results ) {
1465         next unless m{/augeas/load/Modprobe/incl\[(\d*)]};
1466         $i = $1 + 1 if ($1 == $i);
1467     }
1468
1469     $success = $g->aug_set("/augeas/load/Modprobe/incl[$i]",
1470                            "/etc/modules.conf");
1471     $i++;
1472     $success = $g->aug_set("/augeas/load/Modprobe/incl[$i]",
1473                                   "/etc/conf.modules");
1474
1475     # Make augeas reload
1476     $success = $g->aug_load();
1477
1478     my %modprobe_aliases;
1479
1480     for my $pattern qw(/files/etc/conf.modules/alias
1481                        /files/etc/modules.conf/alias
1482                        /files/etc/modprobe.conf/alias
1483                        /files/etc/modprobe.d/*/alias) {
1484         @results = $g->aug_match($pattern);
1485
1486         for my $path ( @results ) {
1487             $path =~ m{^/files(.*)/alias(?:\[\d*\])?$}
1488                 or die __x("{path} doesn't match augeas pattern",
1489                            path => $path);
1490             my $file = $1;
1491
1492             my $alias;
1493             $alias = $g->aug_get($path);
1494
1495             my $modulename;
1496             $modulename = $g->aug_get($path.'/modulename');
1497
1498             my %aliasinfo;
1499             $aliasinfo{modulename} = $modulename;
1500             $aliasinfo{augeas} = $path;
1501             $aliasinfo{file} = $file;
1502
1503             $modprobe_aliases{$alias} = \%aliasinfo;
1504         }
1505     }
1506
1507     $os->{modprobe_aliases} = \%modprobe_aliases;
1508 }
1509
1510 # Get a listing of device drivers in any initrd corresponding to a
1511 # kernel.  This is an indication of what can possibly be booted.
1512
1513 sub _check_for_initrd
1514 {
1515     local $_;
1516     my $g = shift;
1517     my $os = shift;
1518
1519     my %initrd_modules;
1520
1521     foreach my $initrd ($g->ls ("/boot")) {
1522         if ($initrd =~ m/^initrd-(.*)\.img$/ && $g->is_file ("/boot/$initrd")) {
1523             my $version = $1;
1524             my @modules;
1525
1526             # Disregard old-style compressed ext2 files and only
1527             # work with real compressed cpio files, since cpio
1528             # takes ages to (fail to) process anything else.
1529             if ($g->file ("/boot/$initrd") =~ /cpio/) {
1530                 eval {
1531                     @modules = $g->initrd_list ("/boot/$initrd");
1532                 };
1533                 unless ($@) {
1534                     @modules = grep { m,([^/]+)\.ko$, || m,([^/]+)\.o$, }
1535                     @modules;
1536                     $initrd_modules{$version} = \@modules
1537                 } else {
1538                     warn __x("{filename}: could not read initrd format",
1539                              filename => "/boot/$initrd");
1540                 }
1541             }
1542         }
1543     }
1544
1545     $os->{initrd_modules} = \%initrd_modules;
1546 }
1547
1548
1549 1;
1550
1551 =head1 COPYRIGHT
1552
1553 Copyright (C) 2009 Red Hat Inc.
1554
1555 =head1 LICENSE
1556
1557 Please see the file COPYING.LIB for the full license.
1558
1559 =head1 SEE ALSO
1560
1561 L<virt-inspector(1)>,
1562 L<Sys::Guestfs(3)>,
1563 L<guestfs(3)>,
1564 L<http://libguestfs.org/>,
1565 L<Sys::Virt(3)>,
1566 L<http://libvirt.org/>,
1567 L<guestfish(1)>.
1568
1569 =cut