1:28 p.m.
From: "Richard W.M. Jones" <rjones(a)redhat.com>
---
.gitignore | 2 +
ocaml/Makefile.am | 25 +++-
ocaml/t/exit.c | 44 +++++++
ocaml/t/guestfs_500_parallel_mount_local.ml | 189 +++++++++++++++++++++++++++
po/POTFILES.in | 1 +
5 files changed, 259 insertions(+), 2 deletions(-)
create mode 100644 ocaml/t/exit.c
create mode 100644 ocaml/t/guestfs_500_parallel_mount_local.ml
diff --git a/.gitignore b/.gitignore
index e33f718..31cdc3e 100644
--- a/.gitignore
+++ b/.gitignore
@@ -236,6 +236,8 @@ ocaml/t/guestfs_400_events.bc
ocaml/t/guestfs_400_events.opt
ocaml/t/guestfs_400_progress.bc
ocaml/t/guestfs_400_progress.opt
+ocaml/t/guestfs_500_parallel_mount_local.bc
+ocaml/t/guestfs_500_parallel_mount_local.opt
*.orig
*.patch
perl/bindtests.pl
diff --git a/ocaml/Makefile.am b/ocaml/Makefile.am
index c313532..8c742a2 100644
--- a/ocaml/Makefile.am
+++ b/ocaml/Makefile.am
@@ -30,6 +30,7 @@ EXTRA_DIST = \
html/.gitignore \
META.in \
run-bindtests \
+ t/exit.c \
t/*.ml
CLEANFILES = *.cmi *.cmo *.cmx *.cma *.cmxa *.o *.a *.so
@@ -87,7 +88,8 @@ if ENABLE_APPLIANCE
test_progs += \
t/guestfs_010_basic \
t/guestfs_070_threads \
- t/guestfs_400_progress
+ t/guestfs_400_progress \
+ t/guestfs_500_parallel_mount_local
endif
TESTS = run-bindtests \
@@ -163,13 +165,32 @@ t/guestfs_400_progress.opt: t/guestfs_400_progress.cmx
mlguestfs.cmxa
mkdir -p t
$(OCAMLFIND) ocamlopt $(OCAMLOPTFLAGS) -cclib -L$(top_builddir)/src/.libs -I . -package
unix -linkpkg mlguestfs.cmxa $< -o $@
-# Explicit rules for this test which requires 'threads' package.
+t/guestfs_500_parallel_mount_local.bc: t/guestfs_500_parallel_mount_local.cmo
mlguestfs.cma libocamltestlib.a
+ mkdir -p t
+ LD_LIBRARY_PATH=../src/.libs \
+ $(OCAMLFIND) ocamlc -custom $(OCAMLCFLAGS) -I . -package unix,threads -thread -linkpkg
mlguestfs.cma libocamltestlib.a $< -o $@
+
+t/guestfs_500_parallel_mount_local.opt: t/guestfs_500_parallel_mount_local.cmx
mlguestfs.cmxa libocamltestlib.a
+ mkdir -p t
+ $(OCAMLFIND) ocamlopt $(OCAMLOPTFLAGS) -cclib -L$(top_builddir)/src/.libs -I . -package
unix,threads -thread -linkpkg mlguestfs.cmxa libocamltestlib.a $< -o $@
+
+# Explicit rules for these tests which require 'threads' package.
t/guestfs_070_threads.cmo: t/guestfs_070_threads.ml mlguestfs.cma
$(OCAMLFIND) ocamlc $(OCAMLCFLAGS) -package unix,threads -thread -linkpkg -c $< -o
$@
t/guestfs_070_threads.cmx: t/guestfs_070_threads.ml mlguestfs.cmxa
$(OCAMLFIND) ocamlopt $(OCAMLOPTFLAGS) -package unix,threads -thread -linkpkg -c $<
-o $@
+t/guestfs_500_parallel_mount_local.cmo: t/guestfs_500_parallel_mount_local.ml
mlguestfs.cma
+ $(OCAMLFIND) ocamlc $(OCAMLCFLAGS) -package unix,threads -thread -linkpkg -c $< -o
$@
+
+t/guestfs_500_parallel_mount_local.cmx: t/guestfs_500_parallel_mount_local.ml
mlguestfs.cmxa
+ $(OCAMLFIND) ocamlopt $(OCAMLOPTFLAGS) -package unix,threads -thread -linkpkg -c $<
-o $@
+
+noinst_LIBRARIES += libocamltestlib.a
+libocamltestlib_a_SOURCES = t/exit.c
+libocamltestlib_a_CFLAGS = $(libguestfsocaml_a_CFLAGS)
+
%.cmi: %.mli
$(OCAMLFIND) ocamlc $(OCAMLCFLAGS) -package unix -c $< -o $(builddir)/$@
%.cmo: %.ml mlguestfs.cma
diff --git a/ocaml/t/exit.c b/ocaml/t/exit.c
new file mode 100644
index 0000000..ca392de
--- /dev/null
+++ b/ocaml/t/exit.c
@@ -0,0 +1,44 @@
+/* libguestfs OCaml bindings
+ * Copyright (C) 2012 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/alloc.h>
+#include <caml/fail.h>
+#include <caml/memory.h>
+#include <caml/misc.h>
+#include <caml/mlvalues.h>
+
+value ocaml_guestfs__exit (value) Noreturn;
+
+/* _exit : int -> 'a (does not return) */
+value
+ocaml_guestfs__exit (value statusv)
+{
+ CAMLparam1 (statusv);
+ int status = Int_val (statusv);
+
+ _exit (status);
+
+ /*NOTREACHED*/
+ CAMLnoreturn;
+}
diff --git a/ocaml/t/guestfs_500_parallel_mount_local.ml
b/ocaml/t/guestfs_500_parallel_mount_local.ml
new file mode 100644
index 0000000..6cb2b91
--- /dev/null
+++ b/ocaml/t/guestfs_500_parallel_mount_local.ml
@@ -0,0 +1,189 @@
+(* libguestfs OCaml bindings
+ * Copyright (C) 2012 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.
+ *)
+
+(* Test guestfs_mount_local, from a higher level language (it will
+ * mostly be used first from Python), in parallel threads. OCaml
+ * allows us to test this at a reasonable speed.
+ *)
+
+open Unix
+open Printf
+
+let (//) = Filename.concat
+
+(* See [exit.c]. *)
+external _exit : int -> 'a = "ocaml_guestfs__exit"
+
+let nr_threads = 2
+let total_time = 60. (* seconds, excluding launch *)
+let debug = true (* overview debugging messages *)
+
+let rec main () =
+ Random.self_init ();
+
+ let threads = ref [] in
+ for i = 1 to nr_threads do
+ let filename = sprintf "test%d.img" i in
+ let mp = sprintf "mp%d" i in
+ (try rmdir mp with Unix_error _ -> ());
+ mkdir mp 0o700;
+
+ if debug then eprintf "%s : starting thread\n%!" mp;
+ let t = Thread.create start_thread (filename, mp) in
+ threads := (t, filename, mp) :: !threads
+ done;
+
+ (* Wait until the threads terminate and delete the files and mountpoints. *)
+ List.iter (
+ fun (t, filename, mp) ->
+ Thread.join t;
+
+ if debug then eprintf "%s : cleaning up thread\n%!" mp;
+ unlink filename;
+ rmdir mp
+ ) !threads;
+
+ Gc.compact ()
+
+and start_thread (filename, mp) =
+ (* Create a filesystem for the tests. *)
+ let g = new Guestfs.guestfs () in
+
+ let fd = openfile filename [O_WRONLY;O_CREAT;O_NOCTTY;O_TRUNC] 0o666 in
+ ftruncate fd (500 * 1024 * 1024);
+ close fd;
+
+ g#add_drive_opts filename;
+ g#launch ();
+
+ g#part_disk "/dev/sda" "mbr";
+ g#mkfs "ext2" "/dev/sda1";
+ g#mount "/dev/sda1" "/";
+
+ let test_pid = ref 0 in
+ ignore (g#set_event_callback (mounted test_pid) [Guestfs.EVENT_MOUNTED]);
+
+ (* Randomly mount the filesystem and repeat. Keep going until we
+ * finish the test. The interesting stuff is happening in the
+ * 'mounted' event callback.
+ *)
+ let start_t = time () in
+ let rec loop () =
+ let t = time () in
+ if t -. start_t < total_time then (
+ if debug then eprintf "%s < mounting filesystem\n%!" mp;
+ test_pid := 0;
+ g#mount_local mp;
+ assert (!test_pid <> 0); (* mounted callback should have been called *)
+ let _, status = waitpid [] !test_pid in
+ (match status with
+ | WEXITED 0 -> ()
+ | WEXITED i ->
+ eprintf "test subprocess failed (exit code %d)\n" i;
+ exit 1
+ | WSIGNALED i | WSTOPPED i ->
+ eprintf "test subprocess signaled/stopped (signal %d)\n" i;
+ exit 1
+ );
+ loop ()
+ )
+ in
+ loop ();
+
+ g#close ()
+
+(* This callback is called when the filesystem at 'mp' is mounted and
+ * ready to use. We cannot run tests directly here, but must run them
+ * from another process. We cannot just fork and run the tests because
+ * that's not signal-safe, so we must fork and immediately exec a
+ * separate test program.
+ *)
+and mounted return_pid _ _ _ mp _ =
+ let args = [| Sys.executable_name; "--test"; mp |] in
+ let pid = fork () in
+ if pid <> 0 then (* parent *)
+ return_pid := pid
+ else ( (* child *)
+ try execv Sys.executable_name args
+ with exn -> prerr_endline (Printexc.to_string exn); _exit 1
+ )
+
+and test_mountpoint mp =
+ if debug then eprintf "%s | testing filesystem\n%!" mp;
+
+ (* Run through the same set of tests repeatedly a number of times.
+ * The aim of this stress test is repeated mount/unmount, not testing
+ * FUSE itself, so we don't do much here.
+ *)
+ for pass = 0 to Random.int 32 do
+ mkdir (mp // "tmp.d") 0o700;
+ let chan = open_out (mp // "file") in
+ let s = String.make (Random.int (128 * 1024)) (Char.chr (Random.int 256)) in
+ output_string chan s;
+ close_out chan;
+ rename (mp // "tmp.d") (mp // "newdir");
+ link (mp // "file") (mp // "newfile");
+ if Random.int 32 = 0 then sleep 1;
+ rmdir (mp // "newdir");
+ unlink (mp // "file");
+ unlink (mp // "newfile")
+ done;
+
+ if debug then eprintf "%s > unmounting filesystem\n%!" mp;
+
+ unmount mp
+
+(* We may need to retry this a few times because of processes which
+ * run in the background jumping into mountpoints. Only display
+ * errors if it still fails after many retries.
+ *)
+and unmount mp =
+ let logfile = sprintf "%s.fusermount.log" mp in
+ let unlink_logfile () =
+ try unlink logfile with Unix_error _ -> ()
+ in
+ unlink_logfile ();
+
+ let run_command () =
+ Sys.command (sprintf "fusermount -u %s >> %s 2>&1"
+ (Filename.quote mp) (Filename.quote logfile)) = 0
+ in
+
+ let rec loop tries =
+ if tries <= 5 then (
+ if not (run_command ()) then (
+ sleep 1;
+ loop (tries+1)
+ )
+ ) else (
+ ignore (Sys.command (sprintf "cat %s" (Filename.quote logfile)));
+ eprintf "fusermount: %s: failed, see earlier error messages\n" mp;
+ exit 1
+ )
+ in
+ loop 0;
+
+ unlink_logfile ()
+
+let () =
+ match Array.to_list Sys.argv with
+ | [ _; "--test"; mp ] -> test_mountpoint mp
+ | [ _ ] -> main ()
+ | _ ->
+ eprintf "%s: unknown arguments given to program\n" Sys.executable_name;
+ exit 1
diff --git a/po/POTFILES.in b/po/POTFILES.in
index 1f0bb36..5df8b93 100644
--- a/po/POTFILES.in
+++ b/po/POTFILES.in
@@ -135,6 +135,7 @@ inspector/virt-inspector.c
java/com_redhat_et_libguestfs_GuestFS.c
ocaml/guestfs_c.c
ocaml/guestfs_c_actions.c
+ocaml/t/exit.c
perl/Guestfs.c
perl/bindtests.pl
perl/lib/Sys/Guestfs.pm
--
1.7.9.3