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.
35 (* "RString" and "RStringList" require special treatment because
36 * the caller must free them.
39 | RStringList of string
41 (* 0 arguments, 1 argument, etc. The guestfs_h param is implicit. *)
46 | String of string (* const char *name, cannot be NULL *)
48 type flags = ProtocolLimitWarning
51 ("cat", (RString "content", P1 (String "path")), 4, [ProtocolLimitWarning],
52 "list the contents of a file",
54 Return the contents of the file named C<path>.
56 Note that this function cannot correctly handle binary files
57 (specifically, files containing C<\\0> character which is treated
58 as end of string). For those you need to use the C<guestfs_read>
59 function which has a more complex interface.");
61 ("ll", (RString "listing", P1 (String "directory")), 5, [],
62 "list the files in a directory (long format)",
64 List the files in C<directory> (relative to the root directory,
65 there is no cwd) in the format of 'ls -la'.
67 This command is mostly useful for interactive sessions. It
68 is I<not> intended that you try to parse the output string.");
70 ("ls", (RStringList "listing", P1 (String "directory")), 6, [],
71 "list the files in a directory",
73 List the files in C<directory> (relative to the root directory,
74 there is no cwd). The '.' and '..' entries are not returned, but
75 hidden files are shown.
77 This command is mostly useful for interactive sessions. Programs
78 should probably use C<guestfs_readdir> instead.");
80 ("mount", (Err, P2 (String "device", String "mountpoint")), 1, [],
81 "mount a guest disk at a position in the filesystem",
83 Mount a guest disk at a position in the filesystem. Block devices
84 are named C</dev/sda>, C</dev/sdb> and so on, as they were added to
85 the guest. If those block devices contain partitions, they will have
86 the usual names (eg. C</dev/sda1>). Also LVM C</dev/VG/LV>-style
89 The rules are the same as for L<mount(2)>: A filesystem must
90 first be mounted on C</> before others can be mounted. Other
91 filesystems can only be mounted on directories which already
94 The mounted filesystem is writable, if we have sufficient permissions
95 on the underlying device.
97 The filesystem options C<sync> and C<noatime> are set with this
98 call, in order to improve reliability.");
100 ("sync", (Err, P0), 2, [],
101 "sync disks, writes are flushed through to the disk image",
103 This syncs the disk, so that any writes are flushed through to the
104 underlying disk image.
106 You should always call this if you have modified a disk image, before
107 calling C<guestfs_close>.");
109 ("touch", (Err, P1 (String "path")), 3, [],
110 "update file timestamps or create a new file",
112 Touch acts like the L<touch(1)> command. It can be used to
113 update the timestamps on a file, or, if the file does not exist,
114 to create a new zero-length file.");
117 (* 'pr' prints to the current output file. *)
118 let chan = ref stdout
119 let pr fs = ksprintf (output_string !chan) fs
121 let iter_args f = function
124 | P2 (arg1, arg2) -> f arg1; f arg2
126 let iteri_args f = function
128 | P1 arg1 -> f 0 arg1
129 | P2 (arg1, arg2) -> f 0 arg1; f 1 arg2
131 let map_args f = function
133 | P1 arg1 -> [f arg1]
134 | P2 (arg1, arg2) -> [f arg1; f arg2]
136 let nr_args = function | P0 -> 0 | P1 _ -> 1 | P2 _ -> 2
138 type comment_style = CStyle | HashStyle | OCamlStyle
139 type license = GPLv2 | LGPLv2
141 (* Generate a header block in a number of standard styles. *)
142 let rec generate_header comment license =
143 let c = match comment with
144 | CStyle -> pr "/* "; " *"
145 | HashStyle -> pr "# "; "#"
146 | OCamlStyle -> pr "(* "; " *" in
147 pr "libguestfs generated file\n";
148 pr "%s WARNING: THIS FILE IS GENERATED BY 'src/generator.ml'.\n" c;
149 pr "%s ANY CHANGES YOU MAKE TO THIS FILE WILL BE LOST.\n" c;
151 pr "%s Copyright (C) 2009 Red Hat Inc.\n" c;
155 pr "%s This program is free software; you can redistribute it and/or modify\n" c;
156 pr "%s it under the terms of the GNU General Public License as published by\n" c;
157 pr "%s the Free Software Foundation; either version 2 of the License, or\n" c;
158 pr "%s (at your option) any later version.\n" c;
160 pr "%s This program is distributed in the hope that it will be useful,\n" c;
161 pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
162 pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n" c;
163 pr "%s GNU General Public License for more details.\n" c;
165 pr "%s You should have received a copy of the GNU General Public License along\n" c;
166 pr "%s with this program; if not, write to the Free Software Foundation, Inc.,\n" c;
167 pr "%s 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n" c;
170 pr "%s This library is free software; you can redistribute it and/or\n" c;
171 pr "%s modify it under the terms of the GNU Lesser General Public\n" c;
172 pr "%s License as published by the Free Software Foundation; either\n" c;
173 pr "%s version 2 of the License, or (at your option) any later version.\n" c;
175 pr "%s This library is distributed in the hope that it will be useful,\n" c;
176 pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
177 pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU\n" c;
178 pr "%s Lesser General Public License for more details.\n" c;
180 pr "%s You should have received a copy of the GNU Lesser General Public\n" c;
181 pr "%s License along with this library; if not, write to the Free Software\n" c;
182 pr "%s Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA\n" c;
185 | CStyle -> pr " */\n"
187 | OCamlStyle -> pr " *)\n"
191 (* Generate the pod documentation for the C API. *)
192 and generate_pod () =
194 fun (shortname, style, _, flags, _, longdesc) ->
195 let name = "guestfs_" ^ shortname in
196 pr "=head2 %s\n\n" name;
198 generate_prototype ~extern:false ~handle:"handle" name style;
200 pr "%s\n\n" longdesc;
201 (match fst style with
203 pr "This function returns 0 on success or -1 on error.\n\n"
205 pr "This function returns a string or NULL on error. The caller
206 must free the returned string after use.\n\n"
208 pr "This function returns a NULL-terminated array of strings
209 (like L<environ(3)>), or NULL if there was an error.
211 The caller must free the strings I<and> the array after use.\n\n"
213 if List.mem ProtocolLimitWarning flags then
214 pr "Because of the message protocol, there is a transfer limit
215 of somewhere between 2MB and 4MB. To transfer large files you should use
219 (* Generate the protocol (XDR) file. *)
220 and generate_xdr () =
221 generate_header CStyle LGPLv2;
223 (* This has to be defined to get around a limitation in Sun's rpcgen. *)
224 pr "typedef string str<>;\n";
228 fun (shortname, style, _, _, _, _) ->
229 let name = "guestfs_" ^ shortname in
230 pr "/* %s */\n\n" name;
231 (match snd style with
234 pr "struct %s_args {\n" name;
237 | String name -> pr " string %s<>;\n" name
241 (match fst style with
244 pr "struct %s_ret {\n" name;
245 pr " string %s<>;\n" n;
248 pr "struct %s_ret {\n" name;
254 (* Table of procedure numbers. *)
255 pr "enum guestfs_procedure {\n";
257 fun (shortname, _, proc_nr, _, _, _) ->
258 pr " GUESTFS_PROC_%s = %d,\n" (String.uppercase shortname) proc_nr
260 pr " GUESTFS_PROC_dummy\n"; (* so we don't have a "hanging comma" *)
264 (* Having to choose a maximum message size is annoying for several
265 * reasons (it limits what we can do in the API), but it (a) makes
266 * the protocol a lot simpler, and (b) provides a bound on the size
267 * of the daemon which operates in limited memory space. For large
268 * file transfers you should use FTP.
270 pr "const GUESTFS_MESSAGE_MAX = %d;\n" (4 * 1024 * 1024);
273 (* Message header, etc. *)
275 const GUESTFS_PROGRAM = 0x2000F5F5;
276 const GUESTFS_PROTOCOL_VERSION = 1;
278 enum guestfs_message_direction {
279 GUESTFS_DIRECTION_CALL = 0, /* client -> daemon */
280 GUESTFS_DIRECTION_REPLY = 1 /* daemon -> client */
283 enum guestfs_message_status {
284 GUESTFS_STATUS_OK = 0,
285 GUESTFS_STATUS_ERROR = 1
288 const GUESTFS_ERROR_LEN = 256;
290 struct guestfs_message_error {
291 string error<GUESTFS_ERROR_LEN>; /* error message */
294 struct guestfs_message_header {
295 unsigned prog; /* GUESTFS_PROGRAM */
296 unsigned vers; /* GUESTFS_PROTOCOL_VERSION */
297 guestfs_procedure proc; /* GUESTFS_PROC_x */
298 guestfs_message_direction direction;
299 unsigned serial; /* message serial number */
300 guestfs_message_status status;
304 (* Generate the guestfs-actions.h file. *)
305 and generate_actions_h () =
306 generate_header CStyle LGPLv2;
308 fun (shortname, style, _, _, _, _) ->
309 let name = "guestfs_" ^ shortname in
310 generate_prototype ~single_line:true ~newline:true ~handle:"handle"
314 (* Generate the client-side dispatch stubs. *)
315 and generate_client_actions () =
316 generate_header CStyle LGPLv2;
318 fun (shortname, style, _, _, _, _) ->
319 let name = "guestfs_" ^ shortname in
321 (* Generate the return value struct. *)
322 pr "struct %s_rv {\n" shortname;
323 pr " int cb_done; /* flag to indicate callback was called */\n";
324 pr " struct guestfs_message_header hdr;\n";
325 pr " struct guestfs_message_error err;\n";
326 (match fst style with
328 | RString _ | RStringList _ -> pr " struct %s_ret ret;\n" name;
332 (* Generate the callback function. *)
333 pr "static void %s_cb (guestfs_h *g, void *data, XDR *xdr)\n" shortname;
335 pr " struct %s_rv *rv = (struct %s_rv *) data;\n" shortname shortname;
337 pr " if (!xdr_guestfs_message_header (xdr, &rv->hdr)) {\n";
338 pr " error (g, \"%s: failed to parse reply header\");\n" name;
341 pr " if (rv->hdr.status == GUESTFS_STATUS_ERROR) {\n";
342 pr " if (!xdr_guestfs_message_error (xdr, &rv->err)) {\n";
343 pr " error (g, \"%s: failed to parse reply error\");\n" name;
349 (match fst style with
351 | RString _ | RStringList _ ->
352 pr " if (!xdr_%s_ret (xdr, &rv->ret)) {\n" name;
353 pr " error (g, \"%s: failed to parse reply\");\n" name;
359 pr " rv->cb_done = 1;\n";
360 pr " main_loop.main_loop_quit (g);\n";
363 (* Generate the action stub. *)
364 generate_prototype ~extern:false ~semicolon:false ~newline:true
365 ~handle:"g" name style;
370 | RString _ | RStringList _ -> "NULL" in
374 (match snd style with
376 | _ -> pr " struct %s_args args;\n" name
379 pr " struct %s_rv rv;\n" shortname;
382 pr " if (g->state != READY) {\n";
383 pr " error (g, \"%s called from the wrong state, %%d != READY\",\n"
386 pr " return %s;\n" error_code;
389 pr " memset (&rv, 0, sizeof rv);\n";
392 (match snd style with
394 pr " serial = dispatch (g, GUESTFS_PROC_%s, NULL, NULL);\n"
395 (String.uppercase shortname)
399 | String name -> pr " args.%s = (char *) %s;\n" name name
401 pr " serial = dispatch (g, GUESTFS_PROC_%s,\n"
402 (String.uppercase shortname);
403 pr " (xdrproc_t) xdr_%s_args, (char *) &args);\n"
406 pr " if (serial == -1)\n";
407 pr " return %s;\n" error_code;
410 pr " rv.cb_done = 0;\n";
411 pr " g->reply_cb_internal = %s_cb;\n" shortname;
412 pr " g->reply_cb_internal_data = &rv;\n";
413 pr " main_loop.main_loop_run (g);\n";
414 pr " g->reply_cb_internal = NULL;\n";
415 pr " g->reply_cb_internal_data = NULL;\n";
416 pr " if (!rv.cb_done) {\n";
417 pr " error (g, \"%s failed, see earlier error messages\");\n" name;
418 pr " return %s;\n" error_code;
422 pr " if (check_reply_header (g, &rv.hdr, GUESTFS_PROC_%s, serial) == -1)\n"
423 (String.uppercase shortname);
424 pr " return %s;\n" error_code;
427 pr " if (rv.hdr.status == GUESTFS_STATUS_ERROR) {\n";
428 pr " error (g, \"%%s\", rv.err.error);\n";
429 pr " return %s;\n" error_code;
433 (match fst style with
434 | Err -> pr " return 0;\n"
436 pr " return rv.ret.%s; /* caller will free */\n" n
438 pr " /* caller will free this, but we need to add a NULL entry */\n";
439 pr " rv.ret.%s.%s_val = safe_realloc (g, rv.ret.%s.%s_val, rv.ret.%s.%s_len + 1);\n" n n n n n n;
440 pr " rv.ret.%s.%s_val[rv.ret.%s.%s_len] = NULL;\n" n n n n;
441 pr " return rv.ret.%s.%s_val;\n" n n
447 (* Generate daemon/actions.h. *)
448 and generate_daemon_actions_h () =
449 generate_header CStyle GPLv2;
451 fun (name, style, _, _, _, _) ->
452 generate_prototype ~single_line:true ~newline:true ("do_" ^ name) style;
455 (* Generate the server-side stubs. *)
456 and generate_daemon_actions () =
457 generate_header CStyle GPLv2;
459 pr "#include <rpc/types.h>\n";
460 pr "#include <rpc/xdr.h>\n";
461 pr "#include \"daemon.h\"\n";
462 pr "#include \"../src/guestfs_protocol.h\"\n";
463 pr "#include \"actions.h\"\n";
467 fun (name, style, _, _, _, _) ->
468 (* Generate server-side stubs. *)
469 pr "static void %s_stub (XDR *xdr_in)\n" name;
473 | Err -> pr " int r;\n"; "-1"
474 | RString _ -> pr " char *r;\n"; "NULL"
475 | RStringList _ -> pr " char **r;\n"; "NULL" in
476 (match snd style with
479 pr " struct guestfs_%s_args args;\n" name;
482 | String name -> pr " const char *%s;\n" name
487 (match snd style with
490 pr " memset (&args, 0, sizeof args);\n";
492 pr " if (!xdr_guestfs_%s_args (xdr_in, &args)) {\n" name;
493 pr " reply_with_error (\"%s: daemon failed to decode procedure arguments\");\n" name;
498 | String name -> pr " %s = args.%s;\n" name name
503 pr " r = do_%s " name;
504 generate_call_args style;
507 pr " if (r == %s)\n" error_code;
508 pr " /* do_%s has already called reply_with_error, so just return */\n" name;
512 (match fst style with
513 | Err -> pr " reply (NULL, NULL);\n"
515 pr " struct guestfs_%s_ret ret;\n" name;
516 pr " ret.%s = r;\n" n;
517 pr " reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name;
520 pr " struct guestfs_%s_ret ret;\n" name;
521 pr " ret.%s.%s_len = count_strings (r);\n" n n;
522 pr " ret.%s.%s_val = r;\n" n n;
523 pr " reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name;
524 pr " free_strings (r);\n"
530 (* Dispatch function. *)
531 pr "void dispatch_incoming_message (XDR *xdr_in)\n";
533 pr " switch (proc_nr) {\n";
536 fun (name, style, _, _, _, _) ->
537 pr " case GUESTFS_PROC_%s:\n" (String.uppercase name);
538 pr " %s_stub (xdr_in);\n" name;
543 pr " reply_with_error (\"dispatch_incoming_message: unknown procedure number %%d\", proc_nr);\n";
547 (* Generate a lot of different functions for guestfish. *)
548 and generate_fish_cmds () =
549 generate_header CStyle GPLv2;
551 pr "#include <stdio.h>\n";
552 pr "#include <stdlib.h>\n";
553 pr "#include <string.h>\n";
555 pr "#include \"fish.h\"\n";
558 (* list_commands function, which implements guestfish -h *)
559 pr "void list_commands (void)\n";
561 pr " printf (\" %%-16s %%s\\n\", \"Command\", \"Description\");\n";
562 pr " list_builtin_commands ();\n";
564 fun (name, _, _, _, shortdesc, _) ->
565 pr " printf (\"%%-20s %%s\\n\", \"%s\", \"%s\");\n"
568 pr " printf (\" Use -h <cmd> / help <cmd> to show detailed help for a command.\\n\");\n";
572 (* display_command function, which implements guestfish -h cmd *)
573 pr "void display_command (const char *cmd)\n";
576 fun (name, style, _, flags, shortdesc, longdesc) ->
583 String.concat "> <" (
585 | String n -> n) args
590 if List.mem ProtocolLimitWarning flags then
591 "\n\nBecause of the message protocol, there is a transfer limit
592 of somewhere between 2MB and 4MB. To transfer large files you should use
596 pr " if (strcasecmp (cmd, \"%s\") == 0)\n" name;
597 pr " pod2text (\"%s - %s\", %S);\n"
599 (" " ^ synopsis ^ "\n\n" ^ longdesc ^ warnings);
602 pr " display_builtin_command (cmd);\n";
606 (* run_<action> actions *)
608 fun (name, style, _, _, _, _) ->
609 pr "static int run_%s (const char *cmd, int argc, char *argv[])\n" name;
611 (match fst style with
612 | Err -> pr " int r;\n"
613 | RString _ -> pr " char *r;\n"
614 | RStringList _ -> pr " char **r;\n"
618 | String name -> pr " const char *%s;\n" name
621 (* Check and convert parameters. *)
622 let argc_expected = nr_args (snd style) in
623 pr " if (argc != %d) {\n" argc_expected;
624 pr " fprintf (stderr, \"%%s should have %d parameter(s)\\n\", cmd);\n"
626 pr " fprintf (stderr, \"type 'help %%s' for help on %%s\\n\", cmd, cmd);\n";
632 | String name -> pr " %s = argv[%d];\n" name i
635 (* Call C API function. *)
636 pr " r = guestfs_%s " name;
637 generate_call_args ~handle:"g" style;
640 (* Check return value for errors and display command results. *)
641 (match fst style with
642 | Err -> pr " return r;\n"
644 pr " if (r == NULL) return -1;\n";
645 pr " printf (\"%%s\", r);\n";
649 pr " if (r == NULL) return -1;\n";
650 pr " print_strings (r);\n";
651 pr " free_strings (r);\n";
658 (* run_action function *)
659 pr "int run_action (const char *cmd, int argc, char *argv[])\n";
662 fun (name, _, _, _, _, _) ->
663 pr " if (strcasecmp (cmd, \"%s\") == 0)\n" name;
664 pr " return run_%s (cmd, argc, argv);\n" name;
668 pr " fprintf (stderr, \"%%s: unknown command\\n\", cmd);\n";
675 (* Generate a C function prototype. *)
676 and generate_prototype ?(extern = true) ?(static = false) ?(semicolon = true)
677 ?(single_line = false) ?(newline = false)
679 if extern then pr "extern ";
680 if static then pr "static ";
681 (match fst style with
683 | RString _ -> pr "char *"
684 | RStringList _ -> pr "char **"
687 let comma = ref false in
690 | Some handle -> pr "guestfs_h *%s" handle; comma := true
694 if single_line then pr ", " else pr ",\n\t\t"
700 | String name -> next (); pr "const char *%s" name
703 if semicolon then pr ";";
704 if newline then pr "\n"
706 (* Generate C call arguments, eg "(handle, foo, bar)" *)
707 and generate_call_args ?handle style =
709 let comma = ref false in
712 | Some handle -> pr "%s" handle; comma := true
716 if !comma then pr ", ";
719 | String name -> pr "%s" name
723 let output_to filename =
724 let filename_new = filename ^ ".new" in
725 chan := open_out filename_new;
729 Unix.rename filename_new filename;
730 printf "written %s\n%!" filename;
736 let close = output_to "src/guestfs_protocol.x" in
740 let close = output_to "src/guestfs-actions.h" in
741 generate_actions_h ();
744 let close = output_to "src/guestfs-actions.c" in
745 generate_client_actions ();
748 let close = output_to "daemon/actions.h" in
749 generate_daemon_actions_h ();
752 let close = output_to "daemon/stubs.c" in
753 generate_daemon_actions ();
756 let close = output_to "fish/cmds.c" in
757 generate_fish_cmds ();
760 let close = output_to "guestfs-actions.pod" in