[Libguestfs] [PATCH v2 3/4] 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 | 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