Just code motion, no change. --- mllib/Makefile.am | 4 +++- mllib/curl.ml | 64 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ mllib/curl.mli | 38 +++++++++++++++++++++++++++++++++ po/POTFILES-ml | 2 +- v2v/Makefile.am | 5 ++--- v2v/curl.ml | 64 ------------------------------------------------------- v2v/curl.mli | 38 --------------------------------- 7 files changed, 108 insertions(+), 107 deletions(-) create mode 100644 mllib/curl.ml create mode 100644 mllib/curl.mli delete mode 100644 v2v/curl.ml delete mode 100644 v2v/curl.mli diff --git a/mllib/Makefile.am b/mllib/Makefile.am index 10bbebf..e728d54 100644 --- a/mllib/Makefile.am +++ b/mllib/Makefile.am @@ -28,6 +28,7 @@ CLEANFILES = *~ *.annot *.cmi *.cmo *.cmx *.cmxa *.o SOURCES_MLI = \ common_utils.mli \ + curl.mli \ dev_t.mli \ fsync.mli \ JSON.mli \ @@ -52,7 +53,8 @@ SOURCES_ML = \ planner.ml \ regedit.ml \ StatVFS.ml \ - JSON.ml + JSON.ml \ + curl.ml SOURCES_C = \ ../fish/progress.c \ diff --git a/mllib/curl.ml b/mllib/curl.ml new file mode 100644 index 0000000..f0af160 --- /dev/null +++ b/mllib/curl.ml @@ -0,0 +1,64 @@ +(* virt-v2v + * Copyright (C) 2009-2016 Red Hat Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + *) + +open Printf + +open Common_utils + +type curl_args = (string * string option) list + +let run curl_args = + let config_file, chan = Filename.open_temp_file "v2vcurl" ".conf" in + List.iter ( + function + | name, None -> fprintf chan "%s\n" name + | name, Some value -> + fprintf chan "%s = \"" name; + (* Write the quoted value. See 'curl' man page for what is + * allowed here. + *) + let len = String.length value in + for i = 0 to len-1 do + match value.[i] with + | '\\' -> output_string chan "\\\\" + | '"' -> output_string chan "\\\"" + | '\t' -> output_string chan "\\t" + | '\n' -> output_string chan "\\n" + | '\r' -> output_string chan "\\r" + | '\x0b' -> output_string chan "\\v" + | c -> output_char chan c + done; + fprintf chan "\"\n" + ) curl_args; + close_out chan; + + let cmd = sprintf "curl -q --config %s" (Filename.quote config_file) in + let lines = external_command ~echo_cmd:false cmd in + Unix.unlink config_file; + lines + +let print_curl_command chan curl_args = + fprintf chan "curl -q"; + List.iter ( + function + | name, None -> fprintf chan " --%s" name + (* Don't print passwords in the debug output. *) + | "user", Some _ -> fprintf chan " --user <hidden>" + | name, Some value -> fprintf chan " --%s %s" name (Filename.quote value) + ) curl_args; + fprintf chan "\n"; diff --git a/mllib/curl.mli b/mllib/curl.mli new file mode 100644 index 0000000..cd01497 --- /dev/null +++ b/mllib/curl.mli @@ -0,0 +1,38 @@ +(* virt-v2v + * Copyright (C) 2009-2016 Red Hat Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + *) + +(** Functions for dealing with [curl]. *) + +type curl_args = (string * string option) list + +val run : curl_args -> string list +(** [run curl_args] runs the [curl] command. + + It actually uses the [curl --config] option to pass the arguments + securely to curl through an external file. Thus passwords etc are + not exposed to other users on the same machine. + + The curl arguments are a list of key, value pairs corresponding + to curl command line parameters, without leading dashes, + eg. [("user", Some "user:password")]. + + The result is the output of curl as a list of lines. *) + +val print_curl_command : out_channel -> curl_args -> unit +(** Print the curl command line. This elides any arguments that + might contain passwords, so is useful for debugging. *) diff --git a/po/POTFILES-ml b/po/POTFILES-ml index f6bade1..5937ff5 100644 --- a/po/POTFILES-ml +++ b/po/POTFILES-ml @@ -43,6 +43,7 @@ mllib/URI.ml mllib/common_gettext.ml mllib/common_utils.ml mllib/common_utils_tests.ml +mllib/curl.ml mllib/dev_t.ml mllib/fsync.ml mllib/guestfs_config.ml @@ -104,7 +105,6 @@ v2v/cmdline.ml v2v/convert_linux.ml v2v/convert_windows.ml v2v/copy_to_local.ml -v2v/curl.ml v2v/domainxml.ml v2v/input_disk.ml v2v/input_libvirt.ml diff --git a/v2v/Makefile.am b/v2v/Makefile.am index 05f4611..fedc84d 100644 --- a/v2v/Makefile.am +++ b/v2v/Makefile.am @@ -31,7 +31,6 @@ SOURCES_MLI = \ cmdline.mli \ convert_linux.mli \ convert_windows.mli \ - curl.mli \ DOM.mli \ domainxml.mli \ input_disk.mli \ @@ -66,7 +65,6 @@ SOURCES_ML = \ types.ml \ xml.ml \ utils.ml \ - curl.ml \ vCenter.ml \ domainxml.ml \ DOM.ml \ @@ -131,6 +129,7 @@ BOBJECTS = \ $(top_builddir)/mllib/mkdtemp.cmo \ $(top_builddir)/mllib/JSON.cmo \ $(top_builddir)/mllib/StatVFS.cmo \ + $(top_builddir)/mllib/curl.cmo \ $(top_builddir)/customize/customize_utils.cmo \ $(top_builddir)/customize/firstboot.cmo \ $(SOURCES_ML:.ml=.cmo) @@ -199,9 +198,9 @@ COPY_TO_LOCAL_BOBJECTS = \ $(top_builddir)/mllib/common_utils.cmo \ $(top_builddir)/mllib/JSON.cmo \ $(top_builddir)/mllib/StatVFS.cmo \ + $(top_builddir)/mllib/curl.cmo \ xml.cmo \ utils.cmo \ - curl.cmo \ vCenter.cmo \ domainxml.cmo \ copy_to_local.cmo diff --git a/v2v/curl.ml b/v2v/curl.ml deleted file mode 100644 index f0af160..0000000 --- a/v2v/curl.ml +++ /dev/null @@ -1,64 +0,0 @@ -(* virt-v2v - * Copyright (C) 2009-2016 Red Hat Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - *) - -open Printf - -open Common_utils - -type curl_args = (string * string option) list - -let run curl_args = - let config_file, chan = Filename.open_temp_file "v2vcurl" ".conf" in - List.iter ( - function - | name, None -> fprintf chan "%s\n" name - | name, Some value -> - fprintf chan "%s = \"" name; - (* Write the quoted value. See 'curl' man page for what is - * allowed here. - *) - let len = String.length value in - for i = 0 to len-1 do - match value.[i] with - | '\\' -> output_string chan "\\\\" - | '"' -> output_string chan "\\\"" - | '\t' -> output_string chan "\\t" - | '\n' -> output_string chan "\\n" - | '\r' -> output_string chan "\\r" - | '\x0b' -> output_string chan "\\v" - | c -> output_char chan c - done; - fprintf chan "\"\n" - ) curl_args; - close_out chan; - - let cmd = sprintf "curl -q --config %s" (Filename.quote config_file) in - let lines = external_command ~echo_cmd:false cmd in - Unix.unlink config_file; - lines - -let print_curl_command chan curl_args = - fprintf chan "curl -q"; - List.iter ( - function - | name, None -> fprintf chan " --%s" name - (* Don't print passwords in the debug output. *) - | "user", Some _ -> fprintf chan " --user <hidden>" - | name, Some value -> fprintf chan " --%s %s" name (Filename.quote value) - ) curl_args; - fprintf chan "\n"; diff --git a/v2v/curl.mli b/v2v/curl.mli deleted file mode 100644 index cd01497..0000000 --- a/v2v/curl.mli +++ /dev/null @@ -1,38 +0,0 @@ -(* virt-v2v - * Copyright (C) 2009-2016 Red Hat Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. - *) - -(** Functions for dealing with [curl]. *) - -type curl_args = (string * string option) list - -val run : curl_args -> string list -(** [run curl_args] runs the [curl] command. - - It actually uses the [curl --config] option to pass the arguments - securely to curl through an external file. Thus passwords etc are - not exposed to other users on the same machine. - - The curl arguments are a list of key, value pairs corresponding - to curl command line parameters, without leading dashes, - eg. [("user", Some "user:password")]. - - The result is the output of curl as a list of lines. *) - -val print_curl_command : out_channel -> curl_args -> unit -(** Print the curl command line. This elides any arguments that - might contain passwords, so is useful for debugging. *) -- 2.7.4

On Thursday 07 July 2016 17:30:01 Richard W.M. Jones wrote: Definitely a nice improvement, thanks! Just a couple of notes below. I'd use "guestfs-curl" as prefix, as the location for this temporary file is the general $TMPDIR and would be mislead as generated by curl proper. Small unneeded indentation change. Ditto. Thanks, -- Pino Toscano

This adds imperative list manipulation functions inspired by Perl. The functions are passed list refs which get updated in place. This allows us to replace some awkward pure functional code like: let xs = ys in let xs = if foo then xs @ zs else xs in with: let xs = ref ys in if foo then append xs zs; --- mllib/common_utils.ml | 20 ++++++++++++++++++++ mllib/common_utils.mli | 36 ++++++++++++++++++++++++++++++++++++ 2 files changed, 56 insertions(+) diff --git a/mllib/common_utils.ml b/mllib/common_utils.ml index 77b9acd..40a19bc 100644 --- a/mllib/common_utils.ml +++ b/mllib/common_utils.ml @@ -282,6 +282,26 @@ let sort_uniq ?(cmp = Pervasives.compare) xs = let xs = uniq ~cmp xs in xs +let push xsp x = xsp := !xsp @ [x] +let unshift x xsp = xsp := x :: !xsp +let pop xsp = + let x, xs = + match List.rev !xsp with + | x :: xs -> x, xs + | [] -> failwith "pop" in + xsp := List.rev xs; + x +let shift 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 may f = function | None -> () | Some x -> f x diff --git a/mllib/common_utils.mli b/mllib/common_utils.mli index 5b0b9bb..97c7d9f 100644 --- a/mllib/common_utils.mli +++ b/mllib/common_utils.mli @@ -141,6 +141,42 @@ val uniq : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list val sort_uniq : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list (** Sort and uniquify a list. *) +val push : 'a list ref -> 'a -> unit +val unshift : 'a -> 'a list ref -> unit +val pop : 'a list ref -> 'a +val shift : 'a list ref -> 'a +(** Imperative list manipulation functions, similar to the Perl + functions described in http://perlmaven.com/manipulating-perl-arrays + + These operate on list references, and each function modifies the + list reference that is passed to it. + + [push xsp x] appends the element [x] to the end of the list [xsp]. + This function is not tail-recursive. + + [unshift 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 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"]. + This function is not tail-recursive. + + [shift 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 "shift"]. *) + +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} above, except it appends a list to + the list reference. This function is not tail-recursive. + + [prepend] is like {!unshift} above, except it prepends a list + to the list reference. *) + val may : ('a -> unit) -> 'a option -> unit (** [may f (Some x)] runs [f x]. [may f None] does nothing. *) -- 2.7.4

No functional change in this commit. --- builder/downloader.ml | 40 +++++++++++++++++++--------------------- v2v/copy_to_local.ml | 26 +++++++++++--------------- v2v/vCenter.ml | 34 ++++++++++++++++------------------ 3 files changed, 46 insertions(+), 54 deletions(-) diff --git a/builder/downloader.ml b/builder/downloader.ml index 3c9ba18..2a3f76f 100644 --- a/builder/downloader.ml +++ b/builder/downloader.ml @@ -95,17 +95,17 @@ 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 = - common_args @ - (if verbose () then [] else quiet_args) @ [ - "output", Some "/dev/null"; (* Write output to /dev/null. *) - "head", None; (* Request only HEAD. *) - (* Write HTTP status code to stdout. *) - "write-out", Some "%{http_code}"; - "url", Some uri - ] in + let curl_args = ref common_args in + if not (verbose ()) then append curl_args quiet_args; + append curl_args [ + "output", Some "/dev/null"; (* Write output to /dev/null. *) + "head", None; (* Request only HEAD. *) + (* Write HTTP status code to stdout. *) + "write-out", Some "%{http_code}"; + "url", Some uri + ]; - Curl.create ~curl:t.curl curl_args in + Curl.create ~curl:t.curl !curl_args in let lines = Curl.run curl_h in if List.length lines < 1 then @@ -122,19 +122,17 @@ and download_to t ?(progress_bar = false) ~proxy uri filename = (* Now download the file. *) let curl_h = - let curl_args = - common_args @ [ - "output", Some filename_new; - "url", Some uri - ] in + let curl_args = ref common_args in + append curl_args [ + "output", Some filename_new; + "url", Some uri + ]; - let curl_args = - curl_args @ - if verbose () then [] - else if progress_bar then [ "progress-bar", None ] - else quiet_args in + if verbose () then () + else if progress_bar then push curl_args ("progress-bar", None) + else append curl_args quiet_args; - Curl.create ~curl:t.curl curl_args in + Curl.create ~curl:t.curl !curl_args in ignore (Curl.run curl_h) ); diff --git a/v2v/copy_to_local.ml b/v2v/copy_to_local.ml index 2e3b59b..9dfb378 100644 --- a/v2v/copy_to_local.ml +++ b/v2v/copy_to_local.ml @@ -198,22 +198,18 @@ read the man page virt-v2v-copy-to-local(1). error (f_"ssh copy command failed, see earlier errors"); | ESXi _ -> - let curl_args = [ - "url", Some remote_disk; - "output", Some local_disk; - ] in - let curl_args = - if sslverify then curl_args - else ("insecure", None) :: curl_args in - let curl_args = - match cookie with - | None -> curl_args - | Some cookie -> ("cookie", Some cookie) :: curl_args in - let curl_args = - if quiet () then ("silent", None) :: curl_args - else curl_args in + let curl_args = ref [ + "url", Some remote_disk; + "output", Some local_disk; + ] in + if not sslverify then push curl_args ("insecure", None); + (match cookie with + | None -> () + | Some cookie -> push curl_args ("cookie", Some cookie) + ); + if quiet () then push curl_args ("silent", None); - let curl_h = Curl.create curl_args in + let curl_h = Curl.create !curl_args in if verbose () then Curl.print stderr curl_h; ignore (Curl.run curl_h) diff --git a/v2v/vCenter.ml b/v2v/vCenter.ml index ed4a9b2..f534a6d 100644 --- a/v2v/vCenter.ml +++ b/v2v/vCenter.ml @@ -45,25 +45,23 @@ let get_session_cookie password scheme uri sslverify url = if !session_cookie <> "" then Some !session_cookie else ( - let curl_args = [ - "head", None; - "silent", None; - "url", Some url; - ] in - let curl_args = - match uri.uri_user, password with - | None, None -> curl_args - | None, Some _ -> - warning (f_"--password-file parameter ignored because 'user@' was not given in the URL"); - curl_args - | Some user, None -> - ("user", Some user) :: curl_args - | Some user, Some password -> - ("user", Some (user ^ ":" ^ password)) :: curl_args in - let curl_args = - if not sslverify then ("insecure", None) :: curl_args else curl_args in + let curl_args = ref [ + "head", None; + "silent", None; + "url", Some url; + ] in + (match uri.uri_user, password with + | None, None -> () + | None, Some _ -> + warning (f_"--password-file parameter ignored because 'user@' was not given in the URL") + | Some user, None -> + push curl_args ("user", Some user) + | Some user, Some password -> + push curl_args ("user", Some (user ^ ":" ^ password)) + ); + if not sslverify then push curl_args ("insecure", None); - let curl_h = Curl.create curl_args in + let curl_h = Curl.create !curl_args in let lines = Curl.run curl_h in let dump_response chan = -- 2.7.4

In one case, I used prepend instead. --- builder/builder.ml | 2 +- builder/cmdline.ml | 8 ++++---- builder/languages.ml | 6 +++--- builder/sigchecker.ml | 4 +--- customize/customize_main.ml | 4 ++-- dib/cmdline.ml | 17 ++++++----------- generator/customize.ml | 20 ++++++++++---------- resize/resize.ml | 4 ++-- sparsify/cmdline.ml | 4 ++-- sysprep/main.ml | 2 +- sysprep/sysprep_operation.ml | 4 ++-- sysprep/sysprep_operation_script.ml | 2 +- v2v/cmdline.ml | 6 +++--- v2v/convert_linux.ml | 10 +++++----- v2v/convert_windows.ml | 2 +- v2v/copy_to_local.ml | 4 ++-- v2v/input_libvirtxml.ml | 11 ++++++----- v2v/input_ova.ml | 6 +++--- v2v/modules_list.ml | 10 +++++----- v2v/output_libvirt.ml | 2 +- v2v/test-harness/v2v_test_harness.ml | 6 +++--- 21 files changed, 64 insertions(+), 70 deletions(-) diff --git a/builder/builder.ml b/builder/builder.ml index 873df54..6754d9f 100644 --- a/builder/builder.ml +++ b/builder/builder.ml @@ -405,7 +405,7 @@ let main () = let is_not t = not (is t) in let remove = List.remove_assoc in let ret = ref [] in - let tr task weight otags = ret := (task, weight, otags) :: !ret in + let tr task weight otags = unshift (task, weight, otags) ret in (* XXX Weights are not very smartly chosen. At the moment I'm * using a range [0..100] where 0 = free and 100 = expensive. We diff --git a/builder/cmdline.ml b/builder/cmdline.ml index eee8367..93ac179 100644 --- a/builder/cmdline.ml +++ b/builder/cmdline.ml @@ -71,7 +71,7 @@ let parse_cmdline () = | "auto" -> attach_format := None | s -> attach_format := Some s in - let attach_disk s = attach := (!attach_format, s) :: !attach in + let attach_disk s = unshift (!attach_format, s) attach in let cache = ref Paths.xdg_cache_home in let set_cache arg = cache := Some arg in @@ -83,7 +83,7 @@ let parse_cmdline () = let delete_on_failure = ref true in let fingerprints = ref [] in - let add_fingerprint arg = fingerprints := arg :: !fingerprints in + let add_fingerprint arg = unshift arg fingerprints in let format = ref "" in let gpg = ref "gpg" in @@ -113,7 +113,7 @@ let parse_cmdline () = let set_smp arg = smp := Some arg in let sources = ref [] in - let add_source arg = sources := arg :: !sources in + let add_source arg = unshift arg sources in let sync = ref true in let warn_if_partition = ref true in @@ -175,7 +175,7 @@ let parse_cmdline () = let argspec = set_standard_options argspec in let args = ref [] in - let anon_fun s = args := s :: !args in + let anon_fun s = unshift s args in let usage_msg = sprintf (f_"\ %s: build virtual machine images quickly diff --git a/builder/languages.ml b/builder/languages.ml index 37acf83..5e1d70a 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 -> l := (lang ^ "_" ^ territory) :: !l); - l := lang :: !l; + | territory -> unshift (lang ^ "_" ^ territory) l); + unshift lang l; ); - l := "" :: !l; + unshift "" l; List.rev !l let languages () = diff --git a/builder/sigchecker.ml b/builder/sigchecker.ml index 94727d6..e2a3b5f 100644 --- a/builder/sigchecker.ml +++ b/builder/sigchecker.ml @@ -80,9 +80,7 @@ let import_keyfile ~gpg ~gpghome ?(trust = true) keyfile = (match !current with | None -> () | Some k -> - if String.is_suffix id k then ( - subkeys := id :: !subkeys; - ); + if String.is_suffix id k then unshift id subkeys; current := None ) | _ -> () diff --git a/customize/customize_main.ml b/customize/customize_main.ml index 5b7712e..6b58aea 100644 --- a/customize/customize_main.ml +++ b/customize/customize_main.ml @@ -38,7 +38,7 @@ let main () = | "auto" -> attach_format := None | s -> attach_format := Some s in - let attach_disk s = attach := (!attach_format, s) :: !attach in + let attach_disk s = unshift (!attach_format, s) attach in let domain = ref None in let dryrun = ref false in let files = ref [] in @@ -62,7 +62,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 - files := (uri, format) :: !files; + unshift (uri, format) files; format_consumed := true and set_domain dom = if !domain <> None then diff --git a/dib/cmdline.ml b/dib/cmdline.ml index 3a97366..f51a20d 100644 --- a/dib/cmdline.ml +++ b/dib/cmdline.ml @@ -68,20 +68,16 @@ read the man page virt-dib(1). prog in let elements = ref [] in - let append_element element = - elements := element :: !elements in + let append_element element = unshift element elements in let excluded_elements = ref [] in - let append_excluded_element element = - excluded_elements := element :: !excluded_elements in + let append_excluded_element element = unshift element excluded_elements in let element_paths = ref [] in - let append_element_path arg = - element_paths := arg :: !element_paths in + let append_element_path arg = unshift arg element_paths in let excluded_scripts = ref [] in - let append_excluded_script arg = - excluded_scripts := arg :: !excluded_scripts in + let append_excluded_script arg = unshift arg excluded_scripts in let debug = ref 0 in let set_debug arg = @@ -118,8 +114,7 @@ read the man page virt-dib(1). formats := fmts in let envvars = ref [] in - let append_envvar arg = - envvars := arg :: !envvars in + let append_envvar arg = unshift arg envvars in let use_base = ref true in @@ -153,7 +148,7 @@ read the man page virt-dib(1). let extra_packages = ref [] in let append_extra_packages arg = - extra_packages := List.rev (String.nsplit "," arg) @ !extra_packages in + prepend (List.rev (String.nsplit "," arg)) extra_packages in let argspec = [ "-p", Arg.String append_element_path, "path" ^ " " ^ s_"Add new a elements location"; diff --git a/generator/customize.ml b/generator/customize.ml index 5db76d5..b4b12c4 100644 --- a/generator/customize.ml +++ b/generator/customize.ml @@ -653,7 +653,7 @@ let rec argspec () = op_shortdesc = shortdesc; op_pod_longdesc = longdesc } -> pr " (\n"; pr " \"--%s\",\n" name; - pr " Arg.Unit (fun () -> ops := %s :: !ops),\n" discrim; + pr " Arg.Unit (fun () -> unshift %s ops),\n" discrim; pr " \" \" ^ s_\"%s\"\n" shortdesc; pr " ),\n"; pr " None, %S;\n" longdesc @@ -661,7 +661,7 @@ let rec argspec () = op_shortdesc = shortdesc; op_pod_longdesc = longdesc } -> pr " (\n"; pr " \"--%s\",\n" name; - pr " Arg.String (fun s -> ops := %s s :: !ops),\n" discrim; + pr " Arg.String (fun s -> unshift (%s s) ops),\n" discrim; pr " s_\"%s\" ^ \" \" ^ s_\"%s\"\n" v shortdesc; pr " ),\n"; pr " Some %S, %S;\n" v longdesc @@ -672,7 +672,7 @@ let rec argspec () = pr " Arg.String (\n"; pr " fun s ->\n"; pr " let p = split_string_pair \"%s\" s in\n" name; - pr " ops := %s p :: !ops\n" discrim; + pr " unshift (%s p) ops\n" discrim; pr " ),\n"; pr " s_\"%s\" ^ \" \" ^ s_\"%s\"\n" v shortdesc; pr " ),\n"; @@ -684,7 +684,7 @@ let rec argspec () = pr " Arg.String (\n"; pr " fun s ->\n"; pr " let ss = split_string_list s in\n"; - pr " ops := %s ss :: !ops\n" discrim; + pr " unshift (%s ss) ops\n" discrim; pr " ),\n"; pr " s_\"%s\" ^ \" \" ^ s_\"%s\"\n" v shortdesc; pr " ),\n"; @@ -696,7 +696,7 @@ let rec argspec () = pr " Arg.String (\n"; pr " fun s ->\n"; pr " let ss = split_links_list \"%s\" s in\n" name; - pr " ops := %s ss :: !ops\n" discrim; + pr " unshift (%s ss) ops\n" discrim; pr " ),\n"; pr " s_\"%s\" ^ \" \" ^ s_\"%s\"\n" v shortdesc; pr " ),\n"; @@ -708,7 +708,7 @@ let rec argspec () = pr " Arg.String (\n"; pr " fun s ->\n"; pr " let sel = Password.parse_selector s in\n"; - pr " ops := %s sel :: !ops\n" discrim; + pr " unshift (%s sel) ops\n" discrim; pr " ),\n"; pr " s_\"%s\" ^ \" \" ^ s_\"%s\"\n" v shortdesc; pr " ),\n"; @@ -721,7 +721,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 " ops := %s (user, sel) :: !ops\n" discrim; + pr " unshift (%s (user, sel)) ops\n" discrim; pr " ),\n"; pr " s_\"%s\" ^ \" \" ^ s_\"%s\"\n" v shortdesc; pr " ),\n"; @@ -734,7 +734,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 " ops := %s (user, sel) :: !ops\n" discrim; + pr " unshift (%s (user, sel)) ops\n" discrim; pr " ),\n"; pr " s_\"%s\" ^ \" \" ^ s_\"%s\"\n" v shortdesc; pr " ),\n"; @@ -746,7 +746,7 @@ let rec argspec () = pr " Arg.String (\n"; pr " fun s ->\n"; pr " %s s;\n" fn; - pr " ops := %s s :: !ops\n" discrim; + pr " unshift (%s s) ops\n" discrim; pr " ),\n"; pr " s_\"%s\" ^ \" \" ^ s_\"%s\"\n" v shortdesc; pr " ),\n"; @@ -758,7 +758,7 @@ let rec argspec () = pr " Arg.String (\n"; pr " fun s ->\n"; pr " let sel = Subscription_manager.parse_pool_selector s in\n"; - pr " ops := %s sel :: !ops\n" discrim; + pr " unshift (%s sel) ops\n" discrim; pr " ),\n"; pr " s_\"%s\" ^ \" \" ^ s_\"%s\"\n" v shortdesc; pr " ),\n"; diff --git a/resize/resize.ml b/resize/resize.ml index 22386ce..fb98c17 100644 --- a/resize/resize.ml +++ b/resize/resize.ml @@ -150,7 +150,7 @@ let main () = lv_expands, machine_readable, ntfsresize_force, output_format, resizes, resizes_force, shrink, sparse, unknown_fs_mode = - let add xs s = xs := s :: !xs in + let add xs s = unshift s xs in let align_first = ref "auto" in let alignment = ref 128 in @@ -214,7 +214,7 @@ let main () = ] in let argspec = set_standard_options argspec in let disks = ref [] in - let anon_fun s = disks := s :: !disks in + let anon_fun s = unshift 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 bd49e71..1855fa6 100644 --- a/sparsify/cmdline.ml +++ b/sparsify/cmdline.ml @@ -41,7 +41,7 @@ and mode_t = and check_t = [`Ignore|`Continue|`Warn|`Fail] let parse_cmdline () = - let add xs s = xs := s :: !xs in + let add xs s = unshift s xs in let check_tmpdir = ref `Warn in let set_check_tmpdir = function @@ -79,7 +79,7 @@ let parse_cmdline () = ] in let argspec = set_standard_options argspec in let disks = ref [] in - let anon_fun s = disks := s :: !disks in + let anon_fun s = unshift s disks in let usage_msg = sprintf (f_"\ %s: sparsify a virtual machine disk diff --git a/sysprep/main.ml b/sysprep/main.ml index 35a259c..c8db653 100644 --- a/sysprep/main.ml +++ b/sysprep/main.ml @@ -56,7 +56,7 @@ let main () = with Invalid_argument "URI.parse_uri" -> 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 - files := (uri, format) :: !files; + unshift (uri, format) files; format_consumed := true and set_domain dom = if !domain <> None then diff --git a/sysprep/sysprep_operation.ml b/sysprep/sysprep_operation.ml index 057c8c5..806e9d8 100644 --- a/sysprep/sysprep_operation.ml +++ b/sysprep/sysprep_operation.ml @@ -109,9 +109,9 @@ let remove_all_from_set set = empty_set let register_operation op = - all_operations := op :: !all_operations; + unshift op all_operations; if op.enabled_by_default then - enabled_by_default_operations := op :: !enabled_by_default_operations + unshift 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 140225c..f7f6e88 100644 --- a/sysprep/sysprep_operation_script.ml +++ b/sysprep/sysprep_operation_script.ml @@ -33,7 +33,7 @@ let set_scriptdir dir = scriptdir := Some dir let scripts = ref [] -let add_script script = scripts := script :: !scripts +let add_script script = unshift script scripts let rec script_perform (g : Guestfs.guestfs) root side_effects = let scripts = List.rev !scripts in diff --git a/v2v/cmdline.ml b/v2v/cmdline.ml index 1064987..558ace4 100644 --- a/v2v/cmdline.ml +++ b/v2v/cmdline.ml @@ -150,10 +150,10 @@ let parse_cmdline () = in let vdsm_image_uuids = ref [] in - let add_vdsm_image_uuid s = vdsm_image_uuids := s :: !vdsm_image_uuids in + let add_vdsm_image_uuid s = unshift s vdsm_image_uuids in let vdsm_vol_uuids = ref [] in - let add_vdsm_vol_uuid s = vdsm_vol_uuids := s :: !vdsm_vol_uuids in + let add_vdsm_vol_uuid s = unshift s vdsm_vol_uuids in let vmtype_warning _ = warning (f_"the --vmtype option has been removed and now does nothing") @@ -216,7 +216,7 @@ let parse_cmdline () = ] in let argspec = set_standard_options argspec in let args = ref [] in - let anon_fun s = args := s :: !args in + let anon_fun s = unshift 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 a5ba8dd..90f9543 100644 --- a/v2v/convert_linux.ml +++ b/v2v/convert_linux.ml @@ -555,13 +555,13 @@ let rec convert ~keep_serial_console (g : G.guestfs) inspect source rcaps = List.iter ( fun { G.app2_name = name } -> if String.is_prefix name "vmware-tools-libraries-" then - libraries := name :: !libraries + unshift name libraries else if String.is_prefix name "vmware-tools-" then - remove := name :: !remove + unshift name remove else if name = "VMwareTools" then - remove := name :: !remove + unshift name remove else if String.is_prefix name "kmod-vmware-tools" then - remove := name :: !remove + unshift name remove ) inspect.i_apps; let libraries = !libraries in @@ -601,7 +601,7 @@ let rec convert ~keep_serial_console (g : G.guestfs) inspect source rcaps = let cmd = Array.of_list cmd in (try ignore (g#command cmd); - remove := library :: !remove + unshift 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 diff --git a/v2v/convert_windows.ml b/v2v/convert_windows.ml index e5e4dc7..34fe9cb 100644 --- a/v2v/convert_windows.ml +++ b/v2v/convert_windows.ml @@ -196,7 +196,7 @@ let convert ~keep_serial_console (g : G.guestfs) inspect source rcaps = * uninstaller still shows a no-way-out reboot dialog *) " PREVENT_REBOOT=Yes LAUNCHED_BY_SETUP_EXE=Yes" in - uninsts := uninst :: !uninsts + unshift uninst uninsts with Not_found -> () ) uninstnodes diff --git a/v2v/copy_to_local.ml b/v2v/copy_to_local.ml index 9dfb378..3f2f09c 100644 --- a/v2v/copy_to_local.ml +++ b/v2v/copy_to_local.ml @@ -48,7 +48,7 @@ let rec main () = ] in let argspec = set_standard_options argspec in let args = ref [] in - let anon_fun s = args := s :: !args in + let anon_fun s = unshift s args in let usage_msg = sprintf (f_"\ %s: copy a remote guest to the local machine @@ -258,7 +258,7 @@ and parse_libvirt_xml guest_name xml = incr i; let local_disk = sprintf "%s-disk%d" guest_name !i in - disks := (remote_disk, local_disk) :: !disks; + unshift (remote_disk, local_disk) disks; local_disk in get_disks, add_disk diff --git a/v2v/input_libvirtxml.ml b/v2v/input_libvirtxml.ml index 552bd9f..a1fa96a 100644 --- a/v2v/input_libvirtxml.ml +++ b/v2v/input_libvirtxml.ml @@ -76,7 +76,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 - features := Xml.node_name node :: !features + unshift (Xml.node_name node) features done; !features in @@ -193,11 +193,12 @@ let parse_libvirt_xml ?conn xml = let get_disks () = List.rev !disks in let add_disk qemu_uri format controller p_source = incr i; - disks := + unshift { p_source_disk = { s_disk_id = !i; s_qemu_uri = qemu_uri; s_format = format; s_controller = controller }; - p_source = p_source } :: !disks + p_source = p_source } + disks in get_disks, add_disk in @@ -334,7 +335,7 @@ let parse_libvirt_xml ?conn xml = { s_removable_type = typ; s_removable_controller = controller; s_removable_slot = slot } in - disks := disk :: !disks + unshift disk disks done; List.rev !disks in @@ -378,7 +379,7 @@ let parse_libvirt_xml ?conn xml = s_vnet_orig = vnet; s_vnet_type = vnet_type } in - nics := nic :: !nics + unshift nic nics in match xpath_string "source/@network | source/@bridge" with | None -> () diff --git a/v2v/input_ova.ml b/v2v/input_ova.ml index 8a5886c..f3d35c4 100644 --- a/v2v/input_ova.ml +++ b/v2v/input_ova.ml @@ -287,7 +287,7 @@ object s_format = Some "vmdk"; s_controller = controller; } in - disks := disk :: !disks; + unshift disk disks; ) else error (f_"could not parse disk rasd:HostResource from OVF document") done in @@ -331,7 +331,7 @@ object s_removable_controller = controller; s_removable_slot = slot; } in - removables := disk :: !removables; + unshift disk removables; done in let removables = List.rev !removables in @@ -351,7 +351,7 @@ object s_vnet_orig = vnet; s_vnet_type = Network; } in - nics := nic :: !nics + unshift nic nics done; let source = { diff --git a/v2v/modules_list.ml b/v2v/modules_list.ml index fd7b2ff..30b044e 100644 --- a/v2v/modules_list.ml +++ b/v2v/modules_list.ml @@ -16,13 +16,13 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) +open Common_utils + let input_modules = ref [] and output_modules = ref [] -let register_input_module name = - input_modules := name :: !input_modules -and register_output_module name = - output_modules := name :: !output_modules +let register_input_module name = unshift name input_modules +and register_output_module name = unshift name output_modules let input_modules () = List.sort compare !input_modules and output_modules () = List.sort compare !output_modules @@ -35,7 +35,7 @@ type conversion_fn = let convert_modules = ref [] let register_convert_module inspect_fn name conversion_fn = - convert_modules := (inspect_fn, (name, conversion_fn)) :: !convert_modules + unshift (inspect_fn, (name, conversion_fn)) convert_modules let find_convert_module inspect = let rec loop = function diff --git a/v2v/output_libvirt.ml b/v2v/output_libvirt.ml index e7067d7..69cdd2b 100644 --- a/v2v/output_libvirt.ml +++ b/v2v/output_libvirt.ml @@ -64,7 +64,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 - features := feature_name :: !features + unshift feature_name features done; !features ) diff --git a/v2v/test-harness/v2v_test_harness.ml b/v2v/test-harness/v2v_test_harness.ml index 70ce73e..f774978 100644 --- a/v2v/test-harness/v2v_test_harness.ml +++ b/v2v/test-harness/v2v_test_harness.ml @@ -94,7 +94,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 - nodes := Xml.xpathobj_node xpathobj i :: !nodes + unshift (Xml.xpathobj_node xpathobj i) nodes done; List.rev !nodes in @@ -210,7 +210,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 lines := input_line chan :: !lines done + (try while true do unshift (input_line chan) lines done with End_of_file -> ()); let lines = List.rev !lines in let stat = close_process_in chan in @@ -283,7 +283,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 lines := input_line chan :: !lines done + (try while true do unshift (input_line chan) lines done with End_of_file -> ()); let lines = List.rev !lines in let stat = close_process_in chan in -- 2.7.4

--- v2v/OVF.ml | 173 +++++++++++++++++++++++++------------------------- v2v/output_libvirt.ml | 16 +++-- 2 files changed, 100 insertions(+), 89 deletions(-) diff --git a/v2v/OVF.ml b/v2v/OVF.ml index ec835e5..97b2928 100644 --- a/v2v/OVF.ml +++ b/v2v/OVF.ml @@ -274,76 +274,77 @@ let rec create_ovf source targets guestcaps inspect e "Info" [] [PCData "List of Virtual Disks"] ]; - e "Content" ["ovf:id", "out"; "xsi:type", "ovf:VirtualSystem_Type"] ( - let es = [ - e "Name" [] [PCData source.s_name]; - e "TemplateId" [] [PCData "00000000-0000-0000-0000-000000000000"]; - e "TemplateName" [] [PCData "Blank"]; - e "Description" [] [PCData generated_by]; - e "Domain" [] []; - e "CreationDate" [] [PCData iso_time]; - e "IsInitilized" (* sic *) [] [PCData "True"]; - e "IsAutoSuspend" [] [PCData "False"]; - e "TimeZone" [] []; - e "IsStateless" [] [PCData "False"]; - e "VmType" [] [PCData vmtype]; - (* See https://bugzilla.redhat.com/show_bug.cgi?id=1260590#c17 *) - e "DefaultDisplayType" [] [PCData "1"]; - ] in + let content_subnodes = ref [ + e "Name" [] [PCData source.s_name]; + e "TemplateId" [] [PCData "00000000-0000-0000-0000-000000000000"]; + e "TemplateName" [] [PCData "Blank"]; + e "Description" [] [PCData generated_by]; + e "Domain" [] []; + e "CreationDate" [] [PCData iso_time]; + e "IsInitilized" (* sic *) [] [PCData "True"]; + e "IsAutoSuspend" [] [PCData "False"]; + e "TimeZone" [] []; + e "IsStateless" [] [PCData "False"]; + e "VmType" [] [PCData vmtype]; + (* See https://bugzilla.redhat.com/show_bug.cgi?id=1260590#c17 *) + e "DefaultDisplayType" [] [PCData "1"]; + ] in - (* Add the <Origin/> element if we can. *) - let es = - match origin_of_source_hypervisor source.s_hypervisor with - | None -> es - | Some origin -> - es @ [e "Origin" [] [PCData (string_of_int origin)]] in + (* Add the <Origin/> element if we can. *) + (match origin_of_source_hypervisor source.s_hypervisor with + | None -> () + | Some origin -> + push content_subnodes (e "Origin" [] [PCData (string_of_int origin)]) + ); - es @ [ - e "Section" ["ovf:id", vm_uuid; "ovf:required", "false"; - "xsi:type", "ovf:OperatingSystemSection_Type"] [ - e "Info" [] [PCData inspect.i_product_name]; - e "Description" [] [PCData ostype]; - ]; + append content_subnodes [ + e "Section" ["ovf:id", vm_uuid; "ovf:required", "false"; + "xsi:type", "ovf:OperatingSystemSection_Type"] [ + e "Info" [] [PCData inspect.i_product_name]; + e "Description" [] [PCData ostype]; + ]; - e "Section" ["xsi:type", "ovf:VirtualHardwareSection_Type"] [ - e "Info" [] [PCData (sprintf "%d CPU, %Ld Memory" source.s_vcpu memsize_mb)]; - e "Item" [] [ - e "rasd:Caption" [] [PCData (sprintf "%d virtual cpu" source.s_vcpu)]; - e "rasd:Description" [] [PCData "Number of virtual CPU"]; - e "rasd:InstanceId" [] [PCData "1"]; - e "rasd:ResourceType" [] [PCData "3"]; - e "rasd:num_of_sockets" [] [PCData (string_of_int source.s_vcpu)]; - e "rasd:cpu_per_socket"[] [PCData "1"]; - ]; - e "Item" [] [ - e "rasd:Caption" [] [PCData (sprintf "%Ld MB of memory" memsize_mb)]; - e "rasd:Description" [] [PCData "Memory Size"]; - e "rasd:InstanceId" [] [PCData "2"]; - e "rasd:ResourceType" [] [PCData "4"]; - e "rasd:AllocationUnits" [] [PCData "MegaBytes"]; - e "rasd:VirtualQuantity" [] [PCData (Int64.to_string memsize_mb)]; - ]; - e "Item" [] [ - e "rasd:Caption" [] [PCData "USB Controller"]; - e "rasd:InstanceId" [] [PCData "3"]; - e "rasd:ResourceType" [] [PCData "23"]; - e "rasd:UsbPolicy" [] [PCData "Disabled"]; - ]; - (* We always add a qxl device when outputting to RHEV. - * See RHBZ#1213701 and RHBZ#1211231 for the reasoning - * behind that. - *) - e "Item" [] [ - e "rasd:Caption" [] [PCData "Graphical Controller"]; - e "rasd:InstanceId" [] [PCData (uuidgen ())]; - e "rasd:ResourceType" [] [PCData "20"]; - e "Type" [] [PCData "video"]; - e "rasd:VirtualQuantity" [] [PCData "1"]; - e "rasd:Device" [] [PCData "qxl"]; - ] + e "Section" ["xsi:type", "ovf:VirtualHardwareSection_Type"] [ + e "Info" [] [PCData (sprintf "%d CPU, %Ld Memory" source.s_vcpu memsize_mb)]; + e "Item" [] [ + e "rasd:Caption" [] [PCData (sprintf "%d virtual cpu" source.s_vcpu)]; + e "rasd:Description" [] [PCData "Number of virtual CPU"]; + e "rasd:InstanceId" [] [PCData "1"]; + e "rasd:ResourceType" [] [PCData "3"]; + e "rasd:num_of_sockets" [] [PCData (string_of_int source.s_vcpu)]; + e "rasd:cpu_per_socket"[] [PCData "1"]; + ]; + e "Item" [] [ + e "rasd:Caption" [] [PCData (sprintf "%Ld MB of memory" memsize_mb)]; + e "rasd:Description" [] [PCData "Memory Size"]; + e "rasd:InstanceId" [] [PCData "2"]; + e "rasd:ResourceType" [] [PCData "4"]; + e "rasd:AllocationUnits" [] [PCData "MegaBytes"]; + e "rasd:VirtualQuantity" [] [PCData (Int64.to_string memsize_mb)]; + ]; + e "Item" [] [ + e "rasd:Caption" [] [PCData "USB Controller"]; + e "rasd:InstanceId" [] [PCData "3"]; + e "rasd:ResourceType" [] [PCData "23"]; + e "rasd:UsbPolicy" [] [PCData "Disabled"]; + ]; + (* We always add a qxl device when outputting to RHEV. + * See RHBZ#1213701 and RHBZ#1211231 for the reasoning + * behind that. + *) + e "Item" [] [ + e "rasd:Caption" [] [PCData "Graphical Controller"]; + e "rasd:InstanceId" [] [PCData (uuidgen ())]; + e "rasd:ResourceType" [] [PCData "20"]; + e "Type" [] [PCData "video"]; + e "rasd:VirtualQuantity" [] [PCData "1"]; + e "rasd:Device" [] [PCData "qxl"]; ] ] - ) + ]; + + e "Content" ["ovf:id", "out"; "xsi:type", "ovf:VirtualSystem_Type"] + !content_subnodes ] in (* Add disks to the OVF XML. *) @@ -448,7 +449,7 @@ and add_disks targets guestcaps output_alloc sd_uuid image_uuids vol_uuids ovf = (* Add disk to DiskSection. *) let disk = - let attrs = [ + let attrs = ref [ "ovf:diskId", vol_uuid; "ovf:size", Int64.to_string size_gb; "ovf:fileRef", fileref; @@ -465,12 +466,12 @@ and add_disks targets guestcaps output_alloc sd_uuid image_uuids vol_uuids ovf = "ovf:disk-type", "System"; (* RHBZ#744538 *) "ovf:boot", if is_bootable_drive then "True" else "False"; ] in - let attrs = - match actual_size_gb with - | None -> attrs - | Some actual_size_gb -> - ("ovf:actual_size", Int64.to_string actual_size_gb) :: attrs in - e "Disk" attrs [] in + (match actual_size_gb with + | None -> () + | Some actual_size_gb -> + push attrs ("ovf:actual_size", Int64.to_string actual_size_gb) + ); + e "Disk" !attrs [] in if is_estimate then ( let comment = Comment "note: actual_size field is estimated" in append_child comment disk_section @@ -483,7 +484,7 @@ and add_disks targets guestcaps output_alloc sd_uuid image_uuids vol_uuids ovf = * will not parse. *) let caption = sprintf "Drive %d" (i+1) in - e "Item" [] ([ + let item_subnodes = ref [ e "rasd:Caption" [] [PCData caption]; e "rasd:InstanceId" [] [PCData vol_uuid]; e "rasd:ResourceType" [] [PCData "17"]; @@ -497,12 +498,12 @@ and add_disks targets guestcaps output_alloc sd_uuid image_uuids vol_uuids ovf = e "rasd:CreationDate" [] [PCData iso_time]; e "rasd:LastModified" [] [PCData iso_time]; e "rasd:last_modified_date" [] [PCData iso_time]; - ] @ - if is_bootable_drive then - [e "BootOrder" [] [PCData (string_of_int boot_order)]] - else - [] - ) in + ] in + if is_bootable_drive then + push 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) @@ -543,7 +544,7 @@ and add_networks nics guestcaps ovf = append_child network network_section; let item = - let children = [ + let item_subnodes = ref [ e "rasd:InstanceId" [] [PCData (uuidgen ())]; e "rasd:Caption" [] [PCData (sprintf "Ethernet adapter on %s" vnet)]; e "rasd:ResourceType" [] [PCData "10"]; @@ -552,11 +553,13 @@ and add_networks nics guestcaps ovf = e "rasd:Connection" [] [PCData vnet]; e "rasd:Name" [] [PCData dev]; ] in - let children = - match mac with - | None -> children - | Some mac -> children @ [e "rasd:MACAddress" [] [PCData mac]] in - e "Item" [] children in + (match mac with + | None -> () + | Some mac -> + push item_subnodes + (e "rasd:MACAddress" [] [PCData mac]) + ); + e "Item" [] !item_subnodes in append_child item virtualhardware_section; ) nics diff --git a/v2v/output_libvirt.ml b/v2v/output_libvirt.ml index 69cdd2b..750c64d 100644 --- a/v2v/output_libvirt.ml +++ b/v2v/output_libvirt.ml @@ -125,6 +125,9 @@ let create_libvirt_xml ?pool source target_buses guestcaps (e "type" ["arch", guestcaps.gcaps_arch] [PCData "hvm"]) :: loader in + (* The devices. *) + let devices = ref [] in + (* Fixed and removable disks. *) let disks = let make_disk bus_name drive_prefix i = function @@ -189,6 +192,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; let nics = let net_model = @@ -221,6 +225,7 @@ let create_libvirt_xml ?pool source target_buses guestcaps nic ) source.s_nics in + append devices nics; (* Same as old virt-v2v, we always add a display here even if it was * missing from the old metadata. @@ -232,6 +237,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 devices video; let graphics = match source.s_display with @@ -267,6 +273,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 devices graphics; let sound = match source.s_sound with @@ -276,13 +283,14 @@ let create_libvirt_xml ?pool source target_buses guestcaps [ e "sound" [ "model", string_of_source_sound_model model ] [] ] else [] in + append devices sound; - let devices = disks @ nics @ [video] @ [graphics] @ sound @ - (* Standard devices added to every guest. *) [ + (* Standard devices added to every guest. *) + append devices [ e "input" ["type", "tablet"; "bus", "usb"] []; e "input" ["type", "mouse"; "bus", "ps2"] []; e "console" ["type", "pty"] []; - ] in + ]; let doc : doc = doc "domain" [ @@ -300,7 +308,7 @@ let create_libvirt_xml ?pool source target_buses guestcaps e "on_reboot" [] [PCData "restart"]; e "on_crash" [] [PCData "restart"]; - e "devices" [] devices; + e "devices" [] !devices; ] in doc -- 2.7.4