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