generate_ocaml_prototype name style;
pr "(** %s *)\n" shortdesc;
pr "\n"
- ) all_functions_sorted
+ ) all_functions_sorted;
+
+ pr "\
+(** {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_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 : unit -> object
+ method close : unit -> unit
+ method set_progress_callback : progress_cb -> unit
+ method clear_progress_callback : unit -> unit
+ method ocaml_handle : t
+";
+
+ List.iter (
+ function
+ | name, ((_, [], []) as style), _, _, _, _, _ ->
+ pr " method %s : unit -> " name;
+ generate_ocaml_function_type style;
+ pr "\n"
+ | name, style, _, _, _, _, _ ->
+ pr " method %s : " name;
+ generate_ocaml_function_type style;
+ pr "\n"
+ ) all_functions_sorted;
+
+ pr "end\n"
(* Generate the OCaml bindings implementation. *)
and generate_ocaml_ml () =
List.iter (
fun (name, style, _, _, _, shortdesc, _) ->
generate_ocaml_prototype ~is_external:true name style;
- ) all_functions_sorted
+ ) all_functions_sorted;
+
+ (* OO API. *)
+ pr "
+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 ocaml_handle = g
+";
+
+ List.iter (
+ function
+ | name, (_, [], []), _, _, _, _, _ -> (* no params? add explicit unit *)
+ pr " method %s () = %s g\n" name name
+ | name, _, _, _, _, _, _ ->
+ pr " method %s = %s g\n" name name
+ ) all_functions_sorted;
+
+ pr " end\n"
(* Generate the OCaml bindings C implementation. *)
and generate_ocaml_c () =
(* 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);
+ ) 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
+ );
+
let error_code =
- match fst style with
+ match ret with
| RErr -> pr " int r;\n"; "-1"
| RInt _ -> pr " int r;\n"; "-1"
| RInt64 _ -> pr " int64_t r;\n"; "-1"
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";
| StringList n | DeviceList n ->
pr " ocaml_guestfs_free_strings (%s);\n" n;
| Bool _ | Int _ | Int64 _ -> ()
- ) (snd style);
+ ) 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 _ -> ()
+ ) optargs;
pr " if (r == %s)\n" error_code;
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 _ ->
and generate_ocaml_prototype ?(is_external = false) name style =
if is_external then pr "external " else pr "val ";
pr "%s : t -> " name;
+ generate_ocaml_function_type style;
+ if is_external then (
+ pr " = ";
+ 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 (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 _
| Bool _ -> pr "bool -> "
| Int _ -> pr "int -> "
| Int64 _ -> pr "int64 -> "
- ) (snd style);
- (match fst style with
+ ) args;
+ (match ret with
| RErr -> pr "unit" (* all errors are turned into exceptions *)
| RInt _ -> pr "int"
| RInt64 _ -> pr "int64"
| RStruct (_, typ) -> pr "%s" typ
| RStructList (_, typ) -> pr "%s array" typ
| RHashtable _ -> pr "(string * string) list"
- );
- if is_external then (
- pr " = ";
- if List.length (snd style) + 1 > 5 then
- pr "\"ocaml_guestfs_%s_byte\" " name;
- pr "\"ocaml_guestfs_%s\"" name
- );
- pr "\n"
+ )
git.annexia.org / libguestfs.git / blobdiff