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   ("ll", (RString "listing", P1 (String "directory")), 5, [],
  57    "list the files in a directory (long format)",
  58    "\
  59 List the files in C<directory> (relative to the root directory,
  60 there is no cwd) in the format of 'ls -la'.
  61
  62 This command is mostly useful for interactive sessions.  It
  63 is I<not> intended that you try to parse the output string.");
  64
  65   ("ls", (RStringList "listing", P1 (String "directory")), 6, [],
  66    "list the files in a directory",
  67    "\
  68 List the files in C<directory> (relative to the root directory,
  69 there is no cwd).  The '.' and '..' entries are not returned, but
  70 hidden files are shown.
  71
  72 This command is mostly useful for interactive sessions.");
  73
  74   ("mount", (Err, P2 (String "device", String "mountpoint")), 1, [],
  75    "mount a guest disk at a position in the filesystem",
  76    "\
  77 Mount a guest disk at a position in the filesystem.  Block devices
  78 are named C</dev/sda>, C</dev/sdb> and so on, as they were added to
  79 the guest.  If those block devices contain partitions, they will have
  80 the usual names (eg. C</dev/sda1>).  Also LVM C</dev/VG/LV>-style
  81 names can be used.
  82
  83 The rules are the same as for L<mount(2)>:  A filesystem must
  84 first be mounted on C</> before others can be mounted.  Other
  85 filesystems can only be mounted on directories which already
  86 exist.
  87
  88 The mounted filesystem is writable, if we have sufficient permissions
  89 on the underlying device.
  90
  91 The filesystem options C<sync> and C<noatime> are set with this
  92 call, in order to improve reliability.");
  93
  94   ("sync", (Err, P0), 2, [],
  95    "sync disks, writes are flushed through to the disk image",
  96    "\
  97 This syncs the disk, so that any writes are flushed through to the
  98 underlying disk image.
  99
 100 You should always call this if you have modified a disk image, before
 101 calling C<guestfs_close>.");
 102
 103   ("touch", (Err, P1 (String "path")), 3, [],
 104    "update file timestamps or create a new file",
 105    "\
 106 Touch acts like the L<touch(1)> command.  It can be used to
 107 update the timestamps on a file, or, if the file does not exist,
 108 to create a new zero-length file.");
 109 ]
 110
 111 (* 'pr' prints to the current output file. *)
 112 let chan = ref stdout
 113 let pr fs = ksprintf (output_string !chan) fs
 114
 115 let iter_args f = function
 116   | P0 -> ()
 117   | P1 arg1 -> f arg1
 118   | P2 (arg1, arg2) -> f arg1; f arg2
 119
 120 let iteri_args f = function
 121   | P0 -> ()
 122   | P1 arg1 -> f 0 arg1
 123   | P2 (arg1, arg2) -> f 0 arg1; f 1 arg2
 124
 125 let map_args f = function
 126   | P0 -> []
 127   | P1 arg1 -> [f arg1]
 128   | P2 (arg1, arg2) -> [f arg1; f arg2]
 129
 130 let nr_args = function | P0 -> 0 | P1 _ -> 1 | P2 _ -> 2
 131
 132 type comment_style = CStyle | HashStyle | OCamlStyle
 133 type license = GPLv2 | LGPLv2
 134
 135 (* Generate a header block in a number of standard styles. *)
 136 let rec generate_header comment license =
 137   let c = match comment with
 138     | CStyle ->     pr "/* "; " *"
 139     | HashStyle ->  pr "# ";  "#"
 140     | OCamlStyle -> pr "(* "; " *" in
 141   pr "libguestfs generated file\n";
 142   pr "%s WARNING: THIS FILE IS GENERATED BY 'src/generator.ml'.\n" c;
 143   pr "%s ANY CHANGES YOU MAKE TO THIS FILE WILL BE LOST.\n" c;
 144   pr "%s\n" c;
 145   pr "%s Copyright (C) 2009 Red Hat Inc.\n" c;
 146   pr "%s\n" c;
 147   (match license with
 148    | GPLv2 ->
 149        pr "%s This program is free software; you can redistribute it and/or modify\n" c;
 150        pr "%s it under the terms of the GNU General Public License as published by\n" c;
 151        pr "%s the Free Software Foundation; either version 2 of the License, or\n" c;
 152        pr "%s (at your option) any later version.\n" c;
 153        pr "%s\n" c;
 154        pr "%s This program is distributed in the hope that it will be useful,\n" c;
 155        pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
 156        pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the\n" c;
 157        pr "%s GNU General Public License for more details.\n" c;
 158        pr "%s\n" c;
 159        pr "%s You should have received a copy of the GNU General Public License along\n" c;
 160        pr "%s with this program; if not, write to the Free Software Foundation, Inc.,\n" c;
 161        pr "%s 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n" c;
 162
 163    | LGPLv2 ->
 164        pr "%s This library is free software; you can redistribute it and/or\n" c;
 165        pr "%s modify it under the terms of the GNU Lesser General Public\n" c;
 166        pr "%s License as published by the Free Software Foundation; either\n" c;
 167        pr "%s version 2 of the License, or (at your option) any later version.\n" c;
 168        pr "%s\n" c;
 169        pr "%s This library is distributed in the hope that it will be useful,\n" c;
 170        pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
 171        pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU\n" c;
 172        pr "%s Lesser General Public License for more details.\n" c;
 173        pr "%s\n" c;
 174        pr "%s You should have received a copy of the GNU Lesser General Public\n" c;
 175        pr "%s License along with this library; if not, write to the Free Software\n" c;
 176        pr "%s Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA\n" c;
 177   );
 178   (match comment with
 179    | CStyle -> pr " */\n"
 180    | HashStyle -> ()
 181    | OCamlStyle -> pr " *)\n"
 182   );
 183   pr "\n"
 184
 185 (* Generate the pod documentation for the C API. *)
 186 and generate_pod () =
 187   List.iter (
 188     fun (shortname, style, _, flags, _, longdesc) ->
 189       let name = "guestfs_" ^ shortname in
 190       pr "=head2 %s\n\n" name;
 191       pr " ";
 192       generate_prototype ~extern:false ~handle:"handle" name style;
 193       pr "\n\n";
 194       pr "%s\n\n" longdesc;
 195       (match fst style with
 196        | Err ->
 197            pr "This function returns 0 on success or -1 on error.\n\n"
 198        | RString _ ->
 199            pr "This function returns a string or NULL on error.  The caller
 200 must free the returned string after use.\n\n"
 201        | RStringList _ ->
 202            pr "This function returns a NULL-terminated array of strings
 203 (like L<environ(3)>), or NULL if there was an error.
 204
 205 The caller must free the strings I<and> the array after use.\n\n"
 206       );
 207       if List.mem ProtocolLimitWarning flags then
 208         pr "Because of the message protocol, there is a transfer limit
 209 of somewhere between 2MB and 4MB.  To transfer large files you should use
 210 FTP.\n\n";
 211   ) functions
 212
 213 (* Generate the protocol (XDR) file. *)
 214 and generate_xdr () =
 215   generate_header CStyle LGPLv2;
 216
 217   (* This has to be defined to get around a limitation in Sun's rpcgen. *)
 218   pr "typedef string str<>;\n";
 219   pr "\n";
 220
 221   List.iter (
 222     fun (shortname, style, _, _, _, _) ->
 223       let name = "guestfs_" ^ shortname in
 224       pr "/* %s */\n\n" name;
 225       (match snd style with
 226        | P0 -> ()
 227        | args ->
 228            pr "struct %s_args {\n" name;
 229            iter_args (
 230              function
 231              | String name -> pr "  string %s<>;\n" name
 232            ) args;
 233            pr "};\n\n"
 234       );
 235       (match fst style with
 236        | Err -> ()
 237        | RString n ->
 238            pr "struct %s_ret {\n" name;
 239            pr "  string %s<>;\n" n;
 240            pr "};\n\n"
 241        | RStringList n ->
 242            pr "struct %s_ret {\n" name;
 243            pr "  str %s<>;\n" n;
 244            pr "};\n\n"
 245       );
 246   ) functions;
 247
 248   (* Table of procedure numbers. *)
 249   pr "enum guestfs_procedure {\n";
 250   List.iter (
 251     fun (shortname, _, proc_nr, _, _, _) ->
 252       pr "  GUESTFS_PROC_%s = %d,\n" (String.uppercase shortname) proc_nr
 253   ) functions;
 254   pr "  GUESTFS_PROC_dummy\n"; (* so we don't have a "hanging comma" *)
 255   pr "};\n";
 256   pr "\n";
 257
 258   (* Having to choose a maximum message size is annoying for several
 259    * reasons (it limits what we can do in the API), but it (a) makes
 260    * the protocol a lot simpler, and (b) provides a bound on the size
 261    * of the daemon which operates in limited memory space.  For large
 262    * file transfers you should use FTP.
 263    *)
 264   pr "const GUESTFS_MESSAGE_MAX = %d;\n" (4 * 1024 * 1024);
 265   pr "\n";
 266
 267   (* Message header, etc. *)
 268   pr "\
 269 const GUESTFS_PROGRAM = 0x2000F5F5;
 270 const GUESTFS_PROTOCOL_VERSION = 1;
 271
 272 enum guestfs_message_direction {
 273   GUESTFS_DIRECTION_CALL = 0,        /* client -> daemon */
 274   GUESTFS_DIRECTION_REPLY = 1        /* daemon -> client */
 275 };
 276
 277 enum guestfs_message_status {
 278   GUESTFS_STATUS_OK = 0,
 279   GUESTFS_STATUS_ERROR = 1
 280 };
 281
 282 const GUESTFS_ERROR_LEN = 256;
 283
 284 struct guestfs_message_error {
 285   string error<GUESTFS_ERROR_LEN>;   /* error message */
 286 };
 287
 288 struct guestfs_message_header {
 289   unsigned prog;                     /* GUESTFS_PROGRAM */
 290   unsigned vers;                     /* GUESTFS_PROTOCOL_VERSION */
 291   guestfs_procedure proc;            /* GUESTFS_PROC_x */
 292   guestfs_message_direction direction;
 293   unsigned serial;                   /* message serial number */
 294   guestfs_message_status status;
 295 };
 296 "
 297
 298 (* Generate the guestfs-actions.h file. *)
 299 and generate_actions_h () =
 300   generate_header CStyle LGPLv2;
 301   List.iter (
 302     fun (shortname, style, _, _, _, _) ->
 303       let name = "guestfs_" ^ shortname in
 304       generate_prototype ~single_line:true ~newline:true ~handle:"handle"
 305         name style
 306   ) functions
 307
 308 (* Generate the client-side dispatch stubs. *)
 309 and generate_client_actions () =
 310   generate_header CStyle LGPLv2;
 311   List.iter (
 312     fun (shortname, style, _, _, _, _) ->
 313       let name = "guestfs_" ^ shortname in
 314
 315       (* Generate the return value struct. *)
 316       pr "struct %s_rv {\n" shortname;
 317       pr "  int cb_done;  /* flag to indicate callback was called */\n";
 318       pr "  struct guestfs_message_header hdr;\n";
 319       pr "  struct guestfs_message_error err;\n";
 320       (match fst style with
 321        | Err -> ()
 322        | RString _ | RStringList _ -> pr "  struct %s_ret ret;\n" name;
 323       );
 324       pr "};\n\n";
 325
 326       (* Generate the callback function. *)
 327       pr "static void %s_cb (guestfs_h *g, void *data, XDR *xdr)\n" shortname;
 328       pr "{\n";
 329       pr "  struct %s_rv *rv = (struct %s_rv *) data;\n" shortname shortname;
 330       pr "\n";
 331       pr "  if (!xdr_guestfs_message_header (xdr, &rv->hdr)) {\n";
 332       pr "    error (g, \"%s: failed to parse reply header\");\n" name;
 333       pr "    return;\n";
 334       pr "  }\n";
 335       pr "  if (rv->hdr.status == GUESTFS_STATUS_ERROR) {\n";
 336       pr "    if (!xdr_guestfs_message_error (xdr, &rv->err)) {\n";
 337       pr "      error (g, \"%s: failed to parse reply error\");\n" name;
 338       pr "      return;\n";
 339       pr "    }\n";
 340       pr "    goto done;\n";
 341       pr "  }\n";
 342
 343       (match fst style with
 344        | Err -> ()
 345        |  RString _ | RStringList _ ->
 346             pr "  if (!xdr_%s_ret (xdr, &rv->ret)) {\n" name;
 347             pr "    error (g, \"%s: failed to parse reply\");\n" name;
 348             pr "    return;\n";
 349             pr "  }\n";
 350       );
 351
 352       pr " done:\n";
 353       pr "  rv->cb_done = 1;\n";
 354       pr "  main_loop.main_loop_quit (g);\n";
 355       pr "}\n\n";
 356
 357       (* Generate the action stub. *)
 358       generate_prototype ~extern:false ~semicolon:false ~newline:true
 359         ~handle:"g" name style;
 360
 361       let error_code =
 362         match fst style with
 363         | Err -> "-1"
 364         | RString _ | RStringList _ -> "NULL" in
 365
 366       pr "{\n";
 367
 368       (match snd style with
 369        | P0 -> ()
 370        | _ -> pr "  struct %s_args args;\n" name
 371       );
 372
 373       pr "  struct %s_rv rv;\n" shortname;
 374       pr "  int serial;\n";
 375       pr "\n";
 376       pr "  if (g->state != READY) {\n";
 377       pr "    error (g, \"%s called from the wrong state, %%d != READY\",\n"
 378         name;
 379       pr "      g->state);\n";
 380       pr "    return %s;\n" error_code;
 381       pr "  }\n";
 382       pr "\n";
 383       pr "  memset (&rv, 0, sizeof rv);\n";
 384       pr "\n";
 385
 386       (match snd style with
 387        | P0 ->
 388            pr "  serial = dispatch (g, GUESTFS_PROC_%s, NULL, NULL);\n"
 389              (String.uppercase shortname)
 390        | args ->
 391            iter_args (
 392              function
 393              | String name -> pr "  args.%s = (char *) %s;\n" name name
 394            ) args;
 395            pr "  serial = dispatch (g, GUESTFS_PROC_%s,\n"
 396              (String.uppercase shortname);
 397            pr "                     (xdrproc_t) xdr_%s_args, (char *) &args);\n"
 398              name;
 399       );
 400       pr "  if (serial == -1)\n";
 401       pr "    return %s;\n" error_code;
 402       pr "\n";
 403
 404       pr "  rv.cb_done = 0;\n";
 405       pr "  g->reply_cb_internal = %s_cb;\n" shortname;
 406       pr "  g->reply_cb_internal_data = &rv;\n";
 407       pr "  main_loop.main_loop_run (g);\n";
 408       pr "  g->reply_cb_internal = NULL;\n";
 409       pr "  g->reply_cb_internal_data = NULL;\n";
 410       pr "  if (!rv.cb_done) {\n";
 411       pr "    error (g, \"%s failed, see earlier error messages\");\n" name;
 412       pr "    return %s;\n" error_code;
 413       pr "  }\n";
 414       pr "\n";
 415
 416       pr "  if (check_reply_header (g, &rv.hdr, GUESTFS_PROC_%s, serial) == -1)\n"
 417         (String.uppercase shortname);
 418       pr "    return %s;\n" error_code;
 419       pr "\n";
 420
 421       pr "  if (rv.hdr.status == GUESTFS_STATUS_ERROR) {\n";
 422       pr "    error (g, \"%%s\", rv.err.error);\n";
 423       pr "    return %s;\n" error_code;
 424       pr "  }\n";
 425       pr "\n";
 426
 427       (match fst style with
 428        | Err -> pr "  return 0;\n"
 429        | RString n ->
 430            pr "  return rv.ret.%s; /* caller will free */\n" n
 431        | RStringList n ->
 432            pr "  /* caller will free this, but we need to add a NULL entry */\n";
 433            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;
 434            pr "  rv.ret.%s.%s_val[rv.ret.%s.%s_len] = NULL;\n" n n n n;
 435            pr "  return rv.ret.%s.%s_val;\n" n n
 436       );
 437
 438       pr "}\n\n"
 439   ) functions
 440
 441 (* Generate daemon/actions.h. *)
 442 and generate_daemon_actions_h () =
 443   generate_header CStyle GPLv2;
 444   List.iter (
 445     fun (name, style, _, _, _, _) ->
 446       generate_prototype ~single_line:true ~newline:true ("do_" ^ name) style;
 447   ) functions
 448
 449 (* Generate the server-side stubs. *)
 450 and generate_daemon_actions () =
 451   generate_header CStyle GPLv2;
 452
 453   pr "#include <rpc/types.h>\n";
 454   pr "#include <rpc/xdr.h>\n";
 455   pr "#include \"daemon.h\"\n";
 456   pr "#include \"../src/guestfs_protocol.h\"\n";
 457   pr "#include \"actions.h\"\n";
 458   pr "\n";
 459
 460   List.iter (
 461     fun (name, style, _, _, _, _) ->
 462       (* Generate server-side stubs. *)
 463       pr "static void %s_stub (XDR *xdr_in)\n" name;
 464       pr "{\n";
 465       let error_code =
 466         match fst style with
 467         | Err -> pr "  int r;\n"; "-1"
 468         | RString _ -> pr "  char *r;\n"; "NULL"
 469         | RStringList _ -> pr "  char **r;\n"; "NULL" in
 470       (match snd style with
 471        | P0 -> ()
 472        | args ->
 473            pr "  struct guestfs_%s_args args;\n" name;
 474            iter_args (
 475              function
 476              | String name -> pr "  const char *%s;\n" name
 477            ) args
 478       );
 479       pr "\n";
 480
 481       (match snd style with
 482        | P0 -> ()
 483        | args ->
 484            pr "  memset (&args, 0, sizeof args);\n";
 485            pr "\n";
 486            pr "  if (!xdr_guestfs_%s_args (xdr_in, &args)) {\n" name;
 487            pr "    reply_with_error (\"%s: daemon failed to decode procedure arguments\");\n" name;
 488            pr "    return;\n";
 489            pr "  }\n";
 490            iter_args (
 491              function
 492              | String name -> pr "  %s = args.%s;\n" name name
 493            ) args;
 494            pr "\n"
 495       );
 496
 497       pr "  r = do_%s " name;
 498       generate_call_args style;
 499       pr ";\n";
 500
 501       pr "  if (r == %s)\n" error_code;
 502       pr "    /* do_%s has already called reply_with_error, so just return */\n" name;
 503       pr "    return;\n";
 504       pr "\n";
 505
 506       (match fst style with
 507        | Err -> pr "  reply (NULL, NULL);\n"
 508        | RString n ->
 509            pr "  struct guestfs_%s_ret ret;\n" name;
 510            pr "  ret.%s = r;\n" n;
 511            pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name;
 512            pr "  free (r);\n"
 513        | RStringList n ->
 514            pr "  struct guestfs_%s_ret ret;\n" name;
 515            pr "  ret.%s.%s_len = count_strings (r);\n" n n;
 516            pr "  ret.%s.%s_val = r;\n" n n;
 517            pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name;
 518            pr "  free_strings (r);\n"
 519       );
 520
 521       pr "}\n\n";
 522   ) functions;
 523
 524   (* Dispatch function. *)
 525   pr "void dispatch_incoming_message (XDR *xdr_in)\n";
 526   pr "{\n";
 527   pr "  switch (proc_nr) {\n";
 528
 529   List.iter (
 530     fun (name, style, _, _, _, _) ->
 531       pr "    case GUESTFS_PROC_%s:\n" (String.uppercase name);
 532       pr "      %s_stub (xdr_in);\n" name;
 533       pr "      break;\n"
 534   ) functions;
 535
 536   pr "    default:\n";
 537   pr "      reply_with_error (\"dispatch_incoming_message: unknown procedure number %%d\", proc_nr);\n";
 538   pr "  }\n";
 539   pr "}\n"
 540
 541 (* Generate a lot of different functions for guestfish. *)
 542 and generate_fish_cmds () =
 543   generate_header CStyle GPLv2;
 544
 545   pr "#include <stdio.h>\n";
 546   pr "#include <stdlib.h>\n";
 547   pr "#include <string.h>\n";
 548   pr "\n";
 549   pr "#include \"fish.h\"\n";
 550   pr "\n";
 551
 552   (* list_commands function, which implements guestfish -h *)
 553   pr "void list_commands (void)\n";
 554   pr "{\n";
 555   pr "  printf (\"    %%-16s     %%s\\n\", \"Command\", \"Description\");\n";
 556   pr "  list_builtin_commands ();\n";
 557   List.iter (
 558     fun (name, _, _, _, shortdesc, _) ->
 559       pr "  printf (\"%%-20s %%s\\n\", \"%s\", \"%s\");\n"
 560         name shortdesc
 561   ) functions;
 562   pr "  printf (\"    Use -h <cmd> / help <cmd> to show detailed help for a command.\\n\");\n";
 563   pr "}\n";
 564   pr "\n";
 565
 566   (* display_command function, which implements guestfish -h cmd *)
 567   pr "void display_command (const char *cmd)\n";
 568   pr "{\n";
 569   List.iter (
 570     fun (name, style, _, flags, shortdesc, longdesc) ->
 571       let synopsis =
 572         match snd style with
 573         | P0 -> name
 574         | args ->
 575             sprintf "%s <%s>"
 576               name (
 577                 String.concat "> <" (
 578                   map_args (function
 579                             | String n -> n) args
 580                 )
 581               ) in
 582
 583       let warnings =
 584         if List.mem ProtocolLimitWarning flags then
 585           "\n\nBecause of the message protocol, there is a transfer limit
 586 of somewhere between 2MB and 4MB.  To transfer large files you should use
 587 FTP."
 588         else "" in
 589
 590       pr "  if (strcasecmp (cmd, \"%s\") == 0)\n" name;
 591       pr "    pod2text (\"%s - %s\", %S);\n"
 592         name shortdesc
 593         (" " ^ synopsis ^ "\n\n" ^ longdesc ^ warnings);
 594       pr "  else\n"
 595   ) functions;
 596   pr "    display_builtin_command (cmd);\n";
 597   pr "}\n";
 598   pr "\n";
 599
 600   (* run_<action> actions *)
 601   List.iter (
 602     fun (name, style, _, _, _, _) ->
 603       pr "static int run_%s (const char *cmd, int argc, char *argv[])\n" name;
 604       pr "{\n";
 605       (match fst style with
 606        | Err -> pr "  int r;\n"
 607        | RString _ -> pr "  char *r;\n"
 608        | RStringList _ -> pr "  char **r;\n"
 609       );
 610       iter_args (
 611         function
 612         | String name -> pr "  const char *%s;\n" name
 613       ) (snd style);
 614
 615       (* Check and convert parameters. *)
 616       let argc_expected = nr_args (snd style) in
 617       pr "  if (argc != %d) {\n" argc_expected;
 618       pr "    fprintf (stderr, \"%%s should have %d parameter(s)\\n\", cmd);\n"
 619         argc_expected;
 620       pr "    fprintf (stderr, \"type 'help %%s' for help on %%s\\n\", cmd, cmd);\n";
 621       pr "    return -1;\n";
 622       pr "  }\n";
 623       iteri_args (
 624         fun i ->
 625           function
 626           | String name -> pr "  %s = argv[%d];\n" name i
 627       ) (snd style);
 628
 629       (* Call C API function. *)
 630       pr "  r = guestfs_%s " name;
 631       generate_call_args ~handle:"g" style;
 632       pr ";\n";
 633
 634       (* Check return value for errors and display command results. *)
 635       (match fst style with
 636        | Err -> pr "  return r;\n"
 637        | RString _ ->
 638            pr "  if (r == NULL) return -1;\n";
 639            pr "  printf (\"%%s\", r);\n";
 640            pr "  free (r);\n";
 641            pr "  return 0;\n"
 642        | RStringList _ ->
 643            pr "  if (r == NULL) return -1;\n";
 644            pr "  print_strings (r);\n";
 645            pr "  free_strings (r);\n";
 646            pr "  return 0;\n"
 647       );
 648       pr "}\n";
 649       pr "\n"
 650   ) functions;
 651
 652   (* run_action function *)
 653   pr "int run_action (const char *cmd, int argc, char *argv[])\n";
 654   pr "{\n";
 655   List.iter (
 656     fun (name, _, _, _, _, _) ->
 657       pr "  if (strcasecmp (cmd, \"%s\") == 0)\n" name;
 658       pr "    return run_%s (cmd, argc, argv);\n" name;
 659       pr "  else\n";
 660   ) functions;
 661   pr "    {\n";
 662   pr "      fprintf (stderr, \"%%s: unknown command\\n\", cmd);\n";
 663   pr "      return -1;\n";
 664   pr "    }\n";
 665   pr "  return 0;\n";
 666   pr "}\n";
 667   pr "\n"
 668
 669 (* Generate a C function prototype. *)
 670 and generate_prototype ?(extern = true) ?(static = false) ?(semicolon = true)
 671     ?(single_line = false) ?(newline = false)
 672     ?handle name style =
 673   if extern then pr "extern ";
 674   if static then pr "static ";
 675   (match fst style with
 676    | Err -> pr "int "
 677    | RString _ -> pr "char *"
 678    | RStringList _ -> pr "char **"
 679   );
 680   pr "%s (" name;
 681   let comma = ref false in
 682   (match handle with
 683    | None -> ()
 684    | Some handle -> pr "guestfs_h *%s" handle; comma := true
 685   );
 686   let next () =
 687     if !comma then (
 688       if single_line then pr ", " else pr ",\n\t\t"
 689     );
 690     comma := true
 691   in
 692   iter_args (
 693     function
 694     | String name -> next (); pr "const char *%s" name
 695   ) (snd style);
 696   pr ")";
 697   if semicolon then pr ";";
 698   if newline then pr "\n"
 699
 700 (* Generate C call arguments, eg "(handle, foo, bar)" *)
 701 and generate_call_args ?handle style =
 702   pr "(";
 703   let comma = ref false in
 704   (match handle with
 705    | None -> ()
 706    | Some handle -> pr "%s" handle; comma := true
 707   );
 708   iter_args (
 709     fun arg ->
 710       if !comma then pr ", ";
 711       comma := true;
 712       match arg with
 713       | String name -> pr "%s" name
 714   ) (snd style);
 715   pr ")"
 716
 717 let output_to filename =
 718   let filename_new = filename ^ ".new" in
 719   chan := open_out filename_new;
 720   let close () =
 721     close_out !chan;
 722     chan := stdout;
 723     Unix.rename filename_new filename;
 724     printf "written %s\n%!" filename;
 725   in
 726   close
 727
 728 (* Main program. *)
 729 let () =
 730   let close = output_to "src/guestfs_protocol.x" in
 731   generate_xdr ();
 732   close ();
 733
 734   let close = output_to "src/guestfs-actions.h" in
 735   generate_actions_h ();
 736   close ();
 737
 738   let close = output_to "src/guestfs-actions.c" in
 739   generate_client_actions ();
 740   close ();
 741
 742   let close = output_to "daemon/actions.h" in
 743   generate_daemon_actions_h ();
 744   close ();
 745
 746   let close = output_to "daemon/stubs.c" in
 747   generate_daemon_actions ();
 748   close ();
 749
 750   let close = output_to "fish/cmds.c" in
 751   generate_fish_cmds ();
 752   close ();
 753
 754   let close = output_to "guestfs-actions.pod" in
 755   generate_pod ();
 756   close ()