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 (* Generate the OCaml bindings implementation. *)
  97 and generate_ocaml_ml () =
  98   generate_header OCamlStyle LGPLv2plus;
  99
 100   pr "\
 101 type t
 102
 103 exception Error of string
 104 exception Handle_closed of string
 105
 106 external create : unit -> t = \"ocaml_guestfs_create\"
 107 external close : t -> unit = \"ocaml_guestfs_close\"
 108
 109 type progress_cb = int -> int -> int64 -> int64 -> unit
 110
 111 external set_progress_callback : t -> progress_cb -> unit
 112   = \"ocaml_guestfs_set_progress_callback\"
 113 external clear_progress_callback : t -> unit
 114   = \"ocaml_guestfs_clear_progress_callback\"
 115
 116 (* Give the exceptions names, so they can be raised from the C code. *)
 117 let () =
 118   Callback.register_exception \"ocaml_guestfs_error\" (Error \"\");
 119   Callback.register_exception \"ocaml_guestfs_closed\" (Handle_closed \"\")
 120
 121 ";
 122
 123   generate_ocaml_structure_decls ();
 124
 125   (* The actions. *)
 126   List.iter (
 127     fun (name, style, _, _, _, shortdesc, _) ->
 128       generate_ocaml_prototype ~is_external:true name style;
 129   ) all_functions_sorted
 130
 131 (* Generate the OCaml bindings C implementation. *)
 132 and generate_ocaml_c () =
 133   generate_header CStyle LGPLv2plus;
 134
 135   pr "\
 136 #include <stdio.h>
 137 #include <stdlib.h>
 138 #include <string.h>
 139
 140 #include <caml/config.h>
 141 #include <caml/alloc.h>
 142 #include <caml/callback.h>
 143 #include <caml/fail.h>
 144 #include <caml/memory.h>
 145 #include <caml/mlvalues.h>
 146 #include <caml/signals.h>
 147
 148 #include \"guestfs.h\"
 149
 150 #include \"guestfs_c.h\"
 151
 152 /* Copy a hashtable of string pairs into an assoc-list.  We return
 153  * the list in reverse order, but hashtables aren't supposed to be
 154  * ordered anyway.
 155  */
 156 static CAMLprim value
 157 copy_table (char * const * argv)
 158 {
 159   CAMLparam0 ();
 160   CAMLlocal5 (rv, pairv, kv, vv, cons);
 161   size_t i;
 162
 163   rv = Val_int (0);
 164   for (i = 0; argv[i] != NULL; i += 2) {
 165     kv = caml_copy_string (argv[i]);
 166     vv = caml_copy_string (argv[i+1]);
 167     pairv = caml_alloc (2, 0);
 168     Store_field (pairv, 0, kv);
 169     Store_field (pairv, 1, vv);
 170     cons = caml_alloc (2, 0);
 171     Store_field (cons, 1, rv);
 172     rv = cons;
 173     Store_field (cons, 0, pairv);
 174   }
 175
 176   CAMLreturn (rv);
 177 }
 178
 179 ";
 180
 181   (* Struct copy functions. *)
 182
 183   let emit_ocaml_copy_list_function typ =
 184     pr "static CAMLprim value\n";
 185     pr "copy_%s_list (const struct guestfs_%s_list *%ss)\n" typ typ typ;
 186     pr "{\n";
 187     pr "  CAMLparam0 ();\n";
 188     pr "  CAMLlocal2 (rv, v);\n";
 189     pr "  unsigned int i;\n";
 190     pr "\n";
 191     pr "  if (%ss->len == 0)\n" typ;
 192     pr "    CAMLreturn (Atom (0));\n";
 193     pr "  else {\n";
 194     pr "    rv = caml_alloc (%ss->len, 0);\n" typ;
 195     pr "    for (i = 0; i < %ss->len; ++i) {\n" typ;
 196     pr "      v = copy_%s (&%ss->val[i]);\n" typ typ;
 197     pr "      caml_modify (&Field (rv, i), v);\n";
 198     pr "    }\n";
 199     pr "    CAMLreturn (rv);\n";
 200     pr "  }\n";
 201     pr "}\n";
 202     pr "\n";
 203   in
 204
 205   List.iter (
 206     fun (typ, cols) ->
 207       let has_optpercent_col =
 208         List.exists (function (_, FOptPercent) -> true | _ -> false) cols in
 209
 210       pr "static CAMLprim value\n";
 211       pr "copy_%s (const struct guestfs_%s *%s)\n" typ typ typ;
 212       pr "{\n";
 213       pr "  CAMLparam0 ();\n";
 214       if has_optpercent_col then
 215         pr "  CAMLlocal3 (rv, v, v2);\n"
 216       else
 217         pr "  CAMLlocal2 (rv, v);\n";
 218       pr "\n";
 219       pr "  rv = caml_alloc (%d, 0);\n" (List.length cols);
 220       iteri (
 221         fun i col ->
 222           (match col with
 223            | name, FString ->
 224                pr "  v = caml_copy_string (%s->%s);\n" typ name
 225            | name, FBuffer ->
 226                pr "  v = caml_alloc_string (%s->%s_len);\n" typ name;
 227                pr "  memcpy (String_val (v), %s->%s, %s->%s_len);\n"
 228                  typ name typ name
 229            | name, FUUID ->
 230                pr "  v = caml_alloc_string (32);\n";
 231                pr "  memcpy (String_val (v), %s->%s, 32);\n" typ name
 232            | name, (FBytes|FInt64|FUInt64) ->
 233                pr "  v = caml_copy_int64 (%s->%s);\n" typ name
 234            | name, (FInt32|FUInt32) ->
 235                pr "  v = caml_copy_int32 (%s->%s);\n" typ name
 236            | name, FOptPercent ->
 237                pr "  if (%s->%s >= 0) { /* Some %s */\n" typ name name;
 238                pr "    v2 = caml_copy_double (%s->%s);\n" typ name;
 239                pr "    v = caml_alloc (1, 0);\n";
 240                pr "    Store_field (v, 0, v2);\n";
 241                pr "  } else /* None */\n";
 242                pr "    v = Val_int (0);\n";
 243            | name, FChar ->
 244                pr "  v = Val_int (%s->%s);\n" typ name
 245           );
 246           pr "  Store_field (rv, %d, v);\n" i
 247       ) cols;
 248       pr "  CAMLreturn (rv);\n";
 249       pr "}\n";
 250       pr "\n";
 251   ) structs;
 252
 253   (* Emit a copy_TYPE_list function definition only if that function is used. *)
 254   List.iter (
 255     function
 256     | typ, (RStructListOnly | RStructAndList) ->
 257         (* generate the function for typ *)
 258         emit_ocaml_copy_list_function typ
 259     | typ, _ -> () (* empty *)
 260   ) (rstructs_used_by all_functions);
 261
 262   (* The wrappers. *)
 263   List.iter (
 264     fun (name, style, _, _, _, _, _) ->
 265       pr "/* Automatically generated wrapper for function\n";
 266       pr " * ";
 267       generate_ocaml_prototype name style;
 268       pr " */\n";
 269       pr "\n";
 270
 271       let params =
 272         "gv" :: List.map (fun arg -> name_of_argt arg ^ "v") (snd style) in
 273
 274       let needs_extra_vs =
 275         match fst style with RConstOptString _ -> true | _ -> false in
 276
 277       pr "/* Emit prototype to appease gcc's -Wmissing-prototypes. */\n";
 278       pr "CAMLprim value ocaml_guestfs_%s (value %s" name (List.hd params);
 279       List.iter (pr ", value %s") (List.tl params); pr ");\n";
 280       pr "\n";
 281
 282       pr "CAMLprim value\n";
 283       pr "ocaml_guestfs_%s (value %s" name (List.hd params);
 284       List.iter (pr ", value %s") (List.tl params);
 285       pr ")\n";
 286       pr "{\n";
 287
 288       (match params with
 289        | [p1; p2; p3; p4; p5] ->
 290            pr "  CAMLparam5 (%s);\n" (String.concat ", " params)
 291        | p1 :: p2 :: p3 :: p4 :: p5 :: rest ->
 292            pr "  CAMLparam5 (%s);\n" (String.concat ", " [p1; p2; p3; p4; p5]);
 293            pr "  CAMLxparam%d (%s);\n"
 294              (List.length rest) (String.concat ", " rest)
 295        | ps ->
 296            pr "  CAMLparam%d (%s);\n" (List.length ps) (String.concat ", " ps)
 297       );
 298       if not needs_extra_vs then
 299         pr "  CAMLlocal1 (rv);\n"
 300       else
 301         pr "  CAMLlocal3 (rv, v, v2);\n";
 302       pr "\n";
 303
 304       pr "  guestfs_h *g = Guestfs_val (gv);\n";
 305       pr "  if (g == NULL)\n";
 306       pr "    ocaml_guestfs_raise_closed (\"%s\");\n" name;
 307       pr "\n";
 308
 309       List.iter (
 310         function
 311         | Pathname n
 312         | Device n | Dev_or_Path n
 313         | String n
 314         | FileIn n
 315         | FileOut n
 316         | Key n ->
 317             (* Copy strings in case the GC moves them: RHBZ#604691 *)
 318             pr "  char *%s = guestfs_safe_strdup (g, String_val (%sv));\n" n n
 319         | OptString n ->
 320             pr "  char *%s =\n" n;
 321             pr "    %sv != Val_int (0) ?" n;
 322             pr "      guestfs_safe_strdup (g, String_val (Field (%sv, 0))) : NULL;\n" n
 323         | BufferIn n ->
 324             pr "  size_t %s_size = caml_string_length (%sv);\n" n n;
 325             pr "  char *%s = guestfs_safe_memdup (g, String_val (%sv), %s_size);\n" n n n
 326         | StringList n | DeviceList n ->
 327             pr "  char **%s = ocaml_guestfs_strings_val (g, %sv);\n" n n
 328         | Bool n ->
 329             pr "  int %s = Bool_val (%sv);\n" n n
 330         | Int n ->
 331             pr "  int %s = Int_val (%sv);\n" n n
 332         | Int64 n ->
 333             pr "  int64_t %s = Int64_val (%sv);\n" n n
 334       ) (snd style);
 335       let error_code =
 336         match fst style with
 337         | RErr -> pr "  int r;\n"; "-1"
 338         | RInt _ -> pr "  int r;\n"; "-1"
 339         | RInt64 _ -> pr "  int64_t r;\n"; "-1"
 340         | RBool _ -> pr "  int r;\n"; "-1"
 341         | RConstString _ | RConstOptString _ ->
 342             pr "  const char *r;\n"; "NULL"
 343         | RString _ -> pr "  char *r;\n"; "NULL"
 344         | RStringList _ ->
 345             pr "  size_t i;\n";
 346             pr "  char **r;\n";
 347             "NULL"
 348         | RStruct (_, typ) ->
 349             pr "  struct guestfs_%s *r;\n" typ; "NULL"
 350         | RStructList (_, typ) ->
 351             pr "  struct guestfs_%s_list *r;\n" typ; "NULL"
 352         | RHashtable _ ->
 353             pr "  size_t i;\n";
 354             pr "  char **r;\n";
 355             "NULL"
 356         | RBufferOut _ ->
 357             pr "  char *r;\n";
 358             pr "  size_t size;\n";
 359             "NULL" in
 360       pr "\n";
 361
 362       pr "  caml_enter_blocking_section ();\n";
 363       pr "  r = guestfs_%s " name;
 364       generate_c_call_args ~handle:"g" style;
 365       pr ";\n";
 366       pr "  caml_leave_blocking_section ();\n";
 367
 368       (* Free strings if we copied them above. *)
 369       List.iter (
 370         function
 371         | Pathname n | Device n | Dev_or_Path n | String n | OptString n
 372         | FileIn n | FileOut n | BufferIn n | Key n ->
 373             pr "  free (%s);\n" n
 374         | StringList n | DeviceList n ->
 375             pr "  ocaml_guestfs_free_strings (%s);\n" n;
 376         | Bool _ | Int _ | Int64 _ -> ()
 377       ) (snd style);
 378
 379       pr "  if (r == %s)\n" error_code;
 380       pr "    ocaml_guestfs_raise_error (g, \"%s\");\n" name;
 381       pr "\n";
 382
 383       (match fst style with
 384        | RErr -> pr "  rv = Val_unit;\n"
 385        | RInt _ -> pr "  rv = Val_int (r);\n"
 386        | RInt64 _ ->
 387            pr "  rv = caml_copy_int64 (r);\n"
 388        | RBool _ -> pr "  rv = Val_bool (r);\n"
 389        | RConstString _ ->
 390            pr "  rv = caml_copy_string (r);\n"
 391        | RConstOptString _ ->
 392            pr "  if (r) { /* Some string */\n";
 393            pr "    v = caml_alloc (1, 0);\n";
 394            pr "    v2 = caml_copy_string (r);\n";
 395            pr "    Store_field (v, 0, v2);\n";
 396            pr "  } else /* None */\n";
 397            pr "    v = Val_int (0);\n";
 398        | RString _ ->
 399            pr "  rv = caml_copy_string (r);\n";
 400            pr "  free (r);\n"
 401        | RStringList _ ->
 402            pr "  rv = caml_copy_string_array ((const char **) r);\n";
 403            pr "  for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
 404            pr "  free (r);\n"
 405        | RStruct (_, typ) ->
 406            pr "  rv = copy_%s (r);\n" typ;
 407            pr "  guestfs_free_%s (r);\n" typ;
 408        | RStructList (_, typ) ->
 409            pr "  rv = copy_%s_list (r);\n" typ;
 410            pr "  guestfs_free_%s_list (r);\n" typ;
 411        | RHashtable _ ->
 412            pr "  rv = copy_table (r);\n";
 413            pr "  for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
 414            pr "  free (r);\n";
 415        | RBufferOut _ ->
 416            pr "  rv = caml_alloc_string (size);\n";
 417            pr "  memcpy (String_val (rv), r, size);\n";
 418       );
 419
 420       pr "  CAMLreturn (rv);\n";
 421       pr "}\n";
 422       pr "\n";
 423
 424       if List.length params > 5 then (
 425         pr "/* Emit prototype to appease gcc's -Wmissing-prototypes. */\n";
 426         pr "CAMLprim value ";
 427         pr "ocaml_guestfs_%s_byte (value *argv, int argn);\n" name;
 428         pr "CAMLprim value\n";
 429         pr "ocaml_guestfs_%s_byte (value *argv, int argn)\n" name;
 430         pr "{\n";
 431         pr "  return ocaml_guestfs_%s (argv[0]" name;
 432         iteri (fun i _ -> pr ", argv[%d]" i) (List.tl params);
 433         pr ");\n";
 434         pr "}\n";
 435         pr "\n"
 436       )
 437   ) all_functions_sorted
 438
 439 and generate_ocaml_structure_decls () =
 440   List.iter (
 441     fun (typ, cols) ->
 442       pr "type %s = {\n" typ;
 443       List.iter (
 444         function
 445         | name, FString -> pr "  %s : string;\n" name
 446         | name, FBuffer -> pr "  %s : string;\n" name
 447         | name, FUUID -> pr "  %s : string;\n" name
 448         | name, (FBytes|FInt64|FUInt64) -> pr "  %s : int64;\n" name
 449         | name, (FInt32|FUInt32) -> pr "  %s : int32;\n" name
 450         | name, FChar -> pr "  %s : char;\n" name
 451         | name, FOptPercent -> pr "  %s : float option;\n" name
 452       ) cols;
 453       pr "}\n";
 454       pr "\n"
 455   ) structs
 456
 457 and generate_ocaml_prototype ?(is_external = false) name style =
 458   if is_external then pr "external " else pr "val ";
 459   pr "%s : t -> " name;
 460   List.iter (
 461     function
 462     | Pathname _ | Device _ | Dev_or_Path _ | String _ | FileIn _ | FileOut _
 463     | BufferIn _ | Key _ -> pr "string -> "
 464     | OptString _ -> pr "string option -> "
 465     | StringList _ | DeviceList _ -> pr "string array -> "
 466     | Bool _ -> pr "bool -> "
 467     | Int _ -> pr "int -> "
 468     | Int64 _ -> pr "int64 -> "
 469   ) (snd style);
 470   (match fst style with
 471    | RErr -> pr "unit" (* all errors are turned into exceptions *)
 472    | RInt _ -> pr "int"
 473    | RInt64 _ -> pr "int64"
 474    | RBool _ -> pr "bool"
 475    | RConstString _ -> pr "string"
 476    | RConstOptString _ -> pr "string option"
 477    | RString _ | RBufferOut _ -> pr "string"
 478    | RStringList _ -> pr "string array"
 479    | RStruct (_, typ) -> pr "%s" typ
 480    | RStructList (_, typ) -> pr "%s array" typ
 481    | RHashtable _ -> pr "(string * string) list"
 482   );
 483   if is_external then (
 484     pr " = ";
 485     if List.length (snd style) + 1 > 5 then
 486       pr "\"ocaml_guestfs_%s_byte\" " name;
 487     pr "\"ocaml_guestfs_%s\"" name
 488   );
 489   pr "\n"