ubuntu: Add extra suppressions for libnl.1 leaks.
[libguestfs.git] / generator / generator_erlang.ml
1 (* libguestfs
2  * Copyright (C) 2011 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 open Generator_events
32
33 let rec generate_erlang_erl () =
34   generate_header ErlangStyle LGPLv2plus;
35
36   pr "-module(guestfs).\n";
37   pr "\n";
38   pr "-export([create/0, create/1, close/1, init/1]).\n";
39   pr "\n";
40
41   (* Export the public actions. *)
42   List.iter (
43     fun (name, (_, args, optargs), _, _, _, _, _) ->
44       let nr_args = List.length args in
45       if optargs = [] then
46         pr "-export([%s/%d]).\n" name (nr_args+1)
47       else
48         pr "-export([%s/%d, %s/%d]).\n" name (nr_args+1) name (nr_args+2)
49   ) all_functions_sorted;
50
51   pr "\n";
52
53   pr "\
54 create() ->
55   create(\"erl-guestfs\").
56
57 create(ExtProg) ->
58   G = spawn(?MODULE, init, [ExtProg]),
59   {ok, G}.
60
61 close(G) ->
62   G ! close,
63   ok.
64
65 call_port(G, Args) ->
66   G ! {call, self(), Args},
67   receive
68     {guestfs, Result} ->
69       Result
70   end.
71
72 init(ExtProg) ->
73   process_flag(trap_exit, true),
74   Port = open_port({spawn, ExtProg}, [{packet, 4}, binary]),
75   loop(Port).
76 loop(Port) ->
77   receive
78     {call, Caller, Args} ->
79       Port ! { self(), {command, term_to_binary(Args)}},
80       receive
81         {Port, {data, Result}} ->
82           Caller ! { guestfs, binary_to_term(Result)}
83       end,
84       loop(Port);
85     close ->
86       port_close(Port),
87       exit(normal);
88     { 'EXIT', Port, _ } ->
89       exit(port_terminated)
90   end.
91
92 ";
93
94   (* These bindings just marshal the parameters and call the back-end
95    * process which dispatches them to the port.
96    *)
97   List.iter (
98     fun (name, (_, args, optargs), _, _, _, _, _) ->
99       pr "%s(G" name;
100       List.iter (
101         fun arg ->
102           pr ", %s" (String.capitalize (name_of_argt arg))
103       ) args;
104       if optargs <> [] then
105         pr ", Optargs";
106       pr ") ->\n";
107
108       pr "  call_port(G, {%s" name;
109       List.iter (
110         fun arg ->
111           pr ", %s" (String.capitalize (name_of_argt arg))
112       ) args;
113       if optargs <> [] then
114         pr ", Optargs";
115       pr "}).\n";
116
117       (* For functions with optional arguments, make a variant that
118        * has no optarg array, which just calls the function above with
119        * an empty list as the final arg.
120        *)
121       if optargs <> [] then (
122         pr "%s(G" name;
123         List.iter (
124           fun arg ->
125             pr ", %s" (String.capitalize (name_of_argt arg))
126         ) args;
127         pr ") ->\n";
128
129         pr "  %s(G" name;
130         List.iter (
131           fun arg ->
132             pr ", %s" (String.capitalize (name_of_argt arg))
133         ) args;
134         pr ", []";
135         pr ").\n"
136       );
137
138       pr "\n"
139   ) all_functions_sorted
140
141 and generate_erlang_c () =
142   generate_header CStyle GPLv2plus;
143
144   pr "\
145 #include <stdio.h>
146 #include <stdlib.h>
147 #include <string.h>
148 #include <errno.h>
149
150 #include <erl_interface.h>
151 #include <ei.h>
152
153 #include \"guestfs.h\"
154
155 extern guestfs_h *g;
156
157 extern ETERM *dispatch (ETERM *message);
158 extern int atom_equals (ETERM *atom, const char *name);
159 extern ETERM *make_error (const char *funname);
160 extern ETERM *unknown_optarg (const char *funname, ETERM *optargname);
161 extern ETERM *unknown_function (ETERM *fun);
162 extern ETERM *make_string_list (char **r);
163 extern ETERM *make_table (char **r);
164 extern ETERM *make_bool (int r);
165 extern char **get_string_list (ETERM *term);
166 extern int get_bool (ETERM *term);
167 extern void free_strings (char **r);
168
169 #define ARG(i) (ERL_TUPLE_ELEMENT(message,(i)+1))
170
171 ";
172
173   (* Struct copy functions. *)
174   let emit_copy_list_function typ =
175     pr "static ETERM *\n";
176     pr "make_%s_list (const struct guestfs_%s_list *%ss)\n" typ typ typ;
177     pr "{\n";
178     pr "  ETERM *t[%ss->len];\n" typ;
179     pr "  size_t i;\n";
180     pr "\n";
181     pr "  for (i = 0; i < %ss->len; ++i)\n" typ;
182     pr "    t[i] = make_%s (&%ss->val[i]);\n" typ typ;
183     pr "\n";
184     pr "  return erl_mk_list (t, %ss->len);\n" typ;
185     pr "}\n";
186     pr "\n";
187   in
188
189   List.iter (
190     fun (typ, cols) ->
191       pr "static ETERM *\n";
192       pr "make_%s (const struct guestfs_%s *%s)\n" typ typ typ;
193       pr "{\n";
194       pr "  ETERM *t[%d];\n" (List.length cols);
195       pr "\n";
196       iteri (
197         fun i col ->
198           (match col with
199            | name, FString ->
200                pr "  t[%d] = erl_mk_string (%s->%s);\n" i typ name
201            | name, FBuffer ->
202                pr "  t[%d] = erl_mk_estring (%s->%s, %s->%s_len);\n"
203                  i typ name typ name
204            | name, FUUID ->
205                pr "  t[%d] = erl_mk_estring (%s->%s, 32);\n" i typ name
206            | name, (FBytes|FInt64|FUInt64) ->
207                pr "  t[%d] = erl_mk_longlong (%s->%s);\n" i typ name
208            | name, (FInt32|FUInt32) ->
209                pr "  t[%d] = erl_mk_int (%s->%s);\n" i typ name
210            | name, FOptPercent ->
211                pr "  if (%s->%s >= 0)\n" typ name;
212                pr "    t[%d] = erl_mk_float (%s->%s);\n" i typ name;
213                pr "  else\n";
214                pr "    t[%d] = erl_mk_atom (\"undefined\");\n" i;
215            | name, FChar ->
216                pr "  t[%d] = erl_mk_int (%s->%s);\n" i typ name
217           );
218       ) cols;
219       pr "\n";
220       pr "  return erl_mk_list (t, %d);\n" (List.length cols);
221       pr "}\n";
222       pr "\n";
223   ) structs;
224
225   (* Emit a copy_TYPE_list function definition only if that function is used. *)
226   List.iter (
227     function
228     | typ, (RStructListOnly | RStructAndList) ->
229         (* generate the function for typ *)
230         emit_copy_list_function typ
231     | typ, _ -> () (* empty *)
232   ) (rstructs_used_by all_functions);
233
234   (* The wrapper functions. *)
235   List.iter (
236     fun (name, ((ret, args, optargs) as style), _, _, _, _, _) ->
237       pr "static ETERM *\n";
238       pr "run_%s (ETERM *message)\n" name;
239       pr "{\n";
240
241       iteri (
242         fun i ->
243           function
244           | Pathname n
245           | Device n | Dev_or_Path n
246           | String n
247           | FileIn n
248           | FileOut n
249           | Key n ->
250             pr "  char *%s = erl_iolist_to_string (ARG (%d));\n" n i
251           | OptString n ->
252             pr "  char *%s;\n" n;
253             pr "  if (atom_equals (ARG (%d), \"undefined\"))\n" i;
254             pr "    %s = NULL;\n" n;
255             pr "  else\n";
256             pr "    %s = erl_iolist_to_string (ARG (%d));\n" n i
257           | BufferIn n ->
258             pr "  size_t %s_size = erl_iolist_length (ARG (%d));\n" n i;
259             pr "  char *%s = erl_iolist_to_string (ARG (%d));\n" n i
260           | StringList n | DeviceList n ->
261             pr "  char **%s = get_string_list (ARG (%d));\n" n i
262           | Bool n ->
263             pr "  int %s = get_bool (ARG (%d));\n" n i
264           | Int n ->
265             pr "  int %s = ERL_INT_VALUE (ARG (%d));\n" n i
266           | Int64 n ->
267             pr "  int64_t %s = ERL_LL_VALUE (ARG (%d));\n" n i
268           | Pointer (t, n) ->
269             assert false
270       ) args;
271
272       let uc_name = String.uppercase name in
273
274       (* Optional arguments. *)
275       if optargs <> [] then (
276         pr "\n";
277         pr "  struct guestfs_%s_argv optargs_s = { .bitmask = 0 };\n" name;
278         pr "  struct guestfs_%s_argv *optargs = &optargs_s;\n" name;
279         pr "  ETERM *optargst = ARG (%d);\n" (List.length args);
280         pr "  while (!ERL_IS_EMPTY_LIST (optargst)) {\n";
281         pr "    ETERM *hd = ERL_CONS_HEAD (optargst);\n";
282         pr "    ETERM *hd_name = ERL_TUPLE_ELEMENT (hd, 0);\n";
283         pr "    ETERM *hd_value = ERL_TUPLE_ELEMENT (hd, 1);\n";
284         pr "\n";
285         List.iter (
286           fun argt ->
287             let n = name_of_argt argt in
288             let uc_n = String.uppercase n in
289             pr "    if (atom_equals (hd_name, \"%s\")) {\n" n;
290             pr "      optargs_s.bitmask |= GUESTFS_%s_%s_BITMASK;\n" uc_name uc_n;
291             pr "      optargs_s.%s = " n;
292             (match argt with
293              | Bool _ -> pr "get_bool (hd_value)"
294              | Int _ -> pr "ERL_INT_VALUE (hd_value)"
295              | Int64 _ -> pr "ERL_LL_VALUE (hd_value)"
296              | String _ -> pr "erl_iolist_to_string (hd_value)"
297              | _ -> assert false
298             );
299             pr ";\n";
300             pr "    }\n";
301             pr "    else\n";
302         ) optargs;
303         pr "      return unknown_optarg (\"%s\", hd_name);\n" name;
304         pr "    optargst = ERL_CONS_TAIL (optargst);\n";
305         pr "  }\n";
306         pr "\n";
307       );
308
309       (match ret with
310        | RErr -> pr "  int r;\n"
311        | RInt _ -> pr "  int r;\n"
312        | RInt64 _ -> pr "  int64_t r;\n"
313        | RBool _ -> pr "  int r;\n"
314        | RConstString _ | RConstOptString _ ->
315            pr "  const char *r;\n"
316        | RString _ -> pr "  char *r;\n"
317        | RStringList _ ->
318            pr "  size_t i;\n";
319            pr "  char **r;\n"
320        | RStruct (_, typ) ->
321            pr "  struct guestfs_%s *r;\n" typ
322        | RStructList (_, typ) ->
323            pr "  struct guestfs_%s_list *r;\n" typ
324        | RHashtable _ ->
325            pr "  size_t i;\n";
326            pr "  char **r;\n"
327        | RBufferOut _ ->
328            pr "  char *r;\n";
329            pr "  size_t size;\n"
330       );
331       pr "\n";
332
333       if optargs = [] then
334         pr "  r = guestfs_%s " name
335       else
336         pr "  r = guestfs_%s_argv " name;
337       generate_c_call_args ~handle:"g" style;
338       pr ";\n";
339
340       (* Free strings if we copied them above. *)
341       List.iter (
342         function
343         | Pathname n | Device n | Dev_or_Path n | String n | OptString n
344         | FileIn n | FileOut n | BufferIn n | Key n ->
345             pr "  free (%s);\n" n
346         | StringList n | DeviceList n ->
347             pr "  free_strings (%s);\n" n;
348         | Bool _ | Int _ | Int64 _ | Pointer _ -> ()
349       ) args;
350       List.iter (
351         function
352         | String n ->
353             let uc_n = String.uppercase n in
354             pr "  if ((optargs_s.bitmask & GUESTFS_%s_%s_BITMASK))\n"
355               uc_name uc_n;
356             pr "    free ((char *) optargs_s.%s);\n" n
357         | Bool _ | Int _ | Int64 _
358         | Pathname _ | Device _ | Dev_or_Path _ | OptString _
359         | FileIn _ | FileOut _ | BufferIn _ | Key _
360         | StringList _ | DeviceList _ | Pointer _ -> ()
361       ) optargs;
362
363       (match errcode_of_ret ret with
364        | `CannotReturnError -> ()
365        | `ErrorIsMinusOne ->
366            pr "  if (r == -1)\n";
367            pr "    return make_error (\"%s\");\n" name;
368        | `ErrorIsNULL ->
369            pr "  if (r == NULL)\n";
370            pr "    return make_error (\"%s\");\n" name;
371       );
372       pr "\n";
373
374       (match ret with
375        | RErr -> pr "  return erl_mk_atom (\"ok\");\n"
376        | RInt _ -> pr "  return erl_mk_int (r);\n"
377        | RInt64 _ -> pr "  return erl_mk_longlong (r);\n"
378        | RBool _ -> pr "  return make_bool (r);\n"
379        | RConstString _ -> pr "  return erl_mk_string (r);\n"
380        | RConstOptString _ ->
381            pr "  ETERM *rt;\n";
382            pr "  if (r)\n";
383            pr "    rt = erl_mk_string (r);\n";
384            pr "  else\n";
385            pr "    rt = erl_mk_atom (\"undefined\");\n";
386            pr "  return rt;\n"
387        | RString _ ->
388            pr "  ETERM *rt = erl_mk_string (r);\n";
389            pr "  free (r);\n";
390            pr "  return rt;\n"
391        | RStringList _ ->
392            pr "  ETERM *rt = make_string_list (r);\n";
393            pr "  free_strings (r);\n\n";
394            pr "  return rt;\n"
395        | RStruct (_, typ) ->
396            pr "  ETERM *rt = make_%s (r);\n" typ;
397            pr "  guestfs_free_%s (r);\n" typ;
398            pr "  return rt;\n"
399        | RStructList (_, typ) ->
400            pr "  ETERM *rt = make_%s_list (r);\n" typ;
401            pr "  guestfs_free_%s_list (r);\n" typ;
402            pr "  return rt;\n"
403        | RHashtable _ ->
404            pr "  ETERM *rt = make_table (r);\n";
405            pr "  free_strings (r);\n";
406            pr "  return rt;\n"
407        | RBufferOut _ ->
408            pr "  ETERM *rt = erl_mk_estring (r, size);\n";
409            pr "  free (r);\n";
410            pr "  return rt;\n"
411       );
412
413       pr "}\n";
414       pr "\n";
415   ) all_functions_sorted;
416
417   pr "\
418
419 ETERM *
420 dispatch (ETERM *message)
421 {
422   ETERM *fun;
423
424   fun = ERL_TUPLE_ELEMENT (message, 0);
425
426   /* XXX We should use gperf here. */
427   ";
428
429   List.iter (
430     fun (name, (ret, args, optargs), _, _, _, _, _) ->
431       pr "if (atom_equals (fun, \"%s\"))\n" name;
432       pr "    return run_%s (message);\n" name;
433       pr "  else ";
434   ) all_functions_sorted;
435
436   pr "return unknown_function (fun);
437 }
438 ";