5428b104741e610e2e4ef01d807fef85023cc535
[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 Carp qw(croak);
24
25 use Sys::Guestfs;
26 use File::Temp qw/tempdir/;
27 use Locale::TextDomain 'libguestfs';
28
29 # Optional:
30 eval "use Sys::Virt;";
31 eval "use XML::XPath;";
32 eval "use XML::XPath::XMLParser;";
33 eval "use Win::Hivex;";
34
35 =pod
36
37 =head1 NAME
38
39 Sys::Guestfs::Lib - Useful functions for using libguestfs from Perl
40
41 =head1 SYNOPSIS
42
43  use Sys::Guestfs::Lib qw(open_guest inspect_all_partitions ...);
44
45  $g = open_guest ($name);
46
47  %fses = inspect_all_partitions ($g, \@partitions);
48
49 (and many more calls - see the rest of this manpage)
50
51 =head1 DESCRIPTION
52
53 C<Sys::Guestfs::Lib> is an extra library of useful functions for using
54 the libguestfs API from Perl.  It also provides tighter integration
55 with libvirt.
56
57 The basic libguestfs API is not covered by this manpage.  Please refer
58 instead to L<Sys::Guestfs(3)> and L<guestfs(3)>.  The libvirt API is
59 also not covered.  For that, see L<Sys::Virt(3)>.
60
61 =head1 BASIC FUNCTIONS
62
63 =cut
64
65 require Exporter;
66
67 use vars qw(@EXPORT_OK @ISA);
68
69 @ISA = qw(Exporter);
70 @EXPORT_OK = qw(open_guest feature_available
71   get_partitions resolve_windows_path
72   inspect_all_partitions inspect_partition
73   inspect_operating_systems mount_operating_system inspect_in_detail
74   inspect_linux_kernel);
75
76 =head2 open_guest
77
78  $g = open_guest ($name);
79
80  $g = open_guest ($name, rw => 1, ...);
81
82  $g = open_guest ($name, address => $uri, ...);
83
84  $g = open_guest ([$img1, $img2, ...], address => $uri, ...);
85
86  ($g, $conn, $dom, @images) = open_guest ($name);
87
88 This function opens a libguestfs handle for either the libvirt domain
89 called C<$name>, or the disk image called C<$name>.  Any disk images
90 found through libvirt or specified explicitly are attached to the
91 libguestfs handle.
92
93 The C<Sys::Guestfs> handle C<$g> is returned, or if there was an error
94 it throws an exception.  To catch errors, wrap the call in an eval
95 block.
96
97 The first parameter is either a string referring to a libvirt domain
98 or a disk image, or (if a guest has several disk images) an arrayref
99 C<[$img1, $img2, ...]>.
100
101 The handle is I<read-only> by default.  Use the optional parameter
102 C<rw =E<gt> 1> to open a read-write handle.  However if you open a
103 read-write handle, this function will refuse to use active libvirt
104 domains.
105
106 The handle is still in the config state when it is returned, so you
107 have to call C<$g-E<gt>launch ()>.
108
109 The optional C<address> parameter can be added to specify the libvirt
110 URI.
111
112 The implicit libvirt handle is closed after this function, I<unless>
113 you call the function in C<wantarray> context, in which case the
114 function returns a tuple of: the open libguestfs handle, the open
115 libvirt handle, and the open libvirt domain handle, and a list of
116 images.  (This is useful if you want to do other things like pulling
117 the XML description of the guest).  Note that if this is a straight
118 disk image, then C<$conn> and C<$dom> will be C<undef>.
119
120 If the C<Sys::Virt> module is not available, then libvirt is bypassed,
121 and this function can only open disk images.
122
123 The optional C<interface> parameter can be used to open devices with
124 C<add_drive{,_ro}_with_if>.  See
125 L<Sys::Guestfs/guestfs_add_drive_with_if> for more details.
126
127 =cut
128
129 sub open_guest
130 {
131     local $_;
132     my $first = shift;
133     my %params = @_;
134
135     my $rw = $params{rw};
136     my $address = $params{address};
137     my $interface = $params{interface};
138
139     my @images = ();
140     if (ref ($first) eq "ARRAY") {
141         @images = @$first;
142     } elsif (ref ($first) eq "SCALAR") {
143         @images = ($first);
144     } else {
145         croak __"open_guest: first parameter must be a string or an arrayref"
146     }
147
148     my ($conn, $dom);
149
150     if (-e $images[0]) {
151         foreach (@images) {
152             croak __x("guest image {imagename} does not exist or is not readable",
153                     imagename => $_)
154                 unless -r $_;
155         }
156     } else {
157         die __"open_guest: no libvirt support (install Sys::Virt, XML::XPath and XML::XPath::XMLParser)"
158             unless exists $INC{"Sys/Virt.pm"} &&
159             exists $INC{"XML/XPath.pm"} &&
160             exists $INC{"XML/XPath/XMLParser.pm"};
161
162         die __"open_guest: too many domains listed on command line"
163             if @images > 1;
164
165         my @libvirt_args = ();
166         push @libvirt_args, address => $address if defined $address;
167
168         $conn = Sys::Virt->new (readonly => 1, @libvirt_args);
169         die __"open_guest: cannot connect to libvirt" unless $conn;
170
171         my @doms = $conn->list_defined_domains ();
172         my $isitinactive = 1;
173         unless ($rw) {
174             # In the case where we want read-only access to a domain,
175             # allow the user to specify an active domain too.
176             push @doms, $conn->list_domains ();
177             $isitinactive = 0;
178         }
179         foreach (@doms) {
180             if ($_->get_name () eq $images[0]) {
181                 $dom = $_;
182                 last;
183             }
184         }
185
186         unless ($dom) {
187             if ($isitinactive) {
188                 die __x("{imagename} is not the name of an inactive libvirt domain\n",
189                         imagename => $images[0]);
190             } else {
191                 die __x("{imagename} is not the name of a libvirt domain\n",
192                         imagename => $images[0]);
193             }
194         }
195
196         # Get the names of the image(s).
197         my $xml = $dom->get_xml_description ();
198
199         my $p = XML::XPath->new (xml => $xml);
200         my @disks = $p->findnodes ('//devices/disk/source/@dev');
201         push (@disks, $p->findnodes ('//devices/disk/source/@file'));
202
203         die __x("{imagename} seems to have no disk devices\n",
204                 imagename => $images[0])
205             unless @disks;
206
207         @images = map { $_->getData } @disks;
208     }
209
210     # We've now got the list of @images, so feed them to libguestfs.
211     my $g = Sys::Guestfs->new ();
212     foreach (@images) {
213         if ($rw) {
214             if ($interface) {
215                 $g->add_drive_with_if ($_, $interface);
216             } else {
217                 $g->add_drive ($_);
218             }
219         } else {
220             if ($interface) {
221                 $g->add_drive_ro_with_if ($_, $interface);
222             } else {
223                 $g->add_drive_ro ($_);
224             }
225         }
226     }
227
228     return wantarray ? ($g, $conn, $dom, @images) : $g
229 }
230
231 =head2 feature_available
232
233  $bool = feature_available ($g, $feature [, $feature ...]);
234
235 This function is a useful wrapper around the basic
236 C<$g-E<gt>available> call.
237
238 C<$g-E<gt>available> tests for availability of a list of features and
239 dies with an error if any is not available.
240
241 This call tests for the list of features and returns true if all are
242 available, or false otherwise.
243
244 For a list of features you can test for, see L<guestfs(3)/AVAILABILITY>.
245
246 =cut
247
248 sub feature_available {
249     my $g = shift;
250
251     eval { $g->available (\@_); };
252     return $@ ? 0 : 1;
253 }
254
255 =head2 get_partitions
256
257  @partitions = get_partitions ($g);
258
259 This function takes an open libguestfs handle C<$g> and returns all
260 partitions and logical volumes found on it.
261
262 What is returned is everything that could contain a filesystem (or
263 swap).  Physical volumes are excluded from the list, and so are any
264 devices which are partitioned (eg. C</dev/sda> would not be returned
265 if C</dev/sda1> exists).
266
267 =cut
268
269 sub get_partitions
270 {
271     my $g = shift;
272
273     my @partitions = $g->list_partitions ();
274     my @pvs = $g->pvs ();
275     @partitions = grep { ! _is_pv ($_, @pvs) } @partitions;
276
277     my @lvs;
278     @lvs = $g->lvs () if feature_available ($g, "lvm2");
279
280     return sort (@lvs, @partitions);
281 }
282
283 sub _is_pv {
284     local $_;
285     my $t = shift;
286
287     foreach (@_) {
288         return 1 if $_ eq $t;
289     }
290     0;
291 }
292
293 =head2 resolve_windows_path
294
295  $path = resolve_windows_path ($g, $path);
296
297  $path = resolve_windows_path ($g, "/windows/system");
298    ==> "/WINDOWS/System"
299        or undef if no path exists
300
301 This function, which is specific to FAT/NTFS filesystems (ie.  Windows
302 guests), lets you look up a case insensitive C<$path> in the
303 filesystem and returns the true, case sensitive path as required by
304 the underlying kernel or NTFS-3g driver.
305
306 If C<$path> does not exist then this function returns C<undef>.
307
308 The C<$path> parameter must begin with C</> character and be separated
309 by C</> characters.  Do not use C<\>, drive names, etc.
310
311 =cut
312
313 sub resolve_windows_path
314 {
315     my $g = shift;
316     my $path = shift;
317
318     my $r;
319     eval { $r = $g->case_sensitive_path ($path); };
320     return $r;
321 }
322
323 =head2 file_architecture
324
325  $arch = file_architecture ($g, $path)
326
327 The C<file_architecture> function lets you get the architecture for a
328 particular binary or library in the guest.  By "architecture" we mean
329 what processor it is compiled for (eg. C<i586> or C<x86_64>).
330
331 The function works on at least the following types of files:
332
333 =over 4
334
335 =item *
336
337 many types of Un*x binary
338
339 =item *
340
341 many types of Un*x shared library
342
343 =item *
344
345 Windows Win32 and Win64 binaries
346
347 =item *
348
349 Windows Win32 and Win64 DLLs
350
351 Win32 binaries and DLLs return C<i386>.
352
353 Win64 binaries and DLLs return C<x86_64>.
354
355 =item *
356
357 Linux kernel modules
358
359 =item *
360
361 Linux new-style initrd images
362
363 =item *
364
365 some non-x86 Linux vmlinuz kernels
366
367 =back
368
369 What it can't do currently:
370
371 =over 4
372
373 =item *
374
375 static libraries (libfoo.a)
376
377 =item *
378
379 Linux old-style initrd as compressed ext2 filesystem (RHEL 3)
380
381 =item *
382
383 x86 Linux vmlinuz kernels
384
385 x86 vmlinuz images (bzImage format) consist of a mix of 16-, 32- and
386 compressed code, and are horribly hard to unpack.  If you want to find
387 the architecture of a kernel, use the architecture of the associated
388 initrd or kernel module(s) instead.
389
390 =back
391
392 =cut
393
394 sub _elf_arch_to_canonical
395 {
396     local $_ = shift;
397
398     if ($_ eq "Intel 80386") {
399         return "i386";
400     } elsif ($_ eq "Intel 80486") {
401         return "i486";  # probably not in the wild
402     } elsif ($_ eq "x86-64") {
403         return "x86_64";
404     } elsif ($_ eq "AMD x86-64") {
405         return "x86_64";
406     } elsif (/SPARC32/) {
407         return "sparc";
408     } elsif (/SPARC V9/) {
409         return "sparc64";
410     } elsif ($_ eq "IA-64") {
411         return "ia64";
412     } elsif (/64.*PowerPC/) {
413         return "ppc64";
414     } elsif (/PowerPC/) {
415         return "ppc";
416     } else {
417         warn __x("returning non-canonical architecture type '{arch}'",
418                  arch => $_);
419         return $_;
420     }
421 }
422
423 my @_initrd_binaries = ("nash", "modprobe", "sh", "bash");
424
425 sub file_architecture
426 {
427     local $_;
428     my $g = shift;
429     my $path = shift;
430
431     # Our basic tool is 'file' ...
432     my $file = $g->file ($path);
433
434     if ($file =~ /ELF.*(?:executable|shared object|relocatable), (.+?),/) {
435         # ELF executable or shared object.  We need to convert
436         # what file(1) prints into the canonical form.
437         return _elf_arch_to_canonical ($1);
438     } elsif ($file =~ /PE32 executable/) {
439         return "i386";          # Win32 executable or DLL
440     } elsif ($file =~ /PE32\+ executable/) {
441         return "x86_64";        # Win64 executable or DLL
442     }
443
444     elsif ($file =~ /cpio archive/) {
445         # Probably an initrd.
446         my $zcat = "cat";
447         if ($file =~ /gzip/) {
448             $zcat = "zcat";
449         } elsif ($file =~ /bzip2/) {
450             $zcat = "bzcat";
451         }
452
453         # Download and unpack it to find a binary file.
454         my $dir = tempdir (CLEANUP => 1);
455         $g->download ($path, "$dir/initrd");
456
457         my $bins = join " ", map { "bin/$_" } @_initrd_binaries;
458         my $cmd = "cd $dir && $zcat initrd | cpio --quiet -id $bins";
459         my $r = system ($cmd);
460         die __x("cpio command failed: {error}", error => $?)
461             unless $r == 0;
462
463         foreach my $bin (@_initrd_binaries) {
464             if (-f "$dir/bin/$bin") {
465                 $_ = `file $dir/bin/$bin`;
466                 if (/ELF.*executable, (.+?),/) {
467                     return _elf_arch_to_canonical ($1);
468                 }
469             }
470         }
471
472         die __x("file_architecture: no known binaries found in initrd image: {path}",
473                 path => $path);
474     }
475
476     die __x("file_architecture: unknown architecture: {path}",
477             path => $path);
478 }
479
480 =head1 OPERATING SYSTEM INSPECTION FUNCTIONS
481
482 The functions in this section can be used to inspect the operating
483 system(s) available inside a virtual machine image.  For example, you
484 can find out if the VM is Linux or Windows, how the partitions are
485 meant to be mounted, and what applications are installed.
486
487 If you just want a simple command-line interface to this
488 functionality, use the L<virt-inspector(1)> tool.  The documentation
489 below covers the case where you want to access this functionality from
490 a Perl program.
491
492 Once you have the list of partitions (from C<get_partitions>) there
493 are several steps involved:
494
495 =over 4
496
497 =item 1.
498
499 Look at each partition separately and find out what is on it.
500
501 The information you get back includes whether the partition contains a
502 filesystem or swapspace, what sort of filesystem (eg. ext3, ntfs), and
503 a first pass guess at the content of the filesystem (eg. Linux boot,
504 Windows root).
505
506 The result of this step is a C<%fs> hash of information, one hash for
507 each partition.
508
509 See: C<inspect_partition>, C<inspect_all_partitions>
510
511 =item 2.
512
513 Work out the relationship between partitions.
514
515 In this step we work out how partitions are related to each other.  In
516 the case of a single-boot VM, we work out how the partitions are
517 mounted in respect of each other (eg. C</dev/sda1> is mounted as
518 C</boot>).  In the case of a multi-boot VM where there are several
519 roots, we may identify several operating system roots, and mountpoints
520 can even be shared.
521
522 The result of this step is a single hash called C<%oses> which is
523 described in more detail below, but at the top level looks like:
524
525  %oses = {
526    '/dev/VG/Root1' => \%os1,
527    '/dev/VG/Root2' => \%os2,
528  }
529
530  %os1 = {
531    os => 'linux',
532    mounts => {
533      '/' => '/dev/VG/Root1',
534      '/boot' => '/dev/sda1',
535    },
536    ...
537  }
538
539 (example shows a multi-boot VM containing two root partitions).
540
541 See: C<inspect_operating_systems>
542
543 =item 3.
544
545 Mount up the disks.
546
547 Previous to this point we've essentially been looking at each
548 partition in isolation.  Now we construct a true guest filesystem by
549 mounting up all of the disks.  Only once everything is mounted up can
550 we run commands in the OS context to do more detailed inspection.
551
552 See: C<mount_operating_system>
553
554 =item 4.
555
556 Check for kernels and applications.
557
558 This step now does more detailed inspection, where we can look for
559 kernels, applications and more installed in the guest.
560
561 The result of this is an enhanced C<%os> hash.
562
563 See: C<inspect_in_detail>
564
565 =item 5.
566
567 Generate output.
568
569 This library does not contain functions for generating output based on
570 the analysis steps above.  Use a command line tool such as
571 L<virt-inspector(1)> to get useful output.
572
573 =back
574
575 =head2 inspect_all_partitions
576
577  %fses = inspect_all_partitions ($g, \@partitions);
578
579 This calls C<inspect_partition> for each partition in the list
580 C<@partitions>.
581
582 The result is a hash which maps partition name to C<\%fs> hashref.
583
584 The contents of the C<%fs> hash is explained below.
585
586 =cut
587
588 # Turn /dev/vd* and /dev/hd* into canonical device names
589 # (see BLOCK DEVICE NAMING in guestfs(3)).
590
591 sub _canonical_dev ($)
592 {
593     my ($dev) = @_;
594     return "/dev/sd$1" if $dev =~ m{^/dev/[vh]d(\w+)};
595     return $dev;
596 }
597
598 sub inspect_all_partitions
599 {
600     local $_;
601     my $g = shift;
602     my $parts = shift;
603     my @parts = @$parts;
604     return map { _canonical_dev ($_) => inspect_partition ($g, $_) } @parts;
605 }
606
607 =head2 inspect_partition
608
609  \%fs = inspect_partition ($g, $partition);
610
611 This function inspects the device named C<$partition> in isolation and
612 tries to determine what it is.  It returns information such as whether
613 the partition is formatted, and with what, whether it is mountable,
614 and what it appears to contain (eg. a Windows root, or a Linux /usr).
615
616 If the Perl module L<Win::Hivex(3)> is installed, then additional
617 information is made available for Windows guests, if we can locate and
618 read their registries.
619
620 The returned value is a hashref C<\%fs> which may contain the
621 following top-level keys (any key can be missing):
622
623 =over 4
624
625 =item fstype
626
627 Filesystem type, eg. "ext2" or "ntfs"
628
629 =item fsos
630
631 Apparent filesystem OS, eg. "linux" or "windows"
632
633 =item is_swap
634
635 If set, the partition is a swap partition.
636
637 =item uuid
638
639 Filesystem UUID.
640
641 =item label
642
643 Filesystem label.
644
645 =item is_mountable
646
647 If set, the partition could be mounted by libguestfs.
648
649 =item content
650
651 Filesystem content, if we could determine it.  One of: "linux-grub",
652 "linux-root", "linux-usrlocal", "linux-usr", "windows-root".
653
654 =item osdistro
655
656 (For Linux root partitions only).
657 Operating system distribution.  One of: "fedora", "rhel", "centos",
658 "scientific", "debian".
659
660 =item package_format
661
662 (For Linux root partitions only)
663 The package format used by the guest distribution. One of: "rpm", "deb".
664
665 =item package_management
666
667 (For Linux root partitions only)
668 The package management tool used by the guest distribution. One of: "rhn",
669 "yum", "apt".
670
671 =item os_major_version
672
673 (For root partitions only).
674 Operating system major version number.
675
676 =item os_minor_version
677
678 (For root partitions only).
679 Operating system minor version number.
680
681 =item fstab
682
683 (For Linux root partitions only).
684 The contents of the C</etc/fstab> file.
685
686 =item boot_ini
687
688 (For Windows root partitions only).
689 The contents of the C</boot.ini> (NTLDR) file.
690
691 =item registry
692
693 The value is an arrayref, which is a list of Windows registry
694 file contents, in Windows C<.REG> format.
695
696 =back
697
698 =cut
699
700 sub inspect_partition
701 {
702     local $_;
703     my $g = shift;
704     my $dev = shift;            # LV or partition name.
705
706     my %r;                      # Result hash.
707
708     # First try 'file(1)' on it.
709     my $file = $g->file ($dev);
710     if ($file =~ /ext2 filesystem data/) {
711         $r{fstype} = "ext2";
712         $r{fsos} = "linux";
713     } elsif ($file =~ /ext3 filesystem data/) {
714         $r{fstype} = "ext3";
715         $r{fsos} = "linux";
716     } elsif ($file =~ /ext4 filesystem data/) {
717         $r{fstype} = "ext4";
718         $r{fsos} = "linux";
719     } elsif ($file =~ m{Linux/i386 swap file}) {
720         $r{fstype} = "swap";
721         $r{fsos} = "linux";
722         $r{is_swap} = 1;
723     }
724
725     # If it's ext2/3/4, then we want the UUID and label.
726     if (exists $r{fstype} && $r{fstype} =~ /^ext/) {
727         $r{uuid} = $g->get_e2uuid ($dev);
728         $r{label} = $g->get_e2label ($dev);
729     }
730
731     # Try mounting it, fnarrr.
732     if (!$r{is_swap}) {
733         $r{is_mountable} = 1;
734         eval { $g->mount_ro ($dev, "/") };
735         if ($@) {
736             # It's not mountable, probably empty or some format
737             # we don't understand.
738             $r{is_mountable} = 0;
739             goto OUT;
740         }
741
742         # Grub /boot?
743         if ($g->is_file ("/grub/menu.lst") ||
744             $g->is_file ("/grub/grub.conf")) {
745             $r{content} = "linux-grub";
746             _check_grub ($g, \%r);
747             goto OUT;
748         }
749
750         # Linux root?
751         if ($g->is_dir ("/etc") && $g->is_dir ("/bin") &&
752             $g->is_file ("/etc/fstab")) {
753             $r{content} = "linux-root";
754             $r{is_root} = 1;
755             _check_linux_root ($g, \%r);
756             goto OUT;
757         }
758
759         # Linux /usr/local.
760         if ($g->is_dir ("/etc") && $g->is_dir ("/bin") &&
761             $g->is_dir ("/share") && !$g->exists ("/local") &&
762             !$g->is_file ("/etc/fstab")) {
763             $r{content} = "linux-usrlocal";
764             goto OUT;
765         }
766
767         # Linux /usr.
768         if ($g->is_dir ("/etc") && $g->is_dir ("/bin") &&
769             $g->is_dir ("/share") && $g->exists ("/local") &&
770             !$g->is_file ("/etc/fstab")) {
771             $r{content} = "linux-usr";
772             goto OUT;
773         }
774
775         # Windows root?
776         if ($g->is_file ("/AUTOEXEC.BAT") ||
777             $g->is_file ("/autoexec.bat") ||
778             $g->is_dir ("/Program Files") ||
779             $g->is_dir ("/WINDOWS") ||
780             $g->is_file ("/boot.ini") ||
781             $g->is_file ("/ntldr")) {
782             $r{fstype} = "ntfs"; # XXX this is a guess
783             $r{fsos} = "windows";
784             $r{content} = "windows-root";
785             $r{is_root} = 1;
786             _check_windows_root ($g, \%r);
787             goto OUT;
788         }
789     }
790
791   OUT:
792     $g->umount_all ();
793     return \%r;
794 }
795
796 sub _check_linux_root
797 {
798     local $_;
799     my $g = shift;
800     my $r = shift;
801
802     # Look into /etc to see if we recognise the operating system.
803     # N.B. don't use $g->is_file here, because it might be a symlink
804     if ($g->exists ("/etc/redhat-release")) {
805         $r->{package_format} = "rpm";
806
807         $_ = $g->cat ("/etc/redhat-release");
808         if (/Fedora release (\d+)(?:\.(\d+))?/) {
809             chomp; $r->{product_name} = $_;
810             $r->{osdistro} = "fedora";
811             $r->{os_major_version} = "$1";
812             $r->{os_minor_version} = "$2" if(defined($2));
813             $r->{package_management} = "yum";
814         }
815
816         elsif (/(Red Hat Enterprise Linux|CentOS|Scientific Linux)/) {
817             chomp; $r->{product_name} = $_;
818
819             my $distro = $1;
820
821             if($distro eq "Red Hat Enterprise Linux") {
822                 $r->{osdistro} = "rhel";
823             }
824
825             elsif($distro eq "CentOS") {
826                 $r->{osdistro} = "centos";
827                 $r->{package_management} = "yum";
828             }
829
830             elsif($distro eq "Scientific Linux") {
831                 $r->{osdistro} = "scientific";
832                 $r->{package_management} = "yum";
833             }
834
835             # Shouldn't be possible
836             else { die };
837
838             if (/$distro.*release (\d+).*Update (\d+)/) {
839                 $r->{os_major_version} = "$1";
840                 $r->{os_minor_version} = "$2";
841             }
842
843             elsif (/$distro.*release (\d+)(?:\.(\d+))?/) {
844                 $r->{os_major_version} = "$1";
845
846                 if(defined($2)) {
847                     $r->{os_minor_version} = "$2";
848                 } else {
849                     $r->{os_minor_version} = "0";
850                 }
851             }
852
853             # Package management in RHEL changed in version 5
854             if ($r->{osdistro} eq "rhel") {
855                 if ($r->{os_major_version} >= 5) {
856                     $r->{package_management} = "yum";
857                 } else {
858                     $r->{package_management} = "rhn";
859                 }
860             }
861         }
862
863         else {
864             $r->{osdistro} = "redhat-based";
865         }
866     } elsif ($g->is_file ("/etc/debian_version")) {
867         $r->{package_format} = "deb";
868         $r->{package_management} = "apt";
869
870         $_ = $g->cat ("/etc/debian_version");
871         if (/(\d+)\.(\d+)/) {
872             chomp; $r->{product_name} = $_;
873             $r->{osdistro} = "debian";
874             $r->{os_major_version} = "$1";
875             $r->{os_minor_version} = "$2";
876         } else {
877             $r->{osdistro} = "debian";
878         }
879     }
880
881     # Parse the contents of /etc/fstab.  This is pretty vital so
882     # we can determine where filesystems are supposed to be mounted.
883     eval "\$_ = \$g->cat ('/etc/fstab');";
884     if (!$@ && $_) {
885         my @lines = split /\n/;
886         my @fstab;
887         foreach (@lines) {
888             my @fields = split /[ \t]+/;
889             if (@fields >= 2) {
890                 my $spec = $fields[0]; # first column (dev/label/uuid)
891                 my $file = $fields[1]; # second column (mountpoint)
892                 if ($spec =~ m{^/} ||
893                     $spec =~ m{^LABEL=} ||
894                     $spec =~ m{^UUID=} ||
895                     $file eq "swap") {
896                     push @fstab, [$spec, $file]
897                 }
898             }
899         }
900         $r->{fstab} = \@fstab if @fstab;
901     }
902
903     # Determine the architecture of this root.
904     my $arch;
905     foreach ("/bin/bash", "/bin/ls", "/bin/echo", "/bin/rm", "/bin/sh") {
906         if ($g->is_file ($_)) {
907             $arch = file_architecture ($g, $_);
908             last;
909         }
910     }
911
912     $r->{arch} = $arch if defined $arch;
913 }
914
915 # We only support NT.  The control file /boot.ini contains a list of
916 # Windows installations and their %systemroot%s in a simple text
917 # format.
918 #
919 # XXX We don't handle the case where /boot.ini is on a different
920 # partition very well (Windows Vista and later).
921
922 sub _check_windows_root
923 {
924     local $_;
925     my $g = shift;
926     my $r = shift;
927
928     my $boot_ini = resolve_windows_path ($g, "/boot.ini");
929     $r->{boot_ini} = $boot_ini;
930
931     my $systemroot;
932     if (defined $r->{boot_ini}) {
933         $_ = $g->cat ($boot_ini);
934         my @lines = split /\n/;
935         my $section;
936         foreach (@lines) {
937             if (m/\[.*\]/) {
938                 $section = $1;
939             } elsif (m/^default=.*?\\(\w+)$/i) {
940                 $systemroot = $1;
941                 last;
942             } elsif (m/\\(\w+)=/) {
943                 $systemroot = $1;
944                 last;
945             }
946         }
947     }
948
949     if (!defined $systemroot) {
950         # Last ditch ... try to guess %systemroot% location.
951         foreach ("windows", "winnt") {
952             my $dir = resolve_windows_path ($g, "/$_/system32");
953             if (defined $dir) {
954                 $systemroot = $_;
955                 last;
956             }
957         }
958     }
959
960     if (defined $systemroot) {
961         $r->{systemroot} = resolve_windows_path ($g, "/$systemroot");
962         if (defined $r->{systemroot}) {
963             _check_windows_arch ($g, $r, $r->{systemroot});
964             _check_windows_registry ($g, $r, $r->{systemroot});
965         }
966     }
967 }
968
969 # Find Windows userspace arch.
970
971 sub _check_windows_arch
972 {
973     local $_;
974     my $g = shift;
975     my $r = shift;
976     my $systemroot = shift;
977
978     my $cmd_exe =
979         resolve_windows_path ($g, $r->{systemroot} . "/system32/cmd.exe");
980     $r->{arch} = file_architecture ($g, $cmd_exe) if $cmd_exe;
981 }
982
983 sub _check_windows_registry
984 {
985     local $_;
986     my $g = shift;
987     my $r = shift;
988     my $systemroot = shift;
989
990     # Download the system registry files.  Only download the
991     # interesting ones (SOFTWARE and SYSTEM).  We don't bother with
992     # the user ones.
993
994     return unless exists $INC{"Win/Hivex.pm"};
995
996     my $configdir = resolve_windows_path ($g, "$systemroot/system32/config");
997     return unless defined $configdir;
998
999     my $tmpdir = tempdir (CLEANUP => 1);
1000
1001     my $software = resolve_windows_path ($g, "$configdir/software");
1002     my $software_hive;
1003     if (defined $software) {
1004         eval {
1005             $g->download ($software, "$tmpdir/software");
1006             $software_hive = Win::Hivex->open ("$tmpdir/software");
1007         };
1008         warn "$@\n" if $@;
1009         $r->{windows_software_hive} = $software;
1010     }
1011
1012     my $system = resolve_windows_path ($g, "$configdir/system");
1013     my $system_hive;
1014     if (defined $system) {
1015         eval {
1016             $g->download ($system, "$tmpdir/system");
1017             $system_hive = Win::Hivex->open ("$tmpdir/system");
1018         };
1019         warn "$@\n" if $@;
1020         $r->{windows_system_hive} = $system;
1021     }
1022
1023     # Get the ProductName, major and minor version, etc.
1024     if (defined $software_hive) {
1025         my $cv_node;
1026         eval {
1027             $cv_node = $software_hive->root;
1028             $cv_node = $software_hive->node_get_child ($cv_node, $_)
1029                 foreach ("Microsoft", "Windows NT", "CurrentVersion");
1030         };
1031         warn "$@\n" if $@;
1032
1033         if ($cv_node) {
1034             my @values = $software_hive->node_values ($cv_node);
1035
1036             foreach (@values) {
1037                 my $k = $software_hive->value_key ($_);
1038                 if ($k eq "ProductName") {
1039                     $_ = $software_hive->value_string ($_);
1040                     $r->{product_name} = $_ if defined $_;
1041                 } elsif ($k eq "CurrentVersion") {
1042                     $_ = $software_hive->value_string ($_);
1043                     if (defined $_ && m/^(\d+)\.(\d+)/) {
1044                         $r->{os_major_version} = $1;
1045                         $r->{os_minor_version} = $2;
1046                     }
1047                 } elsif ($k eq "CurrentBuild") {
1048                     $_ = $software_hive->value_string ($_);
1049                     $r->{windows_current_build} = $_ if defined $_;
1050                 } elsif ($k eq "SoftwareType") {
1051                     $_ = $software_hive->value_string ($_);
1052                     $r->{windows_software_type} = $_ if defined $_;
1053                 } elsif ($k eq "CurrentType") {
1054                     $_ = $software_hive->value_string ($_);
1055                     $r->{windows_current_type} = $_ if defined $_;
1056                 } elsif ($k eq "RegisteredOwner") {
1057                     $_ = $software_hive->value_string ($_);
1058                     $r->{windows_registered_owner} = $_ if defined $_;
1059                 } elsif ($k eq "RegisteredOrganization") {
1060                     $_ = $software_hive->value_string ($_);
1061                     $r->{windows_registered_organization} = $_ if defined $_;
1062                 } elsif ($k eq "InstallationType") {
1063                     $_ = $software_hive->value_string ($_);
1064                     $r->{windows_installation_type} = $_ if defined $_;
1065                 } elsif ($k eq "EditionID") {
1066                     $_ = $software_hive->value_string ($_);
1067                     $r->{windows_edition_id} = $_ if defined $_;
1068                 } elsif ($k eq "ProductID") {
1069                     $_ = $software_hive->value_string ($_);
1070                     $r->{windows_product_id} = $_ if defined $_;
1071                 }
1072             }
1073         }
1074     }
1075 }
1076
1077 sub _check_grub
1078 {
1079     local $_;
1080     my $g = shift;
1081     my $r = shift;
1082
1083     # Grub version, if we care.
1084 }
1085
1086 =head2 inspect_operating_systems
1087
1088  \%oses = inspect_operating_systems ($g, \%fses);
1089
1090 This function works out how partitions are related to each other.  In
1091 the case of a single-boot VM, we work out how the partitions are
1092 mounted in respect of each other (eg. C</dev/sda1> is mounted as
1093 C</boot>).  In the case of a multi-boot VM where there are several
1094 roots, we may identify several operating system roots, and mountpoints
1095 can even be shared.
1096
1097 This function returns a hashref C<\%oses> which at the top level looks
1098 like:
1099
1100  %oses = {
1101    '/dev/VG/Root' => \%os,
1102  }
1103
1104 (There can be multiple roots for a multi-boot VM).
1105
1106 The C<\%os> hash contains the following keys (any can be omitted):
1107
1108 =over 4
1109
1110 =item os
1111
1112 Operating system type, eg. "linux", "windows".
1113
1114 =item arch
1115
1116 Operating system userspace architecture, eg. "i386", "x86_64".
1117
1118 =item distro
1119
1120 Operating system distribution, eg. "debian".
1121
1122 =item product_name
1123
1124 Free text product name.
1125
1126 =item major_version
1127
1128 Operating system major version, eg. "4".
1129
1130 =item minor_version
1131
1132 Operating system minor version, eg "3".
1133
1134 =item root
1135
1136 The value is a reference to the root partition C<%fs> hash.
1137
1138 =item root_device
1139
1140 The value is the name of the root partition (as a string).
1141
1142 =item mounts
1143
1144 Mountpoints.
1145 The value is a hashref like this:
1146
1147  mounts => {
1148    '/' => '/dev/VG/Root',
1149    '/boot' => '/dev/sda1',
1150  }
1151
1152 =item filesystems
1153
1154 Filesystems (including swap devices and unmounted partitions).
1155 The value is a hashref like this:
1156
1157  filesystems => {
1158    '/dev/sda1' => \%fs,
1159    '/dev/VG/Root' => \%fs,
1160    '/dev/VG/Swap' => \%fs,
1161  }
1162
1163 =back
1164
1165 =cut
1166
1167 sub inspect_operating_systems
1168 {
1169     local $_;
1170     my $g = shift;
1171     my $fses = shift;
1172
1173     my %oses = ();
1174
1175     foreach (sort keys %$fses) {
1176         if ($fses->{$_}->{is_root}) {
1177             my %r = (
1178                 root => $fses->{$_},
1179                 root_device => $_
1180                 );
1181             _get_os_version ($g, \%r);
1182             _assign_mount_points ($g, $fses, \%r);
1183             $oses{$_} = \%r;
1184         }
1185     }
1186
1187     return \%oses;
1188 }
1189
1190 sub _get_os_version
1191 {
1192     local $_;
1193     my $g = shift;
1194     my $r = shift;
1195
1196     $r->{os} = $r->{root}->{fsos} if exists $r->{root}->{fsos};
1197     $r->{product_name} = $r->{root}->{product_name}
1198         if exists $r->{root}->{product_name};
1199     $r->{distro} = $r->{root}->{osdistro} if exists $r->{root}->{osdistro};
1200     $r->{major_version} = $r->{root}->{os_major_version}
1201         if exists $r->{root}->{os_major_version};
1202     $r->{minor_version} = $r->{root}->{os_minor_version}
1203         if exists $r->{root}->{os_minor_version};
1204     $r->{package_format} = $r->{root}->{package_format}
1205         if exists $r->{root}->{package_format};
1206     $r->{package_management} = $r->{root}->{package_management}
1207         if exists $r->{root}->{package_management};
1208     $r->{arch} = $r->{root}->{arch} if exists $r->{root}->{arch};
1209 }
1210
1211 sub _assign_mount_points
1212 {
1213     local $_;
1214     my $g = shift;
1215     my $fses = shift;
1216     my $r = shift;
1217
1218     $r->{mounts} = { "/" => $r->{root_device} };
1219     $r->{filesystems} = { $r->{root_device} => $r->{root} };
1220
1221     # Use /etc/fstab if we have it to mount the rest.
1222     if (exists $r->{root}->{fstab}) {
1223         my @fstab = @{$r->{root}->{fstab}};
1224         foreach (@fstab) {
1225             my ($spec, $file) = @$_;
1226
1227             my ($dev, $fs) = _find_filesystem ($g, $fses, $spec);
1228             if ($dev) {
1229                 $r->{mounts}->{$file} = $dev;
1230                 $r->{filesystems}->{$dev} = $fs;
1231                 if (exists $fs->{used}) {
1232                     $fs->{used}++
1233                 } else {
1234                     $fs->{used} = 1
1235                 }
1236                 $fs->{spec} = $spec;
1237             }
1238         }
1239     }
1240 }
1241
1242 # Find filesystem by device name, LABEL=.. or UUID=..
1243 sub _find_filesystem
1244 {
1245     my $g = shift;
1246     my $fses = shift;
1247     local $_ = shift;
1248
1249     if (/^LABEL=(.*)/) {
1250         my $label = $1;
1251         foreach (sort keys %$fses) {
1252             if (exists $fses->{$_}->{label} &&
1253                 $fses->{$_}->{label} eq $label) {
1254                 return ($_, $fses->{$_});
1255             }
1256         }
1257         warn __x("unknown filesystem label {label}\n", label => $label);
1258         return ();
1259     } elsif (/^UUID=(.*)/) {
1260         my $uuid = $1;
1261         foreach (sort keys %$fses) {
1262             if (exists $fses->{$_}->{uuid} &&
1263                 $fses->{$_}->{uuid} eq $uuid) {
1264                 return ($_, $fses->{$_});
1265             }
1266         }
1267         warn __x("unknown filesystem UUID {uuid}\n", uuid => $uuid);
1268         return ();
1269     } else {
1270         return ($_, $fses->{$_}) if exists $fses->{$_};
1271
1272         # The following is to handle the case where an fstab entry specifies a
1273         # specific device rather than its label or uuid, and the libguestfs
1274         # appliance has named the device differently due to the use of a
1275         # different driver.
1276         # This will work as long as the underlying drivers recognise devices in
1277         # the same order.
1278         if (m{^/dev/hd(.*)} && exists $fses->{"/dev/sd$1"}) {
1279             return ("/dev/sd$1", $fses->{"/dev/sd$1"});
1280         }
1281         if (m{^/dev/xvd(.*)} && exists $fses->{"/dev/sd$1"}) {
1282             return ("/dev/sd$1", $fses->{"/dev/sd$1"});
1283         }
1284         if (m{^/dev/mapper/(.*)-(.*)$} && exists $fses->{"/dev/$1/$2"}) {
1285             return ("/dev/$1/$2", $fses->{"/dev/$1/$2"});
1286         }
1287
1288         return () if m{/dev/cdrom};
1289
1290         warn __x("unknown filesystem {fs}\n", fs => $_);
1291         return ();
1292     }
1293 }
1294
1295 =head2 mount_operating_system
1296
1297  mount_operating_system ($g, \%os, [$ro]);
1298
1299 This function mounts the operating system described in the
1300 C<%os> hash according to the C<mounts> table in that hash (see
1301 C<inspect_operating_systems>).
1302
1303 The partitions are mounted read-only unless the third parameter
1304 is specified as zero explicitly.
1305
1306 To reverse the effect of this call, use the standard
1307 libguestfs API call C<$g-E<gt>umount_all ()>.
1308
1309 =cut
1310
1311 sub mount_operating_system
1312 {
1313     local $_;
1314     my $g = shift;
1315     my $os = shift;
1316     my $ro = shift;             # Read-only?
1317
1318     $ro = 1 unless defined $ro; # ro defaults to 1 if unspecified
1319
1320     my $mounts = $os->{mounts};
1321
1322     # Have to mount / first.  Luckily '/' is early in the ASCII
1323     # character set, so this should be OK.
1324     foreach (sort keys %$mounts) {
1325         if($_ ne "swap" && $_ ne "none" && ($_ eq '/' || $g->is_dir ($_))) {
1326             if($ro) {
1327                 $g->mount_ro ($mounts->{$_}, $_)
1328             } else {
1329                 $g->mount_options ("", $mounts->{$_}, $_)
1330             }
1331         }
1332     }
1333 }
1334
1335 =head2 inspect_in_detail
1336
1337  mount_operating_system ($g, \%os);
1338  inspect_in_detail ($g, \%os);
1339  $g->umount_all ();
1340
1341 The C<inspect_in_detail> function inspects the mounted operating
1342 system for installed applications, installed kernels, kernel modules,
1343 system architecture, and more.
1344
1345 It adds extra keys to the existing C<%os> hash reflecting what it
1346 finds.  These extra keys are:
1347
1348 =over 4
1349
1350 =item apps
1351
1352 List of applications.
1353
1354 =item boot
1355
1356 Boot configurations. A hash containing:
1357
1358 =over 4
1359
1360 =item configs
1361
1362 An array of boot configurations. Each array entry is a hash containing:
1363
1364 =over 4
1365
1366 =item initrd
1367
1368 A reference to the expanded initrd structure (see below) for the initrd used by
1369 this boot configuration.
1370
1371 =item kernel
1372
1373 A reference to the expanded kernel structure (see below) for the kernel used by
1374 this boot configuration.
1375
1376 =item title
1377
1378 The human readable name of the configuration.
1379
1380 =item cmdline
1381
1382 The kernel command line.
1383
1384 =back
1385
1386 =item default
1387
1388 The index of the default configuration in the configs array.
1389
1390 =item grub_fs
1391
1392 The path of the filesystem containing the grub partition.
1393
1394 =back
1395
1396 =item kernels
1397
1398 List of kernels.
1399
1400 This is a hash of kernel version =E<gt> a hash with the following keys:
1401
1402 =over 4
1403
1404 =item version
1405
1406 Kernel version.
1407
1408 =item arch
1409
1410 Kernel architecture (eg. C<x86-64>).
1411
1412 =item modules
1413
1414 List of modules.
1415
1416 =item path
1417
1418 The path to the kernel's vmlinuz file.
1419
1420 =item package
1421
1422 If the kernel was installed in a package, the name of that package.
1423
1424 =back
1425
1426 =item modprobe_aliases
1427
1428 (For Linux VMs).
1429 The contents of the modprobe configuration.
1430
1431 =item initrd_modules
1432
1433 (For Linux VMs).
1434 The kernel modules installed in the initrd.  The value is
1435 a hashref of kernel version to list of modules.
1436
1437 =back
1438
1439 =cut
1440
1441 sub inspect_in_detail
1442 {
1443     local $_;
1444     my $g = shift;
1445     my $os = shift;
1446
1447     _check_for_applications ($g, $os);
1448     _check_for_kernels ($g, $os);
1449     if ($os->{os} eq "linux") {
1450         _find_modprobe_aliases ($g, $os);
1451     }
1452 }
1453
1454 sub _check_for_applications
1455 {
1456     local $_;
1457     my $g = shift;
1458     my $os = shift;
1459
1460     my @apps;
1461
1462     my $osn = $os->{os};
1463     if ($osn eq "linux") {
1464         my $package_format = $os->{package_format};
1465         if (defined $package_format && $package_format eq "rpm") {
1466             my @lines = $g->command_lines
1467                 (["rpm",
1468                   "-q", "-a",
1469                   "--qf", "%{name} %{epoch} %{version} %{release} %{arch}\n"]);
1470             @lines = sort @lines;
1471             foreach (@lines) {
1472                 if (m/^(.*) (.*) (.*) (.*) (.*)$/) {
1473                     my $epoch = $2;
1474                     undef $epoch if $epoch eq "(none)";
1475                     my $app = {
1476                         name => $1,
1477                         epoch => $epoch,
1478                         version => $3,
1479                         release => $4,
1480                         arch => $5
1481                     };
1482                     push @apps, $app
1483                 }
1484             }
1485         } elsif (defined $package_format && $package_format eq "deb") {
1486             my @lines = $g->command_lines
1487                 (["dpkg-query",
1488                   "-f", '${Package} ${Version} ${Architecture} ${Status}\n',
1489                   "-W"]);
1490             @lines = sort @lines;
1491             foreach (@lines) {
1492                 if (m/^(.*) (.*) (.*) (.*) (.*) (.*)$/) {
1493                     if ( $6 eq "installed" ) {
1494                         my $app = {
1495                             name => $1,
1496                             version => $2,
1497                             arch => $3
1498                         };
1499                         push @apps, $app
1500                     }
1501                 }
1502             }
1503         }
1504     } elsif ($osn eq "windows") {
1505         # XXX
1506         # I worked out a general plan for this, but haven't
1507         # implemented it yet.  We can iterate over /Program Files
1508         # looking for *.EXE files, which we download, then use
1509         # i686-pc-mingw32-windres on, to find the VERSIONINFO
1510         # section, which has a lot of useful information.
1511     }
1512
1513     $os->{apps} = \@apps;
1514 }
1515
1516 # Find the path which needs to be prepended to paths in grub.conf to make them
1517 # absolute
1518 sub _find_grub_prefix
1519 {
1520     my ($g, $os) = @_;
1521
1522     my $fses = $os->{filesystems};
1523     die("filesystems undefined") unless(defined($fses));
1524
1525     # Look for the filesystem which contains grub
1526     my $grubdev;
1527     foreach my $dev (keys(%$fses)) {
1528         my $fsinfo = $fses->{$dev};
1529         if(exists($fsinfo->{content}) && $fsinfo->{content} eq "linux-grub") {
1530             $grubdev = $dev;
1531             last;
1532         }
1533     }
1534
1535     my $mounts = $os->{mounts};
1536     die("mounts undefined") unless(defined($mounts));
1537
1538     # Find where the filesystem is mounted
1539     if(defined($grubdev)) {
1540         foreach my $mount (keys(%$mounts)) {
1541             if($mounts->{$mount} eq $grubdev) {
1542                 return "" if($mount eq '/');
1543                 return $mount;
1544             }
1545         }
1546
1547         die("$grubdev defined in filesystems, but not in mounts");
1548     }
1549
1550     # If we didn't find it, look for /boot/grub/menu.lst, then try to work out
1551     # what filesystem it's on. We use menu.lst rather than grub.conf because
1552     # debian only uses menu.lst, and anaconda creates a symlink for it.
1553     die(__"Can't find grub on guest") unless($g->exists('/boot/grub/menu.lst'));
1554
1555     # Look for the most specific mount point in mounts
1556     foreach my $path qw(/boot/grub /boot /) {
1557         if(exists($mounts->{$path})) {
1558             return "" if($path eq '/');
1559             return $path;
1560         }
1561     }
1562
1563     die("Couldn't determine which filesystem holds /boot/grub/menu.lst");
1564 }
1565
1566 sub _check_for_kernels
1567 {
1568     my ($g, $os) = @_;
1569
1570     if ($os->{os} eq "linux" && feature_available ($g, "augeas")) {
1571         # Iterate over entries in grub.conf, populating $os->{boot}
1572         # For every kernel we find, inspect it and add to $os->{kernels}
1573
1574         my $grub = _find_grub_prefix($g, $os);
1575         my $grub_conf = "/etc/grub.conf";
1576
1577         # Debian and other's have no /etc/grub.conf:
1578         if ( ! -f "$grub_conf" ) {
1579             $grub_conf = "$grub/grub/menu.lst";
1580         }
1581
1582         my @boot_configs;
1583
1584         # We want
1585         #  $os->{boot}
1586         #       ->{configs}
1587         #         ->[0]
1588         #           ->{title}   = "Fedora (2.6.29.6-213.fc11.i686.PAE)"
1589         #           ->{kernel}  = \kernel
1590         #           ->{cmdline} = "ro root=/dev/mapper/vg_mbooth-lv_root rhgb"
1591         #           ->{initrd}  = \initrd
1592         #       ->{default} = \config
1593         #       ->{grub_fs} = "/boot"
1594         # Initialise augeas
1595         $g->aug_init("/", 16);
1596
1597         my @configs = ();
1598         # Get all configurations from grub
1599         foreach my $bootable
1600             ($g->aug_match("/files/$grub_conf/title"))
1601         {
1602             my %config = ();
1603             $config{title} = $g->aug_get($bootable);
1604
1605             my $grub_kernel;
1606             eval { $grub_kernel = $g->aug_get("$bootable/kernel"); };
1607             if($@) {
1608                 warn __x("Grub entry {title} has no kernel",
1609                          title => $config{title});
1610             }
1611
1612             # Check we've got a kernel entry
1613             if(defined($grub_kernel)) {
1614                 my $path = "$grub$grub_kernel";
1615
1616                 # Reconstruct the kernel command line
1617                 my @args = ();
1618                 foreach my $arg ($g->aug_match("$bootable/kernel/*")) {
1619                     $arg =~ m{/kernel/([^/]*)$}
1620                         or die("Unexpected return from aug_match: $arg");
1621
1622                     my $name = $1;
1623                     my $value;
1624                     eval { $value = $g->aug_get($arg); };
1625
1626                     if(defined($value)) {
1627                         push(@args, "$name=$value");
1628                     } else {
1629                         push(@args, $name);
1630                     }
1631                 }
1632                 $config{cmdline} = join(' ', @args) if(scalar(@args) > 0);
1633
1634                 my $kernel =
1635                     inspect_linux_kernel($g, $path, $os->{package_format});
1636
1637                 # Check the kernel was recognised
1638                 if(defined($kernel)) {
1639                     # Put this kernel on the top level kernel list
1640                     $os->{kernels} ||= [];
1641                     push(@{$os->{kernels}}, $kernel);
1642
1643                     $config{kernel} = $kernel;
1644
1645                     # Look for an initrd entry
1646                     my $initrd;
1647                     eval {
1648                         $initrd = $g->aug_get("$bootable/initrd");
1649                     };
1650
1651                     unless($@) {
1652                         $config{initrd} =
1653                             _inspect_initrd($g, $os, "$grub$initrd",
1654                                             $kernel->{version});
1655                     } else {
1656                         warn __x("Grub entry {title} does not specify an ".
1657                                  "initrd", title => $config{title});
1658                     }
1659                 }
1660             }
1661
1662             push(@configs, \%config);
1663         }
1664
1665
1666         # Create the top level boot entry
1667         my %boot;
1668         $boot{configs} = \@configs;
1669         $boot{grub_fs} = $grub;
1670
1671         # Add the default configuration
1672         eval {
1673             $boot{default} = $g->aug_get("/files/$grub_conf/default");
1674         };
1675
1676         $os->{boot} = \%boot;
1677     }
1678
1679     elsif ($os->{os} eq "windows") {
1680         # XXX
1681     }
1682 }
1683
1684 =head2 inspect_linux_kernel
1685
1686  my $kernel_hash = inspect_linux_kernel($g, $vmlinuz_path, $package_format);
1687
1688 inspect_linux_kernel returns a hash describing the target linux kernel. For the
1689 contents of the hash, see the I<kernels> structure described under
1690 L</inspect_in_detail>.
1691
1692 =cut
1693
1694 sub inspect_linux_kernel
1695 {
1696     my ($g, $path, $package_format) = @_;
1697
1698     my %kernel = ();
1699
1700     $kernel{path} = $path;
1701
1702     # If this is a packaged kernel, try to work out the name of the package
1703     # which installed it. This lets us know what to install to replace it with,
1704     # e.g. kernel, kernel-smp, kernel-hugemem, kernel-PAE
1705     if($package_format eq "rpm") {
1706         my $package;
1707         eval { $package = $g->command(['rpm', '-qf', '--qf',
1708                                        '%{NAME}', $path]); };
1709         $kernel{package} = $package if defined($package);;
1710     }
1711
1712     # Try to get the kernel version by running file against it
1713     my $version;
1714     my $filedesc = $g->file($path);
1715     if($filedesc =~ /^$path: Linux kernel .*\bversion\s+(\S+)\b/) {
1716         $version = $1;
1717     }
1718
1719     # Sometimes file can't work out the kernel version, for example because it's
1720     # a Xen PV kernel. In this case try to guess the version from the filename
1721     else {
1722         if($path =~ m{/boot/vmlinuz-(.*)}) {
1723             $version = $1;
1724
1725             # Check /lib/modules/$version exists
1726             if(!$g->is_dir("/lib/modules/$version")) {
1727                 warn __x("Didn't find modules directory {modules} for kernel ".
1728                          "{path}", modules => "/lib/modules/$version",
1729                          path => $path);
1730
1731                 # Give up
1732                 return undef;
1733             }
1734         } else {
1735             warn __x("Couldn't guess kernel version number from path for ".
1736                      "kernel {path}", path => $path);
1737
1738             # Give up
1739             return undef;
1740         }
1741     }
1742
1743     $kernel{version} = $version;
1744
1745     # List modules.
1746     my @modules;
1747     my $any_module;
1748     my $prefix = "/lib/modules/$version";
1749     foreach my $module ($g->find ($prefix)) {
1750         if ($module =~ m{/([^/]+)\.(?:ko|o)$}) {
1751             $any_module = "$prefix$module" unless defined $any_module;
1752             push @modules, $1;
1753         }
1754     }
1755
1756     $kernel{modules} = \@modules;
1757
1758     # Determine kernel architecture by looking at the arch
1759     # of any kernel module.
1760     $kernel{arch} = file_architecture ($g, $any_module);
1761
1762     return \%kernel;
1763 }
1764
1765 # Find all modprobe aliases. Specifically, this looks in the following
1766 # locations:
1767 #  * /etc/conf.modules
1768 #  * /etc/modules.conf
1769 #  * /etc/modprobe.conf
1770 #  * /etc/modprobe.d/*
1771
1772 sub _find_modprobe_aliases
1773 {
1774     local $_;
1775     my $g = shift;
1776     my $os = shift;
1777
1778     # Initialise augeas
1779     $g->aug_init("/", 16);
1780
1781     # Register additional paths to the Modprobe lens
1782     $g->aug_set("/augeas/load/Modprobe/incl[last()+1]", "/etc/modules.conf");
1783     $g->aug_set("/augeas/load/Modprobe/incl[last()+1]", "/etc/conf.modules");
1784
1785     # Make augeas reload
1786     $g->aug_load();
1787
1788     my %modprobe_aliases;
1789
1790     for my $pattern qw(/files/etc/conf.modules/alias
1791                        /files/etc/modules.conf/alias
1792                        /files/etc/modprobe.conf/alias
1793                        /files/etc/modprobe.d/*/alias) {
1794         for my $path ( $g->aug_match($pattern) ) {
1795             $path =~ m{^/files(.*)/alias(?:\[\d*\])?$}
1796                 or die __x("{path} doesn't match augeas pattern",
1797                            path => $path);
1798             my $file = $1;
1799
1800             my $alias;
1801             $alias = $g->aug_get($path);
1802
1803             my $modulename;
1804             $modulename = $g->aug_get($path.'/modulename');
1805
1806             my %aliasinfo;
1807             $aliasinfo{modulename} = $modulename;
1808             $aliasinfo{augeas} = $path;
1809             $aliasinfo{file} = $file;
1810
1811             $modprobe_aliases{$alias} = \%aliasinfo;
1812         }
1813     }
1814
1815     $os->{modprobe_aliases} = \%modprobe_aliases;
1816 }
1817
1818 # Get a listing of device drivers from an initrd
1819 sub _inspect_initrd
1820 {
1821     my ($g, $os, $path, $version) = @_;
1822
1823     my @modules;
1824
1825     # Disregard old-style compressed ext2 files and only work with real
1826     # compressed cpio files, since cpio takes ages to (fail to) process anything
1827     # else.
1828     if ($g->file ($path) =~ /cpio/) {
1829         eval {
1830             @modules = $g->initrd_list ($path);
1831         };
1832         unless ($@) {
1833             @modules = grep { m{([^/]+)\.(?:ko|o)$} } @modules;
1834         } else {
1835             warn __x("{filename}: could not read initrd format",
1836                      filename => "$path");
1837         }
1838     }
1839
1840     # Add to the top level initrd_modules entry
1841     $os->{initrd_modules} ||= {};
1842     $os->{initrd_modules}->{$version} = \@modules;
1843
1844     return \@modules;
1845 }
1846
1847 1;
1848
1849 =head1 COPYRIGHT
1850
1851 Copyright (C) 2009 Red Hat Inc.
1852
1853 =head1 LICENSE
1854
1855 Please see the file COPYING.LIB for the full license.
1856
1857 =head1 SEE ALSO
1858
1859 L<virt-inspector(1)>,
1860 L<Sys::Guestfs(3)>,
1861 L<guestfs(3)>,
1862 L<http://libguestfs.org/>,
1863 L<Sys::Virt(3)>,
1864 L<http://libvirt.org/>,
1865 L<guestfish(1)>.
1866
1867 =cut