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_opts filename] instead of
101 [Guestfs.add_drive_opts 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, (ret, args, optargs as style), _, _, _, _, _) ->
327 pr "/* Automatically generated wrapper for function\n";
329 generate_ocaml_prototype name style;
333 (* If we run into this situation, we'll need to change the
336 if args = [] && optargs <> [] then
337 failwithf "ocaml bindings don't support args = [], optargs <> []";
341 List.map (fun arg -> name_of_argt arg ^ "v") (optargs @ args) in
344 match ret with RConstOptString _ -> true | _ -> false in
346 pr "/* Emit prototype to appease gcc's -Wmissing-prototypes. */\n";
347 pr "CAMLprim value ocaml_guestfs_%s (value %s" name (List.hd params);
348 List.iter (pr ", value %s") (List.tl params); pr ");\n";
351 pr "CAMLprim value\n";
352 pr "ocaml_guestfs_%s (value %s" name (List.hd params);
353 List.iter (pr ", value %s") (List.tl params);
358 | [p1; p2; p3; p4; p5] ->
359 pr " CAMLparam5 (%s);\n" (String.concat ", " params)
360 | p1 :: p2 :: p3 :: p4 :: p5 :: rest ->
361 pr " CAMLparam5 (%s);\n" (String.concat ", " [p1; p2; p3; p4; p5]);
362 pr " CAMLxparam%d (%s);\n"
363 (List.length rest) (String.concat ", " rest)
365 pr " CAMLparam%d (%s);\n" (List.length ps) (String.concat ", " ps)
367 if not needs_extra_vs then
368 pr " CAMLlocal1 (rv);\n"
370 pr " CAMLlocal3 (rv, v, v2);\n";
373 pr " guestfs_h *g = Guestfs_val (gv);\n";
374 pr " if (g == NULL)\n";
375 pr " ocaml_guestfs_raise_closed (\"%s\");\n" name;
381 | Device n | Dev_or_Path n
386 (* Copy strings in case the GC moves them: RHBZ#604691 *)
387 pr " char *%s = guestfs_safe_strdup (g, String_val (%sv));\n" n n
389 pr " char *%s =\n" n;
390 pr " %sv != Val_int (0) ?\n" n;
391 pr " guestfs_safe_strdup (g, String_val (Field (%sv, 0))) : NULL;\n" n
393 pr " size_t %s_size = caml_string_length (%sv);\n" n n;
394 pr " char *%s = guestfs_safe_memdup (g, String_val (%sv), %s_size);\n" n n n
395 | StringList n | DeviceList n ->
396 pr " char **%s = ocaml_guestfs_strings_val (g, %sv);\n" n n
398 pr " int %s = Bool_val (%sv);\n" n n
400 pr " int %s = Int_val (%sv);\n" n n
402 pr " int64_t %s = Int64_val (%sv);\n" n n
405 (* Optional arguments. *)
406 if optargs <> [] then (
407 pr " struct guestfs_%s_argv optargs_s = { .bitmask = 0 };\n" name;
408 pr " struct guestfs_%s_argv *optargs = &optargs_s;\n" name;
409 let uc_name = String.uppercase name in
412 let n = name_of_argt argt in
413 let uc_n = String.uppercase n in
414 pr " if (%sv != Val_int (0)) {\n" n;
415 pr " optargs_s.bitmask |= GUESTFS_%s_%s_BITMASK;\n" uc_name uc_n;
416 pr " optargs_s.%s = " n;
418 | Bool _ -> pr "Bool_val (Field (%sv, 0))" n
419 | Int _ -> pr "Int_val (Field (%sv, 0))" n
420 | Int64 _ -> pr "Int64_val (Field (%sv, 0))" n
422 pr "guestfs_safe_strdup (g, String_val (Field (%sv, 0)))" n
432 | RErr -> pr " int r;\n"; "-1"
433 | RInt _ -> pr " int r;\n"; "-1"
434 | RInt64 _ -> pr " int64_t r;\n"; "-1"
435 | RBool _ -> pr " int r;\n"; "-1"
436 | RConstString _ | RConstOptString _ ->
437 pr " const char *r;\n"; "NULL"
438 | RString _ -> pr " char *r;\n"; "NULL"
443 | RStruct (_, typ) ->
444 pr " struct guestfs_%s *r;\n" typ; "NULL"
445 | RStructList (_, typ) ->
446 pr " struct guestfs_%s_list *r;\n" typ; "NULL"
453 pr " size_t size;\n";
457 pr " caml_enter_blocking_section ();\n";
459 pr " r = guestfs_%s " name
461 pr " r = guestfs_%s_argv " name;
462 generate_c_call_args ~handle:"g" style;
464 pr " caml_leave_blocking_section ();\n";
466 (* Free strings if we copied them above. *)
469 | Pathname n | Device n | Dev_or_Path n | String n | OptString n
470 | FileIn n | FileOut n | BufferIn n | Key n ->
472 | StringList n | DeviceList n ->
473 pr " ocaml_guestfs_free_strings (%s);\n" n;
474 | Bool _ | Int _ | Int64 _ -> ()
479 pr " if (%sv != Val_int (0))\n" n;
480 pr " free ((char *) optargs_s.%s);\n" n
481 | Bool _ | Int _ | Int64 _
482 | Pathname _ | Device _ | Dev_or_Path _ | OptString _
483 | FileIn _ | FileOut _ | BufferIn _ | Key _
484 | StringList _ | DeviceList _ -> ()
487 pr " if (r == %s)\n" error_code;
488 pr " ocaml_guestfs_raise_error (g, \"%s\");\n" name;
492 | RErr -> pr " rv = Val_unit;\n"
493 | RInt _ -> pr " rv = Val_int (r);\n"
495 pr " rv = caml_copy_int64 (r);\n"
496 | RBool _ -> pr " rv = Val_bool (r);\n"
498 pr " rv = caml_copy_string (r);\n"
499 | RConstOptString _ ->
500 pr " if (r) { /* Some string */\n";
501 pr " v = caml_alloc (1, 0);\n";
502 pr " v2 = caml_copy_string (r);\n";
503 pr " Store_field (v, 0, v2);\n";
504 pr " } else /* None */\n";
505 pr " v = Val_int (0);\n";
507 pr " rv = caml_copy_string (r);\n";
510 pr " rv = caml_copy_string_array ((const char **) r);\n";
511 pr " for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
513 | RStruct (_, typ) ->
514 pr " rv = copy_%s (r);\n" typ;
515 pr " guestfs_free_%s (r);\n" typ;
516 | RStructList (_, typ) ->
517 pr " rv = copy_%s_list (r);\n" typ;
518 pr " guestfs_free_%s_list (r);\n" typ;
520 pr " rv = copy_table (r);\n";
521 pr " for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
524 pr " rv = caml_alloc_string (size);\n";
525 pr " memcpy (String_val (rv), r, size);\n";
528 pr " CAMLreturn (rv);\n";
532 if List.length params > 5 then (
533 pr "/* Emit prototype to appease gcc's -Wmissing-prototypes. */\n";
534 pr "CAMLprim value ";
535 pr "ocaml_guestfs_%s_byte (value *argv, int argn);\n" name;
536 pr "CAMLprim value\n";
537 pr "ocaml_guestfs_%s_byte (value *argv, int argn)\n" name;
539 pr " return ocaml_guestfs_%s (argv[0]" name;
540 iteri (fun i _ -> pr ", argv[%d]" i) (List.tl params);
545 ) all_functions_sorted
547 and generate_ocaml_structure_decls () =
550 pr "type %s = {\n" typ;
553 | name, FString -> pr " %s : string;\n" name
554 | name, FBuffer -> pr " %s : string;\n" name
555 | name, FUUID -> pr " %s : string;\n" name
556 | name, (FBytes|FInt64|FUInt64) -> pr " %s : int64;\n" name
557 | name, (FInt32|FUInt32) -> pr " %s : int32;\n" name
558 | name, FChar -> pr " %s : char;\n" name
559 | name, FOptPercent -> pr " %s : float option;\n" name
565 and generate_ocaml_prototype ?(is_external = false) name style =
566 if is_external then pr "external " else pr "val ";
567 pr "%s : t -> " name;
568 generate_ocaml_function_type style;
569 if is_external then (
571 let _, args, optargs = style in
572 if List.length args + List.length optargs + 1 > 5 then
573 pr "\"ocaml_guestfs_%s_byte\" " name;
574 pr "\"ocaml_guestfs_%s\"" name
578 and generate_ocaml_function_type (ret, args, optargs) =
581 | Bool n -> pr "?%s:bool -> " n
582 | Int n -> pr "?%s:int -> " n
583 | Int64 n -> pr "?%s:int64 -> " n
584 | String n -> pr "?%s:string -> " n
589 | Pathname _ | Device _ | Dev_or_Path _ | String _ | FileIn _ | FileOut _
590 | BufferIn _ | Key _ -> pr "string -> "
591 | OptString _ -> pr "string option -> "
592 | StringList _ | DeviceList _ -> pr "string array -> "
593 | Bool _ -> pr "bool -> "
594 | Int _ -> pr "int -> "
595 | Int64 _ -> pr "int64 -> "
598 | RErr -> pr "unit" (* all errors are turned into exceptions *)
600 | RInt64 _ -> pr "int64"
601 | RBool _ -> pr "bool"
602 | RConstString _ -> pr "string"
603 | RConstOptString _ -> pr "string option"
604 | RString _ | RBufferOut _ -> pr "string"
605 | RStringList _ -> pr "string array"
606 | RStruct (_, typ) -> pr "%s" typ
607 | RStructList (_, typ) -> pr "%s array" typ
608 | RHashtable _ -> pr "(string * string) list"