[Libguestfs] [PATCH 01/14] v2v: Allow relative paths to appear in -i libvirtxml input.

[Richard W.M. Jones]

When writing libvirt XML by hand, or for tests, this is
immensely useful.
---
 mllib/common_utils.ml |  4 ++++
 v2v/source_libvirt.ml | 28 ++++++++++++++++++++++++----
 2 files changed, 28 insertions(+), 4 deletions(-)

diff --git a/mllib/common_utils.ml b/mllib/common_utils.ml
index 1aa81fb..60e3812 100644
--- a/mllib/common_utils.ml
+++ b/mllib/common_utils.ml
@@ -458,3 +458,7 @@ let is_char_device file =
 let is_directory path =
   try Sys.is_directory path
   with Sys_error _ -> false
+
+let absolute_path path =
+  if not (Filename.is_relative path) then path
+  else Sys.getcwd () // path
diff --git a/v2v/source_libvirt.ml b/v2v/source_libvirt.ml
index 3e252ed..245e0d2 100644
--- a/v2v/source_libvirt.ml
+++ b/v2v/source_libvirt.ml
@@ -24,7 +24,24 @@ open Common_utils
 open Types
 open Utils
 
-let create_xml xml =
+let create_xml ?dir xml =
+  (* When reading libvirt XML from a file (-i libvirtxml) we allow
+   * paths to disk images in the libvirt XML to be relative.  Relative
+   * paths are in fact not permitted in real libvirt XML, but they are
+   * very useful when dealing with test images or when writing the XML
+   * by hand.
+   *)
+  let absolute_path_of_disk path =
+    if not (Filename.is_relative path) then path
+    else (
+      match dir with
+      | None ->
+        error (f_"libvirt returned a non-absolute path in the XML (%s)") path
+      | Some dir ->
+        dir // path
+    )
+  in
+
   let doc = Xml.parse_memory xml in
   let xpathctx = Xml.xpath_new_context doc in
 
@@ -87,10 +104,12 @@ let create_xml xml =
       match xpath_to_string "@type" "" with
       | "block" ->
         let path = xpath_to_string "source/@dev" "" in
-        if path <> "" then disks := (path, format) :: !disks
+        if path <> "" then
+          disks := (absolute_path_of_disk path, format) :: !disks
       | "file" ->
         let path = xpath_to_string "source/@file" "" in
-        if path <> "" then disks := (path, format) :: !disks
+        if path <> "" then
+          disks := (absolute_path_of_disk path, format) :: !disks
       | "network" ->
         (* We only handle <source protocol="nbd"> here, and that is
          * intended only for virt-p2v.  Any other network disk is
@@ -137,7 +156,8 @@ let create_xml xml =
 
 let create_from_xml file =
   let xml = read_whole_file file in
-  create_xml xml
+  let dir = Filename.dirname (absolute_path file) in
+  create_xml ~dir xml
 
 let create libvirt_uri guest =
   let cmd =
-- 
1.9.0