X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=generator%2Fgenerator_ocaml.ml;h=aafc6cb683af92cbcd3b7d8851139a5ad7bb486c;hb=a711777bedcf64d814bb953ff8771858dbd7161b;hp=888a15274ecf02e90b2bdd103873e0756c682eaa;hpb=14490c3e1aac61c6ac90f28828896683f64f0dc9;p=libguestfs.git diff --git a/generator/generator_ocaml.ml b/generator/generator_ocaml.ml index 888a152..aafc6cb 100644 --- a/generator/generator_ocaml.ml +++ b/generator/generator_ocaml.ml @@ -1,5 +1,5 @@ (* 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 @@ -28,6 +28,7 @@ open Generator_optgroups open Generator_actions open Generator_structs open Generator_c +open Generator_events (* Generate the OCaml bindings interface. *) let rec generate_ocaml_mli () = @@ -60,27 +61,42 @@ val close : t -> unit 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. *) -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_handle +(** The opaque event handle which can be used to delete event callbacks. *) - 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. +type event_callback = + t -> event -> event_handle -> string -> int64 array -> unit +(** The event callback. *) + +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 delete_event_callback : t -> event_handle -> unit +(** [delete_event_callback g eh] removes a previously registered + event callback. See {!set_event_callback}. *) -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 user_cancel : t -> unit +(** Cancel current transfer. This is safe to call from OCaml signal + handlers and threads. *) "; generate_ocaml_structure_decls (); @@ -115,8 +131,9 @@ val clear_progress_callback : t -> unit 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 user_cancel : unit -> unit method ocaml_handle : t "; @@ -147,12 +164,36 @@ exception Handle_closed of string 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; -external set_progress_callback : t -> progress_cb -> unit - = \"ocaml_guestfs_set_progress_callback\" -external clear_progress_callback : t -> unit - = \"ocaml_guestfs_clear_progress_callback\" + pr "\ +] + +type event_handle = int + +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\" + +external user_cancel : t -> unit = \"ocaml_guestfs_user_cancel\" \"noalloc\" (* Give the exceptions names, so they can be raised from the C code. *) let () = @@ -175,8 +216,9 @@ 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 user_cancel () = user_cancel g method ocaml_handle = g "; @@ -198,6 +240,7 @@ and generate_ocaml_c () = #include #include #include +#include #include #include @@ -400,6 +443,8 @@ copy_table (char * const * argv) pr " int %s = Int_val (%sv);\n" n n | Int64 n -> pr " int64_t %s = Int64_val (%sv);\n" n n + | Pointer (t, n) -> + pr " %s %s = (%s) (intptr_t) Int64_val (%sv);\n" t n t n ) args; (* Optional arguments. *) @@ -427,31 +472,28 @@ copy_table (char * const * argv) ) optargs ); - let error_code = - match ret 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 + (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"; @@ -471,7 +513,7 @@ copy_table (char * const * argv) pr " free (%s);\n" n | StringList n | DeviceList n -> pr " ocaml_guestfs_free_strings (%s);\n" n; - | Bool _ | Int _ | Int64 _ -> () + | Bool _ | Int _ | Int64 _ | Pointer _ -> () ) args; List.iter ( function @@ -481,11 +523,18 @@ copy_table (char * const * argv) | Bool _ | Int _ | Int64 _ | Pathname _ | Device _ | Dev_or_Path _ | OptString _ | FileIn _ | FileOut _ | BufferIn _ | Key _ - | StringList _ | DeviceList _ -> () + | StringList _ | DeviceList _ | Pointer _ -> () ) optargs; - pr " if (r == %s)\n" error_code; - pr " ocaml_guestfs_raise_error (g, \"%s\");\n" name; + (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 ret with @@ -534,7 +583,8 @@ copy_table (char * const * argv) 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); @@ -592,7 +642,7 @@ and generate_ocaml_function_type (ret, args, optargs) = | StringList _ | DeviceList _ -> pr "string array -> " | Bool _ -> pr "bool -> " | Int _ -> pr "int -> " - | Int64 _ -> pr "int64 -> " + | Int64 _ | Pointer _ -> pr "int64 -> " ) args; (match ret with | RErr -> pr "unit" (* all errors are turned into exceptions *)