2:25 p.m.
The 'may' function is a higher-order function (HOF) that replaces:
match x with
| None -> ()
| Some x -> f x
with:
may f x
The idea comes from lablgtk (OCaml Gtk bindings) where it is widely
used.
If this change is clearer than previous code, then this could be used
in many more places. However I previously steered clear from using
HOFs like this because they can be quite confusing for newcomers to
functional programming.
Rich.
2:25 p.m.
New subject: [PATCH 1/4] mllib: Add Common_utils 'may' function.
This higher order function encapsulates the following pattern:
match x with
| None -> ()
| Some x -> f x
(replaced with: `may f x`)
This is taken from OCaml lablgtk (Gtk bindings) where this pattern is
used frequently.
See also: https://ocaml.org/learn/tutorials/labels.html
---
mllib/common_utils.ml | 4 ++++
mllib/common_utils.mli | 3 +++
2 files changed, 7 insertions(+)
diff --git a/mllib/common_utils.ml b/mllib/common_utils.ml
index d654fa8..52079d2 100644
--- a/mllib/common_utils.ml
+++ b/mllib/common_utils.ml
@@ -267,6 +267,10 @@ let rec assoc ?(cmp = compare) ~default x = function
| (y, y') :: _ when cmp x y = 0 -> y'
| _ :: ys -> assoc ~cmp ~default x ys
+let may f = function
+ | None -> ()
+ | Some x -> f x
+
let istty chan =
Unix.isatty (Unix.descr_of_out_channel chan)
diff --git a/mllib/common_utils.mli b/mllib/common_utils.mli
index 6e08e43..d8f63d5 100644
--- a/mllib/common_utils.mli
+++ b/mllib/common_utils.mli
@@ -124,6 +124,9 @@ val assoc : ?cmp:('a -> 'a -> int) -> default:'b
-> 'a -> ('a * 'b) list -> 'b
(** Like {!List.assoc} but with a user-defined comparison function, and
instead of raising [Not_found], it returns the [~default] value. *)
+val may : ('a -> unit) -> 'a option -> unit
+(** [may f (Some x)] runs [f x]. [may f None] does nothing. *)
+
val prog : string
(** The program name (derived from {!Sys.executable_name}). *)
--
2.5.0
2:25 p.m.
New subject: [PATCH 2/4] builder: Use the 'may' pattern in a few places.
---
builder/builder.ml | 8 +++-----
builder/index.ml | 35 +++++++----------------------------
builder/list_entries.ml | 10 ++--------
3 files changed, 12 insertions(+), 41 deletions(-)
diff --git a/builder/builder.ml b/builder/builder.ml
index 2c51550..b0fef48 100644
--- a/builder/builder.ml
+++ b/builder/builder.ml
@@ -626,8 +626,8 @@ let main () =
let g =
let g = open_guestfs () in
- (match memsize with None -> () | Some memsize -> g#set_memsize memsize);
- (match smp with None -> () | Some smp -> g#set_smp smp);
+ may g#set_memsize memsize;
+ may g#set_smp smp;
g#set_network network;
(* Make sure to turn SELinux off to avoid awkward interactions
@@ -733,8 +733,6 @@ let main () =
Pervasives.flush Pervasives.stdout;
Pervasives.flush Pervasives.stderr;
- match stats with
- | None -> ()
- | Some stats -> print_string stats
+ may print_string stats
let () = run_main_and_handle_errors main
diff --git a/builder/index.ml b/builder/index.ml
index c59d6dd..b2bc08e 100644
--- a/builder/index.ml
+++ b/builder/index.ml
@@ -63,20 +63,11 @@ let print_entry chan (name, { printable_name = printable_name;
hidden = hidden }) =
let fp fs = fprintf chan fs in
fp "[%s]\n" name;
- (match printable_name with
- | None -> ()
- | Some name -> fp "name=%s\n" name
- );
- (match osinfo with
- | None -> ()
- | Some id -> fp "osinfo=%s\n" id
- );
+ may (fp "name=%s\n") printable_name;
+ may (fp "osinfo=%s\n") osinfo;
fp "file=%s\n" file_uri;
fp "arch=%s\n" arch;
- (match signature_uri with
- | None -> ()
- | Some uri -> fp "sig=%s\n" uri
- );
+ may (fp "sig=%s\n") signature_uri;
(match checksums with
| None -> ()
| Some checksums ->
@@ -87,23 +78,11 @@ let print_entry chan (name, { printable_name = printable_name;
) checksums
);
fp "revision=%s\n" (string_of_revision revision);
- (match format with
- | None -> ()
- | Some format -> fp "format=%s\n" format
- );
+ may (fp "format=%s\n") format;
fp "size=%Ld\n" size;
- (match compressed_size with
- | None -> ()
- | Some size -> fp "compressed_size=%Ld\n" size
- );
- (match expand with
- | None -> ()
- | Some expand -> fp "expand=%s\n" expand
- );
- (match lvexpand with
- | None -> ()
- | Some lvexpand -> fp "lvexpand=%s\n" lvexpand
- );
+ may (fp "compressed_size=%Ld\n") compressed_size;
+ may (fp "expand=%s\n") expand;
+ may (fp "lvexpand=%s\n") lvexpand;
List.iter (
fun (lang, notes) ->
match lang with
diff --git a/builder/list_entries.ml b/builder/list_entries.ml
index 4bb899c..2f053e8 100644
--- a/builder/list_entries.ml
+++ b/builder/list_entries.ml
@@ -35,10 +35,7 @@ and list_entries_short index =
if not hidden then (
printf "%-24s" name;
printf " %-10s" arch;
- (match printable_name with
- | None -> ()
- | Some s -> printf " %s" s
- );
+ may (printf " %s") printable_name;
printf "\n"
)
) index
@@ -69,10 +66,7 @@ and list_entries_long ~sources index =
hidden = hidden }) ->
if not hidden then (
printf "%-24s %s\n" "os-version:" name;
- (match printable_name with
- | None -> ()
- | Some name -> printf "%-24s %s\n" (s_"Full name:") name;
- );
+ 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
--
2.5.0
2:25 p.m.
New subject: [PATCH 3/4] v2v: Use the 'may' pattern in the Changeuid module.
---
v2v/changeuid.ml | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/v2v/changeuid.ml b/v2v/changeuid.ml
index 43fa8d6..b64f5ce 100644
--- a/v2v/changeuid.ml
+++ b/v2v/changeuid.ml
@@ -39,8 +39,8 @@ external _exit : int -> unit = "v2v_exit"
"noalloc"
let with_fork { uid = uid; gid = gid } f =
let pid = fork () in
if pid = 0 then ( (* child *)
- (match gid with None -> () | Some gid -> setgid gid);
- (match uid with None -> () | Some uid -> setuid uid);
+ may setgid gid;
+ may setuid uid;
(try f ()
with exn ->
eprintf "%s: KVM uid wrapper: %s\n%!" prog (Printexc.to_string exn);
--
2.5.0
2:25 p.m.
New subject: [PATCH 4/4] mllib, v2v: Allow open_guestfs to set the handle identifier.
Extend open_guestfs to take an optional ?identifier parameter.
Use this parameter in virt-v2v which is currently the only place where
we use the handle identifier.
---
mllib/common_utils.ml | 3 ++-
mllib/common_utils.mli | 2 +-
v2v/output_rhev.ml | 3 +--
v2v/output_vdsm.ml | 3 +--
v2v/v2v.ml | 3 +--
v2v/windows.ml | 3 +--
6 files changed, 7 insertions(+), 10 deletions(-)
diff --git a/mllib/common_utils.ml b/mllib/common_utils.ml
index 52079d2..13e9256 100644
--- a/mllib/common_utils.ml
+++ b/mllib/common_utils.ml
@@ -363,10 +363,11 @@ let info fs =
(* Common function to create a new Guestfs handle, with common options
* (e.g. debug, tracing) already set.
*)
-let open_guestfs () =
+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;
g
(* All the OCaml virt-* programs use this wrapper to catch exceptions
diff --git a/mllib/common_utils.mli b/mllib/common_utils.mli
index d8f63d5..44b8c93 100644
--- a/mllib/common_utils.mli
+++ b/mllib/common_utils.mli
@@ -152,7 +152,7 @@ val warning : ('a, unit, string, unit) format4 -> 'a
val info : ('a, unit, string, unit) format4 -> 'a
(** Standard info function. Note: Use full sentences for this. *)
-val open_guestfs : unit -> Guestfs.guestfs
+val open_guestfs : ?identifier:string -> unit -> Guestfs.guestfs
(** Common function to create a new Guestfs handle, with common options
(e.g. debug, tracing) already set. *)
diff --git a/v2v/output_rhev.ml b/v2v/output_rhev.ml
index 2878e13..2b8d989 100644
--- a/v2v/output_rhev.ml
+++ b/v2v/output_rhev.ml
@@ -262,8 +262,7 @@ object
?clustersize path format size =
Changeuid.func changeuid_t (
fun () ->
- let g = open_guestfs () in
- g#set_identifier "rhev_disk_create";
+ let g = open_guestfs ~identifier:"rhev_disk_create" () in
(* For qcow2, override v2v-supplied compat option, because RHEL 6
* nodes cannot handle qcow2 v3 (RHBZ#1145582).
*)
diff --git a/v2v/output_vdsm.ml b/v2v/output_vdsm.ml
index 079b47f..3c667f3 100644
--- a/v2v/output_vdsm.ml
+++ b/v2v/output_vdsm.ml
@@ -156,8 +156,7 @@ object
method disk_create ?backingfile ?backingformat ?preallocation ?compat
?clustersize path format size =
- let g = open_guestfs () in
- g#set_identifier "vdsm_disk_create";
+ let g = open_guestfs ~identifier:"vdsm_disk_create" () in
(* For qcow2, override v2v-supplied compat option, because RHEL 6
* nodes cannot handle qcow2 v3 (RHBZ#1145582).
*)
diff --git a/v2v/v2v.ml b/v2v/v2v.ml
index 7e8b459..f01a790 100644
--- a/v2v/v2v.ml
+++ b/v2v/v2v.ml
@@ -74,8 +74,7 @@ let rec main () =
| In_place -> message (f_"Opening the source VM")
);
- let g = open_guestfs () in
- g#set_identifier "v2v";
+ let g = open_guestfs ~identifier:"v2v" () in
g#set_network true;
(match conversion_mode with
| Copying (overlays, _) -> populate_overlays g overlays
diff --git a/v2v/windows.ml b/v2v/windows.ml
index d3bc5d9..b7447a5 100644
--- a/v2v/windows.ml
+++ b/v2v/windows.ml
@@ -72,8 +72,7 @@ let rec copy_virtio_drivers g inspect virtio_win driverdir =
)
else if is_regular_file virtio_win then (
try
- let g2 = open_guestfs () in
- g2#set_identifier "virtio_win";
+ let g2 = open_guestfs ~identifier:"virtio_win" () in
g2#add_drive_opts virtio_win ~readonly:true;
g2#launch ();
let vio_root = "/" in
--
2.5.0
8:59 a.m.
New subject: [PATCH 4/4] mllib, v2v: Allow open_guestfs to set the handle identifier.
On Tuesday 10 November 2015 20:25:58 Richard W.M. Jones wrote:
Extend open_guestfs to take an optional ?identifier parameter.
Use this parameter in virt-v2v which is currently the only place where
we use the handle identifier.
---
LGTM -- could a shorter ?id could do it as well?
--
Pino Toscano
10:11 a.m.
New subject: [PATCH 4/4] mllib, v2v: Allow open_guestfs to set the handle identifier.
On Wed, Nov 11, 2015 at 03:59:40PM +0100, Pino Toscano wrote:
On Tuesday 10 November 2015 20:25:58 Richard W.M. Jones wrote:
> Extend open_guestfs to take an optional ?identifier parameter.
>
> Use this parameter in virt-v2v which is currently the only place where
> we use the handle identifier.
> ---
LGTM -- could a shorter ?id could do it as well?
It's called identifier in the guestfs API so I went with that.
Thanks,
Rich.
--
Richard Jones, Virtualization Group, Red Hat http://people.redhat.com/~rjones
Read my programming and virtualization blog: http://rwmj.wordpress.com
libguestfs lets you edit virtual machines. Supports shell scripting,
bindings from many languages. http://libguestfs.org
2:39 p.m.
On Tue, Nov 10, 2015 at 08:25:54PM +0000, Richard W.M. Jones wrote:
The 'may' function is a higher-order function (HOF) that
replaces:
match x with
| None -> ()
| Some x -> f x
with:
may f x
Another possibility is to break from lablgtk and call the
function 'maybe', as in:
g#set_trace trace;
g#set_verbose verbose;
maybe g#set_identifier identifier;
?
Rich.
--
Richard Jones, Virtualization Group, Red Hat http://people.redhat.com/~rjones
Read my programming and virtualization blog: http://rwmj.wordpress.com
virt-df lists disk usage of guests without needing to install any
software inside the virtual machine. Supports Linux and Windows.
http://people.redhat.com/~rjones/virt-df/
9:02 a.m.
On Tuesday 10 November 2015 20:39:29 Richard W.M. Jones wrote:
On Tue, Nov 10, 2015 at 08:25:54PM +0000, Richard W.M. Jones wrote:
> The 'may' function is a higher-order function (HOF) that replaces:
>
> match x with
> | None -> ()
> | Some x -> f x
>
> with:
>
> may f x
Another possibility is to break from lablgtk and call the
function 'maybe', as in:
g#set_trace trace;
g#set_verbose verbose;
maybe g#set_identifier identifier;
I'd personally find slightly more readable 'maybe', but 'may' can
also
be OK if it's what is being used also elsewhere (and people can be used
to).
--
Pino Toscano
3334
days inactive
3335
days old
8 comments
2 participants
participants (2)
-
Pino Toscano -
Richard W.M. Jones