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 Note that methods that take no parameters (except the implicit handle)
105 get an extra unit [()] parameter. This is so you can create a
106 closure from the method easily. For example [g#get_verbose ()]
107 calls the method, whereas [g#get_verbose] is a function. *)
109 class guestfs : object
110 method close : unit -> unit
111 method set_progress_callback : progress_cb -> unit
112 method clear_progress_callback : unit -> unit
117 | name, ((_, []) as style), _, _, _, _, _ ->
118 pr " method %s : unit -> " name;
119 generate_ocaml_function_type style;
121 | name, style, _, _, _, _, _ ->
122 pr " method %s : " name;
123 generate_ocaml_function_type style;
125 ) all_functions_sorted;
129 (* Generate the OCaml bindings implementation. *)
130 and generate_ocaml_ml () =
131 generate_header OCamlStyle LGPLv2plus;
136 exception Error of string
137 exception Handle_closed of string
139 external create : unit -> t = \"ocaml_guestfs_create\"
140 external close : t -> unit = \"ocaml_guestfs_close\"
142 type progress_cb = int -> int -> int64 -> int64 -> unit
144 external set_progress_callback : t -> progress_cb -> unit
145 = \"ocaml_guestfs_set_progress_callback\"
146 external clear_progress_callback : t -> unit
147 = \"ocaml_guestfs_clear_progress_callback\"
149 (* Give the exceptions names, so they can be raised from the C code. *)
151 Callback.register_exception \"ocaml_guestfs_error\" (Error \"\");
152 Callback.register_exception \"ocaml_guestfs_closed\" (Handle_closed \"\")
156 generate_ocaml_structure_decls ();
160 fun (name, style, _, _, _, shortdesc, _) ->
161 generate_ocaml_prototype ~is_external:true name style;
162 ) all_functions_sorted;
169 method close () = close g
170 method set_progress_callback = set_progress_callback g
171 method clear_progress_callback () = clear_progress_callback g
176 | name, (_, []), _, _, _, _, _ -> (* no params? add explicit unit *)
177 pr " method %s () = %s g\n" name name
178 | name, _, _, _, _, _, _ ->
179 pr " method %s = %s g\n" name name
180 ) all_functions_sorted;
184 (* Generate the OCaml bindings C implementation. *)
185 and generate_ocaml_c () =
186 generate_header CStyle LGPLv2plus;
193 #include <caml/config.h>
194 #include <caml/alloc.h>
195 #include <caml/callback.h>
196 #include <caml/fail.h>
197 #include <caml/memory.h>
198 #include <caml/mlvalues.h>
199 #include <caml/signals.h>
201 #include \"guestfs.h\"
203 #include \"guestfs_c.h\"
205 /* Copy a hashtable of string pairs into an assoc-list. We return
206 * the list in reverse order, but hashtables aren't supposed to be
209 static CAMLprim value
210 copy_table (char * const * argv)
213 CAMLlocal5 (rv, pairv, kv, vv, cons);
217 for (i = 0; argv[i] != NULL; i += 2) {
218 kv = caml_copy_string (argv[i]);
219 vv = caml_copy_string (argv[i+1]);
220 pairv = caml_alloc (2, 0);
221 Store_field (pairv, 0, kv);
222 Store_field (pairv, 1, vv);
223 cons = caml_alloc (2, 0);
224 Store_field (cons, 1, rv);
226 Store_field (cons, 0, pairv);
234 (* Struct copy functions. *)
236 let emit_ocaml_copy_list_function typ =
237 pr "static CAMLprim value\n";
238 pr "copy_%s_list (const struct guestfs_%s_list *%ss)\n" typ typ typ;
240 pr " CAMLparam0 ();\n";
241 pr " CAMLlocal2 (rv, v);\n";
242 pr " unsigned int i;\n";
244 pr " if (%ss->len == 0)\n" typ;
245 pr " CAMLreturn (Atom (0));\n";
247 pr " rv = caml_alloc (%ss->len, 0);\n" typ;
248 pr " for (i = 0; i < %ss->len; ++i) {\n" typ;
249 pr " v = copy_%s (&%ss->val[i]);\n" typ typ;
250 pr " caml_modify (&Field (rv, i), v);\n";
252 pr " CAMLreturn (rv);\n";
260 let has_optpercent_col =
261 List.exists (function (_, FOptPercent) -> true | _ -> false) cols in
263 pr "static CAMLprim value\n";
264 pr "copy_%s (const struct guestfs_%s *%s)\n" typ typ typ;
266 pr " CAMLparam0 ();\n";
267 if has_optpercent_col then
268 pr " CAMLlocal3 (rv, v, v2);\n"
270 pr " CAMLlocal2 (rv, v);\n";
272 pr " rv = caml_alloc (%d, 0);\n" (List.length cols);
277 pr " v = caml_copy_string (%s->%s);\n" typ name
279 pr " v = caml_alloc_string (%s->%s_len);\n" typ name;
280 pr " memcpy (String_val (v), %s->%s, %s->%s_len);\n"
283 pr " v = caml_alloc_string (32);\n";
284 pr " memcpy (String_val (v), %s->%s, 32);\n" typ name
285 | name, (FBytes|FInt64|FUInt64) ->
286 pr " v = caml_copy_int64 (%s->%s);\n" typ name
287 | name, (FInt32|FUInt32) ->
288 pr " v = caml_copy_int32 (%s->%s);\n" typ name
289 | name, FOptPercent ->
290 pr " if (%s->%s >= 0) { /* Some %s */\n" typ name name;
291 pr " v2 = caml_copy_double (%s->%s);\n" typ name;
292 pr " v = caml_alloc (1, 0);\n";
293 pr " Store_field (v, 0, v2);\n";
294 pr " } else /* None */\n";
295 pr " v = Val_int (0);\n";
297 pr " v = Val_int (%s->%s);\n" typ name
299 pr " Store_field (rv, %d, v);\n" i
301 pr " CAMLreturn (rv);\n";
306 (* Emit a copy_TYPE_list function definition only if that function is used. *)
309 | typ, (RStructListOnly | RStructAndList) ->
310 (* generate the function for typ *)
311 emit_ocaml_copy_list_function typ
312 | typ, _ -> () (* empty *)
313 ) (rstructs_used_by all_functions);
317 fun (name, style, _, _, _, _, _) ->
318 pr "/* Automatically generated wrapper for function\n";
320 generate_ocaml_prototype name style;
325 "gv" :: List.map (fun arg -> name_of_argt arg ^ "v") (snd style) in
328 match fst style with RConstOptString _ -> true | _ -> false in
330 pr "/* Emit prototype to appease gcc's -Wmissing-prototypes. */\n";
331 pr "CAMLprim value ocaml_guestfs_%s (value %s" name (List.hd params);
332 List.iter (pr ", value %s") (List.tl params); pr ");\n";
335 pr "CAMLprim value\n";
336 pr "ocaml_guestfs_%s (value %s" name (List.hd params);
337 List.iter (pr ", value %s") (List.tl params);
342 | [p1; p2; p3; p4; p5] ->
343 pr " CAMLparam5 (%s);\n" (String.concat ", " params)
344 | p1 :: p2 :: p3 :: p4 :: p5 :: rest ->
345 pr " CAMLparam5 (%s);\n" (String.concat ", " [p1; p2; p3; p4; p5]);
346 pr " CAMLxparam%d (%s);\n"
347 (List.length rest) (String.concat ", " rest)
349 pr " CAMLparam%d (%s);\n" (List.length ps) (String.concat ", " ps)
351 if not needs_extra_vs then
352 pr " CAMLlocal1 (rv);\n"
354 pr " CAMLlocal3 (rv, v, v2);\n";
357 pr " guestfs_h *g = Guestfs_val (gv);\n";
358 pr " if (g == NULL)\n";
359 pr " ocaml_guestfs_raise_closed (\"%s\");\n" name;
365 | Device n | Dev_or_Path n
370 (* Copy strings in case the GC moves them: RHBZ#604691 *)
371 pr " char *%s = guestfs_safe_strdup (g, String_val (%sv));\n" n n
373 pr " char *%s =\n" n;
374 pr " %sv != Val_int (0) ?" n;
375 pr " guestfs_safe_strdup (g, String_val (Field (%sv, 0))) : NULL;\n" n
377 pr " size_t %s_size = caml_string_length (%sv);\n" n n;
378 pr " char *%s = guestfs_safe_memdup (g, String_val (%sv), %s_size);\n" n n n
379 | StringList n | DeviceList n ->
380 pr " char **%s = ocaml_guestfs_strings_val (g, %sv);\n" n n
382 pr " int %s = Bool_val (%sv);\n" n n
384 pr " int %s = Int_val (%sv);\n" n n
386 pr " int64_t %s = Int64_val (%sv);\n" n n
390 | RErr -> pr " int r;\n"; "-1"
391 | RInt _ -> pr " int r;\n"; "-1"
392 | RInt64 _ -> pr " int64_t r;\n"; "-1"
393 | RBool _ -> pr " int r;\n"; "-1"
394 | RConstString _ | RConstOptString _ ->
395 pr " const char *r;\n"; "NULL"
396 | RString _ -> pr " char *r;\n"; "NULL"
401 | RStruct (_, typ) ->
402 pr " struct guestfs_%s *r;\n" typ; "NULL"
403 | RStructList (_, typ) ->
404 pr " struct guestfs_%s_list *r;\n" typ; "NULL"
411 pr " size_t size;\n";
415 pr " caml_enter_blocking_section ();\n";
416 pr " r = guestfs_%s " name;
417 generate_c_call_args ~handle:"g" style;
419 pr " caml_leave_blocking_section ();\n";
421 (* Free strings if we copied them above. *)
424 | Pathname n | Device n | Dev_or_Path n | String n | OptString n
425 | FileIn n | FileOut n | BufferIn n | Key n ->
427 | StringList n | DeviceList n ->
428 pr " ocaml_guestfs_free_strings (%s);\n" n;
429 | Bool _ | Int _ | Int64 _ -> ()
432 pr " if (r == %s)\n" error_code;
433 pr " ocaml_guestfs_raise_error (g, \"%s\");\n" name;
436 (match fst style with
437 | RErr -> pr " rv = Val_unit;\n"
438 | RInt _ -> pr " rv = Val_int (r);\n"
440 pr " rv = caml_copy_int64 (r);\n"
441 | RBool _ -> pr " rv = Val_bool (r);\n"
443 pr " rv = caml_copy_string (r);\n"
444 | RConstOptString _ ->
445 pr " if (r) { /* Some string */\n";
446 pr " v = caml_alloc (1, 0);\n";
447 pr " v2 = caml_copy_string (r);\n";
448 pr " Store_field (v, 0, v2);\n";
449 pr " } else /* None */\n";
450 pr " v = Val_int (0);\n";
452 pr " rv = caml_copy_string (r);\n";
455 pr " rv = caml_copy_string_array ((const char **) r);\n";
456 pr " for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
458 | RStruct (_, typ) ->
459 pr " rv = copy_%s (r);\n" typ;
460 pr " guestfs_free_%s (r);\n" typ;
461 | RStructList (_, typ) ->
462 pr " rv = copy_%s_list (r);\n" typ;
463 pr " guestfs_free_%s_list (r);\n" typ;
465 pr " rv = copy_table (r);\n";
466 pr " for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
469 pr " rv = caml_alloc_string (size);\n";
470 pr " memcpy (String_val (rv), r, size);\n";
473 pr " CAMLreturn (rv);\n";
477 if List.length params > 5 then (
478 pr "/* Emit prototype to appease gcc's -Wmissing-prototypes. */\n";
479 pr "CAMLprim value ";
480 pr "ocaml_guestfs_%s_byte (value *argv, int argn);\n" name;
481 pr "CAMLprim value\n";
482 pr "ocaml_guestfs_%s_byte (value *argv, int argn)\n" name;
484 pr " return ocaml_guestfs_%s (argv[0]" name;
485 iteri (fun i _ -> pr ", argv[%d]" i) (List.tl params);
490 ) all_functions_sorted
492 and generate_ocaml_structure_decls () =
495 pr "type %s = {\n" typ;
498 | name, FString -> pr " %s : string;\n" name
499 | name, FBuffer -> pr " %s : string;\n" name
500 | name, FUUID -> pr " %s : string;\n" name
501 | name, (FBytes|FInt64|FUInt64) -> pr " %s : int64;\n" name
502 | name, (FInt32|FUInt32) -> pr " %s : int32;\n" name
503 | name, FChar -> pr " %s : char;\n" name
504 | name, FOptPercent -> pr " %s : float option;\n" name
510 and generate_ocaml_prototype ?(is_external = false) name style =
511 if is_external then pr "external " else pr "val ";
512 pr "%s : t -> " name;
513 generate_ocaml_function_type style;
514 if is_external then (
516 if List.length (snd style) + 1 > 5 then
517 pr "\"ocaml_guestfs_%s_byte\" " name;
518 pr "\"ocaml_guestfs_%s\"" name
522 and generate_ocaml_function_type style =
525 | Pathname _ | Device _ | Dev_or_Path _ | String _ | FileIn _ | FileOut _
526 | BufferIn _ | Key _ -> pr "string -> "
527 | OptString _ -> pr "string option -> "
528 | StringList _ | DeviceList _ -> pr "string array -> "
529 | Bool _ -> pr "bool -> "
530 | Int _ -> pr "int -> "
531 | Int64 _ -> pr "int64 -> "
533 (match fst style with
534 | RErr -> pr "unit" (* all errors are turned into exceptions *)
536 | RInt64 _ -> pr "int64"
537 | RBool _ -> pr "bool"
538 | RConstString _ -> pr "string"
539 | RConstOptString _ -> pr "string option"
540 | RString _ | RBufferOut _ -> pr "string"
541 | RStringList _ -> pr "string array"
542 | RStruct (_, typ) -> pr "%s" typ
543 | RStructList (_, typ) -> pr "%s array" typ
544 | RHashtable _ -> pr "(string * string) list"