2 * Copyright (C) 2009-2010 Red Hat Inc.
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.
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.
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
19 (* Please read generator/README first. *)
26 open Generator_docstrings
27 open Generator_optgroups
28 open Generator_actions
29 open Generator_structs
32 (* Generate the OCaml bindings interface. *)
33 let rec generate_ocaml_mli () =
34 generate_header OCamlStyle LGPLv2plus;
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. *)
42 (** A [guestfs_h] handle. *)
44 exception Error of string
45 (** This exception is raised when there is an error. *)
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
52 val create : unit -> t
53 (** Create a {!Guestfs.t} handle. *)
56 (** Close the {!Guestfs.t} handle and free up all resources used
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. *)
63 type progress_cb = int -> int -> int64 -> int64 -> unit
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.
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.
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. *)
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}. *)
86 generate_ocaml_structure_decls ();
90 fun (name, style, _, _, _, shortdesc, _) ->
91 generate_ocaml_prototype name style;
92 pr "(** %s *)\n" shortdesc;
94 ) all_functions_sorted;
97 (** {2 Object-oriented API}
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.
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 ()]
109 You can get the {!Guestfs.t} handle by calling [g#ocaml_handle].
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. *)
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
125 | name, ((_, []) as style), _, _, _, _, _ ->
126 pr " method %s : unit -> " name;
127 generate_ocaml_function_type style;
129 | name, style, _, _, _, _, _ ->
130 pr " method %s : " name;
131 generate_ocaml_function_type style;
133 ) all_functions_sorted;
137 (* Generate the OCaml bindings implementation. *)
138 and generate_ocaml_ml () =
139 generate_header OCamlStyle LGPLv2plus;
144 exception Error of string
145 exception Handle_closed of string
147 external create : unit -> t = \"ocaml_guestfs_create\"
148 external close : t -> unit = \"ocaml_guestfs_close\"
150 type progress_cb = int -> int -> int64 -> int64 -> unit
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\"
157 (* Give the exceptions names, so they can be raised from the C code. *)
159 Callback.register_exception \"ocaml_guestfs_error\" (Error \"\");
160 Callback.register_exception \"ocaml_guestfs_closed\" (Handle_closed \"\")
164 generate_ocaml_structure_decls ();
168 fun (name, style, _, _, _, shortdesc, _) ->
169 generate_ocaml_prototype ~is_external:true name style;
170 ) all_functions_sorted;
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
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;
193 (* Generate the OCaml bindings C implementation. *)
194 and generate_ocaml_c () =
195 generate_header CStyle LGPLv2plus;
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>
210 #include \"guestfs.h\"
212 #include \"guestfs_c.h\"
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
218 static CAMLprim value
219 copy_table (char * const * argv)
222 CAMLlocal5 (rv, pairv, kv, vv, cons);
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);
235 Store_field (cons, 0, pairv);
243 (* Struct copy functions. *)
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;
249 pr " CAMLparam0 ();\n";
250 pr " CAMLlocal2 (rv, v);\n";
251 pr " unsigned int i;\n";
253 pr " if (%ss->len == 0)\n" typ;
254 pr " CAMLreturn (Atom (0));\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";
261 pr " CAMLreturn (rv);\n";
269 let has_optpercent_col =
270 List.exists (function (_, FOptPercent) -> true | _ -> false) cols in
272 pr "static CAMLprim value\n";
273 pr "copy_%s (const struct guestfs_%s *%s)\n" typ typ typ;
275 pr " CAMLparam0 ();\n";
276 if has_optpercent_col then
277 pr " CAMLlocal3 (rv, v, v2);\n"
279 pr " CAMLlocal2 (rv, v);\n";
281 pr " rv = caml_alloc (%d, 0);\n" (List.length cols);
286 pr " v = caml_copy_string (%s->%s);\n" typ name
288 pr " v = caml_alloc_string (%s->%s_len);\n" typ name;
289 pr " memcpy (String_val (v), %s->%s, %s->%s_len);\n"
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";
306 pr " v = Val_int (%s->%s);\n" typ name
308 pr " Store_field (rv, %d, v);\n" i
310 pr " CAMLreturn (rv);\n";
315 (* Emit a copy_TYPE_list function definition only if that function is used. *)
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);
326 fun (name, style, _, _, _, _, _) ->
327 pr "/* Automatically generated wrapper for function\n";
329 generate_ocaml_prototype name style;
334 "gv" :: List.map (fun arg -> name_of_argt arg ^ "v") (snd style) in
337 match fst style with RConstOptString _ -> true | _ -> false in
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";
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);
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)
358 pr " CAMLparam%d (%s);\n" (List.length ps) (String.concat ", " ps)
360 if not needs_extra_vs then
361 pr " CAMLlocal1 (rv);\n"
363 pr " CAMLlocal3 (rv, v, v2);\n";
366 pr " guestfs_h *g = Guestfs_val (gv);\n";
367 pr " if (g == NULL)\n";
368 pr " ocaml_guestfs_raise_closed (\"%s\");\n" name;
374 | Device n | Dev_or_Path 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
382 pr " char *%s =\n" n;
383 pr " %sv != Val_int (0) ?\n" n;
384 pr " guestfs_safe_strdup (g, String_val (Field (%sv, 0))) : NULL;\n" 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
391 pr " int %s = Bool_val (%sv);\n" n n
393 pr " int %s = Int_val (%sv);\n" n n
395 pr " int64_t %s = Int64_val (%sv);\n" n n
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"
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"
420 pr " size_t size;\n";
424 pr " caml_enter_blocking_section ();\n";
425 pr " r = guestfs_%s " name;
426 generate_c_call_args ~handle:"g" style;
428 pr " caml_leave_blocking_section ();\n";
430 (* Free strings if we copied them above. *)
433 | Pathname n | Device n | Dev_or_Path n | String n | OptString n
434 | FileIn n | FileOut n | BufferIn n | Key n ->
436 | StringList n | DeviceList n ->
437 pr " ocaml_guestfs_free_strings (%s);\n" n;
438 | Bool _ | Int _ | Int64 _ -> ()
441 pr " if (r == %s)\n" error_code;
442 pr " ocaml_guestfs_raise_error (g, \"%s\");\n" name;
445 (match fst style with
446 | RErr -> pr " rv = Val_unit;\n"
447 | RInt _ -> pr " rv = Val_int (r);\n"
449 pr " rv = caml_copy_int64 (r);\n"
450 | RBool _ -> pr " rv = Val_bool (r);\n"
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";
461 pr " rv = caml_copy_string (r);\n";
464 pr " rv = caml_copy_string_array ((const char **) r);\n";
465 pr " for (i = 0; r[i] != NULL; ++i) free (r[i]);\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;
474 pr " rv = copy_table (r);\n";
475 pr " for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
478 pr " rv = caml_alloc_string (size);\n";
479 pr " memcpy (String_val (rv), r, size);\n";
482 pr " CAMLreturn (rv);\n";
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;
493 pr " return ocaml_guestfs_%s (argv[0]" name;
494 iteri (fun i _ -> pr ", argv[%d]" i) (List.tl params);
499 ) all_functions_sorted
501 and generate_ocaml_structure_decls () =
504 pr "type %s = {\n" typ;
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
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 (
525 if List.length (snd style) + 1 > 5 then
526 pr "\"ocaml_guestfs_%s_byte\" " name;
527 pr "\"ocaml_guestfs_%s\"" name
531 and generate_ocaml_function_type style =
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 -> "
542 (match fst style with
543 | RErr -> pr "unit" (* all errors are turned into exceptions *)
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"