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 ("mount", (Err, P2 (String "device", String "mountpoint")), 1, [],
52 "mount a guest disk at a position in the filesystem",
54 Mount a guest disk at a position in the filesystem. Block devices
55 are named C</dev/sda>, C</dev/sdb> and so on, as they were added to
56 the guest. If those block devices contain partitions, they will have
57 the usual names (eg. C</dev/sda1>). Also LVM C</dev/VG/LV>-style
60 The rules are the same as for L<mount(2)>: A filesystem must
61 first be mounted on C</> before others can be mounted. Other
62 filesystems can only be mounted on directories which already
65 The mounted filesystem is writable, if we have sufficient permissions
66 on the underlying device.
68 The filesystem options C<sync> and C<noatime> are set with this
69 call, in order to improve reliability.");
71 ("sync", (Err, P0), 2, [],
72 "sync disks, writes are flushed through to the disk image",
74 This syncs the disk, so that any writes are flushed through to the
75 underlying disk image.
77 You should always call this if you have modified a disk image, before
78 calling C<guestfs_close>.");
80 ("touch", (Err, P1 (String "path")), 3, [],
81 "update file timestamps or create a new file",
83 Touch acts like the L<touch(1)> command. It can be used to
84 update the timestamps on a file, or, if the file does not exist,
85 to create a new zero-length file.");
87 ("cat", (RString "content", P1 (String "path")), 4, [ProtocolLimitWarning],
88 "list the contents of a file",
90 Return the contents of the file named C<path>.
92 Note that this function cannot correctly handle binary files
93 (specifically, files containing C<\\0> character which is treated
94 as end of string). For those you need to use the C<guestfs_read_file>
95 function which has a more complex interface.");
97 ("ll", (RString "listing", P1 (String "directory")), 5, [],
98 "list the files in a directory (long format)",
100 List the files in C<directory> (relative to the root directory,
101 there is no cwd) in the format of 'ls -la'.
103 This command is mostly useful for interactive sessions. It
104 is I<not> intended that you try to parse the output string.");
106 ("ls", (RStringList "listing", P1 (String "directory")), 6, [],
107 "list the files in a directory",
109 List the files in C<directory> (relative to the root directory,
110 there is no cwd). The '.' and '..' entries are not returned, but
111 hidden files are shown.
113 This command is mostly useful for interactive sessions. Programs
114 should probably use C<guestfs_readdir> instead.");
116 ("list_devices", (RStringList "devices", P0), 7, [],
117 "list the block devices",
119 List all the block devices.
121 The full block device names are returned, eg. C</dev/sda>
124 ("list_partitions", (RStringList "partitions", P0), 8, [],
125 "list the partitions",
127 List all the partitions detected on all block devices.
129 The full partition device names are returned, eg. C</dev/sda1>
131 This does not return logical volumes. For that you will need to
132 call C<guestfs_lvs>.");
135 (* In some places we want the functions to be displayed sorted
136 * alphabetically, so this is useful:
138 let sorted_functions =
139 List.sort (fun (n1,_,_,_,_,_) (n2,_,_,_,_,_) -> compare n1 n2) functions
141 (* Useful functions. *)
142 let failwithf fs = ksprintf failwith fs
143 let replace s c1 c2 =
144 let s2 = String.copy s in
146 for i = 0 to String.length s2 - 1 do
147 if String.unsafe_get s2 i = c1 then (
148 String.unsafe_set s2 i c2;
152 if not !r then s else s2
154 (* 'pr' prints to the current output file. *)
155 let chan = ref stdout
156 let pr fs = ksprintf (output_string !chan) fs
158 let iter_args f = function
161 | P2 (arg1, arg2) -> f arg1; f arg2
163 let iteri_args f = function
165 | P1 arg1 -> f 0 arg1
166 | P2 (arg1, arg2) -> f 0 arg1; f 1 arg2
168 let map_args f = function
170 | P1 arg1 -> [f arg1]
171 | P2 (arg1, arg2) -> [f arg1; f arg2]
173 let nr_args = function | P0 -> 0 | P1 _ -> 1 | P2 _ -> 2
175 (* Check function names etc. for consistency. *)
176 let check_functions () =
178 fun (name, _, _, _, _, _) ->
179 if String.contains name '-' then
180 failwithf "Function name '%s' should not contain '-', use '_' instead."
185 List.map (fun (name, _, proc_nr, _, _, _) -> name, proc_nr) functions in
187 List.sort (fun (_,nr1) (_,nr2) -> compare nr1 nr2) proc_nrs in
188 let rec loop = function
191 | (name1,nr1) :: ((name2,nr2) :: _ as rest) when nr1 < nr2 ->
193 | (name1,nr1) :: (name2,nr2) :: _ ->
194 failwithf "'%s' and '%s' have conflicting procedure numbers (%d, %d)"
199 type comment_style = CStyle | HashStyle | OCamlStyle
200 type license = GPLv2 | LGPLv2
202 (* Generate a header block in a number of standard styles. *)
203 let rec generate_header comment license =
204 let c = match comment with
205 | CStyle -> pr "/* "; " *"
206 | HashStyle -> pr "# "; "#"
207 | OCamlStyle -> pr "(* "; " *" in
208 pr "libguestfs generated file\n";
209 pr "%s WARNING: THIS FILE IS GENERATED BY 'src/generator.ml'.\n" c;
210 pr "%s ANY CHANGES YOU MAKE TO THIS FILE WILL BE LOST.\n" c;
212 pr "%s Copyright (C) 2009 Red Hat Inc.\n" c;
216 pr "%s This program is free software; you can redistribute it and/or modify\n" c;
217 pr "%s it under the terms of the GNU General Public License as published by\n" c;
218 pr "%s the Free Software Foundation; either version 2 of the License, or\n" c;
219 pr "%s (at your option) any later version.\n" c;
221 pr "%s This program is distributed in the hope that it will be useful,\n" c;
222 pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
223 pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n" c;
224 pr "%s GNU General Public License for more details.\n" c;
226 pr "%s You should have received a copy of the GNU General Public License along\n" c;
227 pr "%s with this program; if not, write to the Free Software Foundation, Inc.,\n" c;
228 pr "%s 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n" c;
231 pr "%s This library is free software; you can redistribute it and/or\n" c;
232 pr "%s modify it under the terms of the GNU Lesser General Public\n" c;
233 pr "%s License as published by the Free Software Foundation; either\n" c;
234 pr "%s version 2 of the License, or (at your option) any later version.\n" c;
236 pr "%s This library is distributed in the hope that it will be useful,\n" c;
237 pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
238 pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU\n" c;
239 pr "%s Lesser General Public License for more details.\n" c;
241 pr "%s You should have received a copy of the GNU Lesser General Public\n" c;
242 pr "%s License along with this library; if not, write to the Free Software\n" c;
243 pr "%s Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA\n" c;
246 | CStyle -> pr " */\n"
248 | OCamlStyle -> pr " *)\n"
252 (* Generate the pod documentation for the C API. *)
253 and generate_pod () =
255 fun (shortname, style, _, flags, _, longdesc) ->
256 let name = "guestfs_" ^ shortname in
257 pr "=head2 %s\n\n" name;
259 generate_prototype ~extern:false ~handle:"handle" name style;
261 pr "%s\n\n" longdesc;
262 (match fst style with
264 pr "This function returns 0 on success or -1 on error.\n\n"
266 pr "This function returns a string or NULL on error.
267 I<The caller must free the returned string after use>.\n\n"
269 pr "This function returns a NULL-terminated array of strings
270 (like L<environ(3)>), or NULL if there was an error.
271 I<The caller must free the strings and the array after use>.\n\n"
273 if List.mem ProtocolLimitWarning flags then
274 pr "Because of the message protocol, there is a transfer limit
275 of somewhere between 2MB and 4MB. To transfer large files you should use
279 (* Generate the protocol (XDR) file. *)
280 and generate_xdr () =
281 generate_header CStyle LGPLv2;
283 (* This has to be defined to get around a limitation in Sun's rpcgen. *)
284 pr "typedef string str<>;\n";
288 fun (shortname, style, _, _, _, _) ->
289 let name = "guestfs_" ^ shortname in
290 pr "/* %s */\n\n" name;
291 (match snd style with
294 pr "struct %s_args {\n" name;
297 | String name -> pr " string %s<>;\n" name
301 (match fst style with
304 pr "struct %s_ret {\n" name;
305 pr " string %s<>;\n" n;
308 pr "struct %s_ret {\n" name;
314 (* Table of procedure numbers. *)
315 pr "enum guestfs_procedure {\n";
317 fun (shortname, _, proc_nr, _, _, _) ->
318 pr " GUESTFS_PROC_%s = %d,\n" (String.uppercase shortname) proc_nr
320 pr " GUESTFS_PROC_dummy\n"; (* so we don't have a "hanging comma" *)
324 (* Having to choose a maximum message size is annoying for several
325 * reasons (it limits what we can do in the API), but it (a) makes
326 * the protocol a lot simpler, and (b) provides a bound on the size
327 * of the daemon which operates in limited memory space. For large
328 * file transfers you should use FTP.
330 pr "const GUESTFS_MESSAGE_MAX = %d;\n" (4 * 1024 * 1024);
333 (* Message header, etc. *)
335 const GUESTFS_PROGRAM = 0x2000F5F5;
336 const GUESTFS_PROTOCOL_VERSION = 1;
338 enum guestfs_message_direction {
339 GUESTFS_DIRECTION_CALL = 0, /* client -> daemon */
340 GUESTFS_DIRECTION_REPLY = 1 /* daemon -> client */
343 enum guestfs_message_status {
344 GUESTFS_STATUS_OK = 0,
345 GUESTFS_STATUS_ERROR = 1
348 const GUESTFS_ERROR_LEN = 256;
350 struct guestfs_message_error {
351 string error<GUESTFS_ERROR_LEN>; /* error message */
354 struct guestfs_message_header {
355 unsigned prog; /* GUESTFS_PROGRAM */
356 unsigned vers; /* GUESTFS_PROTOCOL_VERSION */
357 guestfs_procedure proc; /* GUESTFS_PROC_x */
358 guestfs_message_direction direction;
359 unsigned serial; /* message serial number */
360 guestfs_message_status status;
364 (* Generate the guestfs-actions.h file. *)
365 and generate_actions_h () =
366 generate_header CStyle LGPLv2;
368 fun (shortname, style, _, _, _, _) ->
369 let name = "guestfs_" ^ shortname in
370 generate_prototype ~single_line:true ~newline:true ~handle:"handle"
374 (* Generate the client-side dispatch stubs. *)
375 and generate_client_actions () =
376 generate_header CStyle LGPLv2;
378 fun (shortname, style, _, _, _, _) ->
379 let name = "guestfs_" ^ shortname in
381 (* Generate the return value struct. *)
382 pr "struct %s_rv {\n" shortname;
383 pr " int cb_done; /* flag to indicate callback was called */\n";
384 pr " struct guestfs_message_header hdr;\n";
385 pr " struct guestfs_message_error err;\n";
386 (match fst style with
388 | RString _ | RStringList _ -> pr " struct %s_ret ret;\n" name;
392 (* Generate the callback function. *)
393 pr "static void %s_cb (guestfs_h *g, void *data, XDR *xdr)\n" shortname;
395 pr " struct %s_rv *rv = (struct %s_rv *) data;\n" shortname shortname;
397 pr " if (!xdr_guestfs_message_header (xdr, &rv->hdr)) {\n";
398 pr " error (g, \"%s: failed to parse reply header\");\n" name;
401 pr " if (rv->hdr.status == GUESTFS_STATUS_ERROR) {\n";
402 pr " if (!xdr_guestfs_message_error (xdr, &rv->err)) {\n";
403 pr " error (g, \"%s: failed to parse reply error\");\n" name;
409 (match fst style with
411 | RString _ | RStringList _ ->
412 pr " if (!xdr_%s_ret (xdr, &rv->ret)) {\n" name;
413 pr " error (g, \"%s: failed to parse reply\");\n" name;
419 pr " rv->cb_done = 1;\n";
420 pr " main_loop.main_loop_quit (g);\n";
423 (* Generate the action stub. *)
424 generate_prototype ~extern:false ~semicolon:false ~newline:true
425 ~handle:"g" name style;
430 | RString _ | RStringList _ -> "NULL" in
434 (match snd style with
436 | _ -> pr " struct %s_args args;\n" name
439 pr " struct %s_rv rv;\n" shortname;
442 pr " if (g->state != READY) {\n";
443 pr " error (g, \"%s called from the wrong state, %%d != READY\",\n"
446 pr " return %s;\n" error_code;
449 pr " memset (&rv, 0, sizeof rv);\n";
452 (match snd style with
454 pr " serial = dispatch (g, GUESTFS_PROC_%s, NULL, NULL);\n"
455 (String.uppercase shortname)
459 | String name -> pr " args.%s = (char *) %s;\n" name name
461 pr " serial = dispatch (g, GUESTFS_PROC_%s,\n"
462 (String.uppercase shortname);
463 pr " (xdrproc_t) xdr_%s_args, (char *) &args);\n"
466 pr " if (serial == -1)\n";
467 pr " return %s;\n" error_code;
470 pr " rv.cb_done = 0;\n";
471 pr " g->reply_cb_internal = %s_cb;\n" shortname;
472 pr " g->reply_cb_internal_data = &rv;\n";
473 pr " main_loop.main_loop_run (g);\n";
474 pr " g->reply_cb_internal = NULL;\n";
475 pr " g->reply_cb_internal_data = NULL;\n";
476 pr " if (!rv.cb_done) {\n";
477 pr " error (g, \"%s failed, see earlier error messages\");\n" name;
478 pr " return %s;\n" error_code;
482 pr " if (check_reply_header (g, &rv.hdr, GUESTFS_PROC_%s, serial) == -1)\n"
483 (String.uppercase shortname);
484 pr " return %s;\n" error_code;
487 pr " if (rv.hdr.status == GUESTFS_STATUS_ERROR) {\n";
488 pr " error (g, \"%%s\", rv.err.error);\n";
489 pr " return %s;\n" error_code;
493 (match fst style with
494 | Err -> pr " return 0;\n"
496 pr " return rv.ret.%s; /* caller will free */\n" n
498 pr " /* caller will free this, but we need to add a NULL entry */\n";
499 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;
500 pr " rv.ret.%s.%s_val[rv.ret.%s.%s_len] = NULL;\n" n n n n;
501 pr " return rv.ret.%s.%s_val;\n" n n
507 (* Generate daemon/actions.h. *)
508 and generate_daemon_actions_h () =
509 generate_header CStyle GPLv2;
511 fun (name, style, _, _, _, _) ->
512 generate_prototype ~single_line:true ~newline:true ("do_" ^ name) style;
515 (* Generate the server-side stubs. *)
516 and generate_daemon_actions () =
517 generate_header CStyle GPLv2;
519 pr "#include <rpc/types.h>\n";
520 pr "#include <rpc/xdr.h>\n";
521 pr "#include \"daemon.h\"\n";
522 pr "#include \"../src/guestfs_protocol.h\"\n";
523 pr "#include \"actions.h\"\n";
527 fun (name, style, _, _, _, _) ->
528 (* Generate server-side stubs. *)
529 pr "static void %s_stub (XDR *xdr_in)\n" name;
533 | Err -> pr " int r;\n"; "-1"
534 | RString _ -> pr " char *r;\n"; "NULL"
535 | RStringList _ -> pr " char **r;\n"; "NULL" in
536 (match snd style with
539 pr " struct guestfs_%s_args args;\n" name;
542 | String name -> pr " const char *%s;\n" name
547 (match snd style with
550 pr " memset (&args, 0, sizeof args);\n";
552 pr " if (!xdr_guestfs_%s_args (xdr_in, &args)) {\n" name;
553 pr " reply_with_error (\"%s: daemon failed to decode procedure arguments\");\n" name;
558 | String name -> pr " %s = args.%s;\n" name name
563 pr " r = do_%s " name;
564 generate_call_args style;
567 pr " if (r == %s)\n" error_code;
568 pr " /* do_%s has already called reply_with_error, so just return */\n" name;
572 (match fst style with
573 | Err -> pr " reply (NULL, NULL);\n"
575 pr " struct guestfs_%s_ret ret;\n" name;
576 pr " ret.%s = r;\n" n;
577 pr " reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name;
580 pr " struct guestfs_%s_ret ret;\n" name;
581 pr " ret.%s.%s_len = count_strings (r);\n" n n;
582 pr " ret.%s.%s_val = r;\n" n n;
583 pr " reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name;
584 pr " free_strings (r);\n"
590 (* Dispatch function. *)
591 pr "void dispatch_incoming_message (XDR *xdr_in)\n";
593 pr " switch (proc_nr) {\n";
596 fun (name, style, _, _, _, _) ->
597 pr " case GUESTFS_PROC_%s:\n" (String.uppercase name);
598 pr " %s_stub (xdr_in);\n" name;
603 pr " reply_with_error (\"dispatch_incoming_message: unknown procedure number %%d\", proc_nr);\n";
607 (* Generate a lot of different functions for guestfish. *)
608 and generate_fish_cmds () =
609 generate_header CStyle GPLv2;
611 pr "#include <stdio.h>\n";
612 pr "#include <stdlib.h>\n";
613 pr "#include <string.h>\n";
615 pr "#include \"fish.h\"\n";
618 (* list_commands function, which implements guestfish -h *)
619 pr "void list_commands (void)\n";
621 pr " printf (\" %%-16s %%s\\n\", \"Command\", \"Description\");\n";
622 pr " list_builtin_commands ();\n";
624 fun (name, _, _, _, shortdesc, _) ->
625 let name = replace name '_' '-' in
626 pr " printf (\"%%-20s %%s\\n\", \"%s\", \"%s\");\n"
629 pr " printf (\" Use -h <cmd> / help <cmd> to show detailed help for a command.\\n\");\n";
633 (* display_command function, which implements guestfish -h cmd *)
634 pr "void display_command (const char *cmd)\n";
637 fun (name, style, _, flags, shortdesc, longdesc) ->
638 let name2 = replace name '_' '-' in
645 String.concat "> <" (
647 | String n -> n) args
652 if List.mem ProtocolLimitWarning flags then
653 "\n\nBecause of the message protocol, there is a transfer limit
654 of somewhere between 2MB and 4MB. To transfer large files you should use
659 pr "strcasecmp (cmd, \"%s\") == 0" name;
660 if name <> name2 then
661 pr " || strcasecmp (cmd, \"%s\") == 0" name2;
663 pr " pod2text (\"%s - %s\", %S);\n"
665 (" " ^ synopsis ^ "\n\n" ^ longdesc ^ warnings);
668 pr " display_builtin_command (cmd);\n";
672 (* run_<action> actions *)
674 fun (name, style, _, _, _, _) ->
675 pr "static int run_%s (const char *cmd, int argc, char *argv[])\n" name;
677 (match fst style with
678 | Err -> pr " int r;\n"
679 | RString _ -> pr " char *r;\n"
680 | RStringList _ -> pr " char **r;\n"
684 | String name -> pr " const char *%s;\n" name
687 (* Check and convert parameters. *)
688 let argc_expected = nr_args (snd style) in
689 pr " if (argc != %d) {\n" argc_expected;
690 pr " fprintf (stderr, \"%%s should have %d parameter(s)\\n\", cmd);\n"
692 pr " fprintf (stderr, \"type 'help %%s' for help on %%s\\n\", cmd, cmd);\n";
698 | String name -> pr " %s = argv[%d];\n" name i
701 (* Call C API function. *)
702 pr " r = guestfs_%s " name;
703 generate_call_args ~handle:"g" style;
706 (* Check return value for errors and display command results. *)
707 (match fst style with
708 | Err -> pr " return r;\n"
710 pr " if (r == NULL) return -1;\n";
711 pr " printf (\"%%s\", r);\n";
715 pr " if (r == NULL) return -1;\n";
716 pr " print_strings (r);\n";
717 pr " free_strings (r);\n";
724 (* run_action function *)
725 pr "int run_action (const char *cmd, int argc, char *argv[])\n";
728 fun (name, _, _, _, _, _) ->
729 let name2 = replace name '_' '-' in
731 pr "strcasecmp (cmd, \"%s\") == 0" name;
732 if name <> name2 then
733 pr " || strcasecmp (cmd, \"%s\") == 0" name2;
735 pr " return run_%s (cmd, argc, argv);\n" name;
739 pr " fprintf (stderr, \"%%s: unknown command\\n\", cmd);\n";
746 (* Generate a C function prototype. *)
747 and generate_prototype ?(extern = true) ?(static = false) ?(semicolon = true)
748 ?(single_line = false) ?(newline = false)
750 if extern then pr "extern ";
751 if static then pr "static ";
752 (match fst style with
754 | RString _ -> pr "char *"
755 | RStringList _ -> pr "char **"
758 let comma = ref false in
761 | Some handle -> pr "guestfs_h *%s" handle; comma := true
765 if single_line then pr ", " else pr ",\n\t\t"
771 | String name -> next (); pr "const char *%s" name
774 if semicolon then pr ";";
775 if newline then pr "\n"
777 (* Generate C call arguments, eg "(handle, foo, bar)" *)
778 and generate_call_args ?handle style =
780 let comma = ref false in
783 | Some handle -> pr "%s" handle; comma := true
787 if !comma then pr ", ";
790 | String name -> pr "%s" name
794 let output_to filename =
795 let filename_new = filename ^ ".new" in
796 chan := open_out filename_new;
800 Unix.rename filename_new filename;
801 printf "written %s\n%!" filename;
809 let close = output_to "src/guestfs_protocol.x" in
813 let close = output_to "src/guestfs-actions.h" in
814 generate_actions_h ();
817 let close = output_to "src/guestfs-actions.c" in
818 generate_client_actions ();
821 let close = output_to "daemon/actions.h" in
822 generate_daemon_actions_h ();
825 let close = output_to "daemon/stubs.c" in
826 generate_daemon_actions ();
829 let close = output_to "fish/cmds.c" in
830 generate_fish_cmds ();
833 let close = output_to "guestfs-actions.pod" in