Add large test files with standard content for the C API test.

[libguestfs.git] / src / generator.ml

diff --git a/src/generator.ml b/src/generator.ml
index e378395..7905c36 100755 (executable)
--- a/src/generator.ml
+++ b/src/generator.ml
@@ -2131,7 +2131,13 @@ The returned strings are transcoded to UTF-8.");
   ("hexdump", (RString "dump", [String "path"]), 96, [ProtocolLimitWarning],
    [InitBasicFS, Always, 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")],
+       ["hexdump"; "/new"]], "00000000  68 65 6c 6c 6f 0a 77 6f  72 6c 64 0a              |hello.world.|\n0000000c\n");
+    (* Test for RHBZ#501888c2 regression which caused large hexdump
+     * commands to segfault.
+     *)
+    InitBasicFS, Always, TestRun (
+      [["mount_vfs"; "ro"; "squashfs"; "/dev/sdd"; "/"];
+       ["hexdump"; "/100krandom"]])],
    "dump a file in hexadecimal",
    "\
 This runs C<hexdump -C> on the given C<path>.  The result is
@@ -2450,15 +2456,18 @@ manual page for more details.");
    "\
 This command creates a temporary directory.  The
 C<template> parameter should be a full pathname for the
-temporary directory with the six characters being
+temporary directory name with the final six characters being
 \"XXXXXX\".
 
-For example: \"/tmp/tmpXXXXXX\" or \"/Temp/tmpXXXXXX\",
-the second one being suitable for Windows.
+For example: \"/tmp/myprogXXXXXX\" or \"/Temp/myprogXXXXXX\",
+the second one being suitable for Windows filesystems.
 
 The name of the temporary directory that was created
 is returned.
 
+The temporary directory is created with mode 0700
+and is owned by root.
+
 The caller is responsible for deleting the temporary
 directory and its contents after use.
 
@@ -7261,14 +7270,11 @@ and generate_haskell_hs () =
    * 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 _, _
+    | RErr, _
     | RInt _, _
-    | RInt64 _, _
+    | RInt64 _, _ -> true
+    | RBool _, _
     | RConstString _, _
     | RString _, _
     | RStringList _, _
@@ -7297,6 +7303,7 @@ module Guestfs (
   ) where
 import Foreign
 import Foreign.C
+import Foreign.C.Types
 import IO
 import Control.Exception
 import Data.Typeable
@@ -7360,6 +7367,7 @@ last_error h = do
        pr "%s %s = do\n" name
          (String.concat " " ("h" :: List.map name_of_argt (snd style)));
        pr "  r <- ";
+       (* Convert pointer arguments using with* functions. *)
        List.iter (
          function
          | FileIn n
@@ -7367,17 +7375,18 @@ last_error h = do
          | 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
+         | Bool _ | Int _ -> ()
        ) (snd style);
+       (* Convert integer arguments. *)
+       let args =
+         List.map (
+           function
+           | Bool n -> sprintf "(fromBool %s)" n
+           | Int n -> sprintf "(fromIntegral %s)" n
+           | FileIn n | FileOut n | String n | OptString n | StringList n -> n
+         ) (snd style) in
        pr "withForeignPtr h (\\p -> c_%s %s)\n" name
-         (String.concat " " ("p" :: List.map name_of_argt (snd style)));
+         (String.concat " " ("p" :: args));
        (match fst style with
         | RErr | RInt _ | RInt64 _ | RBool _ ->
             pr "  if (r == -1)\n";
@@ -7803,7 +7812,38 @@ public class Bindtests {
 "
 
 and generate_haskell_bindtests () =
-  () (* XXX Haskell bindings need to be fleshed out. *)
+  generate_header HaskellStyle GPLv2;
+
+  pr "\
+module Bindtests where
+import qualified Guestfs
+
+main = do
+  g <- Guestfs.create
+";
+
+  let mkargs args =
+    String.concat " " (
+      List.map (
+       function
+       | CallString s -> "\"" ^ s ^ "\""
+       | CallOptString None -> "Nothing"
+       | CallOptString (Some s) -> sprintf "(Just \"%s\")" s
+       | CallStringList xs ->
+           "[" ^ String.concat "," (List.map (sprintf "\"%s\"") xs) ^ "]"
+       | CallInt i when i < 0 -> "(" ^ string_of_int i ^ ")"
+       | CallInt i -> string_of_int i
+       | CallBool true -> "True"
+       | CallBool false -> "False"
+      ) args
+    )
+  in
+
+  generate_lang_bindtests (
+    fun f args -> pr "  Guestfs.%s g %s\n" f (mkargs args)
+  );
+
+  pr "  putStrLn \"EOF\"\n"
 
 (* Language-independent bindings tests - we do it this way to
  * ensure there is parity in testing bindings across all languages.
@@ -8033,7 +8073,7 @@ Run it from the top source directory using the command
   generate_haskell_hs ();
   close ();
 
-  let close = output_to "haskell/bindtests.hs" in
+  let close = output_to "haskell/Bindtests.hs" in
   generate_haskell_bindtests ();
   close ();