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