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