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