3:44 p.m.
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