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   ("mount", (Err, P2 (String "device", String "mountpoint")), 1, [],
  52    "mount a guest disk at a position in the filesystem",
  53    "\
  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
  58 names can be used.
  59
  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
  63 exist.
  64
  65 The mounted filesystem is writable, if we have sufficient permissions
  66 on the underlying device.
  67
  68 The filesystem options C<sync> and C<noatime> are set with this
  69 call, in order to improve reliability.");
  70
  71   ("sync", (Err, P0), 2, [],
  72    "sync disks, writes are flushed through to the disk image",
  73    "\
  74 This syncs the disk, so that any writes are flushed through to the
  75 underlying disk image.
  76
  77 You should always call this if you have modified a disk image, before
  78 calling C<guestfs_close>.");
  79
  80   ("touch", (Err, P1 (String "path")), 3, [],
  81    "update file timestamps or create a new file",
  82    "\
  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.");
  86
  87   ("cat", (RString "content", P1 (String "path")), 4, [ProtocolLimitWarning],
  88    "list the contents of a file",
  89    "\
  90 Return the contents of the file named C<path>.
  91
  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.");
  96
  97   ("ll", (RString "listing", P1 (String "directory")), 5, [],
  98    "list the files in a directory (long format)",
  99    "\
 100 List the files in C<directory> (relative to the root directory,
 101 there is no cwd) in the format of 'ls -la'.
 102
 103 This command is mostly useful for interactive sessions.  It
 104 is I<not> intended that you try to parse the output string.");
 105
 106   ("ls", (RStringList "listing", P1 (String "directory")), 6, [],
 107    "list the files in a directory",
 108    "\
 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.
 112
 113 This command is mostly useful for interactive sessions.  Programs
 114 should probably use C<guestfs_readdir> instead.");
 115
 116   ("list_devices", (RStringList "devices", P0), 7, [],
 117    "list the block devices",
 118    "\
 119 List all the block devices.
 120
 121 The full block device names are returned, eg. C</dev/sda>
 122 ");
 123
 124   ("list_partitions", (RStringList "partitions", P0), 8, [],
 125    "list the partitions",
 126    "\
 127 List all the partitions detected on all block devices.
 128
 129 The full partition device names are returned, eg. C</dev/sda1>
 130
 131 This does not return logical volumes.  For that you will need to
 132 call C<guestfs_lvs>.");
 133 ]
 134
 135 (* In some places we want the functions to be displayed sorted
 136  * alphabetically, so this is useful:
 137  *)
 138 let sorted_functions =
 139   List.sort (fun (n1,_,_,_,_,_) (n2,_,_,_,_,_) -> compare n1 n2) functions
 140
 141 (* Useful functions. *)
 142 let failwithf fs = ksprintf failwith fs
 143 let replace s c1 c2 =
 144   let s2 = String.copy s in
 145   let r = ref false 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;
 149       r := true
 150     )
 151   done;
 152   if not !r then s else s2
 153
 154 (* 'pr' prints to the current output file. *)
 155 let chan = ref stdout
 156 let pr fs = ksprintf (output_string !chan) fs
 157
 158 let iter_args f = function
 159   | P0 -> ()
 160   | P1 arg1 -> f arg1
 161   | P2 (arg1, arg2) -> f arg1; f arg2
 162
 163 let iteri_args f = function
 164   | P0 -> ()
 165   | P1 arg1 -> f 0 arg1
 166   | P2 (arg1, arg2) -> f 0 arg1; f 1 arg2
 167
 168 let map_args f = function
 169   | P0 -> []
 170   | P1 arg1 -> [f arg1]
 171   | P2 (arg1, arg2) -> [f arg1; f arg2]
 172
 173 let nr_args = function | P0 -> 0 | P1 _ -> 1 | P2 _ -> 2
 174
 175 (* Check function names etc. for consistency. *)
 176 let check_functions () =
 177   List.iter (
 178     fun (name, _, _, _, _, _) ->
 179       if String.contains name '-' then
 180         failwithf "Function name '%s' should not contain '-', use '_' instead."
 181           name
 182   ) functions;
 183
 184   let proc_nrs =
 185     List.map (fun (name, _, proc_nr, _, _, _) -> name, proc_nr) functions in
 186   let proc_nrs =
 187     List.sort (fun (_,nr1) (_,nr2) -> compare nr1 nr2) proc_nrs in
 188   let rec loop = function
 189     | [] -> ()
 190     | [_] -> ()
 191     | (name1,nr1) :: ((name2,nr2) :: _ as rest) when nr1 < nr2 ->
 192         loop rest
 193     | (name1,nr1) :: (name2,nr2) :: _ ->
 194         failwithf "'%s' and '%s' have conflicting procedure numbers (%d, %d)"
 195           name1 name2 nr1 nr2
 196   in
 197   loop proc_nrs
 198
 199 type comment_style = CStyle | HashStyle | OCamlStyle
 200 type license = GPLv2 | LGPLv2
 201
 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;
 211   pr "%s\n" c;
 212   pr "%s Copyright (C) 2009 Red Hat Inc.\n" c;
 213   pr "%s\n" c;
 214   (match license with
 215    | GPLv2 ->
 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;
 220        pr "%s\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;
 225        pr "%s\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;
 229
 230    | LGPLv2 ->
 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;
 235        pr "%s\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;
 240        pr "%s\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;
 244   );
 245   (match comment with
 246    | CStyle -> pr " */\n"
 247    | HashStyle -> ()
 248    | OCamlStyle -> pr " *)\n"
 249   );
 250   pr "\n"
 251
 252 (* Generate the pod documentation for the C API. *)
 253 and generate_pod () =
 254   List.iter (
 255     fun (shortname, style, _, flags, _, longdesc) ->
 256       let name = "guestfs_" ^ shortname in
 257       pr "=head2 %s\n\n" name;
 258       pr " ";
 259       generate_prototype ~extern:false ~handle:"handle" name style;
 260       pr "\n\n";
 261       pr "%s\n\n" longdesc;
 262       (match fst style with
 263        | Err ->
 264            pr "This function returns 0 on success or -1 on error.\n\n"
 265        | RString _ ->
 266            pr "This function returns a string or NULL on error.
 267 I<The caller must free the returned string after use>.\n\n"
 268        | RStringList _ ->
 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"
 272       );
 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
 276 FTP.\n\n";
 277   ) sorted_functions
 278
 279 (* Generate the protocol (XDR) file. *)
 280 and generate_xdr () =
 281   generate_header CStyle LGPLv2;
 282
 283   (* This has to be defined to get around a limitation in Sun's rpcgen. *)
 284   pr "typedef string str<>;\n";
 285   pr "\n";
 286
 287   List.iter (
 288     fun (shortname, style, _, _, _, _) ->
 289       let name = "guestfs_" ^ shortname in
 290       pr "/* %s */\n\n" name;
 291       (match snd style with
 292        | P0 -> ()
 293        | args ->
 294            pr "struct %s_args {\n" name;
 295            iter_args (
 296              function
 297              | String name -> pr "  string %s<>;\n" name
 298            ) args;
 299            pr "};\n\n"
 300       );
 301       (match fst style with
 302        | Err -> ()
 303        | RString n ->
 304            pr "struct %s_ret {\n" name;
 305            pr "  string %s<>;\n" n;
 306            pr "};\n\n"
 307        | RStringList n ->
 308            pr "struct %s_ret {\n" name;
 309            pr "  str %s<>;\n" n;
 310            pr "};\n\n"
 311       );
 312   ) functions;
 313
 314   (* Table of procedure numbers. *)
 315   pr "enum guestfs_procedure {\n";
 316   List.iter (
 317     fun (shortname, _, proc_nr, _, _, _) ->
 318       pr "  GUESTFS_PROC_%s = %d,\n" (String.uppercase shortname) proc_nr
 319   ) functions;
 320   pr "  GUESTFS_PROC_dummy\n"; (* so we don't have a "hanging comma" *)
 321   pr "};\n";
 322   pr "\n";
 323
 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.
 329    *)
 330   pr "const GUESTFS_MESSAGE_MAX = %d;\n" (4 * 1024 * 1024);
 331   pr "\n";
 332
 333   (* Message header, etc. *)
 334   pr "\
 335 const GUESTFS_PROGRAM = 0x2000F5F5;
 336 const GUESTFS_PROTOCOL_VERSION = 1;
 337
 338 enum guestfs_message_direction {
 339   GUESTFS_DIRECTION_CALL = 0,        /* client -> daemon */
 340   GUESTFS_DIRECTION_REPLY = 1        /* daemon -> client */
 341 };
 342
 343 enum guestfs_message_status {
 344   GUESTFS_STATUS_OK = 0,
 345   GUESTFS_STATUS_ERROR = 1
 346 };
 347
 348 const GUESTFS_ERROR_LEN = 256;
 349
 350 struct guestfs_message_error {
 351   string error<GUESTFS_ERROR_LEN>;   /* error message */
 352 };
 353
 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;
 361 };
 362 "
 363
 364 (* Generate the guestfs-actions.h file. *)
 365 and generate_actions_h () =
 366   generate_header CStyle LGPLv2;
 367   List.iter (
 368     fun (shortname, style, _, _, _, _) ->
 369       let name = "guestfs_" ^ shortname in
 370       generate_prototype ~single_line:true ~newline:true ~handle:"handle"
 371         name style
 372   ) functions
 373
 374 (* Generate the client-side dispatch stubs. *)
 375 and generate_client_actions () =
 376   generate_header CStyle LGPLv2;
 377   List.iter (
 378     fun (shortname, style, _, _, _, _) ->
 379       let name = "guestfs_" ^ shortname in
 380
 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
 387        | Err -> ()
 388        | RString _ | RStringList _ -> pr "  struct %s_ret ret;\n" name;
 389       );
 390       pr "};\n\n";
 391
 392       (* Generate the callback function. *)
 393       pr "static void %s_cb (guestfs_h *g, void *data, XDR *xdr)\n" shortname;
 394       pr "{\n";
 395       pr "  struct %s_rv *rv = (struct %s_rv *) data;\n" shortname shortname;
 396       pr "\n";
 397       pr "  if (!xdr_guestfs_message_header (xdr, &rv->hdr)) {\n";
 398       pr "    error (g, \"%s: failed to parse reply header\");\n" name;
 399       pr "    return;\n";
 400       pr "  }\n";
 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;
 404       pr "      return;\n";
 405       pr "    }\n";
 406       pr "    goto done;\n";
 407       pr "  }\n";
 408
 409       (match fst style with
 410        | Err -> ()
 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;
 414             pr "    return;\n";
 415             pr "  }\n";
 416       );
 417
 418       pr " done:\n";
 419       pr "  rv->cb_done = 1;\n";
 420       pr "  main_loop.main_loop_quit (g);\n";
 421       pr "}\n\n";
 422
 423       (* Generate the action stub. *)
 424       generate_prototype ~extern:false ~semicolon:false ~newline:true
 425         ~handle:"g" name style;
 426
 427       let error_code =
 428         match fst style with
 429         | Err -> "-1"
 430         | RString _ | RStringList _ -> "NULL" in
 431
 432       pr "{\n";
 433
 434       (match snd style with
 435        | P0 -> ()
 436        | _ -> pr "  struct %s_args args;\n" name
 437       );
 438
 439       pr "  struct %s_rv rv;\n" shortname;
 440       pr "  int serial;\n";
 441       pr "\n";
 442       pr "  if (g->state != READY) {\n";
 443       pr "    error (g, \"%s called from the wrong state, %%d != READY\",\n"
 444         name;
 445       pr "      g->state);\n";
 446       pr "    return %s;\n" error_code;
 447       pr "  }\n";
 448       pr "\n";
 449       pr "  memset (&rv, 0, sizeof rv);\n";
 450       pr "\n";
 451
 452       (match snd style with
 453        | P0 ->
 454            pr "  serial = dispatch (g, GUESTFS_PROC_%s, NULL, NULL);\n"
 455              (String.uppercase shortname)
 456        | args ->
 457            iter_args (
 458              function
 459              | String name -> pr "  args.%s = (char *) %s;\n" name name
 460            ) args;
 461            pr "  serial = dispatch (g, GUESTFS_PROC_%s,\n"
 462              (String.uppercase shortname);
 463            pr "                     (xdrproc_t) xdr_%s_args, (char *) &args);\n"
 464              name;
 465       );
 466       pr "  if (serial == -1)\n";
 467       pr "    return %s;\n" error_code;
 468       pr "\n";
 469
 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;
 479       pr "  }\n";
 480       pr "\n";
 481
 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;
 485       pr "\n";
 486
 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;
 490       pr "  }\n";
 491       pr "\n";
 492
 493       (match fst style with
 494        | Err -> pr "  return 0;\n"
 495        | RString n ->
 496            pr "  return rv.ret.%s; /* caller will free */\n" n
 497        | RStringList 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
 502       );
 503
 504       pr "}\n\n"
 505   ) functions
 506
 507 (* Generate daemon/actions.h. *)
 508 and generate_daemon_actions_h () =
 509   generate_header CStyle GPLv2;
 510   List.iter (
 511     fun (name, style, _, _, _, _) ->
 512       generate_prototype ~single_line:true ~newline:true ("do_" ^ name) style;
 513   ) functions
 514
 515 (* Generate the server-side stubs. *)
 516 and generate_daemon_actions () =
 517   generate_header CStyle GPLv2;
 518
 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";
 524   pr "\n";
 525
 526   List.iter (
 527     fun (name, style, _, _, _, _) ->
 528       (* Generate server-side stubs. *)
 529       pr "static void %s_stub (XDR *xdr_in)\n" name;
 530       pr "{\n";
 531       let error_code =
 532         match fst style with
 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
 537        | P0 -> ()
 538        | args ->
 539            pr "  struct guestfs_%s_args args;\n" name;
 540            iter_args (
 541              function
 542              | String name -> pr "  const char *%s;\n" name
 543            ) args
 544       );
 545       pr "\n";
 546
 547       (match snd style with
 548        | P0 -> ()
 549        | args ->
 550            pr "  memset (&args, 0, sizeof args);\n";
 551            pr "\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;
 554            pr "    return;\n";
 555            pr "  }\n";
 556            iter_args (
 557              function
 558              | String name -> pr "  %s = args.%s;\n" name name
 559            ) args;
 560            pr "\n"
 561       );
 562
 563       pr "  r = do_%s " name;
 564       generate_call_args style;
 565       pr ";\n";
 566
 567       pr "  if (r == %s)\n" error_code;
 568       pr "    /* do_%s has already called reply_with_error, so just return */\n" name;
 569       pr "    return;\n";
 570       pr "\n";
 571
 572       (match fst style with
 573        | Err -> pr "  reply (NULL, NULL);\n"
 574        | RString 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;
 578            pr "  free (r);\n"
 579        | RStringList n ->
 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"
 585       );
 586
 587       pr "}\n\n";
 588   ) functions;
 589
 590   (* Dispatch function. *)
 591   pr "void dispatch_incoming_message (XDR *xdr_in)\n";
 592   pr "{\n";
 593   pr "  switch (proc_nr) {\n";
 594
 595   List.iter (
 596     fun (name, style, _, _, _, _) ->
 597       pr "    case GUESTFS_PROC_%s:\n" (String.uppercase name);
 598       pr "      %s_stub (xdr_in);\n" name;
 599       pr "      break;\n"
 600   ) functions;
 601
 602   pr "    default:\n";
 603   pr "      reply_with_error (\"dispatch_incoming_message: unknown procedure number %%d\", proc_nr);\n";
 604   pr "  }\n";
 605   pr "}\n"
 606
 607 (* Generate a lot of different functions for guestfish. *)
 608 and generate_fish_cmds () =
 609   generate_header CStyle GPLv2;
 610
 611   pr "#include <stdio.h>\n";
 612   pr "#include <stdlib.h>\n";
 613   pr "#include <string.h>\n";
 614   pr "\n";
 615   pr "#include \"fish.h\"\n";
 616   pr "\n";
 617
 618   (* list_commands function, which implements guestfish -h *)
 619   pr "void list_commands (void)\n";
 620   pr "{\n";
 621   pr "  printf (\"    %%-16s     %%s\\n\", \"Command\", \"Description\");\n";
 622   pr "  list_builtin_commands ();\n";
 623   List.iter (
 624     fun (name, _, _, _, shortdesc, _) ->
 625       let name = replace name '_' '-' in
 626       pr "  printf (\"%%-20s %%s\\n\", \"%s\", \"%s\");\n"
 627         name shortdesc
 628   ) sorted_functions;
 629   pr "  printf (\"    Use -h <cmd> / help <cmd> to show detailed help for a command.\\n\");\n";
 630   pr "}\n";
 631   pr "\n";
 632
 633   (* display_command function, which implements guestfish -h cmd *)
 634   pr "void display_command (const char *cmd)\n";
 635   pr "{\n";
 636   List.iter (
 637     fun (name, style, _, flags, shortdesc, longdesc) ->
 638       let name2 = replace name '_' '-' in
 639       let synopsis =
 640         match snd style with
 641         | P0 -> name2
 642         | args ->
 643             sprintf "%s <%s>"
 644               name2 (
 645                 String.concat "> <" (
 646                   map_args (function
 647                             | String n -> n) args
 648                 )
 649               ) in
 650
 651       let warnings =
 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
 655 FTP."
 656         else "" in
 657
 658       pr "  if (";
 659       pr "strcasecmp (cmd, \"%s\") == 0" name;
 660       if name <> name2 then
 661         pr " || strcasecmp (cmd, \"%s\") == 0" name2;
 662       pr ")\n";
 663       pr "    pod2text (\"%s - %s\", %S);\n"
 664         name2 shortdesc
 665         (" " ^ synopsis ^ "\n\n" ^ longdesc ^ warnings);
 666       pr "  else\n"
 667   ) functions;
 668   pr "    display_builtin_command (cmd);\n";
 669   pr "}\n";
 670   pr "\n";
 671
 672   (* run_<action> actions *)
 673   List.iter (
 674     fun (name, style, _, _, _, _) ->
 675       pr "static int run_%s (const char *cmd, int argc, char *argv[])\n" name;
 676       pr "{\n";
 677       (match fst style with
 678        | Err -> pr "  int r;\n"
 679        | RString _ -> pr "  char *r;\n"
 680        | RStringList _ -> pr "  char **r;\n"
 681       );
 682       iter_args (
 683         function
 684         | String name -> pr "  const char *%s;\n" name
 685       ) (snd style);
 686
 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"
 691         argc_expected;
 692       pr "    fprintf (stderr, \"type 'help %%s' for help on %%s\\n\", cmd, cmd);\n";
 693       pr "    return -1;\n";
 694       pr "  }\n";
 695       iteri_args (
 696         fun i ->
 697           function
 698           | String name -> pr "  %s = argv[%d];\n" name i
 699       ) (snd style);
 700
 701       (* Call C API function. *)
 702       pr "  r = guestfs_%s " name;
 703       generate_call_args ~handle:"g" style;
 704       pr ";\n";
 705
 706       (* Check return value for errors and display command results. *)
 707       (match fst style with
 708        | Err -> pr "  return r;\n"
 709        | RString _ ->
 710            pr "  if (r == NULL) return -1;\n";
 711            pr "  printf (\"%%s\", r);\n";
 712            pr "  free (r);\n";
 713            pr "  return 0;\n"
 714        | RStringList _ ->
 715            pr "  if (r == NULL) return -1;\n";
 716            pr "  print_strings (r);\n";
 717            pr "  free_strings (r);\n";
 718            pr "  return 0;\n"
 719       );
 720       pr "}\n";
 721       pr "\n"
 722   ) functions;
 723
 724   (* run_action function *)
 725   pr "int run_action (const char *cmd, int argc, char *argv[])\n";
 726   pr "{\n";
 727   List.iter (
 728     fun (name, _, _, _, _, _) ->
 729       let name2 = replace name '_' '-' in
 730       pr "  if (";
 731       pr "strcasecmp (cmd, \"%s\") == 0" name;
 732       if name <> name2 then
 733         pr " || strcasecmp (cmd, \"%s\") == 0" name2;
 734       pr ")\n";
 735       pr "    return run_%s (cmd, argc, argv);\n" name;
 736       pr "  else\n";
 737   ) functions;
 738   pr "    {\n";
 739   pr "      fprintf (stderr, \"%%s: unknown command\\n\", cmd);\n";
 740   pr "      return -1;\n";
 741   pr "    }\n";
 742   pr "  return 0;\n";
 743   pr "}\n";
 744   pr "\n"
 745
 746 (* Generate a C function prototype. *)
 747 and generate_prototype ?(extern = true) ?(static = false) ?(semicolon = true)
 748     ?(single_line = false) ?(newline = false)
 749     ?handle name style =
 750   if extern then pr "extern ";
 751   if static then pr "static ";
 752   (match fst style with
 753    | Err -> pr "int "
 754    | RString _ -> pr "char *"
 755    | RStringList _ -> pr "char **"
 756   );
 757   pr "%s (" name;
 758   let comma = ref false in
 759   (match handle with
 760    | None -> ()
 761    | Some handle -> pr "guestfs_h *%s" handle; comma := true
 762   );
 763   let next () =
 764     if !comma then (
 765       if single_line then pr ", " else pr ",\n\t\t"
 766     );
 767     comma := true
 768   in
 769   iter_args (
 770     function
 771     | String name -> next (); pr "const char *%s" name
 772   ) (snd style);
 773   pr ")";
 774   if semicolon then pr ";";
 775   if newline then pr "\n"
 776
 777 (* Generate C call arguments, eg "(handle, foo, bar)" *)
 778 and generate_call_args ?handle style =
 779   pr "(";
 780   let comma = ref false in
 781   (match handle with
 782    | None -> ()
 783    | Some handle -> pr "%s" handle; comma := true
 784   );
 785   iter_args (
 786     fun arg ->
 787       if !comma then pr ", ";
 788       comma := true;
 789       match arg with
 790       | String name -> pr "%s" name
 791   ) (snd style);
 792   pr ")"
 793
 794 let output_to filename =
 795   let filename_new = filename ^ ".new" in
 796   chan := open_out filename_new;
 797   let close () =
 798     close_out !chan;
 799     chan := stdout;
 800     Unix.rename filename_new filename;
 801     printf "written %s\n%!" filename;
 802   in
 803   close
 804
 805 (* Main program. *)
 806 let () =
 807   check_functions ();
 808
 809   let close = output_to "src/guestfs_protocol.x" in
 810   generate_xdr ();
 811   close ();
 812
 813   let close = output_to "src/guestfs-actions.h" in
 814   generate_actions_h ();
 815   close ();
 816
 817   let close = output_to "src/guestfs-actions.c" in
 818   generate_client_actions ();
 819   close ();
 820
 821   let close = output_to "daemon/actions.h" in
 822   generate_daemon_actions_h ();
 823   close ();
 824
 825   let close = output_to "daemon/stubs.c" in
 826   generate_daemon_actions ();
 827   close ();
 828
 829   let close = output_to "fish/cmds.c" in
 830   generate_fish_cmds ();
 831   close ();
 832
 833   let close = output_to "guestfs-actions.pod" in
 834   generate_pod ();
 835   close ()