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 user_cancel : t -> unit
98 (** Cancel current transfer. This is safe to call from OCaml signal
99 handlers and threads. *)
102 generate_ocaml_structure_decls ();
106 fun (name, style, _, _, _, shortdesc, _) ->
107 generate_ocaml_prototype name style;
108 pr "(** %s *)\n" shortdesc;
110 ) all_functions_sorted;
113 (** {2 Object-oriented API}
115 This is an alternate way of calling the API using an object-oriented
116 style, so you can use [g#add_drive_opts filename] instead of
117 [Guestfs.add_drive_opts g filename]. Apart from the different style,
118 it offers exactly the same functionality.
120 Calling [new guestfs ()] creates both the object and the handle.
121 The object and handle are closed either implicitly when the
122 object is garbage collected, or explicitly by calling the [g#close ()]
125 You can get the {!Guestfs.t} handle by calling [g#ocaml_handle].
127 Note that methods that take no parameters (except the implicit handle)
128 get an extra unit [()] parameter. This is so you can create a
129 closure from the method easily. For example [g#get_verbose ()]
130 calls the method, whereas [g#get_verbose] is a function. *)
132 class guestfs : unit -> object
133 method close : unit -> unit
134 method set_event_callback : event_callback -> event list -> event_handle
135 method delete_event_callback : event_handle -> unit
136 method user_cancel : unit -> unit
137 method ocaml_handle : t
142 | name, ((_, [], []) as style), _, _, _, _, _ ->
143 pr " method %s : unit -> " name;
144 generate_ocaml_function_type style;
146 | name, style, _, _, _, _, _ ->
147 pr " method %s : " name;
148 generate_ocaml_function_type style;
150 ) all_functions_sorted;
154 (* Generate the OCaml bindings implementation. *)
155 and generate_ocaml_ml () =
156 generate_header OCamlStyle LGPLv2plus;
161 exception Error of string
162 exception Handle_closed of string
164 external create : unit -> t = \"ocaml_guestfs_create\"
165 external close : t -> unit = \"ocaml_guestfs_close\"
171 pr " | EVENT_%s\n" (String.uppercase name)
180 pr " EVENT_%s;\n" (String.uppercase name)
186 type event_handle = int
188 type event_callback =
189 t -> event -> event_handle -> string -> int64 array -> unit
191 external set_event_callback : t -> event_callback -> event list -> event_handle
192 = \"ocaml_guestfs_set_event_callback\"
193 external delete_event_callback : t -> event_handle -> unit
194 = \"ocaml_guestfs_delete_event_callback\"
196 external user_cancel : t -> unit = \"ocaml_guestfs_user_cancel\" \"noalloc\"
198 (* Give the exceptions names, so they can be raised from the C code. *)
200 Callback.register_exception \"ocaml_guestfs_error\" (Error \"\");
201 Callback.register_exception \"ocaml_guestfs_closed\" (Handle_closed \"\")
205 generate_ocaml_structure_decls ();
209 fun (name, style, _, _, _, shortdesc, _) ->
210 generate_ocaml_prototype ~is_external:true name style;
211 ) all_functions_sorted;
218 method close () = close g
219 method set_event_callback = set_event_callback g
220 method delete_event_callback = delete_event_callback g
221 method user_cancel () = user_cancel g
222 method ocaml_handle = g
227 | name, (_, [], []), _, _, _, _, _ -> (* no params? add explicit unit *)
228 pr " method %s () = %s g\n" name name
229 | name, _, _, _, _, _, _ ->
230 pr " method %s = %s g\n" name name
231 ) all_functions_sorted;
235 (* Generate the OCaml bindings C implementation. *)
236 and generate_ocaml_c () =
237 generate_header CStyle LGPLv2plus;
245 #include <caml/config.h>
246 #include <caml/alloc.h>
247 #include <caml/callback.h>
248 #include <caml/fail.h>
249 #include <caml/memory.h>
250 #include <caml/mlvalues.h>
251 #include <caml/signals.h>
253 #include \"guestfs.h\"
255 #include \"guestfs_c.h\"
257 /* Copy a hashtable of string pairs into an assoc-list. We return
258 * the list in reverse order, but hashtables aren't supposed to be
261 static CAMLprim value
262 copy_table (char * const * argv)
265 CAMLlocal5 (rv, pairv, kv, vv, cons);
269 for (i = 0; argv[i] != NULL; i += 2) {
270 kv = caml_copy_string (argv[i]);
271 vv = caml_copy_string (argv[i+1]);
272 pairv = caml_alloc (2, 0);
273 Store_field (pairv, 0, kv);
274 Store_field (pairv, 1, vv);
275 cons = caml_alloc (2, 0);
276 Store_field (cons, 1, rv);
278 Store_field (cons, 0, pairv);
286 (* Struct copy functions. *)
288 let emit_ocaml_copy_list_function typ =
289 pr "static CAMLprim value\n";
290 pr "copy_%s_list (const struct guestfs_%s_list *%ss)\n" typ typ typ;
292 pr " CAMLparam0 ();\n";
293 pr " CAMLlocal2 (rv, v);\n";
294 pr " unsigned int i;\n";
296 pr " if (%ss->len == 0)\n" typ;
297 pr " CAMLreturn (Atom (0));\n";
299 pr " rv = caml_alloc (%ss->len, 0);\n" typ;
300 pr " for (i = 0; i < %ss->len; ++i) {\n" typ;
301 pr " v = copy_%s (&%ss->val[i]);\n" typ typ;
302 pr " caml_modify (&Field (rv, i), v);\n";
304 pr " CAMLreturn (rv);\n";
312 let has_optpercent_col =
313 List.exists (function (_, FOptPercent) -> true | _ -> false) cols in
315 pr "static CAMLprim value\n";
316 pr "copy_%s (const struct guestfs_%s *%s)\n" typ typ typ;
318 pr " CAMLparam0 ();\n";
319 if has_optpercent_col then
320 pr " CAMLlocal3 (rv, v, v2);\n"
322 pr " CAMLlocal2 (rv, v);\n";
324 pr " rv = caml_alloc (%d, 0);\n" (List.length cols);
329 pr " v = caml_copy_string (%s->%s);\n" typ name
331 pr " v = caml_alloc_string (%s->%s_len);\n" typ name;
332 pr " memcpy (String_val (v), %s->%s, %s->%s_len);\n"
335 pr " v = caml_alloc_string (32);\n";
336 pr " memcpy (String_val (v), %s->%s, 32);\n" typ name
337 | name, (FBytes|FInt64|FUInt64) ->
338 pr " v = caml_copy_int64 (%s->%s);\n" typ name
339 | name, (FInt32|FUInt32) ->
340 pr " v = caml_copy_int32 (%s->%s);\n" typ name
341 | name, FOptPercent ->
342 pr " if (%s->%s >= 0) { /* Some %s */\n" typ name name;
343 pr " v2 = caml_copy_double (%s->%s);\n" typ name;
344 pr " v = caml_alloc (1, 0);\n";
345 pr " Store_field (v, 0, v2);\n";
346 pr " } else /* None */\n";
347 pr " v = Val_int (0);\n";
349 pr " v = Val_int (%s->%s);\n" typ name
351 pr " Store_field (rv, %d, v);\n" i
353 pr " CAMLreturn (rv);\n";
358 (* Emit a copy_TYPE_list function definition only if that function is used. *)
361 | typ, (RStructListOnly | RStructAndList) ->
362 (* generate the function for typ *)
363 emit_ocaml_copy_list_function typ
364 | typ, _ -> () (* empty *)
365 ) (rstructs_used_by all_functions);
369 fun (name, (ret, args, optargs as style), _, _, _, _, _) ->
370 pr "/* Automatically generated wrapper for function\n";
372 generate_ocaml_prototype name style;
376 (* If we run into this situation, we'll need to change the
379 if args = [] && optargs <> [] then
380 failwithf "ocaml bindings don't support args = [], optargs <> []";
384 List.map (fun arg -> name_of_argt arg ^ "v") (optargs @ args) in
387 match ret with RConstOptString _ -> true | _ -> false in
389 pr "/* Emit prototype to appease gcc's -Wmissing-prototypes. */\n";
390 pr "CAMLprim value ocaml_guestfs_%s (value %s" name (List.hd params);
391 List.iter (pr ", value %s") (List.tl params); pr ");\n";
394 pr "CAMLprim value\n";
395 pr "ocaml_guestfs_%s (value %s" name (List.hd params);
396 List.iter (pr ", value %s") (List.tl params);
401 | [p1; p2; p3; p4; p5] ->
402 pr " CAMLparam5 (%s);\n" (String.concat ", " params)
403 | p1 :: p2 :: p3 :: p4 :: p5 :: rest ->
404 pr " CAMLparam5 (%s);\n" (String.concat ", " [p1; p2; p3; p4; p5]);
405 pr " CAMLxparam%d (%s);\n"
406 (List.length rest) (String.concat ", " rest)
408 pr " CAMLparam%d (%s);\n" (List.length ps) (String.concat ", " ps)
410 if not needs_extra_vs then
411 pr " CAMLlocal1 (rv);\n"
413 pr " CAMLlocal3 (rv, v, v2);\n";
416 pr " guestfs_h *g = Guestfs_val (gv);\n";
417 pr " if (g == NULL)\n";
418 pr " ocaml_guestfs_raise_closed (\"%s\");\n" name;
424 | Device n | Dev_or_Path n
429 (* Copy strings in case the GC moves them: RHBZ#604691 *)
430 pr " char *%s = guestfs_safe_strdup (g, String_val (%sv));\n" n n
432 pr " char *%s =\n" n;
433 pr " %sv != Val_int (0) ?\n" n;
434 pr " guestfs_safe_strdup (g, String_val (Field (%sv, 0))) : NULL;\n" n
436 pr " size_t %s_size = caml_string_length (%sv);\n" n n;
437 pr " char *%s = guestfs_safe_memdup (g, String_val (%sv), %s_size);\n" n n n
438 | StringList n | DeviceList n ->
439 pr " char **%s = ocaml_guestfs_strings_val (g, %sv);\n" n n
441 pr " int %s = Bool_val (%sv);\n" n n
443 pr " int %s = Int_val (%sv);\n" n n
445 pr " int64_t %s = Int64_val (%sv);\n" n n
447 pr " %s %s = (%s) (intptr_t) Int64_val (%sv);\n" t n t n
450 (* Optional arguments. *)
451 if optargs <> [] then (
452 pr " struct guestfs_%s_argv optargs_s = { .bitmask = 0 };\n" name;
453 pr " struct guestfs_%s_argv *optargs = &optargs_s;\n" name;
454 let uc_name = String.uppercase name in
457 let n = name_of_argt argt in
458 let uc_n = String.uppercase n in
459 pr " if (%sv != Val_int (0)) {\n" n;
460 pr " optargs_s.bitmask |= GUESTFS_%s_%s_BITMASK;\n" uc_name uc_n;
461 pr " optargs_s.%s = " n;
463 | Bool _ -> pr "Bool_val (Field (%sv, 0))" n
464 | Int _ -> pr "Int_val (Field (%sv, 0))" n
465 | Int64 _ -> pr "Int64_val (Field (%sv, 0))" n
467 pr "guestfs_safe_strdup (g, String_val (Field (%sv, 0)))" n
476 | RErr -> pr " int r;\n"
477 | RInt _ -> pr " int r;\n"
478 | RInt64 _ -> pr " int64_t r;\n"
479 | RBool _ -> pr " int r;\n"
480 | RConstString _ | RConstOptString _ ->
481 pr " const char *r;\n"
482 | RString _ -> pr " char *r;\n"
486 | RStruct (_, typ) ->
487 pr " struct guestfs_%s *r;\n" typ
488 | RStructList (_, typ) ->
489 pr " struct guestfs_%s_list *r;\n" typ
499 pr " caml_enter_blocking_section ();\n";
501 pr " r = guestfs_%s " name
503 pr " r = guestfs_%s_argv " name;
504 generate_c_call_args ~handle:"g" style;
506 pr " caml_leave_blocking_section ();\n";
508 (* Free strings if we copied them above. *)
511 | Pathname n | Device n | Dev_or_Path n | String n | OptString n
512 | FileIn n | FileOut n | BufferIn n | Key n ->
514 | StringList n | DeviceList n ->
515 pr " ocaml_guestfs_free_strings (%s);\n" n;
516 | Bool _ | Int _ | Int64 _ | Pointer _ -> ()
521 pr " if (%sv != Val_int (0))\n" n;
522 pr " free ((char *) optargs_s.%s);\n" n
523 | Bool _ | Int _ | Int64 _
524 | Pathname _ | Device _ | Dev_or_Path _ | OptString _
525 | FileIn _ | FileOut _ | BufferIn _ | Key _
526 | StringList _ | DeviceList _ | Pointer _ -> ()
529 (match errcode_of_ret ret with
530 | `CannotReturnError -> ()
531 | `ErrorIsMinusOne ->
532 pr " if (r == -1)\n";
533 pr " ocaml_guestfs_raise_error (g, \"%s\");\n" name;
535 pr " if (r == NULL)\n";
536 pr " ocaml_guestfs_raise_error (g, \"%s\");\n" name;
541 | RErr -> pr " rv = Val_unit;\n"
542 | RInt _ -> pr " rv = Val_int (r);\n"
544 pr " rv = caml_copy_int64 (r);\n"
545 | RBool _ -> pr " rv = Val_bool (r);\n"
547 pr " rv = caml_copy_string (r);\n"
548 | RConstOptString _ ->
549 pr " if (r) { /* Some string */\n";
550 pr " v = caml_alloc (1, 0);\n";
551 pr " v2 = caml_copy_string (r);\n";
552 pr " Store_field (v, 0, v2);\n";
553 pr " } else /* None */\n";
554 pr " v = Val_int (0);\n";
556 pr " rv = caml_copy_string (r);\n";
559 pr " rv = caml_copy_string_array ((const char **) r);\n";
560 pr " for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
562 | RStruct (_, typ) ->
563 pr " rv = copy_%s (r);\n" typ;
564 pr " guestfs_free_%s (r);\n" typ;
565 | RStructList (_, typ) ->
566 pr " rv = copy_%s_list (r);\n" typ;
567 pr " guestfs_free_%s_list (r);\n" typ;
569 pr " rv = copy_table (r);\n";
570 pr " for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
573 pr " rv = caml_alloc_string (size);\n";
574 pr " memcpy (String_val (rv), r, size);\n";
577 pr " CAMLreturn (rv);\n";
581 if List.length params > 5 then (
582 pr "/* Emit prototype to appease gcc's -Wmissing-prototypes. */\n";
583 pr "CAMLprim value ";
584 pr "ocaml_guestfs_%s_byte (value *argv, int argn);\n" name;
585 pr "CAMLprim value\n";
586 pr "ocaml_guestfs_%s_byte (value *argv, int argn ATTRIBUTE_UNUSED)\n"
589 pr " return ocaml_guestfs_%s (argv[0]" name;
590 iteri (fun i _ -> pr ", argv[%d]" i) (List.tl params);
595 ) all_functions_sorted
597 and generate_ocaml_structure_decls () =
600 pr "type %s = {\n" typ;
603 | name, FString -> pr " %s : string;\n" name
604 | name, FBuffer -> pr " %s : string;\n" name
605 | name, FUUID -> pr " %s : string;\n" name
606 | name, (FBytes|FInt64|FUInt64) -> pr " %s : int64;\n" name
607 | name, (FInt32|FUInt32) -> pr " %s : int32;\n" name
608 | name, FChar -> pr " %s : char;\n" name
609 | name, FOptPercent -> pr " %s : float option;\n" name
615 and generate_ocaml_prototype ?(is_external = false) name style =
616 if is_external then pr "external " else pr "val ";
617 pr "%s : t -> " name;
618 generate_ocaml_function_type style;
619 if is_external then (
621 let _, args, optargs = style in
622 if List.length args + List.length optargs + 1 > 5 then
623 pr "\"ocaml_guestfs_%s_byte\" " name;
624 pr "\"ocaml_guestfs_%s\"" name
628 and generate_ocaml_function_type (ret, args, optargs) =
631 | Bool n -> pr "?%s:bool -> " n
632 | Int n -> pr "?%s:int -> " n
633 | Int64 n -> pr "?%s:int64 -> " n
634 | String n -> pr "?%s:string -> " n
639 | Pathname _ | Device _ | Dev_or_Path _ | String _ | FileIn _ | FileOut _
640 | BufferIn _ | Key _ -> pr "string -> "
641 | OptString _ -> pr "string option -> "
642 | StringList _ | DeviceList _ -> pr "string array -> "
643 | Bool _ -> pr "bool -> "
644 | Int _ -> pr "int -> "
645 | Int64 _ | Pointer _ -> pr "int64 -> "
648 | RErr -> pr "unit" (* all errors are turned into exceptions *)
650 | RInt64 _ -> pr "int64"
651 | RBool _ -> pr "bool"
652 | RConstString _ -> pr "string"
653 | RConstOptString _ -> pr "string option"
654 | RString _ | RBufferOut _ -> pr "string"
655 | RStringList _ -> pr "string array"
656 | RStruct (_, typ) -> pr "%s" typ
657 | RStructList (_, typ) -> pr "%s array" typ
658 | RHashtable _ -> pr "(string * string) list"