From eef11f33f9f14d3706b681bd4e23e334fcc9b791 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Wed, 18 Jul 2012 13:45:21 +0100 Subject: ocaml: Test mount-local, without parallel test. Unfortunately the parallel test keeps hitting this bug: https://bugzilla.redhat.com/show_bug.cgi?id=838081 which could be a bug in the OCaml runtime. Just test simple mount-local. We will write a parallel test in C to replace this. --- .gitignore | 4 +- ocaml/Makefile.am | 21 +-- ocaml/t/exit.c | 44 ------ ocaml/t/guestfs_500_mount_local.ml | 178 +++++++++++++++++++++++ ocaml/t/guestfs_500_parallel_mount_local.ml | 215 ---------------------------- po/POTFILES | 1 - 6 files changed, 185 insertions(+), 278 deletions(-) delete mode 100644 ocaml/t/exit.c create mode 100644 ocaml/t/guestfs_500_mount_local.ml delete mode 100644 ocaml/t/guestfs_500_parallel_mount_local.ml diff --git a/.gitignore b/.gitignore index 822bc074..193c79d1 100644 --- a/.gitignore +++ b/.gitignore @@ -246,8 +246,8 @@ Makefile.in /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 +/ocaml/t/guestfs_500_mount_local.bc +/ocaml/t/guestfs_500_mount_local.opt /perl/bindtests.pl /perl/blib /perl/examples/guestfs-perl.3 diff --git a/ocaml/Makefile.am b/ocaml/Makefile.am index 9a06d5a5..e2c4667b 100644 --- a/ocaml/Makefile.am +++ b/ocaml/Makefile.am @@ -36,7 +36,6 @@ EXTRA_DIST = \ html/.gitignore \ META.in \ run-bindtests \ - t/exit.c \ t/*.ml CLEANFILES = *.cmi *.cmo *.cmx *.cma *.cmxa *.o *.a *.so @@ -92,7 +91,7 @@ test_progs += \ t/guestfs_010_basic \ t/guestfs_070_threads \ t/guestfs_400_progress \ - t/guestfs_500_parallel_mount_local + t/guestfs_500_mount_local endif TESTS = run-bindtests \ @@ -168,14 +167,14 @@ 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 $@ -t/guestfs_500_parallel_mount_local.bc: t/guestfs_500_parallel_mount_local.cmo mlguestfs.cma libocamltestlib.a +t/guestfs_500_mount_local.bc: t/guestfs_500_mount_local.cmo mlguestfs.cma mkdir -p t LD_LIBRARY_PATH=../src/.libs \ - $(OCAMLFIND) ocamlc -custom $(OCAMLCFLAGS) -I . -package unix,threads -thread -linkpkg mlguestfs.cma libocamltestlib.a $< -o $@ + $(OCAMLFIND) ocamlc -custom $(OCAMLCFLAGS) -I . -package unix -linkpkg mlguestfs.cma $< -o $@ -t/guestfs_500_parallel_mount_local.opt: t/guestfs_500_parallel_mount_local.cmx mlguestfs.cmxa libocamltestlib.a +t/guestfs_500_mount_local.opt: t/guestfs_500_mount_local.cmx mlguestfs.cmxa mkdir -p t - $(OCAMLFIND) ocamlopt $(OCAMLOPTFLAGS) -cclib -L$(top_builddir)/src/.libs -I . -package unix,threads -thread -linkpkg mlguestfs.cmxa libocamltestlib.a $< -o $@ + $(OCAMLFIND) ocamlopt $(OCAMLOPTFLAGS) -cclib -L$(top_builddir)/src/.libs -I . -package unix -linkpkg mlguestfs.cmxa $< -o $@ # Explicit rules for these tests which require 'threads' package. t/guestfs_070_threads.cmo: t/guestfs_070_threads.ml mlguestfs.cma @@ -184,16 +183,6 @@ t/guestfs_070_threads.cmo: t/guestfs_070_threads.ml mlguestfs.cma 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 deleted file mode 100644 index ca392def..00000000 --- a/ocaml/t/exit.c +++ /dev/null @@ -1,44 +0,0 @@ -/* 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 - -#include -#include -#include - -#include -#include -#include -#include -#include - -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_mount_local.ml b/ocaml/t/guestfs_500_mount_local.ml new file mode 100644 index 00000000..b4dd28d7 --- /dev/null +++ b/ocaml/t/guestfs_500_mount_local.ml @@ -0,0 +1,178 @@ +(* 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. *) + +open Unix +open Printf + +let (//) = Filename.concat + +(* Some settings. *) +let total_time = 60. (* seconds, excluding launch *) +let debug = true (* overview debugging messages *) + +let rec main () = + Random.self_init (); + + (* Allow the test to be skipped by setting this environment variable. + * This is for RHEL 5, where FUSE doesn't work very reliably. + *) + let () = + let name = "SKIP_TEST_GUESTFS_500_MOUNT_LOCAL_ML" in + let value = try Sys.getenv name with Not_found -> "" in + if value <> "" then ( + printf "%s: test skipped because %s is set.\n" + Sys.executable_name name; + exit 0 + ) + in + + let filename = "test1.img" in + let fd = openfile filename [O_WRONLY;O_CREAT;O_NOCTTY;O_TRUNC] 0o666 in + ftruncate fd (500 * 1024 * 1024); + close fd; + + let mp = "mp" in + (try rmdir mp with Unix_error _ -> ()); + mkdir mp 0o700; + + start_test filename mp; + + unlink filename; + rmdir mp; + + Gc.compact () + +and start_test filename mp = + (* Create a filesystem for the tests. *) + let g = new Guestfs.guestfs () in + + g#add_drive filename; + g#launch (); + + g#part_disk "/dev/sda" "mbr"; + g#mkfs "ext2" "/dev/sda1"; + g#mount "/dev/sda1" "/"; + + (* Randomly mount the filesystem and repeat. Keep going until we + * finish the test. + *) + 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; + g#mount_local mp; + + (* Run test in an exec'd subprocess. *) + let args = [| Sys.executable_name; "--test"; mp |] in + let pid = fork () in + if pid = 0 then ( (* child *) + try execv Sys.executable_name args + with exn -> prerr_endline (Printexc.to_string exn); exit 1 + ); + + (* Run FUSE main loop. This processes requests until the + * subprocess unmounts the filesystem. + *) + g#mount_local_run (); + + let _, status = waitpid [] 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#shutdown (); + g#close () + +(* This is run in a child program. *) +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/ocaml/t/guestfs_500_parallel_mount_local.ml b/ocaml/t/guestfs_500_parallel_mount_local.ml deleted file mode 100644 index 17e30ee7..00000000 --- a/ocaml/t/guestfs_500_parallel_mount_local.ml +++ /dev/null @@ -1,215 +0,0 @@ -(* 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" - -(* Some settings. *) -let total_time = 60. (* seconds, excluding launch *) -let debug = true (* overview debugging messages *) -let min_threads = 2 -let max_threads = 12 -let mbytes_per_thread = 900 - -let clip low high v = min high (max low v) - -let rec main () = - Random.self_init (); - - (* Allow the test to be skipped by setting this environment variable. - * This is for RHEL 5, where FUSE doesn't work very reliably. - *) - let () = - let name = "SKIP_TEST_GUESTFS_500_PARALLEL_MOUNT_LOCAL_ML" in - let value = try Sys.getenv name with Not_found -> "" in - if value <> "" then ( - printf "%s: test skipped because %s is set.\n" - Sys.executable_name name; - exit 0 - ) - in - - (* Choose the number of threads based on the amount of free memory. *) - let nr_threads = - let mbytes = - let cmd = "LANG=C free -m | grep 'buffers/cache' | awk '{print $NF}'" in - let chan = open_process_in cmd in - let mbytes = input_line chan in - match close_process_in chan with - | WEXITED 0 -> Some (int_of_string mbytes) - | _ -> None in - match mbytes with - | None -> min_threads (* default *) - | Some mbytes -> - clip min_threads max_threads (mbytes / mbytes_per_thread) in - - 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 filename; - g#launch (); - - g#part_disk "/dev/sda" "mbr"; - g#mkfs "ext2" "/dev/sda1"; - g#mount "/dev/sda1" "/"; - - (* Randomly mount the filesystem and repeat. Keep going until we - * finish the test. - *) - 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; - g#mount_local mp; - - (* Run test in an exec'd subprocess. *) - let args = [| Sys.executable_name; "--test"; mp |] in - let pid = fork () in - if pid = 0 then ( (* child *) - try execv Sys.executable_name args - with exn -> prerr_endline (Printexc.to_string exn); _exit 1 - ); - - (* Run FUSE main loop. This processes requests until the - * subprocess unmounts the filesystem. - *) - g#mount_local_run (); - - let _, status = waitpid [] 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#shutdown (); - g#close () - -(* This is run in a child program. *) -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 b/po/POTFILES index e3986871..6a590d47 100644 --- a/po/POTFILES +++ b/po/POTFILES @@ -180,7 +180,6 @@ 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 -- cgit