2 * Copyright (C) 2009-2010 Red Hat Inc.
4 * This program is free software; you can redistribute it and/or modify
5 * it under the terms of the GNU General Public License as published by
6 * the Free Software Foundation; either version 2 of the License, or
7 * (at your option) any later version.
9 * This program is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 * GNU General Public License for more details.
14 * You should have received a copy of the GNU General Public License
15 * along with this program; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
19 (* Please read generator/README first. *)
26 open Generator_docstrings
27 open Generator_optgroups
28 open Generator_actions
29 open Generator_structs
32 (* Generate the OCaml bindings interface. *)
33 let rec generate_ocaml_mli () =
34 generate_header OCamlStyle LGPLv2plus;
37 (** For API documentation you should refer to the C API
38 in the guestfs(3) manual page. The OCaml API uses almost
39 exactly the same calls. *)
42 (** A [guestfs_h] handle. *)
44 exception Error of string
45 (** This exception is raised when there is an error. *)
47 exception Handle_closed of string
48 (** This exception is raised if you use a {!Guestfs.t} handle
49 after calling {!close} on it. The string is the name of
52 val create : unit -> t
53 (** Create a {!Guestfs.t} handle. *)
56 (** Close the {!Guestfs.t} handle and free up all resources used
59 Handles are closed by the garbage collector when they become
60 unreferenced, but callers can call this in order to provide
61 predictable cleanup. *)
63 type progress_cb = int -> int -> int64 -> int64 -> unit
65 val set_progress_callback : t -> progress_cb -> unit
66 (** [set_progress_callback g f] sets [f] as the progress callback function.
67 For some long-running functions, [f] will be called repeatedly
68 during the function with progress updates.
70 The callback is [f proc_nr serial position total]. See
71 the description of [guestfs_set_progress_callback] in guestfs(3)
72 for the meaning of these four numbers.
74 Note that if the closure captures a reference to the handle,
75 this reference will prevent the handle from being
76 automatically closed by the garbage collector. There are
77 three ways to avoid this: be careful not to capture the handle
78 in the closure, or use a weak reference, or call
79 {!Guestfs.clear_progress_callback} to remove the reference. *)
81 val clear_progress_callback : t -> unit
82 (** [clear_progress_callback g] removes any progress callback function
83 associated with the handle. See {!Guestfs.set_progress_callback}. *)
86 generate_ocaml_structure_decls ();
90 fun (name, style, _, _, _, shortdesc, _) ->
91 generate_ocaml_prototype name style;
92 pr "(** %s *)\n" shortdesc;
94 ) all_functions_sorted;
97 (** {2 Object-oriented API}
99 This is an alternate way of calling the API using an object-oriented
100 style, so you can use [g#add_drive_opts filename] instead of
101 [Guestfs.add_drive_opts g filename]. Apart from the different style,
102 it offers exactly the same functionality.
104 Calling [new guestfs ()] creates both the object and the handle.
105 The object and handle are closed either implicitly when the
106 object is garbage collected, or explicitly by calling the [g#close ()]
109 You can get the {!Guestfs.t} handle by calling [g#ocaml_handle].
111 Note that methods that take no parameters (except the implicit handle)
112 get an extra unit [()] parameter. This is so you can create a
113 closure from the method easily. For example [g#get_verbose ()]
114 calls the method, whereas [g#get_verbose] is a function. *)
116 class guestfs : unit -> object
117 method close : unit -> unit
118 method set_progress_callback : progress_cb -> unit
119 method clear_progress_callback : unit -> unit
120 method ocaml_handle : t
125 | name, ((_, [], []) as style), _, _, _, _, _ ->
126 pr " method %s : unit -> " name;
127 generate_ocaml_function_type style;
129 | name, style, _, _, _, _, _ ->
130 pr " method %s : " name;
131 generate_ocaml_function_type style;
133 ) all_functions_sorted;
137 (* Generate the OCaml bindings implementation. *)
138 and generate_ocaml_ml () =
139 generate_header OCamlStyle LGPLv2plus;
144 exception Error of string
145 exception Handle_closed of string
147 external create : unit -> t = \"ocaml_guestfs_create\"
148 external close : t -> unit = \"ocaml_guestfs_close\"
150 type progress_cb = int -> int -> int64 -> int64 -> unit
152 external set_progress_callback : t -> progress_cb -> unit
153 = \"ocaml_guestfs_set_progress_callback\"
154 external clear_progress_callback : t -> unit
155 = \"ocaml_guestfs_clear_progress_callback\"
157 (* Give the exceptions names, so they can be raised from the C code. *)
159 Callback.register_exception \"ocaml_guestfs_error\" (Error \"\");
160 Callback.register_exception \"ocaml_guestfs_closed\" (Handle_closed \"\")
164 generate_ocaml_structure_decls ();
168 fun (name, style, _, _, _, shortdesc, _) ->
169 generate_ocaml_prototype ~is_external:true name style;
170 ) all_functions_sorted;
177 method close () = close g
178 method set_progress_callback = set_progress_callback g
179 method clear_progress_callback () = clear_progress_callback g
180 method ocaml_handle = g
185 | name, (_, [], []), _, _, _, _, _ -> (* no params? add explicit unit *)
186 pr " method %s () = %s g\n" name name
187 | name, _, _, _, _, _, _ ->
188 pr " method %s = %s g\n" name name
189 ) all_functions_sorted;
193 (* Generate the OCaml bindings C implementation. *)
194 and generate_ocaml_c () =
195 generate_header CStyle LGPLv2plus;
203 #include <caml/config.h>
204 #include <caml/alloc.h>
205 #include <caml/callback.h>
206 #include <caml/fail.h>
207 #include <caml/memory.h>
208 #include <caml/mlvalues.h>
209 #include <caml/signals.h>
211 #include \"guestfs.h\"
213 #include \"guestfs_c.h\"
215 /* Copy a hashtable of string pairs into an assoc-list. We return
216 * the list in reverse order, but hashtables aren't supposed to be
219 static CAMLprim value
220 copy_table (char * const * argv)
223 CAMLlocal5 (rv, pairv, kv, vv, cons);
227 for (i = 0; argv[i] != NULL; i += 2) {
228 kv = caml_copy_string (argv[i]);
229 vv = caml_copy_string (argv[i+1]);
230 pairv = caml_alloc (2, 0);
231 Store_field (pairv, 0, kv);
232 Store_field (pairv, 1, vv);
233 cons = caml_alloc (2, 0);
234 Store_field (cons, 1, rv);
236 Store_field (cons, 0, pairv);
244 (* Struct copy functions. *)
246 let emit_ocaml_copy_list_function typ =
247 pr "static CAMLprim value\n";
248 pr "copy_%s_list (const struct guestfs_%s_list *%ss)\n" typ typ typ;
250 pr " CAMLparam0 ();\n";
251 pr " CAMLlocal2 (rv, v);\n";
252 pr " unsigned int i;\n";
254 pr " if (%ss->len == 0)\n" typ;
255 pr " CAMLreturn (Atom (0));\n";
257 pr " rv = caml_alloc (%ss->len, 0);\n" typ;
258 pr " for (i = 0; i < %ss->len; ++i) {\n" typ;
259 pr " v = copy_%s (&%ss->val[i]);\n" typ typ;
260 pr " caml_modify (&Field (rv, i), v);\n";
262 pr " CAMLreturn (rv);\n";
270 let has_optpercent_col =
271 List.exists (function (_, FOptPercent) -> true | _ -> false) cols in
273 pr "static CAMLprim value\n";
274 pr "copy_%s (const struct guestfs_%s *%s)\n" typ typ typ;
276 pr " CAMLparam0 ();\n";
277 if has_optpercent_col then
278 pr " CAMLlocal3 (rv, v, v2);\n"
280 pr " CAMLlocal2 (rv, v);\n";
282 pr " rv = caml_alloc (%d, 0);\n" (List.length cols);
287 pr " v = caml_copy_string (%s->%s);\n" typ name
289 pr " v = caml_alloc_string (%s->%s_len);\n" typ name;
290 pr " memcpy (String_val (v), %s->%s, %s->%s_len);\n"
293 pr " v = caml_alloc_string (32);\n";
294 pr " memcpy (String_val (v), %s->%s, 32);\n" typ name
295 | name, (FBytes|FInt64|FUInt64) ->
296 pr " v = caml_copy_int64 (%s->%s);\n" typ name
297 | name, (FInt32|FUInt32) ->
298 pr " v = caml_copy_int32 (%s->%s);\n" typ name
299 | name, FOptPercent ->
300 pr " if (%s->%s >= 0) { /* Some %s */\n" typ name name;
301 pr " v2 = caml_copy_double (%s->%s);\n" typ name;
302 pr " v = caml_alloc (1, 0);\n";
303 pr " Store_field (v, 0, v2);\n";
304 pr " } else /* None */\n";
305 pr " v = Val_int (0);\n";
307 pr " v = Val_int (%s->%s);\n" typ name
309 pr " Store_field (rv, %d, v);\n" i
311 pr " CAMLreturn (rv);\n";
316 (* Emit a copy_TYPE_list function definition only if that function is used. *)
319 | typ, (RStructListOnly | RStructAndList) ->
320 (* generate the function for typ *)
321 emit_ocaml_copy_list_function typ
322 | typ, _ -> () (* empty *)
323 ) (rstructs_used_by all_functions);
327 fun (name, (ret, args, optargs as style), _, _, _, _, _) ->
328 pr "/* Automatically generated wrapper for function\n";
330 generate_ocaml_prototype name style;
334 (* If we run into this situation, we'll need to change the
337 if args = [] && optargs <> [] then
338 failwithf "ocaml bindings don't support args = [], optargs <> []";
342 List.map (fun arg -> name_of_argt arg ^ "v") (optargs @ args) in
345 match ret with RConstOptString _ -> true | _ -> false in
347 pr "/* Emit prototype to appease gcc's -Wmissing-prototypes. */\n";
348 pr "CAMLprim value ocaml_guestfs_%s (value %s" name (List.hd params);
349 List.iter (pr ", value %s") (List.tl params); pr ");\n";
352 pr "CAMLprim value\n";
353 pr "ocaml_guestfs_%s (value %s" name (List.hd params);
354 List.iter (pr ", value %s") (List.tl params);
359 | [p1; p2; p3; p4; p5] ->
360 pr " CAMLparam5 (%s);\n" (String.concat ", " params)
361 | p1 :: p2 :: p3 :: p4 :: p5 :: rest ->
362 pr " CAMLparam5 (%s);\n" (String.concat ", " [p1; p2; p3; p4; p5]);
363 pr " CAMLxparam%d (%s);\n"
364 (List.length rest) (String.concat ", " rest)
366 pr " CAMLparam%d (%s);\n" (List.length ps) (String.concat ", " ps)
368 if not needs_extra_vs then
369 pr " CAMLlocal1 (rv);\n"
371 pr " CAMLlocal3 (rv, v, v2);\n";
374 pr " guestfs_h *g = Guestfs_val (gv);\n";
375 pr " if (g == NULL)\n";
376 pr " ocaml_guestfs_raise_closed (\"%s\");\n" name;
382 | Device n | Dev_or_Path n
387 (* Copy strings in case the GC moves them: RHBZ#604691 *)
388 pr " char *%s = guestfs_safe_strdup (g, String_val (%sv));\n" n n
390 pr " char *%s =\n" n;
391 pr " %sv != Val_int (0) ?\n" n;
392 pr " guestfs_safe_strdup (g, String_val (Field (%sv, 0))) : NULL;\n" n
394 pr " size_t %s_size = caml_string_length (%sv);\n" n n;
395 pr " char *%s = guestfs_safe_memdup (g, String_val (%sv), %s_size);\n" n n n
396 | StringList n | DeviceList n ->
397 pr " char **%s = ocaml_guestfs_strings_val (g, %sv);\n" n n
399 pr " int %s = Bool_val (%sv);\n" n n
401 pr " int %s = Int_val (%sv);\n" n n
403 pr " int64_t %s = Int64_val (%sv);\n" n n
405 pr " %s %s = (%s) (intptr_t) Int64_val (%sv);\n" t n t n
408 (* Optional arguments. *)
409 if optargs <> [] then (
410 pr " struct guestfs_%s_argv optargs_s = { .bitmask = 0 };\n" name;
411 pr " struct guestfs_%s_argv *optargs = &optargs_s;\n" name;
412 let uc_name = String.uppercase name in
415 let n = name_of_argt argt in
416 let uc_n = String.uppercase n in
417 pr " if (%sv != Val_int (0)) {\n" n;
418 pr " optargs_s.bitmask |= GUESTFS_%s_%s_BITMASK;\n" uc_name uc_n;
419 pr " optargs_s.%s = " n;
421 | Bool _ -> pr "Bool_val (Field (%sv, 0))" n
422 | Int _ -> pr "Int_val (Field (%sv, 0))" n
423 | Int64 _ -> pr "Int64_val (Field (%sv, 0))" n
425 pr "guestfs_safe_strdup (g, String_val (Field (%sv, 0)))" n
435 | RErr -> pr " int r;\n"; "-1"
436 | RInt _ -> pr " int r;\n"; "-1"
437 | RInt64 _ -> pr " int64_t r;\n"; "-1"
438 | RBool _ -> pr " int r;\n"; "-1"
439 | RConstString _ | RConstOptString _ ->
440 pr " const char *r;\n"; "NULL"
441 | RString _ -> pr " char *r;\n"; "NULL"
446 | RStruct (_, typ) ->
447 pr " struct guestfs_%s *r;\n" typ; "NULL"
448 | RStructList (_, typ) ->
449 pr " struct guestfs_%s_list *r;\n" typ; "NULL"
456 pr " size_t size;\n";
460 pr " caml_enter_blocking_section ();\n";
462 pr " r = guestfs_%s " name
464 pr " r = guestfs_%s_argv " name;
465 generate_c_call_args ~handle:"g" style;
467 pr " caml_leave_blocking_section ();\n";
469 (* Free strings if we copied them above. *)
472 | Pathname n | Device n | Dev_or_Path n | String n | OptString n
473 | FileIn n | FileOut n | BufferIn n | Key n ->
475 | StringList n | DeviceList n ->
476 pr " ocaml_guestfs_free_strings (%s);\n" n;
477 | Bool _ | Int _ | Int64 _ | Pointer _ -> ()
482 pr " if (%sv != Val_int (0))\n" n;
483 pr " free ((char *) optargs_s.%s);\n" n
484 | Bool _ | Int _ | Int64 _
485 | Pathname _ | Device _ | Dev_or_Path _ | OptString _
486 | FileIn _ | FileOut _ | BufferIn _ | Key _
487 | StringList _ | DeviceList _ | Pointer _ -> ()
490 pr " if (r == %s)\n" error_code;
491 pr " ocaml_guestfs_raise_error (g, \"%s\");\n" name;
495 | RErr -> pr " rv = Val_unit;\n"
496 | RInt _ -> pr " rv = Val_int (r);\n"
498 pr " rv = caml_copy_int64 (r);\n"
499 | RBool _ -> pr " rv = Val_bool (r);\n"
501 pr " rv = caml_copy_string (r);\n"
502 | RConstOptString _ ->
503 pr " if (r) { /* Some string */\n";
504 pr " v = caml_alloc (1, 0);\n";
505 pr " v2 = caml_copy_string (r);\n";
506 pr " Store_field (v, 0, v2);\n";
507 pr " } else /* None */\n";
508 pr " v = Val_int (0);\n";
510 pr " rv = caml_copy_string (r);\n";
513 pr " rv = caml_copy_string_array ((const char **) r);\n";
514 pr " for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
516 | RStruct (_, typ) ->
517 pr " rv = copy_%s (r);\n" typ;
518 pr " guestfs_free_%s (r);\n" typ;
519 | RStructList (_, typ) ->
520 pr " rv = copy_%s_list (r);\n" typ;
521 pr " guestfs_free_%s_list (r);\n" typ;
523 pr " rv = copy_table (r);\n";
524 pr " for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
527 pr " rv = caml_alloc_string (size);\n";
528 pr " memcpy (String_val (rv), r, size);\n";
531 pr " CAMLreturn (rv);\n";
535 if List.length params > 5 then (
536 pr "/* Emit prototype to appease gcc's -Wmissing-prototypes. */\n";
537 pr "CAMLprim value ";
538 pr "ocaml_guestfs_%s_byte (value *argv, int argn);\n" name;
539 pr "CAMLprim value\n";
540 pr "ocaml_guestfs_%s_byte (value *argv, int argn ATTRIBUTE_UNUSED)\n"
543 pr " return ocaml_guestfs_%s (argv[0]" name;
544 iteri (fun i _ -> pr ", argv[%d]" i) (List.tl params);
549 ) all_functions_sorted
551 and generate_ocaml_structure_decls () =
554 pr "type %s = {\n" typ;
557 | name, FString -> pr " %s : string;\n" name
558 | name, FBuffer -> pr " %s : string;\n" name
559 | name, FUUID -> pr " %s : string;\n" name
560 | name, (FBytes|FInt64|FUInt64) -> pr " %s : int64;\n" name
561 | name, (FInt32|FUInt32) -> pr " %s : int32;\n" name
562 | name, FChar -> pr " %s : char;\n" name
563 | name, FOptPercent -> pr " %s : float option;\n" name
569 and generate_ocaml_prototype ?(is_external = false) name style =
570 if is_external then pr "external " else pr "val ";
571 pr "%s : t -> " name;
572 generate_ocaml_function_type style;
573 if is_external then (
575 let _, args, optargs = style in
576 if List.length args + List.length optargs + 1 > 5 then
577 pr "\"ocaml_guestfs_%s_byte\" " name;
578 pr "\"ocaml_guestfs_%s\"" name
582 and generate_ocaml_function_type (ret, args, optargs) =
585 | Bool n -> pr "?%s:bool -> " n
586 | Int n -> pr "?%s:int -> " n
587 | Int64 n -> pr "?%s:int64 -> " n
588 | String n -> pr "?%s:string -> " n
593 | Pathname _ | Device _ | Dev_or_Path _ | String _ | FileIn _ | FileOut _
594 | BufferIn _ | Key _ -> pr "string -> "
595 | OptString _ -> pr "string option -> "
596 | StringList _ | DeviceList _ -> pr "string array -> "
597 | Bool _ -> pr "bool -> "
598 | Int _ -> pr "int -> "
599 | Int64 _ | Pointer _ -> pr "int64 -> "
602 | RErr -> pr "unit" (* all errors are turned into exceptions *)
604 | RInt64 _ -> pr "int64"
605 | RBool _ -> pr "bool"
606 | RConstString _ -> pr "string"
607 | RConstOptString _ -> pr "string option"
608 | RString _ | RBufferOut _ -> pr "string"
609 | RStringList _ -> pr "string array"
610 | RStruct (_, typ) -> pr "%s" typ
611 | RStructList (_, typ) -> pr "%s array" typ
612 | RHashtable _ -> pr "(string * string) list"