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