mllib: add an helper shell_command

Add a simple shell_command, which is mostly a wrapper around
Sys.command but with logging of the command run.

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. *)

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;

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;
   );

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!");
 

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");
 

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. *)

mllib/common_utils.mli

@@ -245,6 +245,12 @@ val external_command : ?echo_cmd:bool -> string -> string list
     [echo_cmd] specifies whether to 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 to output the full command on verbose
+    mode, and it's on by default. *)
+
 val uuidgen : unit -> string
 (** Run uuidgen to return a random UUID. *)
 

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. *)

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;
 

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
 

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 ->
@@ -276,8 +274,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

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";

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.")

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
 

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 _ -> ()
     );
 

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