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