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