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 (** For API documentation you should refer to the C API
39 in the guestfs(3) manual page. The OCaml API uses almost
40 exactly the same calls. *)
43 (** A [guestfs_h] handle. *)
45 exception Error of string
46 (** This exception is raised when there is an error. *)
48 exception Handle_closed of string
49 (** This exception is raised if you use a {!Guestfs.t} handle
50 after calling {!close} on it. The string is the name of
53 val create : unit -> t
54 (** Create a {!Guestfs.t} handle. *)
57 (** Close the {!Guestfs.t} handle and free up all resources used
60 Handles are closed by the garbage collector when they become
61 unreferenced, but callers can call this in order to provide
62 predictable cleanup. *)
68 pr " | EVENT_%s\n" (String.uppercase name)
73 val event_all : event list
74 (** A list containing all event types. *)
77 (** The opaque event handle which can be used to delete event callbacks. *)
80 t -> event -> event_handle -> string -> int64 array -> unit
81 (** The event callback. *)
83 val set_event_callback : t -> event_callback -> event list -> event_handle
84 (** [set_event_callback g f es] sets [f] as the event callback function
85 for all events in the set [es].
87 Note that if the closure captures a reference to the handle,
88 this reference will prevent the handle from being
89 automatically closed by the garbage collector. Since the
90 handle is passed to the event callback, with careful programming
91 it should be possible to avoid capturing the handle in the closure. *)
93 val delete_event_callback : t -> event_handle -> unit
94 (** [delete_event_callback g eh] removes a previously registered
95 event callback. See {!set_event_callback}. *)
97 val last_errno : t -> int
98 (** [last_errno g] returns the last errno that happened on the handle [g]
99 (or [0] if there was no errno). Note that the returned integer is the
100 raw errno number, and it is {i not} related to the {!Unix.error} type.
102 [last_errno] can be overwritten by subsequent operations on a handle,
103 so if you want to capture the errno correctly, you must call this
104 in the {!Error} exception handler, before any other operation on [g]. *)
106 val user_cancel : t -> unit
107 (** Cancel current transfer. This is safe to call from OCaml signal
108 handlers and threads. *)
111 generate_ocaml_structure_decls ();
115 fun (name, style, _, _, _, shortdesc, _) ->
116 generate_ocaml_prototype name style;
117 pr "(** %s *)\n" shortdesc;
119 ) all_functions_sorted;
122 (** {2 Object-oriented API}
124 This is an alternate way of calling the API using an object-oriented
125 style, so you can use [g#add_drive_opts filename] instead of
126 [Guestfs.add_drive_opts g filename]. Apart from the different style,
127 it offers exactly the same functionality.
129 Calling [new guestfs ()] creates both the object and the handle.
130 The object and handle are closed either implicitly when the
131 object is garbage collected, or explicitly by calling the [g#close ()]
134 You can get the {!Guestfs.t} handle by calling [g#ocaml_handle].
136 Note that methods that take no parameters (except the implicit handle)
137 get an extra unit [()] parameter. This is so you can create a
138 closure from the method easily. For example [g#get_verbose ()]
139 calls the method, whereas [g#get_verbose] is a function. *)
141 class guestfs : unit -> object
142 method close : unit -> unit
143 method set_event_callback : event_callback -> event list -> event_handle
144 method delete_event_callback : event_handle -> unit
145 method last_errno : unit -> int
146 method user_cancel : unit -> unit
147 method ocaml_handle : t
152 | name, ((_, [], []) as style), _, _, _, _, _ ->
153 pr " method %s : unit -> " name;
154 generate_ocaml_function_type style;
156 | name, style, _, _, _, _, _ ->
157 pr " method %s : " name;
158 generate_ocaml_function_type style;
160 ) all_functions_sorted;
164 (* Generate the OCaml bindings implementation. *)
165 and generate_ocaml_ml () =
166 generate_header OCamlStyle LGPLv2plus;
171 exception Error of string
172 exception Handle_closed of string
174 external create : unit -> t = \"ocaml_guestfs_create\"
175 external close : t -> unit = \"ocaml_guestfs_close\"
181 pr " | EVENT_%s\n" (String.uppercase name)
190 pr " EVENT_%s;\n" (String.uppercase name)
196 type event_handle = int
198 type event_callback =
199 t -> event -> event_handle -> string -> int64 array -> unit
201 external set_event_callback : t -> event_callback -> event list -> event_handle
202 = \"ocaml_guestfs_set_event_callback\"
203 external delete_event_callback : t -> event_handle -> unit
204 = \"ocaml_guestfs_delete_event_callback\"
206 external last_errno : t -> int = \"ocaml_guestfs_last_errno\"
208 external user_cancel : t -> unit = \"ocaml_guestfs_user_cancel\" \"noalloc\"
210 (* Give the exceptions names, so they can be raised from the C code. *)
212 Callback.register_exception \"ocaml_guestfs_error\" (Error \"\");
213 Callback.register_exception \"ocaml_guestfs_closed\" (Handle_closed \"\")
217 generate_ocaml_structure_decls ();
221 fun (name, style, _, _, _, shortdesc, _) ->
222 generate_ocaml_prototype ~is_external:true name style;
223 ) all_functions_sorted;
230 method close () = close g
231 method set_event_callback = set_event_callback g
232 method delete_event_callback = delete_event_callback g
233 method last_errno () = last_errno g
234 method user_cancel () = user_cancel g
235 method ocaml_handle = g
240 | name, (_, [], []), _, _, _, _, _ -> (* no params? add explicit unit *)
241 pr " method %s () = %s g\n" name name
242 | name, _, _, _, _, _, _ ->
243 pr " method %s = %s g\n" name name
244 ) all_functions_sorted;
248 (* Generate the OCaml bindings C implementation. *)
249 and generate_ocaml_c () =
250 generate_header CStyle LGPLv2plus;
258 #include <caml/config.h>
259 #include <caml/alloc.h>
260 #include <caml/callback.h>
261 #include <caml/fail.h>
262 #include <caml/memory.h>
263 #include <caml/mlvalues.h>
264 #include <caml/signals.h>
266 #include \"guestfs.h\"
268 #include \"guestfs_c.h\"
270 /* Copy a hashtable of string pairs into an assoc-list. We return
271 * the list in reverse order, but hashtables aren't supposed to be
274 static CAMLprim value
275 copy_table (char * const * argv)
278 CAMLlocal5 (rv, pairv, kv, vv, cons);
282 for (i = 0; argv[i] != NULL; i += 2) {
283 kv = caml_copy_string (argv[i]);
284 vv = caml_copy_string (argv[i+1]);
285 pairv = caml_alloc (2, 0);
286 Store_field (pairv, 0, kv);
287 Store_field (pairv, 1, vv);
288 cons = caml_alloc (2, 0);
289 Store_field (cons, 1, rv);
291 Store_field (cons, 0, pairv);
299 (* Struct copy functions. *)
301 let emit_ocaml_copy_list_function typ =
302 pr "static CAMLprim value\n";
303 pr "copy_%s_list (const struct guestfs_%s_list *%ss)\n" typ typ typ;
305 pr " CAMLparam0 ();\n";
306 pr " CAMLlocal2 (rv, v);\n";
307 pr " unsigned int i;\n";
309 pr " if (%ss->len == 0)\n" typ;
310 pr " CAMLreturn (Atom (0));\n";
312 pr " rv = caml_alloc (%ss->len, 0);\n" typ;
313 pr " for (i = 0; i < %ss->len; ++i) {\n" typ;
314 pr " v = copy_%s (&%ss->val[i]);\n" typ typ;
315 pr " caml_modify (&Field (rv, i), v);\n";
317 pr " CAMLreturn (rv);\n";
325 let has_optpercent_col =
326 List.exists (function (_, FOptPercent) -> true | _ -> false) cols in
328 pr "static CAMLprim value\n";
329 pr "copy_%s (const struct guestfs_%s *%s)\n" typ typ typ;
331 pr " CAMLparam0 ();\n";
332 if has_optpercent_col then
333 pr " CAMLlocal3 (rv, v, v2);\n"
335 pr " CAMLlocal2 (rv, v);\n";
337 pr " rv = caml_alloc (%d, 0);\n" (List.length cols);
342 pr " v = caml_copy_string (%s->%s);\n" typ name
344 pr " v = caml_alloc_string (%s->%s_len);\n" typ name;
345 pr " memcpy (String_val (v), %s->%s, %s->%s_len);\n"
348 pr " v = caml_alloc_string (32);\n";
349 pr " memcpy (String_val (v), %s->%s, 32);\n" typ name
350 | name, (FBytes|FInt64|FUInt64) ->
351 pr " v = caml_copy_int64 (%s->%s);\n" typ name
352 | name, (FInt32|FUInt32) ->
353 pr " v = caml_copy_int32 (%s->%s);\n" typ name
354 | name, FOptPercent ->
355 pr " if (%s->%s >= 0) { /* Some %s */\n" typ name name;
356 pr " v2 = caml_copy_double (%s->%s);\n" typ name;
357 pr " v = caml_alloc (1, 0);\n";
358 pr " Store_field (v, 0, v2);\n";
359 pr " } else /* None */\n";
360 pr " v = Val_int (0);\n";
362 pr " v = Val_int (%s->%s);\n" typ name
364 pr " Store_field (rv, %d, v);\n" i
366 pr " CAMLreturn (rv);\n";
371 (* Emit a copy_TYPE_list function definition only if that function is used. *)
374 | typ, (RStructListOnly | RStructAndList) ->
375 (* generate the function for typ *)
376 emit_ocaml_copy_list_function typ
377 | typ, _ -> () (* empty *)
378 ) (rstructs_used_by all_functions);
382 fun (name, (ret, args, optargs as style), _, _, _, _, _) ->
383 pr "/* Automatically generated wrapper for function\n";
385 generate_ocaml_prototype name style;
389 (* If we run into this situation, we'll need to change the
392 if args = [] && optargs <> [] then
393 failwithf "ocaml bindings don't support args = [], optargs <> []";
397 List.map (fun arg -> name_of_argt arg ^ "v") (optargs @ args) in
400 match ret with RConstOptString _ -> true | _ -> false in
402 pr "/* Emit prototype to appease gcc's -Wmissing-prototypes. */\n";
403 pr "CAMLprim value ocaml_guestfs_%s (value %s" name (List.hd params);
404 List.iter (pr ", value %s") (List.tl params); pr ");\n";
407 pr "CAMLprim value\n";
408 pr "ocaml_guestfs_%s (value %s" name (List.hd params);
409 List.iter (pr ", value %s") (List.tl params);
414 | [p1; p2; p3; p4; p5] ->
415 pr " CAMLparam5 (%s);\n" (String.concat ", " params)
416 | p1 :: p2 :: p3 :: p4 :: p5 :: rest ->
417 pr " CAMLparam5 (%s);\n" (String.concat ", " [p1; p2; p3; p4; p5]);
418 pr " CAMLxparam%d (%s);\n"
419 (List.length rest) (String.concat ", " rest)
421 pr " CAMLparam%d (%s);\n" (List.length ps) (String.concat ", " ps)
423 if not needs_extra_vs then
424 pr " CAMLlocal1 (rv);\n"
426 pr " CAMLlocal3 (rv, v, v2);\n";
429 pr " guestfs_h *g = Guestfs_val (gv);\n";
430 pr " if (g == NULL)\n";
431 pr " ocaml_guestfs_raise_closed (\"%s\");\n" name;
437 | Device n | Dev_or_Path n
442 (* Copy strings in case the GC moves them: RHBZ#604691 *)
443 pr " char *%s = guestfs_safe_strdup (g, String_val (%sv));\n" n n
445 pr " char *%s =\n" n;
446 pr " %sv != Val_int (0) ?\n" n;
447 pr " guestfs_safe_strdup (g, String_val (Field (%sv, 0))) : NULL;\n" n
449 pr " size_t %s_size = caml_string_length (%sv);\n" n n;
450 pr " char *%s = guestfs_safe_memdup (g, String_val (%sv), %s_size);\n" n n n
451 | StringList n | DeviceList n ->
452 pr " char **%s = ocaml_guestfs_strings_val (g, %sv);\n" n n
454 pr " int %s = Bool_val (%sv);\n" n n
456 pr " int %s = Int_val (%sv);\n" n n
458 pr " int64_t %s = Int64_val (%sv);\n" n n
460 pr " %s %s = (%s) (intptr_t) Int64_val (%sv);\n" t n t n
463 (* Optional arguments. *)
464 if optargs <> [] then (
465 pr " struct guestfs_%s_argv optargs_s = { .bitmask = 0 };\n" name;
466 pr " struct guestfs_%s_argv *optargs = &optargs_s;\n" name;
467 let uc_name = String.uppercase name in
470 let n = name_of_argt argt in
471 let uc_n = String.uppercase n in
472 pr " if (%sv != Val_int (0)) {\n" n;
473 pr " optargs_s.bitmask |= GUESTFS_%s_%s_BITMASK;\n" uc_name uc_n;
474 pr " optargs_s.%s = " n;
476 | Bool _ -> pr "Bool_val (Field (%sv, 0))" n
477 | Int _ -> pr "Int_val (Field (%sv, 0))" n
478 | Int64 _ -> pr "Int64_val (Field (%sv, 0))" n
480 pr "guestfs_safe_strdup (g, String_val (Field (%sv, 0)))" n
489 | RErr -> pr " int r;\n"
490 | RInt _ -> pr " int r;\n"
491 | RInt64 _ -> pr " int64_t r;\n"
492 | RBool _ -> pr " int r;\n"
493 | RConstString _ | RConstOptString _ ->
494 pr " const char *r;\n"
495 | RString _ -> pr " char *r;\n"
499 | RStruct (_, typ) ->
500 pr " struct guestfs_%s *r;\n" typ
501 | RStructList (_, typ) ->
502 pr " struct guestfs_%s_list *r;\n" typ
512 pr " caml_enter_blocking_section ();\n";
514 pr " r = guestfs_%s " name
516 pr " r = guestfs_%s_argv " name;
517 generate_c_call_args ~handle:"g" style;
519 pr " caml_leave_blocking_section ();\n";
521 (* Free strings if we copied them above. *)
524 | Pathname n | Device n | Dev_or_Path n | String n | OptString n
525 | FileIn n | FileOut n | BufferIn n | Key n ->
527 | StringList n | DeviceList n ->
528 pr " ocaml_guestfs_free_strings (%s);\n" n;
529 | Bool _ | Int _ | Int64 _ | Pointer _ -> ()
534 pr " if (%sv != Val_int (0))\n" n;
535 pr " free ((char *) optargs_s.%s);\n" n
536 | Bool _ | Int _ | Int64 _
537 | Pathname _ | Device _ | Dev_or_Path _ | OptString _
538 | FileIn _ | FileOut _ | BufferIn _ | Key _
539 | StringList _ | DeviceList _ | Pointer _ -> ()
542 (match errcode_of_ret ret with
543 | `CannotReturnError -> ()
544 | `ErrorIsMinusOne ->
545 pr " if (r == -1)\n";
546 pr " ocaml_guestfs_raise_error (g, \"%s\");\n" name;
548 pr " if (r == NULL)\n";
549 pr " ocaml_guestfs_raise_error (g, \"%s\");\n" name;
554 | RErr -> pr " rv = Val_unit;\n"
555 | RInt _ -> pr " rv = Val_int (r);\n"
557 pr " rv = caml_copy_int64 (r);\n"
558 | RBool _ -> pr " rv = Val_bool (r);\n"
560 pr " rv = caml_copy_string (r);\n"
561 | RConstOptString _ ->
562 pr " if (r) { /* Some string */\n";
563 pr " v = caml_alloc (1, 0);\n";
564 pr " v2 = caml_copy_string (r);\n";
565 pr " Store_field (v, 0, v2);\n";
566 pr " } else /* None */\n";
567 pr " v = Val_int (0);\n";
569 pr " rv = caml_copy_string (r);\n";
572 pr " rv = caml_copy_string_array ((const char **) r);\n";
573 pr " for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
575 | RStruct (_, typ) ->
576 pr " rv = copy_%s (r);\n" typ;
577 pr " guestfs_free_%s (r);\n" typ;
578 | RStructList (_, typ) ->
579 pr " rv = copy_%s_list (r);\n" typ;
580 pr " guestfs_free_%s_list (r);\n" typ;
582 pr " rv = copy_table (r);\n";
583 pr " for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
586 pr " rv = caml_alloc_string (size);\n";
587 pr " memcpy (String_val (rv), r, size);\n";
590 pr " CAMLreturn (rv);\n";
594 if List.length params > 5 then (
595 pr "/* Emit prototype to appease gcc's -Wmissing-prototypes. */\n";
596 pr "CAMLprim value ";
597 pr "ocaml_guestfs_%s_byte (value *argv, int argn);\n" name;
598 pr "CAMLprim value\n";
599 pr "ocaml_guestfs_%s_byte (value *argv, int argn ATTRIBUTE_UNUSED)\n"
602 pr " return ocaml_guestfs_%s (argv[0]" name;
603 iteri (fun i _ -> pr ", argv[%d]" i) (List.tl params);
608 ) all_functions_sorted
610 and generate_ocaml_structure_decls () =
613 pr "type %s = {\n" typ;
616 | name, FString -> pr " %s : string;\n" name
617 | name, FBuffer -> pr " %s : string;\n" name
618 | name, FUUID -> pr " %s : string;\n" name
619 | name, (FBytes|FInt64|FUInt64) -> pr " %s : int64;\n" name
620 | name, (FInt32|FUInt32) -> pr " %s : int32;\n" name
621 | name, FChar -> pr " %s : char;\n" name
622 | name, FOptPercent -> pr " %s : float option;\n" name
628 and generate_ocaml_prototype ?(is_external = false) name style =
629 if is_external then pr "external " else pr "val ";
630 pr "%s : t -> " name;
631 generate_ocaml_function_type style;
632 if is_external then (
634 let _, args, optargs = style in
635 if List.length args + List.length optargs + 1 > 5 then
636 pr "\"ocaml_guestfs_%s_byte\" " name;
637 pr "\"ocaml_guestfs_%s\"" name
641 and generate_ocaml_function_type (ret, args, optargs) =
644 | Bool n -> pr "?%s:bool -> " n
645 | Int n -> pr "?%s:int -> " n
646 | Int64 n -> pr "?%s:int64 -> " n
647 | String n -> pr "?%s:string -> " n
652 | Pathname _ | Device _ | Dev_or_Path _ | String _ | FileIn _ | FileOut _
653 | BufferIn _ | Key _ -> pr "string -> "
654 | OptString _ -> pr "string option -> "
655 | StringList _ | DeviceList _ -> pr "string array -> "
656 | Bool _ -> pr "bool -> "
657 | Int _ -> pr "int -> "
658 | Int64 _ | Pointer _ -> pr "int64 -> "
661 | RErr -> pr "unit" (* all errors are turned into exceptions *)
663 | RInt64 _ -> pr "int64"
664 | RBool _ -> pr "bool"
665 | RConstString _ -> pr "string"
666 | RConstOptString _ -> pr "string option"
667 | RString _ | RBufferOut _ -> pr "string"
668 | RStringList _ -> pr "string array"
669 | RStruct (_, typ) -> pr "%s" typ
670 | RStructList (_, typ) -> pr "%s array" typ
671 | RHashtable _ -> pr "(string * string) list"