[Libguestfs] [PATCH 2/5] mllib: add an helper shell_command
Pino Toscano
ptoscano at redhat.com
Mon May 23 16:25:14 UTC 2016
Add a simple shell_command, which is mostly a wrapper around
Sys.command but with logging of the command run.
---
builder/builder.ml | 24 +++++++++---------------
builder/cache.ml | 2 +-
builder/downloader.ml | 5 ++---
builder/sigchecker.ml | 18 ++++++------------
dib/dib.ml | 2 +-
mllib/common_utils.ml | 7 ++++++-
mllib/common_utils.mli | 6 ++++++
sparsify/copying.ml | 3 +--
v2v/copy_to_local.ml | 6 ++----
v2v/input_libvirt_vcenter_https.ml | 3 +--
v2v/input_ova.ml | 9 +++------
v2v/output_glance.ml | 8 +++-----
v2v/output_libvirt.ml | 5 ++---
v2v/output_qemu.ml | 2 +-
v2v/output_rhev.ml | 6 ++----
v2v/v2v.ml | 6 ++----
16 files changed, 48 insertions(+), 64 deletions(-)
diff --git a/builder/builder.ml b/builder/builder.ml
index cd3e972..6645e75 100644
--- a/builder/builder.ml
+++ b/builder/builder.ml
@@ -129,8 +129,7 @@ let main () =
| None -> ""
| Some output -> sprintf " --output %s" (quote output))
(quote cmdline.arg) in
- debug "%s" cmd;
- exit (Sys.command cmd)
+ exit (shell_command cmd)
| `Delete_cache -> (* --delete-cache *)
(match cmdline.cache with
@@ -150,7 +149,7 @@ let main () =
* disables all signature checks.
*)
let cmd = sprintf "%s --help >/dev/null 2>&1" cmdline.gpg in
- if Sys.command cmd <> 0 then (
+ if shell_command cmd <> 0 then (
if cmdline.check_signature then
error (f_"gpg is not installed (or does not work)\nYou should install gpg, or use --gpg option, or use --no-check-signature.")
else if verbose () then
@@ -159,12 +158,12 @@ let main () =
(* Check that curl works. *)
let cmd = sprintf "%s --help >/dev/null 2>&1" cmdline.curl in
- if Sys.command cmd <> 0 then
+ if shell_command cmd <> 0 then
error (f_"curl is not installed (or does not work)");
(* Check that virt-resize works. *)
let cmd = "virt-resize --help >/dev/null 2>&1" in
- if Sys.command cmd <> 0 then
+ if shell_command cmd <> 0 then
error (f_"virt-resize is not installed (or does not work)");
(* Create the cache. *)
@@ -552,15 +551,13 @@ let main () =
let ofile = List.assoc `Filename otags in
message (f_"Copying");
let cmd = sprintf "cp %s %s" (quote ifile) (quote ofile) in
- debug "%s" cmd;
- if Sys.command cmd <> 0 then exit 1
+ if shell_command cmd <> 0 then exit 1
| itags, `Rename, otags ->
let ifile = List.assoc `Filename itags in
let ofile = List.assoc `Filename otags in
let cmd = sprintf "mv %s %s" (quote ifile) (quote ofile) in
- debug "%s" cmd;
- if Sys.command cmd <> 0 then exit 1
+ if shell_command cmd <> 0 then exit 1
| itags, `Pxzcat, otags ->
let ifile = List.assoc `Filename itags in
@@ -598,8 +595,7 @@ let main () =
| None -> ""
| Some lvexpand -> sprintf " --lv-expand %s" (quote lvexpand))
(quote ifile) (quote ofile) in
- debug "%s" cmd;
- if Sys.command cmd <> 0 then exit 1
+ if shell_command cmd <> 0 then exit 1
| itags, `Disk_resize, otags ->
let ofile = List.assoc `Filename otags in
@@ -609,8 +605,7 @@ let main () =
(human_size osize);
let cmd = sprintf "qemu-img resize %s %Ld%s"
(quote ofile) osize (if verbose () then "" else " >/dev/null") in
- debug "%s" cmd;
- if Sys.command cmd <> 0 then exit 1
+ if shell_command cmd <> 0 then exit 1
| itags, `Convert, otags ->
let ifile = List.assoc `Filename itags in
@@ -628,8 +623,7 @@ let main () =
| Some iformat -> sprintf " -f %s" (quote iformat))
(quote ifile) (quote oformat) (quote (qemu_input_filename ofile))
(if verbose () then "" else " >/dev/null 2>&1") in
- debug "%s" cmd;
- if Sys.command cmd <> 0 then exit 1
+ if shell_command cmd <> 0 then exit 1
) plan;
(* Now mount the output disk so we can make changes. *)
diff --git a/builder/cache.ml b/builder/cache.ml
index 0791500..9d056a1 100644
--- a/builder/cache.ml
+++ b/builder/cache.ml
@@ -26,7 +26,7 @@ open Printf
let clean_cachedir dir =
let cmd = sprintf "rm -rf %s" (quote dir) in
- ignore (Sys.command cmd);
+ ignore (shell_command cmd);
type t = {
directory : string;
diff --git a/builder/downloader.ml b/builder/downloader.ml
index 7dc0a29..7406ce8 100644
--- a/builder/downloader.ml
+++ b/builder/downloader.ml
@@ -88,7 +88,7 @@ and download_to t ?(progress_bar = false) ~proxy uri filename =
let cmd = sprintf "cp%s %s %s"
(if verbose () then " -v" else "")
(quote path) (quote filename_new) in
- let r = Sys.command cmd in
+ let r = shell_command cmd in
if r <> 0 then
error (f_"cp (download) command failed copying '%s'") path;
| _ as protocol -> (* Any other protocol. *)
@@ -118,8 +118,7 @@ and download_to t ?(progress_bar = false) ~proxy uri filename =
t.curl
(if verbose () then "" else if progress_bar then " -#" else " -s -S")
(quote filename_new) (quote uri) in
- debug "%s" cmd;
- let r = Sys.command cmd in
+ let r = shell_command cmd in
if r <> 0 then
error (f_"curl (download) command failed downloading '%s'") uri;
);
diff --git a/builder/sigchecker.ml b/builder/sigchecker.ml
index 39a2766..d30baf5 100644
--- a/builder/sigchecker.ml
+++ b/builder/sigchecker.ml
@@ -39,8 +39,7 @@ let import_keyfile ~gpg ~gpghome ?(trust = true) keyfile =
let cmd = sprintf "%s --homedir %s --status-file %s --import %s%s"
gpg gpghome (quote status_file) (quote keyfile)
(if verbose () then "" else " >/dev/null 2>&1") in
- debug "%s" cmd;
- let r = Sys.command cmd in
+ let r = shell_command cmd in
if r <> 0 then
error (f_"could not import public key\nUse the '-v' option and look for earlier error messages.");
let status = read_whole_file status_file in
@@ -59,8 +58,7 @@ let import_keyfile ~gpg ~gpghome ?(trust = true) keyfile =
let cmd = sprintf "%s --homedir %s --trusted-key %s --list-keys%s"
gpg gpghome (quote !key_id)
(if verbose () then "" else " >/dev/null 2>&1") in
- debug "%s" cmd;
- let r = Sys.command cmd in
+ let r = shell_command cmd in
if r <> 0 then
error (f_"GPG failure: could not trust the imported key\nUse the '-v' option and look for earlier error messages.");
);
@@ -108,8 +106,7 @@ let rec create ~gpg ~gpgkey ~check_signature =
*)
let cmd = sprintf "%s --homedir %s --list-keys%s"
gpg tmpdir (if verbose () then "" else " >/dev/null 2>&1") in
- debug "%s" cmd;
- let r = Sys.command cmd in
+ let r = shell_command cmd in
if r <> 0 then
error (f_"GPG failure: could not run GPG the first time\nUse the '-v' option and look for earlier error messages.");
match gpgkey with
@@ -123,8 +120,7 @@ let rec create ~gpg ~gpgkey ~check_signature =
let cmd = sprintf "%s --yes --armor --output %s --export %s%s"
gpg (quote filename) (quote fp)
(if verbose () then "" else " >/dev/null 2>&1") in
- debug "%s" cmd;
- let r = Sys.command cmd in
+ let r = shell_command cmd in
if r <> 0 then
error (f_"could not export public key\nUse the '-v' option and look for earlier error messages.");
import_keyfile gpg tmpdir filename
@@ -188,8 +184,7 @@ and verify_and_remove_signature t filename =
let asc_file = Filename.temp_file "vbfile" ".asc" in
unlink_on_exit asc_file;
let cmd = sprintf "cp %s %s" (quote filename) (quote asc_file) in
- debug "%s" cmd;
- if Sys.command cmd <> 0 then exit 1;
+ if shell_command cmd <> 0 then exit 1;
let out_file = Filename.temp_file "vbfile" "" in
unlink_on_exit out_file;
let args = sprintf "--yes --output %s %s" (quote out_file) (quote filename) in
@@ -207,8 +202,7 @@ and do_verify ?(verify_only = true) t args =
(if verify_only then "--verify" else "")
(if verbose () then "" else " --batch -q --logger-file /dev/null")
(quote status_file) args in
- debug "%s" cmd;
- let r = Sys.command cmd in
+ let r = shell_command cmd in
if r <> 0 then
error (f_"GPG failure: could not verify digital signature of file\nTry:\n - Use the '-v' option and look for earlier error messages.\n - Delete the cache: virt-builder --delete-cache\n - Check no one has tampered with the website or your network!");
diff --git a/dib/dib.ml b/dib/dib.ml
index 534a072..b988f14 100644
--- a/dib/dib.ml
+++ b/dib/dib.ml
@@ -624,7 +624,7 @@ let main () =
g#rm remotetar in
if debug >= 1 then
- ignore (Sys.command (sprintf "tree -ps %s" (quote tmpdir)));
+ ignore (shell_command (sprintf "tree -ps %s" (quote tmpdir)));
message (f_"Opening the disks");
diff --git a/mllib/common_utils.ml b/mllib/common_utils.ml
index 32071f4..d1aa8d2 100644
--- a/mllib/common_utils.ml
+++ b/mllib/common_utils.ml
@@ -669,6 +669,11 @@ let external_command ?(echo_cmd = true) cmd =
);
lines
+let shell_command ?(echo_cmd = true) cmd =
+ if echo_cmd then
+ debug "%s" cmd;
+ Sys.command cmd
+
(* Run uuidgen to return a random UUID. *)
let uuidgen () =
let lines = external_command "uuidgen -r" in
@@ -713,7 +718,7 @@ let rmdir_on_exit =
List.iter (
fun dir ->
let cmd = sprintf "rm -rf %s" (Filename.quote dir) in
- ignore (Sys.command cmd)
+ ignore (shell_command cmd)
) !dirs
and register_handlers () =
(* Remove on exit. *)
diff --git a/mllib/common_utils.mli b/mllib/common_utils.mli
index a216e21..7f288b4 100644
--- a/mllib/common_utils.mli
+++ b/mllib/common_utils.mli
@@ -245,6 +245,12 @@ val external_command : ?echo_cmd:bool -> string -> string list
[echo_cmd] specifies whether output the full command on verbose
mode, and it's on by default. *)
+val shell_command : ?echo_cmd:bool -> string -> int
+(** Run an external shell command, and return its exit code.
+
+ [echo_cmd] specifies whether output the full command on verbose
+ mode, and it's on by default. *)
+
val uuidgen : unit -> string
(** Run uuidgen to return a random UUID. *)
diff --git a/sparsify/copying.ml b/sparsify/copying.ml
index b2a7f41..83cbec7 100644
--- a/sparsify/copying.ml
+++ b/sparsify/copying.ml
@@ -326,8 +326,7 @@ You can ignore this warning or change it to a hard failure using the
| None -> ""
| Some option -> " -o " ^ quote option)
(quote overlaydisk) (quote (qemu_input_filename outdisk)) in
- debug "%s" cmd;
- if Sys.command cmd <> 0 then
+ if shell_command cmd <> 0 then
error (f_"external command failed: %s") cmd;
(* Finished. *)
diff --git a/v2v/copy_to_local.ml b/v2v/copy_to_local.ml
index 629c8b6..0706f27 100644
--- a/v2v/copy_to_local.ml
+++ b/v2v/copy_to_local.ml
@@ -194,8 +194,7 @@ read the man page virt-v2v-copy-to-local(1).
(if quiet () then ""
else " status=progress")
(quote local_disk) in
- debug "%s" cmd;
- if Sys.command cmd <> 0 then
+ if shell_command cmd <> 0 then
error (f_"ssh copy command failed, see earlier errors");
| ESXi _ ->
@@ -220,8 +219,7 @@ read the man page virt-v2v-copy-to-local(1).
| Test ->
let cmd = sprintf "cp %s %s" (quote remote_disk) (quote local_disk) in
- debug "%s" cmd;
- if Sys.command cmd <> 0 then
+ if shell_command cmd <> 0 then
error (f_"copy command failed, see earlier errors");
) disks;
diff --git a/v2v/input_libvirt_vcenter_https.ml b/v2v/input_libvirt_vcenter_https.ml
index 2acf966..1d28e17 100644
--- a/v2v/input_libvirt_vcenter_https.ml
+++ b/v2v/input_libvirt_vcenter_https.ml
@@ -131,8 +131,7 @@ object
let cmd =
sprintf "qemu-img rebase -u -b %s %s"
(quote backing_qemu_uri) (quote overlay.ov_overlay_file) in
- debug "%s" cmd;
- if Sys.command cmd <> 0 then
+ if shell_command cmd <> 0 then
warning (f_"qemu-img rebase failed (ignored)")
end
diff --git a/v2v/input_ova.ml b/v2v/input_ova.ml
index 65a2028..dd52af5 100644
--- a/v2v/input_ova.ml
+++ b/v2v/input_ova.ml
@@ -61,8 +61,7 @@ object
let untar ?(format = "") file outdir =
let cmd = sprintf "tar -x%sf %s -C %s" format (quote file) (quote outdir) in
- debug "%s" cmd;
- if Sys.command cmd <> 0 then
+ if shell_command cmd <> 0 then
error (f_"error unpacking %s, see earlier error messages") ova in
match detect_file_type ova with
@@ -77,8 +76,7 @@ object
let cmd = sprintf "unzip%s -j -d %s %s"
(if verbose () then "" else " -q")
(quote tmpdir) (quote ova) in
- debug "%s" cmd;
- if Sys.command cmd <> 0 then
+ if shell_command cmd <> 0 then
error (f_"error unpacking %s, see earlier error messages") ova;
tmpdir
| (`GZip|`XZ) as format ->
@@ -274,8 +272,7 @@ object
let new_filename = tmpdir // String.random8 () ^ ".vmdk" in
let cmd =
sprintf "zcat %s > %s" (quote filename) (quote new_filename) in
- debug "%s" cmd;
- if Sys.command cmd <> 0 then
+ if shell_command cmd <> 0 then
error (f_"error uncompressing %s, see earlier error messages")
filename;
new_filename
diff --git a/v2v/output_glance.ml b/v2v/output_glance.ml
index 4713287..dc5d868 100644
--- a/v2v/output_glance.ml
+++ b/v2v/output_glance.ml
@@ -48,7 +48,7 @@ object
* 'glance' commands work as the current user. If not then the
* program exits early.
*)
- if Sys.command "glance image-list > /dev/null" <> 0 then
+ if shell_command "glance image-list > /dev/null" <> 0 then
error (f_"glance: glance client is not installed or set up correctly. You may need to set environment variables or source a script to enable authentication. See preceding messages for details.");
(* Write targets to a temporary local file - see above for reason. *)
@@ -76,8 +76,7 @@ object
let cmd =
sprintf "glance image-create --name %s --disk-format=%s --container-format=bare --file %s"
(quote name) (quote target_format) target_file in
- debug "%s" cmd;
- if Sys.command cmd <> 0 then
+ if shell_command cmd <> 0 then
error (f_"glance: image upload to glance failed, see earlier errors");
(* Set the properties (ie. metadata). *)
@@ -126,8 +125,7 @@ object
) properties
))
(quote name) in
- debug "%s" cmd;
- if Sys.command cmd <> 0 then (
+ if shell_command cmd <> 0 then (
warning (f_"glance: failed to set image properties (ignored)");
(* Dump out the image properties so the user can set them. *)
printf "Image properties:\n";
diff --git a/v2v/output_libvirt.ml b/v2v/output_libvirt.ml
index 7e04a54..db3a3fa 100644
--- a/v2v/output_libvirt.ml
+++ b/v2v/output_libvirt.ml
@@ -390,8 +390,7 @@ class output_libvirt oc output_pool = object
| Some uri ->
sprintf "virsh -c %s pool-refresh %s"
(quote uri) (quote output_pool) in
- debug "%s" cmd;
- if Sys.command cmd <> 0 then
+ if shell_command cmd <> 0 then
warning (f_"could not refresh libvirt pool %s") output_pool;
(* Parse the capabilities XML in order to get the supported features. *)
@@ -423,7 +422,7 @@ class output_libvirt oc output_pool = object
| None -> sprintf "virsh define %s" (quote tmpfile)
| Some uri ->
sprintf "virsh -c %s define %s" (quote uri) (quote tmpfile) in
- if Sys.command cmd = 0 then (
+ if shell_command cmd = 0 then (
try Unix.unlink tmpfile with _ -> ()
) else (
warning (f_"could not define libvirt domain. The libvirt XML is still available in '%s'. Try running 'virsh define %s' yourself instead.")
diff --git a/v2v/output_qemu.ml b/v2v/output_qemu.ml
index f76b3be..f1d3c5f 100644
--- a/v2v/output_qemu.ml
+++ b/v2v/output_qemu.ml
@@ -195,7 +195,7 @@ object
(* If --qemu-boot option was specified then we should boot the guest. *)
if qemu_boot then (
let cmd = sprintf "%s &" (quote file) in
- ignore (Sys.command cmd)
+ ignore (shell_command cmd)
)
end
diff --git a/v2v/output_rhev.ml b/v2v/output_rhev.ml
index 6301d9a..971c1af 100644
--- a/v2v/output_rhev.ml
+++ b/v2v/output_rhev.ml
@@ -45,15 +45,13 @@ let rec mount_and_check_storage_domain domain_class os =
(* Try mounting it. *)
let cmd =
sprintf "mount %s:%s %s" (quote server) (quote export) (quote mp) in
- debug "%s" cmd;
- if Sys.command cmd <> 0 then
+ if shell_command cmd <> 0 then
error (f_"mount command failed, see earlier errors.\n\nThis probably means you didn't specify the right %s path [-os %s], or else you need to rerun virt-v2v as root.") domain_class os;
(* Make sure it is unmounted at exit. *)
at_exit (fun () ->
let cmd = sprintf "umount %s" (quote mp) in
- debug "%s" cmd;
- ignore (Sys.command cmd);
+ ignore (shell_command cmd);
try rmdir mp with _ -> ()
);
diff --git a/v2v/v2v.ml b/v2v/v2v.ml
index 18d343e..b332ced 100644
--- a/v2v/v2v.ml
+++ b/v2v/v2v.ml
@@ -229,8 +229,7 @@ and create_overlays src_disks =
let cmd =
sprintf "qemu-img create -q -f qcow2 -b %s -o %s %s"
(quote qemu_uri) (quote options) overlay_file in
- debug "%s" cmd;
- if Sys.command cmd <> 0 then
+ if shell_command cmd <> 0 then
error (f_"qemu-img command failed, see earlier errors");
(* Sanity check created overlay (see below). *)
@@ -637,9 +636,8 @@ and copy_targets cmdline targets input output =
(if cmdline.compressed then " -c" else "")
(quote overlay_file)
(quote t.target_file) in
- debug "%s" cmd;
let start_time = gettimeofday () in
- if Sys.command cmd <> 0 then
+ if shell_command cmd <> 0 then
error (f_"qemu-img command failed, see earlier errors");
let end_time = gettimeofday () in
--
2.5.5
More information about the Libguestfs
mailing list