common/mlstdutils: Introduce Option submodule.

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

@@ -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

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"

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 :: _ ->

common/mlstdutils/std_utils.ml

@@ -271,6 +271,20 @@ module String = struct
       loop 0
 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
 
@@ -568,10 +582,6 @@ let prepend xs xsp = xsp := xs @ !xsp
 
 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 =

common/mlstdutils/std_utils.mli

@@ -134,6 +134,18 @@ module String : sig
 end
 (** Override the String 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. *)
 
@@ -272,9 +284,6 @@ val prepend : 'a list -> 'a list ref -> 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. *)
 

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

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

daemon/inspect_types.ml

@@ -144,38 +144,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

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

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

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 () =

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

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

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;

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 =

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)

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