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