generator/generator_ocaml.ml

   1 (* libguestfs
   2  * Copyright (C) 2009-2010 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
  32 (* Generate the OCaml bindings interface. *)
  33 let rec generate_ocaml_mli () =
  34   generate_header OCamlStyle LGPLv2plus;
  35
  36   pr "\
  37 (** For API documentation you should refer to the C API
  38     in the guestfs(3) manual page.  The OCaml API uses almost
  39     exactly the same calls. *)
  40
  41 type t
  42 (** A [guestfs_h] handle. *)
  43
  44 exception Error of string
  45 (** This exception is raised when there is an error. *)
  46
  47 exception Handle_closed of string
  48 (** This exception is raised if you use a {!Guestfs.t} handle
  49     after calling {!close} on it.  The string is the name of
  50     the function. *)
  51
  52 val create : unit -> t
  53 (** Create a {!Guestfs.t} handle. *)
  54
  55 val close : t -> unit
  56 (** Close the {!Guestfs.t} handle and free up all resources used
  57     by it immediately.
  58
  59     Handles are closed by the garbage collector when they become
  60     unreferenced, but callers can call this in order to provide
  61     predictable cleanup. *)
  62
  63 type progress_cb = int -> int -> int64 -> int64 -> unit
  64
  65 val set_progress_callback : t -> progress_cb -> unit
  66 (** [set_progress_callback g f] sets [f] as the progress callback function.
  67     For some long-running functions, [f] will be called repeatedly
  68     during the function with progress updates.
  69
  70     The callback is [f proc_nr serial position total].  See
  71     the description of [guestfs_set_progress_callback] in guestfs(3)
  72     for the meaning of these four numbers.
  73
  74     Note that if the closure captures a reference to the handle,
  75     this reference will prevent the handle from being
  76     automatically closed by the garbage collector.  There are
  77     three ways to avoid this: be careful not to capture the handle
  78     in the closure, or use a weak reference, or call
  79     {!Guestfs.clear_progress_callback} to remove the reference. *)
  80
  81 val clear_progress_callback : t -> unit
  82 (** [clear_progress_callback g] removes any progress callback function
  83     associated with the handle.  See {!Guestfs.set_progress_callback}. *)
  84
  85 ";
  86   generate_ocaml_structure_decls ();
  87
  88   (* The actions. *)
  89   List.iter (
  90     fun (name, style, _, _, _, shortdesc, _) ->
  91       generate_ocaml_prototype name style;
  92       pr "(** %s *)\n" shortdesc;
  93       pr "\n"
  94   ) all_functions_sorted;
  95
  96   pr "\
  97 (** {2 Object-oriented API}
  98
  99     This is an alternate way of calling the API using an object-oriented
 100     style, so you can use [g#add_drive filename] instead of
 101     [Guestfs.add_drive g filename].  Apart from the different style,
 102     it offers exactly the same functionality.
 103
 104     Note that methods that take no parameters (except the implicit handle)
 105     get an extra unit [()] parameter.  This is so you can create a
 106     closure from the method easily.  For example [g#get_verbose ()]
 107     calls the method, whereas [g#get_verbose] is a function. *)
 108
 109 class guestfs : object
 110   method close : unit -> unit
 111   method set_progress_callback : progress_cb -> unit
 112   method clear_progress_callback : unit -> unit
 113 ";
 114
 115   List.iter (
 116     function
 117     | name, ((_, []) as style), _, _, _, _, _ ->
 118         pr "  method %s : unit -> " name;
 119         generate_ocaml_function_type style;
 120         pr "\n"
 121     | name, style, _, _, _, _, _ ->
 122         pr "  method %s : " name;
 123         generate_ocaml_function_type style;
 124         pr "\n"
 125   ) all_functions_sorted;
 126
 127   pr "  end\n"
 128
 129 (* Generate the OCaml bindings implementation. *)
 130 and generate_ocaml_ml () =
 131   generate_header OCamlStyle LGPLv2plus;
 132
 133   pr "\
 134 type t
 135
 136 exception Error of string
 137 exception Handle_closed of string
 138
 139 external create : unit -> t = \"ocaml_guestfs_create\"
 140 external close : t -> unit = \"ocaml_guestfs_close\"
 141
 142 type progress_cb = int -> int -> int64 -> int64 -> unit
 143
 144 external set_progress_callback : t -> progress_cb -> unit
 145   = \"ocaml_guestfs_set_progress_callback\"
 146 external clear_progress_callback : t -> unit
 147   = \"ocaml_guestfs_clear_progress_callback\"
 148
 149 (* Give the exceptions names, so they can be raised from the C code. *)
 150 let () =
 151   Callback.register_exception \"ocaml_guestfs_error\" (Error \"\");
 152   Callback.register_exception \"ocaml_guestfs_closed\" (Handle_closed \"\")
 153
 154 ";
 155
 156   generate_ocaml_structure_decls ();
 157
 158   (* The actions. *)
 159   List.iter (
 160     fun (name, style, _, _, _, shortdesc, _) ->
 161       generate_ocaml_prototype ~is_external:true name style;
 162   ) all_functions_sorted;
 163
 164   (* OO API. *)
 165   pr "
 166 class guestfs =
 167   let g = create () in
 168   object
 169     method close () = close g
 170     method set_progress_callback = set_progress_callback g
 171     method clear_progress_callback () = clear_progress_callback g
 172 ";
 173
 174   List.iter (
 175     function
 176     | name, (_, []), _, _, _, _, _ ->   (* no params?  add explicit unit *)
 177         pr "    method %s () = %s g\n" name name
 178     | name, _, _, _, _, _, _ ->
 179         pr "    method %s = %s g\n" name name
 180   ) all_functions_sorted;
 181
 182   pr "  end\n"
 183
 184 (* Generate the OCaml bindings C implementation. *)
 185 and generate_ocaml_c () =
 186   generate_header CStyle LGPLv2plus;
 187
 188   pr "\
 189 #include <stdio.h>
 190 #include <stdlib.h>
 191 #include <string.h>
 192
 193 #include <caml/config.h>
 194 #include <caml/alloc.h>
 195 #include <caml/callback.h>
 196 #include <caml/fail.h>
 197 #include <caml/memory.h>
 198 #include <caml/mlvalues.h>
 199 #include <caml/signals.h>
 200
 201 #include \"guestfs.h\"
 202
 203 #include \"guestfs_c.h\"
 204
 205 /* Copy a hashtable of string pairs into an assoc-list.  We return
 206  * the list in reverse order, but hashtables aren't supposed to be
 207  * ordered anyway.
 208  */
 209 static CAMLprim value
 210 copy_table (char * const * argv)
 211 {
 212   CAMLparam0 ();
 213   CAMLlocal5 (rv, pairv, kv, vv, cons);
 214   size_t i;
 215
 216   rv = Val_int (0);
 217   for (i = 0; argv[i] != NULL; i += 2) {
 218     kv = caml_copy_string (argv[i]);
 219     vv = caml_copy_string (argv[i+1]);
 220     pairv = caml_alloc (2, 0);
 221     Store_field (pairv, 0, kv);
 222     Store_field (pairv, 1, vv);
 223     cons = caml_alloc (2, 0);
 224     Store_field (cons, 1, rv);
 225     rv = cons;
 226     Store_field (cons, 0, pairv);
 227   }
 228
 229   CAMLreturn (rv);
 230 }
 231
 232 ";
 233
 234   (* Struct copy functions. *)
 235
 236   let emit_ocaml_copy_list_function typ =
 237     pr "static CAMLprim value\n";
 238     pr "copy_%s_list (const struct guestfs_%s_list *%ss)\n" typ typ typ;
 239     pr "{\n";
 240     pr "  CAMLparam0 ();\n";
 241     pr "  CAMLlocal2 (rv, v);\n";
 242     pr "  unsigned int i;\n";
 243     pr "\n";
 244     pr "  if (%ss->len == 0)\n" typ;
 245     pr "    CAMLreturn (Atom (0));\n";
 246     pr "  else {\n";
 247     pr "    rv = caml_alloc (%ss->len, 0);\n" typ;
 248     pr "    for (i = 0; i < %ss->len; ++i) {\n" typ;
 249     pr "      v = copy_%s (&%ss->val[i]);\n" typ typ;
 250     pr "      caml_modify (&Field (rv, i), v);\n";
 251     pr "    }\n";
 252     pr "    CAMLreturn (rv);\n";
 253     pr "  }\n";
 254     pr "}\n";
 255     pr "\n";
 256   in
 257
 258   List.iter (
 259     fun (typ, cols) ->
 260       let has_optpercent_col =
 261         List.exists (function (_, FOptPercent) -> true | _ -> false) cols in
 262
 263       pr "static CAMLprim value\n";
 264       pr "copy_%s (const struct guestfs_%s *%s)\n" typ typ typ;
 265       pr "{\n";
 266       pr "  CAMLparam0 ();\n";
 267       if has_optpercent_col then
 268         pr "  CAMLlocal3 (rv, v, v2);\n"
 269       else
 270         pr "  CAMLlocal2 (rv, v);\n";
 271       pr "\n";
 272       pr "  rv = caml_alloc (%d, 0);\n" (List.length cols);
 273       iteri (
 274         fun i col ->
 275           (match col with
 276            | name, FString ->
 277                pr "  v = caml_copy_string (%s->%s);\n" typ name
 278            | name, FBuffer ->
 279                pr "  v = caml_alloc_string (%s->%s_len);\n" typ name;
 280                pr "  memcpy (String_val (v), %s->%s, %s->%s_len);\n"
 281                  typ name typ name
 282            | name, FUUID ->
 283                pr "  v = caml_alloc_string (32);\n";
 284                pr "  memcpy (String_val (v), %s->%s, 32);\n" typ name
 285            | name, (FBytes|FInt64|FUInt64) ->
 286                pr "  v = caml_copy_int64 (%s->%s);\n" typ name
 287            | name, (FInt32|FUInt32) ->
 288                pr "  v = caml_copy_int32 (%s->%s);\n" typ name
 289            | name, FOptPercent ->
 290                pr "  if (%s->%s >= 0) { /* Some %s */\n" typ name name;
 291                pr "    v2 = caml_copy_double (%s->%s);\n" typ name;
 292                pr "    v = caml_alloc (1, 0);\n";
 293                pr "    Store_field (v, 0, v2);\n";
 294                pr "  } else /* None */\n";
 295                pr "    v = Val_int (0);\n";
 296            | name, FChar ->
 297                pr "  v = Val_int (%s->%s);\n" typ name
 298           );
 299           pr "  Store_field (rv, %d, v);\n" i
 300       ) cols;
 301       pr "  CAMLreturn (rv);\n";
 302       pr "}\n";
 303       pr "\n";
 304   ) structs;
 305
 306   (* Emit a copy_TYPE_list function definition only if that function is used. *)
 307   List.iter (
 308     function
 309     | typ, (RStructListOnly | RStructAndList) ->
 310         (* generate the function for typ *)
 311         emit_ocaml_copy_list_function typ
 312     | typ, _ -> () (* empty *)
 313   ) (rstructs_used_by all_functions);
 314
 315   (* The wrappers. *)
 316   List.iter (
 317     fun (name, style, _, _, _, _, _) ->
 318       pr "/* Automatically generated wrapper for function\n";
 319       pr " * ";
 320       generate_ocaml_prototype name style;
 321       pr " */\n";
 322       pr "\n";
 323
 324       let params =
 325         "gv" :: List.map (fun arg -> name_of_argt arg ^ "v") (snd style) in
 326
 327       let needs_extra_vs =
 328         match fst style with RConstOptString _ -> true | _ -> false in
 329
 330       pr "/* Emit prototype to appease gcc's -Wmissing-prototypes. */\n";
 331       pr "CAMLprim value ocaml_guestfs_%s (value %s" name (List.hd params);
 332       List.iter (pr ", value %s") (List.tl params); pr ");\n";
 333       pr "\n";
 334
 335       pr "CAMLprim value\n";
 336       pr "ocaml_guestfs_%s (value %s" name (List.hd params);
 337       List.iter (pr ", value %s") (List.tl params);
 338       pr ")\n";
 339       pr "{\n";
 340
 341       (match params with
 342        | [p1; p2; p3; p4; p5] ->
 343            pr "  CAMLparam5 (%s);\n" (String.concat ", " params)
 344        | p1 :: p2 :: p3 :: p4 :: p5 :: rest ->
 345            pr "  CAMLparam5 (%s);\n" (String.concat ", " [p1; p2; p3; p4; p5]);
 346            pr "  CAMLxparam%d (%s);\n"
 347              (List.length rest) (String.concat ", " rest)
 348        | ps ->
 349            pr "  CAMLparam%d (%s);\n" (List.length ps) (String.concat ", " ps)
 350       );
 351       if not needs_extra_vs then
 352         pr "  CAMLlocal1 (rv);\n"
 353       else
 354         pr "  CAMLlocal3 (rv, v, v2);\n";
 355       pr "\n";
 356
 357       pr "  guestfs_h *g = Guestfs_val (gv);\n";
 358       pr "  if (g == NULL)\n";
 359       pr "    ocaml_guestfs_raise_closed (\"%s\");\n" name;
 360       pr "\n";
 361
 362       List.iter (
 363         function
 364         | Pathname n
 365         | Device n | Dev_or_Path n
 366         | String n
 367         | FileIn n
 368         | FileOut n
 369         | Key n ->
 370             (* Copy strings in case the GC moves them: RHBZ#604691 *)
 371             pr "  char *%s = guestfs_safe_strdup (g, String_val (%sv));\n" n n
 372         | OptString n ->
 373             pr "  char *%s =\n" n;
 374             pr "    %sv != Val_int (0) ?" n;
 375             pr "      guestfs_safe_strdup (g, String_val (Field (%sv, 0))) : NULL;\n" n
 376         | BufferIn n ->
 377             pr "  size_t %s_size = caml_string_length (%sv);\n" n n;
 378             pr "  char *%s = guestfs_safe_memdup (g, String_val (%sv), %s_size);\n" n n n
 379         | StringList n | DeviceList n ->
 380             pr "  char **%s = ocaml_guestfs_strings_val (g, %sv);\n" n n
 381         | Bool n ->
 382             pr "  int %s = Bool_val (%sv);\n" n n
 383         | Int n ->
 384             pr "  int %s = Int_val (%sv);\n" n n
 385         | Int64 n ->
 386             pr "  int64_t %s = Int64_val (%sv);\n" n n
 387       ) (snd style);
 388       let error_code =
 389         match fst style with
 390         | RErr -> pr "  int r;\n"; "-1"
 391         | RInt _ -> pr "  int r;\n"; "-1"
 392         | RInt64 _ -> pr "  int64_t r;\n"; "-1"
 393         | RBool _ -> pr "  int r;\n"; "-1"
 394         | RConstString _ | RConstOptString _ ->
 395             pr "  const char *r;\n"; "NULL"
 396         | RString _ -> pr "  char *r;\n"; "NULL"
 397         | RStringList _ ->
 398             pr "  size_t i;\n";
 399             pr "  char **r;\n";
 400             "NULL"
 401         | RStruct (_, typ) ->
 402             pr "  struct guestfs_%s *r;\n" typ; "NULL"
 403         | RStructList (_, typ) ->
 404             pr "  struct guestfs_%s_list *r;\n" typ; "NULL"
 405         | RHashtable _ ->
 406             pr "  size_t i;\n";
 407             pr "  char **r;\n";
 408             "NULL"
 409         | RBufferOut _ ->
 410             pr "  char *r;\n";
 411             pr "  size_t size;\n";
 412             "NULL" in
 413       pr "\n";
 414
 415       pr "  caml_enter_blocking_section ();\n";
 416       pr "  r = guestfs_%s " name;
 417       generate_c_call_args ~handle:"g" style;
 418       pr ";\n";
 419       pr "  caml_leave_blocking_section ();\n";
 420
 421       (* Free strings if we copied them above. *)
 422       List.iter (
 423         function
 424         | Pathname n | Device n | Dev_or_Path n | String n | OptString n
 425         | FileIn n | FileOut n | BufferIn n | Key n ->
 426             pr "  free (%s);\n" n
 427         | StringList n | DeviceList n ->
 428             pr "  ocaml_guestfs_free_strings (%s);\n" n;
 429         | Bool _ | Int _ | Int64 _ -> ()
 430       ) (snd style);
 431
 432       pr "  if (r == %s)\n" error_code;
 433       pr "    ocaml_guestfs_raise_error (g, \"%s\");\n" name;
 434       pr "\n";
 435
 436       (match fst style with
 437        | RErr -> pr "  rv = Val_unit;\n"
 438        | RInt _ -> pr "  rv = Val_int (r);\n"
 439        | RInt64 _ ->
 440            pr "  rv = caml_copy_int64 (r);\n"
 441        | RBool _ -> pr "  rv = Val_bool (r);\n"
 442        | RConstString _ ->
 443            pr "  rv = caml_copy_string (r);\n"
 444        | RConstOptString _ ->
 445            pr "  if (r) { /* Some string */\n";
 446            pr "    v = caml_alloc (1, 0);\n";
 447            pr "    v2 = caml_copy_string (r);\n";
 448            pr "    Store_field (v, 0, v2);\n";
 449            pr "  } else /* None */\n";
 450            pr "    v = Val_int (0);\n";
 451        | RString _ ->
 452            pr "  rv = caml_copy_string (r);\n";
 453            pr "  free (r);\n"
 454        | RStringList _ ->
 455            pr "  rv = caml_copy_string_array ((const char **) r);\n";
 456            pr "  for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
 457            pr "  free (r);\n"
 458        | RStruct (_, typ) ->
 459            pr "  rv = copy_%s (r);\n" typ;
 460            pr "  guestfs_free_%s (r);\n" typ;
 461        | RStructList (_, typ) ->
 462            pr "  rv = copy_%s_list (r);\n" typ;
 463            pr "  guestfs_free_%s_list (r);\n" typ;
 464        | RHashtable _ ->
 465            pr "  rv = copy_table (r);\n";
 466            pr "  for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
 467            pr "  free (r);\n";
 468        | RBufferOut _ ->
 469            pr "  rv = caml_alloc_string (size);\n";
 470            pr "  memcpy (String_val (rv), r, size);\n";
 471       );
 472
 473       pr "  CAMLreturn (rv);\n";
 474       pr "}\n";
 475       pr "\n";
 476
 477       if List.length params > 5 then (
 478         pr "/* Emit prototype to appease gcc's -Wmissing-prototypes. */\n";
 479         pr "CAMLprim value ";
 480         pr "ocaml_guestfs_%s_byte (value *argv, int argn);\n" name;
 481         pr "CAMLprim value\n";
 482         pr "ocaml_guestfs_%s_byte (value *argv, int argn)\n" name;
 483         pr "{\n";
 484         pr "  return ocaml_guestfs_%s (argv[0]" name;
 485         iteri (fun i _ -> pr ", argv[%d]" i) (List.tl params);
 486         pr ");\n";
 487         pr "}\n";
 488         pr "\n"
 489       )
 490   ) all_functions_sorted
 491
 492 and generate_ocaml_structure_decls () =
 493   List.iter (
 494     fun (typ, cols) ->
 495       pr "type %s = {\n" typ;
 496       List.iter (
 497         function
 498         | name, FString -> pr "  %s : string;\n" name
 499         | name, FBuffer -> pr "  %s : string;\n" name
 500         | name, FUUID -> pr "  %s : string;\n" name
 501         | name, (FBytes|FInt64|FUInt64) -> pr "  %s : int64;\n" name
 502         | name, (FInt32|FUInt32) -> pr "  %s : int32;\n" name
 503         | name, FChar -> pr "  %s : char;\n" name
 504         | name, FOptPercent -> pr "  %s : float option;\n" name
 505       ) cols;
 506       pr "}\n";
 507       pr "\n"
 508   ) structs
 509
 510 and generate_ocaml_prototype ?(is_external = false) name style =
 511   if is_external then pr "external " else pr "val ";
 512   pr "%s : t -> " name;
 513   generate_ocaml_function_type style;
 514   if is_external then (
 515     pr " = ";
 516     if List.length (snd style) + 1 > 5 then
 517       pr "\"ocaml_guestfs_%s_byte\" " name;
 518     pr "\"ocaml_guestfs_%s\"" name
 519   );
 520   pr "\n"
 521
 522 and generate_ocaml_function_type style =
 523   List.iter (
 524     function
 525     | Pathname _ | Device _ | Dev_or_Path _ | String _ | FileIn _ | FileOut _
 526     | BufferIn _ | Key _ -> pr "string -> "
 527     | OptString _ -> pr "string option -> "
 528     | StringList _ | DeviceList _ -> pr "string array -> "
 529     | Bool _ -> pr "bool -> "
 530     | Int _ -> pr "int -> "
 531     | Int64 _ -> pr "int64 -> "
 532   ) (snd style);
 533   (match fst style with
 534    | RErr -> pr "unit" (* all errors are turned into exceptions *)
 535    | RInt _ -> pr "int"
 536    | RInt64 _ -> pr "int64"
 537    | RBool _ -> pr "bool"
 538    | RConstString _ -> pr "string"
 539    | RConstOptString _ -> pr "string option"
 540    | RString _ | RBufferOut _ -> pr "string"
 541    | RStringList _ -> pr "string array"
 542    | RStruct (_, typ) -> pr "%s" typ
 543    | RStructList (_, typ) -> pr "%s array" typ
 544    | RHashtable _ -> pr "(string * string) list"
 545   )