X-Git-Url: http://git.annexia.org/?p=libguestfs.git;a=blobdiff_plain;f=src%2Fgenerator.ml;h=bb3744ed016b55d43bad20995b6c7c3231a59b68;hp=9c210bc0a2bbeab6f7b73c23a242cc0a09964e6f;hb=bfdc03be234d6d95f18450846433bce4f97e184c;hpb=6610af333b93d93f6f0f4b917e0caee0d35ba389 diff --git a/src/generator.ml b/src/generator.ml index 9c210bc..bb3744e 100755 --- a/src/generator.ml +++ b/src/generator.ml @@ -116,6 +116,7 @@ type flags = | FishAlias of string (* provide an alias for this cmd in guestfish *) | FishAction of string (* call this function in guestfish *) | NotInFish (* do not export via guestfish *) + | NotInDocs (* do not add this function to documentation *) let protocol_limit_warning = "Because of the message protocol, there is a transfer limit @@ -129,9 +130,13 @@ can easily destroy all your data>." (* You can supply zero or as many tests as you want per API call. * * Note that the test environment has 3 block devices, of size 500MB, - * 50MB and 10MB (respectively /dev/sda, /dev/sdb, /dev/sdc). + * 50MB and 10MB (respectively /dev/sda, /dev/sdb, /dev/sdc), and + * a fourth squashfs block device with some known files on it (/dev/sdd). + * * Note for partitioning purposes, the 500MB device has 63 cylinders. * + * The squashfs block device (/dev/sdd) comes from images/test.sqsh. + * * To be able to run the tests in a reasonable amount of time, * the virtual machine and block devices are reused between tests. * So don't try testing kill_subprocess :-x @@ -253,7 +258,81 @@ and cmd = string list * Apart from that, long descriptions are just perldoc paragraphs. *) -let non_daemon_functions = [ +(* These test functions are used in the language binding tests. *) + +let test_all_args = [ + String "str"; + OptString "optstr"; + StringList "strlist"; + Bool "b"; + Int "integer"; + FileIn "filein"; + FileOut "fileout"; +] + +let test_all_rets = [ + (* except for RErr, which is tested thoroughly elsewhere *) + "test0rint", RInt "valout"; + "test0rint64", RInt64 "valout"; + "test0rbool", RBool "valout"; + "test0rconststring", RConstString "valout"; + "test0rstring", RString "valout"; + "test0rstringlist", RStringList "valout"; + "test0rintbool", RIntBool ("valout", "valout"); + "test0rpvlist", RPVList "valout"; + "test0rvglist", RVGList "valout"; + "test0rlvlist", RLVList "valout"; + "test0rstat", RStat "valout"; + "test0rstatvfs", RStatVFS "valout"; + "test0rhashtable", RHashtable "valout"; +] + +let test_functions = [ + ("test0", (RErr, test_all_args), -1, [NotInFish; NotInDocs], + [], + "internal test function - do not use", + "\ +This is an internal test function which is used to test whether +the automatically generated bindings can handle every possible +parameter type correctly. + +It echos the contents of each parameter to stdout. + +You probably don't want to call this function."); +] @ List.flatten ( + List.map ( + fun (name, ret) -> + [(name, (ret, [String "val"]), -1, [NotInFish; NotInDocs], + [], + "internal test function - do not use", + "\ +This is an internal test function which is used to test whether +the automatically generated bindings can handle every possible +return type correctly. + +It converts string C to the return type. + +You probably don't want to call this function."); + (name ^ "err", (ret, []), -1, [NotInFish; NotInDocs], + [], + "internal test function - do not use", + "\ +This is an internal test function which is used to test whether +the automatically generated bindings can handle every possible +return type correctly. + +This function always returns an error. + +You probably don't want to call this function.")] + ) test_all_rets +) + +(* non_daemon_functions are any functions which don't get processed + * in the daemon, eg. functions for setting and getting local + * configuration values. + *) + +let non_daemon_functions = test_functions @ [ ("launch", (RErr, []), -1, [FishAlias "run"; FishAction "launch"], [], "launch the qemu subprocess", @@ -295,7 +374,12 @@ for whatever operations you want to perform (ie. read access if you just want to read the image or write access if you want to modify the image). -This is equivalent to the qemu parameter C<-drive file=filename>."); +This is equivalent to the qemu parameter C<-drive file=filename>. + +Note that this call checks for the existence of C. This +stops you from specifying other types of drive which are supported +by qemu such as C and C URLs. To specify those, use +the general C call instead."); ("add_cdrom", (RErr, [String "filename"]), -1, [FishAlias "cdrom"], [], @@ -303,7 +387,33 @@ This is equivalent to the qemu parameter C<-drive file=filename>."); "\ This function adds a virtual CD-ROM disk image to the guest. -This is equivalent to the qemu parameter C<-cdrom filename>."); +This is equivalent to the qemu parameter C<-cdrom filename>. + +Note that this call checks for the existence of C. This +stops you from specifying other types of drive which are supported +by qemu such as C and C URLs. To specify those, use +the general C call instead."); + + ("add_drive_ro", (RErr, [String "filename"]), -1, [FishAlias "add-ro"], + [], + "add a drive in snapshot mode (read-only)", + "\ +This adds a drive in snapshot mode, making it effectively +read-only. + +Note that writes to the device are allowed, and will be seen for +the duration of the guestfs handle, but they are written +to a temporary file which is discarded as soon as the guestfs +handle is closed. We don't currently have any method to enable +changes to be committed, although qemu can support this. + +This is equivalent to the qemu parameter +C<-drive file=filename,snapshot=on>. + +Note that this call checks for the existence of C. This +stops you from specifying other types of drive which are supported +by qemu such as C and C URLs. To specify those, use +the general C call instead."); ("config", (RErr, [String "qemuparam"; OptString "qemuvalue"]), -1, [], [], @@ -491,6 +601,10 @@ For more information on states, see L."); ] +(* daemon_functions are any functions which cause some action + * to take place in the daemon. + *) + let daemon_functions = [ ("mount", (RErr, [String "device"; String "mountpoint"]), 1, [], [InitEmpty, Always, TestOutput ( @@ -580,7 +694,7 @@ should probably use C instead."); ("list_devices", (RStringList "devices", []), 7, [], [InitEmpty, Always, TestOutputList ( - [["list_devices"]], ["/dev/sda"; "/dev/sdb"; "/dev/sdc"])], + [["list_devices"]], ["/dev/sda"; "/dev/sdb"; "/dev/sdc"; "/dev/sdd"])], "list the block devices", "\ List all the block devices. @@ -923,7 +1037,14 @@ Create a directory named C."); ["is_dir"; "/new/foo"]]; InitBasicFS, Always, TestOutputTrue [["mkdir_p"; "/new/foo/bar"]; - ["is_dir"; "/new"]]], + ["is_dir"; "/new"]]; + (* Regression tests for RHBZ#503133: *) + InitBasicFS, Always, TestRun + [["mkdir"; "/new"]; + ["mkdir_p"; "/new"]]; + InitBasicFS, Always, TestLastFail + [["touch"; "/new"]; + ["mkdir_p"; "/new"]]], "create a directory and parents", "\ Create a directory named C, creating any parent directories @@ -1483,7 +1604,7 @@ This uses the L command."); ("upload", (RErr, [FileIn "filename"; String "remotefilename"]), 66, [], [InitBasicFS, Always, TestOutput ( (* Pick a file from cwd which isn't likely to change. *) - [["upload"; "COPYING.LIB"; "/COPYING.LIB"]; + [["upload"; "../COPYING.LIB"; "/COPYING.LIB"]; ["checksum"; "md5"; "/COPYING.LIB"]], "e3eda01d9815f8d24aae2dbd89b68b06")], "upload a file from the local machine", "\ @@ -1497,7 +1618,7 @@ See also C."); ("download", (RErr, [String "remotefilename"; FileOut "filename"]), 67, [], [InitBasicFS, Always, TestOutput ( (* Pick a file from cwd which isn't likely to change. *) - [["upload"; "COPYING.LIB"; "/COPYING.LIB"]; + [["upload"; "../COPYING.LIB"; "/COPYING.LIB"]; ["download"; "/COPYING.LIB"; "testdownload.tmp"]; ["upload"; "testdownload.tmp"; "/upload"]; ["checksum"; "md5"; "/upload"]], "e3eda01d9815f8d24aae2dbd89b68b06")], @@ -1533,7 +1654,10 @@ See also C, C."); ["checksum"; "sha384"; "/new"]], "109bb6b5b6d5547c1ce03c7a8bd7d8f80c1cb0957f50c4f7fda04692079917e4f9cad52b878f3d8234e1a170b154b72d"); InitBasicFS, Always, TestOutput ( [["write_file"; "/new"; "test\n"; "0"]; - ["checksum"; "sha512"; "/new"]], "0e3e75234abc68f4378a86b3f4b32a198ba301845b0cd6e50106e874345700cc6663a86c1ea125dc5e92be17c98f9a0f85ca9d5f595db2012f7cc3571945c123")], + ["checksum"; "sha512"; "/new"]], "0e3e75234abc68f4378a86b3f4b32a198ba301845b0cd6e50106e874345700cc6663a86c1ea125dc5e92be17c98f9a0f85ca9d5f595db2012f7cc3571945c123"); + InitBasicFS, Always, TestOutput ( + [["mount"; "/dev/sdd"; "/"]; + ["checksum"; "md5"; "/known-3"]], "46d6ca27ee07cdc6fa99c2e138cc522c")], "compute MD5, SHAx or CRC checksum of file", "\ This call computes the MD5, SHAx or CRC checksum of the @@ -1579,7 +1703,7 @@ The checksum is returned as a printable string."); ("tar_in", (RErr, [FileIn "tarfile"; String "directory"]), 69, [], [InitBasicFS, Always, TestOutput ( - [["tar_in"; "images/helloworld.tar"; "/"]; + [["tar_in"; "../images/helloworld.tar"; "/"]; ["cat"; "/hello"]], "hello\n")], "unpack tarfile to directory", "\ @@ -1599,7 +1723,7 @@ To download a compressed tarball, use C."); ("tgz_in", (RErr, [FileIn "tarball"; String "directory"]), 71, [], [InitBasicFS, Always, TestOutput ( - [["tgz_in"; "images/helloworld.tar.gz"; "/"]; + [["tgz_in"; "../images/helloworld.tar.gz"; "/"]; ["cat"; "/hello"]], "hello\n")], "unpack compressed tarball to directory", "\ @@ -2294,6 +2418,14 @@ let statvfs_cols = [ "namemax", `Int; ] +(* Used for testing language bindings. *) +type callt = + | CallString of string + | CallOptString of string option + | CallStringList of string list + | CallInt of int + | CallBool of bool + (* Useful functions. * Note we don't want to use any external OCaml libraries which * makes this a bit harder than it should be. @@ -2455,9 +2587,13 @@ let check_functions () = failwithf "%s param/ret %s should not contain '-' or '_'" name n; if n = "value" then - failwithf "%s has a param/ret called 'value', which causes conflicts in the OCaml bindings, use something like 'val' or a more descriptive name" n; + failwithf "%s has a param/ret called 'value', which causes conflicts in the OCaml bindings, use something like 'val' or a more descriptive name" name; + if n = "int" || n = "char" || n = "short" || n = "long" then + failwithf "%s has a param/ret which conflicts with a C type (eg. 'int', 'char' etc.)" name; + if n = "i" then + failwithf "%s has a param/ret called 'i', which will cause some conflicts in the generated code" name; if n = "argv" || n = "args" then - failwithf "%s has a param/ret called 'argv' or 'args', which will cause some conflicts in the generated code" n + failwithf "%s has a param/ret called 'argv' or 'args', which will cause some conflicts in the generated code" name in (match fst style with @@ -2609,71 +2745,73 @@ let generate_header comment license = let rec generate_actions_pod () = List.iter ( fun (shortname, style, _, flags, _, _, longdesc) -> - let name = "guestfs_" ^ shortname in - pr "=head2 %s\n\n" name; - pr " "; - generate_prototype ~extern:false ~handle:"handle" name style; - pr "\n\n"; - pr "%s\n\n" longdesc; - (match fst style with - | RErr -> - pr "This function returns 0 on success or -1 on error.\n\n" - | RInt _ -> - pr "On error this function returns -1.\n\n" - | RInt64 _ -> - pr "On error this function returns -1.\n\n" - | RBool _ -> - pr "This function returns a C truth value on success or -1 on error.\n\n" - | RConstString _ -> - pr "This function returns a string, or NULL on error. + if not (List.mem NotInDocs flags) then ( + let name = "guestfs_" ^ shortname in + pr "=head2 %s\n\n" name; + pr " "; + generate_prototype ~extern:false ~handle:"handle" name style; + pr "\n\n"; + pr "%s\n\n" longdesc; + (match fst style with + | RErr -> + pr "This function returns 0 on success or -1 on error.\n\n" + | RInt _ -> + pr "On error this function returns -1.\n\n" + | RInt64 _ -> + pr "On error this function returns -1.\n\n" + | RBool _ -> + pr "This function returns a C truth value on success or -1 on error.\n\n" + | RConstString _ -> + pr "This function returns a string, or NULL on error. The string is owned by the guest handle and must I be freed.\n\n" - | RString _ -> - pr "This function returns a string, or NULL on error. + | RString _ -> + pr "This function returns a string, or NULL on error. I.\n\n" - | RStringList _ -> - pr "This function returns a NULL-terminated array of strings + | RStringList _ -> + pr "This function returns a NULL-terminated array of strings (like L), or NULL if there was an error. I.\n\n" - | RIntBool _ -> - pr "This function returns a C, + | RIntBool _ -> + pr "This function returns a C, or NULL if there was an error. I after use>.\n\n" - | RPVList _ -> - pr "This function returns a C + | RPVList _ -> + pr "This function returns a C (see Eguestfs-structs.hE), or NULL if there was an error. I after use>.\n\n" - | RVGList _ -> - pr "This function returns a C + | RVGList _ -> + pr "This function returns a C (see Eguestfs-structs.hE), or NULL if there was an error. I after use>.\n\n" - | RLVList _ -> - pr "This function returns a C + | RLVList _ -> + pr "This function returns a C (see Eguestfs-structs.hE), or NULL if there was an error. I after use>.\n\n" - | RStat _ -> - pr "This function returns a C + | RStat _ -> + pr "This function returns a C (see L and Eguestfs-structs.hE), or NULL if there was an error. I after use>.\n\n" - | RStatVFS _ -> - pr "This function returns a C + | RStatVFS _ -> + pr "This function returns a C (see L and Eguestfs-structs.hE), or NULL if there was an error. I after use>.\n\n" - | RHashtable _ -> - pr "This function returns a NULL-terminated array of + | RHashtable _ -> + pr "This function returns a NULL-terminated array of strings, or NULL if there was an error. The array of strings will always have length C<2n+1>, where C keys and values alternate, followed by the trailing NULL entry. I.\n\n" - ); - if List.mem ProtocolLimitWarning flags then - pr "%s\n\n" protocol_limit_warning; - if List.mem DangerWillRobinson flags then - pr "%s\n\n" danger_will_robinson; + ); + if List.mem ProtocolLimitWarning flags then + pr "%s\n\n" protocol_limit_warning; + if List.mem DangerWillRobinson flags then + pr "%s\n\n" danger_will_robinson + ) ) all_functions_sorted and generate_structs_pod () = @@ -3701,7 +3839,6 @@ int main (int argc, char *argv[]) { char c = 0; int failed = 0; - const char *srcdir; const char *filename; int fd, i; int nr_tests, test_num = 0; @@ -3717,10 +3854,7 @@ int main (int argc, char *argv[]) guestfs_set_error_handler (g, print_error, NULL); - srcdir = getenv (\"srcdir\"); - if (!srcdir) srcdir = \".\"; - chdir (srcdir); - guestfs_set_path (g, \".\"); + guestfs_set_path (g, \"../appliance\"); filename = \"test1.img\"; fd = open (filename, O_WRONLY|O_CREAT|O_NOCTTY|O_NONBLOCK|O_TRUNC, 0666); @@ -3806,6 +3940,11 @@ int main (int argc, char *argv[]) exit (1); } + if (guestfs_add_drive_ro (g, \"../images/test.sqsh\") == -1) { + printf (\"guestfs_add_drive_ro ../images/test.sqsh FAILED\\n\"); + exit (1); + } + if (guestfs_launch (g) == -1) { printf (\"guestfs_launch FAILED\\n\"); exit (1); @@ -4656,7 +4795,8 @@ char **do_completion (const char *text, int start, int end) and generate_fish_actions_pod () = let all_functions_sorted = List.filter ( - fun (_, _, _, flags, _, _, _) -> not (List.mem NotInFish flags) + fun (_, _, _, flags, _, _, _) -> + not (List.mem NotInFish flags || List.mem NotInDocs flags) ) all_functions_sorted in let rex = Str.regexp "C]+\\)>" in @@ -5312,13 +5452,19 @@ DESTROY (g) generate_call_args ~handle:"g" (snd style); pr "\n"; pr " guestfs_h *g;\n"; - List.iter ( - function - | String n | FileIn n | FileOut n -> pr " char *%s;\n" n - | OptString n -> pr " char *%s;\n" n - | StringList n -> pr " char **%s;\n" n - | Bool n -> pr " int %s;\n" n - | Int n -> pr " int %s;\n" n + iteri ( + fun i -> + function + | String n | FileIn n | FileOut n -> pr " char *%s;\n" n + | OptString n -> + (* http://www.perlmonks.org/?node_id=554277 + * Note that the implicit handle argument means we have + * to add 1 to the ST(x) operator. + *) + pr " char *%s = SvOK(ST(%d)) ? SvPV_nolen(ST(%d)) : NULL;\n" n (i+1) (i+1) + | StringList n -> pr " char **%s;\n" n + | Bool n -> pr " int %s;\n" n + | Int n -> pr " int %s;\n" n ) (snd style); let do_cleanups () = @@ -5584,15 +5730,17 @@ sub new { *) List.iter ( fun (name, style, _, flags, _, _, longdesc) -> - let longdesc = replace_str longdesc "C" in - pr "=item "; - generate_perl_prototype name style; - pr "\n\n"; - pr "%s\n\n" longdesc; - if List.mem ProtocolLimitWarning flags then - pr "%s\n\n" protocol_limit_warning; - if List.mem DangerWillRobinson flags then - pr "%s\n\n" danger_will_robinson + if not (List.mem NotInDocs flags) then ( + let longdesc = replace_str longdesc "C" in + pr "=item "; + generate_perl_prototype name style; + pr "\n\n"; + pr "%s\n\n" longdesc; + if List.mem ProtocolLimitWarning flags then + pr "%s\n\n" protocol_limit_warning; + if List.mem DangerWillRobinson flags then + pr "%s\n\n" danger_will_robinson + ) ) all_functions_sorted; (* End of file. *) @@ -6095,43 +6243,45 @@ class GuestFS: List.iter ( fun (name, style, _, flags, _, _, longdesc) -> - let doc = replace_str longdesc "C doc - | RStringList _ -> - doc ^ "\n\nThis function returns a list of strings." - | RIntBool _ -> - doc ^ "\n\nThis function returns a tuple (int, bool).\n" - | RPVList _ -> - doc ^ "\n\nThis function returns a list of PVs. Each PV is represented as a dictionary." - | RVGList _ -> - doc ^ "\n\nThis function returns a list of VGs. Each VG is represented as a dictionary." - | RLVList _ -> - doc ^ "\n\nThis function returns a list of LVs. Each LV is represented as a dictionary." - | RStat _ -> - doc ^ "\n\nThis function returns a dictionary, with keys matching the various fields in the stat structure." - | RStatVFS _ -> - doc ^ "\n\nThis function returns a dictionary, with keys matching the various fields in the statvfs structure." - | RHashtable _ -> - doc ^ "\n\nThis function returns a dictionary." in - let doc = - if List.mem ProtocolLimitWarning flags then - doc ^ "\n\n" ^ protocol_limit_warning - else doc in - let doc = - if List.mem DangerWillRobinson flags then - doc ^ "\n\n" ^ danger_will_robinson - else doc in - let doc = pod2text ~width:60 name doc in - let doc = List.map (fun line -> replace_str line "\\" "\\\\") doc in - let doc = String.concat "\n " doc in - pr " def %s " name; generate_call_args ~handle:"self" (snd style); pr ":\n"; - pr " u\"\"\"%s\"\"\"\n" doc; + + if not (List.mem NotInDocs flags) then ( + let doc = replace_str longdesc "C doc + | RStringList _ -> + doc ^ "\n\nThis function returns a list of strings." + | RIntBool _ -> + doc ^ "\n\nThis function returns a tuple (int, bool).\n" + | RPVList _ -> + doc ^ "\n\nThis function returns a list of PVs. Each PV is represented as a dictionary." + | RVGList _ -> + doc ^ "\n\nThis function returns a list of VGs. Each VG is represented as a dictionary." + | RLVList _ -> + doc ^ "\n\nThis function returns a list of LVs. Each LV is represented as a dictionary." + | RStat _ -> + doc ^ "\n\nThis function returns a dictionary, with keys matching the various fields in the stat structure." + | RStatVFS _ -> + doc ^ "\n\nThis function returns a dictionary, with keys matching the various fields in the statvfs structure." + | RHashtable _ -> + doc ^ "\n\nThis function returns a dictionary." in + let doc = + if List.mem ProtocolLimitWarning flags then + doc ^ "\n\n" ^ protocol_limit_warning + else doc in + let doc = + if List.mem DangerWillRobinson flags then + doc ^ "\n\n" ^ danger_will_robinson + else doc in + let doc = pod2text ~width:60 name doc in + let doc = List.map (fun line -> replace_str line "\\" "\\\\") doc in + let doc = String.concat "\n " doc in + pr " u\"\"\"%s\"\"\"\n" doc; + ); pr " return libguestfsmod.%s " name; generate_call_args ~handle:"self._o" (snd style); pr "\n"; @@ -6248,7 +6398,7 @@ static VALUE ruby_guestfs_close (VALUE gv) pr " rb_raise (rb_eTypeError, \"expected string for parameter %%s of %%s\",\n"; pr " \"%s\", \"%s\");\n" n name | OptString n -> - pr " const char *%s = StringValueCStr (%sv);\n" n n + pr " const char *%s = !NIL_P (%sv) ? StringValueCStr (%sv) : NULL;\n" n n n | StringList n -> pr " char **%s;" n; pr " {\n"; @@ -6262,7 +6412,8 @@ static VALUE ruby_guestfs_close (VALUE gv) pr " }\n"; pr " %s[len] = NULL;\n" n; pr " }\n"; - | Bool n + | Bool n -> + pr " int %s = RTEST (%sv);\n" n n | Int n -> pr " int %s = NUM2INT (%sv);\n" n n ) (snd style); @@ -6482,25 +6633,32 @@ public class GuestFS { List.iter ( fun (name, style, _, flags, _, shortdesc, longdesc) -> - let doc = replace_str longdesc "C "

" + | nonempty -> nonempty + ) doc in + let doc = String.concat "\n * " doc in + + pr " /**\n"; + pr " * %s\n" shortdesc; + pr " *

\n"; + pr " * %s\n" doc; + pr " * @throws LibGuestFSException\n"; + pr " */\n"; + pr " "; + ); generate_java_prototype ~public:true ~semicolon:false name style; pr "\n"; pr " {\n"; @@ -6769,10 +6927,14 @@ Java_com_redhat_et_libguestfs_GuestFS__1close List.iter ( function | String n - | OptString n | FileIn n | FileOut n -> pr " %s = (*env)->GetStringUTFChars (env, j%s, NULL);\n" n n + | OptString n -> + (* This is completely undocumented, but Java null becomes + * a NULL parameter. + *) + pr " %s = j%s ? (*env)->GetStringUTFChars (env, j%s, NULL) : NULL;\n" n n n | StringList n -> pr " %s_len = (*env)->GetArrayLength (env, j%s);\n" n n; pr " %s = guestfs_safe_malloc (g, sizeof (char *) * (%s_len+1));\n" n n; @@ -6796,10 +6958,12 @@ Java_com_redhat_et_libguestfs_GuestFS__1close List.iter ( function | String n - | OptString n | FileIn n | FileOut n -> pr " (*env)->ReleaseStringUTFChars (env, j%s, %s);\n" n n + | OptString n -> + pr " if (j%s)\n" n; + pr " (*env)->ReleaseStringUTFChars (env, j%s, %s);\n" n n | StringList n -> pr " for (i = 0; i < %s_len; ++i) {\n" n; pr " jobject o = (*env)->GetObjectArrayElement (env, j%s, i);\n" @@ -7120,6 +7284,402 @@ and generate_haskell_prototype ~handle ?(hs = false) style = ); pr ")" +and generate_bindtests () = + generate_header CStyle LGPLv2; + + pr "\ +#include +#include +#include +#include + +#include \"guestfs.h\" +#include \"guestfs_protocol.h\" + +#define error guestfs_error + +static void +print_strings (char * const* const argv) +{ + int argc; + + printf (\"[\"); + for (argc = 0; argv[argc] != NULL; ++argc) { + if (argc > 0) printf (\", \"); + printf (\"\\\"%%s\\\"\", argv[argc]); + } + printf (\"]\\n\"); +} + +/* The test0 function prints its parameters to stdout. */ +"; + + let test0, tests = + match test_functions with + | [] -> assert false + | test0 :: tests -> test0, tests in + + let () = + let (name, style, _, _, _, _, _) = test0 in + generate_prototype ~extern:false ~semicolon:false ~newline:true + ~handle:"g" ~prefix:"guestfs_" name style; + pr "{\n"; + List.iter ( + function + | String n + | FileIn n + | FileOut n -> pr " printf (\"%%s\\n\", %s);\n" n + | OptString n -> pr " printf (\"%%s\\n\", %s ? %s : \"null\");\n" n n + | StringList n -> pr " print_strings (%s);\n" n + | Bool n -> pr " printf (\"%%s\\n\", %s ? \"true\" : \"false\");\n" n + | Int n -> pr " printf (\"%%d\\n\", %s);\n" n + ) (snd style); + pr " /* Java changes stdout line buffering so we need this: */\n"; + pr " fflush (stdout);\n"; + pr " return 0;\n"; + pr "}\n"; + pr "\n" in + + List.iter ( + fun (name, style, _, _, _, _, _) -> + if String.sub name (String.length name - 3) 3 <> "err" then ( + pr "/* Test normal return. */\n"; + generate_prototype ~extern:false ~semicolon:false ~newline:true + ~handle:"g" ~prefix:"guestfs_" name style; + pr "{\n"; + (match fst style with + | RErr -> + pr " return 0;\n" + | RInt _ -> + pr " int r;\n"; + pr " sscanf (val, \"%%d\", &r);\n"; + pr " return r;\n" + | RInt64 _ -> + pr " int64_t r;\n"; + pr " sscanf (val, \"%%\" SCNi64, &r);\n"; + pr " return r;\n" + | RBool _ -> + pr " return strcmp (val, \"true\") == 0;\n" + | RConstString _ -> + (* Can't return the input string here. Return a static + * string so we ensure we get a segfault if the caller + * tries to free it. + *) + pr " return \"static string\";\n" + | RString _ -> + pr " return strdup (val);\n" + | RStringList _ -> + pr " char **strs;\n"; + pr " int n, i;\n"; + pr " sscanf (val, \"%%d\", &n);\n"; + pr " strs = malloc ((n+1) * sizeof (char *));\n"; + pr " for (i = 0; i < n; ++i) {\n"; + pr " strs[i] = malloc (16);\n"; + pr " snprintf (strs[i], 16, \"%%d\", i);\n"; + pr " }\n"; + pr " strs[n] = NULL;\n"; + pr " return strs;\n" + | RIntBool _ -> + pr " struct guestfs_int_bool *r;\n"; + pr " r = malloc (sizeof (struct guestfs_int_bool));\n"; + pr " sscanf (val, \"%%\" SCNi32, &r->i);\n"; + pr " r->b = 0;\n"; + pr " return r;\n" + | RPVList _ -> + pr " struct guestfs_lvm_pv_list *r;\n"; + pr " int i;\n"; + pr " r = malloc (sizeof (struct guestfs_lvm_pv_list));\n"; + pr " sscanf (val, \"%%d\", &r->len);\n"; + pr " r->val = calloc (r->len, sizeof (struct guestfs_lvm_pv));\n"; + pr " for (i = 0; i < r->len; ++i) {\n"; + pr " r->val[i].pv_name = malloc (16);\n"; + pr " snprintf (r->val[i].pv_name, 16, \"%%d\", i);\n"; + pr " }\n"; + pr " return r;\n" + | RVGList _ -> + pr " struct guestfs_lvm_vg_list *r;\n"; + pr " int i;\n"; + pr " r = malloc (sizeof (struct guestfs_lvm_vg_list));\n"; + pr " sscanf (val, \"%%d\", &r->len);\n"; + pr " r->val = calloc (r->len, sizeof (struct guestfs_lvm_vg));\n"; + pr " for (i = 0; i < r->len; ++i) {\n"; + pr " r->val[i].vg_name = malloc (16);\n"; + pr " snprintf (r->val[i].vg_name, 16, \"%%d\", i);\n"; + pr " }\n"; + pr " return r;\n" + | RLVList _ -> + pr " struct guestfs_lvm_lv_list *r;\n"; + pr " int i;\n"; + pr " r = malloc (sizeof (struct guestfs_lvm_lv_list));\n"; + pr " sscanf (val, \"%%d\", &r->len);\n"; + pr " r->val = calloc (r->len, sizeof (struct guestfs_lvm_lv));\n"; + pr " for (i = 0; i < r->len; ++i) {\n"; + pr " r->val[i].lv_name = malloc (16);\n"; + pr " snprintf (r->val[i].lv_name, 16, \"%%d\", i);\n"; + pr " }\n"; + pr " return r;\n" + | RStat _ -> + pr " struct guestfs_stat *r;\n"; + pr " r = calloc (1, sizeof (*r));\n"; + pr " sscanf (val, \"%%\" SCNi64, &r->dev);\n"; + pr " return r;\n" + | RStatVFS _ -> + pr " struct guestfs_statvfs *r;\n"; + pr " r = calloc (1, sizeof (*r));\n"; + pr " sscanf (val, \"%%\" SCNi64, &r->bsize);\n"; + pr " return r;\n" + | RHashtable _ -> + pr " char **strs;\n"; + pr " int n, i;\n"; + pr " sscanf (val, \"%%d\", &n);\n"; + pr " strs = malloc ((n*2+1) * sizeof (char *));\n"; + pr " for (i = 0; i < n; ++i) {\n"; + pr " strs[i*2] = malloc (16);\n"; + pr " strs[i*2+1] = malloc (16);\n"; + pr " snprintf (strs[i*2], 16, \"%%d\", i);\n"; + pr " snprintf (strs[i*2+1], 16, \"%%d\", i);\n"; + pr " }\n"; + pr " strs[n*2] = NULL;\n"; + pr " return strs;\n" + ); + pr "}\n"; + pr "\n" + ) else ( + pr "/* Test error return. */\n"; + generate_prototype ~extern:false ~semicolon:false ~newline:true + ~handle:"g" ~prefix:"guestfs_" name style; + pr "{\n"; + pr " error (g, \"error\");\n"; + (match fst style with + | RErr | RInt _ | RInt64 _ | RBool _ -> + pr " return -1;\n" + | RConstString _ + | RString _ | RStringList _ | RIntBool _ + | RPVList _ | RVGList _ | RLVList _ | RStat _ | RStatVFS _ + | RHashtable _ -> + pr " return NULL;\n" + ); + pr "}\n"; + pr "\n" + ) + ) tests + +and generate_ocaml_bindtests () = + generate_header OCamlStyle GPLv2; + + pr "\ +let () = + let g = Guestfs.create () in +"; + + let mkargs args = + String.concat " " ( + List.map ( + function + | CallString s -> "\"" ^ s ^ "\"" + | CallOptString None -> "None" + | CallOptString (Some s) -> sprintf "(Some \"%s\")" s + | CallStringList xs -> + "[|" ^ String.concat ";" (List.map (sprintf "\"%s\"") xs) ^ "|]" + | CallInt i when i >= 0 -> string_of_int i + | CallInt i (* when i < 0 *) -> "(" ^ string_of_int i ^ ")" + | CallBool b -> string_of_bool b + ) args + ) + in + + generate_lang_bindtests ( + fun f args -> pr " Guestfs.%s g %s;\n" f (mkargs args) + ); + + pr "print_endline \"EOF\"\n" + +and generate_perl_bindtests () = + pr "#!/usr/bin/perl -w\n"; + generate_header HashStyle GPLv2; + + pr "\ +use strict; + +use Sys::Guestfs; + +my $g = Sys::Guestfs->new (); +"; + + let mkargs args = + String.concat ", " ( + List.map ( + function + | CallString s -> "\"" ^ s ^ "\"" + | CallOptString None -> "undef" + | CallOptString (Some s) -> sprintf "\"%s\"" s + | CallStringList xs -> + "[" ^ String.concat "," (List.map (sprintf "\"%s\"") xs) ^ "]" + | CallInt i -> string_of_int i + | CallBool b -> if b then "1" else "0" + ) args + ) + in + + generate_lang_bindtests ( + fun f args -> pr "$g->%s (%s);\n" f (mkargs args) + ); + + pr "print \"EOF\\n\"\n" + +and generate_python_bindtests () = + generate_header HashStyle GPLv2; + + pr "\ +import guestfs + +g = guestfs.GuestFS () +"; + + let mkargs args = + String.concat ", " ( + List.map ( + function + | CallString s -> "\"" ^ s ^ "\"" + | CallOptString None -> "None" + | CallOptString (Some s) -> sprintf "\"%s\"" s + | CallStringList xs -> + "[" ^ String.concat "," (List.map (sprintf "\"%s\"") xs) ^ "]" + | CallInt i -> string_of_int i + | CallBool b -> if b then "1" else "0" + ) args + ) + in + + generate_lang_bindtests ( + fun f args -> pr "g.%s (%s)\n" f (mkargs args) + ); + + pr "print \"EOF\"\n" + +and generate_ruby_bindtests () = + generate_header HashStyle GPLv2; + + pr "\ +require 'guestfs' + +g = Guestfs::create() +"; + + let mkargs args = + String.concat ", " ( + List.map ( + function + | CallString s -> "\"" ^ s ^ "\"" + | CallOptString None -> "nil" + | CallOptString (Some s) -> sprintf "\"%s\"" s + | CallStringList xs -> + "[" ^ String.concat "," (List.map (sprintf "\"%s\"") xs) ^ "]" + | CallInt i -> string_of_int i + | CallBool b -> string_of_bool b + ) args + ) + in + + generate_lang_bindtests ( + fun f args -> pr "g.%s(%s)\n" f (mkargs args) + ); + + pr "print \"EOF\\n\"\n" + +and generate_java_bindtests () = + generate_header CStyle GPLv2; + + pr "\ +import com.redhat.et.libguestfs.*; + +public class Bindtests { + public static void main (String[] argv) + { + try { + GuestFS g = new GuestFS (); +"; + + let mkargs args = + String.concat ", " ( + List.map ( + function + | CallString s -> "\"" ^ s ^ "\"" + | CallOptString None -> "null" + | CallOptString (Some s) -> sprintf "\"%s\"" s + | CallStringList xs -> + "new String[]{" ^ + String.concat "," (List.map (sprintf "\"%s\"") xs) ^ "}" + | CallInt i -> string_of_int i + | CallBool b -> string_of_bool b + ) args + ) + in + + generate_lang_bindtests ( + fun f args -> pr " g.%s (%s);\n" f (mkargs args) + ); + + pr " + System.out.println (\"EOF\"); + } + catch (Exception exn) { + System.err.println (exn); + System.exit (1); + } + } +} +" + +and generate_haskell_bindtests () = + () (* XXX Haskell bindings need to be fleshed out. *) + +(* Language-independent bindings tests - we do it this way to + * ensure there is parity in testing bindings across all languages. + *) +and generate_lang_bindtests call = + call "test0" [CallString "abc"; CallOptString (Some "def"); + CallStringList []; CallBool false; + CallInt 0; CallString "123"; CallString "456"]; + call "test0" [CallString "abc"; CallOptString None; + CallStringList []; CallBool false; + CallInt 0; CallString "123"; CallString "456"]; + call "test0" [CallString ""; CallOptString (Some "def"); + CallStringList []; CallBool false; + CallInt 0; CallString "123"; CallString "456"]; + call "test0" [CallString ""; CallOptString (Some ""); + CallStringList []; CallBool false; + CallInt 0; CallString "123"; CallString "456"]; + call "test0" [CallString "abc"; CallOptString (Some "def"); + CallStringList ["1"]; CallBool false; + CallInt 0; CallString "123"; CallString "456"]; + call "test0" [CallString "abc"; CallOptString (Some "def"); + CallStringList ["1"; "2"]; CallBool false; + CallInt 0; CallString "123"; CallString "456"]; + call "test0" [CallString "abc"; CallOptString (Some "def"); + CallStringList ["1"]; CallBool true; + CallInt 0; CallString "123"; CallString "456"]; + call "test0" [CallString "abc"; CallOptString (Some "def"); + CallStringList ["1"]; CallBool false; + CallInt (-1); CallString "123"; CallString "456"]; + call "test0" [CallString "abc"; CallOptString (Some "def"); + CallStringList ["1"]; CallBool false; + CallInt (-2); CallString "123"; CallString "456"]; + call "test0" [CallString "abc"; CallOptString (Some "def"); + CallStringList ["1"]; CallBool false; + CallInt 1; CallString "123"; CallString "456"]; + call "test0" [CallString "abc"; CallOptString (Some "def"); + CallStringList ["1"]; CallBool false; + CallInt 2; CallString "123"; CallString "456"]; + call "test0" [CallString "abc"; CallOptString (Some "def"); + CallStringList ["1"]; CallBool false; + CallInt 4095; CallString "123"; CallString "456"]; + call "test0" [CallString "abc"; CallOptString (Some "def"); + CallStringList ["1"]; CallBool false; + CallInt 0; CallString ""; CallString ""] + + (* XXX Add here tests of the return and error functions. *) + let output_to filename = let filename_new = filename ^ ".new" in chan := open_out filename_new; @@ -7177,10 +7737,14 @@ Run it from the top source directory using the command generate_daemon_actions (); close (); - let close = output_to "tests.c" in + let close = output_to "capitests/tests.c" in generate_tests (); close (); + let close = output_to "src/guestfs-bindtests.c" in + generate_bindtests (); + close (); + let close = output_to "fish/cmds.c" in generate_fish_cmds (); close (); @@ -7213,6 +7777,10 @@ Run it from the top source directory using the command generate_ocaml_c (); close (); + let close = output_to "ocaml/bindtests.ml" in + generate_ocaml_bindtests (); + close (); + let close = output_to "perl/Guestfs.xs" in generate_perl_xs (); close (); @@ -7221,6 +7789,10 @@ Run it from the top source directory using the command generate_perl_pm (); close (); + let close = output_to "perl/bindtests.pl" in + generate_perl_bindtests (); + close (); + let close = output_to "python/guestfs-py.c" in generate_python_c (); close (); @@ -7229,10 +7801,18 @@ Run it from the top source directory using the command generate_python_py (); close (); + let close = output_to "python/bindtests.py" in + generate_python_bindtests (); + close (); + let close = output_to "ruby/ext/guestfs/_guestfs.c" in generate_ruby_c (); close (); + let close = output_to "ruby/bindtests.rb" in + generate_ruby_bindtests (); + close (); + let close = output_to "java/com/redhat/et/libguestfs/GuestFS.java" in generate_java_java (); close (); @@ -7261,6 +7841,14 @@ Run it from the top source directory using the command generate_java_c (); close (); + let close = output_to "java/Bindtests.java" in + generate_java_bindtests (); + close (); + let close = output_to "haskell/Guestfs.hs" in generate_haskell_hs (); close (); + + let close = output_to "haskell/bindtests.hs" in + generate_haskell_bindtests (); + close ();