Libguestfs - Aug 2016 - [PATCH] mllib: move _exit from v2v as Exit module

Move the OCaml binding to C _exit to an own module.

Just code motion, adapting v2v in the process.
---
 docs/C_SOURCE_FILES |  2 +-
 mllib/Makefile.am   |  5 ++++-
 mllib/exit-c.c      | 33 +++++++++++++++++++++++++++++++++
 mllib/exit.ml       | 19 +++++++++++++++++++
 mllib/exit.mli      | 20 ++++++++++++++++++++
 v2v/Makefile.am     |  1 -
 v2v/changeuid-c.c   | 33 ---------------------------------
 v2v/changeuid.ml    |  7 ++-----
 8 files changed, 79 insertions(+), 41 deletions(-)
 create mode 100644 mllib/exit-c.c
 create mode 100644 mllib/exit.ml
 create mode 100644 mllib/exit.mli
 delete mode 100644 v2v/changeuid-c.c

diff --git a/docs/C_SOURCE_FILES b/docs/C_SOURCE_FILES
index 3db4db3..551ce16 100644
--- a/docs/C_SOURCE_FILES
+++ b/docs/C_SOURCE_FILES
@@ -181,6 +181,7 @@ lua/lua-guestfs.c
 make-fs/make-fs.c
 mllib/dev_t-c.c
 mllib/dummy.c
+mllib/exit-c.c
 mllib/fsync-c.c
 mllib/getopt-c.c
 mllib/mkdtemp-c.c
@@ -286,7 +287,6 @@ utils/boot-analysis/boot-analysis.c
 utils/boot-benchmark/boot-benchmark.c
 utils/qemu-boot/qemu-boot.c
 utils/qemu-speed-test/qemu-speed-test.c
-v2v/changeuid-c.c
 v2v/domainxml-c.c
 v2v/utils-c.c
 v2v/xml-c.c
diff --git a/mllib/Makefile.am b/mllib/Makefile.am
index 8f8b5f4..69df1bc 100644
--- a/mllib/Makefile.am
+++ b/mllib/Makefile.am
@@ -32,6 +32,7 @@ SOURCES_MLI = \
 	common_utils.mli \
 	curl.mli \
 	dev_t.mli \
+	exit.mli \
 	fsync.mli \
 	getopt.mli \
 	JSON.mli \
@@ -60,12 +61,14 @@ SOURCES_ML = \
 	regedit.ml \
 	StatVFS.ml \
 	JSON.ml \
-	curl.ml
+	curl.ml \
+	exit.ml
 
 SOURCES_C = \
 	../fish/progress.c \
 	../fish/uri.c \
 	dev_t-c.c \
+	exit-c.c \
 	fsync-c.c \
 	getopt-c.c \
 	mkdtemp-c.c \
diff --git a/mllib/exit-c.c b/mllib/exit-c.c
new file mode 100644
index 0000000..eed58a3
--- /dev/null
+++ b/mllib/exit-c.c
@@ -0,0 +1,33 @@
+/* libguestfs OCaml tools common code
+ * 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.
+ */
+
+#include <config.h>
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <unistd.h>
+
+#include <caml/mlvalues.h>
+
+extern int guestfs_int_mllib_exit (value rv) __attribute__((noreturn));
+
+int
+guestfs_int_mllib_exit (value rv)
+{
+  _exit (Int_val (rv));
+}
diff --git a/mllib/exit.ml b/mllib/exit.ml
new file mode 100644
index 0000000..e752bfe
--- /dev/null
+++ b/mllib/exit.ml
@@ -0,0 +1,19 @@
+(* libguestfs OCaml tools common code
+ * Copyright (C) 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.
+ *)
+
+external _exit : int -> unit = "guestfs_int_mllib_exit"
"noalloc"
diff --git a/mllib/exit.mli b/mllib/exit.mli
new file mode 100644
index 0000000..c1f0ab5
--- /dev/null
+++ b/mllib/exit.mli
@@ -0,0 +1,20 @@
+(* libguestfs OCaml tools common code
+ * Copyright (C) 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.
+ *)
+
+val _exit : int -> unit
+(** Call _exit directly, ie. do not run OCaml atexit handlers. *)
diff --git a/v2v/Makefile.am b/v2v/Makefile.am
index 8fd013d..008c5ba 100644
--- a/v2v/Makefile.am
+++ b/v2v/Makefile.am
@@ -95,7 +95,6 @@ SOURCES_ML = \
 
 SOURCES_C = \
 	domainxml-c.c \
-	changeuid-c.c \
 	utils-c.c \
 	xml-c.c
 
diff --git a/v2v/changeuid-c.c b/v2v/changeuid-c.c
deleted file mode 100644
index 0de5a30..0000000
--- a/v2v/changeuid-c.c
+++ /dev/null
@@ -1,33 +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.
- */
-
-#include <config.h>
-
-#include <stdio.h>
-#include <stdlib.h>
-#include <unistd.h>
-
-#include <caml/mlvalues.h>
-
-extern int v2v_exit (value rv) __attribute__((noreturn));
-
-int
-v2v_exit (value rv)
-{
-  _exit (Int_val (rv));
-}
diff --git a/v2v/changeuid.ml b/v2v/changeuid.ml
index 07cf6fb..53c0bc3 100644
--- a/v2v/changeuid.ml
+++ b/v2v/changeuid.ml
@@ -33,9 +33,6 @@ type t = {
 
 let create ?uid ?gid () = { uid = uid; gid = gid }
 
-(* Call _exit directly, ie. do not run OCaml atexit handlers. *)
-external _exit : int -> unit = "v2v_exit" "noalloc"
-
 let with_fork { uid = uid; gid = gid } name f    let pid = fork () in
 
@@ -46,9 +43,9 @@ let with_fork { uid = uid; gid = gid } name f      (try f ()
      with exn ->
        eprintf "%s: changeuid: %s: %s\n%!" prog name
(Printexc.to_string exn);
-       _exit 1
+       Exit._exit 1
     );
-    _exit 0
+    Exit._exit 0
   );
 
   (* Parent. *)
-- 
2.7.4

Instead of running them before lanching the appliance with the disks and
then uploading the result after root.d hooks run, mount the root in the
local temporary directory using FUSE and then run the hooks on the
guest.  Other than being closer to what diskimage-builder does, it also
avoids issues with the extra-data.d scripts assuming to find things
already, and we don't error out while trying to unpack files on the
guest.

Since virt-dib requires FUSE now, build it only if FUSE is supported.
---
 Makefile.am      |   4 +-
 dib/dib.ml       | 123 +++++++++++++++++++++++++++++++------------------------
 dib/virt-dib.pod |  23 -----------
 3 files changed, 73 insertions(+), 77 deletions(-)

diff --git a/Makefile.am b/Makefile.am
index 4b5babb..acc6bd4 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -147,7 +147,6 @@ SUBDIRS += \
 	mllib \
 	customize \
 	builder builder/website \
-	dib \
 	get-kernel \
 	resize \
 	sparsify \
@@ -156,6 +155,9 @@ SUBDIRS += \
 if HAVE_OCAML_PKG_LIBVIRT
 SUBDIRS += v2v/test-harness
 endif
+if HAVE_FUSE
+SUBDIRS += dib
+endif
 endif
 
 # Perl tools.
diff --git a/dib/dib.ml b/dib/dib.ml
index 87af4eb..17775d8 100644
--- a/dib/dib.ml
+++ b/dib/dib.ml
@@ -69,13 +69,15 @@ let envvars_string l  
 let prepare_external ~envvars ~dib_args ~dib_vars ~out_name ~root_label
   ~rootfs_uuid ~image_cache ~arch ~network ~debug
-  destdir libdir hooksdir tmpdir fakebindir all_elements element_paths + 
destdir libdir hooksdir fakebindir all_elements element_paths    let
network_string = if network then "" else "1" in
 
   let run_extra = sprintf "\
 #!/bin/bash
 set -e
 %s
+mount_dir=$1
+shift
 target_dir=$1
 shift
 script=$1
@@ -87,7 +89,7 @@ shift
 export PATH=%s:$PATH
 
 # d-i-b variables
-export TMP_MOUNT_PATH=%s
+export TMP_MOUNT_PATH=\"$mount_dir\"
 export DIB_OFFLINE=%s
 export IMAGE_NAME=\"%s\"
 export DIB_ROOT_LABEL=\"%s\"
@@ -120,7 +122,6 @@ $target_dir/$script
     (if debug >= 1 then "set -x\n" else "")
     (envvars_string envvars)
     fakebindir
-    (quote tmpdir)
     network_string
     out_name
     root_label
@@ -134,10 +135,7 @@ $target_dir/$script
     (String.concat ":" element_paths)
     (quote dib_vars)
     debug in
-  write_script (destdir // "run-part-extra.sh") run_extra;
-
-  (* Needed as TMPDIR for the extra-data hooks *)
-  do_mkdir (tmpdir // "tmp")
+  write_script (destdir // "run-part-extra.sh") run_extra
 
 let prepare_aux ~envvars ~dib_args ~dib_vars ~log_file ~out_name ~rootfs_uuid
   ~arch ~network ~root_label ~install_type ~debug ~extra_packages
@@ -392,26 +390,61 @@ let run_parts ~debug ~sysroot ~blockdev ~log_file ?(new_wd
= "")
   flush_all ();
   Buffer.contents outbuf
 
-let run_parts_host ~debug hooks_dir hook_name scripts run_script +let
run_parts_host ~debug (g : Guestfs.guestfs) hooks_dir hook_name base_mount_dir
scripts run_script    let hook_dir = hooks_dir // hook_name in
   let scripts = List.sort digit_prefix_compare scripts in
-  let timings = Hashtbl.create 13 in
-  List.iter (
-    fun x ->
-      message (f_"Running: %s/%s") hook_name x;
-      let cmd = [ run_script; hook_dir; x ] in
-      let run () -        run_command cmd in
-      let delta_t = timed_run run in
-      if debug >= 1 then (
-        printf "\n";
-        printf "%s completed after %.3f s\n" x delta_t
-      );
-      Hashtbl.add timings x delta_t;
-  ) scripts;
-  if debug >= 1 then (
-    print_string (timing_output ~target_name:hook_name scripts timings)
+  let mount_dir = base_mount_dir // hook_name in
+  do_mkdir mount_dir;
+
+  let rec fork_and_run () +    let pid = Unix.fork () in
+    if pid = 0 then ( (* child *)
+      let retcode = run_scripts () in
+      flush_all ();
+      let cmd = [ "guestunmount"; mount_dir ] in
+      ignore (run_command cmd);
+      Exit._exit retcode
+    );
+    pid
+  and run_scripts () +    let timings = Hashtbl.create 13 in
+    let rec loop = function
+      | x :: xs ->
+        message (f_"Running: %s/%s") hook_name x;
+        let cmd = [ run_script; mount_dir; hook_dir; x ] in
+        let retcode = ref 0 in
+        let run () +          retcode := run_command cmd in
+        let delta_t = timed_run run in
+        if debug >= 1 then (
+          printf "\n";
+          printf "%s completed after %.3f s\n" x delta_t
+        );
+        Hashtbl.add timings x delta_t;
+        let retcode = !retcode in
+        if retcode <> 0 then retcode
+        else loop xs
+      | [] -> 0
+    in
+    let retcode = loop scripts in
+    if debug >= 1 then (
+      print_string (timing_output ~target_name:hook_name scripts timings)
+    );
+    retcode
+  in
+
+  g#mount_local mount_dir;
+  let pid = fork_and_run () in
+  g#mount_local_run ();
+
+  (match snd (Unix.waitpid [] pid) with
+  | Unix.WEXITED 0 -> ()
+  | Unix.WEXITED i -> exit i
+  | Unix.WSIGNALED i
+  | Unix.WSTOPPED i ->
+    error (f_"sub-process killed by signal (%d)") i
   );
+
   flush_all ()
 
 let run_install_packages ~debug ~blockdev ~log_file
@@ -455,8 +488,6 @@ let main ()    do_mkdir auxtmpdir;
   let hookstmpdir = auxtmpdir // "hooks" in
   do_mkdir (hookstmpdir // "environment.d");    (* Just like d-i-b
does. *)
-  let extradatatmpdir = tmpdir // "extra-data" in
-  do_mkdir extradatatmpdir;
   do_mkdir (auxtmpdir // "out" // image_basename_d);
   let elements      if cmdline.use_base then ["base"] @
cmdline.elements
@@ -575,20 +606,11 @@ let main ()    prepare_external ~envvars ~dib_args
~dib_vars ~out_name:image_basename
                    ~root_label ~rootfs_uuid ~image_cache ~arch
                    ~network:cmdline.network ~debug
-                   tmpdir cmdline.basepath hookstmpdir extradatatmpdir
+                   tmpdir cmdline.basepath hookstmpdir
                    (auxtmpdir // "fake-bin")
                    all_elements cmdline.element_paths;
 
-  let run_hook_host hook -    try
-      let scripts = Hashtbl.find final_hooks hook in
-      if debug >= 1 then (
-        printf "Running hooks for %s...\n%!" hook;
-      );
-      run_parts_host ~debug hookstmpdir hook scripts
-        (tmpdir // "run-part-extra.sh")
-    with Not_found -> ()
-  and run_hook ~blockdev ~sysroot ?(new_wd = "") (g :
Guestfs.guestfs) hook +  let run_hook ~blockdev ~sysroot ?(new_wd =
"") (g : Guestfs.guestfs) hook      try
       let scripts = Hashtbl.find final_hooks hook in
       if debug >= 1 then (
@@ -597,8 +619,6 @@ let main ()        run_parts ~debug ~sysroot ~blockdev
~log_file ~new_wd g hook scripts
     with Not_found -> "" in
 
-  run_hook_host "extra-data.d";
-
   let copy_in (g : Guestfs.guestfs) srcdir destdir      let desttar =
Filename.temp_file ~temp_dir:tmpdir "virt-dib." ".tar.gz" in
     let cmd = [ "tar"; "czf"; desttar; "-C";
srcdir; "--owner=root";
@@ -608,18 +628,6 @@ let main ()      g#tar_in ~compress:"gzip"
desttar destdir;
     Sys.remove desttar in
 
-  let copy_preserve_in (g : Guestfs.guestfs) srcdir destdir -    let desttar =
Filename.temp_file ~temp_dir:tmpdir "virt-dib." ".tar.gz" in
-    let remotetar = "/tmp/aux/" ^ (Filename.basename desttar) in
-    let cmd = [ "tar"; "czf"; desttar; "-C";
srcdir; "--owner=root";
-                "--group=root"; "." ] in
-    if run_command cmd <> 0 then exit 1;
-    g#upload desttar remotetar;
-    let verbose_flag = if debug > 0 then "v" else "" in
-    ignore (g#debug "sh" [| "tar"; "-C";
"/sysroot" ^ destdir; "--no-overwrite-dir"; "-x" ^
verbose_flag ^ "zf"; "/sysroot" ^ remotetar |]);
-    Sys.remove desttar;
-    g#rm remotetar in
-
   if debug >= 1 then
     ignore (run_command [ "tree"; "-ps"; tmpdir ]);
 
@@ -747,7 +755,16 @@ let main ()    and run_hook_subroot hook     
do_run_hooks_noout ~sysroot:Subroot hook
   and do_run_hooks_noout ~sysroot ?(new_wd = "") hook -    ignore
(run_hook ~sysroot ~blockdev ~new_wd g hook) in
+    ignore (run_hook ~sysroot ~blockdev ~new_wd g hook)
+  and run_hook_host hook +    try
+      let scripts = Hashtbl.find final_hooks hook in
+      if debug >= 1 then (
+        printf "Running hooks for %s...\n%!" hook;
+      );
+      run_parts_host ~debug g hookstmpdir hook tmpdir scripts
+        (tmpdir // "run-part-extra.sh")
+    with Not_found -> () in
 
   g#sync ();
   checked_umount_all ();
@@ -799,7 +816,7 @@ let main ()    mount_aux ();
   g#ln_s "aux/hooks" "/tmp/in_target.d";
 
-  copy_preserve_in g extradatatmpdir "/";
+  run_hook_host "extra-data.d";
 
   run_hook_in "pre-install.d";
 
diff --git a/dib/virt-dib.pod b/dib/virt-dib.pod
index 8ccb9f5..41e7ec7 100644
--- a/dib/virt-dib.pod
+++ b/dib/virt-dib.pod
@@ -577,29 +577,6 @@ arguments
 
 =item
 
-C<extra-data.d> scripts run in the host environment, before all the
-other ones (even C<root.d>); this means that, depending on the
-configuration for the elements, some of them may fail due to missing
-content (usually directories) in C<TMP_HOOKS_PATH>.
-
-Workarounds for this may be either:
-
-=over 4
-
-=item
-
-fix the C<extra-data.d> scripts to create the missing directories
-
-=item
-
-create (and use) a simple element with a C<extra-data.d> script
-named e.g. F<00-create-missing-dirs> to create the missing
-directories
-
-=back
-
-=item
-
 extra tools needed on some out-of-chroot phases need to be available
 in the appliance, see L</EXTRA DEPENDENCIES>.
 
-- 
2.7.4

On Wed, Aug 03, 2016 at 04:49:43PM +0200, Pino Toscano
wrote:
> Instead of running them before lanching the appliance with the disks and
> then uploading the result after root.d hooks run, mount the root in the
> local temporary directory using FUSE and then run the hooks on the
> guest.  Other than being closer to what diskimage-builder does, it also
> avoids issues with the extra-data.d scripts assuming to find things
> already, and we don't error out while trying to unpack files on the
> guest.
> 
> Since virt-dib requires FUSE now, build it only if FUSE is supported.
> ---
>  Makefile.am      |   4 +-
>  dib/dib.ml       | 123
+++++++++++++++++++++++++++++++------------------------
>  dib/virt-dib.pod |  23 -----------
>  3 files changed, 73 insertions(+), 77 deletions(-)
> 
> diff --git a/Makefile.am b/Makefile.am
> index 4b5babb..acc6bd4 100644
> --- a/Makefile.am
> +++ b/Makefile.am
> @@ -147,7 +147,6 @@ SUBDIRS += \
>  	mllib \
>  	customize \
>  	builder builder/website \
> -	dib \
>  	get-kernel \
>  	resize \
>  	sparsify \
> @@ -156,6 +155,9 @@ SUBDIRS += \
>  if HAVE_OCAML_PKG_LIBVIRT
>  SUBDIRS += v2v/test-harness
>  endif
> +if HAVE_FUSE
> +SUBDIRS += dib
> +endif
>  endif
>  
>  # Perl tools.
> diff --git a/dib/dib.ml b/dib/dib.ml
> index 87af4eb..17775d8 100644
> --- a/dib/dib.ml
> +++ b/dib/dib.ml
> @@ -69,13 +69,15 @@ let envvars_string l >  
>  let prepare_external ~envvars ~dib_args ~dib_vars ~out_name ~root_label
>    ~rootfs_uuid ~image_cache ~arch ~network ~debug
> -  destdir libdir hooksdir tmpdir fakebindir all_elements element_paths
> +  destdir libdir hooksdir fakebindir all_elements element_paths >   
let network_string = if network then "" else "1" in
>  
>    let run_extra = sprintf "\
>  #!/bin/bash
>  set -e
>  %s
> +mount_dir=$1
> +shift
>  target_dir=$1
>  shift
>  script=$1
> @@ -87,7 +89,7 @@ shift
>  export PATH=%s:$PATH
>  
>  # d-i-b variables
> -export TMP_MOUNT_PATH=%s
> +export TMP_MOUNT_PATH=\"$mount_dir\"
>  export DIB_OFFLINE=%s
>  export IMAGE_NAME=\"%s\"
>  export DIB_ROOT_LABEL=\"%s\"
> @@ -120,7 +122,6 @@ $target_dir/$script
>      (if debug >= 1 then "set -x\n" else "")
>      (envvars_string envvars)
>      fakebindir
> -    (quote tmpdir)
>      network_string
>      out_name
>      root_label
> @@ -134,10 +135,7 @@ $target_dir/$script
>      (String.concat ":" element_paths)
>      (quote dib_vars)
>      debug in
> -  write_script (destdir // "run-part-extra.sh") run_extra;
> -
> -  (* Needed as TMPDIR for the extra-data hooks *)
> -  do_mkdir (tmpdir // "tmp")
> +  write_script (destdir // "run-part-extra.sh") run_extra
>  
>  let prepare_aux ~envvars ~dib_args ~dib_vars ~log_file ~out_name
~rootfs_uuid
>    ~arch ~network ~root_label ~install_type ~debug ~extra_packages
> @@ -392,26 +390,61 @@ let run_parts ~debug ~sysroot ~blockdev ~log_file
?(new_wd = "")
>    flush_all ();
>    Buffer.contents outbuf
>  
> -let run_parts_host ~debug hooks_dir hook_name scripts run_script > +let
run_parts_host ~debug (g : Guestfs.guestfs) hooks_dir hook_name base_mount_dir
scripts run_script >    let hook_dir = hooks_dir // hook_name in
>    let scripts = List.sort digit_prefix_compare scripts in
> -  let timings = Hashtbl.create 13 in
> -  List.iter (
> -    fun x ->
> -      message (f_"Running: %s/%s") hook_name x;
> -      let cmd = [ run_script; hook_dir; x ] in
> -      let run () > -        run_command cmd in
> -      let delta_t = timed_run run in
> -      if debug >= 1 then (
> -        printf "\n";
> -        printf "%s completed after %.3f s\n" x delta_t
> -      );
> -      Hashtbl.add timings x delta_t;
> -  ) scripts;
> -  if debug >= 1 then (
> -    print_string (timing_output ~target_name:hook_name scripts timings)
> +  let mount_dir = base_mount_dir // hook_name in
> +  do_mkdir mount_dir;
> +
> +  let rec fork_and_run () > +    let pid = Unix.fork () in
> +    if pid = 0 then ( (* child *)
> +      let retcode = run_scripts () in
> +      flush_all ();
> +      let cmd = [ "guestunmount"; mount_dir ] in
> +      ignore (run_command cmd);
> +      Exit._exit retcode
> +    );
> +    pid
> +  and run_scripts () > +    let timings = Hashtbl.create 13 in
> +    let rec loop = function
> +      | x :: xs ->
> +        message (f_"Running: %s/%s") hook_name x;
> +        let cmd = [ run_script; mount_dir; hook_dir; x ] in
> +        let retcode = ref 0 in
> +        let run () > +          retcode := run_command cmd in
> +        let delta_t = timed_run run in
> +        if debug >= 1 then (
> +          printf "\n";
> +          printf "%s completed after %.3f s\n" x delta_t
> +        );
> +        Hashtbl.add timings x delta_t;
> +        let retcode = !retcode in
> +        if retcode <> 0 then retcode
> +        else loop xs
> +      | [] -> 0
> +    in
> +    let retcode = loop scripts in
> +    if debug >= 1 then (
> +      print_string (timing_output ~target_name:hook_name scripts timings)
> +    );
> +    retcode
> +  in
> +
> +  g#mount_local mount_dir;
> +  let pid = fork_and_run () in
> +  g#mount_local_run ();
> +
> +  (match snd (Unix.waitpid [] pid) with
> +  | Unix.WEXITED 0 -> ()
> +  | Unix.WEXITED i -> exit i
> +  | Unix.WSIGNALED i
> +  | Unix.WSTOPPED i ->
> +    error (f_"sub-process killed by signal (%d)") i
>    );
> +
>    flush_all ()
>  
>  let run_install_packages ~debug ~blockdev ~log_file
> @@ -455,8 +488,6 @@ let main () >    do_mkdir auxtmpdir;
>    let hookstmpdir = auxtmpdir // "hooks" in
>    do_mkdir (hookstmpdir // "environment.d");    (* Just like
d-i-b does. *)
> -  let extradatatmpdir = tmpdir // "extra-data" in
> -  do_mkdir extradatatmpdir;
>    do_mkdir (auxtmpdir // "out" // image_basename_d);
>    let elements >      if cmdline.use_base then ["base"] @
cmdline.elements
> @@ -575,20 +606,11 @@ let main () >    prepare_external ~envvars
~dib_args ~dib_vars ~out_name:image_basename
>                     ~root_label ~rootfs_uuid ~image_cache ~arch
>                     ~network:cmdline.network ~debug
> -                   tmpdir cmdline.basepath hookstmpdir extradatatmpdir
> +                   tmpdir cmdline.basepath hookstmpdir
>                     (auxtmpdir // "fake-bin")
>                     all_elements cmdline.element_paths;
>  
> -  let run_hook_host hook > -    try
> -      let scripts = Hashtbl.find final_hooks hook in
> -      if debug >= 1 then (
> -        printf "Running hooks for %s...\n%!" hook;
> -      );
> -      run_parts_host ~debug hookstmpdir hook scripts
> -        (tmpdir // "run-part-extra.sh")
> -    with Not_found -> ()
> -  and run_hook ~blockdev ~sysroot ?(new_wd = "") (g :
Guestfs.guestfs) hook > +  let run_hook ~blockdev ~sysroot ?(new_wd =
"") (g : Guestfs.guestfs) hook >      try
>        let scripts = Hashtbl.find final_hooks hook in
>        if debug >= 1 then (
> @@ -597,8 +619,6 @@ let main () >        run_parts ~debug ~sysroot
~blockdev ~log_file ~new_wd g hook scripts
>      with Not_found -> "" in
>  
> -  run_hook_host "extra-data.d";
> -
>    let copy_in (g : Guestfs.guestfs) srcdir destdir >      let desttar =
Filename.temp_file ~temp_dir:tmpdir "virt-dib." ".tar.gz" in
>      let cmd = [ "tar"; "czf"; desttar; "-C";
srcdir; "--owner=root";
> @@ -608,18 +628,6 @@ let main () >      g#tar_in
~compress:"gzip" desttar destdir;
>      Sys.remove desttar in
>  
> -  let copy_preserve_in (g : Guestfs.guestfs) srcdir destdir > -    let
desttar = Filename.temp_file ~temp_dir:tmpdir "virt-dib."
".tar.gz" in
> -    let remotetar = "/tmp/aux/" ^ (Filename.basename desttar) in
> -    let cmd = [ "tar"; "czf"; desttar; "-C";
srcdir; "--owner=root";
> -                "--group=root"; "." ] in
> -    if run_command cmd <> 0 then exit 1;
> -    g#upload desttar remotetar;
> -    let verbose_flag = if debug > 0 then "v" else
"" in
> -    ignore (g#debug "sh" [| "tar"; "-C";
"/sysroot" ^ destdir; "--no-overwrite-dir"; "-x" ^
verbose_flag ^ "zf"; "/sysroot" ^ remotetar |]);
> -    Sys.remove desttar;
> -    g#rm remotetar in
> -
>    if debug >= 1 then
>      ignore (run_command [ "tree"; "-ps"; tmpdir ]);
>  
> @@ -747,7 +755,16 @@ let main () >    and run_hook_subroot hook >    
do_run_hooks_noout ~sysroot:Subroot hook
>    and do_run_hooks_noout ~sysroot ?(new_wd = "") hook > -   
ignore (run_hook ~sysroot ~blockdev ~new_wd g hook) in
> +    ignore (run_hook ~sysroot ~blockdev ~new_wd g hook)
> +  and run_hook_host hook > +    try
> +      let scripts = Hashtbl.find final_hooks hook in
> +      if debug >= 1 then (
> +        printf "Running hooks for %s...\n%!" hook;
> +      );
> +      run_parts_host ~debug g hookstmpdir hook tmpdir scripts
> +        (tmpdir // "run-part-extra.sh")
> +    with Not_found -> () in
>  
>    g#sync ();
>    checked_umount_all ();
> @@ -799,7 +816,7 @@ let main () >    mount_aux ();
>    g#ln_s "aux/hooks" "/tmp/in_target.d";
>  
> -  copy_preserve_in g extradatatmpdir "/";
> +  run_hook_host "extra-data.d";
>  
>    run_hook_in "pre-install.d";
>  
> diff --git a/dib/virt-dib.pod b/dib/virt-dib.pod
> index 8ccb9f5..41e7ec7 100644
> --- a/dib/virt-dib.pod
> +++ b/dib/virt-dib.pod
> @@ -577,29 +577,6 @@ arguments
>  
>  =item
>  
> -C<extra-data.d> scripts run in the host environment, before all the
> -other ones (even C<root.d>); this means that, depending on the
> -configuration for the elements, some of them may fail due to missing
> -content (usually directories) in C<TMP_HOOKS_PATH>.
> -
> -Workarounds for this may be either:
> -
> -=over 4
> -
> -=item
> -
> -fix the C<extra-data.d> scripts to create the missing directories
> -
> -=item
> -
> -create (and use) a simple element with a C<extra-data.d> script
> -named e.g. F<00-create-missing-dirs> to create the missing
> -directories
> -
> -=back
> -
> -=item
> -
>  extra tools needed on some out-of-chroot phases need to be available
>  in the appliance, see L</EXTRA DEPENDENCIES>.
>  
> -- 
> 2.7.4
> 
> _______________________________________________
> Libguestfs mailing list
> Libguestfs@redhat.com
> https://www.redhat.com/mailman/listinfo/libguestfs
ACK

Rich.

-- 
Richard Jones, Virtualization Group, Red Hat http://people.redhat.com/~rjones
Read my programming and virtualization blog: http://rwmj.wordpress.com
virt-builder quickly builds VMs from scratch
http://libguestfs.org/virt-builder.1.html

On Wed, Aug 03, 2016 at 04:49:42PM +0200, Pino Toscano
wrote:
> Move the OCaml binding to C _exit to an own module.
> 
> Just code motion, adapting v2v in the process.
> ---
>  docs/C_SOURCE_FILES |  2 +-
>  mllib/Makefile.am   |  5 ++++-
>  mllib/exit-c.c      | 33 +++++++++++++++++++++++++++++++++
>  mllib/exit.ml       | 19 +++++++++++++++++++
>  mllib/exit.mli      | 20 ++++++++++++++++++++
>  v2v/Makefile.am     |  1 -
>  v2v/changeuid-c.c   | 33 ---------------------------------
>  v2v/changeuid.ml    |  7 ++-----
>  8 files changed, 79 insertions(+), 41 deletions(-)
>  create mode 100644 mllib/exit-c.c
>  create mode 100644 mllib/exit.ml
>  create mode 100644 mllib/exit.mli
>  delete mode 100644 v2v/changeuid-c.c
> 
> diff --git a/docs/C_SOURCE_FILES b/docs/C_SOURCE_FILES
> index 3db4db3..551ce16 100644
> --- a/docs/C_SOURCE_FILES
> +++ b/docs/C_SOURCE_FILES
> @@ -181,6 +181,7 @@ lua/lua-guestfs.c
>  make-fs/make-fs.c
>  mllib/dev_t-c.c
>  mllib/dummy.c
> +mllib/exit-c.c
>  mllib/fsync-c.c
>  mllib/getopt-c.c
>  mllib/mkdtemp-c.c
> @@ -286,7 +287,6 @@ utils/boot-analysis/boot-analysis.c
>  utils/boot-benchmark/boot-benchmark.c
>  utils/qemu-boot/qemu-boot.c
>  utils/qemu-speed-test/qemu-speed-test.c
> -v2v/changeuid-c.c
>  v2v/domainxml-c.c
>  v2v/utils-c.c
>  v2v/xml-c.c
> diff --git a/mllib/Makefile.am b/mllib/Makefile.am
> index 8f8b5f4..69df1bc 100644
> --- a/mllib/Makefile.am
> +++ b/mllib/Makefile.am
> @@ -32,6 +32,7 @@ SOURCES_MLI = \
>  	common_utils.mli \
>  	curl.mli \
>  	dev_t.mli \
> +	exit.mli \
>  	fsync.mli \
>  	getopt.mli \
>  	JSON.mli \
> @@ -60,12 +61,14 @@ SOURCES_ML = \
>  	regedit.ml \
>  	StatVFS.ml \
>  	JSON.ml \
> -	curl.ml
> +	curl.ml \
> +	exit.ml
>  
>  SOURCES_C = \
>  	../fish/progress.c \
>  	../fish/uri.c \
>  	dev_t-c.c \
> +	exit-c.c \
>  	fsync-c.c \
>  	getopt-c.c \
>  	mkdtemp-c.c \
> diff --git a/mllib/exit-c.c b/mllib/exit-c.c
> new file mode 100644
> index 0000000..eed58a3
> --- /dev/null
> +++ b/mllib/exit-c.c
> @@ -0,0 +1,33 @@
> +/* libguestfs OCaml tools common code
> + * 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.
> + */
> +
> +#include <config.h>
> +
> +#include <stdio.h>
> +#include <stdlib.h>
> +#include <unistd.h>
> +
> +#include <caml/mlvalues.h>
> +
> +extern int guestfs_int_mllib_exit (value rv) __attribute__((noreturn));
> +
> +int
> +guestfs_int_mllib_exit (value rv)
> +{
> +  _exit (Int_val (rv));
> +}
> diff --git a/mllib/exit.ml b/mllib/exit.ml
> new file mode 100644
> index 0000000..e752bfe
> --- /dev/null
> +++ b/mllib/exit.ml
> @@ -0,0 +1,19 @@
> +(* libguestfs OCaml tools common code
> + * Copyright (C) 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.
> + *)
> +
> +external _exit : int -> unit = "guestfs_int_mllib_exit"
"noalloc"
> diff --git a/mllib/exit.mli b/mllib/exit.mli
> new file mode 100644
> index 0000000..c1f0ab5
> --- /dev/null
> +++ b/mllib/exit.mli
> @@ -0,0 +1,20 @@
> +(* libguestfs OCaml tools common code
> + * Copyright (C) 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.
> + *)
> +
> +val _exit : int -> unit
> +(** Call _exit directly, ie. do not run OCaml atexit handlers. *)
> diff --git a/v2v/Makefile.am b/v2v/Makefile.am
> index 8fd013d..008c5ba 100644
> --- a/v2v/Makefile.am
> +++ b/v2v/Makefile.am
> @@ -95,7 +95,6 @@ SOURCES_ML = \
>  
>  SOURCES_C = \
>  	domainxml-c.c \
> -	changeuid-c.c \
>  	utils-c.c \
>  	xml-c.c
>  
> diff --git a/v2v/changeuid-c.c b/v2v/changeuid-c.c
> deleted file mode 100644
> index 0de5a30..0000000
> --- a/v2v/changeuid-c.c
> +++ /dev/null
> @@ -1,33 +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.
> - */
> -
> -#include <config.h>
> -
> -#include <stdio.h>
> -#include <stdlib.h>
> -#include <unistd.h>
> -
> -#include <caml/mlvalues.h>
> -
> -extern int v2v_exit (value rv) __attribute__((noreturn));
> -
> -int
> -v2v_exit (value rv)
> -{
> -  _exit (Int_val (rv));
> -}
> diff --git a/v2v/changeuid.ml b/v2v/changeuid.ml
> index 07cf6fb..53c0bc3 100644
> --- a/v2v/changeuid.ml
> +++ b/v2v/changeuid.ml
> @@ -33,9 +33,6 @@ type t = {
>  
>  let create ?uid ?gid () = { uid = uid; gid = gid }
>  
> -(* Call _exit directly, ie. do not run OCaml atexit handlers. *)
> -external _exit : int -> unit = "v2v_exit" "noalloc"
> -
>  let with_fork { uid = uid; gid = gid } name f >    let pid = fork () in
>  
> @@ -46,9 +43,9 @@ let with_fork { uid = uid; gid = gid } name f >     
(try f ()
>       with exn ->
>         eprintf "%s: changeuid: %s: %s\n%!" prog name
(Printexc.to_string exn);
> -       _exit 1
> +       Exit._exit 1
>      );
> -    _exit 0
> +    Exit._exit 0
>    );
>  
>    (* Parent. *)
> -- 
> 2.7.4
> 
> _______________________________________________
> Libguestfs mailing list
> Libguestfs@redhat.com
> https://www.redhat.com/mailman/listinfo/libguestfs
ACK

Rich.

-- 
Richard Jones, Virtualization Group, Red Hat http://people.redhat.com/~rjones
Read my programming and virtualization blog: http://rwmj.wordpress.com
virt-p2v converts physical machines to virtual machines.  Boot with a
live CD or over the network (PXE) and turn machines into KVM guests.
http://libguestfs.org/virt-v2v