src/generator.ml

   1 #!/usr/bin/ocamlrun ocaml
   2 (* libguestfs
   3  * Copyright (C) 2009 Red Hat Inc.
   4  *
   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.
   9  *
  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.
  14  *
  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
  18  *
  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.
  23  *)
  24
  25 #load "unix.cma";;
  26
  27 open Printf
  28
  29 type style = ret * args
  30 and ret =
  31     (* "Err" as a return value means an int used as a simple error
  32      * indication, ie. 0 or -1.
  33      *)
  34   | Err
  35     (* "RString" and "RStringList" require special treatment because
  36      * the caller must free them.
  37      *)
  38   | RString of string
  39   | RStringList of string
  40 and args =
  41     (* 0 arguments, 1 argument, etc. The guestfs_h param is implicit. *)
  42   | P0
  43   | P1 of argt
  44   | P2 of argt * argt
  45 and argt =
  46   | String of string    (* const char *name, cannot be NULL *)
  47
  48 type flags = ProtocolLimitWarning
  49
  50 let functions = [
  51   ("cat", (RString "content", P1 (String "path")), 4, [ProtocolLimitWarning],
  52    "list the contents of a file",
  53    "\
  54 Return the contents of the file named C<path>.
  55
  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.");
  60
  61   ("ll", (RString "listing", P1 (String "directory")), 5, [],
  62    "list the files in a directory (long format)",
  63    "\
  64 List the files in C<directory> (relative to the root directory,
  65 there is no cwd) in the format of 'ls -la'.
  66
  67 This command is mostly useful for interactive sessions.  It
  68 is I<not> intended that you try to parse the output string.");
  69
  70   ("ls", (RStringList "listing", P1 (String "directory")), 6, [],
  71    "list the files in a directory",
  72    "\
  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.
  76
  77 This command is mostly useful for interactive sessions.  Programs
  78 should probably use C<guestfs_readdir> instead.");
  79
  80   ("mount", (Err, P2 (String "device", String "mountpoint")), 1, [],
  81    "mount a guest disk at a position in the filesystem",
  82    "\
  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
  87 names can be used.
  88
  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
  92 exist.
  93
  94 The mounted filesystem is writable, if we have sufficient permissions
  95 on the underlying device.
  96
  97 The filesystem options C<sync> and C<noatime> are set with this
  98 call, in order to improve reliability.");
  99
 100   ("sync", (Err, P0), 2, [],
 101    "sync disks, writes are flushed through to the disk image",
 102    "\
 103 This syncs the disk, so that any writes are flushed through to the
 104 underlying disk image.
 105
 106 You should always call this if you have modified a disk image, before
 107 calling C<guestfs_close>.");
 108
 109   ("touch", (Err, P1 (String "path")), 3, [],
 110    "update file timestamps or create a new file",
 111    "\
 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.");
 115 ]
 116
 117 (* 'pr' prints to the current output file. *)
 118 let chan = ref stdout
 119 let pr fs = ksprintf (output_string !chan) fs
 120
 121 let iter_args f = function
 122   | P0 -> ()
 123   | P1 arg1 -> f arg1
 124   | P2 (arg1, arg2) -> f arg1; f arg2
 125
 126 let iteri_args f = function
 127   | P0 -> ()
 128   | P1 arg1 -> f 0 arg1
 129   | P2 (arg1, arg2) -> f 0 arg1; f 1 arg2
 130
 131 let map_args f = function
 132   | P0 -> []
 133   | P1 arg1 -> [f arg1]
 134   | P2 (arg1, arg2) -> [f arg1; f arg2]
 135
 136 let nr_args = function | P0 -> 0 | P1 _ -> 1 | P2 _ -> 2
 137
 138 type comment_style = CStyle | HashStyle | OCamlStyle
 139 type license = GPLv2 | LGPLv2
 140
 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;
 150   pr "%s\n" c;
 151   pr "%s Copyright (C) 2009 Red Hat Inc.\n" c;
 152   pr "%s\n" c;
 153   (match license with
 154    | GPLv2 ->
 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;
 159        pr "%s\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;
 164        pr "%s\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;
 168
 169    | LGPLv2 ->
 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;
 174        pr "%s\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;
 179        pr "%s\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;
 183   );
 184   (match comment with
 185    | CStyle -> pr " */\n"
 186    | HashStyle -> ()
 187    | OCamlStyle -> pr " *)\n"
 188   );
 189   pr "\n"
 190
 191 (* Generate the pod documentation for the C API. *)
 192 and generate_pod () =
 193   List.iter (
 194     fun (shortname, style, _, flags, _, longdesc) ->
 195       let name = "guestfs_" ^ shortname in
 196       pr "=head2 %s\n\n" name;
 197       pr " ";
 198       generate_prototype ~extern:false ~handle:"handle" name style;
 199       pr "\n\n";
 200       pr "%s\n\n" longdesc;
 201       (match fst style with
 202        | Err ->
 203            pr "This function returns 0 on success or -1 on error.\n\n"
 204        | RString _ ->
 205            pr "This function returns a string or NULL on error.  The caller
 206 must free the returned string after use.\n\n"
 207        | RStringList _ ->
 208            pr "This function returns a NULL-terminated array of strings
 209 (like L<environ(3)>), or NULL if there was an error.
 210
 211 The caller must free the strings I<and> the array after use.\n\n"
 212       );
 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
 216 FTP.\n\n";
 217   ) functions
 218
 219 (* Generate the protocol (XDR) file. *)
 220 and generate_xdr () =
 221   generate_header CStyle LGPLv2;
 222
 223   (* This has to be defined to get around a limitation in Sun's rpcgen. *)
 224   pr "typedef string str<>;\n";
 225   pr "\n";
 226
 227   List.iter (
 228     fun (shortname, style, _, _, _, _) ->
 229       let name = "guestfs_" ^ shortname in
 230       pr "/* %s */\n\n" name;
 231       (match snd style with
 232        | P0 -> ()
 233        | args ->
 234            pr "struct %s_args {\n" name;
 235            iter_args (
 236              function
 237              | String name -> pr "  string %s<>;\n" name
 238            ) args;
 239            pr "};\n\n"
 240       );
 241       (match fst style with
 242        | Err -> ()
 243        | RString n ->
 244            pr "struct %s_ret {\n" name;
 245            pr "  string %s<>;\n" n;
 246            pr "};\n\n"
 247        | RStringList n ->
 248            pr "struct %s_ret {\n" name;
 249            pr "  str %s<>;\n" n;
 250            pr "};\n\n"
 251       );
 252   ) functions;
 253
 254   (* Table of procedure numbers. *)
 255   pr "enum guestfs_procedure {\n";
 256   List.iter (
 257     fun (shortname, _, proc_nr, _, _, _) ->
 258       pr "  GUESTFS_PROC_%s = %d,\n" (String.uppercase shortname) proc_nr
 259   ) functions;
 260   pr "  GUESTFS_PROC_dummy\n"; (* so we don't have a "hanging comma" *)
 261   pr "};\n";
 262   pr "\n";
 263
 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.
 269    *)
 270   pr "const GUESTFS_MESSAGE_MAX = %d;\n" (4 * 1024 * 1024);
 271   pr "\n";
 272
 273   (* Message header, etc. *)
 274   pr "\
 275 const GUESTFS_PROGRAM = 0x2000F5F5;
 276 const GUESTFS_PROTOCOL_VERSION = 1;
 277
 278 enum guestfs_message_direction {
 279   GUESTFS_DIRECTION_CALL = 0,        /* client -> daemon */
 280   GUESTFS_DIRECTION_REPLY = 1        /* daemon -> client */
 281 };
 282
 283 enum guestfs_message_status {
 284   GUESTFS_STATUS_OK = 0,
 285   GUESTFS_STATUS_ERROR = 1
 286 };
 287
 288 const GUESTFS_ERROR_LEN = 256;
 289
 290 struct guestfs_message_error {
 291   string error<GUESTFS_ERROR_LEN>;   /* error message */
 292 };
 293
 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;
 301 };
 302 "
 303
 304 (* Generate the guestfs-actions.h file. *)
 305 and generate_actions_h () =
 306   generate_header CStyle LGPLv2;
 307   List.iter (
 308     fun (shortname, style, _, _, _, _) ->
 309       let name = "guestfs_" ^ shortname in
 310       generate_prototype ~single_line:true ~newline:true ~handle:"handle"
 311         name style
 312   ) functions
 313
 314 (* Generate the client-side dispatch stubs. *)
 315 and generate_client_actions () =
 316   generate_header CStyle LGPLv2;
 317   List.iter (
 318     fun (shortname, style, _, _, _, _) ->
 319       let name = "guestfs_" ^ shortname in
 320
 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
 327        | Err -> ()
 328        | RString _ | RStringList _ -> pr "  struct %s_ret ret;\n" name;
 329       );
 330       pr "};\n\n";
 331
 332       (* Generate the callback function. *)
 333       pr "static void %s_cb (guestfs_h *g, void *data, XDR *xdr)\n" shortname;
 334       pr "{\n";
 335       pr "  struct %s_rv *rv = (struct %s_rv *) data;\n" shortname shortname;
 336       pr "\n";
 337       pr "  if (!xdr_guestfs_message_header (xdr, &rv->hdr)) {\n";
 338       pr "    error (g, \"%s: failed to parse reply header\");\n" name;
 339       pr "    return;\n";
 340       pr "  }\n";
 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;
 344       pr "      return;\n";
 345       pr "    }\n";
 346       pr "    goto done;\n";
 347       pr "  }\n";
 348
 349       (match fst style with
 350        | Err -> ()
 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;
 354             pr "    return;\n";
 355             pr "  }\n";
 356       );
 357
 358       pr " done:\n";
 359       pr "  rv->cb_done = 1;\n";
 360       pr "  main_loop.main_loop_quit (g);\n";
 361       pr "}\n\n";
 362
 363       (* Generate the action stub. *)
 364       generate_prototype ~extern:false ~semicolon:false ~newline:true
 365         ~handle:"g" name style;
 366
 367       let error_code =
 368         match fst style with
 369         | Err -> "-1"
 370         | RString _ | RStringList _ -> "NULL" in
 371
 372       pr "{\n";
 373
 374       (match snd style with
 375        | P0 -> ()
 376        | _ -> pr "  struct %s_args args;\n" name
 377       );
 378
 379       pr "  struct %s_rv rv;\n" shortname;
 380       pr "  int serial;\n";
 381       pr "\n";
 382       pr "  if (g->state != READY) {\n";
 383       pr "    error (g, \"%s called from the wrong state, %%d != READY\",\n"
 384         name;
 385       pr "      g->state);\n";
 386       pr "    return %s;\n" error_code;
 387       pr "  }\n";
 388       pr "\n";
 389       pr "  memset (&rv, 0, sizeof rv);\n";
 390       pr "\n";
 391
 392       (match snd style with
 393        | P0 ->
 394            pr "  serial = dispatch (g, GUESTFS_PROC_%s, NULL, NULL);\n"
 395              (String.uppercase shortname)
 396        | args ->
 397            iter_args (
 398              function
 399              | String name -> pr "  args.%s = (char *) %s;\n" name name
 400            ) args;
 401            pr "  serial = dispatch (g, GUESTFS_PROC_%s,\n"
 402              (String.uppercase shortname);
 403            pr "                     (xdrproc_t) xdr_%s_args, (char *) &args);\n"
 404              name;
 405       );
 406       pr "  if (serial == -1)\n";
 407       pr "    return %s;\n" error_code;
 408       pr "\n";
 409
 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;
 419       pr "  }\n";
 420       pr "\n";
 421
 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;
 425       pr "\n";
 426
 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;
 430       pr "  }\n";
 431       pr "\n";
 432
 433       (match fst style with
 434        | Err -> pr "  return 0;\n"
 435        | RString n ->
 436            pr "  return rv.ret.%s; /* caller will free */\n" n
 437        | RStringList 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
 442       );
 443
 444       pr "}\n\n"
 445   ) functions
 446
 447 (* Generate daemon/actions.h. *)
 448 and generate_daemon_actions_h () =
 449   generate_header CStyle GPLv2;
 450   List.iter (
 451     fun (name, style, _, _, _, _) ->
 452       generate_prototype ~single_line:true ~newline:true ("do_" ^ name) style;
 453   ) functions
 454
 455 (* Generate the server-side stubs. *)
 456 and generate_daemon_actions () =
 457   generate_header CStyle GPLv2;
 458
 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";
 464   pr "\n";
 465
 466   List.iter (
 467     fun (name, style, _, _, _, _) ->
 468       (* Generate server-side stubs. *)
 469       pr "static void %s_stub (XDR *xdr_in)\n" name;
 470       pr "{\n";
 471       let error_code =
 472         match fst style with
 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
 477        | P0 -> ()
 478        | args ->
 479            pr "  struct guestfs_%s_args args;\n" name;
 480            iter_args (
 481              function
 482              | String name -> pr "  const char *%s;\n" name
 483            ) args
 484       );
 485       pr "\n";
 486
 487       (match snd style with
 488        | P0 -> ()
 489        | args ->
 490            pr "  memset (&args, 0, sizeof args);\n";
 491            pr "\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;
 494            pr "    return;\n";
 495            pr "  }\n";
 496            iter_args (
 497              function
 498              | String name -> pr "  %s = args.%s;\n" name name
 499            ) args;
 500            pr "\n"
 501       );
 502
 503       pr "  r = do_%s " name;
 504       generate_call_args style;
 505       pr ";\n";
 506
 507       pr "  if (r == %s)\n" error_code;
 508       pr "    /* do_%s has already called reply_with_error, so just return */\n" name;
 509       pr "    return;\n";
 510       pr "\n";
 511
 512       (match fst style with
 513        | Err -> pr "  reply (NULL, NULL);\n"
 514        | RString 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;
 518            pr "  free (r);\n"
 519        | RStringList n ->
 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"
 525       );
 526
 527       pr "}\n\n";
 528   ) functions;
 529
 530   (* Dispatch function. *)
 531   pr "void dispatch_incoming_message (XDR *xdr_in)\n";
 532   pr "{\n";
 533   pr "  switch (proc_nr) {\n";
 534
 535   List.iter (
 536     fun (name, style, _, _, _, _) ->
 537       pr "    case GUESTFS_PROC_%s:\n" (String.uppercase name);
 538       pr "      %s_stub (xdr_in);\n" name;
 539       pr "      break;\n"
 540   ) functions;
 541
 542   pr "    default:\n";
 543   pr "      reply_with_error (\"dispatch_incoming_message: unknown procedure number %%d\", proc_nr);\n";
 544   pr "  }\n";
 545   pr "}\n"
 546
 547 (* Generate a lot of different functions for guestfish. *)
 548 and generate_fish_cmds () =
 549   generate_header CStyle GPLv2;
 550
 551   pr "#include <stdio.h>\n";
 552   pr "#include <stdlib.h>\n";
 553   pr "#include <string.h>\n";
 554   pr "\n";
 555   pr "#include \"fish.h\"\n";
 556   pr "\n";
 557
 558   (* list_commands function, which implements guestfish -h *)
 559   pr "void list_commands (void)\n";
 560   pr "{\n";
 561   pr "  printf (\"    %%-16s     %%s\\n\", \"Command\", \"Description\");\n";
 562   pr "  list_builtin_commands ();\n";
 563   List.iter (
 564     fun (name, _, _, _, shortdesc, _) ->
 565       pr "  printf (\"%%-20s %%s\\n\", \"%s\", \"%s\");\n"
 566         name shortdesc
 567   ) functions;
 568   pr "  printf (\"    Use -h <cmd> / help <cmd> to show detailed help for a command.\\n\");\n";
 569   pr "}\n";
 570   pr "\n";
 571
 572   (* display_command function, which implements guestfish -h cmd *)
 573   pr "void display_command (const char *cmd)\n";
 574   pr "{\n";
 575   List.iter (
 576     fun (name, style, _, flags, shortdesc, longdesc) ->
 577       let synopsis =
 578         match snd style with
 579         | P0 -> name
 580         | args ->
 581             sprintf "%s <%s>"
 582               name (
 583                 String.concat "> <" (
 584                   map_args (function
 585                             | String n -> n) args
 586                 )
 587               ) in
 588
 589       let warnings =
 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
 593 FTP."
 594         else "" in
 595
 596       pr "  if (strcasecmp (cmd, \"%s\") == 0)\n" name;
 597       pr "    pod2text (\"%s - %s\", %S);\n"
 598         name shortdesc
 599         (" " ^ synopsis ^ "\n\n" ^ longdesc ^ warnings);
 600       pr "  else\n"
 601   ) functions;
 602   pr "    display_builtin_command (cmd);\n";
 603   pr "}\n";
 604   pr "\n";
 605
 606   (* run_<action> actions *)
 607   List.iter (
 608     fun (name, style, _, _, _, _) ->
 609       pr "static int run_%s (const char *cmd, int argc, char *argv[])\n" name;
 610       pr "{\n";
 611       (match fst style with
 612        | Err -> pr "  int r;\n"
 613        | RString _ -> pr "  char *r;\n"
 614        | RStringList _ -> pr "  char **r;\n"
 615       );
 616       iter_args (
 617         function
 618         | String name -> pr "  const char *%s;\n" name
 619       ) (snd style);
 620
 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"
 625         argc_expected;
 626       pr "    fprintf (stderr, \"type 'help %%s' for help on %%s\\n\", cmd, cmd);\n";
 627       pr "    return -1;\n";
 628       pr "  }\n";
 629       iteri_args (
 630         fun i ->
 631           function
 632           | String name -> pr "  %s = argv[%d];\n" name i
 633       ) (snd style);
 634
 635       (* Call C API function. *)
 636       pr "  r = guestfs_%s " name;
 637       generate_call_args ~handle:"g" style;
 638       pr ";\n";
 639
 640       (* Check return value for errors and display command results. *)
 641       (match fst style with
 642        | Err -> pr "  return r;\n"
 643        | RString _ ->
 644            pr "  if (r == NULL) return -1;\n";
 645            pr "  printf (\"%%s\", r);\n";
 646            pr "  free (r);\n";
 647            pr "  return 0;\n"
 648        | RStringList _ ->
 649            pr "  if (r == NULL) return -1;\n";
 650            pr "  print_strings (r);\n";
 651            pr "  free_strings (r);\n";
 652            pr "  return 0;\n"
 653       );
 654       pr "}\n";
 655       pr "\n"
 656   ) functions;
 657
 658   (* run_action function *)
 659   pr "int run_action (const char *cmd, int argc, char *argv[])\n";
 660   pr "{\n";
 661   List.iter (
 662     fun (name, _, _, _, _, _) ->
 663       pr "  if (strcasecmp (cmd, \"%s\") == 0)\n" name;
 664       pr "    return run_%s (cmd, argc, argv);\n" name;
 665       pr "  else\n";
 666   ) functions;
 667   pr "    {\n";
 668   pr "      fprintf (stderr, \"%%s: unknown command\\n\", cmd);\n";
 669   pr "      return -1;\n";
 670   pr "    }\n";
 671   pr "  return 0;\n";
 672   pr "}\n";
 673   pr "\n"
 674
 675 (* Generate a C function prototype. *)
 676 and generate_prototype ?(extern = true) ?(static = false) ?(semicolon = true)
 677     ?(single_line = false) ?(newline = false)
 678     ?handle name style =
 679   if extern then pr "extern ";
 680   if static then pr "static ";
 681   (match fst style with
 682    | Err -> pr "int "
 683    | RString _ -> pr "char *"
 684    | RStringList _ -> pr "char **"
 685   );
 686   pr "%s (" name;
 687   let comma = ref false in
 688   (match handle with
 689    | None -> ()
 690    | Some handle -> pr "guestfs_h *%s" handle; comma := true
 691   );
 692   let next () =
 693     if !comma then (
 694       if single_line then pr ", " else pr ",\n\t\t"
 695     );
 696     comma := true
 697   in
 698   iter_args (
 699     function
 700     | String name -> next (); pr "const char *%s" name
 701   ) (snd style);
 702   pr ")";
 703   if semicolon then pr ";";
 704   if newline then pr "\n"
 705
 706 (* Generate C call arguments, eg "(handle, foo, bar)" *)
 707 and generate_call_args ?handle style =
 708   pr "(";
 709   let comma = ref false in
 710   (match handle with
 711    | None -> ()
 712    | Some handle -> pr "%s" handle; comma := true
 713   );
 714   iter_args (
 715     fun arg ->
 716       if !comma then pr ", ";
 717       comma := true;
 718       match arg with
 719       | String name -> pr "%s" name
 720   ) (snd style);
 721   pr ")"
 722
 723 let output_to filename =
 724   let filename_new = filename ^ ".new" in
 725   chan := open_out filename_new;
 726   let close () =
 727     close_out !chan;
 728     chan := stdout;
 729     Unix.rename filename_new filename;
 730     printf "written %s\n%!" filename;
 731   in
 732   close
 733
 734 (* Main program. *)
 735 let () =
 736   let close = output_to "src/guestfs_protocol.x" in
 737   generate_xdr ();
 738   close ();
 739
 740   let close = output_to "src/guestfs-actions.h" in
 741   generate_actions_h ();
 742   close ();
 743
 744   let close = output_to "src/guestfs-actions.c" in
 745   generate_client_actions ();
 746   close ();
 747
 748   let close = output_to "daemon/actions.h" in
 749   generate_daemon_actions_h ();
 750   close ();
 751
 752   let close = output_to "daemon/stubs.c" in
 753   generate_daemon_actions ();
 754   close ();
 755
 756   let close = output_to "fish/cmds.c" in
 757   generate_fish_cmds ();
 758   close ();
 759
 760   let close = output_to "guestfs-actions.pod" in
 761   generate_pod ();
 762   close ()