(* libguestfs
- * Copyright (C) 2009-2010 Red Hat Inc.
+ * Copyright (C) 2009-2011 Red Hat Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
open Generator_actions
open Generator_structs
open Generator_c
+open Generator_events
(* Generate the OCaml bindings interface. *)
let rec generate_ocaml_mli () =
unreferenced, but callers can call this in order to provide
predictable cleanup. *)
-type progress_cb = int -> int -> int64 -> int64 -> unit
+type event =
+";
+ List.iter (
+ fun (name, _) ->
+ pr " | EVENT_%s\n" (String.uppercase name)
+ ) events;
+ pr "\n";
+
+ pr "\
+val event_all : event list
+(** A list containing all event types. *)
+
+type event_handle
+(** The opaque event handle which can be used to delete event callbacks. *)
-val set_progress_callback : t -> progress_cb -> unit
-(** [set_progress_callback g f] sets [f] as the progress callback function.
- For some long-running functions, [f] will be called repeatedly
- during the function with progress updates.
+type event_callback =
+ t -> event -> event_handle -> string -> int64 array -> unit
+(** The event callback. *)
- The callback is [f proc_nr serial position total]. See
- the description of [guestfs_set_progress_callback] in guestfs(3)
- for the meaning of these four numbers.
+val set_event_callback : t -> event_callback -> event list -> event_handle
+(** [set_event_callback g f es] sets [f] as the event callback function
+ for all events in the set [es].
Note that if the closure captures a reference to the handle,
this reference will prevent the handle from being
- automatically closed by the garbage collector. There are
- three ways to avoid this: be careful not to capture the handle
- in the closure, or use a weak reference, or call
- {!Guestfs.clear_progress_callback} to remove the reference. *)
+ automatically closed by the garbage collector. Since the
+ handle is passed to the event callback, with careful programming
+ it should be possible to avoid capturing the handle in the closure. *)
-val clear_progress_callback : t -> unit
-(** [clear_progress_callback g] removes any progress callback function
- associated with the handle. See {!Guestfs.set_progress_callback}. *)
+val delete_event_callback : t -> event_handle -> unit
+(** [delete_event_callback g eh] removes a previously registered
+ event callback. See {!set_event_callback}. *)
";
generate_ocaml_structure_decls ();
(** {2 Object-oriented API}
This is an alternate way of calling the API using an object-oriented
- style, so you can use [g#add_drive filename] instead of
- [Guestfs.add_drive g filename]. Apart from the different style,
+ style, so you can use [g#add_drive_opts filename] instead of
+ [Guestfs.add_drive_opts g filename]. Apart from the different style,
it offers exactly the same functionality.
+ Calling [new guestfs ()] creates both the object and the handle.
+ The object and handle are closed either implicitly when the
+ object is garbage collected, or explicitly by calling the [g#close ()]
+ method.
+
+ You can get the {!Guestfs.t} handle by calling [g#ocaml_handle].
+
Note that methods that take no parameters (except the implicit handle)
get an extra unit [()] parameter. This is so you can create a
closure from the method easily. For example [g#get_verbose ()]
calls the method, whereas [g#get_verbose] is a function. *)
-class guestfs : object
+class guestfs : unit -> object
method close : unit -> unit
- method set_progress_callback : progress_cb -> unit
- method clear_progress_callback : unit -> unit
+ method set_event_callback : event_callback -> event list -> event_handle
+ method delete_event_callback : event_handle -> unit
+ method ocaml_handle : t
";
List.iter (
function
- | name, ((_, []) as style), _, _, _, _, _ ->
+ | name, ((_, [], []) as style), _, _, _, _, _ ->
pr " method %s : unit -> " name;
generate_ocaml_function_type style;
pr "\n"
pr "\n"
) all_functions_sorted;
- pr " end\n"
+ pr "end\n"
(* Generate the OCaml bindings implementation. *)
and generate_ocaml_ml () =
external create : unit -> t = \"ocaml_guestfs_create\"
external close : t -> unit = \"ocaml_guestfs_close\"
-type progress_cb = int -> int -> int64 -> int64 -> unit
+type event =
+";
+ List.iter (
+ fun (name, _) ->
+ pr " | EVENT_%s\n" (String.uppercase name)
+ ) events;
+ pr "\n";
+
+ pr "\
+let event_all = [
+";
+ List.iter (
+ fun (name, _) ->
+ pr " EVENT_%s;\n" (String.uppercase name)
+ ) events;
+
+ pr "\
+]
+
+type event_handle = int
-external set_progress_callback : t -> progress_cb -> unit
- = \"ocaml_guestfs_set_progress_callback\"
-external clear_progress_callback : t -> unit
- = \"ocaml_guestfs_clear_progress_callback\"
+type event_callback =
+ t -> event -> event_handle -> string -> int64 array -> unit
+
+external set_event_callback : t -> event_callback -> event list -> event_handle
+ = \"ocaml_guestfs_set_event_callback\"
+external delete_event_callback : t -> event_handle -> unit
+ = \"ocaml_guestfs_delete_event_callback\"
(* Give the exceptions names, so they can be raised from the C code. *)
let () =
(* OO API. *)
pr "
-class guestfs =
+class guestfs () =
let g = create () in
object
method close () = close g
- method set_progress_callback = set_progress_callback g
- method clear_progress_callback () = clear_progress_callback g
+ method set_event_callback = set_event_callback g
+ method delete_event_callback = delete_event_callback g
+ method ocaml_handle = g
";
List.iter (
function
- | name, (_, []), _, _, _, _, _ -> (* no params? add explicit unit *)
+ | name, (_, [], []), _, _, _, _, _ -> (* no params? add explicit unit *)
pr " method %s () = %s g\n" name name
| name, _, _, _, _, _, _ ->
pr " method %s = %s g\n" name name
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
+#include <stdint.h>
#include <caml/config.h>
#include <caml/alloc.h>
(* The wrappers. *)
List.iter (
- fun (name, style, _, _, _, _, _) ->
+ fun (name, (ret, args, optargs as style), _, _, _, _, _) ->
pr "/* Automatically generated wrapper for function\n";
pr " * ";
generate_ocaml_prototype name style;
pr " */\n";
pr "\n";
+ (* If we run into this situation, we'll need to change the
+ * bindings a little.
+ *)
+ if args = [] && optargs <> [] then
+ failwithf "ocaml bindings don't support args = [], optargs <> []";
+
let params =
- "gv" :: List.map (fun arg -> name_of_argt arg ^ "v") (snd style) in
+ "gv" ::
+ List.map (fun arg -> name_of_argt arg ^ "v") (optargs @ args) in
let needs_extra_vs =
- match fst style with RConstOptString _ -> true | _ -> false in
+ match ret with RConstOptString _ -> true | _ -> false in
pr "/* Emit prototype to appease gcc's -Wmissing-prototypes. */\n";
pr "CAMLprim value ocaml_guestfs_%s (value %s" name (List.hd params);
pr " char *%s = guestfs_safe_strdup (g, String_val (%sv));\n" n n
| OptString n ->
pr " char *%s =\n" n;
- pr " %sv != Val_int (0) ?" n;
+ pr " %sv != Val_int (0) ?\n" n;
pr " guestfs_safe_strdup (g, String_val (Field (%sv, 0))) : NULL;\n" n
| BufferIn n ->
pr " size_t %s_size = caml_string_length (%sv);\n" n n;
pr " int %s = Int_val (%sv);\n" n n
| Int64 n ->
pr " int64_t %s = Int64_val (%sv);\n" n n
- ) (snd style);
- let error_code =
- match fst style with
- | RErr -> pr " int r;\n"; "-1"
- | RInt _ -> pr " int r;\n"; "-1"
- | RInt64 _ -> pr " int64_t r;\n"; "-1"
- | RBool _ -> pr " int r;\n"; "-1"
- | RConstString _ | RConstOptString _ ->
- pr " const char *r;\n"; "NULL"
- | RString _ -> pr " char *r;\n"; "NULL"
- | RStringList _ ->
- pr " size_t i;\n";
- pr " char **r;\n";
- "NULL"
- | RStruct (_, typ) ->
- pr " struct guestfs_%s *r;\n" typ; "NULL"
- | RStructList (_, typ) ->
- pr " struct guestfs_%s_list *r;\n" typ; "NULL"
- | RHashtable _ ->
- pr " size_t i;\n";
- pr " char **r;\n";
- "NULL"
- | RBufferOut _ ->
- pr " char *r;\n";
- pr " size_t size;\n";
- "NULL" in
+ | Pointer (t, n) ->
+ pr " %s %s = (%s) (intptr_t) Int64_val (%sv);\n" t n t n
+ ) args;
+
+ (* Optional arguments. *)
+ if optargs <> [] then (
+ pr " struct guestfs_%s_argv optargs_s = { .bitmask = 0 };\n" name;
+ pr " struct guestfs_%s_argv *optargs = &optargs_s;\n" name;
+ let uc_name = String.uppercase name in
+ List.iter (
+ fun argt ->
+ let n = name_of_argt argt in
+ let uc_n = String.uppercase n in
+ pr " if (%sv != Val_int (0)) {\n" n;
+ pr " optargs_s.bitmask |= GUESTFS_%s_%s_BITMASK;\n" uc_name uc_n;
+ pr " optargs_s.%s = " n;
+ (match argt with
+ | Bool _ -> pr "Bool_val (Field (%sv, 0))" n
+ | Int _ -> pr "Int_val (Field (%sv, 0))" n
+ | Int64 _ -> pr "Int64_val (Field (%sv, 0))" n
+ | String _ ->
+ pr "guestfs_safe_strdup (g, String_val (Field (%sv, 0)))" n
+ | _ -> assert false
+ );
+ pr ";\n";
+ pr " }\n";
+ ) optargs
+ );
+
+ (match ret with
+ | RErr -> pr " int r;\n"
+ | RInt _ -> pr " int r;\n"
+ | RInt64 _ -> pr " int64_t r;\n"
+ | RBool _ -> pr " int r;\n"
+ | RConstString _ | RConstOptString _ ->
+ pr " const char *r;\n"
+ | RString _ -> pr " char *r;\n"
+ | RStringList _ ->
+ pr " size_t i;\n";
+ pr " char **r;\n"
+ | RStruct (_, typ) ->
+ pr " struct guestfs_%s *r;\n" typ
+ | RStructList (_, typ) ->
+ pr " struct guestfs_%s_list *r;\n" typ
+ | RHashtable _ ->
+ pr " size_t i;\n";
+ pr " char **r;\n"
+ | RBufferOut _ ->
+ pr " char *r;\n";
+ pr " size_t size;\n"
+ );
pr "\n";
pr " caml_enter_blocking_section ();\n";
- pr " r = guestfs_%s " name;
+ if optargs = [] then
+ pr " r = guestfs_%s " name
+ else
+ pr " r = guestfs_%s_argv " name;
generate_c_call_args ~handle:"g" style;
pr ";\n";
pr " caml_leave_blocking_section ();\n";
pr " free (%s);\n" n
| StringList n | DeviceList n ->
pr " ocaml_guestfs_free_strings (%s);\n" n;
- | Bool _ | Int _ | Int64 _ -> ()
- ) (snd style);
-
- pr " if (r == %s)\n" error_code;
- pr " ocaml_guestfs_raise_error (g, \"%s\");\n" name;
+ | Bool _ | Int _ | Int64 _ | Pointer _ -> ()
+ ) args;
+ List.iter (
+ function
+ | String n ->
+ pr " if (%sv != Val_int (0))\n" n;
+ pr " free ((char *) optargs_s.%s);\n" n
+ | Bool _ | Int _ | Int64 _
+ | Pathname _ | Device _ | Dev_or_Path _ | OptString _
+ | FileIn _ | FileOut _ | BufferIn _ | Key _
+ | StringList _ | DeviceList _ | Pointer _ -> ()
+ ) optargs;
+
+ (match errcode_of_ret ret with
+ | `CannotReturnError -> ()
+ | `ErrorIsMinusOne ->
+ pr " if (r == -1)\n";
+ pr " ocaml_guestfs_raise_error (g, \"%s\");\n" name;
+ | `ErrorIsNULL ->
+ pr " if (r == NULL)\n";
+ pr " ocaml_guestfs_raise_error (g, \"%s\");\n" name;
+ );
pr "\n";
- (match fst style with
+ (match ret with
| RErr -> pr " rv = Val_unit;\n"
| RInt _ -> pr " rv = Val_int (r);\n"
| RInt64 _ ->
pr "CAMLprim value ";
pr "ocaml_guestfs_%s_byte (value *argv, int argn);\n" name;
pr "CAMLprim value\n";
- pr "ocaml_guestfs_%s_byte (value *argv, int argn)\n" name;
+ pr "ocaml_guestfs_%s_byte (value *argv, int argn ATTRIBUTE_UNUSED)\n"
+ name;
pr "{\n";
pr " return ocaml_guestfs_%s (argv[0]" name;
iteri (fun i _ -> pr ", argv[%d]" i) (List.tl params);
generate_ocaml_function_type style;
if is_external then (
pr " = ";
- if List.length (snd style) + 1 > 5 then
+ let _, args, optargs = style in
+ if List.length args + List.length optargs + 1 > 5 then
pr "\"ocaml_guestfs_%s_byte\" " name;
pr "\"ocaml_guestfs_%s\"" name
);
pr "\n"
-and generate_ocaml_function_type style =
+and generate_ocaml_function_type (ret, args, optargs) =
+ List.iter (
+ function
+ | Bool n -> pr "?%s:bool -> " n
+ | Int n -> pr "?%s:int -> " n
+ | Int64 n -> pr "?%s:int64 -> " n
+ | String n -> pr "?%s:string -> " n
+ | _ -> assert false
+ ) optargs;
List.iter (
function
| Pathname _ | Device _ | Dev_or_Path _ | String _ | FileIn _ | FileOut _
| StringList _ | DeviceList _ -> pr "string array -> "
| Bool _ -> pr "bool -> "
| Int _ -> pr "int -> "
- | Int64 _ -> pr "int64 -> "
- ) (snd style);
- (match fst style with
+ | Int64 _ | Pointer _ -> pr "int64 -> "
+ ) args;
+ (match ret with
| RErr -> pr "unit" (* all errors are turned into exceptions *)
| RInt _ -> pr "int"
| RInt64 _ -> pr "int64"
git.annexia.org / libguestfs.git / blobdiff