Files
libguestfs/v2v/linux.ml
Richard W.M. Jones 61d4891ef4 mllib: Split ‘Common_utils’ into ‘Std_utils’ + ‘Common_utils’.
The new module ‘Std_utils’ contains only functions which are pure
OCaml and depend only on the OCaml stdlib.  Therefore these functions
may be used by the generator.

The new module is moved to ‘common/mlstdutils’.

This also removes the "<stdlib>" hack, and the code which copied the
library around.

Also ‘Guestfs_config’, ‘Libdir’ and ‘StringMap’ modules are moved
since these are essentially the same.

The bulk of this change is just updating files which use
‘open Common_utils’ to add ‘open Std_utils’ where necessary.
2017-07-10 17:01:59 +01:00

160 lines
5.2 KiB
OCaml
Raw Blame History

This file contains ambiguous Unicode characters
This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
(* virt-v2v
* Copyright (C) 2009-2017 Red Hat Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License along
* with this program; if not, write to the Free Software Foundation, Inc.,
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
*)
open Printf
open Std_utils
open Common_utils
open Common_gettext.Gettext
open Types
open Utils
module G = Guestfs
(* Wrappers around aug_init & aug_load which can dump out full Augeas
* parsing problems when debugging is enabled.
*)
let rec augeas_init g =
g#aug_init "/" 1;
debug_augeas_errors g
and augeas_reload g =
g#aug_load ();
debug_augeas_errors g
let rec remove g inspect packages =
if packages <> [] then (
do_remove g inspect packages;
(* Reload Augeas in case anything changed. *)
augeas_reload g
)
and do_remove g { i_package_format = package_format } packages =
assert (List.length packages > 0);
match package_format with
| "deb" ->
let cmd = [ "dpkg"; "--purge" ] @ packages in
let cmd = Array.of_list cmd in
ignore (g#command cmd);
| "rpm" ->
let cmd = [ "rpm"; "-e" ] @ packages in
let cmd = Array.of_list cmd in
ignore (g#command cmd)
| format ->
error (f_"dont know how to remove packages using %s: packages: %s")
format (String.concat " " packages)
let file_list_of_package (g : Guestfs.guestfs) inspect app =
match inspect.i_package_format with
| "deb" ->
let cmd = [| "dpkg"; "-L"; app.G.app2_name |] in
debug "%s" (String.concat " " (Array.to_list cmd));
let files = g#command_lines cmd in
let files = Array.to_list files in
List.sort compare files
| "rpm" ->
(* Since RPM allows multiple packages installed with the same
* name, always check the full ENVR here (RHBZ#1161250).
*)
let pkg_name =
sprintf "%s-%s-%s" app.G.app2_name
app.G.app2_version app.G.app2_release in
let pkg_name =
if app.G.app2_epoch > 0_l then (
(* RHEL 3/4 'rpm' does not support using the epoch prefix.
* (RHBZ#1170685).
*)
let is_rhel_lt_5 =
match inspect with
| { i_type = "linux";
i_distro = "rhel" | "centos" | "scientificlinux" |
"redhat-based";
i_major_version = v } when v < 5 -> true
| _ -> false in
if is_rhel_lt_5 then
pkg_name
else
sprintf "%ld:%s" app.G.app2_epoch pkg_name
) else
pkg_name in
let cmd = [| "rpm"; "-ql"; pkg_name |] in
debug "%s" (String.concat " " (Array.to_list cmd));
let files = g#command_lines cmd in
let files = Array.to_list files in
List.sort compare files
| format ->
error (f_"dont know how to get list of files from package using %s")
format
let rec file_owner (g : G.guestfs) { i_package_format = package_format } path =
match package_format with
| "deb" ->
(* With dpkg usually the directories are owned by all the packages
* that install anything in them. Also with multiarch the same
* package is allowed (although with different architectures).
* This function returns only one package in all the cases.
*)
let cmd = [| "dpkg"; "-S"; path |] in
debug "%s" (String.concat " " (Array.to_list cmd));
let lines =
try g#command_lines cmd
with Guestfs.Error msg as exn ->
if String.find msg "no path found matching pattern" >= 0 then
raise Not_found
else
raise exn in
if Array.length lines = 0 then
error (f_"internal error: file_owner: dpkg command returned no output");
let line = lines.(0) in
let line =
try String.sub line 0 (String.rindex line ':')
with Invalid_argument _ ->
error (f_"internal error: file_owner: invalid dpkg output: %s")
line in
fst (String.split "," line)
| "rpm" ->
(* Although it is possible in RPM for multiple packages to own
* a file, this deliberately only returns one package.
*)
let cmd = [| "rpm"; "-qf"; "--qf"; "%{NAME}\\n"; path |] in
debug "%s" (String.concat " " (Array.to_list cmd));
(try
let pkgs = g#command_lines cmd in
pkgs.(0)
with Guestfs.Error msg as exn ->
if String.find msg "is not owned" >= 0 then
raise Not_found
else
raise exn
| Invalid_argument _ (* pkgs.(0) raises index out of bounds *) ->
error (f_"internal error: file_owner: rpm command returned no output")
)
| format ->
error (f_"dont know how to find file owner using %s") format
and is_file_owned g inspect path =
try ignore (file_owner g inspect path); true
with Not_found -> false