[Libguestfs] [PATCH v2 3/4] common/mlstdutils: Introduce Option submodule.

Richard W.M. Jones
Sun, 08 Oct 2017 21:26:55 -0000

Inspired by ocaml-extlib, introduce a module for handling option
types.

We already had the ‘may’ function (which becomes ‘Option.may’).  This
adds also ‘Option.map’ (unused), and ‘Option.default’ functions.

Note this does *not* introduce the unsafe ‘Option.get’ function from
extlib.
---
 builder/builder.ml              |  6 ++---
 builder/index.ml                | 27 +++++++++------------
 builder/list_entries.ml         | 20 +++++++---------
 common/mlstdutils/std_utils.ml  | 18 ++++++++++----
 common/mlstdutils/std_utils.mli | 15 +++++++++---
 common/mltools/tools_utils.ml   |  6 ++---
 customize/customize_main.ml     |  4 ++--
 daemon/inspect_types.ml         | 52 ++++++++++++++++++++---------------------
 dib/dib.ml                      |  4 ++--
 resize/resize.ml                |  6 ++---
 sysprep/sysprep_operation.ml    | 16 ++++++-------
 v2v/changeuid.ml                |  4 ++--
 v2v/cmdline.ml                  |  6 ++---
 v2v/input_libvirt_vddk.ml       |  3 ++-
 v2v/parse_libvirt_xml.ml        |  6 ++---
 v2v/types.ml                    |  7 +++---
 v2v/v2v.ml                      |  6 ++---
 17 files changed, 107 insertions(+), 99 deletions(-)

diff --git a/builder/builder.ml b/builder/builder.ml
index 8b4c20765..9b907ac8e 100644
--- a/builder/builder.ml
+++ b/builder/builder.ml
@@ -688,8 +688,8 @@ let main ()    let g      let g = open_guestfs () in

-    may g#set_memsize cmdline.memsize;
-    may g#set_smp cmdline.smp;
+    Option.may g#set_memsize cmdline.memsize;
+    Option.may g#set_smp cmdline.smp;
     g#set_network cmdline.network;

     (* The output disk is being created, so use cache=unsafe here. *)
@@ -781,6 +781,6 @@ let main ()    Pervasives.flush Pervasives.stdout;
   Pervasives.flush Pervasives.stderr;

-  may print_string stats
+  Option.may print_string stats

 let () = run_main_and_handle_errors main
diff --git a/builder/index.ml b/builder/index.ml
index b895e3f52..84f66c265 100644
--- a/builder/index.ml
+++ b/builder/index.ml
@@ -53,34 +53,29 @@ let print_entry chan (name, { printable_name; file_uri;
arch; osinfo;
                               notes; aliases; hidden })    let fp fs = fprintf
chan fs in
   fp "[%s]\n" name;
-  may (fp "name=%s\n") printable_name;
-  may (fp "osinfo=%s\n") osinfo;
+  Option.may (fp "name=%s\n") printable_name;
+  Option.may (fp "osinfo=%s\n") osinfo;
   fp "file=%s\n" file_uri;
   fp "arch=%s\n" arch;
-  may (fp "sig=%s\n") signature_uri;
-  (match checksums with
-  | None -> ()
-  | Some checksums ->
+  Option.may (fp "sig=%s\n") signature_uri;
+  Option.may (
     List.iter (
       fun c ->
         fp "checksum[%s]=%s\n"
           (Checksums.string_of_csum_t c) (Checksums.string_of_csum c)
-    ) checksums
-  );
+    )
+  ) checksums;
   fp "revision=%s\n" (string_of_revision revision);
-  may (fp "format=%s\n") format;
+  Option.may (fp "format=%s\n") format;
   fp "size=%Ld\n" size;
-  may (fp "compressed_size=%Ld\n") compressed_size;
-  may (fp "expand=%s\n") expand;
-  may (fp "lvexpand=%s\n") lvexpand;
+  Option.may (fp "compressed_size=%Ld\n") compressed_size;
+  Option.may (fp "expand=%s\n") expand;
+  Option.may (fp "lvexpand=%s\n") lvexpand;
   List.iter (
     fun (lang, notes) ->
       match lang with
       | "" -> fp "notes=%s\n" notes
       | lang -> fp "notes[%s]=%s\n" lang notes
   ) notes;
-  (match aliases with
-  | None -> ()
-  | Some l -> fp "aliases=%s\n" (String.concat " " l)
-  );
+  Option.may (fun l -> fp "aliases=%s\n" (String.concat "
" l)) aliases;
   if hidden then fp "hidden=true\n"
diff --git a/builder/list_entries.ml b/builder/list_entries.ml
index 2cd030fca..af1d2419b 100644
--- a/builder/list_entries.ml
+++ b/builder/list_entries.ml
@@ -47,7 +47,7 @@ and list_entries_short index        if not hidden then (
         printf "%-24s" name;
         printf " %-10s" arch;
-        may (printf " %s") printable_name;
+        Option.may (printf " %s") printable_name;
         printf "\n"
       )
   ) index
@@ -73,19 +73,15 @@ and list_entries_long ~sources index
notes; aliases; hidden }) ->
       if not hidden then (
         printf "%-24s %s\n" "os-version:" name;
-        may (printf "%-24s %s\n" (s_"Full name:"))
printable_name;
+        Option.may (printf "%-24s %s\n" (s_"Full name:"))
printable_name;
         printf "%-24s %s\n" (s_"Architecture:") arch;
         printf "%-24s %s\n" (s_"Minimum/default size:")
(human_size size);
-        (match compressed_size with
-        | None -> ()
-        | Some size ->
-          printf "%-24s %s\n" (s_"Download size:")
(human_size size);
-        );
-        (match aliases with
-        | None -> ()
-        | Some l -> printf "%-24s %s\n" (s_"Aliases:")
-                      (String.concat " " l);
-        );
+        Option.may (fun size ->
+            printf "%-24s %s\n" (s_"Download size:")
(human_size size)
+        ) compressed_size;
+        Option.may (
+            fun l -> printf "%-24s %s\n" (s_"Aliases:")
(String.concat " " l)
+        ) aliases;
         let notes = Languages.find_notes langs notes in
         (match notes with
         | notes :: _ ->
diff --git a/common/mlstdutils/std_utils.ml b/common/mlstdutils/std_utils.ml
index 558b1e3e2..32bba4113 100644
--- a/common/mlstdutils/std_utils.ml
+++ b/common/mlstdutils/std_utils.ml
@@ -359,6 +359,20 @@ module List = struct
     let push_front_list xs xsp = xsp := xs @ !xsp
 end

+module Option = struct
+    let may f = function
+      | None -> ()
+      | Some x -> f x
+
+    let map f = function
+      | None -> None
+      | Some x -> Some (f x)
+
+    let default def = function
+      | None -> def
+      | Some x -> x
+end
+
 let (//) = Filename.concat
 let quote = Filename.quote

@@ -575,10 +589,6 @@ and output_spaces chan n = for i = 0 to n-1 do output_char
chan ' ' done

 let unique = let i = ref 0 in fun () -> incr i; !i

-let may f = function
-  | None -> ()
-  | Some x -> f x
-
 type ('a, 'b) maybe = Either of 'a | Or of 'b

 let protect ~f ~finally diff --git a/common/mlstdutils/std_utils.mli
b/common/mlstdutils/std_utils.mli
index 3895a41cc..b3cfdcd55 100644
--- a/common/mlstdutils/std_utils.mli
+++ b/common/mlstdutils/std_utils.mli
@@ -256,6 +256,18 @@ module List : sig
 end
 (** Override the List module from stdlib. *)

+module Option : sig
+    val may : ('a -> unit) -> 'a option -> unit
+    (** [may f (Some x)] runs [f x].  [may f None] does nothing. *)
+
+    val map : ('a -> 'b) -> 'a option -> 'b option
+    (** [map f (Some x)] returns [Some (f x)].  [map f None] returns [None]. *)
+
+    val default : 'a -> 'a option -> 'a
+    (** [default x (Some y)] returns [y].  [default x None] returns [x]. *)
+end
+(** Functions for dealing with option types. *)
+
 val ( // ) : string -> string -> string
 (** Concatenate directory and filename. *)

@@ -320,9 +332,6 @@ val output_spaces : out_channel -> int -> unit
 val unique : unit -> int
 (** Returns a unique number each time called. *)

-val may : ('a -> unit) -> 'a option -> unit
-(** [may f (Some x)] runs [f x].  [may f None] does nothing. *)
-
 type ('a, 'b) maybe = Either of 'a | Or of 'b
 (** Like the Haskell [Either] type. *)

diff --git a/common/mltools/tools_utils.ml b/common/mltools/tools_utils.ml
index f66ee9f50..8140ba84d 100644
--- a/common/mltools/tools_utils.ml
+++ b/common/mltools/tools_utils.ml
@@ -109,7 +109,7 @@ let open_guestfs ?identifier ()    let g = new
Guestfs.guestfs () in
   if trace () then g#set_trace true;
   if verbose () then g#set_verbose true;
-  may g#set_identifier identifier;
+  Option.may g#set_identifier identifier;
   g

 (* All the OCaml virt-* programs use this wrapper to catch exceptions
@@ -340,8 +340,8 @@ and do_run ?(echo_cmd = true) ?stdout_chan ?stderr_chan args
Or 127

 and do_teardown app outfd errfd exitstat -  may Unix.close outfd;
-  may Unix.close errfd;
+  Option.may Unix.close outfd;
+  Option.may Unix.close errfd;
   match exitstat with
   | Unix.WEXITED i ->
     i
diff --git a/customize/customize_main.ml b/customize/customize_main.ml
index f6ffc872d..8ba4f5ce7 100644
--- a/customize/customize_main.ml
+++ b/customize/customize_main.ml
@@ -157,8 +157,8 @@ read the man page virt-customize(1).
   (* Connect to libguestfs. *)
   let g      let g = open_guestfs () in
-    may g#set_memsize memsize;
-    may g#set_smp smp;
+    Option.may g#set_memsize memsize;
+    Option.may g#set_smp smp;
     g#set_network network;

     (* Add disks. *)
diff --git a/daemon/inspect_types.ml b/daemon/inspect_types.ml
index a687ea08c..1da41064d 100644
--- a/daemon/inspect_types.ml
+++ b/daemon/inspect_types.ml
@@ -143,38 +143,38 @@ and string_of_root { root_location; inspection_data }  and
string_of_inspection_data data    let b = Buffer.create 1024 in
   let bpf fs = bprintf b fs in
-  may (fun v -> bpf "    type: %s\n" (string_of_os_type v))
-      data.os_type;
-  may (fun v -> bpf "    distro: %s\n" (string_of_distro v))
-      data.distro;
-  may (fun v -> bpf "    package_format: %s\n"
(string_of_package_format v))
-      data.package_format;
-  may (fun v -> bpf "    package_management: %s\n"
(string_of_package_management v))
-      data.package_management;
-  may (fun v -> bpf "    product_name: %s\n" v)
-      data.product_name;
-  may (fun v -> bpf "    product_variant: %s\n" v)
-      data.product_variant;
-  may (fun (major, minor) -> bpf "    version: %d.%d\n" major
minor)
-      data.version;
-  may (fun v -> bpf "    arch: %s\n" v)
-      data.arch;
-  may (fun v -> bpf "    hostname: %s\n" v)
-      data.hostname;
+  Option.may (fun v -> bpf "    type: %s\n" (string_of_os_type v))
+             data.os_type;
+  Option.may (fun v -> bpf "    distro: %s\n" (string_of_distro
v))
+             data.distro;
+  Option.may (fun v -> bpf "    package_format: %s\n"
(string_of_package_format v))
+             data.package_format;
+  Option.may (fun v -> bpf "    package_management: %s\n"
(string_of_package_management v))
+             data.package_management;
+  Option.may (fun v -> bpf "    product_name: %s\n" v)
+             data.product_name;
+  Option.may (fun v -> bpf "    product_variant: %s\n" v)
+             data.product_variant;
+  Option.may (fun (major, minor) -> bpf "    version: %d.%d\n"
major minor)
+             data.version;
+  Option.may (fun v -> bpf "    arch: %s\n" v)
+             data.arch;
+  Option.may (fun v -> bpf "    hostname: %s\n" v)
+             data.hostname;
   if data.fstab <> [] then (
     let v = List.map (
       fun (a, b) -> sprintf "(%s, %s)" (Mountable.to_string a) b
     ) data.fstab in
     bpf "    fstab: [%s]\n" (String.concat ", " v)
   );
-  may (fun v -> bpf "    windows_systemroot: %s\n" v)
-      data.windows_systemroot;
-  may (fun v -> bpf "    windows_software_hive: %s\n" v)
-      data.windows_software_hive;
-  may (fun v -> bpf "    windows_system_hive: %s\n" v)
-      data.windows_system_hive;
-  may (fun v -> bpf "    windows_current_control_set: %s\n" v)
-      data.windows_current_control_set;
+  Option.may (fun v -> bpf "    windows_systemroot: %s\n" v)
+             data.windows_systemroot;
+  Option.may (fun v -> bpf "    windows_software_hive: %s\n" v)
+             data.windows_software_hive;
+  Option.may (fun v -> bpf "    windows_system_hive: %s\n" v)
+             data.windows_system_hive;
+  Option.may (fun v -> bpf "    windows_current_control_set: %s\n"
v)
+             data.windows_current_control_set;
   if data.drive_mappings <> [] then (
     let v        List.map (fun (a, b) -> sprintf "(%s, %s)" a b)
data.drive_mappings in
diff --git a/dib/dib.ml b/dib/dib.ml
index f8595636a..9a8d86bd9 100644
--- a/dib/dib.ml
+++ b/dib/dib.ml
@@ -720,8 +720,8 @@ let main ()
   let g, tmpdisk, tmpdiskfmt, drive_partition      let g = open_guestfs () in
-    may g#set_memsize cmdline.memsize;
-    may g#set_smp cmdline.smp;
+    Option.may g#set_memsize cmdline.memsize;
+    Option.may g#set_smp cmdline.smp;
     g#set_network cmdline.network;

     (* Main disk with the built image. *)
diff --git a/resize/resize.ml b/resize/resize.ml
index 4eeb0a170..837c3ce9e 100644
--- a/resize/resize.ml
+++ b/resize/resize.ml
@@ -1005,7 +1005,7 @@ read the man page virt-resize(1).
       let ok          try
           g#part_init "/dev/sdb" parttype_string;
-          may (g#part_set_disk_guid "/dev/sdb") disk_guid;
+          Option.may (g#part_set_disk_guid "/dev/sdb") disk_guid;
           true
         with G.Error error -> last_error := error; false in
       if ok then g, true
@@ -1195,8 +1195,8 @@ read the man page virt-resize(1).
       if p.p_bootable then
         g#part_set_bootable "/dev/sdb" p.p_target_partnum true;

-      may (g#part_set_name "/dev/sdb" p.p_target_partnum) p.p_label;
-      may (g#part_set_gpt_guid "/dev/sdb" p.p_target_partnum)
p.p_guid;
+      Option.may (g#part_set_name "/dev/sdb" p.p_target_partnum)
p.p_label;
+      Option.may (g#part_set_gpt_guid "/dev/sdb" p.p_target_partnum)
p.p_guid;

       match parttype, p.p_id with
       | GPT, GPT_Type gpt_type ->
diff --git a/sysprep/sysprep_operation.ml b/sysprep/sysprep_operation.ml
index 2ddce302a..0013ff504 100644
--- a/sysprep/sysprep_operation.ml
+++ b/sysprep/sysprep_operation.ml
@@ -187,15 +187,13 @@ let dump_pod ()        if op.enabled_by_default then
printf "*\n";
       printf "\n";
       printf "%s.\n\n" op.heading;
-      may (printf "%s\n\n") op.pod_description;
-      (match op.pod_notes with
-      | None -> ()
-      | Some notes ->
-        printf "=head3 ";
-        printf (f_"Notes on %s") op.name;
-        printf "\n\n";
-        printf "%s\n\n" notes
-      )
+      Option.may (printf "%s\n\n") op.pod_description;
+      Option.may (fun notes ->
+          printf "=head3 ";
+          printf (f_"Notes on %s") op.name;
+          printf "\n\n";
+          printf "%s\n\n" notes
+      ) op.pod_notes;
   ) !all_operations

 let dump_pod_options () diff --git a/v2v/changeuid.ml b/v2v/changeuid.ml
index d02f2f5cf..49290c298 100644
--- a/v2v/changeuid.ml
+++ b/v2v/changeuid.ml
@@ -40,8 +40,8 @@ let with_fork { uid; gid } name f
   if pid = 0 then (
     (* Child. *)
-    may setgid gid;
-    may setuid uid;
+    Option.may setgid gid;
+    Option.may setuid uid;
     (try f ()
      with exn ->
        eprintf "%s: changeuid: %s: %s\n%!" prog name
(Printexc.to_string exn);
diff --git a/v2v/cmdline.ml b/v2v/cmdline.ml
index 2180b656f..1ae018bcd 100644
--- a/v2v/cmdline.ml
+++ b/v2v/cmdline.ml
@@ -319,8 +319,7 @@ read the man page virt-v2v(1).
   let vdsm_image_uuids = List.rev !vdsm_image_uuids in
   let vdsm_vol_uuids = List.rev !vdsm_vol_uuids in
   let vdsm_vm_uuid = !vdsm_vm_uuid in
-  let vdsm_ovf_output -    match !vdsm_ovf_output with None -> "."
| Some s -> s in
+  let vdsm_ovf_output = Option.default "." !vdsm_ovf_output in

   (* No arguments and machine-readable mode?  Print out some facts
    * about what this binary supports.
@@ -422,8 +421,7 @@ read the man page virt-v2v(1).

     | `Not_set
     | `Libvirt ->
-      let output_storage -        match output_storage with None ->
"default" | Some os -> os in
+      let output_storage = Option.default "default" output_storage in
       if qemu_boot then
         error_option_cannot_be_used_in_output_mode "libvirt"
"--qemu-boot";
       if not do_copy then
diff --git a/v2v/input_libvirt_vddk.ml b/v2v/input_libvirt_vddk.ml
index 9afa9ed32..13a6a1561 100644
--- a/v2v/input_libvirt_vddk.ml
+++ b/v2v/input_libvirt_vddk.ml
@@ -210,7 +210,8 @@ object
       add_arg (sprintf "libdir=%s" libdir);

       (* The passthrough parameters. *)
-      let pt name = may (fun field -> add_arg (sprintf "%s=%s"
name field)) in
+      let pt name +        Option.may (fun field -> add_arg (sprintf
"%s=%s" name field)) in
       pt "config" vddk_options.vddk_config;
       pt "cookie" vddk_options.vddk_cookie;
       pt "nfchostport" vddk_options.vddk_nfchostport;
diff --git a/v2v/parse_libvirt_xml.ml b/v2v/parse_libvirt_xml.ml
index 7a03156f3..2f90bee0c 100644
--- a/v2v/parse_libvirt_xml.ml
+++ b/v2v/parse_libvirt_xml.ml
@@ -111,9 +111,9 @@ let parse_libvirt_xml ?conn xml      | Some vcpu, _,    _,
_    -> vcpu
     | None,      None, None, None -> 1
     | None,      _,    _,    _    ->
-       let sockets = match cpu_sockets with None -> 1 | Some v -> v in
-       let cores = match cpu_cores with None -> 1 | Some v -> v in
-       let threads = match cpu_threads with None -> 1 | Some v -> v in
+       let sockets = Option.default 1 cpu_sockets
+       and cores = Option.default 1 cpu_cores
+       and threads = Option.default 1 cpu_threads in
        sockets * cores * threads in

   let features diff --git a/v2v/types.ml b/v2v/types.ml
index 1b4e57845..fbf616c3d 100644
--- a/v2v/types.ml
+++ b/v2v/types.ml
@@ -18,8 +18,9 @@

 open Printf

-open Common_gettext.Gettext
+open Std_utils
 open Tools_utils
+open Common_gettext.Gettext

 (* Types.  See types.mli for documentation. *)

@@ -126,8 +127,8 @@ NICs:
     (string_of_source_hypervisor s.s_hypervisor)
     s.s_memory
     s.s_vcpu
-    (match s.s_cpu_vendor with None -> "" | Some v -> v)
-    (match s.s_cpu_model with None -> "" | Some v -> v)
+    (Option.default "" s.s_cpu_vendor)
+    (Option.default "" s.s_cpu_model)
     (match s.s_cpu_sockets with None -> "-" | Some v ->
string_of_int v)
     (match s.s_cpu_cores with None -> "-" | Some v ->
string_of_int v)
     (match s.s_cpu_threads with None -> "-" | Some v ->
string_of_int v)
diff --git a/v2v/v2v.ml b/v2v/v2v.ml
index 9e609b526..2864d728d 100644
--- a/v2v/v2v.ml
+++ b/v2v/v2v.ml
@@ -214,9 +214,9 @@ and open_source cmdline input    (match
source.s_cpu_sockets, source.s_cpu_cores, source.s_cpu_threads with
    | None, None, None -> () (* no topology specified *)
    | sockets, cores, threads ->
-      let sockets = match sockets with None -> 1 | Some v -> v in
-      let cores = match cores with None -> 1 | Some v -> v in
-      let threads = match threads with None -> 1 | Some v -> v in
+      let sockets = Option.default 1 sockets
+      and cores = Option.default 1 cores
+      and threads = Option.default 1 threads in
       let expected_vcpu = sockets * cores * threads in
       if expected_vcpu <> source.s_vcpu then
         warning (f_"source sockets * cores * threads <> number of
vCPUs.\nSockets %d * cores per socket %d * threads %d = %d, but number of vCPUs
= %d.\n\nThis is a problem with either the source metadata or the virt-v2v input
module.  In some circumstances this could stop the guest from booting on the
target.")
--
2.13.2