393eb8adb21dd4e3d40f4394a717f0d679d1dd3b
[libguestfs.git] / perl / lib / Sys / Guestfs / Lib.pm
1 # Sys::Guestfs::Lib
2 # Copyright (C) 2009-2010 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 # The minor part of this version number is incremented when some
24 # change is made to this module.  The major part is incremented if we
25 # make a change which is not backwards compatible.  It is not related
26 # to the libguestfs version number.
27 use vars qw($VERSION);
28 $VERSION = '0.3';
29
30 use Carp qw(croak);
31
32 use Sys::Guestfs;
33 use File::Temp qw/tempdir/;
34 use Locale::TextDomain 'libguestfs';
35
36 # Optional:
37 eval "use Sys::Virt;";
38 eval "use XML::XPath;";
39 eval "use XML::XPath::XMLParser;";
40 eval "use Win::Hivex;";
41
42 =pod
43
44 =head1 NAME
45
46 Sys::Guestfs::Lib - Useful functions for using libguestfs from Perl
47
48 =head1 SYNOPSIS
49
50  use Sys::Guestfs::Lib qw(open_guest ...);
51
52  $g = open_guest ($name);
53
54 =head1 DESCRIPTION
55
56 C<Sys::Guestfs::Lib> is an extra library of useful functions for using
57 the libguestfs API from Perl.  It also provides tighter integration
58 with libvirt.
59
60 The basic libguestfs API is not covered by this manpage.  Please refer
61 instead to L<Sys::Guestfs(3)> and L<guestfs(3)>.  The libvirt API is
62 also not covered.  For that, see L<Sys::Virt(3)>.
63
64 =head1 DEPRECATION OF SOME FUNCTIONS
65
66 This module contains functions and code to perform inspection of guest
67 images.  Since libguestfs 1.5.3 this ability has moved into the core
68 API (see L<guestfs(3)/INSPECTION>).  The inspection functions in this
69 module are deprecated and will not be updated.  Each deprecated
70 function is marked in the documentation below.
71
72 =head1 BASIC FUNCTIONS
73
74 =cut
75
76 require Exporter;
77
78 use vars qw(@EXPORT_OK @ISA);
79
80 @ISA = qw(Exporter);
81 @EXPORT_OK = qw(open_guest feature_available
82   get_partitions resolve_windows_path
83   inspect_all_partitions inspect_partition
84   inspect_operating_systems mount_operating_system inspect_in_detail
85   inspect_linux_kernel);
86
87 =head2 open_guest
88
89  $g = open_guest ($name);
90
91  $g = open_guest ($name, rw => 1, ...);
92
93  $g = open_guest ($name, address => $uri, ...);
94
95  $g = open_guest ([$img1, $img2, ...], address => $uri, format => $format, ...);
96
97  ($g, $conn, $dom, @images) = open_guest ($name);
98
99 This function opens a libguestfs handle for either the libvirt domain
100 called C<$name>, or the disk image called C<$name>.  Any disk images
101 found through libvirt or specified explicitly are attached to the
102 libguestfs handle.
103
104 The C<Sys::Guestfs> handle C<$g> is returned, or if there was an error
105 it throws an exception.  To catch errors, wrap the call in an eval
106 block.
107
108 The first parameter is either a string referring to a libvirt domain
109 or a disk image, or (if a guest has several disk images) an arrayref
110 C<[$img1, $img2, ...]>.  For disk images, if the C<format> parameter
111 is specified then that format is forced.
112
113 The handle is I<read-only> by default.  Use the optional parameter
114 C<rw =E<gt> 1> to open a read-write handle.  However if you open a
115 read-write handle, this function will refuse to use active libvirt
116 domains.
117
118 The handle is still in the config state when it is returned, so you
119 have to call C<$g-E<gt>launch ()>.
120
121 The optional C<address> parameter can be added to specify the libvirt
122 URI.
123
124 The implicit libvirt handle is closed after this function, I<unless>
125 you call the function in C<wantarray> context, in which case the
126 function returns a tuple of: the open libguestfs handle, the open
127 libvirt handle, and the open libvirt domain handle, and a list of
128 [image,format] pairs.  (This is useful if you want to do other things
129 like pulling the XML description of the guest).  Note that if this is
130 a straight disk image, then C<$conn> and C<$dom> will be C<undef>.
131
132 If the C<Sys::Virt> module is not available, then libvirt is bypassed,
133 and this function can only open disk images.
134
135 The optional C<interface> parameter can be used to open devices with a
136 specified qemu interface.  See L<Sys::Guestfs/guestfs_add_drive_opts>
137 for more details.
138
139 =cut
140
141 sub open_guest
142 {
143     local $_;
144     my $first = shift;
145     my %params = @_;
146
147     my $rw = $params{rw};
148     my $address = $params{address};
149     my $interface = $params{interface};
150     my $format = $params{format}; # undef == autodetect
151
152     my @images = ();
153     if (ref ($first) eq "ARRAY") {
154         @images = @$first;
155     } elsif (ref ($first) eq "SCALAR") {
156         @images = ($first);
157     } else {
158         croak __"open_guest: first parameter must be a string or an arrayref"
159     }
160
161     # Check each element of @images is defined.
162     # (See https://bugzilla.redhat.com/show_bug.cgi?id=601092#c3).
163     foreach (@images) {
164         croak __"open_guest: first argument contains undefined element"
165             unless defined $_;
166     }
167
168     my ($conn, $dom);
169
170     if (-e $images[0]) {
171         foreach (@images) {
172             croak __x("guest image {imagename} does not exist or is not readable",
173                     imagename => $_)
174                 unless -r $_;
175         }
176
177         @images = map { [ $_, $format ] } @images;
178     } else {
179         die __"open_guest: no libvirt support (install Sys::Virt, XML::XPath and XML::XPath::XMLParser)"
180             unless exists $INC{"Sys/Virt.pm"} &&
181             exists $INC{"XML/XPath.pm"} &&
182             exists $INC{"XML/XPath/XMLParser.pm"};
183
184         die __"open_guest: too many domains listed on command line"
185             if @images > 1;
186
187         my @libvirt_args = ();
188         push @libvirt_args, address => $address if defined $address;
189
190         $conn = Sys::Virt->new (readonly => 1, @libvirt_args);
191         die __"open_guest: cannot connect to libvirt" unless $conn;
192
193         my @doms = $conn->list_defined_domains ();
194         my $isitinactive = 1;
195         unless ($rw) {
196             # In the case where we want read-only access to a domain,
197             # allow the user to specify an active domain too.
198             push @doms, $conn->list_domains ();
199             $isitinactive = 0;
200         }
201         foreach (@doms) {
202             if ($_->get_name () eq $images[0]) {
203                 $dom = $_;
204                 last;
205             }
206         }
207
208         unless ($dom) {
209             if ($isitinactive) {
210                 die __x("{imagename} is not the name of an inactive libvirt domain\n",
211                         imagename => $images[0]);
212             } else {
213                 die __x("{imagename} is not the name of a libvirt domain\n",
214                         imagename => $images[0]);
215             }
216         }
217
218         # Get the names of the image(s).
219         my $xml = $dom->get_xml_description ();
220
221         my $p = XML::XPath->new (xml => $xml);
222         my $nodes = $p->find ('//devices/disk');
223
224         my @disks = ();
225         my $node;
226         foreach $node ($nodes->get_nodelist) {
227             # The filename can be in dev or file attribute, hence:
228             my $filename = $p->find ('./source/@dev', $node);
229             unless ($filename) {
230                 $filename = $p->find ('./source/@file', $node);
231                 next unless $filename;
232             }
233             $filename = $filename->to_literal;
234
235             # Get the disk format (may not be set).
236             my $format = $p->find ('./driver/@type', $node);
237             $format = $format->to_literal if $format;
238
239             push @disks, [ $filename, $format ];
240         }
241
242         die __x("{imagename} seems to have no disk devices\n",
243                 imagename => $images[0])
244             unless @disks;
245
246         @images = @disks;
247     }
248
249     # We've now got the list of @images, so feed them to libguestfs.
250     my $g = Sys::Guestfs->new ();
251     foreach (@images) {
252         my @args = ($_->[0]);
253         push @args, format => $_->[1] if defined $_->[1];
254         push @args, readonly => 1 unless $rw;
255         push @args, iface => $interface if defined $interface;
256         $g->add_drive_opts (@args);
257     }
258
259     return wantarray ? ($g, $conn, $dom, @images) : $g
260 }
261
262 =head2 feature_available
263
264  $bool = feature_available ($g, $feature [, $feature ...]);
265
266 This function is a useful wrapper around the basic
267 C<$g-E<gt>available> call.
268
269 C<$g-E<gt>available> tests for availability of a list of features and
270 dies with an error if any is not available.
271
272 This call tests for the list of features and returns true if all are
273 available, or false otherwise.
274
275 For a list of features you can test for, see L<guestfs(3)/AVAILABILITY>.
276
277 =cut
278
279 sub feature_available {
280     my $g = shift;
281
282     eval { $g->available (\@_); };
283     return $@ ? 0 : 1;
284 }
285
286 =head2 get_partitions
287
288 This function is deprecated.  It will not be updated in future
289 versions of libguestfs.  New code should not use this function.  Use
290 the core API function L<Sys::Guestfs(3)/list_filesystems> instead.
291
292 =cut
293
294 sub get_partitions
295 {
296     local $_;
297     my $g = shift;
298
299     # Look to see if any devices directly contain filesystems (RHBZ#590167).
300     my @devices = $g->list_devices ();
301     my @fses_on_device = ();
302     foreach (@devices) {
303         eval { $g->mount_ro ($_, "/"); };
304         push @fses_on_device, $_ unless $@;
305         $g->umount_all ();
306     }
307
308     my @partitions = $g->list_partitions ();
309     my @pvs = $g->pvs ();
310     @partitions = grep { ! _is_pv ($_, @pvs) } @partitions;
311
312     my @lvs;
313     @lvs = $g->lvs () if feature_available ($g, "lvm2");
314
315     return sort (@fses_on_device, @lvs, @partitions);
316 }
317
318 sub _is_pv {
319     local $_;
320     my $t = shift;
321
322     foreach (@_) {
323         return 1 if $_ eq $t;
324     }
325     0;
326 }
327
328 =head2 resolve_windows_path
329
330  $path = resolve_windows_path ($g, $path);
331
332  $path = resolve_windows_path ($g, "/windows/system");
333    ==> "/WINDOWS/System"
334        or undef if no path exists
335
336 This function, which is specific to FAT/NTFS filesystems (ie.  Windows
337 guests), lets you look up a case insensitive C<$path> in the
338 filesystem and returns the true, case sensitive path as required by
339 the underlying kernel or NTFS-3g driver.
340
341 If C<$path> does not exist then this function returns C<undef>.
342
343 The C<$path> parameter must begin with C</> character and be separated
344 by C</> characters.  Do not use C<\>, drive names, etc.
345
346 =cut
347
348 sub resolve_windows_path
349 {
350     my $g = shift;
351     my $path = shift;
352
353     my $r;
354     eval { $r = $g->case_sensitive_path ($path); };
355     return $r;
356 }
357
358 =head2 file_architecture
359
360 Deprecated function.  Replace any calls to this function with:
361
362  $g->file_architecture ($path);
363
364 =cut
365
366 sub file_architecture
367 {
368     my $g = shift;
369     my $path = shift;
370
371     return $g->file_architecture ($path);
372 }
373
374 =head1 OPERATING SYSTEM INSPECTION FUNCTIONS
375
376 =head2 inspect_all_partitions
377
378 This function is deprecated.  It will not be updated in future
379 versions of libguestfs.  New code should not use this function.  Use
380 the core API functions instead, see L<guestfs(3)/INSPECTION>.
381
382 =cut
383
384 # Turn /dev/vd* and /dev/hd* into canonical device names
385 # (see BLOCK DEVICE NAMING in guestfs(3)).
386
387 sub _canonical_dev ($)
388 {
389     my ($dev) = @_;
390     return "/dev/sd$1" if $dev =~ m{^/dev/[vh]d(\w+)};
391     return $dev;
392 }
393
394 sub inspect_all_partitions
395 {
396     local $_;
397     my $g = shift;
398     my $parts = shift;
399     my @parts = @$parts;
400     return map { _canonical_dev ($_) => inspect_partition ($g, $_) } @parts;
401 }
402
403 =head2 inspect_partition
404
405 This function is deprecated.  It will not be updated in future
406 versions of libguestfs.  New code should not use this function.  Use
407 the core API functions instead, see L<guestfs(3)/INSPECTION>.
408
409 =cut
410
411 sub inspect_partition
412 {
413     local $_;
414     my $g = shift;
415     my $dev = shift;            # LV or partition name.
416
417     my %r;                      # Result hash.
418
419     # First try 'file(1)' on it.
420     my $file = $g->file ($dev);
421     if ($file =~ /ext2 filesystem data/) {
422         $r{fstype} = "ext2";
423         $r{fsos} = "linux";
424     } elsif ($file =~ /ext3 filesystem data/) {
425         $r{fstype} = "ext3";
426         $r{fsos} = "linux";
427     } elsif ($file =~ /ext4 filesystem data/) {
428         $r{fstype} = "ext4";
429         $r{fsos} = "linux";
430     } elsif ($file =~ m{Linux/i386 swap file}) {
431         $r{fstype} = "swap";
432         $r{fsos} = "linux";
433         $r{is_swap} = 1;
434     }
435
436     # If it's ext2/3/4, then we want the UUID and label.
437     if (exists $r{fstype} && $r{fstype} =~ /^ext/) {
438         $r{uuid} = $g->get_e2uuid ($dev);
439         $r{label} = $g->get_e2label ($dev);
440     }
441
442     # Try mounting it, fnarrr.
443     if (!$r{is_swap}) {
444         $r{is_mountable} = 1;
445         eval { $g->mount_ro ($dev, "/") };
446         if ($@) {
447             # It's not mountable, probably empty or some format
448             # we don't understand.
449             $r{is_mountable} = 0;
450             goto OUT;
451         }
452
453         # Grub /boot?
454         if ($g->is_file ("/grub/menu.lst") ||
455             $g->is_file ("/grub/grub.conf")) {
456             $r{content} = "linux-grub";
457             _check_grub ($g, \%r);
458             goto OUT;
459         }
460
461         # Linux root?
462         if ($g->is_dir ("/etc") && $g->is_dir ("/bin") &&
463             $g->is_file ("/etc/fstab")) {
464             $r{content} = "linux-root";
465             $r{is_root} = 1;
466             _check_linux_root ($g, \%r);
467             goto OUT;
468         }
469
470         # Linux /usr/local.
471         if ($g->is_dir ("/etc") && $g->is_dir ("/bin") &&
472             $g->is_dir ("/share") && !$g->exists ("/local") &&
473             !$g->is_file ("/etc/fstab")) {
474             $r{content} = "linux-usrlocal";
475             goto OUT;
476         }
477
478         # Linux /usr.
479         if ($g->is_dir ("/etc") && $g->is_dir ("/bin") &&
480             $g->is_dir ("/share") && $g->exists ("/local") &&
481             !$g->is_file ("/etc/fstab")) {
482             $r{content} = "linux-usr";
483             goto OUT;
484         }
485
486         # Windows root?
487         if ($g->is_file ("/AUTOEXEC.BAT") ||
488             $g->is_file ("/autoexec.bat") ||
489             $g->is_dir ("/Program Files") ||
490             $g->is_dir ("/WINDOWS") ||
491             $g->is_file ("/boot.ini") ||
492             $g->is_file ("/ntldr")) {
493             $r{fstype} = "ntfs"; # XXX this is a guess
494             $r{fsos} = "windows";
495             $r{content} = "windows-root";
496             $r{is_root} = 1;
497             _check_windows_root ($g, \%r);
498             goto OUT;
499         }
500     }
501
502   OUT:
503     $g->umount_all ();
504     return \%r;
505 }
506
507 sub _check_linux_root
508 {
509     local $_;
510     my $g = shift;
511     my $r = shift;
512
513     # Look into /etc to see if we recognise the operating system.
514     # N.B. don't use $g->is_file here, because it might be a symlink
515     if ($g->exists ("/etc/redhat-release")) {
516         $r->{package_format} = "rpm";
517
518         $_ = $g->cat ("/etc/redhat-release");
519         if (/Fedora release (\d+)(?:\.(\d+))?/) {
520             chomp; $r->{product_name} = $_;
521             $r->{osdistro} = "fedora";
522             $r->{os_major_version} = "$1";
523             $r->{os_minor_version} = "$2" if(defined($2));
524             $r->{package_management} = "yum";
525         }
526
527         elsif (/(Red Hat Enterprise Linux|CentOS|Scientific Linux)/) {
528             chomp; $r->{product_name} = $_;
529
530             my $distro = $1;
531
532             if($distro eq "Red Hat Enterprise Linux") {
533                 $r->{osdistro} = "rhel";
534             }
535
536             elsif($distro eq "CentOS") {
537                 $r->{osdistro} = "centos";
538                 $r->{package_management} = "yum";
539             }
540
541             elsif($distro eq "Scientific Linux") {
542                 $r->{osdistro} = "scientific";
543                 $r->{package_management} = "yum";
544             }
545
546             # Shouldn't be possible
547             else { die };
548
549             if (/$distro.*release (\d+).*Update (\d+)/) {
550                 $r->{os_major_version} = "$1";
551                 $r->{os_minor_version} = "$2";
552             }
553
554             elsif (/$distro.*release (\d+)(?:\.(\d+))?/) {
555                 $r->{os_major_version} = "$1";
556
557                 if(defined($2)) {
558                     $r->{os_minor_version} = "$2";
559                 } else {
560                     $r->{os_minor_version} = "0";
561                 }
562             }
563
564             # Package management in RHEL changed in version 5
565             if ($r->{osdistro} eq "rhel") {
566                 if ($r->{os_major_version} >= 5) {
567                     $r->{package_management} = "yum";
568                 } else {
569                     $r->{package_management} = "rhn";
570                 }
571             }
572         }
573
574         else {
575             $r->{osdistro} = "redhat-based";
576         }
577     } elsif ($g->is_file ("/etc/debian_version")) {
578         $r->{package_format} = "deb";
579         $r->{package_management} = "apt";
580
581         $_ = $g->cat ("/etc/debian_version");
582         if (/(\d+)\.(\d+)/) {
583             chomp; $r->{product_name} = $_;
584             $r->{osdistro} = "debian";
585             $r->{os_major_version} = "$1";
586             $r->{os_minor_version} = "$2";
587         } else {
588             $r->{osdistro} = "debian";
589         }
590     }
591
592     # Parse the contents of /etc/fstab.  This is pretty vital so
593     # we can determine where filesystems are supposed to be mounted.
594     eval "\$_ = \$g->cat ('/etc/fstab');";
595     if (!$@ && $_) {
596         my @lines = split /\n/;
597         my @fstab;
598         foreach (@lines) {
599             my @fields = split /[ \t]+/;
600             if (@fields >= 2) {
601                 my $spec = $fields[0]; # first column (dev/label/uuid)
602                 my $file = $fields[1]; # second column (mountpoint)
603                 if ($spec =~ m{^/} ||
604                     $spec =~ m{^LABEL=} ||
605                     $spec =~ m{^UUID=} ||
606                     $file eq "swap") {
607                     push @fstab, [$spec, $file]
608                 }
609             }
610         }
611         $r->{fstab} = \@fstab if @fstab;
612     }
613
614     # Determine the architecture of this root.
615     my $arch;
616     foreach ("/bin/bash", "/bin/ls", "/bin/echo", "/bin/rm", "/bin/sh") {
617         if ($g->is_file ($_)) {
618             $arch = file_architecture ($g, $_);
619             last;
620         }
621     }
622
623     $r->{arch} = $arch if defined $arch;
624 }
625
626 # We only support NT.  The control file /boot.ini contains a list of
627 # Windows installations and their %systemroot%s in a simple text
628 # format.
629 #
630 # XXX We don't handle the case where /boot.ini is on a different
631 # partition very well (Windows Vista and later).
632
633 sub _check_windows_root
634 {
635     local $_;
636     my $g = shift;
637     my $r = shift;
638
639     my $boot_ini = resolve_windows_path ($g, "/boot.ini");
640     $r->{boot_ini} = $boot_ini;
641
642     my $systemroot;
643     if (defined $r->{boot_ini}) {
644         $_ = $g->cat ($boot_ini);
645         my @lines = split /\n/;
646         my $section;
647         foreach (@lines) {
648             if (m/\[.*\]/) {
649                 $section = $1;
650             } elsif (m/^default=.*?\\(\w+)$/i) {
651                 $systemroot = $1;
652                 last;
653             } elsif (m/\\(\w+)=/) {
654                 $systemroot = $1;
655                 last;
656             }
657         }
658     }
659
660     if (!defined $systemroot) {
661         # Last ditch ... try to guess %systemroot% location.
662         foreach ("windows", "winnt") {
663             my $dir = resolve_windows_path ($g, "/$_/system32");
664             if (defined $dir) {
665                 $systemroot = $_;
666                 last;
667             }
668         }
669     }
670
671     if (defined $systemroot) {
672         $r->{systemroot} = resolve_windows_path ($g, "/$systemroot");
673         if (defined $r->{systemroot}) {
674             _check_windows_arch ($g, $r, $r->{systemroot});
675             _check_windows_registry ($g, $r, $r->{systemroot});
676         }
677     }
678 }
679
680 # Find Windows userspace arch.
681
682 sub _check_windows_arch
683 {
684     local $_;
685     my $g = shift;
686     my $r = shift;
687     my $systemroot = shift;
688
689     my $cmd_exe =
690         resolve_windows_path ($g, $r->{systemroot} . "/system32/cmd.exe");
691     $r->{arch} = file_architecture ($g, $cmd_exe) if $cmd_exe;
692 }
693
694 sub _check_windows_registry
695 {
696     local $_;
697     my $g = shift;
698     my $r = shift;
699     my $systemroot = shift;
700
701     # Download the system registry files.  Only download the
702     # interesting ones (SOFTWARE and SYSTEM).  We don't bother with
703     # the user ones.
704
705     return unless exists $INC{"Win/Hivex.pm"};
706
707     my $configdir = resolve_windows_path ($g, "$systemroot/system32/config");
708     return unless defined $configdir;
709
710     my $tmpdir = tempdir (CLEANUP => 1);
711
712     my $software = resolve_windows_path ($g, "$configdir/software");
713     my $software_hive;
714     if (defined $software) {
715         eval {
716             $g->download ($software, "$tmpdir/software");
717             $software_hive = Win::Hivex->open ("$tmpdir/software");
718         };
719         warn "$@\n" if $@;
720         $r->{windows_software_hive} = $software;
721     }
722
723     my $system = resolve_windows_path ($g, "$configdir/system");
724     my $system_hive;
725     if (defined $system) {
726         eval {
727             $g->download ($system, "$tmpdir/system");
728             $system_hive = Win::Hivex->open ("$tmpdir/system");
729         };
730         warn "$@\n" if $@;
731         $r->{windows_system_hive} = $system;
732     }
733
734     # Get the ProductName, major and minor version, etc.
735     if (defined $software_hive) {
736         my $cv_node;
737         eval {
738             $cv_node = $software_hive->root;
739             $cv_node = $software_hive->node_get_child ($cv_node, $_)
740                 foreach ("Microsoft", "Windows NT", "CurrentVersion");
741         };
742         warn "$@\n" if $@;
743
744         if ($cv_node) {
745             my @values = $software_hive->node_values ($cv_node);
746
747             foreach (@values) {
748                 my $k = $software_hive->value_key ($_);
749                 if ($k eq "ProductName") {
750                     $_ = $software_hive->value_string ($_);
751                     $r->{product_name} = $_ if defined $_;
752                 } elsif ($k eq "CurrentVersion") {
753                     $_ = $software_hive->value_string ($_);
754                     if (defined $_ && m/^(\d+)\.(\d+)/) {
755                         $r->{os_major_version} = $1;
756                         $r->{os_minor_version} = $2;
757                     }
758                 } elsif ($k eq "CurrentBuild") {
759                     $_ = $software_hive->value_string ($_);
760                     $r->{windows_current_build} = $_ if defined $_;
761                 } elsif ($k eq "SoftwareType") {
762                     $_ = $software_hive->value_string ($_);
763                     $r->{windows_software_type} = $_ if defined $_;
764                 } elsif ($k eq "CurrentType") {
765                     $_ = $software_hive->value_string ($_);
766                     $r->{windows_current_type} = $_ if defined $_;
767                 } elsif ($k eq "RegisteredOwner") {
768                     $_ = $software_hive->value_string ($_);
769                     $r->{windows_registered_owner} = $_ if defined $_;
770                 } elsif ($k eq "RegisteredOrganization") {
771                     $_ = $software_hive->value_string ($_);
772                     $r->{windows_registered_organization} = $_ if defined $_;
773                 } elsif ($k eq "InstallationType") {
774                     $_ = $software_hive->value_string ($_);
775                     $r->{windows_installation_type} = $_ if defined $_;
776                 } elsif ($k eq "EditionID") {
777                     $_ = $software_hive->value_string ($_);
778                     $r->{windows_edition_id} = $_ if defined $_;
779                 } elsif ($k eq "ProductID") {
780                     $_ = $software_hive->value_string ($_);
781                     $r->{windows_product_id} = $_ if defined $_;
782                 }
783             }
784         }
785     }
786 }
787
788 sub _check_grub
789 {
790     local $_;
791     my $g = shift;
792     my $r = shift;
793
794     # Grub version, if we care.
795 }
796
797 =head2 inspect_operating_systems
798
799 This function is deprecated.  It will not be updated in future
800 versions of libguestfs.  New code should not use this function.  Use
801 the core API functions instead, see L<guestfs(3)/INSPECTION>.
802
803 =cut
804
805 sub inspect_operating_systems
806 {
807     local $_;
808     my $g = shift;
809     my $fses = shift;
810
811     my %oses = ();
812
813     foreach (sort keys %$fses) {
814         if ($fses->{$_}->{is_root}) {
815             my %r = (
816                 root => $fses->{$_},
817                 root_device => $_
818                 );
819             _get_os_version ($g, \%r);
820             _assign_mount_points ($g, $fses, \%r);
821             $oses{$_} = \%r;
822         }
823     }
824
825     # If we didn't find any operating systems then it's an error (RHBZ#591142).
826     if (0 == keys %oses) {
827         die __"No operating system could be detected inside this disk image.\n\nThis may be because the file is not a disk image, or is not a virtual machine\nimage, or because the OS type is not understood by virt-inspector.\n\nIf you feel this is an error, please file a bug report including as much\ninformation about the disk image as possible.\n";
828     }
829
830     return \%oses;
831 }
832
833 sub _get_os_version
834 {
835     local $_;
836     my $g = shift;
837     my $r = shift;
838
839     $r->{os} = $r->{root}->{fsos} if exists $r->{root}->{fsos};
840     $r->{product_name} = $r->{root}->{product_name}
841         if exists $r->{root}->{product_name};
842     $r->{distro} = $r->{root}->{osdistro} if exists $r->{root}->{osdistro};
843     $r->{major_version} = $r->{root}->{os_major_version}
844         if exists $r->{root}->{os_major_version};
845     $r->{minor_version} = $r->{root}->{os_minor_version}
846         if exists $r->{root}->{os_minor_version};
847     $r->{package_format} = $r->{root}->{package_format}
848         if exists $r->{root}->{package_format};
849     $r->{package_management} = $r->{root}->{package_management}
850         if exists $r->{root}->{package_management};
851     $r->{arch} = $r->{root}->{arch} if exists $r->{root}->{arch};
852 }
853
854 sub _assign_mount_points
855 {
856     local $_;
857     my $g = shift;
858     my $fses = shift;
859     my $r = shift;
860
861     $r->{mounts} = { "/" => $r->{root_device} };
862     $r->{filesystems} = { $r->{root_device} => $r->{root} };
863
864     # Use /etc/fstab if we have it to mount the rest.
865     if (exists $r->{root}->{fstab}) {
866         my @fstab = @{$r->{root}->{fstab}};
867         foreach (@fstab) {
868             my ($spec, $file) = @$_;
869
870             my ($dev, $fs) = _find_filesystem ($g, $fses, $spec, $file);
871             if ($dev) {
872                 $r->{mounts}->{$file} = $dev;
873                 $r->{filesystems}->{$dev} = $fs;
874                 if (exists $fs->{used}) {
875                     $fs->{used}++
876                 } else {
877                     $fs->{used} = 1
878                 }
879                 $fs->{spec} = $spec;
880             }
881         }
882     }
883 }
884
885 # Find filesystem by device name, LABEL=.. or UUID=..
886 sub _find_filesystem
887 {
888     my $g = shift;
889     my $fses = shift;
890     local $_ = shift;
891     my $file = shift;
892
893     if (/^LABEL=(.*)/) {
894         my $label = $1;
895         foreach (sort keys %$fses) {
896             if (exists $fses->{$_}->{label} &&
897                 $fses->{$_}->{label} =~ /$label/i) {
898                 return ($_, $fses->{$_});
899             }
900         }
901         warn __x("unknown filesystem label {label}\n", label => $label);
902         return ();
903     } elsif (/^UUID=(.*)/) {
904         my $uuid = $1;
905         foreach (sort keys %$fses) {
906             if (exists $fses->{$_}->{uuid} &&
907                 $fses->{$_}->{uuid} eq $uuid) {
908                 return ($_, $fses->{$_});
909             }
910         }
911         warn __x("unknown filesystem UUID {uuid}\n", uuid => $uuid);
912         return ();
913     } else {
914         return ($_, $fses->{$_}) if exists $fses->{$_};
915
916         # The following is to handle the case where an fstab entry specifies a
917         # specific device rather than its label or uuid, and the libguestfs
918         # appliance has named the device differently due to the use of a
919         # different driver.
920         # This will work as long as the underlying drivers recognise devices in
921         # the same order.
922         if (m{^/dev/hd(.*)} && exists $fses->{"/dev/sd$1"}) {
923             return ("/dev/sd$1", $fses->{"/dev/sd$1"});
924         }
925         if (m{^/dev/xvd(.*)} && exists $fses->{"/dev/sd$1"}) {
926             return ("/dev/sd$1", $fses->{"/dev/sd$1"});
927         }
928         if (m{^/dev/mapper/(.*)-(.*)$} && exists $fses->{"/dev/$1/$2"}) {
929             return ("/dev/$1/$2", $fses->{"/dev/$1/$2"});
930         }
931
932         return () if $file =~ (/media\/cdrom/);
933         return () if m{/dev/cdrom};
934         return () if m{/dev/fd0};
935
936         warn __x("unknown filesystem {fs}\n", fs => $_);
937         return ();
938     }
939 }
940
941 =head2 mount_operating_system
942
943 This function is deprecated.  It will not be updated in future
944 versions of libguestfs.  New code should not use this function.  Use
945 the core API functions instead, see L<guestfs(3)/INSPECTION>.
946
947 =cut
948
949 sub mount_operating_system
950 {
951     local $_;
952     my $g = shift;
953     my $os = shift;
954     my $ro = shift;             # Read-only?
955
956     $ro = 1 unless defined $ro; # ro defaults to 1 if unspecified
957
958     my $mounts = $os->{mounts};
959
960     # Have to mount / first.  Luckily '/' is early in the ASCII
961     # character set, so this should be OK.
962     foreach (sort keys %$mounts) {
963         if($_ ne "swap" && $_ ne "none" && ($_ eq '/' || $g->is_dir ($_))) {
964             if($ro) {
965                 $g->mount_ro ($mounts->{$_}, $_)
966             } else {
967                 $g->mount_options ("", $mounts->{$_}, $_)
968             }
969         }
970     }
971 }
972
973 =head2 inspect_in_detail
974
975 This function is deprecated.  It will not be updated in future
976 versions of libguestfs.  New code should not use this function.  Use
977 the core API functions instead, see L<guestfs(3)/INSPECTION>.
978
979 =cut
980
981 sub inspect_in_detail
982 {
983     local $_;
984     my $g = shift;
985     my $os = shift;
986
987     _check_for_applications ($g, $os);
988     _check_for_kernels ($g, $os);
989     if ($os->{os} eq "linux") {
990         _find_modprobe_aliases ($g, $os);
991     }
992 }
993
994 sub _check_for_applications
995 {
996     local $_;
997     my $g = shift;
998     my $os = shift;
999
1000     my @apps;
1001
1002     my $osn = $os->{os};
1003     if ($osn eq "linux") {
1004         my $package_format = $os->{package_format};
1005         if (defined $package_format && $package_format eq "rpm") {
1006             my @lines = ();
1007             eval {
1008                 @lines = $g->command_lines
1009                     (["rpm",
1010                       "-q", "-a", "--qf",
1011                       "%{name} %{epoch} %{version} %{release} %{arch}\n"]);
1012             };
1013
1014             warn(__x("Error running rpm -qa: {error}", error => $@)) if ($@);
1015
1016             @lines = sort @lines;
1017             foreach (@lines) {
1018                 if (m/^(.*) (.*) (.*) (.*) (.*)$/) {
1019                     my $epoch = $2;
1020                     undef $epoch if $epoch eq "(none)";
1021                     my $app = {
1022                         name => $1,
1023                         epoch => $epoch,
1024                         version => $3,
1025                         release => $4,
1026                         arch => $5
1027                     };
1028                     push @apps, $app
1029                 }
1030             }
1031         } elsif (defined $package_format && $package_format eq "deb") {
1032             my @lines = ();
1033             eval {
1034                 @lines = $g->command_lines
1035                     (["dpkg-query",
1036                       "-f", '${Package} ${Version} ${Architecture} ${Status}\n',
1037                       "-W"]);
1038             };
1039
1040             warn(__x("Error running dpkg-query: {error}", error => $@)) if ($@);
1041
1042             @lines = sort @lines;
1043             foreach (@lines) {
1044                 if (m/^(.*) (.*) (.*) (.*) (.*) (.*)$/) {
1045                     if ( $6 eq "installed" ) {
1046                         my $app = {
1047                             name => $1,
1048                             version => $2,
1049                             arch => $3
1050                         };
1051                         push @apps, $app
1052                     }
1053                 }
1054             }
1055         }
1056     } elsif ($osn eq "windows") {
1057         # XXX
1058         # I worked out a general plan for this, but haven't
1059         # implemented it yet.  We can iterate over /Program Files
1060         # looking for *.EXE files, which we download, then use
1061         # i686-pc-mingw32-windres on, to find the VERSIONINFO
1062         # section, which has a lot of useful information.
1063     }
1064
1065     $os->{apps} = \@apps;
1066 }
1067
1068 # Find the path which needs to be prepended to paths in grub.conf to make them
1069 # absolute
1070 sub _find_grub_prefix
1071 {
1072     my ($g, $os) = @_;
1073
1074     my $fses = $os->{filesystems};
1075     die("filesystems undefined") unless(defined($fses));
1076
1077     # Look for the filesystem which contains grub
1078     my $grubdev;
1079     foreach my $dev (keys(%$fses)) {
1080         my $fsinfo = $fses->{$dev};
1081         if(exists($fsinfo->{content}) && $fsinfo->{content} eq "linux-grub") {
1082             $grubdev = $dev;
1083             last;
1084         }
1085     }
1086
1087     my $mounts = $os->{mounts};
1088     die("mounts undefined") unless(defined($mounts));
1089
1090     # Find where the filesystem is mounted
1091     if(defined($grubdev)) {
1092         foreach my $mount (keys(%$mounts)) {
1093             if($mounts->{$mount} eq $grubdev) {
1094                 return "" if($mount eq '/');
1095                 return $mount;
1096             }
1097         }
1098
1099         die("$grubdev defined in filesystems, but not in mounts");
1100     }
1101
1102     # If we didn't find it, look for /boot/grub/menu.lst, then try to work out
1103     # what filesystem it's on. We use menu.lst rather than grub.conf because
1104     # debian only uses menu.lst, and anaconda creates a symlink for it.
1105     die(__"Can't find grub on guest") unless($g->exists('/boot/grub/menu.lst'));
1106
1107     # Look for the most specific mount point in mounts
1108     foreach my $path qw(/boot/grub /boot /) {
1109         if(exists($mounts->{$path})) {
1110             return "" if($path eq '/');
1111             return $path;
1112         }
1113     }
1114
1115     die("Couldn't determine which filesystem holds /boot/grub/menu.lst");
1116 }
1117
1118 sub _check_for_kernels
1119 {
1120     my ($g, $os) = @_;
1121
1122     if ($os->{os} eq "linux" && feature_available ($g, "augeas")) {
1123         # Iterate over entries in grub.conf, populating $os->{boot}
1124         # For every kernel we find, inspect it and add to $os->{kernels}
1125
1126         my $grub = _find_grub_prefix($g, $os);
1127         my $grub_conf = "/etc/grub.conf";
1128
1129         # Debian and other's have no /etc/grub.conf:
1130         if ( ! -f "$grub_conf" ) {
1131             $grub_conf = "$grub/grub/menu.lst";
1132         }
1133
1134         my @boot_configs;
1135
1136         # We want
1137         #  $os->{boot}
1138         #       ->{configs}
1139         #         ->[0]
1140         #           ->{title}   = "Fedora (2.6.29.6-213.fc11.i686.PAE)"
1141         #           ->{kernel}  = \kernel
1142         #           ->{cmdline} = "ro root=/dev/mapper/vg_mbooth-lv_root rhgb"
1143         #           ->{initrd}  = \initrd
1144         #       ->{default} = \config
1145         #       ->{grub_fs} = "/boot"
1146         # Initialise augeas
1147         $g->aug_init("/", 16);
1148
1149         my @configs = ();
1150         # Get all configurations from grub
1151         foreach my $bootable
1152             ($g->aug_match("/files/$grub_conf/title"))
1153         {
1154             my %config = ();
1155             $config{title} = $g->aug_get($bootable);
1156
1157             my $grub_kernel;
1158             eval { $grub_kernel = $g->aug_get("$bootable/kernel"); };
1159             if($@) {
1160                 warn __x("Grub entry {title} has no kernel",
1161                          title => $config{title});
1162             }
1163
1164             # Check we've got a kernel entry
1165             if(defined($grub_kernel)) {
1166                 my $path = "$grub$grub_kernel";
1167
1168                 # Reconstruct the kernel command line
1169                 my @args = ();
1170                 foreach my $arg ($g->aug_match("$bootable/kernel/*")) {
1171                     $arg =~ m{/kernel/([^/]*)$}
1172                         or die("Unexpected return from aug_match: $arg");
1173
1174                     my $name = $1;
1175                     my $value;
1176                     eval { $value = $g->aug_get($arg); };
1177
1178                     if(defined($value)) {
1179                         push(@args, "$name=$value");
1180                     } else {
1181                         push(@args, $name);
1182                     }
1183                 }
1184                 $config{cmdline} = join(' ', @args) if(scalar(@args) > 0);
1185
1186                 my $kernel;
1187                 if ($g->exists($path)) {
1188                     $kernel =
1189                         inspect_linux_kernel($g, $path, $os->{package_format});
1190                 } else {
1191                     warn __x("grub refers to {path}, which doesn't exist\n",
1192                              path => $path);
1193                 }
1194
1195                 # Check the kernel was recognised
1196                 if(defined($kernel)) {
1197                     # Put this kernel on the top level kernel list
1198                     $os->{kernels} ||= [];
1199                     push(@{$os->{kernels}}, $kernel);
1200
1201                     $config{kernel} = $kernel;
1202
1203                     # Look for an initrd entry
1204                     my $initrd;
1205                     eval {
1206                         $initrd = $g->aug_get("$bootable/initrd");
1207                     };
1208
1209                     unless($@) {
1210                         $config{initrd} =
1211                             _inspect_initrd($g, $os, "$grub$initrd",
1212                                             $kernel->{version});
1213                     } else {
1214                         warn __x("Grub entry {title} does not specify an ".
1215                                  "initrd", title => $config{title});
1216                     }
1217                 }
1218             }
1219
1220             push(@configs, \%config);
1221         }
1222
1223
1224         # Create the top level boot entry
1225         my %boot;
1226         $boot{configs} = \@configs;
1227         $boot{grub_fs} = $grub;
1228
1229         # Add the default configuration
1230         eval {
1231             $boot{default} = $g->aug_get("/files/$grub_conf/default");
1232         };
1233
1234         $os->{boot} = \%boot;
1235     }
1236
1237     elsif ($os->{os} eq "windows") {
1238         # XXX
1239     }
1240 }
1241
1242 =head2 inspect_linux_kernel
1243
1244 This function is deprecated.  It will not be updated in future
1245 versions of libguestfs.  New code should not use this function.  Use
1246 the core API functions instead, see L<guestfs(3)/INSPECTION>.
1247
1248 =cut
1249
1250 sub inspect_linux_kernel
1251 {
1252     my ($g, $path, $package_format) = @_;
1253
1254     my %kernel = ();
1255
1256     $kernel{path} = $path;
1257
1258     # If this is a packaged kernel, try to work out the name of the package
1259     # which installed it. This lets us know what to install to replace it with,
1260     # e.g. kernel, kernel-smp, kernel-hugemem, kernel-PAE
1261     if($package_format eq "rpm") {
1262         my $package;
1263         eval { $package = $g->command(['rpm', '-qf', '--qf',
1264                                        '%{NAME}', $path]); };
1265         $kernel{package} = $package if defined($package);;
1266     }
1267
1268     # Try to get the kernel version by running file against it
1269     my $version;
1270     my $filedesc = $g->file($path);
1271     if($filedesc =~ /^$path: Linux kernel .*\bversion\s+(\S+)\b/) {
1272         $version = $1;
1273     }
1274
1275     # Sometimes file can't work out the kernel version, for example because it's
1276     # a Xen PV kernel. In this case try to guess the version from the filename
1277     else {
1278         if($path =~ m{/boot/vmlinuz-(.*)}) {
1279             $version = $1;
1280
1281             # Check /lib/modules/$version exists
1282             if(!$g->is_dir("/lib/modules/$version")) {
1283                 warn __x("Didn't find modules directory {modules} for kernel ".
1284                          "{path}", modules => "/lib/modules/$version",
1285                          path => $path);
1286
1287                 # Give up
1288                 return undef;
1289             }
1290         } else {
1291             warn __x("Couldn't guess kernel version number from path for ".
1292                      "kernel {path}", path => $path);
1293
1294             # Give up
1295             return undef;
1296         }
1297     }
1298
1299     $kernel{version} = $version;
1300
1301     # List modules.
1302     my @modules;
1303     my $any_module;
1304     my $prefix = "/lib/modules/$version";
1305     foreach my $module ($g->find ($prefix)) {
1306         if ($module =~ m{/([^/]+)\.(?:ko|o)$}) {
1307             $any_module = "$prefix$module" unless defined $any_module;
1308             push @modules, $1;
1309         }
1310     }
1311
1312     $kernel{modules} = \@modules;
1313
1314     # Determine kernel architecture by looking at the arch
1315     # of any kernel module.
1316     $kernel{arch} = file_architecture ($g, $any_module);
1317
1318     return \%kernel;
1319 }
1320
1321 # Find all modprobe aliases. Specifically, this looks in the following
1322 # locations:
1323 #  * /etc/conf.modules
1324 #  * /etc/modules.conf
1325 #  * /etc/modprobe.conf
1326 #  * /etc/modprobe.d/*
1327
1328 sub _find_modprobe_aliases
1329 {
1330     local $_;
1331     my $g = shift;
1332     my $os = shift;
1333
1334     # Initialise augeas
1335     $g->aug_init("/", 16);
1336
1337     my %modprobe_aliases;
1338
1339     for my $pattern qw(/files/etc/conf.modules/alias
1340                        /files/etc/modules.conf/alias
1341                        /files/etc/modprobe.conf/alias
1342                        /files/etc/modprobe.d/*/alias) {
1343         for my $path ( $g->aug_match($pattern) ) {
1344             $path =~ m{^/files(.*)/alias(?:\[\d*\])?$}
1345                 or die __x("{path} doesn't match augeas pattern",
1346                            path => $path);
1347             my $file = $1;
1348
1349             my $alias;
1350             $alias = $g->aug_get($path);
1351
1352             my $modulename;
1353             $modulename = $g->aug_get($path.'/modulename');
1354
1355             my %aliasinfo;
1356             $aliasinfo{modulename} = $modulename;
1357             $aliasinfo{augeas} = $path;
1358             $aliasinfo{file} = $file;
1359
1360             $modprobe_aliases{$alias} = \%aliasinfo;
1361         }
1362     }
1363
1364     $os->{modprobe_aliases} = \%modprobe_aliases;
1365 }
1366
1367 # Get a listing of device drivers from an initrd
1368 sub _inspect_initrd
1369 {
1370     my ($g, $os, $path, $version) = @_;
1371
1372     my @modules;
1373
1374     # Disregard old-style compressed ext2 files and only work with real
1375     # compressed cpio files, since cpio takes ages to (fail to) process anything
1376     # else.
1377     if ($g->exists($path) && $g->file($path) =~ /cpio/) {
1378         eval {
1379             @modules = $g->initrd_list ($path);
1380         };
1381         unless ($@) {
1382             @modules = grep { m{([^/]+)\.(?:ko|o)$} } @modules;
1383         } else {
1384             warn __x("{filename}: could not read initrd format",
1385                      filename => "$path");
1386         }
1387     }
1388
1389     # Add to the top level initrd_modules entry
1390     $os->{initrd_modules} ||= {};
1391     $os->{initrd_modules}->{$version} = \@modules;
1392
1393     return \@modules;
1394 }
1395
1396 1;
1397
1398 =head1 COPYRIGHT
1399
1400 Copyright (C) 2009-2010 Red Hat Inc.
1401
1402 =head1 LICENSE
1403
1404 Please see the file COPYING.LIB for the full license.
1405
1406 =head1 SEE ALSO
1407
1408 L<virt-inspector(1)>,
1409 L<Sys::Guestfs(3)>,
1410 L<guestfs(3)>,
1411 L<http://libguestfs.org/>,
1412 L<Sys::Virt(3)>,
1413 L<http://libvirt.org/>,
1414 L<guestfish(1)>.
1415
1416 =cut