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