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 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. *)
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
122 | name, ((_, []) as style), _, _, _, _, _ ->
123 pr " method %s : unit -> " name;
124 generate_ocaml_function_type style;
126 | name, style, _, _, _, _, _ ->
127 pr " method %s : " name;
128 generate_ocaml_function_type style;
130 ) all_functions_sorted;
134 (* Generate the OCaml bindings implementation. *)
135 and generate_ocaml_ml () =
136 generate_header OCamlStyle LGPLv2plus;
141 exception Error of string
142 exception Handle_closed of string
144 external create : unit -> t = \"ocaml_guestfs_create\"
145 external close : t -> unit = \"ocaml_guestfs_close\"
147 type progress_cb = int -> int -> int64 -> int64 -> unit
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\"
154 (* Give the exceptions names, so they can be raised from the C code. *)
156 Callback.register_exception \"ocaml_guestfs_error\" (Error \"\");
157 Callback.register_exception \"ocaml_guestfs_closed\" (Handle_closed \"\")
161 generate_ocaml_structure_decls ();
165 fun (name, style, _, _, _, shortdesc, _) ->
166 generate_ocaml_prototype ~is_external:true name style;
167 ) all_functions_sorted;
174 method close () = close g
175 method set_progress_callback = set_progress_callback g
176 method clear_progress_callback () = clear_progress_callback g
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;
189 (* Generate the OCaml bindings C implementation. *)
190 and generate_ocaml_c () =
191 generate_header CStyle LGPLv2plus;
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>
206 #include \"guestfs.h\"
208 #include \"guestfs_c.h\"
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
214 static CAMLprim value
215 copy_table (char * const * argv)
218 CAMLlocal5 (rv, pairv, kv, vv, cons);
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);
231 Store_field (cons, 0, pairv);
239 (* Struct copy functions. *)
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;
245 pr " CAMLparam0 ();\n";
246 pr " CAMLlocal2 (rv, v);\n";
247 pr " unsigned int i;\n";
249 pr " if (%ss->len == 0)\n" typ;
250 pr " CAMLreturn (Atom (0));\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";
257 pr " CAMLreturn (rv);\n";
265 let has_optpercent_col =
266 List.exists (function (_, FOptPercent) -> true | _ -> false) cols in
268 pr "static CAMLprim value\n";
269 pr "copy_%s (const struct guestfs_%s *%s)\n" typ typ typ;
271 pr " CAMLparam0 ();\n";
272 if has_optpercent_col then
273 pr " CAMLlocal3 (rv, v, v2);\n"
275 pr " CAMLlocal2 (rv, v);\n";
277 pr " rv = caml_alloc (%d, 0);\n" (List.length cols);
282 pr " v = caml_copy_string (%s->%s);\n" typ name
284 pr " v = caml_alloc_string (%s->%s_len);\n" typ name;
285 pr " memcpy (String_val (v), %s->%s, %s->%s_len);\n"
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";
302 pr " v = Val_int (%s->%s);\n" typ name
304 pr " Store_field (rv, %d, v);\n" i
306 pr " CAMLreturn (rv);\n";
311 (* Emit a copy_TYPE_list function definition only if that function is used. *)
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);
322 fun (name, style, _, _, _, _, _) ->
323 pr "/* Automatically generated wrapper for function\n";
325 generate_ocaml_prototype name style;
330 "gv" :: List.map (fun arg -> name_of_argt arg ^ "v") (snd style) in
333 match fst style with RConstOptString _ -> true | _ -> false in
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";
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);
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)
354 pr " CAMLparam%d (%s);\n" (List.length ps) (String.concat ", " ps)
356 if not needs_extra_vs then
357 pr " CAMLlocal1 (rv);\n"
359 pr " CAMLlocal3 (rv, v, v2);\n";
362 pr " guestfs_h *g = Guestfs_val (gv);\n";
363 pr " if (g == NULL)\n";
364 pr " ocaml_guestfs_raise_closed (\"%s\");\n" name;
370 | Device n | Dev_or_Path 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
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
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
387 pr " int %s = Bool_val (%sv);\n" n n
389 pr " int %s = Int_val (%sv);\n" n n
391 pr " int64_t %s = Int64_val (%sv);\n" n n
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"
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"
416 pr " size_t size;\n";
420 pr " caml_enter_blocking_section ();\n";
421 pr " r = guestfs_%s " name;
422 generate_c_call_args ~handle:"g" style;
424 pr " caml_leave_blocking_section ();\n";
426 (* Free strings if we copied them above. *)
429 | Pathname n | Device n | Dev_or_Path n | String n | OptString n
430 | FileIn n | FileOut n | BufferIn n | Key n ->
432 | StringList n | DeviceList n ->
433 pr " ocaml_guestfs_free_strings (%s);\n" n;
434 | Bool _ | Int _ | Int64 _ -> ()
437 pr " if (r == %s)\n" error_code;
438 pr " ocaml_guestfs_raise_error (g, \"%s\");\n" name;
441 (match fst style with
442 | RErr -> pr " rv = Val_unit;\n"
443 | RInt _ -> pr " rv = Val_int (r);\n"
445 pr " rv = caml_copy_int64 (r);\n"
446 | RBool _ -> pr " rv = Val_bool (r);\n"
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";
457 pr " rv = caml_copy_string (r);\n";
460 pr " rv = caml_copy_string_array ((const char **) r);\n";
461 pr " for (i = 0; r[i] != NULL; ++i) free (r[i]);\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;
470 pr " rv = copy_table (r);\n";
471 pr " for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
474 pr " rv = caml_alloc_string (size);\n";
475 pr " memcpy (String_val (rv), r, size);\n";
478 pr " CAMLreturn (rv);\n";
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;
489 pr " return ocaml_guestfs_%s (argv[0]" name;
490 iteri (fun i _ -> pr ", argv[%d]" i) (List.tl params);
495 ) all_functions_sorted
497 and generate_ocaml_structure_decls () =
500 pr "type %s = {\n" typ;
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
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 (
521 if List.length (snd style) + 1 > 5 then
522 pr "\"ocaml_guestfs_%s_byte\" " name;
523 pr "\"ocaml_guestfs_%s\"" name
527 and generate_ocaml_function_type style =
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 -> "
538 (match fst style with
539 | RErr -> pr "unit" (* all errors are turned into exceptions *)
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"