X-Git-Url: http://git.annexia.org/?p=libguestfs.git;a=blobdiff_plain;f=generator%2Fgenerator_ocaml.ml;h=888a15274ecf02e90b2bdd103873e0756c682eaa;hp=a4e4fa99c7617f01a9935caebb3f7a64f096d435;hb=7badf512f6859c2585c434a6d3f5772979bb5131;hpb=04d8209077d2227eb1d42695ba71147f78987050 diff --git a/generator/generator_ocaml.ml b/generator/generator_ocaml.ml index a4e4fa9..888a152 100644 --- a/generator/generator_ocaml.ml +++ b/generator/generator_ocaml.ml @@ -91,7 +91,48 @@ val clear_progress_callback : t -> unit 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 () = @@ -126,7 +167,28 @@ let () = 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 () = @@ -261,18 +323,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); @@ -318,7 +387,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; @@ -331,9 +400,35 @@ 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); + ) 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" @@ -360,7 +455,10 @@ copy_table (char * const * argv) 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"; @@ -374,13 +472,23 @@ copy_table (char * const * argv) | 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 _ -> @@ -457,6 +565,25 @@ and generate_ocaml_structure_decls () = 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 _ @@ -466,8 +593,8 @@ and generate_ocaml_prototype ?(is_external = false) name style = | 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" @@ -479,11 +606,4 @@ and generate_ocaml_prototype ?(is_external = false) name style = | 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" + )