ocaml: Fix memory leak in bindings for functions that return buffers.
[libguestfs.git] / generator / generator_ocaml.ml
1 (* libguestfs
2  * Copyright (C) 2009-2011 Red Hat Inc.
3  *
4  * This program is free software; you can redistribute it and/or modify
5  * it under the terms of the GNU General Public License as published by
6  * the Free Software Foundation; either version 2 of the License, or
7  * (at your option) any later version.
8  *
9  * This program is distributed in the hope that it will be useful,
10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12  * GNU General Public License for more details.
13  *
14  * You should have received a copy of the GNU General Public License
15  * along with this program; if not, write to the Free Software
16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
17  *)
18
19 (* Please read generator/README first. *)
20
21 open Printf
22
23 open Generator_types
24 open Generator_utils
25 open Generator_pr
26 open Generator_docstrings
27 open Generator_optgroups
28 open Generator_actions
29 open Generator_structs
30 open Generator_c
31 open Generator_events
32
33 (* Generate the OCaml bindings interface. *)
34 let rec generate_ocaml_mli () =
35   generate_header OCamlStyle LGPLv2plus;
36
37   pr "\
38 (** libguestfs bindings for OCaml.
39
40     For API documentation, the canonical reference is the
41     {{:http://libguestfs.org/guestfs.3.html}guestfs(3)} man page.
42     The OCaml API uses almost exactly the same calls.
43
44     For examples written in OCaml see the
45     {{:http://libguestfs.org/guestfs-ocaml.3.html}guestfs-ocaml(3)} man page.
46     *)
47
48 (** {2 Module style API}
49
50     This is the module-style API.  There is also an object-oriented API
51     (see the end of this file and {!guestfs})
52     which is functionally completely equivalent, but is more compact. *)
53
54 type t
55 (** A [guestfs_h] handle. *)
56
57 exception Error of string
58 (** This exception is raised when there is an error. *)
59
60 exception Handle_closed of string
61 (** This exception is raised if you use a {!t} handle
62     after calling {!close} on it.  The string is the name of
63     the function. *)
64
65 val create : unit -> t
66 (** Create a {!t} handle. *)
67
68 val close : t -> unit
69 (** Close the {!t} handle and free up all resources used
70     by it immediately.
71
72     Handles are closed by the garbage collector when they become
73     unreferenced, but callers can call this in order to provide
74     predictable cleanup. *)
75
76 type event =
77 ";
78   List.iter (
79     fun (name, _) ->
80       pr "  | EVENT_%s\n" (String.uppercase name)
81   ) events;
82   pr "\n";
83
84   pr "\
85 val event_all : event list
86 (** A list containing all event types. *)
87
88 type event_handle
89 (** The opaque event handle which can be used to delete event callbacks. *)
90
91 type event_callback =
92   t -> event -> event_handle -> string -> int64 array -> unit
93 (** The event callback. *)
94
95 val set_event_callback : t -> event_callback -> event list -> event_handle
96 (** [set_event_callback g f es] sets [f] as the event callback function
97     for all events in the set [es].
98
99     Note that if the closure captures a reference to the handle,
100     this reference will prevent the handle from being
101     automatically closed by the garbage collector.  Since the
102     handle is passed to the event callback, with careful programming
103     it should be possible to avoid capturing the handle in the closure. *)
104
105 val delete_event_callback : t -> event_handle -> unit
106 (** [delete_event_callback g eh] removes a previously registered
107     event callback.  See {!set_event_callback}. *)
108
109 val last_errno : t -> int
110 (** [last_errno g] returns the last errno that happened on the handle [g]
111     (or [0] if there was no errno).  Note that the returned integer is the
112     raw errno number, and it is {i not} related to the {!Unix.error} type.
113
114     [last_errno] can be overwritten by subsequent operations on a handle,
115     so if you want to capture the errno correctly, you must call this
116     in the {!Error} exception handler, before any other operation on [g]. *)
117
118 val user_cancel : t -> unit
119 (** Cancel current transfer.  This is safe to call from OCaml signal
120     handlers and threads. *)
121
122 ";
123   generate_ocaml_structure_decls ();
124
125   (* The actions. *)
126   List.iter (
127     fun (name, style, _, flags, _, shortdesc, _) ->
128       let deprecated =
129         try Some (find_map (function DeprecatedBy fn -> Some fn | _ -> None)
130                     flags)
131         with Not_found -> None in
132       let in_docs = not (List.mem NotInDocs flags) in
133
134       generate_ocaml_prototype name style;
135
136       if in_docs then (
137         pr "(** %s" shortdesc;
138         (match deprecated with
139          | None -> ()
140          | Some replacement ->
141              pr "\n\n    @deprecated Use {!%s} instead\n" replacement
142         );
143         pr " *)\n";
144       );
145       pr "\n"
146   ) all_functions_sorted;
147
148   pr "\
149 (** {2 Object-oriented API}
150
151     This is an alternate way of calling the API using an object-oriented
152     style, so you can use
153     [g#]{{!guestfs.add_drive_opts}add_drive_opts} [filename]
154     instead of [Guestfs.add_drive_opts g filename].
155     Apart from the different style, it offers exactly the same functionality.
156
157     Calling [new guestfs ()] creates both the object and the handle.
158     The object and handle are closed either implicitly when the
159     object is garbage collected, or explicitly by calling the
160     [g#]{{!guestfs.close}close} [()] method.
161
162     You can get the {!t} handle by calling
163     [g#]{{!guestfs.ocaml_handle}ocaml_handle}.
164
165     Note that methods that take no parameters (except the implicit handle)
166     get an extra unit [()] parameter.  This is so you can create a
167     closure from the method easily.  For example
168     [g#]{{!guestfs.get_verbose}get_verbose} [()]
169     calls the method, whereas [g#get_verbose] is a function. *)
170
171 class guestfs : unit -> object
172   method close : unit -> unit
173   method set_event_callback : event_callback -> event list -> event_handle
174   method delete_event_callback : event_handle -> unit
175   method last_errno : unit -> int
176   method user_cancel : unit -> unit
177   method ocaml_handle : t
178 ";
179
180   List.iter (
181     function
182     | name, ((_, [], []) as style), _, _, _, _, _ ->
183         pr "  method %s : unit -> " name;
184         generate_ocaml_function_type style;
185         pr "\n"
186     | name, style, _, _, _, _, _ ->
187         pr "  method %s : " name;
188         generate_ocaml_function_type style;
189         pr "\n"
190   ) all_functions_sorted;
191
192   pr "end\n"
193
194 (* Generate the OCaml bindings implementation. *)
195 and generate_ocaml_ml () =
196   generate_header OCamlStyle LGPLv2plus;
197
198   pr "\
199 type t
200
201 exception Error of string
202 exception Handle_closed of string
203
204 external create : unit -> t = \"ocaml_guestfs_create\"
205 external close : t -> unit = \"ocaml_guestfs_close\"
206
207 type event =
208 ";
209   List.iter (
210     fun (name, _) ->
211       pr "  | EVENT_%s\n" (String.uppercase name)
212   ) events;
213   pr "\n";
214
215   pr "\
216 let event_all = [
217 ";
218   List.iter (
219     fun (name, _) ->
220       pr "  EVENT_%s;\n" (String.uppercase name)
221   ) events;
222
223   pr "\
224 ]
225
226 type event_handle = int
227
228 type event_callback =
229   t -> event -> event_handle -> string -> int64 array -> unit
230
231 external set_event_callback : t -> event_callback -> event list -> event_handle
232   = \"ocaml_guestfs_set_event_callback\"
233 external delete_event_callback : t -> event_handle -> unit
234   = \"ocaml_guestfs_delete_event_callback\"
235
236 external last_errno : t -> int = \"ocaml_guestfs_last_errno\"
237
238 external user_cancel : t -> unit = \"ocaml_guestfs_user_cancel\" \"noalloc\"
239
240 (* Give the exceptions names, so they can be raised from the C code. *)
241 let () =
242   Callback.register_exception \"ocaml_guestfs_error\" (Error \"\");
243   Callback.register_exception \"ocaml_guestfs_closed\" (Handle_closed \"\")
244
245 ";
246
247   generate_ocaml_structure_decls ();
248
249   (* The actions. *)
250   List.iter (
251     fun (name, style, _, _, _, shortdesc, _) ->
252       generate_ocaml_prototype ~is_external:true name style;
253   ) all_functions_sorted;
254
255   (* OO API. *)
256   pr "
257 class guestfs () =
258   let g = create () in
259   object
260     method close () = close g
261     method set_event_callback = set_event_callback g
262     method delete_event_callback = delete_event_callback g
263     method last_errno () = last_errno g
264     method user_cancel () = user_cancel g
265     method ocaml_handle = g
266 ";
267
268   List.iter (
269     function
270     | name, (_, [], []), _, _, _, _, _ -> (* no params?  add explicit unit *)
271         pr "    method %s () = %s g\n" name name
272     | name, _, _, _, _, _, _ ->
273         pr "    method %s = %s g\n" name name
274   ) all_functions_sorted;
275
276   pr "  end\n"
277
278 (* Generate the OCaml bindings C implementation. *)
279 and generate_ocaml_c () =
280   generate_header CStyle LGPLv2plus;
281
282   pr "\
283 #include <stdio.h>
284 #include <stdlib.h>
285 #include <string.h>
286 #include <stdint.h>
287
288 #include <caml/config.h>
289 #include <caml/alloc.h>
290 #include <caml/callback.h>
291 #include <caml/fail.h>
292 #include <caml/memory.h>
293 #include <caml/mlvalues.h>
294 #include <caml/signals.h>
295
296 #include \"guestfs.h\"
297
298 #include \"guestfs_c.h\"
299
300 /* Copy a hashtable of string pairs into an assoc-list.  We return
301  * the list in reverse order, but hashtables aren't supposed to be
302  * ordered anyway.
303  */
304 static CAMLprim value
305 copy_table (char * const * argv)
306 {
307   CAMLparam0 ();
308   CAMLlocal5 (rv, pairv, kv, vv, cons);
309   size_t i;
310
311   rv = Val_int (0);
312   for (i = 0; argv[i] != NULL; i += 2) {
313     kv = caml_copy_string (argv[i]);
314     vv = caml_copy_string (argv[i+1]);
315     pairv = caml_alloc (2, 0);
316     Store_field (pairv, 0, kv);
317     Store_field (pairv, 1, vv);
318     cons = caml_alloc (2, 0);
319     Store_field (cons, 1, rv);
320     rv = cons;
321     Store_field (cons, 0, pairv);
322   }
323
324   CAMLreturn (rv);
325 }
326
327 ";
328
329   (* Struct copy functions. *)
330
331   let emit_ocaml_copy_list_function typ =
332     pr "static CAMLprim value\n";
333     pr "copy_%s_list (const struct guestfs_%s_list *%ss)\n" typ typ typ;
334     pr "{\n";
335     pr "  CAMLparam0 ();\n";
336     pr "  CAMLlocal2 (rv, v);\n";
337     pr "  unsigned int i;\n";
338     pr "\n";
339     pr "  if (%ss->len == 0)\n" typ;
340     pr "    CAMLreturn (Atom (0));\n";
341     pr "  else {\n";
342     pr "    rv = caml_alloc (%ss->len, 0);\n" typ;
343     pr "    for (i = 0; i < %ss->len; ++i) {\n" typ;
344     pr "      v = copy_%s (&%ss->val[i]);\n" typ typ;
345     pr "      caml_modify (&Field (rv, i), v);\n";
346     pr "    }\n";
347     pr "    CAMLreturn (rv);\n";
348     pr "  }\n";
349     pr "}\n";
350     pr "\n";
351   in
352
353   List.iter (
354     fun (typ, cols) ->
355       let has_optpercent_col =
356         List.exists (function (_, FOptPercent) -> true | _ -> false) cols in
357
358       pr "static CAMLprim value\n";
359       pr "copy_%s (const struct guestfs_%s *%s)\n" typ typ typ;
360       pr "{\n";
361       pr "  CAMLparam0 ();\n";
362       if has_optpercent_col then
363         pr "  CAMLlocal3 (rv, v, v2);\n"
364       else
365         pr "  CAMLlocal2 (rv, v);\n";
366       pr "\n";
367       pr "  rv = caml_alloc (%d, 0);\n" (List.length cols);
368       iteri (
369         fun i col ->
370           (match col with
371            | name, FString ->
372                pr "  v = caml_copy_string (%s->%s);\n" typ name
373            | name, FBuffer ->
374                pr "  v = caml_alloc_string (%s->%s_len);\n" typ name;
375                pr "  memcpy (String_val (v), %s->%s, %s->%s_len);\n"
376                  typ name typ name
377            | name, FUUID ->
378                pr "  v = caml_alloc_string (32);\n";
379                pr "  memcpy (String_val (v), %s->%s, 32);\n" typ name
380            | name, (FBytes|FInt64|FUInt64) ->
381                pr "  v = caml_copy_int64 (%s->%s);\n" typ name
382            | name, (FInt32|FUInt32) ->
383                pr "  v = caml_copy_int32 (%s->%s);\n" typ name
384            | name, FOptPercent ->
385                pr "  if (%s->%s >= 0) { /* Some %s */\n" typ name name;
386                pr "    v2 = caml_copy_double (%s->%s);\n" typ name;
387                pr "    v = caml_alloc (1, 0);\n";
388                pr "    Store_field (v, 0, v2);\n";
389                pr "  } else /* None */\n";
390                pr "    v = Val_int (0);\n";
391            | name, FChar ->
392                pr "  v = Val_int (%s->%s);\n" typ name
393           );
394           pr "  Store_field (rv, %d, v);\n" i
395       ) cols;
396       pr "  CAMLreturn (rv);\n";
397       pr "}\n";
398       pr "\n";
399   ) structs;
400
401   (* Emit a copy_TYPE_list function definition only if that function is used. *)
402   List.iter (
403     function
404     | typ, (RStructListOnly | RStructAndList) ->
405         (* generate the function for typ *)
406         emit_ocaml_copy_list_function typ
407     | typ, _ -> () (* empty *)
408   ) (rstructs_used_by all_functions);
409
410   (* The wrappers. *)
411   List.iter (
412     fun (name, (ret, args, optargs as style), _, _, _, _, _) ->
413       pr "/* Automatically generated wrapper for function\n";
414       pr " * ";
415       generate_ocaml_prototype name style;
416       pr " */\n";
417       pr "\n";
418
419       (* If we run into this situation, we'll need to change the
420        * bindings a little.
421        *)
422       if args = [] && optargs <> [] then
423         failwithf "ocaml bindings don't support args = [], optargs <> []";
424
425       let params =
426         "gv" ::
427           List.map (fun arg -> name_of_argt arg ^ "v") (optargs @ args) in
428
429       let needs_extra_vs =
430         match ret with RConstOptString _ -> true | _ -> false in
431
432       pr "/* Emit prototype to appease gcc's -Wmissing-prototypes. */\n";
433       pr "CAMLprim value ocaml_guestfs_%s (value %s" name (List.hd params);
434       List.iter (pr ", value %s") (List.tl params); pr ");\n";
435       pr "\n";
436
437       pr "CAMLprim value\n";
438       pr "ocaml_guestfs_%s (value %s" name (List.hd params);
439       List.iter (pr ", value %s") (List.tl params);
440       pr ")\n";
441       pr "{\n";
442
443       (* CAMLparam<N> can only take up to 5 parameters.  Further parameters
444        * have to be passed in groups of 5 to CAMLxparam<N> calls.
445        *)
446       (match params with
447        | p1 :: p2 :: p3 :: p4 :: p5 :: rest ->
448            pr "  CAMLparam5 (%s);\n" (String.concat ", " [p1; p2; p3; p4; p5]);
449            let rec loop = function
450              | [] -> ()
451              | p1 :: p2 :: p3 :: p4 :: p5 :: rest ->
452                pr "  CAMLxparam5 (%s);\n"
453                  (String.concat ", " [p1; p2; p3; p4; p5]);
454                loop rest
455              | rest ->
456                pr "  CAMLxparam%d (%s);\n"
457                  (List.length rest) (String.concat ", " rest)
458            in
459            loop rest
460        | ps ->
461            pr "  CAMLparam%d (%s);\n" (List.length ps) (String.concat ", " ps)
462       );
463       if not needs_extra_vs then
464         pr "  CAMLlocal1 (rv);\n"
465       else
466         pr "  CAMLlocal3 (rv, v, v2);\n";
467       pr "\n";
468
469       pr "  guestfs_h *g = Guestfs_val (gv);\n";
470       pr "  if (g == NULL)\n";
471       pr "    ocaml_guestfs_raise_closed (\"%s\");\n" name;
472       pr "\n";
473
474       List.iter (
475         function
476         | Pathname n
477         | Device n | Dev_or_Path n
478         | String n
479         | FileIn n
480         | FileOut n
481         | Key n ->
482             (* Copy strings in case the GC moves them: RHBZ#604691 *)
483             pr "  char *%s = guestfs_safe_strdup (g, String_val (%sv));\n" n n
484         | OptString n ->
485             pr "  char *%s =\n" n;
486             pr "    %sv != Val_int (0) ?\n" n;
487             pr "      guestfs_safe_strdup (g, String_val (Field (%sv, 0))) : NULL;\n" n
488         | BufferIn n ->
489             pr "  size_t %s_size = caml_string_length (%sv);\n" n n;
490             pr "  char *%s = guestfs_safe_memdup (g, String_val (%sv), %s_size);\n" n n n
491         | StringList n | DeviceList n ->
492             pr "  char **%s = ocaml_guestfs_strings_val (g, %sv);\n" n n
493         | Bool n ->
494             pr "  int %s = Bool_val (%sv);\n" n n
495         | Int n ->
496             pr "  int %s = Int_val (%sv);\n" n n
497         | Int64 n ->
498             pr "  int64_t %s = Int64_val (%sv);\n" n n
499         | Pointer (t, n) ->
500             pr "  %s %s = (%s) (intptr_t) Int64_val (%sv);\n" t n t n
501       ) args;
502
503       (* Optional arguments. *)
504       if optargs <> [] then (
505         pr "  struct guestfs_%s_argv optargs_s = { .bitmask = 0 };\n" name;
506         pr "  struct guestfs_%s_argv *optargs = &optargs_s;\n" name;
507         let uc_name = String.uppercase name in
508         List.iter (
509           fun argt ->
510             let n = name_of_argt argt in
511             let uc_n = String.uppercase n in
512             pr "  if (%sv != Val_int (0)) {\n" n;
513             pr "    optargs_s.bitmask |= GUESTFS_%s_%s_BITMASK;\n" uc_name uc_n;
514             pr "    optargs_s.%s = " n;
515             (match argt with
516              | Bool _ -> pr "Bool_val (Field (%sv, 0))" n
517              | Int _ -> pr "Int_val (Field (%sv, 0))" n
518              | Int64 _ -> pr "Int64_val (Field (%sv, 0))" n
519              | String _ ->
520                  pr "guestfs_safe_strdup (g, String_val (Field (%sv, 0)))" n
521              | _ -> assert false
522             );
523             pr ";\n";
524             pr "  }\n";
525         ) optargs
526       );
527
528       (match ret with
529        | RErr -> pr "  int r;\n"
530        | RInt _ -> pr "  int r;\n"
531        | RInt64 _ -> pr "  int64_t r;\n"
532        | RBool _ -> pr "  int r;\n"
533        | RConstString _ | RConstOptString _ ->
534            pr "  const char *r;\n"
535        | RString _ -> pr "  char *r;\n"
536        | RStringList _ ->
537            pr "  size_t i;\n";
538            pr "  char **r;\n"
539        | RStruct (_, typ) ->
540            pr "  struct guestfs_%s *r;\n" typ
541        | RStructList (_, typ) ->
542            pr "  struct guestfs_%s_list *r;\n" typ
543        | RHashtable _ ->
544            pr "  size_t i;\n";
545            pr "  char **r;\n"
546        | RBufferOut _ ->
547            pr "  char *r;\n";
548            pr "  size_t size;\n"
549       );
550       pr "\n";
551
552       pr "  caml_enter_blocking_section ();\n";
553       if optargs = [] then
554         pr "  r = guestfs_%s " name
555       else
556         pr "  r = guestfs_%s_argv " name;
557       generate_c_call_args ~handle:"g" style;
558       pr ";\n";
559       pr "  caml_leave_blocking_section ();\n";
560
561       (* Free strings if we copied them above. *)
562       List.iter (
563         function
564         | Pathname n | Device n | Dev_or_Path n | String n | OptString n
565         | FileIn n | FileOut n | BufferIn n | Key n ->
566             pr "  free (%s);\n" n
567         | StringList n | DeviceList n ->
568             pr "  ocaml_guestfs_free_strings (%s);\n" n;
569         | Bool _ | Int _ | Int64 _ | Pointer _ -> ()
570       ) args;
571       List.iter (
572         function
573         | String n ->
574             pr "  if (%sv != Val_int (0))\n" n;
575             pr "    free ((char *) optargs_s.%s);\n" n
576         | Bool _ | Int _ | Int64 _
577         | Pathname _ | Device _ | Dev_or_Path _ | OptString _
578         | FileIn _ | FileOut _ | BufferIn _ | Key _
579         | StringList _ | DeviceList _ | Pointer _ -> ()
580       ) optargs;
581
582       (match errcode_of_ret ret with
583        | `CannotReturnError -> ()
584        | `ErrorIsMinusOne ->
585            pr "  if (r == -1)\n";
586            pr "    ocaml_guestfs_raise_error (g, \"%s\");\n" name;
587        | `ErrorIsNULL ->
588            pr "  if (r == NULL)\n";
589            pr "    ocaml_guestfs_raise_error (g, \"%s\");\n" name;
590       );
591       pr "\n";
592
593       (match ret with
594        | RErr -> pr "  rv = Val_unit;\n"
595        | RInt _ -> pr "  rv = Val_int (r);\n"
596        | RInt64 _ ->
597            pr "  rv = caml_copy_int64 (r);\n"
598        | RBool _ -> pr "  rv = Val_bool (r);\n"
599        | RConstString _ ->
600            pr "  rv = caml_copy_string (r);\n"
601        | RConstOptString _ ->
602            pr "  if (r) { /* Some string */\n";
603            pr "    v = caml_alloc (1, 0);\n";
604            pr "    v2 = caml_copy_string (r);\n";
605            pr "    Store_field (v, 0, v2);\n";
606            pr "  } else /* None */\n";
607            pr "    v = Val_int (0);\n";
608        | RString _ ->
609            pr "  rv = caml_copy_string (r);\n";
610            pr "  free (r);\n"
611        | RStringList _ ->
612            pr "  rv = caml_copy_string_array ((const char **) r);\n";
613            pr "  for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
614            pr "  free (r);\n"
615        | RStruct (_, typ) ->
616            pr "  rv = copy_%s (r);\n" typ;
617            pr "  guestfs_free_%s (r);\n" typ;
618        | RStructList (_, typ) ->
619            pr "  rv = copy_%s_list (r);\n" typ;
620            pr "  guestfs_free_%s_list (r);\n" typ;
621        | RHashtable _ ->
622            pr "  rv = copy_table (r);\n";
623            pr "  for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
624            pr "  free (r);\n";
625        | RBufferOut _ ->
626            pr "  rv = caml_alloc_string (size);\n";
627            pr "  memcpy (String_val (rv), r, size);\n";
628            pr "  free (r);\n"
629       );
630
631       pr "  CAMLreturn (rv);\n";
632       pr "}\n";
633       pr "\n";
634
635       if List.length params > 5 then (
636         pr "/* Emit prototype to appease gcc's -Wmissing-prototypes. */\n";
637         pr "CAMLprim value ";
638         pr "ocaml_guestfs_%s_byte (value *argv, int argn);\n" name;
639         pr "CAMLprim value\n";
640         pr "ocaml_guestfs_%s_byte (value *argv, int argn ATTRIBUTE_UNUSED)\n"
641           name;
642         pr "{\n";
643         pr "  return ocaml_guestfs_%s (argv[0]" name;
644         iteri (fun i _ -> pr ", argv[%d]" i) (List.tl params);
645         pr ");\n";
646         pr "}\n";
647         pr "\n"
648       )
649   ) all_functions_sorted
650
651 and generate_ocaml_structure_decls () =
652   List.iter (
653     fun (typ, cols) ->
654       pr "type %s = {\n" typ;
655       List.iter (
656         function
657         | name, FString -> pr "  %s : string;\n" name
658         | name, FBuffer -> pr "  %s : string;\n" name
659         | name, FUUID -> pr "  %s : string;\n" name
660         | name, (FBytes|FInt64|FUInt64) -> pr "  %s : int64;\n" name
661         | name, (FInt32|FUInt32) -> pr "  %s : int32;\n" name
662         | name, FChar -> pr "  %s : char;\n" name
663         | name, FOptPercent -> pr "  %s : float option;\n" name
664       ) cols;
665       pr "}\n";
666       pr "\n"
667   ) structs
668
669 and generate_ocaml_prototype ?(is_external = false) name style =
670   if is_external then pr "external " else pr "val ";
671   pr "%s : t -> " name;
672   generate_ocaml_function_type style;
673   if is_external then (
674     pr " = ";
675     let _, args, optargs = style in
676     if List.length args + List.length optargs + 1 > 5 then
677       pr "\"ocaml_guestfs_%s_byte\" " name;
678     pr "\"ocaml_guestfs_%s\"" name
679   );
680   pr "\n"
681
682 and generate_ocaml_function_type (ret, args, optargs) =
683   List.iter (
684     function
685     | Bool n -> pr "?%s:bool -> " n
686     | Int n -> pr "?%s:int -> " n
687     | Int64 n -> pr "?%s:int64 -> " n
688     | String n -> pr "?%s:string -> " n
689     | _ -> assert false
690   ) optargs;
691   List.iter (
692     function
693     | Pathname _ | Device _ | Dev_or_Path _ | String _ | FileIn _ | FileOut _
694     | BufferIn _ | Key _ -> pr "string -> "
695     | OptString _ -> pr "string option -> "
696     | StringList _ | DeviceList _ -> pr "string array -> "
697     | Bool _ -> pr "bool -> "
698     | Int _ -> pr "int -> "
699     | Int64 _ | Pointer _ -> pr "int64 -> "
700   ) args;
701   (match ret with
702    | RErr -> pr "unit" (* all errors are turned into exceptions *)
703    | RInt _ -> pr "int"
704    | RInt64 _ -> pr "int64"
705    | RBool _ -> pr "bool"
706    | RConstString _ -> pr "string"
707    | RConstOptString _ -> pr "string option"
708    | RString _ | RBufferOut _ -> pr "string"
709    | RStringList _ -> pr "string array"
710    | RStruct (_, typ) -> pr "%s" typ
711    | RStructList (_, typ) -> pr "%s array" typ
712    | RHashtable _ -> pr "(string * string) list"
713   )