X-Git-Url: http://git.annexia.org/?p=libguestfs.git;a=blobdiff_plain;f=perl%2Flib%2FSys%2FGuestfs%2FLib.pm;h=e8796ad320af5330449d4c23aa3d048d516c0fe0;hp=89f2aa67100779b649c4b5f08a4a08546f48e272;hb=de33cc91ee93f85f06b9976fdc5454c0eb851b8e;hpb=da90c9d8761caced81b9cf7d6e41180afa53ecb9 diff --git a/perl/lib/Sys/Guestfs/Lib.pm b/perl/lib/Sys/Guestfs/Lib.pm index 89f2aa6..e8796ad 100644 --- a/perl/lib/Sys/Guestfs/Lib.pm +++ b/perl/lib/Sys/Guestfs/Lib.pm @@ -64,9 +64,11 @@ require Exporter; use vars qw(@EXPORT_OK @ISA); @ISA = qw(Exporter); -@EXPORT_OK = qw(open_guest get_partitions resolve_windows_path +@EXPORT_OK = qw(open_guest feature_available + get_partitions resolve_windows_path inspect_all_partitions inspect_partition - inspect_operating_systems mount_operating_system inspect_in_detail); + inspect_operating_systems mount_operating_system inspect_in_detail + inspect_linux_kernel); =head2 open_guest @@ -99,11 +101,10 @@ read-write handle, this function will refuse to use active libvirt domains. The handle is still in the config state when it is returned, so you -have to call C<$g-Elaunch ()> and C<$g-Ewait_ready>. +have to call C<$g-Elaunch ()>. The optional C
parameter can be added to specify the libvirt -URI. In addition, L lists other parameters which are -passed through to Cnew> unchanged. +URI. The implicit libvirt handle is closed after this function, I you call the function in C context, in which case the @@ -116,6 +117,10 @@ disk image, then C<$conn> and C<$dom> will be C. If the C module is not available, then libvirt is bypassed, and this function can only open disk images. +The optional C parameter can be used to open devices with +C. See +L for more details. + =cut sub open_guest @@ -124,7 +129,9 @@ sub open_guest my $first = shift; my %params = @_; - my $readwrite = $params{rw}; + my $rw = $params{rw}; + my $address = $params{address}; + my $interface = $params{interface}; my @images = (); if (ref ($first) eq "ARRAY") { @@ -152,12 +159,15 @@ sub open_guest die __"open_guest: too many domains listed on command line" if @images > 1; - $conn = Sys::Virt->new (readonly => 1, @_); + my @libvirt_args = (); + push @libvirt_args, address => $address if defined $address; + + $conn = Sys::Virt->new (readonly => 1, @libvirt_args); die __"open_guest: cannot connect to libvirt" unless $conn; my @doms = $conn->list_defined_domains (); my $isitinactive = 1; - unless ($readwrite) { + unless ($rw) { # In the case where we want read-only access to a domain, # allow the user to specify an active domain too. push @doms, $conn->list_domains (); @@ -197,16 +207,48 @@ sub open_guest # We've now got the list of @images, so feed them to libguestfs. my $g = Sys::Guestfs->new (); foreach (@images) { - if ($readwrite) { - $g->add_drive ($_); + if ($rw) { + if ($interface) { + $g->add_drive_with_if ($_, $interface); + } else { + $g->add_drive ($_); + } } else { - $g->add_drive_ro ($_); + if ($interface) { + $g->add_drive_ro_with_if ($_, $interface); + } else { + $g->add_drive_ro ($_); + } } } return wantarray ? ($g, $conn, $dom, @images) : $g } +=head2 feature_available + + $bool = feature_available ($g, $feature [, $feature ...]); + +This function is a useful wrapper around the basic +C<$g-Eavailable> call. + +C<$g-Eavailable> tests for availability of a list of features and +dies with an error if any is not available. + +This call tests for the list of features and returns true if all are +available, or false otherwise. + +For a list of features you can test for, see L. + +=cut + +sub feature_available { + my $g = shift; + + eval { $g->available (\@_); }; + return $@ ? 0 : 1; +} + =head2 get_partitions @partitions = get_partitions ($g); @@ -229,7 +271,8 @@ sub get_partitions my @pvs = $g->pvs (); @partitions = grep { ! _is_pv ($_, @pvs) } @partitions; - my @lvs = $g->lvs (); + my @lvs; + @lvs = $g->lvs () if feature_available ($g, "lvm2"); return sort (@lvs, @partitions); } @@ -266,38 +309,12 @@ by C characters. Do not use C<\>, drive names, etc. sub resolve_windows_path { - local $_; my $g = shift; my $path = shift; - if (substr ($path, 0, 1) ne "/") { - warn __"resolve_windows_path: path must start with a / character"; - return undef; - } - - my @elems = split (/\//, $path); - shift @elems; - - # Start reconstructing the path at the top. - $path = "/"; - - foreach my $dir (@elems) { - my $found = 0; - foreach ($g->ls ($path)) { - if (lc ($_) eq lc ($dir)) { - if ($path eq "/") { - $path = "/$_"; - $found = 1; - } else { - $path = "$path/$_"; - $found = 1; - } - } - } - return undef unless $found; - } - - return $path; + my $r; + eval { $r = $g->case_sensitive_path ($path); }; + return $r; } =head2 file_architecture @@ -568,13 +585,23 @@ C flag are explained below. =cut +# Turn /dev/vd* and /dev/hd* into canonical device names +# (see BLOCK DEVICE NAMING in guestfs(3)). + +sub _canonical_dev ($) +{ + my ($dev) = @_; + return "/dev/sd$1" if $dev =~ m{^/dev/[vh]d(\w+)}; + return $dev; +} + sub inspect_all_partitions { local $_; my $g = shift; my $parts = shift; my @parts = @$parts; - return map { $_ => inspect_partition ($g, $_, @_) } @parts; + return map { _canonical_dev ($_) => inspect_partition ($g, $_, @_) } @parts; } =head2 inspect_partition @@ -638,7 +665,7 @@ Operating system distribution. One of: "fedora", "rhel", "centos", =item package_format (For Linux root partitions only) -The package format used by the guest distribution. One of: "rpm", "dpkg". +The package format used by the guest distribution. One of: "rpm", "deb". =item package_management @@ -842,7 +869,7 @@ sub _check_linux_root $r->{osdistro} = "redhat-based"; } } elsif ($g->is_file ("/etc/debian_version")) { - $r->{package_format} = "dpkg"; + $r->{package_format} = "deb"; $r->{package_management} = "apt"; $_ = $g->cat ("/etc/debian_version"); @@ -1271,7 +1298,7 @@ sub mount_operating_system if($ro) { $g->mount_ro ($mounts->{$_}, $_) } else { - $g->mount ($mounts->{$_}, $_) + $g->mount_options ("", $mounts->{$_}, $_) } } } @@ -1330,7 +1357,11 @@ The kernel command line. =item default -The index of the default configuration in the configs array +The index of the default configuration in the configs array. + +=item grub_fs + +The path of the filesystem containing the grub partition. =back @@ -1411,7 +1442,7 @@ sub _check_for_applications foreach (@lines) { if (m/^(.*) (.*) (.*) (.*) (.*)$/) { my $epoch = $2; - $epoch = "" if $epoch eq "(none)"; + undef $epoch if $epoch eq "(none)"; my $app = { name => $1, epoch => $epoch, @@ -1422,6 +1453,23 @@ sub _check_for_applications push @apps, $app } } + } elsif (defined $package_format && $package_format eq "deb") { + my @lines = $g->command_lines + (["dpkg-query", + "-f", '${Package} ${Version} ${Architecture} ${Status}\n', + "-W"]); + foreach (@lines) { + if (m/^(.*) (.*) (.*) (.*) (.*) (.*)$/) { + if ( $6 eq "installed" ) { + my $app = { + name => $1, + version => $2, + arch => $3 + }; + push @apps, $app + } + } + } } } elsif ($osn eq "windows") { # XXX @@ -1489,11 +1537,17 @@ sub _check_for_kernels { my ($g, $os) = @_; - if ($os->{os} eq "linux") { + if ($os->{os} eq "linux" && feature_available ($g, "augeas")) { # Iterate over entries in grub.conf, populating $os->{boot} # For every kernel we find, inspect it and add to $os->{kernels} my $grub = _find_grub_prefix($g, $os); + my $grub_conf = "/etc/grub.conf"; + + # Debian and other's have no /etc/grub.conf: + if ( ! -f "$grub_conf" ) { + $grub_conf = "$grub/grub/menu.lst"; + } my @boot_configs; @@ -1506,13 +1560,14 @@ sub _check_for_kernels # ->{cmdline} = "ro root=/dev/mapper/vg_mbooth-lv_root rhgb" # ->{initrd} = \initrd # ->{default} = \config + # ->{grub_fs} = "/boot" # Initialise augeas $g->aug_init("/", 16); my @configs = (); # Get all configurations from grub foreach my $bootable - ($g->aug_match("/files/etc/grub.conf/title")) + ($g->aug_match("/files/$grub_conf/title")) { my %config = (); $config{title} = $g->aug_get($bootable); @@ -1546,10 +1601,15 @@ sub _check_for_kernels } $config{cmdline} = join(' ', @args) if(scalar(@args) > 0); - my $kernel = _inspect_linux_kernel($g, $os, "$path"); + my $kernel = + inspect_linux_kernel($g, $path, $os->{package_format}); # Check the kernel was recognised if(defined($kernel)) { + # Put this kernel on the top level kernel list + $os->{kernels} ||= []; + push(@{$os->{kernels}}, $kernel); + $config{kernel} = $kernel; # Look for an initrd entry @@ -1576,10 +1636,11 @@ sub _check_for_kernels # Create the top level boot entry my %boot; $boot{configs} = \@configs; + $boot{grub_fs} = $grub; # Add the default configuration eval { - $boot{default} = $g->aug_get("/files/etc/grub.conf/default"); + $boot{default} = $g->aug_get("/files/$grub_conf/default"); }; if($@) { warn __"No grub default specified"; @@ -1593,9 +1654,19 @@ sub _check_for_kernels } } -sub _inspect_linux_kernel +=head2 inspect_linux_kernel + + my $kernel_hash = inspect_linux_kernel($g, $vmlinuz_path, $package_format); + +inspect_linux_kernel returns a hash describing the target linux kernel. For the +contents of the hash, see the I structure described under +L. + +=cut + +sub inspect_linux_kernel { - my ($g, $os, $path) = @_; + my ($g, $path, $package_format) = @_; my %kernel = (); @@ -1604,7 +1675,7 @@ sub _inspect_linux_kernel # If this is a packaged kernel, try to work out the name of the package # which installed it. This lets us know what to install to replace it with, # e.g. kernel, kernel-smp, kernel-hugemem, kernel-PAE - if($os->{package_format} eq "rpm") { + if($package_format eq "rpm") { my $package; eval { $package = $g->command(['rpm', '-qf', '--qf', '%{NAME}', $path]); }; @@ -1661,14 +1732,6 @@ sub _inspect_linux_kernel # of any kernel module. $kernel{arch} = file_architecture ($g, $any_module); - # Put this kernel on the top level kernel list - my $kernels = $os->{kernels}; - if(!defined($kernels)) { - $kernels = []; - $os->{kernels} = $kernels; - } - push(@$kernels, \%kernel); - return \%kernel; } @@ -1748,13 +1811,8 @@ sub _inspect_initrd } # Add to the top level initrd_modules entry - my $initrd_modules = $os->{initrd_modules}; - if(!defined($initrd_modules)) { - $initrd_modules = {}; - $os->{initrd_modules} = $initrd_modules; - } - - $initrd_modules->{$version} = \@modules; + $os->{initrd_modules} ||= {}; + $os->{initrd_modules}->{$version} = \@modules; return \@modules; }