mirror of
https://github.com/libguestfs/libguestfs.git
synced 2026-03-22 07:03:38 +00:00
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.
160 lines
5.2 KiB
OCaml
160 lines
5.2 KiB
OCaml
(* 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_"don’t 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_"don’t 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_"don’t 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
|