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