thr3ads.net - Libguestfs - Re: [Libguestfs] [PATCH v3 4/8] mllib: Add some imperative list manipulation functions. [Jul 2016]

If this information is useful, please help other people find it:
Share via:

Richard W.M. Jones

2016-Jul-07 16:29 UTC

[Libguestfs] [PATCH v3 0/8] v2v: Move Curl wrapper to mllib and more.

v2 -> v3:

 - Changes to the Curl API suggested by Pino.

Richard W.M. Jones

2016-Jul-07 16:30 UTC

head link

[Libguestfs] [PATCH v3 1/8] v2v: Move Curl wrapper to mllib.

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

Richard W.M. Jones

2016-Jul-07 16:30 UTC

head link

[Libguestfs] [PATCH v3 2/8] curl: Change the API to use an abstract data type.

Change the Curl module to use an ADT to store the name of the curl
binary and the arguments.

The callers in virt-v2v are changed accordingly.

This also adds a (currently unused) ?proxy argument to allow callers
to override the proxy.  It also adds some safety arguments implicitly.
---
 mllib/curl.ml        | 50 ++++++++++++++++++++++++++++++++++++++------------
 mllib/curl.mli       | 50 +++++++++++++++++++++++++++++++++++++++++---------
 v2v/copy_to_local.ml | 11 ++++++-----
 v2v/vCenter.ml       | 13 +++++++------
 4 files changed, 92 insertions(+), 32 deletions(-)

diff --git a/mllib/curl.ml b/mllib/curl.ml
index f0af160..d7983ec 100644
--- a/mllib/curl.ml
+++ b/mllib/curl.ml
@@ -20,10 +20,32 @@ open Printf
 
 open Common_utils
 
-type curl_args = (string * string option) list
+let quote = Filename.quote
 
-let run curl_args -  let config_file, chan = Filename.open_temp_file
"v2vcurl" ".conf" in
+type t = {
+  curl : string;
+  args : args;
+}
+and args = (string * string option) list
+
+let safe_args = [
+  "max-redirs", Some "5";
+  "globoff", None;         (* Don't glob URLs. *)
+]
+
+type proxy = UnsetProxy | SystemProxy | ForcedProxy of string
+
+let args_of_proxy = function
+  | UnsetProxy ->      [ "proxy", Some "" ;
"noproxy", Some "*" ]
+  | SystemProxy ->     []
+  | ForcedProxy url -> [ "proxy", Some url; "noproxy",
Some "" ]
+
+let create ?(curl = "curl") ?(proxy = SystemProxy) args +  let args =
safe_args @ args_of_proxy proxy @ args in
+  { curl = curl; args = args }
+
+let run { curl = curl; args = args } +  let config_file, chan =
Filename.open_temp_file "curl" ".conf" in
   List.iter (
     function
     | name, None -> fprintf chan "%s\n" name
@@ -44,21 +66,25 @@ let run curl_args          | c -> output_char chan c
       done;
       fprintf chan "\"\n"
-  ) curl_args;
+  ) args;
   close_out chan;
 
-  let cmd = sprintf "curl -q --config %s" (Filename.quote
config_file) in
+  let cmd = sprintf "%s -q --config %s" (quote curl) (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";
+let to_string { curl = curl; args = args } +  let b = Buffer.create 128 in
+  bprintf b "%s -q" (quote curl);
   List.iter (
     function
-    | name, None -> fprintf chan " --%s" name
+    | name, None -> bprintf b " --%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";
+    | "user", Some _ -> bprintf b " --user
<hidden>"
+    | name, Some value -> bprintf b " --%s %s" name (quote value)
+  ) args;
+  bprintf b "\n";
+  Buffer.contents b
+
+let print chan t = output_string chan (to_string t)
diff --git a/mllib/curl.mli b/mllib/curl.mli
index cd01497..f045572 100644
--- a/mllib/curl.mli
+++ b/mllib/curl.mli
@@ -18,21 +18,53 @@
 
 (** Functions for dealing with [curl]. *)
 
-type curl_args = (string * string option) list
+type t
 
-val run : curl_args -> string list
-(** [run curl_args] runs the [curl] command.
+type args = (string * string option) list
 
-    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.
+type proxy +  | UnsetProxy            (** The proxy is forced off. *)
+  | SystemProxy           (** Use the system settings. *)
+  | ForcedProxy of string (** The proxy is forced to the specified URL. *)
+
+val create : ?curl:string -> ?proxy:proxy -> args -> t
+(** Create a curl command handle.
 
     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 optional [?curl] parameter controls the name of the curl
+    binary (default ["curl"]).
+
+    The optional [?proxy] parameter adds extra arguments to
+    control the proxy.
+
+    Note that some extra arguments are added implicitly:
+
+    - [--max-redirs 5] Only follow 3XX redirects up to 5 times.
+    - [--globoff] Disable URL globbing.
+
+    Note this does {b not} enable redirects.  If you want to follow
+    redirects you have to add the ["location"] parameter yourself. *)
+
+val run : t -> string list
+(** [run t] runs previously constructed 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 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. *)
+val to_string : t -> string
+(** Convert the curl command line to a string.
+
+    This elides any arguments that might contain passwords, so is
+    useful for debugging. *)
+
+val print : out_channel -> t -> unit
+(** Print the curl command line.
+
+    This elides any arguments that might contain passwords, so is
+    useful for debugging. *)
diff --git a/v2v/copy_to_local.ml b/v2v/copy_to_local.ml
index 717ba50..2e3b59b 100644
--- a/v2v/copy_to_local.ml
+++ b/v2v/copy_to_local.ml
@@ -199,9 +199,9 @@ read the man page virt-v2v-copy-to-local(1).
 
     | ESXi _ ->
        let curl_args = [
-         "url", Some remote_disk;
-         "output", Some local_disk;
-       ] in
+           "url", Some remote_disk;
+           "output", Some local_disk;
+         ] in
        let curl_args           if sslverify then curl_args
          else ("insecure", None) :: curl_args in
@@ -213,9 +213,10 @@ read the man page virt-v2v-copy-to-local(1).
          if quiet () then ("silent", None) :: curl_args
          else curl_args in
 
+       let curl_h = Curl.create curl_args in
        if verbose () then
-         Curl.print_curl_command stderr curl_args;
-       ignore (Curl.run curl_args)
+         Curl.print stderr curl_h;
+       ignore (Curl.run curl_h)
 
     | Test ->
        let cmd = [ "cp"; remote_disk; local_disk ] in
diff --git a/v2v/vCenter.ml b/v2v/vCenter.ml
index d41f223..ed4a9b2 100644
--- a/v2v/vCenter.ml
+++ b/v2v/vCenter.ml
@@ -46,10 +46,10 @@ let get_session_cookie password scheme uri sslverify url    
Some !session_cookie
   else (
     let curl_args = [
-      "head", None;
-      "silent", None;
-      "url", Some url;
-    ] in
+        "head", None;
+        "silent", None;
+        "url", Some url;
+      ] in
     let curl_args        match uri.uri_user, password with
       | None, None -> curl_args
@@ -63,10 +63,11 @@ let get_session_cookie password scheme uri sslverify url    
let curl_args        if not sslverify then ("insecure", None) ::
curl_args else curl_args in
 
-    let lines = Curl.run curl_args in
+    let curl_h = Curl.create curl_args in
+    let lines = Curl.run curl_h in
 
     let dump_response chan -      Curl.print_curl_command chan curl_args;
+      Curl.print chan curl_h;
 
       (* Dump out the output of the command. *)
       List.iter (fun x -> fprintf chan "%s\n" x) lines;
-- 
2.7.4

Richard W.M. Jones

2016-Jul-07 16:30 UTC

head link

[Libguestfs] [PATCH v3 3/8] builder: Use the new Curl module for passing parameters to curl.

These are now passed using a curl configuration file, which is a
little bit safer than using command lines.  virt-builder doesn't need
to pass usernames and passwords to curl, but if it ever does in future
this will be a lot safer.
---
 builder/Makefile.am    |  1 +
 builder/builder.ml     |  2 +-
 builder/downloader.ml  | 80 ++++++++++++++++++++++++--------------------------
 builder/downloader.mli | 10 +------
 builder/index.ml       |  2 +-
 builder/index.mli      |  2 +-
 builder/sources.ml     | 10 +++----
 builder/sources.mli    |  2 +-
 8 files changed, 49 insertions(+), 60 deletions(-)

diff --git a/builder/Makefile.am b/builder/Makefile.am
index ad32940..5c41cfa 100644
--- a/builder/Makefile.am
+++ b/builder/Makefile.am
@@ -144,6 +144,7 @@ BOBJECTS = \
 	$(top_builddir)/mllib/JSON.cmo \
 	$(top_builddir)/mllib/URI.cmo \
 	$(top_builddir)/mllib/mkdtemp.cmo \
+	$(top_builddir)/mllib/curl.cmo \
 	$(top_builddir)/customize/customize_utils.cmo \
 	$(top_builddir)/customize/urandom.cmo \
 	$(top_builddir)/customize/random_seed.cmo \
diff --git a/builder/builder.ml b/builder/builder.ml
index affce10..873df54 100644
--- a/builder/builder.ml
+++ b/builder/builder.ml
@@ -185,7 +185,7 @@ let main ()        {
         Sources.name = source; uri = source;
         gpgkey = Utils.Fingerprint fingerprint;
-        proxy = Downloader.SystemProxy;
+        proxy = Curl.SystemProxy;
         format = Sources.FormatNative;
       }
   ) cmdline.sources in
diff --git a/builder/downloader.ml b/builder/downloader.ml
index 8c47bad..3c9ba18 100644
--- a/builder/downloader.ml
+++ b/builder/downloader.ml
@@ -32,17 +32,12 @@ type t = {
   cache : Cache.t option;               (* cache for templates *)
 }
 
-type proxy_mode -  | UnsetProxy
-  | SystemProxy
-  | ForcedProxy of string
-
 let create ~curl ~cache = {
   curl = curl;
   cache = cache;
 }
 
-let rec download t ?template ?progress_bar ?(proxy = SystemProxy) uri +let rec
download t ?template ?progress_bar ?(proxy = Curl.SystemProxy) uri    match
template with
   | None ->                       (* no cache, simple download *)
     (* Create a temporary name. *)
@@ -83,6 +78,7 @@ and download_to t ?(progress_bar = false) ~proxy uri filename 
unlink_on_exit filename_new;
 
   (match parseduri.URI.protocol with
+  (* Download (ie. copy) from a local file. *)
   | "file" ->
     let path = parseduri.URI.path in
     let cmd = [ "cp" ] @
@@ -91,15 +87,27 @@ and download_to t ?(progress_bar = false) ~proxy uri
filename      let r = run_command cmd in
     if r <> 0 then
       error (f_"cp (download) command failed copying '%s'")
path;
-  | _ as protocol -> (* Any other protocol. *)
-    let outenv = proxy_envvar protocol proxy in
+
+  (* Any other protocol. *)
+  | _ ->
+    let common_args = [ "location", None ] (* Follow 3XX redirects.
*) in
+    let quiet_args = [ "silent", None; "show-error", None ]
in
+
     (* Get the status code first to ensure the file exists. *)
-    let cmd = sprintf "%s%s%s -L --max-redirs 5 -g -o /dev/null -I -w
'%%{http_code}' %s"
-      outenv
-      t.curl
-      (if verbose () then "" else " -s -S")
-      (quote uri) in
-    let lines = external_command cmd in
+    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
+
+      Curl.create ~curl:t.curl curl_args in
+
+    let lines = Curl.run curl_h in
     if List.length lines < 1 then
       error (f_"unexpected output from curl command, enable debug and look
at previous messages");
     let status_code = List.hd lines in
@@ -113,35 +121,23 @@ and download_to t ?(progress_bar = false) ~proxy uri
filename        error (f_"failed to download %s: HTTP status code %s")
uri status_code;
 
     (* Now download the file. *)
-    let cmd = sprintf "%s%s%s -L --max-redirs 5 -g -o %s %s"
-      outenv
-      t.curl
-      (if verbose () then "" else if progress_bar then "
-#" else " -s -S")
-      (quote filename_new) (quote uri) in
-    let r = shell_command cmd in
-    if r <> 0 then
-      error (f_"curl (download) command failed downloading
'%s'") uri;
+    let curl_h +      let curl_args +        common_args @ [
+          "output", Some filename_new;
+          "url", Some uri
+        ] in
+
+      let curl_args +        curl_args @
+          if verbose () then []
+          else if progress_bar then [ "progress-bar", None ]
+          else quiet_args in
+
+      Curl.create ~curl:t.curl curl_args in
+
+    ignore (Curl.run curl_h)
   );
 
   (* Rename the file if the download was successful. *)
   rename filename_new filename
-
-and proxy_envvar protocol = function
-  | UnsetProxy ->
-    (match protocol with
-    | "http" -> "env http_proxy= no_proxy=* "
-    | "https" -> "env https_proxy= no_proxy=* "
-    | "ftp" -> "env ftp_proxy= no_proxy=* "
-    | _ -> "env no_proxy=* "
-    )
-  | SystemProxy ->
-    (* No changes required. *)
-    ""
-  | ForcedProxy proxy ->
-    let proxy = quote proxy in
-    (match protocol with
-    | "http" -> sprintf "env http_proxy=%s no_proxy= "
proxy
-    | "https" -> sprintf "env https_proxy=%s no_proxy= "
proxy
-    | "ftp" -> sprintf "env ftp_proxy=%s no_proxy= "
proxy
-    | _ -> ""
-    )
diff --git a/builder/downloader.mli b/builder/downloader.mli
index 11ec498..c99aee2 100644
--- a/builder/downloader.mli
+++ b/builder/downloader.mli
@@ -24,18 +24,10 @@ type filename = string
 type t
 (** The abstract data type. *)
 
-(** Type of proxy. *)
-type proxy_mode -  | UnsetProxy                 (* The proxy is forced off. *)
-  | SystemProxy                (* The proxy is not changed (follows the
-                                * system configuration).
-                                *)
-  | ForcedProxy of string      (* The proxy is forced to the specified URL. *)
-
 val create : curl:string -> cache:Cache.t option -> t
 (** Create the abstract type. *)
 
-val download : t -> ?template:(string*string*Utils.revision) ->
?progress_bar:bool -> ?proxy:proxy_mode -> uri -> (filename * bool)
+val download : t -> ?template:(string*string*Utils.revision) ->
?progress_bar:bool -> ?proxy:Curl.proxy -> uri -> (filename * bool)
 (** Download the URI, returning the downloaded filename and a
     temporary file flag.  The temporary file flag is [true] iff
     the downloaded file is temporary and should be deleted by the
diff --git a/builder/index.ml b/builder/index.ml
index 01b4a5f..23b9820 100644
--- a/builder/index.ml
+++ b/builder/index.ml
@@ -43,7 +43,7 @@ and entry = {
   aliases : string list option;
 
   sigchecker : Sigchecker.t;
-  proxy : Downloader.proxy_mode;
+  proxy : Curl.proxy;
 }
 
 let print_entry chan (name, { printable_name = printable_name;
diff --git a/builder/index.mli b/builder/index.mli
index 07cfb9d..09b277e 100644
--- a/builder/index.mli
+++ b/builder/index.mli
@@ -35,7 +35,7 @@ and entry = {
   aliases : string list option;
 
   sigchecker : Sigchecker.t;
-  proxy : Downloader.proxy_mode;
+  proxy : Curl.proxy;
 }
 
 val print_entry : out_channel -> (string * entry) -> unit
diff --git a/builder/sources.ml b/builder/sources.ml
index 4c8d6c7..db1a969 100644
--- a/builder/sources.ml
+++ b/builder/sources.ml
@@ -26,7 +26,7 @@ type source = {
   name : string;
   uri : string;
   gpgkey : Utils.gpgkey_type;
-  proxy : Downloader.proxy_mode;
+  proxy : Curl.proxy;
   format : source_format;
 }
 and source_format @@ -67,12 +67,12 @@ let parse_conf file          let proxy   
try
             (match (List.assoc ("proxy", None) fields) with
-            | "no" | "off" -> Downloader.UnsetProxy
-            | "system" -> Downloader.SystemProxy
-            | _ as proxy -> Downloader.ForcedProxy proxy
+            | "no" | "off" -> Curl.UnsetProxy
+            | "system" -> Curl.SystemProxy
+            | _ as proxy -> Curl.ForcedProxy proxy
             )
           with
-            Not_found -> Downloader.SystemProxy in
+            Not_found -> Curl.SystemProxy in
         let format            try
             (match (List.assoc ("format", None) fields) with
diff --git a/builder/sources.mli b/builder/sources.mli
index e621a9f..6594d00 100644
--- a/builder/sources.mli
+++ b/builder/sources.mli
@@ -20,7 +20,7 @@ type source = {
   name : string;
   uri : string;
   gpgkey : Utils.gpgkey_type;
-  proxy : Downloader.proxy_mode;
+  proxy : Curl.proxy;
   format : source_format;
 }
 and source_format -- 
2.7.4

Richard W.M. Jones

2016-Jul-07 16:30 UTC

head link

[Libguestfs] [PATCH v3 4/8] mllib: Add some imperative list manipulation functions.

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

Richard W.M. Jones

2016-Jul-07 16:30 UTC

head link

[Libguestfs] [PATCH v3 5/8] builder, v2v: Use imperative list functions to simplify curl arg code.

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

Richard W.M. Jones

2016-Jul-07 16:30 UTC

head link

[Libguestfs] [PATCH v3 6/8] Replace 'xs := x :: !xs' with 'unshift x xs'.

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

Richard W.M. Jones

2016-Jul-07 16:30 UTC

head link

[Libguestfs] [PATCH v3 7/8] v2v: Don't open DOM module in output_rhev and output_vdsm.

I think this is left over from before we moved the OVF code
out to its own module.
---
 v2v/output_rhev.ml | 3 +--
 v2v/output_vdsm.ml | 3 +--
 2 files changed, 2 insertions(+), 4 deletions(-)

diff --git a/v2v/output_rhev.ml b/v2v/output_rhev.ml
index 5277456..e45043b 100644
--- a/v2v/output_rhev.ml
+++ b/v2v/output_rhev.ml
@@ -24,7 +24,6 @@ open Printf
 
 open Types
 open Utils
-open DOM
 
 let rec mount_and_check_storage_domain domain_class os    (* The user can
either specify -os nfs:/export, or a local directory
@@ -276,7 +275,7 @@ object
     let dir = esd_mp // esd_uuid // "master" // "vms" //
vm_uuid in
     Changeuid.mkdir changeuid_t dir 0o755;
     let file = dir // vm_uuid ^ ".ovf" in
-    Changeuid.output changeuid_t file (fun chan -> doc_to_chan chan ovf);
+    Changeuid.output changeuid_t file (fun chan -> DOM.doc_to_chan chan
ovf);
 
     (* Finished, so don't delete the target directory on exit. *)
     delete_target_directory <- false
diff --git a/v2v/output_vdsm.ml b/v2v/output_vdsm.ml
index 39f722b..7cd94c0 100644
--- a/v2v/output_vdsm.ml
+++ b/v2v/output_vdsm.ml
@@ -24,7 +24,6 @@ open Printf
 
 open Types
 open Utils
-open DOM
 
 type vdsm_params = {
   image_uuids : string list;
@@ -171,7 +170,7 @@ object
     (* Write it to the metadata file. *)
     let file = vdsm_params.ovf_output // vdsm_params.vm_uuid ^ ".ovf"
in
     let chan = open_out file in
-    doc_to_chan chan ovf;
+    DOM.doc_to_chan chan ovf;
     close_out chan
 end
 
-- 
2.7.4

Richard W.M. Jones

2016-Jul-07 16:30 UTC

head link

[Libguestfs] [PATCH v3 8/8] v2v: Use imperative list functions to simplify DOM building code.

---
 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

Pino Toscano

2016-Jul-07 17:00 UTC

head link

Re: [Libguestfs] [PATCH v3 2/8] curl: Change the API to use an abstract data type.

On Thursday 07 July 2016 17:30:01 Richard W.M. Jones
wrote:> Change the Curl module to use an ADT to store the name of the curl
> binary and the arguments.
> 
> The callers in virt-v2v are changed accordingly.
> 
> This also adds a (currently unused) ?proxy argument to allow callers
> to override the proxy.  It also adds some safety arguments implicitly.
> ---
Definitely a nice improvement, thanks!

Just a couple of notes below.
> +let run { curl = curl; args = args } > +  let config_file, chan =
Filename.open_temp_file "curl" ".conf" in
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.
> diff --git a/v2v/copy_to_local.ml b/v2v/copy_to_local.ml
> index 717ba50..2e3b59b 100644
> --- a/v2v/copy_to_local.ml
> +++ b/v2v/copy_to_local.ml
> @@ -199,9 +199,9 @@ read the man page virt-v2v-copy-to-local(1).
>  
>      | ESXi _ ->
>         let curl_args = [
> -         "url", Some remote_disk;
> -         "output", Some local_disk;
> -       ] in
> +           "url", Some remote_disk;
> +           "output", Some local_disk;
> +         ] in
Small unneeded indentation change.
> diff --git a/v2v/vCenter.ml b/v2v/vCenter.ml
> index d41f223..ed4a9b2 100644
> --- a/v2v/vCenter.ml
> +++ b/v2v/vCenter.ml
> @@ -46,10 +46,10 @@ let get_session_cookie password scheme uri sslverify
url >      Some !session_cookie
>    else (
>      let curl_args = [
> -      "head", None;
> -      "silent", None;
> -      "url", Some url;
> -    ] in
> +        "head", None;
> +        "silent", None;
> +        "url", Some url;
> +      ] in
Ditto.

Thanks,
-- 
Pino Toscano

Pino Toscano

2016-Jul-07 17:00 UTC

head link

Re: [Libguestfs] [PATCH v3 4/8] mllib: Add some imperative list manipulation functions.

On Thursday 07 July 2016 17:30:03 Richard W.M. Jones
wrote:> 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;
> ---
TBH I've always found the "shift" and "unshift" naming
of Perl
functions slightly awkward, but can live with them. (At least the
new functions do the same as Perl ones.)

-- 
Pino Toscano

Pino Toscano

2016-Jul-07 17:00 UTC

head link

Re: [Libguestfs] [PATCH v3 5/8] builder, v2v: Use imperative list functions to simplify curl arg code.

On Thursday 07 July 2016 17:30:04 Richard W.M. Jones
wrote:> -      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;
Hm this could be better as:

  if not (verbose ()) then (
     if progress_bar then push curl_args ("progress-bar", None)
     else append curl_args quiet_args;
  );

Thanks,
-- 
Pino Toscano

Pino Toscano

2016-Jul-07 17:01 UTC

head link

Re: [Libguestfs] [PATCH v3 0/8] v2v: Move Curl wrapper to mllib and more.

On Thursday 07 July 2016 17:29:59 Richard W.M. Jones
wrote:> v2 -> v3:
> 
>  - Changes to the Curl API suggested by Pino.
With the last suggested changes for patches #2 and #5, LGTM.

Thanks,
-- 
Pino Toscano

Reasonably Related Threads

Search for more apparently analagous threads

Libguestfs - Jul 2016 - Re: [PATCH v3 4/8] mllib: Add some imperative list manipulation functions.

[Libguestfs] [PATCH v3 0/8] v2v: Move Curl wrapper to mllib and more.

[Libguestfs] [PATCH v3 1/8] v2v: Move Curl wrapper to mllib.

[Libguestfs] [PATCH v3 2/8] curl: Change the API to use an abstract data type.

[Libguestfs] [PATCH v3 3/8] builder: Use the new Curl module for passing parameters to curl.

[Libguestfs] [PATCH v3 4/8] mllib: Add some imperative list manipulation functions.

[Libguestfs] [PATCH v3 5/8] builder, v2v: Use imperative list functions to simplify curl arg code.

[Libguestfs] [PATCH v3 6/8] Replace 'xs := x :: !xs' with 'unshift x xs'.

[Libguestfs] [PATCH v3 7/8] v2v: Don't open DOM module in output_rhev and output_vdsm.

[Libguestfs] [PATCH v3 8/8] v2v: Use imperative list functions to simplify DOM building code.

Re: [Libguestfs] [PATCH v3 2/8] curl: Change the API to use an abstract data type.

Re: [Libguestfs] [PATCH v3 4/8] mllib: Add some imperative list manipulation functions.

Re: [Libguestfs] [PATCH v3 5/8] builder, v2v: Use imperative list functions to simplify curl arg code.

Re: [Libguestfs] [PATCH v3 0/8] v2v: Move Curl wrapper to mllib and more.

Reasonably Related Threads