X-Git-Url: http://git.annexia.org/?p=libguestfs.git;a=blobdiff_plain;f=src%2Fgenerator.ml;h=7f248027784df7c1f64a1b94ef1280963712fac7;hp=92da3817d3ea7436be90ff91621e67d9cbeb08e7;hb=09128ca421f13da9fb6446cd7b09b0ae89c3876f;hpb=8c60f5c681b5d7cf90bc798fcaf94cd4e242e27f diff --git a/src/generator.ml b/src/generator.ml index 92da381..7f24802 100755 --- a/src/generator.ml +++ b/src/generator.ml @@ -136,7 +136,15 @@ can easily destroy all your data>." * the virtual machine and block devices are reused between tests. * So don't try testing kill_subprocess :-x * - * Between each test we umount-all and lvm-remove-all (except InitNone). + * Between each test we blockdev-setrw, umount-all, lvm-remove-all + * (except InitNone). + * + * If the appliance is running an older Linux kernel (eg. RHEL 5) then + * devices are named /dev/hda etc. To cope with this, the test suite + * adds some hairly logic to detect this case, and then automagically + * replaces all strings which match "/dev/sd.*" with "/dev/hd.*". + * When writing test cases you shouldn't have to worry about this + * difference. * * Don't assume anything about the previous contents of the block * devices. Use 'Init*' to create some initial scenarios. @@ -430,6 +438,16 @@ actions using the low-level API. For more information on states, see L."); + ("end_busy", (RErr, []), -1, [NotInFish], + [], + "leave the busy state", + "\ +This sets the state to C, or if in C then it leaves the +state as is. This is only used when implementing +actions using the low-level API. + +For more information on states, see L."); + ] let daemon_functions = [ @@ -989,7 +1007,7 @@ on the volume group C, with C megabytes."); "make a filesystem", "\ This creates a filesystem on C (usually a partition -of LVM logical volume). The filesystem type is C, for +or LVM logical volume). The filesystem type is C, for example C."); ("sfdisk", (RErr, [String "device"; @@ -1045,7 +1063,12 @@ with length C. As a special case, if C is C<0> then the length is calculated using C (so in this case -the content cannot contain embedded ASCII NULs)."); +the content cannot contain embedded ASCII NULs). + +I Owing to a bug, writing content containing ASCII NUL +characters does I work, even if the length is specified. +We hope to resolve this bug in a future version. In the meantime +use C."); ("umount", (RErr, [String "pathordevice"]), 45, [FishAlias "unmount"], [InitEmpty, TestOutputList ( @@ -1766,6 +1789,71 @@ verbose messages with C or by setting the environment variable C before running the program."); + ("ping_daemon", (RErr, []), 92, [], + [InitEmpty, TestRun ( + [["ping_daemon"]])], + "ping the guest daemon", + "\ +This is a test probe into the guestfs daemon running inside +the qemu subprocess. Calling this function checks that the +daemon responds to the ping message, without affecting the daemon +or attached block device(s) in any other way."); + + ("equal", (RBool "equality", [String "file1"; String "file2"]), 93, [], + [InitBasicFS, TestOutputTrue ( + [["write_file"; "/file1"; "contents of a file"; "0"]; + ["cp"; "/file1"; "/file2"]; + ["equal"; "/file1"; "/file2"]]); + InitBasicFS, TestOutputFalse ( + [["write_file"; "/file1"; "contents of a file"; "0"]; + ["write_file"; "/file2"; "contents of another file"; "0"]; + ["equal"; "/file1"; "/file2"]]); + InitBasicFS, TestLastFail ( + [["equal"; "/file1"; "/file2"]])], + "test if two files have equal contents", + "\ +This compares the two files C and C and returns +true if their content is exactly equal, or false otherwise. + +The external L program is used for the comparison."); + + ("strings", (RStringList "stringsout", [String "path"]), 94, [ProtocolLimitWarning], + [InitBasicFS, TestOutputList ( + [["write_file"; "/new"; "hello\nworld\n"; "0"]; + ["strings"; "/new"]], ["hello"; "world"])], + "print the printable strings in a file", + "\ +This runs the L command on a file and returns +the list of printable strings found."); + + ("strings_e", (RStringList "stringsout", [String "encoding"; String "path"]), 95, [ProtocolLimitWarning], + [InitBasicFS, TestOutputList ( + [["write_file"; "/new"; "hello\nworld\n"; "0"]; + ["strings_e"; "b"; "/new"]], []); + (*InitBasicFS, TestOutputList ( + [["write_file"; "/new"; "\000h\000e\000l\000l\000o\000\n\000w\000o\000r\000l\000d\000\n"; "24"]; + ["strings_e"; "b"; "/new"]], ["hello"; "world"])*)], + "print the printable strings in a file", + "\ +This is like the C command, but allows you to +specify the encoding. + +See the L manpage for the full list of encodings. + +Commonly useful encodings are C (lower case L) which will +show strings inside Windows/x86 files. + +The returned strings are transcoded to UTF-8."); + + ("hexdump", (RString "dump", [String "path"]), 96, [ProtocolLimitWarning], + [InitBasicFS, TestOutput ( + [["write_file"; "/new"; "hello\nworld\n"; "12"]; + ["hexdump"; "/new"]], "00000000 68 65 6c 6c 6f 0a 77 6f 72 6c 64 0a |hello.world.|\n0000000c\n")], + "dump a file in hexadecimal", + "\ +This runs C on the given C. The result is +the human-readable, canonical hex dump of the file."); + ] let all_functions = non_daemon_functions @ daemon_functions @@ -2126,14 +2214,15 @@ let chan = ref stdout let pr fs = ksprintf (output_string !chan) fs (* Generate a header block in a number of standard styles. *) -type comment_style = CStyle | HashStyle | OCamlStyle +type comment_style = CStyle | HashStyle | OCamlStyle | HaskellStyle type license = GPLv2 | LGPLv2 let generate_header comment license = let c = match comment with | CStyle -> pr "/* "; " *" | HashStyle -> pr "# "; "#" - | OCamlStyle -> pr "(* "; " *" in + | OCamlStyle -> pr "(* "; " *" + | HaskellStyle -> pr "{- "; " " in pr "libguestfs generated file\n"; pr "%s WARNING: THIS FILE IS GENERATED BY 'src/generator.ml'.\n" c; pr "%s ANY CHANGES YOU MAKE TO THIS FILE WILL BE LOST.\n" c; @@ -2175,6 +2264,7 @@ let generate_header comment license = | CStyle -> pr " */\n" | HashStyle -> () | OCamlStyle -> pr " *)\n" + | HaskellStyle -> pr "-}\n" ); pr "\n" @@ -2746,7 +2836,7 @@ check_state (guestfs_h *g, const char *caller) name; ); pr " if (serial == -1) {\n"; - pr " guestfs_set_ready (g);\n"; + pr " guestfs_end_busy (g);\n"; pr " return %s;\n" error_code; pr " }\n"; pr "\n"; @@ -2761,7 +2851,7 @@ check_state (guestfs_h *g, const char *caller) pr "\n"; pr " r = guestfs__send_file_sync (g, %s);\n" n; pr " if (r == -1) {\n"; - pr " guestfs_set_ready (g);\n"; + pr " guestfs_end_busy (g);\n"; pr " return %s;\n" error_code; pr " }\n"; pr " if (r == -2) /* daemon cancelled */\n"; @@ -2781,21 +2871,22 @@ check_state (guestfs_h *g, const char *caller) pr " guestfs_set_reply_callback (g, NULL, NULL);\n"; pr " if (ctx.cb_sequence != 1) {\n"; pr " error (g, \"%%s reply failed, see earlier error messages\", \"%s\");\n" name; - pr " guestfs_set_ready (g);\n"; + pr " guestfs_end_busy (g);\n"; pr " return %s;\n" error_code; pr " }\n"; pr "\n"; pr " if (check_reply_header (g, &ctx.hdr, GUESTFS_PROC_%s, serial) == -1) {\n" (String.uppercase shortname); - pr " guestfs_set_ready (g);\n"; + pr " guestfs_end_busy (g);\n"; pr " return %s;\n" error_code; pr " }\n"; pr "\n"; pr " if (ctx.hdr.status == GUESTFS_STATUS_ERROR) {\n"; pr " error (g, \"%%s\", ctx.err.error_message);\n"; - pr " guestfs_set_ready (g);\n"; + pr " free (ctx.err.error_message);\n"; + pr " guestfs_end_busy (g);\n"; pr " return %s;\n" error_code; pr " }\n"; pr "\n"; @@ -2805,14 +2896,14 @@ check_state (guestfs_h *g, const char *caller) function | FileOut n -> pr " if (guestfs__receive_file_sync (g, %s) == -1) {\n" n; - pr " guestfs_set_ready (g);\n"; + pr " guestfs_end_busy (g);\n"; pr " return %s;\n" error_code; pr " }\n"; pr "\n"; | _ -> () ) (snd style); - pr " guestfs_set_ready (g);\n"; + pr " guestfs_end_busy (g);\n"; (match fst style with | RErr -> pr " return 0;\n" @@ -3214,6 +3305,11 @@ and generate_tests () = static guestfs_h *g; static int suppress_error = 0; +/* This will be 's' or 'h' depending on whether the guest kernel + * names IDE devices /dev/sd* or /dev/hd*. + */ +static char devchar = 's'; + static void print_error (guestfs_h *g, void *data, const char *msg) { if (!suppress_error) @@ -3272,8 +3368,9 @@ int main (int argc, char *argv[]) int failed = 0; const char *srcdir; const char *filename; - int fd; + int fd, i; int nr_tests, test_num = 0; + char **devs; no_test_warnings (); @@ -3383,6 +3480,28 @@ int main (int argc, char *argv[]) exit (1); } + /* Detect if the appliance uses /dev/sd* or /dev/hd* in device + * names. This changed between RHEL 5 and RHEL 6 so we have to + * support both. + */ + devs = guestfs_list_devices (g); + if (devs == NULL || devs[0] == NULL) { + printf (\"guestfs_list_devices FAILED\\n\"); + exit (1); + } + if (strncmp (devs[0], \"/dev/sd\", 7) == 0) + devchar = 's'; + else if (strncmp (devs[0], \"/dev/hd\", 7) == 0) + devchar = 'h'; + else { + printf (\"guestfs_list_devices returned unexpected string '%%s'\\n\", + devs[0]); + exit (1); + } + for (i = 0; devs[i] != NULL; ++i) + free (devs[i]); + free (devs); + nr_tests = %d; " (500 * 1024 * 1024) (50 * 1024 * 1024) (10 * 1024 * 1024) nr_tests; @@ -3424,12 +3543,14 @@ and generate_one_test name i (init, test) = | InitEmpty -> pr " /* InitEmpty for %s (%d) */\n" name i; List.iter (generate_test_command_call test_name) - [["umount_all"]; + [["blockdev_setrw"; "/dev/sda"]; + ["umount_all"]; ["lvm_remove_all"]] | InitBasicFS -> pr " /* InitBasicFS for %s (%d): create ext2 on /dev/sda1 */\n" name i; List.iter (generate_test_command_call test_name) - [["umount_all"]; + [["blockdev_setrw"; "/dev/sda"]; + ["umount_all"]; ["lvm_remove_all"]; ["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ","]; ["mkfs"; "ext2"; "/dev/sda1"]; @@ -3438,7 +3559,8 @@ and generate_one_test name i (init, test) = pr " /* InitBasicFSonLVM for %s (%d): create ext2 on /dev/VG/LV */\n" name i; List.iter (generate_test_command_call test_name) - [["umount_all"]; + [["blockdev_setrw"; "/dev/sda"]; + ["umount_all"]; ["lvm_remove_all"]; ["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ","]; ["pvcreate"; "/dev/sda1"]; @@ -3463,10 +3585,14 @@ and generate_one_test name i (init, test) = List.iter (generate_test_command_call test_name) seq | TestOutput (seq, expected) -> pr " /* TestOutput for %s (%d) */\n" name i; + pr " char expected[] = \"%s\";\n" (c_quote expected); + if String.length expected > 7 && + String.sub expected 0 7 = "/dev/sd" then + pr " expected[5] = devchar;\n"; let seq, last = get_seq_last seq in let test () = - pr " if (strcmp (r, \"%s\") != 0) {\n" (c_quote expected); - pr " fprintf (stderr, \"%s: expected \\\"%s\\\" but got \\\"%%s\\\"\\n\", r);\n" test_name (c_quote expected); + pr " if (strcmp (r, expected) != 0) {\n"; + pr " fprintf (stderr, \"%s: expected \\\"%%s\\\" but got \\\"%%s\\\"\\n\", expected, r);\n" test_name; pr " return -1;\n"; pr " }\n" in @@ -3483,9 +3609,14 @@ and generate_one_test name i (init, test) = pr " print_strings (r);\n"; pr " return -1;\n"; pr " }\n"; - pr " if (strcmp (r[%d], \"%s\") != 0) {\n" i (c_quote str); - pr " fprintf (stderr, \"%s: expected \\\"%s\\\" but got \\\"%%s\\\"\\n\", r[%d]);\n" test_name (c_quote str) i; - pr " return -1;\n"; + pr " {\n"; + pr " char expected[] = \"%s\";\n" (c_quote str); + if String.length str > 7 && String.sub str 0 7 = "/dev/sd" then + pr " expected[5] = devchar;\n"; + pr " if (strcmp (r[%d], expected) != 0) {\n" i; + pr " fprintf (stderr, \"%s: expected \\\"%%s\\\" but got \\\"%%s\\\"\\n\", expected, r[%d]);\n" test_name i; + pr " return -1;\n"; + pr " }\n"; pr " }\n" ) expected; pr " if (r[%d] != NULL) {\n" (List.length expected); @@ -3629,16 +3760,26 @@ and generate_test_command_call ?(expect_error = false) ?test test_name cmd = List.iter ( function - | String _, _ - | OptString _, _ + | OptString n, "NULL" -> () + | String n, arg + | OptString n, arg -> + pr " char %s[] = \"%s\";\n" n (c_quote arg); + if String.length arg > 7 && String.sub arg 0 7 = "/dev/sd" then + pr " %s[5] = devchar;\n" n | Int _, _ - | Bool _, _ -> () + | Bool _, _ | FileIn _, _ | FileOut _, _ -> () | StringList n, arg -> - pr " char *%s[] = {\n" n; let strs = string_split " " arg in - List.iter ( - fun str -> pr " \"%s\",\n" (c_quote str) + iteri ( + fun i str -> + pr " char %s_%d[] = \"%s\";\n" n i (c_quote str); + if String.length str > 7 && String.sub str 0 7 = "/dev/sd" then + pr " %s_%d[5] = devchar;\n" n i + ) strs; + pr " char *%s[] = {\n" n; + iteri ( + fun i _ -> pr " %s_%d,\n" n i ) strs; pr " NULL\n"; pr " };\n"; @@ -3673,11 +3814,12 @@ and generate_test_command_call ?(expect_error = false) ?test test_name cmd = (* Generate the parameters. *) List.iter ( function - | String _, arg + | OptString _, "NULL" -> pr ", NULL" + | String n, _ + | OptString n, _ -> + pr ", %s" n | FileIn _, arg | FileOut _, arg -> pr ", \"%s\"" (c_quote arg) - | OptString _, arg -> - if arg = "NULL" then pr ", NULL" else pr ", \"%s\"" (c_quote arg) | StringList n, _ -> pr ", %s" n | Int _, arg -> @@ -3728,6 +3870,7 @@ and c_quote str = let str = replace_str str "\r" "\\r" in let str = replace_str str "\n" "\\n" in let str = replace_str str "\t" "\\t" in + let str = replace_str str "\000" "\\0" in str (* Generate a lot of different functions for guestfish. *) @@ -4719,7 +4862,7 @@ XS_unpack_charPtrPtr (SV *arg) { croak (\"array reference expected\"); av = (AV *)SvRV (arg); - ret = malloc (av_len (av) + 1 + 1); + ret = malloc ((av_len (av) + 1 + 1) * sizeof (char *)); if (!ret) croak (\"malloc failed\"); @@ -4739,6 +4882,8 @@ XS_unpack_charPtrPtr (SV *arg) { MODULE = Sys::Guestfs PACKAGE = Sys::Guestfs +PROTOTYPES: ENABLE + guestfs_h * _create () CODE: @@ -5648,6 +5793,11 @@ and generate_ruby_c () = #include \"extconf.h\" +/* For Ruby < 1.9 */ +#ifndef RARRAY_LEN +#define RARRAY_LEN(r) (RARRAY((r))->len) +#endif + static VALUE m_guestfs; /* guestfs module */ static VALUE c_guestfs; /* guestfs_h handle */ static VALUE e_Error; /* used for all errors */ @@ -6217,7 +6367,7 @@ Java_com_redhat_et_libguestfs_GuestFS__1close let needs_i = (match fst style with | RStringList _ | RPVList _ | RVGList _ | RLVList _ -> true - | RErr _ | RBool _ | RInt _ | RInt64 _ | RConstString _ + | RErr | RBool _ | RInt _ | RInt64 _ | RConstString _ | RString _ | RIntBool _ | RStat _ | RStatVFS _ | RHashtable _ -> false) || List.exists (function StringList _ -> true | _ -> false) (snd style) in @@ -6380,6 +6530,207 @@ and generate_java_lvm_return typ jtyp cols = pr " guestfs_free_lvm_%s_list (r);\n" typ; pr " return jr;\n" +and generate_haskell_hs () = + generate_header HaskellStyle LGPLv2; + + (* XXX We only know how to generate partial FFI for Haskell + * at the moment. Please help out! + *) + let can_generate style = + let check_no_bad_args = + List.for_all (function Bool _ | Int _ -> false | _ -> true) + in + match style with + | RErr, args -> check_no_bad_args args + | RBool _, _ + | RInt _, _ + | RInt64 _, _ + | RConstString _, _ + | RString _, _ + | RStringList _, _ + | RIntBool _, _ + | RPVList _, _ + | RVGList _, _ + | RLVList _, _ + | RStat _, _ + | RStatVFS _, _ + | RHashtable _, _ -> false in + + pr "\ +{-# INCLUDE #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +module Guestfs ( + create"; + + (* List out the names of the actions we want to export. *) + List.iter ( + fun (name, style, _, _, _, _, _) -> + if can_generate style then pr ",\n %s" name + ) all_functions; + + pr " + ) where +import Foreign +import Foreign.C +import IO +import Control.Exception +import Data.Typeable + +data GuestfsS = GuestfsS -- represents the opaque C struct +type GuestfsP = Ptr GuestfsS -- guestfs_h * +type GuestfsH = ForeignPtr GuestfsS -- guestfs_h * with attached finalizer + +-- XXX define properly later XXX +data PV = PV +data VG = VG +data LV = LV +data IntBool = IntBool +data Stat = Stat +data StatVFS = StatVFS +data Hashtable = Hashtable + +foreign import ccall unsafe \"guestfs_create\" c_create + :: IO GuestfsP +foreign import ccall unsafe \"&guestfs_close\" c_close + :: FunPtr (GuestfsP -> IO ()) +foreign import ccall unsafe \"guestfs_set_error_handler\" c_set_error_handler + :: GuestfsP -> Ptr CInt -> Ptr CInt -> IO () + +create :: IO GuestfsH +create = do + p <- c_create + c_set_error_handler p nullPtr nullPtr + h <- newForeignPtr c_close p + return h + +foreign import ccall unsafe \"guestfs_last_error\" c_last_error + :: GuestfsP -> IO CString + +-- last_error :: GuestfsH -> IO (Maybe String) +-- last_error h = do +-- str <- withForeignPtr h (\\p -> c_last_error p) +-- maybePeek peekCString str + +last_error :: GuestfsH -> IO (String) +last_error h = do + str <- withForeignPtr h (\\p -> c_last_error p) + if (str == nullPtr) + then return \"no error\" + else peekCString str + +"; + + (* Generate wrappers for each foreign function. *) + List.iter ( + fun (name, style, _, _, _, _, _) -> + if can_generate style then ( + pr "foreign import ccall unsafe \"guestfs_%s\" c_%s\n" name name; + pr " :: "; + generate_haskell_prototype ~handle:"GuestfsP" style; + pr "\n"; + pr "\n"; + pr "%s :: " name; + generate_haskell_prototype ~handle:"GuestfsH" ~hs:true style; + pr "\n"; + pr "%s %s = do\n" name + (String.concat " " ("h" :: List.map name_of_argt (snd style))); + pr " r <- "; + List.iter ( + function + | FileIn n + | FileOut n + | String n -> pr "withCString %s $ \\%s -> " n n + | OptString n -> pr "maybeWith withCString %s $ \\%s -> " n n + | StringList n -> pr "withMany withCString %s $ \\%s -> withArray0 nullPtr %s $ \\%s -> " n n n n + | Bool n -> + (* XXX this doesn't work *) + pr " let\n"; + pr " %s = case %s of\n" n n; + pr " False -> 0\n"; + pr " True -> 1\n"; + pr " in fromIntegral %s $ \\%s ->\n" n n + | Int n -> pr "fromIntegral %s $ \\%s -> " n n + ) (snd style); + pr "withForeignPtr h (\\p -> c_%s %s)\n" name + (String.concat " " ("p" :: List.map name_of_argt (snd style))); + (match fst style with + | RErr | RInt _ | RInt64 _ | RBool _ -> + pr " if (r == -1)\n"; + pr " then do\n"; + pr " err <- last_error h\n"; + pr " fail err\n"; + | RConstString _ | RString _ | RStringList _ | RIntBool _ + | RPVList _ | RVGList _ | RLVList _ | RStat _ | RStatVFS _ + | RHashtable _ -> + pr " if (r == nullPtr)\n"; + pr " then do\n"; + pr " err <- last_error h\n"; + pr " fail err\n"; + ); + (match fst style with + | RErr -> + pr " else return ()\n" + | RInt _ -> + pr " else return (fromIntegral r)\n" + | RInt64 _ -> + pr " else return (fromIntegral r)\n" + | RBool _ -> + pr " else return (toBool r)\n" + | RConstString _ + | RString _ + | RStringList _ + | RIntBool _ + | RPVList _ + | RVGList _ + | RLVList _ + | RStat _ + | RStatVFS _ + | RHashtable _ -> + pr " else return ()\n" (* XXXXXXXXXXXXXXXXXXXX *) + ); + pr "\n"; + ) + ) all_functions + +and generate_haskell_prototype ~handle ?(hs = false) style = + pr "%s -> " handle; + let string = if hs then "String" else "CString" in + let int = if hs then "Int" else "CInt" in + let bool = if hs then "Bool" else "CInt" in + let int64 = if hs then "Integer" else "Int64" in + List.iter ( + fun arg -> + (match arg with + | String _ -> pr "%s" string + | OptString _ -> if hs then pr "Maybe String" else pr "CString" + | StringList _ -> if hs then pr "[String]" else pr "Ptr CString" + | Bool _ -> pr "%s" bool + | Int _ -> pr "%s" int + | FileIn _ -> pr "%s" string + | FileOut _ -> pr "%s" string + ); + pr " -> "; + ) (snd style); + pr "IO ("; + (match fst style with + | RErr -> if not hs then pr "CInt" + | RInt _ -> pr "%s" int + | RInt64 _ -> pr "%s" int64 + | RBool _ -> pr "%s" bool + | RConstString _ -> pr "%s" string + | RString _ -> pr "%s" string + | RStringList _ -> pr "[%s]" string + | RIntBool _ -> pr "IntBool" + | RPVList _ -> pr "[PV]" + | RVGList _ -> pr "[VG]" + | RLVList _ -> pr "[LV]" + | RStat _ -> pr "Stat" + | RStatVFS _ -> pr "StatVFS" + | RHashtable _ -> pr "Hashtable" + ); + pr ")" + let output_to filename = let filename_new = filename ^ ".new" in chan := open_out filename_new; @@ -6520,3 +6871,7 @@ Run it from the top source directory using the command let close = output_to "java/com_redhat_et_libguestfs_GuestFS.c" in generate_java_c (); close (); + + let close = output_to "haskell/Guestfs.hs" in + generate_haskell_hs (); + close ();