2 * Copyright (C) 2009-2011 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
33 (* Generate the OCaml bindings interface. *)
34 let rec generate_ocaml_mli () =
35 generate_header OCamlStyle LGPLv2plus;
38 (** libguestfs bindings for OCaml.
40 For API documentation, the canonical reference is the
41 {{:http://libguestfs.org/guestfs.3.html}guestfs(3)} man page.
42 The OCaml API uses almost exactly the same calls.
44 For examples written in OCaml see the
45 {{:http://libguestfs.org/guestfs-ocaml.3.html}guestfs-ocaml(3)} man page.
48 (** {2 Module style API}
50 This is the module-style API. There is also an object-oriented API
51 (see the end of this file and {!guestfs})
52 which is functionally completely equivalent, but is more compact. *)
55 (** A [guestfs_h] handle. *)
57 exception Error of string
58 (** This exception is raised when there is an error. *)
60 exception Handle_closed of string
61 (** This exception is raised if you use a {!t} handle
62 after calling {!close} on it. The string is the name of
65 val create : unit -> t
66 (** Create a {!t} handle. *)
69 (** Close the {!t} handle and free up all resources used
72 Handles are closed by the garbage collector when they become
73 unreferenced, but callers can call this in order to provide
74 predictable cleanup. *)
80 pr " | EVENT_%s\n" (String.uppercase name)
85 val event_all : event list
86 (** A list containing all event types. *)
89 (** The opaque event handle which can be used to delete event callbacks. *)
92 t -> event -> event_handle -> string -> int64 array -> unit
93 (** The event callback. *)
95 val set_event_callback : t -> event_callback -> event list -> event_handle
96 (** [set_event_callback g f es] sets [f] as the event callback function
97 for all events in the set [es].
99 Note that if the closure captures a reference to the handle,
100 this reference will prevent the handle from being
101 automatically closed by the garbage collector. Since the
102 handle is passed to the event callback, with careful programming
103 it should be possible to avoid capturing the handle in the closure. *)
105 val delete_event_callback : t -> event_handle -> unit
106 (** [delete_event_callback g eh] removes a previously registered
107 event callback. See {!set_event_callback}. *)
109 val last_errno : t -> int
110 (** [last_errno g] returns the last errno that happened on the handle [g]
111 (or [0] if there was no errno). Note that the returned integer is the
112 raw errno number, and it is {i not} related to the {!Unix.error} type.
114 [last_errno] can be overwritten by subsequent operations on a handle,
115 so if you want to capture the errno correctly, you must call this
116 in the {!Error} exception handler, before any other operation on [g]. *)
118 val user_cancel : t -> unit
119 (** Cancel current transfer. This is safe to call from OCaml signal
120 handlers and threads. *)
123 generate_ocaml_structure_decls ();
127 fun (name, style, _, flags, _, shortdesc, _) ->
129 try Some (find_map (function DeprecatedBy fn -> Some fn | _ -> None)
131 with Not_found -> None in
132 let in_docs = not (List.mem NotInDocs flags) in
134 generate_ocaml_prototype name style;
137 pr "(** %s" shortdesc;
138 (match deprecated with
140 | Some replacement ->
141 pr "\n\n @deprecated Use {!%s} instead\n" replacement
146 ) all_functions_sorted;
149 (** {2 Object-oriented API}
151 This is an alternate way of calling the API using an object-oriented
152 style, so you can use
153 [g#]{{!guestfs.add_drive_opts}add_drive_opts} [filename]
154 instead of [Guestfs.add_drive_opts g filename].
155 Apart from the different style, it offers exactly the same functionality.
157 Calling [new guestfs ()] creates both the object and the handle.
158 The object and handle are closed either implicitly when the
159 object is garbage collected, or explicitly by calling the
160 [g#]{{!guestfs.close}close} [()] method.
162 You can get the {!t} handle by calling
163 [g#]{{!guestfs.ocaml_handle}ocaml_handle}.
165 Note that methods that take no parameters (except the implicit handle)
166 get an extra unit [()] parameter. This is so you can create a
167 closure from the method easily. For example
168 [g#]{{!guestfs.get_verbose}get_verbose} [()]
169 calls the method, whereas [g#get_verbose] is a function. *)
171 class guestfs : unit -> object
172 method close : unit -> unit
173 method set_event_callback : event_callback -> event list -> event_handle
174 method delete_event_callback : event_handle -> unit
175 method last_errno : unit -> int
176 method user_cancel : unit -> unit
177 method ocaml_handle : t
182 | name, ((_, [], []) as style), _, _, _, _, _ ->
183 pr " method %s : unit -> " name;
184 generate_ocaml_function_type style;
186 | name, style, _, _, _, _, _ ->
187 pr " method %s : " name;
188 generate_ocaml_function_type style;
190 ) all_functions_sorted;
194 (* Generate the OCaml bindings implementation. *)
195 and generate_ocaml_ml () =
196 generate_header OCamlStyle LGPLv2plus;
201 exception Error of string
202 exception Handle_closed of string
204 external create : unit -> t = \"ocaml_guestfs_create\"
205 external close : t -> unit = \"ocaml_guestfs_close\"
211 pr " | EVENT_%s\n" (String.uppercase name)
220 pr " EVENT_%s;\n" (String.uppercase name)
226 type event_handle = int
228 type event_callback =
229 t -> event -> event_handle -> string -> int64 array -> unit
231 external set_event_callback : t -> event_callback -> event list -> event_handle
232 = \"ocaml_guestfs_set_event_callback\"
233 external delete_event_callback : t -> event_handle -> unit
234 = \"ocaml_guestfs_delete_event_callback\"
236 external last_errno : t -> int = \"ocaml_guestfs_last_errno\"
238 external user_cancel : t -> unit = \"ocaml_guestfs_user_cancel\" \"noalloc\"
240 (* Give the exceptions names, so they can be raised from the C code. *)
242 Callback.register_exception \"ocaml_guestfs_error\" (Error \"\");
243 Callback.register_exception \"ocaml_guestfs_closed\" (Handle_closed \"\")
247 generate_ocaml_structure_decls ();
251 fun (name, style, _, _, _, shortdesc, _) ->
252 generate_ocaml_prototype ~is_external:true name style;
253 ) all_functions_sorted;
260 method close () = close g
261 method set_event_callback = set_event_callback g
262 method delete_event_callback = delete_event_callback g
263 method last_errno () = last_errno g
264 method user_cancel () = user_cancel g
265 method ocaml_handle = g
270 | name, (_, [], []), _, _, _, _, _ -> (* no params? add explicit unit *)
271 pr " method %s () = %s g\n" name name
272 | name, _, _, _, _, _, _ ->
273 pr " method %s = %s g\n" name name
274 ) all_functions_sorted;
278 (* Generate the OCaml bindings C implementation. *)
279 and generate_ocaml_c () =
280 generate_header CStyle LGPLv2plus;
288 #include <caml/config.h>
289 #include <caml/alloc.h>
290 #include <caml/callback.h>
291 #include <caml/fail.h>
292 #include <caml/memory.h>
293 #include <caml/mlvalues.h>
294 #include <caml/signals.h>
296 #include \"guestfs.h\"
298 #include \"guestfs_c.h\"
300 /* Copy a hashtable of string pairs into an assoc-list. We return
301 * the list in reverse order, but hashtables aren't supposed to be
304 static CAMLprim value
305 copy_table (char * const * argv)
308 CAMLlocal5 (rv, pairv, kv, vv, cons);
312 for (i = 0; argv[i] != NULL; i += 2) {
313 kv = caml_copy_string (argv[i]);
314 vv = caml_copy_string (argv[i+1]);
315 pairv = caml_alloc (2, 0);
316 Store_field (pairv, 0, kv);
317 Store_field (pairv, 1, vv);
318 cons = caml_alloc (2, 0);
319 Store_field (cons, 1, rv);
321 Store_field (cons, 0, pairv);
329 (* Struct copy functions. *)
331 let emit_ocaml_copy_list_function typ =
332 pr "static CAMLprim value\n";
333 pr "copy_%s_list (const struct guestfs_%s_list *%ss)\n" typ typ typ;
335 pr " CAMLparam0 ();\n";
336 pr " CAMLlocal2 (rv, v);\n";
337 pr " unsigned int i;\n";
339 pr " if (%ss->len == 0)\n" typ;
340 pr " CAMLreturn (Atom (0));\n";
342 pr " rv = caml_alloc (%ss->len, 0);\n" typ;
343 pr " for (i = 0; i < %ss->len; ++i) {\n" typ;
344 pr " v = copy_%s (&%ss->val[i]);\n" typ typ;
345 pr " caml_modify (&Field (rv, i), v);\n";
347 pr " CAMLreturn (rv);\n";
355 let has_optpercent_col =
356 List.exists (function (_, FOptPercent) -> true | _ -> false) cols in
358 pr "static CAMLprim value\n";
359 pr "copy_%s (const struct guestfs_%s *%s)\n" typ typ typ;
361 pr " CAMLparam0 ();\n";
362 if has_optpercent_col then
363 pr " CAMLlocal3 (rv, v, v2);\n"
365 pr " CAMLlocal2 (rv, v);\n";
367 pr " rv = caml_alloc (%d, 0);\n" (List.length cols);
372 pr " v = caml_copy_string (%s->%s);\n" typ name
374 pr " v = caml_alloc_string (%s->%s_len);\n" typ name;
375 pr " memcpy (String_val (v), %s->%s, %s->%s_len);\n"
378 pr " v = caml_alloc_string (32);\n";
379 pr " memcpy (String_val (v), %s->%s, 32);\n" typ name
380 | name, (FBytes|FInt64|FUInt64) ->
381 pr " v = caml_copy_int64 (%s->%s);\n" typ name
382 | name, (FInt32|FUInt32) ->
383 pr " v = caml_copy_int32 (%s->%s);\n" typ name
384 | name, FOptPercent ->
385 pr " if (%s->%s >= 0) { /* Some %s */\n" typ name name;
386 pr " v2 = caml_copy_double (%s->%s);\n" typ name;
387 pr " v = caml_alloc (1, 0);\n";
388 pr " Store_field (v, 0, v2);\n";
389 pr " } else /* None */\n";
390 pr " v = Val_int (0);\n";
392 pr " v = Val_int (%s->%s);\n" typ name
394 pr " Store_field (rv, %d, v);\n" i
396 pr " CAMLreturn (rv);\n";
401 (* Emit a copy_TYPE_list function definition only if that function is used. *)
404 | typ, (RStructListOnly | RStructAndList) ->
405 (* generate the function for typ *)
406 emit_ocaml_copy_list_function typ
407 | typ, _ -> () (* empty *)
408 ) (rstructs_used_by all_functions);
412 fun (name, (ret, args, optargs as style), _, _, _, _, _) ->
413 pr "/* Automatically generated wrapper for function\n";
415 generate_ocaml_prototype name style;
419 (* If we run into this situation, we'll need to change the
422 if args = [] && optargs <> [] then
423 failwithf "ocaml bindings don't support args = [], optargs <> []";
427 List.map (fun arg -> name_of_argt arg ^ "v") (optargs @ args) in
430 match ret with RConstOptString _ -> true | _ -> false in
432 pr "/* Emit prototype to appease gcc's -Wmissing-prototypes. */\n";
433 pr "CAMLprim value ocaml_guestfs_%s (value %s" name (List.hd params);
434 List.iter (pr ", value %s") (List.tl params); pr ");\n";
437 pr "CAMLprim value\n";
438 pr "ocaml_guestfs_%s (value %s" name (List.hd params);
439 List.iter (pr ", value %s") (List.tl params);
443 (* CAMLparam<N> can only take up to 5 parameters. Further parameters
444 * have to be passed in groups of 5 to CAMLxparam<N> calls.
447 | p1 :: p2 :: p3 :: p4 :: p5 :: rest ->
448 pr " CAMLparam5 (%s);\n" (String.concat ", " [p1; p2; p3; p4; p5]);
449 let rec loop = function
451 | p1 :: p2 :: p3 :: p4 :: p5 :: rest ->
452 pr " CAMLxparam5 (%s);\n"
453 (String.concat ", " [p1; p2; p3; p4; p5]);
456 pr " CAMLxparam%d (%s);\n"
457 (List.length rest) (String.concat ", " rest)
461 pr " CAMLparam%d (%s);\n" (List.length ps) (String.concat ", " ps)
463 if not needs_extra_vs then
464 pr " CAMLlocal1 (rv);\n"
466 pr " CAMLlocal3 (rv, v, v2);\n";
469 pr " guestfs_h *g = Guestfs_val (gv);\n";
470 pr " if (g == NULL)\n";
471 pr " ocaml_guestfs_raise_closed (\"%s\");\n" name;
477 | Device n | Dev_or_Path n
482 (* Copy strings in case the GC moves them: RHBZ#604691 *)
483 pr " char *%s = guestfs_safe_strdup (g, String_val (%sv));\n" n n
485 pr " char *%s =\n" n;
486 pr " %sv != Val_int (0) ?\n" n;
487 pr " guestfs_safe_strdup (g, String_val (Field (%sv, 0))) : NULL;\n" n
489 pr " size_t %s_size = caml_string_length (%sv);\n" n n;
490 pr " char *%s = guestfs_safe_memdup (g, String_val (%sv), %s_size);\n" n n n
491 | StringList n | DeviceList n ->
492 pr " char **%s = ocaml_guestfs_strings_val (g, %sv);\n" n n
494 pr " int %s = Bool_val (%sv);\n" n n
496 pr " int %s = Int_val (%sv);\n" n n
498 pr " int64_t %s = Int64_val (%sv);\n" n n
500 pr " %s %s = (%s) (intptr_t) Int64_val (%sv);\n" t n t n
503 (* Optional arguments. *)
504 if optargs <> [] then (
505 pr " struct guestfs_%s_argv optargs_s = { .bitmask = 0 };\n" name;
506 pr " struct guestfs_%s_argv *optargs = &optargs_s;\n" name;
507 let uc_name = String.uppercase name in
510 let n = name_of_argt argt in
511 let uc_n = String.uppercase n in
512 pr " if (%sv != Val_int (0)) {\n" n;
513 pr " optargs_s.bitmask |= GUESTFS_%s_%s_BITMASK;\n" uc_name uc_n;
514 pr " optargs_s.%s = " n;
516 | Bool _ -> pr "Bool_val (Field (%sv, 0))" n
517 | Int _ -> pr "Int_val (Field (%sv, 0))" n
518 | Int64 _ -> pr "Int64_val (Field (%sv, 0))" n
520 pr "guestfs_safe_strdup (g, String_val (Field (%sv, 0)))" n
529 | RErr -> pr " int r;\n"
530 | RInt _ -> pr " int r;\n"
531 | RInt64 _ -> pr " int64_t r;\n"
532 | RBool _ -> pr " int r;\n"
533 | RConstString _ | RConstOptString _ ->
534 pr " const char *r;\n"
535 | RString _ -> pr " char *r;\n"
539 | RStruct (_, typ) ->
540 pr " struct guestfs_%s *r;\n" typ
541 | RStructList (_, typ) ->
542 pr " struct guestfs_%s_list *r;\n" typ
552 pr " caml_enter_blocking_section ();\n";
554 pr " r = guestfs_%s " name
556 pr " r = guestfs_%s_argv " name;
557 generate_c_call_args ~handle:"g" style;
559 pr " caml_leave_blocking_section ();\n";
561 (* Free strings if we copied them above. *)
564 | Pathname n | Device n | Dev_or_Path n | String n | OptString n
565 | FileIn n | FileOut n | BufferIn n | Key n ->
567 | StringList n | DeviceList n ->
568 pr " ocaml_guestfs_free_strings (%s);\n" n;
569 | Bool _ | Int _ | Int64 _ | Pointer _ -> ()
574 pr " if (%sv != Val_int (0))\n" n;
575 pr " free ((char *) optargs_s.%s);\n" n
576 | Bool _ | Int _ | Int64 _
577 | Pathname _ | Device _ | Dev_or_Path _ | OptString _
578 | FileIn _ | FileOut _ | BufferIn _ | Key _
579 | StringList _ | DeviceList _ | Pointer _ -> ()
582 (match errcode_of_ret ret with
583 | `CannotReturnError -> ()
584 | `ErrorIsMinusOne ->
585 pr " if (r == -1)\n";
586 pr " ocaml_guestfs_raise_error (g, \"%s\");\n" name;
588 pr " if (r == NULL)\n";
589 pr " ocaml_guestfs_raise_error (g, \"%s\");\n" name;
594 | RErr -> pr " rv = Val_unit;\n"
595 | RInt _ -> pr " rv = Val_int (r);\n"
597 pr " rv = caml_copy_int64 (r);\n"
598 | RBool _ -> pr " rv = Val_bool (r);\n"
600 pr " rv = caml_copy_string (r);\n"
601 | RConstOptString _ ->
602 pr " if (r) { /* Some string */\n";
603 pr " v = caml_alloc (1, 0);\n";
604 pr " v2 = caml_copy_string (r);\n";
605 pr " Store_field (v, 0, v2);\n";
606 pr " } else /* None */\n";
607 pr " v = Val_int (0);\n";
609 pr " rv = caml_copy_string (r);\n";
612 pr " rv = caml_copy_string_array ((const char **) r);\n";
613 pr " for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
615 | RStruct (_, typ) ->
616 pr " rv = copy_%s (r);\n" typ;
617 pr " guestfs_free_%s (r);\n" typ;
618 | RStructList (_, typ) ->
619 pr " rv = copy_%s_list (r);\n" typ;
620 pr " guestfs_free_%s_list (r);\n" typ;
622 pr " rv = copy_table (r);\n";
623 pr " for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
626 pr " rv = caml_alloc_string (size);\n";
627 pr " memcpy (String_val (rv), r, size);\n";
631 pr " CAMLreturn (rv);\n";
635 if List.length params > 5 then (
636 pr "/* Emit prototype to appease gcc's -Wmissing-prototypes. */\n";
637 pr "CAMLprim value ";
638 pr "ocaml_guestfs_%s_byte (value *argv, int argn);\n" name;
639 pr "CAMLprim value\n";
640 pr "ocaml_guestfs_%s_byte (value *argv, int argn ATTRIBUTE_UNUSED)\n"
643 pr " return ocaml_guestfs_%s (argv[0]" name;
644 iteri (fun i _ -> pr ", argv[%d]" i) (List.tl params);
649 ) all_functions_sorted
651 and generate_ocaml_structure_decls () =
654 pr "type %s = {\n" typ;
657 | name, FString -> pr " %s : string;\n" name
658 | name, FBuffer -> pr " %s : string;\n" name
659 | name, FUUID -> pr " %s : string;\n" name
660 | name, (FBytes|FInt64|FUInt64) -> pr " %s : int64;\n" name
661 | name, (FInt32|FUInt32) -> pr " %s : int32;\n" name
662 | name, FChar -> pr " %s : char;\n" name
663 | name, FOptPercent -> pr " %s : float option;\n" name
669 and generate_ocaml_prototype ?(is_external = false) name style =
670 if is_external then pr "external " else pr "val ";
671 pr "%s : t -> " name;
672 generate_ocaml_function_type style;
673 if is_external then (
675 let _, args, optargs = style in
676 if List.length args + List.length optargs + 1 > 5 then
677 pr "\"ocaml_guestfs_%s_byte\" " name;
678 pr "\"ocaml_guestfs_%s\"" name
682 and generate_ocaml_function_type (ret, args, optargs) =
685 | Bool n -> pr "?%s:bool -> " n
686 | Int n -> pr "?%s:int -> " n
687 | Int64 n -> pr "?%s:int64 -> " n
688 | String n -> pr "?%s:string -> " n
693 | Pathname _ | Device _ | Dev_or_Path _ | String _ | FileIn _ | FileOut _
694 | BufferIn _ | Key _ -> pr "string -> "
695 | OptString _ -> pr "string option -> "
696 | StringList _ | DeviceList _ -> pr "string array -> "
697 | Bool _ -> pr "bool -> "
698 | Int _ -> pr "int -> "
699 | Int64 _ | Pointer _ -> pr "int64 -> "
702 | RErr -> pr "unit" (* all errors are turned into exceptions *)
704 | RInt64 _ -> pr "int64"
705 | RBool _ -> pr "bool"
706 | RConstString _ -> pr "string"
707 | RConstOptString _ -> pr "string option"
708 | RString _ | RBufferOut _ -> pr "string"
709 | RStringList _ -> pr "string array"
710 | RStruct (_, typ) -> pr "%s" typ
711 | RStructList (_, typ) -> pr "%s array" typ
712 | RHashtable _ -> pr "(string * string) list"