1 #!/usr/bin/ocamlrun ocaml
3 * Copyright (C) 2009 Red Hat Inc.
5 * This program is free software; you can redistribute it and/or modify
6 * it under the terms of the GNU General Public License as published by
7 * the Free Software Foundation; either version 2 of the License, or
8 * (at your option) any later version.
10 * This program is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 * GNU General Public License for more details.
15 * You should have received a copy of the GNU General Public License
16 * along with this program; if not, write to the Free Software
17 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
19 * This script generates a large amount of code and documentation for
20 * all the daemon actions. To add a new action there are only two
21 * files you need to change, this one to describe the interface, and
22 * daemon/<somefile>.c to write the implementation.
29 type style = ret * args
31 (* "Err" as a return value means an int used as a simple error
32 * indication, ie. 0 or -1.
36 (* 0 arguments, 1 argument, etc. The guestfs_h param is implicit. *)
41 | String of string (* const char *name, cannot be NULL *)
44 ("mount", (Err, P2 (String "device", String "mountpoint")),
45 "Mount a guest disk at a position in the filesystem",
47 Mount a guest disk at a position in the filesystem. Block devices
48 are named C</dev/sda>, C</dev/sdb> and so on, as they were added to
49 the guest. If those block devices contain partitions, they will have
50 the usual names (eg. C</dev/sda1>). Also LVM C</dev/VG/LV>-style
53 The rules are the same as for L<mount(2)>: A filesystem must
54 first be mounted on C</> before others can be mounted. Other
55 filesystems can only be mounted on directories which already
59 "Sync disks, writes are flushed through to the disk image",
61 This syncs the disk, so that any writes are flushed through to the
62 underlying disk image.
64 You should always call this if you have modified a disk image, before
65 calling C<guestfs_close>.");
67 ("touch", (Err, P1 (String "path")),
68 "Update file timestamps or create a new file",
70 Touch acts like the L<touch(1)> command. It can be used to
71 update the filesystems on a file, or, if the file does not exist,
72 to create a new zero-length file.");
75 (* 'pr' prints to the current output file. *)
77 let pr fs = ksprintf (output_string !chan) fs
79 let iter_args f = function
82 | P2 (arg1, arg2) -> f arg1; f arg2
84 type comment_style = CStyle | HashStyle | OCamlStyle
85 type license = GPLv2 | LGPLv2
87 (* Generate a header block in a number of standard styles. *)
88 let rec generate_header comment license =
89 let c = match comment with
90 | CStyle -> pr "/* "; " *"
91 | HashStyle -> pr "# "; "#"
92 | OCamlStyle -> pr "(* "; " *" in
93 pr "libguestfs generated file\n";
94 pr "%s WARNING: THIS FILE IS GENERATED BY 'src/generator.ml'.\n" c;
95 pr "%s ANY CHANGES YOU MAKE TO THIS FILE WILL BE LOST.\n" c;
97 pr "%s Copyright (C) 2009 Red Hat Inc.\n" c;
101 pr "%s This program is free software; you can redistribute it and/or modify\n" c;
102 pr "%s it under the terms of the GNU General Public License as published by\n" c;
103 pr "%s the Free Software Foundation; either version 2 of the License, or\n" c;
104 pr "%s (at your option) any later version.\n" c;
106 pr "%s This program is distributed in the hope that it will be useful,\n" c;
107 pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
108 pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n" c;
109 pr "%s GNU General Public License for more details.\n" c;
111 pr "%s You should have received a copy of the GNU General Public License along\n" c;
112 pr "%s with this program; if not, write to the Free Software Foundation, Inc.,\n" c;
113 pr "%s 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n" c;
116 pr "%s This library is free software; you can redistribute it and/or\n" c;
117 pr "%s modify it under the terms of the GNU Lesser General Public\n" c;
118 pr "%s License as published by the Free Software Foundation; either\n" c;
119 pr "%s version 2 of the License, or (at your option) any later version.\n" c;
121 pr "%s This library is distributed in the hope that it will be useful,\n" c;
122 pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
123 pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU\n" c;
124 pr "%s Lesser General Public License for more details.\n" c;
126 pr "%s You should have received a copy of the GNU Lesser General Public\n" c;
127 pr "%s License along with this library; if not, write to the Free Software\n" c;
128 pr "%s Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA\n" c;
131 | CStyle -> pr " */\n"
133 | OCamlStyle -> pr " *)\n"
137 (* Generate the pod documentation for the C API. *)
138 and generate_pod () =
140 fun (shortname, style, _, longdesc) ->
141 let name = "guestfs_" ^ shortname in
142 pr "=head2 %s\n\n" name;
144 generate_prototype ~extern:false name style;
146 pr "%s\n\n" longdesc;
149 pr "This function return 0 on success or -1 on error.\n\n"
153 (* Generate the protocol (XDR) file. *)
154 and generate_xdr () =
155 generate_header CStyle LGPLv2;
157 fun (shortname, style, _, _) ->
158 let name = "guestfs_" ^ shortname in
159 pr "/* %s */\n\n" name;
163 pr "struct %s_args {\n" name;
166 | String name -> pr " string %s<>;\n" name
172 (* | ... -> pr "struct %s_ret ...\n" name; *)
176 (* Generate the guestfs-actions.h file. *)
177 and generate_actions_h () =
178 generate_header CStyle LGPLv2;
180 fun (shortname, style, _, _) ->
181 let name = "guestfs_" ^ shortname in
182 generate_prototype ~single_line:true ~newline:true name style
185 (* Generate the client-side dispatch stubs. *)
186 and generate_client_actions () =
187 generate_header CStyle LGPLv2;
189 fun (shortname, style, _, _) ->
190 let name = "guestfs_" ^ shortname in
192 (* Generate the return value struct. *)
193 pr "struct %s_rv {\n" shortname;
194 pr " int err_code; /* 0 or -1 */\n";
195 pr " char err_str[256];\n";
198 (* | _ -> pr " struct %s_ret ret;\n" name; *)
202 (* Generate the callback function. *)
203 pr "static void %s_cb (guestfs_h *g, void *data, XDR *xdr)\n" shortname;
205 pr " struct %s_rv *rv = (struct %s_rv *) data;\n" shortname shortname;
207 pr " /* XXX */ rv.code = 0;\n";
208 pr " main_loop.main_loop_quit (g);\n";
211 (* Generate the action stub. *)
212 generate_prototype ~extern:false ~semicolon:false ~newline:true
213 ~handle:"g" name style;
217 | (Err, _) -> "-1" in
223 | _ -> pr " struct %s_args args;\n" name
226 pr " struct %s_rv rv;\n" shortname;
228 pr " if (g->state != READY) {\n";
229 pr " error (g, \"%s called from the wrong state, %%d != READY\",\n"
232 pr " return %s;\n" error_code;
241 | String name -> pr " args.%s = (char *) %s;\n" name name
243 pr " if (dispatch (g, (xdrproc_t) xdr_%s_args, (char *) &args) == -1)\n"
245 pr " return %s;\n" error_code;
249 pr " rv.err_code = 42;\n";
250 pr " g->reply_cb_internal = %s_cb;\n" shortname;
251 pr " g->reply_cb_internal_data = &rv;\n";
252 pr " main_loop.main_loop_run (g);\n";
253 pr " g->reply_cb_internal = NULL;\n";
254 pr " g->reply_cb_internal_data = NULL;\n";
255 pr " if (rv.err_code == 42) { /* callback wasn't called */\n";
256 pr " error (g, \"%s failed, see earlier error messages\");\n" name;
257 pr " return %s;\n" error_code;
259 pr " else if (rv.err_code == -1) { /* error from remote end */\n";
260 pr " error (g, \"%%s\", rv.err_str);\n";
261 pr " return %s;\n" error_code;
266 | (Err, _) -> pr " return 0;\n"
272 (* Generate daemon/actions.h. *)
273 and generate_daemon_actions_h () =
274 generate_header CStyle GPLv2;
276 fun (name, style, _, _) ->
277 generate_prototype ~single_line:true ~newline:true ("do_" ^ name) style;
280 (* Generate the server-side stubs. *)
281 and generate_daemon_actions () =
282 generate_header CStyle GPLv2;
284 pr "#include <rpc/types.h>\n";
285 pr "#include <rpc/xdr.h>\n";
286 pr "#include \"daemon.h\"\n";
287 pr "#include \"../src/guest_protocol.h\"\n";
288 pr "#include \"actions.h\"\n";
292 fun (name, style, _, _) ->
293 (* Generate server-side stubs. *)
294 pr "static void %s_stub (XDR *xdr_in)\n" name;
298 | (Err, _) -> pr " int r;\n"; "-1" in
302 pr " struct guestfs_%s_args args;\n" name;
305 | String name -> pr " const char *%s;\n" name
313 pr " if (!xdr_guestfs_%s_args (xdr_in, &args)) {\n" name;
314 pr " reply_with_error (\"%s: daemon failed to decode procedure arguments\");\n" name;
319 | String name -> pr " %s = args.%s;\n" name name
324 pr " r = do_%s " name;
325 generate_call_args style;
328 pr " if (r == %s)\n" error_code;
329 pr " /* do_%s has already called reply_with_error, so just return */\n" name;
334 | (Err, _) -> pr " reply (NULL, NULL);\n"
340 (* Generate a C function prototype. *)
341 and generate_prototype ?(extern = true) ?(static = false) ?(semicolon = true)
342 ?(single_line = false) ?(newline = false)
343 ?(handle = "handle") name style =
344 if extern then pr "extern ";
345 if static then pr "static ";
347 | (Err, _) -> pr "int "
349 pr "%s (guestfs_h *%s" name handle;
350 let next () = if single_line then pr ", " else pr ",\n\t\t" in
353 | String name -> next (); pr "const char *%s" name
356 if semicolon then pr ";";
357 if newline then pr "\n"
359 (* Generate C call arguments, eg "(handle, foo, bar)" *)
360 and generate_call_args ?handle style =
362 let comma = ref false in
365 | Some handle -> pr "%s" handle; comma := true
369 if !comma then pr ", ";
372 | String name -> pr "%s" name
376 let output_to filename =
377 let filename_new = filename ^ ".new" in
378 chan := open_out filename_new;
382 Unix.rename filename_new filename;
383 printf "written %s\n%!" filename;
389 let close = output_to "src/guestfs_protocol.x" in
393 let close = output_to "src/guestfs-actions.h" in
394 generate_actions_h ();
397 let close = output_to "src/guestfs-actions.c" in
398 generate_client_actions ();
401 let close = output_to "daemon/actions.h" in
402 generate_daemon_actions_h ();
405 let close = output_to "daemon/stubs.c" in
406 generate_daemon_actions ();
409 let close = output_to "guestfs-actions.pod" in