inspect: Refuse to download software hive if it is huge.
[libguestfs.git] / generator / generator_ocaml.ml
1 (* libguestfs
2  * Copyright (C) 2009-2010 Red Hat Inc.
3  *
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.
8  *
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.
13  *
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
17  *)
18
19 (* Please read generator/README first. *)
20
21 open Printf
22
23 open Generator_types
24 open Generator_utils
25 open Generator_pr
26 open Generator_docstrings
27 open Generator_optgroups
28 open Generator_actions
29 open Generator_structs
30 open Generator_c
31
32 (* Generate the OCaml bindings interface. *)
33 let rec generate_ocaml_mli () =
34   generate_header OCamlStyle LGPLv2plus;
35
36   pr "\
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. *)
40
41 type t
42 (** A [guestfs_h] handle. *)
43
44 exception Error of string
45 (** This exception is raised when there is an error. *)
46
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
50     the function. *)
51
52 val create : unit -> t
53 (** Create a {!Guestfs.t} handle. *)
54
55 val close : t -> unit
56 (** Close the {!Guestfs.t} handle and free up all resources used
57     by it immediately.
58
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. *)
62
63 type progress_cb = int -> int -> int64 -> int64 -> unit
64
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.
69
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.
73
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. *)
80
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}. *)
84
85 ";
86   generate_ocaml_structure_decls ();
87
88   (* The actions. *)
89   List.iter (
90     fun (name, style, _, _, _, shortdesc, _) ->
91       generate_ocaml_prototype name style;
92       pr "(** %s *)\n" shortdesc;
93       pr "\n"
94   ) all_functions_sorted;
95
96   pr "\
97 (** {2 Object-oriented API}
98
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.
103
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 ()]
107     method.
108
109     You can get the {!Guestfs.t} handle by calling [g#ocaml_handle].
110
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. *)
115
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
121 ";
122
123   List.iter (
124     function
125     | name, ((_, [], []) as style), _, _, _, _, _ ->
126         pr "  method %s : unit -> " name;
127         generate_ocaml_function_type style;
128         pr "\n"
129     | name, style, _, _, _, _, _ ->
130         pr "  method %s : " name;
131         generate_ocaml_function_type style;
132         pr "\n"
133   ) all_functions_sorted;
134
135   pr "end\n"
136
137 (* Generate the OCaml bindings implementation. *)
138 and generate_ocaml_ml () =
139   generate_header OCamlStyle LGPLv2plus;
140
141   pr "\
142 type t
143
144 exception Error of string
145 exception Handle_closed of string
146
147 external create : unit -> t = \"ocaml_guestfs_create\"
148 external close : t -> unit = \"ocaml_guestfs_close\"
149
150 type progress_cb = int -> int -> int64 -> int64 -> unit
151
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\"
156
157 (* Give the exceptions names, so they can be raised from the C code. *)
158 let () =
159   Callback.register_exception \"ocaml_guestfs_error\" (Error \"\");
160   Callback.register_exception \"ocaml_guestfs_closed\" (Handle_closed \"\")
161
162 ";
163
164   generate_ocaml_structure_decls ();
165
166   (* The actions. *)
167   List.iter (
168     fun (name, style, _, _, _, shortdesc, _) ->
169       generate_ocaml_prototype ~is_external:true name style;
170   ) all_functions_sorted;
171
172   (* OO API. *)
173   pr "
174 class guestfs () =
175   let g = create () in
176   object
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
181 ";
182
183   List.iter (
184     function
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;
190
191   pr "  end\n"
192
193 (* Generate the OCaml bindings C implementation. *)
194 and generate_ocaml_c () =
195   generate_header CStyle LGPLv2plus;
196
197   pr "\
198 #include <stdio.h>
199 #include <stdlib.h>
200 #include <string.h>
201 #include <stdint.h>
202
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>
210
211 #include \"guestfs.h\"
212
213 #include \"guestfs_c.h\"
214
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
217  * ordered anyway.
218  */
219 static CAMLprim value
220 copy_table (char * const * argv)
221 {
222   CAMLparam0 ();
223   CAMLlocal5 (rv, pairv, kv, vv, cons);
224   size_t i;
225
226   rv = Val_int (0);
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);
235     rv = cons;
236     Store_field (cons, 0, pairv);
237   }
238
239   CAMLreturn (rv);
240 }
241
242 ";
243
244   (* Struct copy functions. *)
245
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;
249     pr "{\n";
250     pr "  CAMLparam0 ();\n";
251     pr "  CAMLlocal2 (rv, v);\n";
252     pr "  unsigned int i;\n";
253     pr "\n";
254     pr "  if (%ss->len == 0)\n" typ;
255     pr "    CAMLreturn (Atom (0));\n";
256     pr "  else {\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";
261     pr "    }\n";
262     pr "    CAMLreturn (rv);\n";
263     pr "  }\n";
264     pr "}\n";
265     pr "\n";
266   in
267
268   List.iter (
269     fun (typ, cols) ->
270       let has_optpercent_col =
271         List.exists (function (_, FOptPercent) -> true | _ -> false) cols in
272
273       pr "static CAMLprim value\n";
274       pr "copy_%s (const struct guestfs_%s *%s)\n" typ typ typ;
275       pr "{\n";
276       pr "  CAMLparam0 ();\n";
277       if has_optpercent_col then
278         pr "  CAMLlocal3 (rv, v, v2);\n"
279       else
280         pr "  CAMLlocal2 (rv, v);\n";
281       pr "\n";
282       pr "  rv = caml_alloc (%d, 0);\n" (List.length cols);
283       iteri (
284         fun i col ->
285           (match col with
286            | name, FString ->
287                pr "  v = caml_copy_string (%s->%s);\n" typ name
288            | name, FBuffer ->
289                pr "  v = caml_alloc_string (%s->%s_len);\n" typ name;
290                pr "  memcpy (String_val (v), %s->%s, %s->%s_len);\n"
291                  typ name typ name
292            | name, FUUID ->
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";
306            | name, FChar ->
307                pr "  v = Val_int (%s->%s);\n" typ name
308           );
309           pr "  Store_field (rv, %d, v);\n" i
310       ) cols;
311       pr "  CAMLreturn (rv);\n";
312       pr "}\n";
313       pr "\n";
314   ) structs;
315
316   (* Emit a copy_TYPE_list function definition only if that function is used. *)
317   List.iter (
318     function
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);
324
325   (* The wrappers. *)
326   List.iter (
327     fun (name, (ret, args, optargs as style), _, _, _, _, _) ->
328       pr "/* Automatically generated wrapper for function\n";
329       pr " * ";
330       generate_ocaml_prototype name style;
331       pr " */\n";
332       pr "\n";
333
334       (* If we run into this situation, we'll need to change the
335        * bindings a little.
336        *)
337       if args = [] && optargs <> [] then
338         failwithf "ocaml bindings don't support args = [], optargs <> []";
339
340       let params =
341         "gv" ::
342           List.map (fun arg -> name_of_argt arg ^ "v") (optargs @ args) in
343
344       let needs_extra_vs =
345         match ret with RConstOptString _ -> true | _ -> false in
346
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";
350       pr "\n";
351
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);
355       pr ")\n";
356       pr "{\n";
357
358       (match params with
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)
365        | ps ->
366            pr "  CAMLparam%d (%s);\n" (List.length ps) (String.concat ", " ps)
367       );
368       if not needs_extra_vs then
369         pr "  CAMLlocal1 (rv);\n"
370       else
371         pr "  CAMLlocal3 (rv, v, v2);\n";
372       pr "\n";
373
374       pr "  guestfs_h *g = Guestfs_val (gv);\n";
375       pr "  if (g == NULL)\n";
376       pr "    ocaml_guestfs_raise_closed (\"%s\");\n" name;
377       pr "\n";
378
379       List.iter (
380         function
381         | Pathname n
382         | Device n | Dev_or_Path n
383         | String n
384         | FileIn n
385         | FileOut n
386         | Key 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
389         | OptString 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
393         | BufferIn 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
398         | Bool n ->
399             pr "  int %s = Bool_val (%sv);\n" n n
400         | Int n ->
401             pr "  int %s = Int_val (%sv);\n" n n
402         | Int64 n ->
403             pr "  int64_t %s = Int64_val (%sv);\n" n n
404         | Pointer (t, n) ->
405             pr "  %s %s = (%s) (intptr_t) Int64_val (%sv);\n" t n t n
406       ) args;
407
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
413         List.iter (
414           fun argt ->
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;
420             (match argt with
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
424              | String _ ->
425                  pr "guestfs_safe_strdup (g, String_val (Field (%sv, 0)))" n
426              | _ -> assert false
427             );
428             pr ";\n";
429             pr "  }\n";
430         ) optargs
431       );
432
433       let error_code =
434         match ret with
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"
442         | RStringList _ ->
443             pr "  size_t i;\n";
444             pr "  char **r;\n";
445             "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"
450         | RHashtable _ ->
451             pr "  size_t i;\n";
452             pr "  char **r;\n";
453             "NULL"
454         | RBufferOut _ ->
455             pr "  char *r;\n";
456             pr "  size_t size;\n";
457             "NULL" in
458       pr "\n";
459
460       pr "  caml_enter_blocking_section ();\n";
461       if optargs = [] then
462         pr "  r = guestfs_%s " name
463       else
464         pr "  r = guestfs_%s_argv " name;
465       generate_c_call_args ~handle:"g" style;
466       pr ";\n";
467       pr "  caml_leave_blocking_section ();\n";
468
469       (* Free strings if we copied them above. *)
470       List.iter (
471         function
472         | Pathname n | Device n | Dev_or_Path n | String n | OptString n
473         | FileIn n | FileOut n | BufferIn n | Key n ->
474             pr "  free (%s);\n" n
475         | StringList n | DeviceList n ->
476             pr "  ocaml_guestfs_free_strings (%s);\n" n;
477         | Bool _ | Int _ | Int64 _ | Pointer _ -> ()
478       ) args;
479       List.iter (
480         function
481         | String n ->
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 _ -> ()
488       ) optargs;
489
490       pr "  if (r == %s)\n" error_code;
491       pr "    ocaml_guestfs_raise_error (g, \"%s\");\n" name;
492       pr "\n";
493
494       (match ret with
495        | RErr -> pr "  rv = Val_unit;\n"
496        | RInt _ -> pr "  rv = Val_int (r);\n"
497        | RInt64 _ ->
498            pr "  rv = caml_copy_int64 (r);\n"
499        | RBool _ -> pr "  rv = Val_bool (r);\n"
500        | RConstString _ ->
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";
509        | RString _ ->
510            pr "  rv = caml_copy_string (r);\n";
511            pr "  free (r);\n"
512        | RStringList _ ->
513            pr "  rv = caml_copy_string_array ((const char **) r);\n";
514            pr "  for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
515            pr "  free (r);\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;
522        | RHashtable _ ->
523            pr "  rv = copy_table (r);\n";
524            pr "  for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
525            pr "  free (r);\n";
526        | RBufferOut _ ->
527            pr "  rv = caml_alloc_string (size);\n";
528            pr "  memcpy (String_val (rv), r, size);\n";
529       );
530
531       pr "  CAMLreturn (rv);\n";
532       pr "}\n";
533       pr "\n";
534
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)\n" name;
541         pr "{\n";
542         pr "  return ocaml_guestfs_%s (argv[0]" name;
543         iteri (fun i _ -> pr ", argv[%d]" i) (List.tl params);
544         pr ");\n";
545         pr "}\n";
546         pr "\n"
547       )
548   ) all_functions_sorted
549
550 and generate_ocaml_structure_decls () =
551   List.iter (
552     fun (typ, cols) ->
553       pr "type %s = {\n" typ;
554       List.iter (
555         function
556         | name, FString -> pr "  %s : string;\n" name
557         | name, FBuffer -> pr "  %s : string;\n" name
558         | name, FUUID -> pr "  %s : string;\n" name
559         | name, (FBytes|FInt64|FUInt64) -> pr "  %s : int64;\n" name
560         | name, (FInt32|FUInt32) -> pr "  %s : int32;\n" name
561         | name, FChar -> pr "  %s : char;\n" name
562         | name, FOptPercent -> pr "  %s : float option;\n" name
563       ) cols;
564       pr "}\n";
565       pr "\n"
566   ) structs
567
568 and generate_ocaml_prototype ?(is_external = false) name style =
569   if is_external then pr "external " else pr "val ";
570   pr "%s : t -> " name;
571   generate_ocaml_function_type style;
572   if is_external then (
573     pr " = ";
574     let _, args, optargs = style in
575     if List.length args + List.length optargs + 1 > 5 then
576       pr "\"ocaml_guestfs_%s_byte\" " name;
577     pr "\"ocaml_guestfs_%s\"" name
578   );
579   pr "\n"
580
581 and generate_ocaml_function_type (ret, args, optargs) =
582   List.iter (
583     function
584     | Bool n -> pr "?%s:bool -> " n
585     | Int n -> pr "?%s:int -> " n
586     | Int64 n -> pr "?%s:int64 -> " n
587     | String n -> pr "?%s:string -> " n
588     | _ -> assert false
589   ) optargs;
590   List.iter (
591     function
592     | Pathname _ | Device _ | Dev_or_Path _ | String _ | FileIn _ | FileOut _
593     | BufferIn _ | Key _ -> pr "string -> "
594     | OptString _ -> pr "string option -> "
595     | StringList _ | DeviceList _ -> pr "string array -> "
596     | Bool _ -> pr "bool -> "
597     | Int _ -> pr "int -> "
598     | Int64 _ | Pointer _ -> pr "int64 -> "
599   ) args;
600   (match ret with
601    | RErr -> pr "unit" (* all errors are turned into exceptions *)
602    | RInt _ -> pr "int"
603    | RInt64 _ -> pr "int64"
604    | RBool _ -> pr "bool"
605    | RConstString _ -> pr "string"
606    | RConstOptString _ -> pr "string option"
607    | RString _ | RBufferOut _ -> pr "string"
608    | RStringList _ -> pr "string array"
609    | RStruct (_, typ) -> pr "%s" typ
610    | RStructList (_, typ) -> pr "%s array" typ
611    | RHashtable _ -> pr "(string * string) list"
612   )