X-Git-Url: http://git.annexia.org/?p=libguestfs.git;a=blobdiff_plain;f=generator%2Fgenerator_ocaml.ml;h=aafc6cb683af92cbcd3b7d8851139a5ad7bb486c;hp=e5dfc686a9503f2e02d83a84d985bc2de096ea7d;hb=60dd9494f0890dcc6c9a1cce311edc92cb992290;hpb=67636f721056d2f2250b0ff8acd981a0294536a9 diff --git a/generator/generator_ocaml.ml b/generator/generator_ocaml.ml index e5dfc68..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. *) + +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}. *) + +val user_cancel : t -> unit +(** Cancel current transfer. This is safe to call from OCaml signal + handlers and threads. *) "; generate_ocaml_structure_decls (); @@ -97,24 +113,33 @@ val clear_progress_callback : t -> unit (** {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 user_cancel : unit -> 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" @@ -124,7 +149,7 @@ class guestfs : object pr "\n" ) all_functions_sorted; - pr " end\n" + pr "end\n" (* Generate the OCaml bindings implementation. *) and generate_ocaml_ml () = @@ -139,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; + + 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\" + +external user_cancel : t -> unit = \"ocaml_guestfs_user_cancel\" \"noalloc\" (* Give the exceptions names, so they can be raised from the C code. *) let () = @@ -163,17 +212,19 @@ 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 user_cancel () = user_cancel 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 @@ -189,6 +240,7 @@ and generate_ocaml_c () = #include #include #include +#include #include #include @@ -314,18 +366,25 @@ copy_table (char * const * argv) (* 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); @@ -371,7 +430,7 @@ copy_table (char * const * argv) 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; @@ -384,36 +443,64 @@ 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 - ) (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"; @@ -426,14 +513,31 @@ 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 _ -> () - ) (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 _ -> @@ -479,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); @@ -513,13 +618,22 @@ and generate_ocaml_prototype ?(is_external = false) name style = 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 _ @@ -528,9 +642,9 @@ and generate_ocaml_function_type style = | 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"