Richard W.M. Jones
2017-Oct-08 21:26 UTC
[Libguestfs] [[PATCH v2 0/4] common/mlstdutils: Add Std_utils List and Option modules.
This time including the first commit ...
Richard W.M. Jones
2017-Oct-08 21:26 UTC
[Libguestfs] [PATCH v2 1/4] common/mlstdutils: Extend the List module.
We defined a number of functions on lists which are not provided by
the standard library. As with Char and String, let's extend List to
add these new functions to a List pseudo-module (really
Std_utils.List, but called List when you ‘open Std_utils’).
The initial exported functions are all List functions from OCaml 3.11
+ iteri + mapi. We can add other functions as needed.
---
common/mlstdutils/std_utils.ml | 4 ++++
common/mlstdutils/std_utils.mli | 47 +++++++++++++++++++++++++++++++++++++++++
2 files changed, 51 insertions(+)
diff --git a/common/mlstdutils/std_utils.ml b/common/mlstdutils/std_utils.ml
index fca76c208..67d449ac2 100644
--- a/common/mlstdutils/std_utils.ml
+++ b/common/mlstdutils/std_utils.ml
@@ -271,6 +271,10 @@ module String = struct
loop 0
end
+module List = struct
+ include List
+end
+
let (//) = Filename.concat
let quote = Filename.quote
diff --git a/common/mlstdutils/std_utils.mli b/common/mlstdutils/std_utils.mli
index 786f42591..f3f9c01cb 100644
--- a/common/mlstdutils/std_utils.mli
+++ b/common/mlstdutils/std_utils.mli
@@ -134,6 +134,53 @@ module String : sig
end
(** Override the String module from stdlib. *)
+module List : sig
+ val length : 'a list -> int
+ val hd : 'a list -> 'a
+ val tl : 'a list -> 'a list
+ val nth : 'a list -> int -> 'a
+ val rev : 'a list -> 'a list
+ val append : 'a list -> 'a list -> 'a list
+ val rev_append : 'a list -> 'a list -> 'a list
+ val concat : 'a list list -> 'a list
+ val flatten : 'a list list -> 'a list
+ val iter : ('a -> unit) -> 'a list -> unit
+ val iteri : (int -> 'a -> unit) -> 'a list -> unit
+ val map : ('a -> 'b) -> 'a list -> 'b list
+ val mapi : (int -> 'a -> 'b) -> 'a list -> 'b
list
+ val rev_map : ('a -> 'b) -> 'a list -> 'b list
+ val fold_left : ('a -> 'b -> 'a) -> 'a ->
'b list -> 'a
+ val fold_right : ('a -> 'b -> 'b) -> 'a list ->
'b -> 'b
+ val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b
list -> unit
+ val map2 : ('a -> 'b -> 'c) -> 'a list ->
'b list -> 'c list
+ val rev_map2 : ('a -> 'b -> 'c) -> 'a list ->
'b list -> 'c list
+ val fold_left2 : ('a -> 'b -> 'c -> 'a) ->
'a -> 'b list -> 'c list -> 'a
+ val fold_right2 : ('a -> 'b -> 'c -> 'c) ->
'a list -> 'b list -> 'c -> 'c
+ val for_all : ('a -> bool) -> 'a list -> bool
+ val exists : ('a -> bool) -> 'a list -> bool
+ val for_all2 : ('a -> 'b -> bool) -> 'a list ->
'b list -> bool
+ val exists2 : ('a -> 'b -> bool) -> 'a list ->
'b list -> bool
+ val mem : 'a -> 'a list -> bool
+ val memq : 'a -> 'a list -> bool
+ val find : ('a -> bool) -> 'a list -> 'a
+ val filter : ('a -> bool) -> 'a list -> 'a list
+ val find_all : ('a -> bool) -> 'a list -> 'a list
+ val partition : ('a -> bool) -> 'a list -> 'a list *
'a list
+ val assoc : 'a -> ('a * 'b) list -> 'b
+ val assq : 'a -> ('a * 'b) list -> 'b
+ val mem_assoc : 'a -> ('a * 'b) list -> bool
+ val mem_assq : 'a -> ('a * 'b) list -> bool
+ val remove_assoc : 'a -> ('a * 'b) list -> ('a *
'b) list
+ val remove_assq : 'a -> ('a * 'b) list -> ('a *
'b) list
+ val split : ('a * 'b) list -> 'a list * 'b list
+ val combine : 'a list -> 'b list -> ('a * 'b) list
+ val sort : ('a -> 'a -> int) -> 'a list -> 'a
list
+ val stable_sort : ('a -> 'a -> int) -> 'a list ->
'a list
+ val fast_sort : ('a -> 'a -> int) -> 'a list ->
'a list
+ val merge : ('a -> 'a -> int) -> 'a list -> 'a
list -> 'a list
+end
+(** Override the List module from stdlib. *)
+
val ( // ) : string -> string -> string
(** Concatenate directory and filename. *)
--
2.13.2
Richard W.M. Jones
2017-Oct-08 21:26 UTC
[Libguestfs] [PATCH v2 2/4] common/mlstdutils: Move list functions into extended List module.
However some existing functions had names which shadowed existing
functions in the List module, so I had to rename them:
assoc -> List.assoc_
append -> List.push_back_list
prepend -> List.push_front_list
This is an extension of the previous commit.
---
builder/builder.ml | 2 +-
builder/cmdline.ml | 8 +-
builder/downloader.ml | 10 +--
builder/languages.ml | 6 +-
builder/sigchecker.ml | 2 +-
builder/simplestreams_parser.ml | 6 +-
builder/yajl.ml | 2 +-
common/mlstdutils/std_utils.ml | 167 ++++++++++++++++++-----------------
common/mlstdutils/std_utils.mli | 149 +++++++++++++++----------------
common/mltools/getopt_tests.ml | 6 +-
common/mltools/tools_utils.ml | 2 +-
customize/customize_main.ml | 4 +-
customize/customize_run.ml | 2 +-
daemon/inspect.ml | 6 +-
daemon/inspect_fs_unix_fstab.ml | 2 +-
daemon/inspect_fs_windows.ml | 4 +-
daemon/listfs.ml | 12 +--
daemon/lvm.ml | 2 +-
daemon/mount.ml | 22 ++---
daemon/parted.ml | 14 +--
dib/cmdline.ml | 14 +--
dib/dib.ml | 2 +-
dib/elements.ml | 2 +-
dib/output_format.ml | 4 +-
generator/UEFI.ml | 2 +-
generator/customize.ml | 20 ++---
generator/tests_c_api.ml | 2 +-
resize/resize.ml | 4 +-
sparsify/cmdline.ml | 4 +-
sparsify/utils.ml | 2 +-
sysprep/main.ml | 4 +-
sysprep/sysprep_operation.ml | 4 +-
sysprep/sysprep_operation_script.ml | 2 +-
v2v/DOM.ml | 2 +-
v2v/cmdline.ml | 6 +-
v2v/convert_linux.ml | 16 ++--
v2v/convert_windows.ml | 2 +-
v2v/copy_to_local.ml | 10 +--
v2v/create_libvirt_xml.ml | 42 ++++-----
v2v/create_ovf.ml | 24 ++---
v2v/input_libvirt_vddk.ml | 2 +-
v2v/input_ova.ml | 2 +-
v2v/input_vmx.ml | 6 +-
v2v/linux_bootloaders.ml | 2 +-
v2v/linux_kernels.ml | 6 +-
v2v/modules_list.ml | 6 +-
v2v/output_glance.ml | 20 ++---
v2v/output_libvirt.ml | 2 +-
v2v/output_qemu.ml | 8 +-
v2v/output_rhv.ml | 2 +-
v2v/output_vdsm.ml | 4 +-
v2v/parse_libvirt_xml.ml | 8 +-
v2v/parse_ovf_from_ova.ml | 6 +-
v2v/parse_vmx.ml | 2 +-
v2v/test-harness/v2v_test_harness.ml | 6 +-
v2v/v2v.ml | 6 +-
v2v/vCenter.ml | 6 +-
57 files changed, 347 insertions(+), 343 deletions(-)
diff --git a/builder/builder.ml b/builder/builder.ml
index 3d0dbe7a8..8b4c20765 100644
--- a/builder/builder.ml
+++ b/builder/builder.ml
@@ -462,7 +462,7 @@ let main () in
(* Add a transition to the returned list. *)
- let tr task otags = push_front (task, weight task otags, otags) ret in
+ let tr task otags = List.push_front (task, weight task otags, otags) ret in
(* Since the final plan won't run in parallel, we don't only need
* to choose unique tempfiles per transition, so this is OK:
diff --git a/builder/cmdline.ml b/builder/cmdline.ml
index 8cbd4ca68..2b56bd9e6 100644
--- a/builder/cmdline.ml
+++ b/builder/cmdline.ml
@@ -73,7 +73,7 @@ let parse_cmdline () | "auto" ->
attach_format := None
| s -> attach_format := Some s
in
- let attach_disk s = push_front (!attach_format, s) attach in
+ let attach_disk s = List.push_front (!attach_format, s) attach in
let cache = ref Paths.xdg_cache_home in
let set_cache arg = cache := Some arg in
@@ -85,7 +85,7 @@ let parse_cmdline () let delete_on_failure = ref true in
let fingerprints = ref [] in
- let add_fingerprint arg = push_front arg fingerprints in
+ let add_fingerprint arg = List.push_front arg fingerprints in
let format = ref "" in
let gpg @@ -119,7 +119,7 @@ let parse_cmdline () let set_smp arg = smp :=
Some arg in
let sources = ref [] in
- let add_source arg = push_front arg sources in
+ let add_source arg = List.push_front arg sources in
let sync = ref true in
let warn_if_partition = ref true in
@@ -176,7 +176,7 @@ let parse_cmdline () let argspec = argspec @
customize_argspec in
let args = ref [] in
- let anon_fun s = push_front s args in
+ let anon_fun s = List.push_front s args in
let usage_msg sprintf (f_"\
%s: build virtual machine images quickly
diff --git a/builder/downloader.ml b/builder/downloader.ml
index b1119bae4..424c9cd34 100644
--- a/builder/downloader.ml
+++ b/builder/downloader.ml
@@ -103,8 +103,8 @@ and download_to t ?(progress_bar = false) ~proxy uri
filename (* Get the status code first to ensure the file exists. *)
let curl_h let curl_args = ref common_args in
- if not (verbose ()) then append curl_args quiet_args;
- append curl_args [
+ if not (verbose ()) then List.push_back_list curl_args quiet_args;
+ List.push_back_list curl_args [
"output", Some "/dev/null"; (* Write output to
/dev/null. *)
"head", None; (* Request only HEAD. *)
"write-out", Some "%{http_code}" (* HTTP status
code to stdout. *)
@@ -128,11 +128,11 @@ and download_to t ?(progress_bar = false) ~proxy uri
filename (* Now download the file. *)
let curl_h let curl_args = ref common_args in
- push_back curl_args ("output", Some filename_new);
+ List.push_back curl_args ("output", Some filename_new);
if not (verbose ()) then (
- if progress_bar then push_back curl_args ("progress-bar",
None)
- else append curl_args quiet_args
+ if progress_bar then List.push_back curl_args
("progress-bar", None)
+ else List.push_back_list curl_args quiet_args
);
Curl.create ~curl:t.curl ~tmpdir:t.tmpdir !curl_args in
diff --git a/builder/languages.ml b/builder/languages.ml
index e97b1e3da..18b9e1b41 100644
--- a/builder/languages.ml
+++ b/builder/languages.ml
@@ -30,10 +30,10 @@ let split_locale loc let territory = match_or_empty 3
in
(match territory with
| "" -> ()
- | territory -> push_front (lang ^ "_" ^ territory) l);
- push_front lang l;
+ | territory -> List.push_front (lang ^ "_" ^ territory) l);
+ List.push_front lang l;
);
- push_front "" l;
+ List.push_front "" l;
List.rev !l
let languages () diff --git a/builder/sigchecker.ml b/builder/sigchecker.ml
index d7fba405b..088674d66 100644
--- a/builder/sigchecker.ml
+++ b/builder/sigchecker.ml
@@ -82,7 +82,7 @@ let import_keyfile ~gpg ~gpghome ~tmpdir ?(trust = true)
keyfile (match !current with
| None -> ()
| Some k ->
- if String.is_suffix id k then push_front id subkeys;
+ if String.is_suffix id k then List.push_front id subkeys;
current := None
)
| _ -> ()
diff --git a/builder/simplestreams_parser.ml b/builder/simplestreams_parser.ml
index 75592e377..a37d5a8a3 100644
--- a/builder/simplestreams_parser.ml
+++ b/builder/simplestreams_parser.ml
@@ -60,7 +60,7 @@ let get_index ~downloader ~sigchecker { Sources.uri; proxy }
uri format;
let index = Array.to_list (object_get_object "index" tree) in
- filter_map (
+ List.filter_map (
fun (_, desc) ->
let format = object_get_string "format" desc in
let datatype = object_get_string "datatype" desc in
@@ -81,11 +81,11 @@ let get_index ~downloader ~sigchecker { Sources.uri; proxy }
let products_node = object_get_object "products" tree in
let products = Array.to_list products_node in
- filter_map (
+ List.filter_map (
fun (prod, prod_desc) ->
let arch = object_get_string "arch" prod_desc in
let prods = Array.to_list (object_get_object "versions"
prod_desc) in
- let prods = filter_map (
+ let prods = List.filter_map (
fun (rel, rel_desc) ->
let pubname = objects_get_string "pubname" [rel_desc;
prod_desc] in
let items = object_find_object "items" rel_desc in
diff --git a/builder/yajl.ml b/builder/yajl.ml
index a555baa22..d95f3932a 100644
--- a/builder/yajl.ml
+++ b/builder/yajl.ml
@@ -55,7 +55,7 @@ let object_find_object key yv | _ -> error (f_"the
value for the key ‘%s’ is not an object") key
let object_find_objects fn = function
- | Yajl_object o -> filter_map fn (Array.to_list o)
+ | Yajl_object o -> List.filter_map fn (Array.to_list o)
| _ -> error (f_"the value is not an object")
let object_get_object key yv diff --git a/common/mlstdutils/std_utils.ml
b/common/mlstdutils/std_utils.ml
index 67d449ac2..558b1e3e2 100644
--- a/common/mlstdutils/std_utils.ml
+++ b/common/mlstdutils/std_utils.ml
@@ -273,6 +273,90 @@ end
module List = struct
include List
+
+ (* Drop elements from a list while a predicate is true. *)
+ let rec dropwhile f = function
+ | [] -> []
+ | x :: xs when f x -> dropwhile f xs
+ | xs -> xs
+
+ (* Take elements from a list while a predicate is true. *)
+ let rec takewhile f = function
+ | x :: xs when f x -> x :: takewhile f xs
+ | _ -> []
+
+ let rec filter_map f = function
+ | [] -> []
+ | x :: xs ->
+ match f x with
+ | Some y -> y :: filter_map f xs
+ | None -> filter_map f xs
+
+ let rec find_map f = function
+ | [] -> raise Not_found
+ | x :: xs ->
+ match f x with
+ | Some y -> y
+ | None -> find_map f xs
+
+ let rec combine3 xs ys zs + match xs, ys, zs with
+ | [], [], [] -> []
+ | x::xs, y::ys, z::zs -> (x, y, z) :: combine3 xs ys zs
+ | _ -> invalid_arg "combine3"
+
+ let rec assoc_ ?(cmp = compare) ~default x = function
+ | [] -> default
+ | (y, y') :: _ when cmp x y = 0 -> y'
+ | _ :: ys -> assoc_ ~cmp ~default x ys
+
+ let uniq ?(cmp = Pervasives.compare) xs + let rec loop acc = function
+ | [] -> acc
+ | [x] -> x :: acc
+ | x :: (y :: _ as xs) when cmp x y = 0 ->
+ loop acc xs
+ | x :: (y :: _ as xs) ->
+ loop (x :: acc) xs
+ in
+ List.rev (loop [] xs)
+
+ (* This is present in OCaml 4.04, so we can remove it when
+ * we depend on OCaml >= 4.04.
+ *)
+ let sort_uniq ?(cmp = Pervasives.compare) xs + let xs = List.sort cmp
xs in
+ let xs = uniq ~cmp xs in
+ xs
+
+ let remove_duplicates xs + let h = Hashtbl.create (List.length xs) in
+ let rec loop = function
+ | [] -> []
+ | x :: xs when Hashtbl.mem h x -> xs
+ | x :: xs -> Hashtbl.add h x true; x :: loop xs
+ in
+ loop xs
+
+ let push_back xsp x = xsp := !xsp @ [x]
+ let push_front x xsp = xsp := x :: !xsp
+ let pop_back xsp + let x, xs + match List.rev !xsp with
+ | x :: xs -> x, xs
+ | [] -> failwith "pop" in
+ xsp := List.rev xs;
+ x
+ let pop_front xsp + let x, xs + match !xsp with
+ | x :: xs -> x, xs
+ | [] -> failwith "shift" in
+ xsp := xs;
+ x
+
+ let push_back_list xsp xs = xsp := !xsp @ xs
+ let push_front_list xs xsp = xsp := xs @ !xsp
end
let (//) = Filename.concat
@@ -489,87 +573,6 @@ and _wrap_find_next_break i len str
and output_spaces chan n = for i = 0 to n-1 do output_char chan ' '
done
-(* Drop elements from a list while a predicate is true. *)
-let rec dropwhile f = function
- | [] -> []
- | x :: xs when f x -> dropwhile f xs
- | xs -> xs
-
-(* Take elements from a list while a predicate is true. *)
-let rec takewhile f = function
- | x :: xs when f x -> x :: takewhile f xs
- | _ -> []
-
-let rec filter_map f = function
- | [] -> []
- | x :: xs ->
- match f x with
- | Some y -> y :: filter_map f xs
- | None -> filter_map f xs
-
-let rec find_map f = function
- | [] -> raise Not_found
- | x :: xs ->
- match f x with
- | Some y -> y
- | None -> find_map f xs
-
-let rec combine3 xs ys zs - match xs, ys, zs with
- | [], [], [] -> []
- | x::xs, y::ys, z::zs -> (x, y, z) :: combine3 xs ys zs
- | _ -> invalid_arg "combine3"
-
-let rec assoc ?(cmp = compare) ~default x = function
- | [] -> default
- | (y, y') :: _ when cmp x y = 0 -> y'
- | _ :: ys -> assoc ~cmp ~default x ys
-
-let uniq ?(cmp = Pervasives.compare) xs - let rec loop acc = function
- | [] -> acc
- | [x] -> x :: acc
- | x :: (y :: _ as xs) when cmp x y = 0 ->
- loop acc xs
- | x :: (y :: _ as xs) ->
- loop (x :: acc) xs
- in
- List.rev (loop [] xs)
-
-let sort_uniq ?(cmp = Pervasives.compare) xs - let xs = List.sort cmp xs in
- let xs = uniq ~cmp xs in
- xs
-
-let remove_duplicates xs - let h = Hashtbl.create (List.length xs) in
- let rec loop = function
- | [] -> []
- | x :: xs when Hashtbl.mem h x -> xs
- | x :: xs -> Hashtbl.add h x true; x :: loop xs
- in
- loop xs
-
-let push_back xsp x = xsp := !xsp @ [x]
-let push_front x xsp = xsp := x :: !xsp
-let pop_back xsp - let x, xs - match List.rev !xsp with
- | x :: xs -> x, xs
- | [] -> failwith "pop" in
- xsp := List.rev xs;
- x
-let pop_front xsp - let x, xs - match !xsp with
- | x :: xs -> x, xs
- | [] -> failwith "shift" in
- xsp := xs;
- x
-
-let append xsp xs = xsp := !xsp @ xs
-let prepend xs xsp = xsp := xs @ !xsp
-
let unique = let i = ref 0 in fun () -> incr i; !i
let may f = function
@@ -593,7 +596,7 @@ let which executable let paths try String.nsplit
":" (Sys.getenv "PATH")
with Not_found -> [] in
- let paths = filter_map (
+ let paths = List.filter_map (
fun p ->
let path = p // executable in
try Unix.access path [Unix.X_OK]; Some path
diff --git a/common/mlstdutils/std_utils.mli b/common/mlstdutils/std_utils.mli
index f3f9c01cb..3895a41cc 100644
--- a/common/mlstdutils/std_utils.mli
+++ b/common/mlstdutils/std_utils.mli
@@ -178,6 +178,81 @@ module List : sig
val stable_sort : ('a -> 'a -> int) -> 'a list ->
'a list
val fast_sort : ('a -> 'a -> int) -> 'a list ->
'a list
val merge : ('a -> 'a -> int) -> 'a list -> 'a
list -> 'a list
+
+ val dropwhile : ('a -> bool) -> 'a list -> 'a list
+ (** [dropwhile f xs] drops leading elements from [xs] until
+ [f] returns false. *)
+ val takewhile : ('a -> bool) -> 'a list -> 'a list
+ (** [takewhile f xs] takes leading elements from [xs] until
+ [f] returns false.
+
+ For any list [xs] and function [f],
+ [xs = takewhile f xs @ dropwhile f xs] *)
+ val filter_map : ('a -> 'b option) -> 'a list ->
'b list
+ (** [filter_map f xs] applies [f] to each element of [xs]. If
+ [f x] returns [Some y] then [y] is added to the returned list. *)
+ val find_map : ('a -> 'b option) -> 'a list -> 'b
+ (** [find_map f xs] applies [f] to each element of [xs] until
+ [f x] returns [Some y]. It returns [y]. If we exhaust the
+ list then this raises [Not_found]. *)
+
+ val combine3 : 'a list -> 'b list -> 'c list ->
('a * 'b * 'c) list
+ (** Like {!List.combine} but for triples.
+ All lists must be the same length. *)
+
+ val assoc_ : ?cmp:('a -> 'a -> int) -> default:'b
-> 'a -> ('a * 'b) list -> 'b
+ (** Like {!assoc} but with a user-defined comparison function, and
+ instead of raising [Not_found], it returns the [~default] value. *)
+
+ val uniq : ?cmp:('a -> 'a -> int) -> 'a list ->
'a list
+ (** Uniquify a list (the list must be sorted first). *)
+
+ val sort_uniq : ?cmp:('a -> 'a -> int) -> 'a list
-> 'a list
+ (** Sort and uniquify a list. *)
+
+ val remove_duplicates : 'a list -> 'a list
+ (** Remove duplicates from an unsorted list; useful when the order
+ of the elements matter.
+
+ Please use [sort_uniq] when the order does not matter. *)
+
+ val push_back : 'a list ref -> 'a -> unit
+ val push_front : 'a -> 'a list ref -> unit
+ val pop_back : 'a list ref -> 'a
+ val pop_front : 'a list ref -> 'a
+ (** Imperative list manipulation functions, similar to C++ STL
+ functions with the same names. (Although the names are similar,
+ the computational complexity of the functions is quite different.)
+
+ These operate on list references, and each function modifies the
+ list reference that is passed to it.
+
+ [push_back xsp x] appends the element [x] to the end of the list
+ [xsp]. This function is not tail-recursive.
+
+ [push_front x xsp] prepends the element [x] to the head of the
+ list [xsp]. (The arguments are reversed compared to the same Perl
+ function, but OCaml is type safe so that's OK.)
+
+ [pop_back xsp] removes the last element of the list [xsp] and
+ returns it. The list is modified to become the list minus the
+ final element. If a zero-length list is passed in, this raises
+ [Failure "pop_back"]. This function is not tail-recursive.
+
+ [pop_front xsp] removes the head element of the list [xsp] and
+ returns it. The list is modified to become the tail of the list.
+ If a zero-length list is passed in, this raises [Failure
+ "pop_front"]. *)
+
+ val push_back_list : 'a list ref -> 'a list -> unit
+ val push_front_list : 'a list -> 'a list ref -> unit
+ (** More imperative list manipulation functions.
+
+ [push_back_list] is like {!push_back} above, except it appends
+ a list to the list reference. This function is not tail-recursive.
+
+ [push_front_list] is like {!push_front} above, except it prepends
+ a list to the list reference. *)
end
(** Override the List module from stdlib. *)
@@ -242,80 +317,6 @@ val wrap : ?chan:out_channel -> ?indent:int -> string
-> unit
val output_spaces : out_channel -> int -> unit
(** Write [n] spaces to [out_channel]. *)
-val dropwhile : ('a -> bool) -> 'a list -> 'a list
-(** [dropwhile f xs] drops leading elements from [xs] until
- [f] returns false. *)
-val takewhile : ('a -> bool) -> 'a list -> 'a list
-(** [takewhile f xs] takes leading elements from [xs] until
- [f] returns false.
-
- For any list [xs] and function [f],
- [xs = takewhile f xs @ dropwhile f xs] *)
-val filter_map : ('a -> 'b option) -> 'a list -> 'b
list
-(** [filter_map f xs] applies [f] to each element of [xs]. If
- [f x] returns [Some y] then [y] is added to the returned list. *)
-val find_map : ('a -> 'b option) -> 'a list -> 'b
-(** [find_map f xs] applies [f] to each element of [xs] until
- [f x] returns [Some y]. It returns [y]. If we exhaust the
- list then this raises [Not_found]. *)
-
-val combine3 : 'a list -> 'b list -> 'c list -> ('a *
'b * 'c) list
-(** Like {!List.combine} but for triples. All lists must be the same length.
*)
-
-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 uniq : ?cmp:('a -> 'a -> int) -> 'a list -> 'a
list
-(** Uniquify a list (the list must be sorted first). *)
-
-val sort_uniq : ?cmp:('a -> 'a -> int) -> 'a list ->
'a list
-(** Sort and uniquify a list. *)
-
-val remove_duplicates : 'a list -> 'a list
-(** Remove duplicates from an unsorted list; useful when the order
- of the elements matter.
-
- Please use [sort_uniq] when the order does not matter. *)
-
-val push_back : 'a list ref -> 'a -> unit
-val push_front : 'a -> 'a list ref -> unit
-val pop_back : 'a list ref -> 'a
-val pop_front : 'a list ref -> 'a
-(** Imperative list manipulation functions, similar to C++ STL
- functions with the same names. (Although the names are similar,
- the computational complexity of the functions is quite different.)
-
- These operate on list references, and each function modifies the
- list reference that is passed to it.
-
- [push_back xsp x] appends the element [x] to the end of the list
- [xsp]. This function is not tail-recursive.
-
- [push_front x xsp] prepends the element [x] to the head of the
- list [xsp]. (The arguments are reversed compared to the same Perl
- function, but OCaml is type safe so that's OK.)
-
- [pop_back xsp] removes the last element of the list [xsp] and
- returns it. The list is modified to become the list minus the
- final element. If a zero-length list is passed in, this raises
- [Failure "pop_back"]. This function is not tail-recursive.
-
- [pop_front xsp] removes the head element of the list [xsp] and
- returns it. The list is modified to become the tail of the list.
- If a zero-length list is passed in, this raises [Failure
- "pop_front"]. *)
-
-val append : 'a list ref -> 'a list -> unit
-val prepend : 'a list -> 'a list ref -> unit
-(** More imperative list manipulation functions.
-
- [append] is like {!push_back} above, except it appends a list to
- the list reference. This function is not tail-recursive.
-
- [prepend] is like {!push_front} above, except it prepends a list
- to the list reference. *)
-
val unique : unit -> int
(** Returns a unique number each time called. *)
diff --git a/common/mltools/getopt_tests.ml b/common/mltools/getopt_tests.ml
index 1314d3bca..751bf1d5f 100644
--- a/common/mltools/getopt_tests.ml
+++ b/common/mltools/getopt_tests.ml
@@ -27,13 +27,13 @@ open Tools_utils
open Getopt.OptionName
let adds = ref []
-let add_string = push_back adds
+let add_string = List.push_back adds
let anons = ref []
-let anon_fun = push_back anons
+let anon_fun = List.push_back anons
let ints = ref []
-let add_int = push_back ints
+let add_int = List.push_back ints
let clear_flag = ref true
let set_flag = ref false
diff --git a/common/mltools/tools_utils.ml b/common/mltools/tools_utils.ml
index 9049ab3f1..f66ee9f50 100644
--- a/common/mltools/tools_utils.ml
+++ b/common/mltools/tools_utils.ml
@@ -286,7 +286,7 @@ let rec run_commands ?(echo_cmd = true) cmds
res.(i) <- code;
None
) cmds in
- let pids = filter_map identity pids in
+ let pids = List.filter_map identity pids in
let pids = ref pids in
while !pids <> [] do
let pid, stat = Unix.waitpid [] 0 in
diff --git a/customize/customize_main.ml b/customize/customize_main.ml
index 8bd197b83..f6ffc872d 100644
--- a/customize/customize_main.ml
+++ b/customize/customize_main.ml
@@ -39,7 +39,7 @@ let main () | "auto" -> attach_format :=
None
| s -> attach_format := Some s
in
- let attach_disk s = push_front (!attach_format, s) attach in
+ let attach_disk s = List.push_front (!attach_format, s) attach in
let domain = ref None in
let dryrun = ref false in
let files = ref [] in
@@ -63,7 +63,7 @@ let main () error (f_"error parsing URI
'%s'. Look for error messages printed above.")
arg in
let format = match !format with "auto" -> None | fmt ->
Some fmt in
- push_front (uri, format) files;
+ List.push_front (uri, format) files;
format_consumed := true
and set_domain dom if !domain <> None then
diff --git a/customize/customize_run.ml b/customize/customize_run.ml
index b42dd774d..f37e283f3 100644
--- a/customize/customize_run.ml
+++ b/customize/customize_run.ml
@@ -66,7 +66,7 @@ let run (g : G.guestfs) root (ops : ops) * Also catch
errors and dump the log file completely on error.
*)
let env_vars - filter_map (
+ List.filter_map (
fun name ->
try Some (sprintf "export %s=%s" name (quote (Sys.getenv
name)))
with Not_found -> None
diff --git a/daemon/inspect.ml b/daemon/inspect.ml
index ecc45e7c7..11e977947 100644
--- a/daemon/inspect.ml
+++ b/daemon/inspect.ml
@@ -33,7 +33,7 @@ let rec inspect_os () let fses = Listfs.list_filesystems ()
in
let fses - filter_map (
+ List.filter_map (
fun (mountable, vfs_type) ->
Inspect_fs.check_for_filesystem_on mountable vfs_type
) fses in
@@ -228,7 +228,7 @@ and inspect_get_roots () let fses =
!Inspect_types.inspect_fses in
let roots - filter_map (
+ List.filter_map (
fun fs -> try Some (root_of_fs fs) with Invalid_argument _ -> None
) fses in
if verbose () then (
@@ -257,7 +257,7 @@ and inspect_get_mountpoints root_mountable if fstab = []
then
[ "/", root_mountable ]
else (
- filter_map (
+ List.filter_map (
fun (mountable, mp) ->
if String.length mp > 0 && mp.[0] = '/' then
Some (mp, mountable)
diff --git a/daemon/inspect_fs_unix_fstab.ml b/daemon/inspect_fs_unix_fstab.ml
index e3c7fd1cd..658e0cf10 100644
--- a/daemon/inspect_fs_unix_fstab.ml
+++ b/daemon/inspect_fs_unix_fstab.ml
@@ -52,7 +52,7 @@ and check_fstab_aug mdadm_conf root_mountable os_type aug
let path = "/files/etc/fstab/*[label() != '#comment']" in
let entries = aug_matches_noerrors aug path in
- filter_map (check_fstab_entry md_map root_mountable os_type aug) entries
+ List.filter_map (check_fstab_entry md_map root_mountable os_type aug) entries
and check_fstab_entry md_map root_mountable os_type aug entry if verbose ()
then
diff --git a/daemon/inspect_fs_windows.ml b/daemon/inspect_fs_windows.ml
index 78af7f048..f471835cc 100644
--- a/daemon/inspect_fs_windows.ml
+++ b/daemon/inspect_fs_windows.ml
@@ -110,7 +110,7 @@ and get_windows_systemroot_from_boot_ini boot_ini_path
| Some oses ->
(* Rewrite multi|scsi lines, removing any which we cannot parse. *)
let oses - filter_map (
+ List.filter_map (
fun line ->
if PCRE.matches re_boot_ini_os line then (
let ctrlr_type = PCRE.sub 1
@@ -312,7 +312,7 @@ and get_drive_mappings h root data let values =
Hivex.node_values h node in
let values = Array.to_list values in
let values - filter_map (
+ List.filter_map (
fun value ->
let key = Hivex.value_key h value in
let keylen = String.length key in
diff --git a/daemon/listfs.ml b/daemon/listfs.ml
index 610a1ea78..1ccd3bead 100644
--- a/daemon/listfs.ml
+++ b/daemon/listfs.ml
@@ -44,14 +44,14 @@ let rec list_filesystems () ) devices in
(* Use vfs-type to check for filesystems on devices. *)
- let ret = filter_map check_with_vfs_type devices in
+ let ret = List.filter_map check_with_vfs_type devices in
(* Use vfs-type to check for filesystems on partitions, but
* ignore MBR partition type 42 used by LDM.
*)
let ret ret @
- filter_map (
+ List.filter_map (
fun part ->
if not has_ldm || not (is_mbr_partition_type_42 part) then
check_with_vfs_type part
@@ -60,14 +60,14 @@ let rec list_filesystems () ) partitions in
(* Use vfs-type to check for filesystems on md devices. *)
- let ret = ret @ filter_map check_with_vfs_type mds in
+ let ret = ret @ List.filter_map check_with_vfs_type mds in
(* LVM. *)
let ret if has_lvm2 then (
let lvs = Lvm.lvs () in
(* Use vfs-type to check for filesystems on LVs. *)
- ret @ filter_map check_with_vfs_type lvs
+ ret @ List.filter_map check_with_vfs_type lvs
)
else ret in
@@ -78,8 +78,8 @@ let rec list_filesystems () let ldmparts =
Ldm.list_ldm_partitions () in
(* Use vfs-type to check for filesystems on Windows dynamic disks. *)
ret @
- filter_map check_with_vfs_type ldmvols @
- filter_map check_with_vfs_type ldmparts
+ List.filter_map check_with_vfs_type ldmvols @
+ List.filter_map check_with_vfs_type ldmparts
)
else ret in
diff --git a/daemon/lvm.ml b/daemon/lvm.ml
index 4210c2fb3..39c6d365b 100644
--- a/daemon/lvm.ml
+++ b/daemon/lvm.ml
@@ -84,7 +84,7 @@ and filter_convert_old_lvs_output out let lines =
List.filter ((<>) "") lines in
let lines = List.filter ((<>) "unknown device") lines in
- let lines = filter_map (
+ let lines = List.filter_map (
fun line ->
match String.nsplit ":" line with
| [ lv_attr; vg_name; lv_name ] ->
diff --git a/daemon/mount.ml b/daemon/mount.ml
index fbf4ddc39..db530b138 100644
--- a/daemon/mount.ml
+++ b/daemon/mount.ml
@@ -34,26 +34,26 @@ let mount_vfs options vfs mountable mountpoint (match
options, mountable.m_type with
| (None | Some ""), (MountableDevice | MountablePath) -> ()
| Some options, (MountableDevice | MountablePath) ->
- push_back args "-o";
- push_back args options
+ List.push_back args "-o";
+ List.push_back args options
| (None | Some ""), MountableBtrfsVol subvol ->
- push_back args "-o";
- push_back args ("subvol=" ^ subvol)
+ List.push_back args "-o";
+ List.push_back args ("subvol=" ^ subvol)
| Some options, MountableBtrfsVol subvol ->
- push_back args "-o";
- push_back args ("subvol=" ^ subvol ^ "," ^ options)
+ List.push_back args "-o";
+ List.push_back args ("subvol=" ^ subvol ^ "," ^
options)
);
(* -t vfs *)
(match vfs with
| None | Some "" -> ()
| Some t ->
- push_back args "-t";
- push_back args t
+ List.push_back args "-t";
+ List.push_back args t
);
- push_back args mountable.m_device;
- push_back args mp;
+ List.push_back args mountable.m_device;
+ List.push_back args mp;
ignore (command "mount" !args)
@@ -105,7 +105,7 @@ let rec umount_all () (String.is_prefix mp
sysroot &&
String.length mp > sysroot_len &&
mp.[sysroot_len] = '/') then
- push_front mp mps
+ List.push_front mp mps
)
) info;
diff --git a/daemon/parted.ml b/daemon/parted.ml
index 2e8e744d0..7721b64ca 100644
--- a/daemon/parted.ml
+++ b/daemon/parted.ml
@@ -65,13 +65,13 @@ let print_partition_table_machine_readable device
udev_settle ();
let args = ref [] in
- push_back args "-m";
- push_back args "-s";
- push_back args "--";
- push_back args device;
- push_back args "unit";
- push_back args "b";
- push_back args "print";
+ List.push_back args "-m";
+ List.push_back args "-s";
+ List.push_back args "--";
+ List.push_back args device;
+ List.push_back args "unit";
+ List.push_back args "b";
+ List.push_back args "print";
let out try command "parted" !args
diff --git a/dib/cmdline.ml b/dib/cmdline.ml
index 9f0a70a72..d013a181e 100644
--- a/dib/cmdline.ml
+++ b/dib/cmdline.ml
@@ -71,16 +71,16 @@ read the man page virt-dib(1).
prog in
let elements = ref [] in
- let append_element element = push_front element elements in
+ let append_element element = List.push_front element elements in
let excluded_elements = ref [] in
- let append_excluded_element element = push_front element excluded_elements in
+ let append_excluded_element element = List.push_front element
excluded_elements in
let element_paths = ref [] in
- let append_element_path arg = push_front arg element_paths in
+ let append_element_path arg = List.push_front arg element_paths in
let excluded_scripts = ref [] in
- let append_excluded_script arg = push_front arg excluded_scripts in
+ let append_excluded_script arg = List.push_front arg excluded_scripts in
let debug = ref 0 in
let set_debug arg @@ -107,7 +107,7 @@ read the man page virt-dib(1).
let formats = ref None in
let set_format arg - let fmts = remove_duplicates (String.nsplit
"," arg) in
+ let fmts = List.remove_duplicates (String.nsplit "," arg) in
let fmtset List.fold_left (
fun fmtset fmt ->
@@ -118,7 +118,7 @@ read the man page virt-dib(1).
formats := Some fmtset in
let envvars = ref [] in
- let append_envvar arg = push_front arg envvars in
+ let append_envvar arg = List.push_front arg envvars in
let use_base = ref true in
@@ -149,7 +149,7 @@ read the man page virt-dib(1).
let extra_packages = ref [] in
let append_extra_packages arg - prepend (List.rev (String.nsplit
"," arg)) extra_packages in
+ List.push_front_list (List.rev (String.nsplit "," arg))
extra_packages in
let checksum = ref false in
diff --git a/dib/dib.ml b/dib/dib.ml
index 9429d2371..f8595636a 100644
--- a/dib/dib.ml
+++ b/dib/dib.ml
@@ -41,7 +41,7 @@ let exclude_elements elements = function
| excl -> StringSet.filter (not_in_list excl) elements
let read_envvars envvars - filter_map (
+ List.filter_map (
fun var ->
let i = String.find var "=" in
if i = -1 then (
diff --git a/dib/elements.ml b/dib/elements.ml
index d8eb6c145..5a904baef 100644
--- a/dib/elements.ml
+++ b/dib/elements.ml
@@ -82,7 +82,7 @@ let load_scripts (g : Guestfs.guestfs) path | _ ->
false
) listing in
let scripts = List.filter (fun x -> valid_script_name x.Guestfs.name)
scripts in
- filter_map (
+ List.filter_map (
fun x ->
let { Guestfs.st_mode = mode } = g#statns (path ^ "/" ^
x.Guestfs.name) in
if mode &^ 0o111_L > 0_L then Some x.Guestfs.name
diff --git a/dib/output_format.ml b/dib/output_format.ml
index 79a90ae35..a39e807fe 100644
--- a/dib/output_format.ml
+++ b/dib/output_format.ml
@@ -69,7 +69,7 @@ let set_cardinal set FormatSet.cardinal set
let register_format op - push_front op all_formats
+ List.push_front op all_formats
let baked = ref false
let rec bake () @@ -183,7 +183,7 @@ let get_filenames ~formats image_name (*
Run the formats in alphabetical, rather than random order. *)
let formats = List.sort compare_formats (FormatSet.elements formats) in
- filter_map (
+ List.filter_map (
function
| { output_to_file = true; name } ->
Some (output_filename image_name name)
diff --git a/generator/UEFI.ml b/generator/UEFI.ml
index 17418f473..5161e28ee 100644
--- a/generator/UEFI.ml
+++ b/generator/UEFI.ml
@@ -77,7 +77,7 @@ let firmware = [
[];
]
-let arches = sort_uniq (List.map (fun (arch, _, _, _, _) -> arch) firmware)
+let arches = List.sort_uniq (List.map (fun (arch, _, _, _, _) -> arch)
firmware)
let generate_uefi_c () generate_header CStyle LGPLv2plus;
diff --git a/generator/customize.ml b/generator/customize.ml
index 75984c9d5..c278347c1 100644
--- a/generator/customize.ml
+++ b/generator/customize.ml
@@ -688,7 +688,7 @@ let rec argspec () op_shortdesc = shortdesc;
op_pod_longdesc = longdesc } ->
pr " (\n";
pr " [ L\"%s\" ],\n" name;
- pr " Getopt.Unit (fun () -> push_front %s ops),\n"
discrim;
+ pr " Getopt.Unit (fun () -> List.push_front %s ops),\n"
discrim;
pr " s_\"%s\"\n" shortdesc;
pr " ),\n";
pr " None, %S;\n" longdesc
@@ -696,7 +696,7 @@ let rec argspec () op_shortdesc = shortdesc;
op_pod_longdesc = longdesc } ->
pr " (\n";
pr " [ L\"%s\" ],\n" name;
- pr " Getopt.String (s_\"%s\", fun s -> push_front
(%s s) ops),\n" v discrim;
+ pr " Getopt.String (s_\"%s\", fun s ->
List.push_front (%s s) ops),\n" v discrim;
pr " s_\"%s\"\n" shortdesc;
pr " ),\n";
pr " Some %S, %S;\n" v longdesc
@@ -708,7 +708,7 @@ let rec argspec () pr "
s_\"%s\",\n" v;
pr " fun s ->\n";
pr " let p = split_string_pair \"%s\" s
in\n" name;
- pr " push_front (%s p) ops\n" discrim;
+ pr " List.push_front (%s p) ops\n" discrim;
pr " ),\n";
pr " s_\"%s\"\n" shortdesc;
pr " ),\n";
@@ -721,7 +721,7 @@ let rec argspec () pr "
s_\"%s\",\n" v;
pr " fun s ->\n";
pr " let ss = split_string_list s in\n";
- pr " push_front (%s ss) ops\n" discrim;
+ pr " List.push_front (%s ss) ops\n" discrim;
pr " ),\n";
pr " s_\"%s\"\n" shortdesc;
pr " ),\n";
@@ -734,7 +734,7 @@ let rec argspec () pr "
s_\"%s\",\n" v;
pr " fun s ->\n";
pr " let ss = split_links_list \"%s\" s
in\n" name;
- pr " push_front (%s ss) ops\n" discrim;
+ pr " List.push_front (%s ss) ops\n" discrim;
pr " ),\n";
pr " s_\"%s\"\n" shortdesc;
pr " ),\n";
@@ -747,7 +747,7 @@ let rec argspec () pr "
s_\"%s\",\n" v;
pr " fun s ->\n";
pr " let sel = Password.parse_selector s in\n";
- pr " push_front (%s sel) ops\n" discrim;
+ pr " List.push_front (%s sel) ops\n" discrim;
pr " ),\n";
pr " s_\"%s\"\n" shortdesc;
pr " ),\n";
@@ -761,7 +761,7 @@ let rec argspec () pr " fun s
->\n";
pr " let user, sel = split_string_pair \"%s\" s
in\n" name;
pr " let sel = Password.parse_selector sel in\n";
- pr " push_front (%s (user, sel)) ops\n" discrim;
+ pr " List.push_front (%s (user, sel)) ops\n" discrim;
pr " ),\n";
pr " s_\"%s\"\n" shortdesc;
pr " ),\n";
@@ -775,7 +775,7 @@ let rec argspec () pr " fun s
->\n";
pr " let user, selstr = String.split \":\" s
in\n";
pr " let sel = Ssh_key.parse_selector selstr in\n";
- pr " push_front (%s (user, sel)) ops\n" discrim;
+ pr " List.push_front (%s (user, sel)) ops\n" discrim;
pr " ),\n";
pr " s_\"%s\"\n" shortdesc;
pr " ),\n";
@@ -788,7 +788,7 @@ let rec argspec () pr "
s_\"%s\",\n" v;
pr " fun s ->\n";
pr " %s s;\n" fn;
- pr " push_front (%s s) ops\n" discrim;
+ pr " List.push_front (%s s) ops\n" discrim;
pr " ),\n";
pr " s_\"%s\"\n" shortdesc;
pr " ),\n";
@@ -801,7 +801,7 @@ let rec argspec () pr "
s_\"%s\",\n" v;
pr " fun s ->\n";
pr " let sel = Subscription_manager.parse_pool_selector s
in\n";
- pr " push_front (%s sel) ops\n" discrim;
+ pr " List.push_front (%s sel) ops\n" discrim;
pr " ),\n";
pr " s_\"%s\"\n" shortdesc;
pr " ),\n";
diff --git a/generator/tests_c_api.ml b/generator/tests_c_api.ml
index 33da61181..b569b9317 100644
--- a/generator/tests_c_api.ml
+++ b/generator/tests_c_api.ml
@@ -70,7 +70,7 @@ let rec generate_c_api_tests () let hash : (string, bool)
Hashtbl.t = Hashtbl.create 13 in
List.iter (
fun { tests } ->
- let seqs = filter_map (
+ let seqs = List.filter_map (
function
| (_, (Always|IfAvailable _|IfNotCrossAppliance), test, cleanup) ->
Some (seq_of_test test @ cleanup)
diff --git a/resize/resize.ml b/resize/resize.ml
index f428f3ebe..4eeb0a170 100644
--- a/resize/resize.ml
+++ b/resize/resize.ml
@@ -158,7 +158,7 @@ let main () lv_expands, machine_readable,
ntfsresize_force, output_format,
resizes, resizes_force, shrink, sparse, unknown_fs_mode
- let add xs s = push_front s xs in
+ let add xs s = List.push_front s xs in
let align_first = ref "auto" in
let alignment = ref 128 in
@@ -214,7 +214,7 @@ let main ()
s_"Behaviour on expand unknown filesystems (default: warn)";
] in
let disks = ref [] in
- let anon_fun s = push_front s disks in
+ let anon_fun s = List.push_front s disks in
let usage_msg sprintf (f_"\
%s: resize a virtual machine disk
diff --git a/sparsify/cmdline.ml b/sparsify/cmdline.ml
index 521f6733d..f435bbf5e 100644
--- a/sparsify/cmdline.ml
+++ b/sparsify/cmdline.ml
@@ -43,7 +43,7 @@ and mode_t and check_t = [`Ignore|`Continue|`Warn|`Fail]
let parse_cmdline () - let add xs s = push_front s xs in
+ let add xs s = List.push_front s xs in
let check_tmpdir = ref `Warn in
let set_check_tmpdir = function
@@ -78,7 +78,7 @@ let parse_cmdline () [ L"zero" ],
Getopt.String (s_"fs", add zeroes), s_"Zero filesystem";
] in
let disks = ref [] in
- let anon_fun s = push_front s disks in
+ let anon_fun s = List.push_front s disks in
let usage_msg sprintf (f_"\
%s: sparsify a virtual machine disk
diff --git a/sparsify/utils.ml b/sparsify/utils.ml
index facf466a8..7f0c02cf6 100644
--- a/sparsify/utils.ml
+++ b/sparsify/utils.ml
@@ -27,7 +27,7 @@ module G = Guestfs
(* Return true if the filesystem is a read-only LV (RHBZ#1185561). *)
let is_read_only_lv (g : G.guestfs) let lvs = Array.to_list (g#lvs_full ())
in
- let ro_uuids = filter_map (
+ let ro_uuids = List.filter_map (
fun { G.lv_uuid; lv_attr } ->
if lv_attr.[1] = 'r' then Some lv_uuid else None
) lvs in
diff --git a/sysprep/main.ml b/sysprep/main.ml
index 3ba0c7b82..218ac43ef 100644
--- a/sysprep/main.ml
+++ b/sysprep/main.ml
@@ -58,7 +58,7 @@ let main () with URI.Parse_failed ->
error (f_"error parsing URI ‘%s’. Look for error messages
printed above.") arg in
let format = match !format with "auto" -> None | fmt ->
Some fmt in
- push_front (uri, format) files;
+ List.push_front (uri, format) files;
format_consumed := true
and set_domain dom if !domain <> None then
@@ -203,7 +203,7 @@ read the man page virt-sysprep(1).
let mount_opts = !mount_opts in
let mount_opts List.map (String.split ":") (String.nsplit
";" mount_opts) in
- let mount_opts mp = assoc ~default:"" mp mount_opts in
+ let mount_opts mp = List.assoc_ ~default:"" mp mount_opts in
message (f_"Examining the guest ...");
diff --git a/sysprep/sysprep_operation.ml b/sysprep/sysprep_operation.ml
index 0c70258db..2ddce302a 100644
--- a/sysprep/sysprep_operation.ml
+++ b/sysprep/sysprep_operation.ml
@@ -110,9 +110,9 @@ let remove_all_from_set set empty_set
let register_operation op - push_front op all_operations;
+ List.push_front op all_operations;
if op.enabled_by_default then
- push_front op enabled_by_default_operations
+ List.push_front op enabled_by_default_operations
let baked = ref false
let rec bake () diff --git a/sysprep/sysprep_operation_script.ml
b/sysprep/sysprep_operation_script.ml
index fd9e62aa0..bb105f57f 100644
--- a/sysprep/sysprep_operation_script.ml
+++ b/sysprep/sysprep_operation_script.ml
@@ -36,7 +36,7 @@ let set_scriptdir dir scriptdir := Some dir
let scripts = ref []
-let add_script script = push_front script scripts
+let add_script script = List.push_front script scripts
let rec script_perform (g : Guestfs.guestfs) root side_effects let scripts =
List.rev !scripts in
diff --git a/v2v/DOM.ml b/v2v/DOM.ml
index 3ba93b4f6..8fd40e6b4 100644
--- a/v2v/DOM.ml
+++ b/v2v/DOM.ml
@@ -123,7 +123,7 @@ let path_to_nodes (Doc doc) path ) nodes
| p :: ps ->
let children - filter_map (
+ List.filter_map (
function
| PCData _ -> None
| Comment _ -> None
diff --git a/v2v/cmdline.ml b/v2v/cmdline.ml
index 6d4219bd8..2180b656f 100644
--- a/v2v/cmdline.ml
+++ b/v2v/cmdline.ml
@@ -165,10 +165,10 @@ let parse_cmdline () in
let vdsm_image_uuids = ref [] in
- let add_vdsm_image_uuid s = push_front s vdsm_image_uuids in
+ let add_vdsm_image_uuid s = List.push_front s vdsm_image_uuids in
let vdsm_vol_uuids = ref [] in
- let add_vdsm_vol_uuid s = push_front s vdsm_vol_uuids in
+ let add_vdsm_vol_uuid s = List.push_front s vdsm_vol_uuids in
let vmtype_warning _ warning (f_"the --vmtype option has been
removed and now does nothing")
@@ -241,7 +241,7 @@ let parse_cmdline ()
s_"Ignored for backwards compatibility";
] in
let args = ref [] in
- let anon_fun s = push_front s args in
+ let anon_fun s = List.push_front s args in
let usage_msg sprintf (f_"\
%s: convert a guest to use KVM
diff --git a/v2v/convert_linux.ml b/v2v/convert_linux.ml
index 81e195866..ea44b262c 100644
--- a/v2v/convert_linux.ml
+++ b/v2v/convert_linux.ml
@@ -139,7 +139,7 @@ let convert (g : G.guestfs) inspect source output rcaps
and unconfigure_xen () (* Remove kmod-xenpv-* (RHEL 3). *)
let xenmods - filter_map (
+ List.filter_map (
fun { G.app2_name = name } ->
if name = "kmod-xenpv" || String.is_prefix name
"kmod-xenpv-" then
Some name
@@ -235,7 +235,7 @@ let convert (g : G.guestfs) inspect source output rcaps
let lines = g#read_lines vboxconfig in
let lines = Array.to_list lines in
let rex = PCRE.compile "^INSTALL_DIR=(.*)$" in
- let lines = filter_map (
+ let lines = List.filter_map (
fun line ->
if PCRE.matches rex line then (
let path = PCRE.sub 1 in
@@ -279,13 +279,13 @@ let convert (g : G.guestfs) inspect source output rcaps
List.iter (
fun { G.app2_name = name } ->
if String.is_prefix name "vmware-tools-libraries-" then
- push_front name libraries
+ List.push_front name libraries
else if String.is_prefix name "vmware-tools-" then
- push_front name remove
+ List.push_front name remove
else if name = "VMwareTools" then
- push_front name remove
+ List.push_front name remove
else if String.is_prefix name "kmod-vmware-tools" then
- push_front name remove
+ List.push_front name remove
) inspect.i_apps;
let libraries = !libraries in
@@ -333,13 +333,13 @@ let convert (g : G.guestfs) inspect source output rcaps
let cmd = Array.of_list cmd in
(try
ignore (g#command cmd);
- push_front library remove
+ List.push_front library remove
with G.Error msg ->
eprintf "%s: could not install replacement for %s. Error
was: %s. %s was not removed.\n"
prog library msg library
);
) else (
- push_front library remove;
+ List.push_front library remove;
);
) libraries
)
diff --git a/v2v/convert_windows.ml b/v2v/convert_windows.ml
index 247ffff3f..41e734b67 100644
--- a/v2v/convert_windows.ml
+++ b/v2v/convert_windows.ml
@@ -166,7 +166,7 @@ let convert (g : G.guestfs) inspect source output rcaps
* uninstaller still shows a no-way-out reboot dialog *)
" PREVENT_REBOOT=Yes LAUNCHED_BY_SETUP_EXE=Yes"
in
- push_front uninst uninsts
+ List.push_front uninst uninsts
with
Not_found -> ()
) uninstnodes
diff --git a/v2v/copy_to_local.ml b/v2v/copy_to_local.ml
index d92ad0f88..d2471a546 100644
--- a/v2v/copy_to_local.ml
+++ b/v2v/copy_to_local.ml
@@ -50,7 +50,7 @@ let rec main ()
s_"Use password from file";
] in
let args = ref [] in
- let anon_fun s = push_front s args in
+ let anon_fun s = List.push_front s args in
let usage_msg sprintf (f_"\
%s: copy a remote guest to the local machine
@@ -205,12 +205,12 @@ read the man page virt-v2v-copy-to-local(1).
"url", Some remote_disk;
"output", Some local_disk;
] in
- if not sslverify then push_back curl_args ("insecure", None);
+ if not sslverify then List.push_back curl_args ("insecure",
None);
(match cookie with
| None -> ()
- | Some cookie -> push_back curl_args ("cookie", Some
cookie)
+ | Some cookie -> List.push_back curl_args ("cookie", Some
cookie)
);
- if quiet () then push_back curl_args ("silent", None);
+ if quiet () then List.push_back curl_args ("silent", None);
let curl_h = Curl.create !curl_args in
if verbose () then
@@ -261,7 +261,7 @@ and parse_libvirt_xml guest_name xml incr i;
let local_disk = sprintf "%s-disk%d" guest_name !i in
- push_front (remote_disk, local_disk) disks;
+ List.push_front (remote_disk, local_disk) disks;
local_disk
in
get_disks, add_disk
diff --git a/v2v/create_libvirt_xml.ml b/v2v/create_libvirt_xml.ml
index 70c04cc64..ecf0d14c5 100644
--- a/v2v/create_libvirt_xml.ml
+++ b/v2v/create_libvirt_xml.ml
@@ -35,13 +35,13 @@ let create_libvirt_xml ?pool source target_buses guestcaps
(* The main body of the libvirt XML document. *)
let body = ref [] in
- append body [
+ List.push_back_list body [
Comment generated_by;
e "name" [] [PCData source.s_name];
];
let memory_k = source.s_memory /^ 1024L in
- append body [
+ List.push_back_list body [
e "memory" ["unit", "KiB"] [PCData
(Int64.to_string memory_k)];
e "currentMemory" ["unit", "KiB"] [PCData
(Int64.to_string memory_k)];
e "vcpu" [] [PCData (string_of_int source.s_vcpu)]
@@ -55,32 +55,32 @@ let create_libvirt_xml ?pool source target_buses guestcaps
(match source.s_cpu_vendor with
| None -> ()
| Some vendor ->
- push_back cpu (e "vendor" [] [PCData vendor])
+ List.push_back cpu (e "vendor" [] [PCData vendor])
);
(match source.s_cpu_model with
| None -> ()
| Some model ->
- push_back cpu (e "model" ["fallback",
"allow"] [PCData model])
+ List.push_back cpu (e "model" ["fallback",
"allow"] [PCData model])
);
if source.s_cpu_sockets <> None || source.s_cpu_cores <> None
||
source.s_cpu_threads <> None then (
let topology_attrs = ref [] in
(match source.s_cpu_sockets with
| None -> ()
- | Some v -> push_back topology_attrs ("sockets",
string_of_int v)
+ | Some v -> List.push_back topology_attrs ("sockets",
string_of_int v)
);
(match source.s_cpu_cores with
| None -> ()
- | Some v -> push_back topology_attrs ("cores",
string_of_int v)
+ | Some v -> List.push_back topology_attrs ("cores",
string_of_int v)
);
(match source.s_cpu_threads with
| None -> ()
- | Some v -> push_back topology_attrs ("threads",
string_of_int v)
+ | Some v -> List.push_back topology_attrs ("threads",
string_of_int v)
);
- push_back cpu (e "topology" !topology_attrs [])
+ List.push_back cpu (e "topology" !topology_attrs [])
);
- append body [ e "cpu" [ "match", "minimum" ]
!cpu ]
+ List.push_back_list body [ e "cpu" [ "match",
"minimum" ] !cpu ]
);
let uefi_firmware @@ -140,7 +140,7 @@ let create_libvirt_xml ?pool source
target_buses guestcaps
let features = List.sort compare (StringSet.elements features) in
- append body [
+ List.push_back_list body [
e "features" [] (List.map (fun s -> e s [] []) features);
];
@@ -161,7 +161,7 @@ let create_libvirt_xml ?pool source target_buses guestcaps
(e "type" (["arch", guestcaps.gcaps_arch] @ machine)
[PCData "hvm"])
:: loader in
- append body [
+ List.push_back_list body [
e "os" [] os_section;
e "on_poweroff" [] [PCData "destroy"];
@@ -236,7 +236,7 @@ let create_libvirt_xml ?pool source target_buses guestcaps
(Array.mapi (make_disk "floppy" "fd")
target_buses.target_floppy_bus)
] in
- append devices disks;
+ List.push_back_list devices disks;
let nics let net_model @@ -269,7 +269,7 @@ let create_libvirt_xml ?pool
source target_buses guestcaps
nic
) source.s_nics in
- append devices nics;
+ List.push_back_list devices nics;
(* Same as old virt-v2v, we always add a display here even if it was
* missing from the old metadata.
@@ -281,7 +281,7 @@ let create_libvirt_xml ?pool source target_buses guestcaps
| Cirrus -> e "model" [ "type",
"cirrus"; "vram", "9216" ] [] in
append_attr ("heads", "1") video_model;
e "video" [] [ video_model ] in
- push_back devices video;
+ List.push_back devices video;
let graphics match source.s_display with
@@ -326,7 +326,7 @@ let create_libvirt_xml ?pool source target_buses guestcaps
| Some { s_port = None } | None ->
append_attr ("autoport", "yes") graphics;
append_attr ("port", "-1") graphics);
- push_back devices graphics;
+ List.push_back devices graphics;
let sound match source.s_sound with
@@ -336,11 +336,11 @@ let create_libvirt_xml ?pool source target_buses guestcaps
[ e "sound" [ "model",
string_of_source_sound_model model ] [] ]
else
[] in
- append devices sound;
+ List.push_back_list devices sound;
(* Miscellaneous KVM devices. *)
if guestcaps.gcaps_virtio_rng then
- push_back devices (
+ List.push_back devices (
e "rng" ["model", "virtio"] [
(* XXX Using /dev/urandom requires libvirt >= 1.3.4. Libvirt
* was broken before that.
@@ -351,27 +351,27 @@ let create_libvirt_xml ?pool source target_buses guestcaps
(* For the balloon device, libvirt adds an implicit device
* unless we use model='none', hence this:
*)
- push_back devices (
+ List.push_back devices (
e "memballoon"
["model",
if guestcaps.gcaps_virtio_balloon then "virtio" else
"none"]
[]
);
if guestcaps.gcaps_isa_pvpanic then
- push_back devices (
+ List.push_back devices (
e "panic" ["model", "isa"] [
e "address" ["type", "isa";
"iobase", "0x505"] []
]
);
(* Standard devices added to every guest. *)
- append devices [
+ List.push_back_list devices [
e "input" ["type", "tablet"; "bus",
"usb"] [];
e "input" ["type", "mouse"; "bus",
"ps2"] [];
e "console" ["type", "pty"] [];
];
- append body [
+ List.push_back_list body [
e "devices" [] !devices;
];
diff --git a/v2v/create_ovf.ml b/v2v/create_ovf.ml
index 1b851b0e9..aebdf6230 100644
--- a/v2v/create_ovf.ml
+++ b/v2v/create_ovf.ml
@@ -314,18 +314,18 @@ let rec create_ovf source targets guestcaps inspect
(match source.s_cpu_model with
| None -> ()
| Some model ->
- push_back content_subnodes (e "CustomCpuName" [] [PCData
model])
+ List.push_back content_subnodes (e "CustomCpuName" []
[PCData model])
);
(* Add the <Origin/> element if we can. *)
(match origin_of_source_hypervisor source.s_hypervisor with
| None -> ()
| Some origin ->
- push_back content_subnodes
+ List.push_back content_subnodes
(e "Origin" [] [PCData (string_of_int origin)])
);
- push_back content_subnodes (
+ List.push_back content_subnodes (
e "Section" ["ovf:id", vm_uuid;
"ovf:required", "false";
"xsi:type",
"ovf:OperatingSystemSection_Type"] [
e "Info" [] [PCData inspect.i_product_name];
@@ -338,7 +338,7 @@ let rec create_ovf source targets guestcaps inspect
source.s_vcpu memsize_mb)]
] in
- push_back virtual_hardware_section_items (
+ List.push_back virtual_hardware_section_items (
e "Item" [] ([
e "rasd:Caption" [] [PCData (sprintf "%d virtual
cpu" source.s_vcpu)];
e "rasd:Description" [] [PCData "Number of virtual
CPU"];
@@ -370,7 +370,7 @@ let rec create_ovf source targets guestcaps inspect
)
);
- append virtual_hardware_section_items [
+ List.push_back_list virtual_hardware_section_items [
e "Item" [] [
e "rasd:Caption" [] [PCData (sprintf "%Ld MB of
memory" memsize_mb)];
e "rasd:Description" [] [PCData "Memory Size"];
@@ -403,7 +403,7 @@ let rec create_ovf source targets guestcaps inspect
(* Add the miscellaneous KVM devices. *)
if guestcaps.gcaps_virtio_rng then
- push_back virtual_hardware_section_items (
+ List.push_back virtual_hardware_section_items (
e "Item" [] [
e "rasd:Caption" [] [PCData "RNG Device"];
e "rasd:InstanceId" [] [PCData (uuidgen ())];
@@ -413,7 +413,7 @@ let rec create_ovf source targets guestcaps inspect
]
);
if guestcaps.gcaps_virtio_balloon then
- push_back virtual_hardware_section_items (
+ List.push_back virtual_hardware_section_items (
e "Item" [] [
e "rasd:Caption" [] [PCData "Memory Ballooning
Device"];
e "rasd:InstanceId" [] [PCData (uuidgen ())];
@@ -423,7 +423,7 @@ let rec create_ovf source targets guestcaps inspect
]
);
- push_back content_subnodes (
+ List.push_back content_subnodes (
e "Section" ["xsi:type",
"ovf:VirtualHardwareSection_Type"]
!virtual_hardware_section_items
);
@@ -554,7 +554,7 @@ and add_disks targets guestcaps output_alloc sd_uuid
image_uuids vol_uuids ovf (match actual_size_gb with
| None -> ()
| Some actual_size_gb ->
- push_back attrs ("ovf:actual_size", Int64.to_string
actual_size_gb)
+ List.push_back attrs ("ovf:actual_size", Int64.to_string
actual_size_gb)
);
e "Disk" !attrs [] in
if is_estimate then (
@@ -585,12 +585,12 @@ and add_disks targets guestcaps output_alloc sd_uuid
image_uuids vol_uuids ovf e "rasd:last_modified_date" []
[PCData iso_time];
] in
if is_bootable_drive then
- push_back item_subnodes
+ List.push_back item_subnodes
(e "BootOrder" [] [PCData (string_of_int
boot_order)]);
e "Item" [] !item_subnodes in
append_child item virtualhardware_section;
- ) (combine3 targets image_uuids vol_uuids)
+ ) (List.combine3 targets image_uuids vol_uuids)
(* This modifies the OVF DOM, adding a section for each NIC. *)
and add_networks nics guestcaps ovf @@ -641,7 +641,7 @@ and add_networks nics
guestcaps ovf (match mac with
| None -> ()
| Some mac ->
- push_back item_subnodes
+ List.push_back item_subnodes
(e "rasd:MACAddress" [] [PCData mac])
);
e "Item" [] !item_subnodes in
diff --git a/v2v/input_libvirt_vddk.ml b/v2v/input_libvirt_vddk.ml
index 8fa33fbeb..9afa9ed32 100644
--- a/v2v/input_libvirt_vddk.ml
+++ b/v2v/input_libvirt_vddk.ml
@@ -151,7 +151,7 @@ object
let args let add_arg, get_args let args = ref [] in
- let add_arg a = push_front a args in
+ let add_arg a = List.push_front a args in
let get_args () = List.rev !args in
add_arg, get_args in
diff --git a/v2v/input_ova.ml b/v2v/input_ova.ml
index 5f313b6fb..abb0654a5 100644
--- a/v2v/input_ova.ml
+++ b/v2v/input_ova.ml
@@ -76,7 +76,7 @@ let untar ?format ?(paths = []) file outdir let
untar_metadata file outdir let files = external_command (sprintf "tar
-tf %s" (Filename.quote file)) in
let files - filter_map (
+ List.filter_map (
fun f ->
if Filename.check_suffix f ".ovf" ||
Filename.check_suffix f ".mf" then Some f
diff --git a/v2v/input_vmx.ml b/v2v/input_vmx.ml
index 366e63560..649e86cac 100644
--- a/v2v/input_vmx.ml
+++ b/v2v/input_vmx.ml
@@ -108,7 +108,7 @@ and find_hdds vmx vmx_filename
Some (c, t, s)
| _ -> None
) hdds in
- let hdds = filter_map identity hdds in
+ let hdds = List.filter_map identity hdds in
(* We don't have a way to return the controllers and targets, so
* just make sure the disks are sorted into order, since Parse_vmx
@@ -188,7 +188,7 @@ and find_removables vmx Some s
| _ -> None
) devs in
- let devs = filter_map identity devs in
+ let devs = List.filter_map identity devs in
(* Sort by slot. *)
let devs @@ -260,7 +260,7 @@ and find_nics vmx
s_vnet_type = vnet_type })
| _ -> None
) nics in
- let nics = filter_map identity nics in
+ let nics = List.filter_map identity nics in
(* Sort by port. *)
let nics = List.sort compare nics in
diff --git a/v2v/linux_bootloaders.ml b/v2v/linux_bootloaders.ml
index 4ddc6d0dd..bc015740a 100644
--- a/v2v/linux_bootloaders.ml
+++ b/v2v/linux_bootloaders.ml
@@ -84,7 +84,7 @@ object
let paths = Array.to_list paths in
(* Remove duplicates. *)
- let paths = remove_duplicates paths in
+ let paths = List.remove_duplicates paths in
(* Get the default kernel from grub if it's set. *)
let default diff --git a/v2v/linux_kernels.ml b/v2v/linux_kernels.ml
index 59948cb61..438a00afa 100644
--- a/v2v/linux_kernels.ml
+++ b/v2v/linux_kernels.ml
@@ -89,7 +89,7 @@ let detect_kernels (g : G.guestfs) inspect family bootloader
PCRE.compile "^initrd.img-.*$"
else
PCRE.compile "^initr(?:d|amfs)-.*(?:\\.img)?$" in
- filter_map (
+ List.filter_map (
function
| { G.app2_name = name } as app
when name = "kernel" || String.is_prefix name
"kernel-"
@@ -177,7 +177,7 @@ let detect_kernels (g : G.guestfs) inspect family bootloader
g#file_architecture any_module in
(* Just return the module names, without path or extension. *)
- let modules = filter_map (
+ let modules = List.filter_map (
fun m ->
if PCRE.matches rex_ko_extract m then
Some (PCRE.sub 1)
@@ -259,7 +259,7 @@ let detect_kernels (g : G.guestfs) inspect family bootloader
let vmlinuzes = bootloader#list_kernels in
(* Map these to installed kernels. *)
- filter_map (
+ List.filter_map (
fun vmlinuz ->
try
let statbuf = g#statns vmlinuz in
diff --git a/v2v/modules_list.ml b/v2v/modules_list.ml
index e3c6d5934..d5120b70b 100644
--- a/v2v/modules_list.ml
+++ b/v2v/modules_list.ml
@@ -21,8 +21,8 @@ open Std_utils
let input_modules = ref []
and output_modules = ref []
-let register_input_module name = push_front name input_modules
-and register_output_module name = push_front name output_modules
+let register_input_module name = List.push_front name input_modules
+and register_output_module name = List.push_front name output_modules
let input_modules () = List.sort compare !input_modules
and output_modules () = List.sort compare !output_modules
@@ -36,7 +36,7 @@ type conversion_fn let convert_modules = ref []
let register_convert_module inspect_fn name conversion_fn - push_front
(inspect_fn, (name, conversion_fn)) convert_modules
+ List.push_front (inspect_fn, (name, conversion_fn)) convert_modules
let find_convert_module inspect let rec loop = function
diff --git a/v2v/output_glance.ml b/v2v/output_glance.ml
index 4e4f965c1..6ce637c59 100644
--- a/v2v/output_glance.ml
+++ b/v2v/output_glance.ml
@@ -99,42 +99,42 @@ object
] in
if source.s_cpu_sockets <> None || source.s_cpu_cores <> None
||
source.s_cpu_threads <> None then (
- push_back properties ("hw_cpu_sockets",
+ List.push_back properties ("hw_cpu_sockets",
match source.s_cpu_sockets with
| None -> "1"
| Some v -> string_of_int v);
- push_back properties ("hw_cpu_cores",
+ List.push_back properties ("hw_cpu_cores",
match source.s_cpu_cores with
| None -> "1"
| Some v -> string_of_int v);
- push_back properties ("hw_cpu_threads",
+ List.push_back properties ("hw_cpu_threads",
match source.s_cpu_threads with
| None -> "1"
| Some v -> string_of_int v);
)
else (
- push_back properties ("hw_cpu_sockets", "1");
- push_back properties ("hw_cpu_cores", string_of_int
source.s_vcpu);
+ List.push_back properties ("hw_cpu_sockets", "1");
+ List.push_back properties ("hw_cpu_cores", string_of_int
source.s_vcpu);
);
(match guestcaps.gcaps_block_bus with
| Virtio_SCSI ->
- push_back properties ("hw_scsi_model",
"virtio-scsi")
+ List.push_back properties ("hw_scsi_model",
"virtio-scsi")
| Virtio_blk | IDE -> ()
);
(match inspect.i_major_version, inspect.i_minor_version with
| 0, 0 -> ()
- | x, 0 -> push_back properties ("os_version", string_of_int
x)
- | x, y -> push_back properties ("os_version", sprintf
"%d.%d" x y)
+ | x, 0 -> List.push_back properties ("os_version",
string_of_int x)
+ | x, y -> List.push_back properties ("os_version", sprintf
"%d.%d" x y)
);
if guestcaps.gcaps_virtio_rng then
- push_back properties ("hw_rng_model", "virtio");
+ List.push_back properties ("hw_rng_model",
"virtio");
(* XXX Neither memory balloon nor pvpanic are supported by
* Glance at this time.
*)
(match target_firmware with
| TargetBIOS -> ()
| TargetUEFI ->
- push_back properties ("hw_firmware_type", "uefi")
+ List.push_back properties ("hw_firmware_type",
"uefi")
);
!properties in
diff --git a/v2v/output_libvirt.ml b/v2v/output_libvirt.ml
index 02b4d54ff..3fb449d5a 100644
--- a/v2v/output_libvirt.ml
+++ b/v2v/output_libvirt.ml
@@ -61,7 +61,7 @@ let target_features_of_capabilities_doc doc arch for i =
0 to Xml.xpathobj_nr_nodes obj - 1 do
let feature_node = Xml.xpathobj_node obj i in
let feature_name = Xml.node_name feature_node in
- push_front feature_name features
+ List.push_front feature_name features
done;
!features
)
diff --git a/v2v/output_qemu.ml b/v2v/output_qemu.ml
index d18b4b7c9..5304329ae 100644
--- a/v2v/output_qemu.ml
+++ b/v2v/output_qemu.ml
@@ -99,16 +99,16 @@ object
if source.s_cpu_sockets <> None || source.s_cpu_cores <> None
||
source.s_cpu_threads <> None then (
let a = ref [] in
- push_back a (sprintf "cpus=%d" source.s_vcpu);
- push_back a (sprintf "sockets=%d"
+ List.push_back a (sprintf "cpus=%d" source.s_vcpu);
+ List.push_back a (sprintf "sockets=%d"
(match source.s_cpu_sockets with
| None -> 1
| Some v -> v));
- push_back a (sprintf "cores=%d"
+ List.push_back a (sprintf "cores=%d"
(match source.s_cpu_cores with
| None -> 1
| Some v -> v));
- push_back a (sprintf "threads=%d"
+ List.push_back a (sprintf "threads=%d"
(match source.s_cpu_threads with
| None -> 1
| Some v -> v));
diff --git a/v2v/output_rhv.ml b/v2v/output_rhv.ml
index ce2d75c1d..2bcd988c1 100644
--- a/v2v/output_rhv.ml
+++ b/v2v/output_rhv.ml
@@ -233,7 +233,7 @@ object
debug "RHV: will export %s to %s" ov_sd target_file;
{ t with target_file = target_file }
- ) (combine3 targets image_uuids vol_uuids) in
+ ) (List.combine3 targets image_uuids vol_uuids) in
(* Generate the .meta file associated with each volume. *)
let metas diff --git a/v2v/output_vdsm.ml b/v2v/output_vdsm.ml
index f60b6b4c7..0aeee289d 100644
--- a/v2v/output_vdsm.ml
+++ b/v2v/output_vdsm.ml
@@ -85,7 +85,7 @@ object
let mp, uuid let fields = String.nsplit "/" os in (* ...
"data-center" "UUID" *)
let fields = List.rev fields in (* "UUID"
"data-center" ... *)
- let fields = dropwhile ((=) "") fields in
+ let fields = List.dropwhile ((=) "") fields in
match fields with
| uuid :: rest when String.length uuid = 36 ->
let mp = String.concat "/" (List.rev rest) in
@@ -135,7 +135,7 @@ object
debug "VDSM: will export %s to %s" ov_sd target_file;
{ t with target_file = target_file }
- ) (combine3 targets vdsm_params.image_uuids vdsm_params.vol_uuids) in
+ ) (List.combine3 targets vdsm_params.image_uuids vdsm_params.vol_uuids)
in
(* Generate the .meta files associated with each volume. *)
let metas diff --git a/v2v/parse_libvirt_xml.ml b/v2v/parse_libvirt_xml.ml
index 40d558a5e..7a03156f3 100644
--- a/v2v/parse_libvirt_xml.ml
+++ b/v2v/parse_libvirt_xml.ml
@@ -122,7 +122,7 @@ let parse_libvirt_xml ?conn xml let nr_nodes =
Xml.xpathobj_nr_nodes obj in
for i = 0 to nr_nodes-1 do
let node = Xml.xpathobj_node obj i in
- push_front (Xml.node_name node) features
+ List.push_front (Xml.node_name node) features
done;
!features in
@@ -253,7 +253,7 @@ let parse_libvirt_xml ?conn xml
s_controller = controller };
p_source = p_source
} in
- push_front disk disks
+ List.push_front disk disks
in
get_disks, add_disk
in
@@ -402,7 +402,7 @@ let parse_libvirt_xml ?conn xml { s_removable_type
= typ;
s_removable_controller = controller;
s_removable_slot = slot } in
- push_front disk disks
+ List.push_front disk disks
done;
List.rev !disks in
@@ -446,7 +446,7 @@ let parse_libvirt_xml ?conn xml s_vnet_orig =
vnet;
s_vnet_type = vnet_type
} in
- push_front nic nics
+ List.push_front nic nics
in
match xpath_string "source/@network | source/@bridge" with
| None -> ()
diff --git a/v2v/parse_ovf_from_ova.ml b/v2v/parse_ovf_from_ova.ml
index e3518e30d..1c113eca2 100644
--- a/v2v/parse_ovf_from_ova.ml
+++ b/v2v/parse_ovf_from_ova.ml
@@ -174,7 +174,7 @@ let parse_ovf_from_ova ovf_filename href = href;
compressed = compressed
} in
- push_front disk disks;
+ List.push_front disk disks;
) else
error (f_"could not parse disk rasd:HostResource from OVF
document")
done;
@@ -217,7 +217,7 @@ let parse_ovf_from_ova ovf_filename
s_removable_controller = controller;
s_removable_slot = slot;
} in
- push_front disk removables;
+ List.push_front disk removables;
done;
List.rev !removables
@@ -239,7 +239,7 @@ let parse_ovf_from_ova ovf_filename s_vnet_orig =
vnet;
s_vnet_type = Network;
} in
- push_front nic nics
+ List.push_front nic nics
done;
List.rev !nics
in
diff --git a/v2v/parse_vmx.ml b/v2v/parse_vmx.ml
index 3c72527b9..65d5a0edd 100644
--- a/v2v/parse_vmx.ml
+++ b/v2v/parse_vmx.ml
@@ -290,7 +290,7 @@ and parse_string str ) lines in
(* Parse the lines into key = "value". *)
- let lines = filter_map (
+ let lines = List.filter_map (
fun line ->
if PCRE.matches rex line then (
let key = PCRE.sub 1 and value = PCRE.sub 2 in
diff --git a/v2v/test-harness/v2v_test_harness.ml
b/v2v/test-harness/v2v_test_harness.ml
index ae0033dde..a2eeab0ff 100644
--- a/v2v/test-harness/v2v_test_harness.ml
+++ b/v2v/test-harness/v2v_test_harness.ml
@@ -93,7 +93,7 @@ let run ~test ?input_disk ?input_xml ?(test_plan =
default_plan) () let nodes_of_xpathobj doc xpathobj let nodes = ref []
in
for i = 0 to Xml.xpathobj_nr_nodes xpathobj - 1 do
- push_front (Xml.xpathobj_node xpathobj i) nodes
+ List.push_front (Xml.xpathobj_node xpathobj i) nodes
done;
List.rev !nodes
in
@@ -209,7 +209,7 @@ let run ~test ?input_disk ?input_xml ?(test_plan =
default_plan) () printf "%s\n%!" cmd;
let chan = open_process_in cmd in
let lines = ref [] in
- (try while true do push_front (input_line chan) lines done
+ (try while true do List.push_front (input_line chan) lines done
with End_of_file -> ());
let lines = List.rev !lines in
let stat = close_process_in chan in
@@ -282,7 +282,7 @@ let run ~test ?input_disk ?input_xml ?(test_plan =
default_plan) () printf "%s\n%!" cmd;
let chan = open_process_in cmd in
let lines = ref [] in
- (try while true do push_front (input_line chan) lines done
+ (try while true do List.push_front (input_line chan) lines done
with End_of_file -> ());
let lines = List.rev !lines in
let stat = close_process_in chan in
diff --git a/v2v/v2v.ml b/v2v/v2v.ml
index 92aa6102b..9e609b526 100644
--- a/v2v/v2v.ml
+++ b/v2v/v2v.ml
@@ -447,7 +447,7 @@ and do_fstrim g inspect (* Get all filesystems. *)
let fses = g#list_filesystems () in
- let fses = filter_map (
+ let fses = List.filter_map (
function (_, ("unknown"|"swap")) -> None | (dev, _)
-> Some dev
) fses in
@@ -788,7 +788,7 @@ and rcaps_from_source source let source_block_types
List.map (fun sd -> sd.s_controller) source.s_disks in
let source_block_type - match sort_uniq source_block_types with
+ match List.sort_uniq source_block_types with
| [] -> error (f_"source has no hard disks!")
| [t] -> t
| _ -> error (f_"source has multiple hard disk types!") in
@@ -804,7 +804,7 @@ and rcaps_from_source source let source_net_types
List.map (fun nic -> nic.s_nic_model) source.s_nics in
let source_net_type - match sort_uniq source_net_types with
+ match List.sort_uniq source_net_types with
| [] -> None
| [t] -> t
| _ -> error (f_"source has multiple network adapter model!")
in
diff --git a/v2v/vCenter.ml b/v2v/vCenter.ml
index 18879432b..41bdbdd01 100644
--- a/v2v/vCenter.ml
+++ b/v2v/vCenter.ml
@@ -42,11 +42,11 @@ let get_session_cookie password scheme uri sslverify url
| None, Some _ ->
warning (f_"--password-file parameter ignored because
'user@' was not given in the URL")
| Some user, None ->
- push_back curl_args ("user", Some user)
+ List.push_back curl_args ("user", Some user)
| Some user, Some password ->
- push_back curl_args ("user", Some (user ^ ":" ^
password))
+ List.push_back curl_args ("user", Some (user ^ ":"
^ password))
);
- if not sslverify then push_back curl_args ("insecure", None);
+ if not sslverify then List.push_back curl_args ("insecure",
None);
let curl_h = Curl.create !curl_args in
let lines = Curl.run curl_h in
--
2.13.2
Richard W.M. Jones
2017-Oct-08 21:26 UTC
[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
Richard W.M. Jones
2017-Oct-08 21:26 UTC
[Libguestfs] [PATCH v2 4/4] common/mltools: xpath_helpers: Get rid of xpath_*_default functions.
Instead of using ‘xpath_(string|int|int64)_default’ we can write the
equivalent code using ‘Option.default’. This is not quite so concise,
but may be easier to understand.
eg:
xpath_int_default xctx "xpath_expr" 10
->
Option.default 10 (xpath_int xctx "xpath_expr")
---
common/mltools/xpath_helpers.ml | 12 ------------
common/mltools/xpath_helpers.mli | 6 ------
v2v/copy_to_local.ml | 6 +++---
v2v/parse_libvirt_xml.ml | 9 ++++-----
v2v/parse_ovf_from_ova.ml | 16 ++++++++--------
5 files changed, 15 insertions(+), 34 deletions(-)
diff --git a/common/mltools/xpath_helpers.ml b/common/mltools/xpath_helpers.ml
index 05fad89a4..3afee8b21 100644
--- a/common/mltools/xpath_helpers.ml
+++ b/common/mltools/xpath_helpers.ml
@@ -40,15 +40,3 @@ let xpath_eval parsefn xpathctx expr let xpath_string =
xpath_eval identity
let xpath_int = xpath_eval int_of_string
let xpath_int64 = xpath_eval Int64.of_string
-
-(* Parse an xpath expression and return a string/int; if the expression
- * doesn't match, return the default.
- *)
-let xpath_eval_default parsefn xpath expr default - match xpath_eval parsefn
xpath expr with
- | None -> default
- | Some s -> s
-
-let xpath_string_default = xpath_eval_default identity
-let xpath_int_default = xpath_eval_default int_of_string
-let xpath_int64_default = xpath_eval_default Int64.of_string
diff --git a/common/mltools/xpath_helpers.mli b/common/mltools/xpath_helpers.mli
index 7434ba645..3a8190b05 100644
--- a/common/mltools/xpath_helpers.mli
+++ b/common/mltools/xpath_helpers.mli
@@ -25,9 +25,3 @@ val xpath_int : Xml.xpathctx -> string -> int option
val xpath_int64 : Xml.xpathctx -> string -> int64 option
(** Parse an xpath expression and return a string/int. Returns
[Some v], or [None] if the expression doesn't match. *)
-
-val xpath_string_default : Xml.xpathctx -> string -> string -> string
-val xpath_int_default : Xml.xpathctx -> string -> int -> int
-val xpath_int64_default : Xml.xpathctx -> string -> int64 -> int64
-(** Parse an xpath expression and return a string/int; if the expression
- doesn't match, return the default. *)
diff --git a/v2v/copy_to_local.ml b/v2v/copy_to_local.ml
index d2471a546..8a64f3a58 100644
--- a/v2v/copy_to_local.ml
+++ b/v2v/copy_to_local.ml
@@ -243,14 +243,14 @@ and parse_libvirt_xml guest_name xml let xpathctx =
Xml.xpath_new_context doc in
Xml.xpath_register_ns xpathctx
"vmware"
"http://libvirt.org/schemas/domain/vmware/1.0";
- let xpath_string = xpath_string xpathctx
- and xpath_string_default = xpath_string_default xpathctx in
+ let xpath_string = xpath_string xpathctx in
(* Get the dcpath, only present for libvirt >= 1.2.20 so use a
* sensible default for older versions.
*)
let dcpath - xpath_string_default
"/domain/vmware:datacenterpath" "ha-datacenter" in
+ Option.default "ha-datacenter"
+ (xpath_string "/domain/vmware:datacenterpath") in
(* Parse the disks. *)
let get_disks, add_disk diff --git a/v2v/parse_libvirt_xml.ml
b/v2v/parse_libvirt_xml.ml
index 2f90bee0c..421175373 100644
--- a/v2v/parse_libvirt_xml.ml
+++ b/v2v/parse_libvirt_xml.ml
@@ -77,10 +77,8 @@ let parse_libvirt_xml ?conn xml let doc = Xml.parse_memory
xml in
let xpathctx = Xml.xpath_new_context doc in
let xpath_string = xpath_string xpathctx
- and xpath_string_default = xpath_string_default xpathctx
and xpath_int = xpath_int xpathctx
- (*and xpath_int_default = xpath_int_default xpathctx*)
- and xpath_int64_default = xpath_int64_default xpathctx in
+ and xpath_int64 = xpath_int64 xpathctx in
let hypervisor match xpath_string "/domain/@type" with
@@ -92,7 +90,8 @@ let parse_libvirt_xml ?conn xml | None | Some
"" ->
error (f_"in the libvirt XML metadata, <name> is missing or
empty")
| Some s -> s in
- let memory = xpath_int64_default "/domain/memory/text()" (1024L *^
1024L) in
+ let memory + Option.default (1024L *^ 1024L) (xpath_int64
"/domain/memory/text()") in
let memory = memory *^ 1024L in
let cpu_vendor = xpath_string "/domain/cpu/vendor/text()" in
@@ -317,7 +316,7 @@ let parse_libvirt_xml ?conn xml (* This is for
testing curl, eg for testing VMware conversions
* without needing VMware around.
*)
- let path = xpath_string_default "source/@name"
"" in
+ let path = Option.default "" (xpath_string
"source/@name") in
let qemu_uri = create_curl_qemu_uri driver host port path in
add_disk qemu_uri format controller P_dont_rewrite
| Some protocol, _, _ ->
diff --git a/v2v/parse_ovf_from_ova.ml b/v2v/parse_ovf_from_ova.ml
index 1c113eca2..1d7c632bc 100644
--- a/v2v/parse_ovf_from_ova.ml
+++ b/v2v/parse_ovf_from_ova.ml
@@ -52,9 +52,7 @@ let parse_ovf_from_ova ovf_filename
let xpath_string = xpath_string xpathctx
and xpath_int = xpath_int xpathctx
- and xpath_string_default = xpath_string_default xpathctx
- and xpath_int_default = xpath_int_default xpathctx
- and xpath_int64_default = xpath_int64_default xpathctx in
+ and xpath_int64 = xpath_int64 xpathctx in
let rec parse_top () (* Search for vm name. *)
@@ -64,11 +62,11 @@ let parse_ovf_from_ova ovf_filename | Some _ as name
-> name in
(* Search for memory. *)
- let memory = xpath_int64_default
"/ovf:Envelope/ovf:VirtualSystem/ovf:VirtualHardwareSection/ovf:Item[rasd:ResourceType/text()=4]/rasd:VirtualQuantity/text()"
(1024L *^ 1024L) in
+ let memory = Option.default (1024L *^ 1024L) (xpath_int64
"/ovf:Envelope/ovf:VirtualSystem/ovf:VirtualHardwareSection/ovf:Item[rasd:ResourceType/text()=4]/rasd:VirtualQuantity/text()")
in
let memory = memory *^ 1024L *^ 1024L in
(* Search for number of vCPUs. *)
- let vcpu = xpath_int_default
"/ovf:Envelope/ovf:VirtualSystem/ovf:VirtualHardwareSection/ovf:Item[rasd:ResourceType/text()=3]/rasd:VirtualQuantity/text()"
1 in
+ let vcpu = Option.default 1 (xpath_int
"/ovf:Envelope/ovf:VirtualSystem/ovf:VirtualHardwareSection/ovf:Item[rasd:ResourceType/text()=3]/rasd:VirtualQuantity/text()")
in
(* CPU topology. coresPerSocket is a VMware proprietary extension.
* I couldn't find out how hyperthreads is specified in the OVF.
@@ -91,7 +89,7 @@ let parse_ovf_from_ova ovf_filename Some sockets,
Some cores_per_socket in
(* BIOS or EFI firmware? *)
- let firmware = xpath_string_default
"/ovf:Envelope/ovf:VirtualSystem/ovf:VirtualHardwareSection/vmw:Config[@vmw:key=\"firmware\"]/@vmw:value"
"bios" in
+ let firmware = Option.default "bios" (xpath_string
"/ovf:Envelope/ovf:VirtualSystem/ovf:VirtualHardwareSection/vmw:Config[@vmw:key=\"firmware\"]/@vmw:value")
in
let firmware match firmware with
| "bios" -> BIOS
@@ -141,7 +139,8 @@ let parse_ovf_from_ova ovf_filename | Some id ->
parent_controller id in
Xml.xpathctx_set_current_context xpathctx n;
- let file_id = xpath_string_default "rasd:HostResource/text()"
"" in
+ let file_id + Option.default "" (xpath_string
"rasd:HostResource/text()") in
let rex = PCRE.compile "^(?:ovf:)?/disk/(.*)" in
if PCRE.matches rex file_id then (
(* Chase the references through to the actual file name. *)
@@ -231,7 +230,8 @@ let parse_ovf_from_ova ovf_filename let n =
Xml.xpathobj_node obj i in
Xml.xpathctx_set_current_context xpathctx n;
let vnet - xpath_string_default
"rasd:ElementName/text()" (sprintf"eth%d" i) in
+ Option.default (sprintf"eth%d" i)
+ (xpath_string "rasd:ElementName/text()") in
let nic = {
s_mac = None;
s_nic_model = None;
--
2.13.2
Pino Toscano
2017-Oct-12 13:50 UTC
Re: [Libguestfs] [PATCH v2 3/4] common/mlstdutils: Introduce Option submodule.
On Sunday, 8 October 2017 23:26:55 CEST Richard W.M. Jones wrote:> 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. > ---LGTM. THanks, -- Pino Toscano
Pino Toscano
2017-Oct-12 13:52 UTC
Re: [Libguestfs] [PATCH v2 4/4] common/mltools: xpath_helpers: Get rid of xpath_*_default functions.
On Sunday, 8 October 2017 23:26:56 CEST Richard W.M. Jones wrote:> Instead of using ‘xpath_(string|int|int64)_default’ we can write the > equivalent code using ‘Option.default’. This is not quite so concise, > but may be easier to understand. > > eg: > xpath_int_default xctx "xpath_expr" 10 > -> > Option.default 10 (xpath_int xctx "xpath_expr") > ---LGTM. Thanks, -- Pino Toscano
Pino Toscano
2017-Nov-07 14:16 UTC
Re: [Libguestfs] [PATCH v2 1/4] common/mlstdutils: Extend the List module.
On Sunday, 8 October 2017 23:26:53 CET Richard W.M. Jones wrote:> We defined a number of functions on lists which are not provided by > the standard library. As with Char and String, let's extend List to > add these new functions to a List pseudo-module (really > Std_utils.List, but called List when you ‘open Std_utils’). > > The initial exported functions are all List functions from OCaml 3.11 > + iteri + mapi. We can add other functions as needed. > ---My worry about this is that: - OCaml does not have OOTB support for conditional code depending on the version - the interface of the List module would get "frozen" this way, and overrides the module in the standard library then we could run into issues like commit 7cd27531154dd25d9093cf04c085a3669bc834e5, i.e. restricting the interface because of compatibility issues. Also IMHO this makes more difficult to know what's stdlib and what's ours, when using the API -- I guess I mentioned that when String was introduced, maybe... -- Pino Toscano
Reasonably Related Threads
- [PATCH] common/mlstdutils: Add with_openfile function.
- [PATCH 2/2] common/mlstdutils: Add with_openfile function.
- [PATCH v3] common/mlstdutils: Build a bytecode version of this library.
- [PATCH v4] common/mlstdutils: Build a bytecode version of this library.
- Re: [PATCH v2] common/mlstdutils: Build a bytecode version of this library.