src/generator.ml

   1 #!/usr/bin/env 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     (* LVM PVs, VGs and LVs. *)
  41   | RPVList of string
  42   | RVGList of string
  43   | RLVList of string
  44 and args =
  45     (* 0 arguments, 1 argument, etc. The guestfs_h param is implicit. *)
  46   | P0
  47   | P1 of argt
  48   | P2 of argt * argt
  49 and argt =
  50   | String of string    (* const char *name, cannot be NULL *)
  51
  52 type flags = ProtocolLimitWarning
  53
  54 (* Note about long descriptions: When referring to another
  55  * action, use the format C<guestfs_other> (ie. the full name of
  56  * the C function).  This will be replaced as appropriate in other
  57  * language bindings.
  58  *
  59  * Apart from that, long descriptions are just perldoc paragraphs.
  60  *)
  61
  62 let functions = [
  63   ("mount", (Err, P2 (String "device", String "mountpoint")), 1, [],
  64    "mount a guest disk at a position in the filesystem",
  65    "\
  66 Mount a guest disk at a position in the filesystem.  Block devices
  67 are named C</dev/sda>, C</dev/sdb> and so on, as they were added to
  68 the guest.  If those block devices contain partitions, they will have
  69 the usual names (eg. C</dev/sda1>).  Also LVM C</dev/VG/LV>-style
  70 names can be used.
  71
  72 The rules are the same as for L<mount(2)>:  A filesystem must
  73 first be mounted on C</> before others can be mounted.  Other
  74 filesystems can only be mounted on directories which already
  75 exist.
  76
  77 The mounted filesystem is writable, if we have sufficient permissions
  78 on the underlying device.
  79
  80 The filesystem options C<sync> and C<noatime> are set with this
  81 call, in order to improve reliability.");
  82
  83   ("sync", (Err, P0), 2, [],
  84    "sync disks, writes are flushed through to the disk image",
  85    "\
  86 This syncs the disk, so that any writes are flushed through to the
  87 underlying disk image.
  88
  89 You should always call this if you have modified a disk image, before
  90 closing the handle.");
  91
  92   ("touch", (Err, P1 (String "path")), 3, [],
  93    "update file timestamps or create a new file",
  94    "\
  95 Touch acts like the L<touch(1)> command.  It can be used to
  96 update the timestamps on a file, or, if the file does not exist,
  97 to create a new zero-length file.");
  98
  99   ("cat", (RString "content", P1 (String "path")), 4, [ProtocolLimitWarning],
 100    "list the contents of a file",
 101    "\
 102 Return the contents of the file named C<path>.
 103
 104 Note that this function cannot correctly handle binary files
 105 (specifically, files containing C<\\0> character which is treated
 106 as end of string).  For those you need to use the C<guestfs_read_file>
 107 function which has a more complex interface.");
 108
 109   ("ll", (RString "listing", P1 (String "directory")), 5, [],
 110    "list the files in a directory (long format)",
 111    "\
 112 List the files in C<directory> (relative to the root directory,
 113 there is no cwd) in the format of 'ls -la'.
 114
 115 This command is mostly useful for interactive sessions.  It
 116 is I<not> intended that you try to parse the output string.");
 117
 118   ("ls", (RStringList "listing", P1 (String "directory")), 6, [],
 119    "list the files in a directory",
 120    "\
 121 List the files in C<directory> (relative to the root directory,
 122 there is no cwd).  The '.' and '..' entries are not returned, but
 123 hidden files are shown.
 124
 125 This command is mostly useful for interactive sessions.  Programs
 126 should probably use C<guestfs_readdir> instead.");
 127
 128   ("list_devices", (RStringList "devices", P0), 7, [],
 129    "list the block devices",
 130    "\
 131 List all the block devices.
 132
 133 The full block device names are returned, eg. C</dev/sda>");
 134
 135   ("list_partitions", (RStringList "partitions", P0), 8, [],
 136    "list the partitions",
 137    "\
 138 List all the partitions detected on all block devices.
 139
 140 The full partition device names are returned, eg. C</dev/sda1>
 141
 142 This does not return logical volumes.  For that you will need to
 143 call C<guestfs_lvs>.");
 144
 145   ("pvs", (RStringList "physvols", P0), 9, [],
 146    "list the LVM physical volumes (PVs)",
 147    "\
 148 List all the physical volumes detected.  This is the equivalent
 149 of the L<pvs(8)> command.
 150
 151 This returns a list of just the device names that contain
 152 PVs (eg. C</dev/sda2>).
 153
 154 See also C<guestfs_pvs_full>.");
 155
 156   ("vgs", (RStringList "volgroups", P0), 10, [],
 157    "list the LVM volume groups (VGs)",
 158    "\
 159 List all the volumes groups detected.  This is the equivalent
 160 of the L<vgs(8)> command.
 161
 162 This returns a list of just the volume group names that were
 163 detected (eg. C<VolGroup00>).
 164
 165 See also C<guestfs_vgs_full>.");
 166
 167   ("lvs", (RStringList "logvols", P0), 11, [],
 168    "list the LVM logical volumes (LVs)",
 169    "\
 170 List all the logical volumes detected.  This is the equivalent
 171 of the L<lvs(8)> command.
 172
 173 This returns a list of the logical volume device names
 174 (eg. C</dev/VolGroup00/LogVol00>).
 175
 176 See also C<guestfs_lvs_full>.");
 177
 178   ("pvs_full", (RPVList "physvols", P0), 12, [],
 179    "list the LVM physical volumes (PVs)",
 180    "\
 181 List all the physical volumes detected.  This is the equivalent
 182 of the L<pvs(8)> command.  The \"full\" version includes all fields.");
 183
 184   ("vgs_full", (RVGList "volgroups", P0), 13, [],
 185    "list the LVM volume groups (VGs)",
 186    "\
 187 List all the volumes groups detected.  This is the equivalent
 188 of the L<vgs(8)> command.  The \"full\" version includes all fields.");
 189
 190   ("lvs_full", (RLVList "logvols", P0), 14, [],
 191    "list the LVM logical volumes (LVs)",
 192    "\
 193 List all the logical volumes detected.  This is the equivalent
 194 of the L<lvs(8)> command.  The \"full\" version includes all fields.");
 195 ]
 196
 197 (* Column names and types from LVM PVs/VGs/LVs. *)
 198 let pv_cols = [
 199   "pv_name", `String;
 200   "pv_uuid", `UUID;
 201   "pv_fmt", `String;
 202   "pv_size", `Bytes;
 203   "dev_size", `Bytes;
 204   "pv_free", `Bytes;
 205   "pv_used", `Bytes;
 206   "pv_attr", `String (* XXX *);
 207   "pv_pe_count", `Int;
 208   "pv_pe_alloc_count", `Int;
 209   "pv_tags", `String;
 210   "pe_start", `Bytes;
 211   "pv_mda_count", `Int;
 212   "pv_mda_free", `Bytes;
 213 (* Not in Fedora 10:
 214   "pv_mda_size", `Bytes;
 215 *)
 216 ]
 217 let vg_cols = [
 218   "vg_name", `String;
 219   "vg_uuid", `UUID;
 220   "vg_fmt", `String;
 221   "vg_attr", `String (* XXX *);
 222   "vg_size", `Bytes;
 223   "vg_free", `Bytes;
 224   "vg_sysid", `String;
 225   "vg_extent_size", `Bytes;
 226   "vg_extent_count", `Int;
 227   "vg_free_count", `Int;
 228   "max_lv", `Int;
 229   "max_pv", `Int;
 230   "pv_count", `Int;
 231   "lv_count", `Int;
 232   "snap_count", `Int;
 233   "vg_seqno", `Int;
 234   "vg_tags", `String;
 235   "vg_mda_count", `Int;
 236   "vg_mda_free", `Bytes;
 237 (* Not in Fedora 10:
 238   "vg_mda_size", `Bytes;
 239 *)
 240 ]
 241 let lv_cols = [
 242   "lv_name", `String;
 243   "lv_uuid", `UUID;
 244   "lv_attr", `String (* XXX *);
 245   "lv_major", `Int;
 246   "lv_minor", `Int;
 247   "lv_kernel_major", `Int;
 248   "lv_kernel_minor", `Int;
 249   "lv_size", `Bytes;
 250   "seg_count", `Int;
 251   "origin", `String;
 252   "snap_percent", `OptPercent;
 253   "copy_percent", `OptPercent;
 254   "move_pv", `String;
 255   "lv_tags", `String;
 256   "mirror_log", `String;
 257   "modules", `String;
 258 ]
 259
 260 (* In some places we want the functions to be displayed sorted
 261  * alphabetically, so this is useful:
 262  *)
 263 let sorted_functions =
 264   List.sort (fun (n1,_,_,_,_,_) (n2,_,_,_,_,_) -> compare n1 n2) functions
 265
 266 (* Useful functions.
 267  * Note we don't want to use any external OCaml libraries which
 268  * makes this a bit harder than it should be.
 269  *)
 270 let failwithf fs = ksprintf failwith fs
 271
 272 let replace_char s c1 c2 =
 273   let s2 = String.copy s in
 274   let r = ref false in
 275   for i = 0 to String.length s2 - 1 do
 276     if String.unsafe_get s2 i = c1 then (
 277       String.unsafe_set s2 i c2;
 278       r := true
 279     )
 280   done;
 281   if not !r then s else s2
 282
 283 let rec find s sub =
 284   let len = String.length s in
 285   let sublen = String.length sub in
 286   let rec loop i =
 287     if i <= len-sublen then (
 288       let rec loop2 j =
 289         if j < sublen then (
 290           if s.[i+j] = sub.[j] then loop2 (j+1)
 291           else -1
 292         ) else
 293           i (* found *)
 294       in
 295       let r = loop2 0 in
 296       if r = -1 then loop (i+1) else r
 297     ) else
 298       -1 (* not found *)
 299   in
 300   loop 0
 301
 302 let rec replace_str s s1 s2 =
 303   let len = String.length s in
 304   let sublen = String.length s1 in
 305   let i = find s s1 in
 306   if i = -1 then s
 307   else (
 308     let s' = String.sub s 0 i in
 309     let s'' = String.sub s (i+sublen) (len-i-sublen) in
 310     s' ^ s2 ^ replace_str s'' s1 s2
 311   )
 312
 313 (* 'pr' prints to the current output file. *)
 314 let chan = ref stdout
 315 let pr fs = ksprintf (output_string !chan) fs
 316
 317 let iter_args f = function
 318   | P0 -> ()
 319   | P1 arg1 -> f arg1
 320   | P2 (arg1, arg2) -> f arg1; f arg2
 321
 322 let iteri_args f = function
 323   | P0 -> ()
 324   | P1 arg1 -> f 0 arg1
 325   | P2 (arg1, arg2) -> f 0 arg1; f 1 arg2
 326
 327 let map_args f = function
 328   | P0 -> []
 329   | P1 arg1 -> [f arg1]
 330   | P2 (arg1, arg2) -> [f arg1; f arg2]
 331
 332 let nr_args = function | P0 -> 0 | P1 _ -> 1 | P2 _ -> 2
 333
 334 (* Check function names etc. for consistency. *)
 335 let check_functions () =
 336   List.iter (
 337     fun (name, _, _, _, _, longdesc) ->
 338       if String.contains name '-' then
 339         failwithf "Function name '%s' should not contain '-', use '_' instead."
 340           name;
 341       if longdesc.[String.length longdesc-1] = '\n' then
 342         failwithf "Long description of %s should not end with \\n." name
 343   ) functions;
 344
 345   let proc_nrs =
 346     List.map (fun (name, _, proc_nr, _, _, _) -> name, proc_nr) functions in
 347   let proc_nrs =
 348     List.sort (fun (_,nr1) (_,nr2) -> compare nr1 nr2) proc_nrs in
 349   let rec loop = function
 350     | [] -> ()
 351     | [_] -> ()
 352     | (name1,nr1) :: ((name2,nr2) :: _ as rest) when nr1 < nr2 ->
 353         loop rest
 354     | (name1,nr1) :: (name2,nr2) :: _ ->
 355         failwithf "'%s' and '%s' have conflicting procedure numbers (%d, %d)"
 356           name1 name2 nr1 nr2
 357   in
 358   loop proc_nrs
 359
 360 type comment_style = CStyle | HashStyle | OCamlStyle
 361 type license = GPLv2 | LGPLv2
 362
 363 (* Generate a header block in a number of standard styles. *)
 364 let rec generate_header comment license =
 365   let c = match comment with
 366     | CStyle ->     pr "/* "; " *"
 367     | HashStyle ->  pr "# ";  "#"
 368     | OCamlStyle -> pr "(* "; " *" in
 369   pr "libguestfs generated file\n";
 370   pr "%s WARNING: THIS FILE IS GENERATED BY 'src/generator.ml'.\n" c;
 371   pr "%s ANY CHANGES YOU MAKE TO THIS FILE WILL BE LOST.\n" c;
 372   pr "%s\n" c;
 373   pr "%s Copyright (C) 2009 Red Hat Inc.\n" c;
 374   pr "%s\n" c;
 375   (match license with
 376    | GPLv2 ->
 377        pr "%s This program is free software; you can redistribute it and/or modify\n" c;
 378        pr "%s it under the terms of the GNU General Public License as published by\n" c;
 379        pr "%s the Free Software Foundation; either version 2 of the License, or\n" c;
 380        pr "%s (at your option) any later version.\n" c;
 381        pr "%s\n" c;
 382        pr "%s This program is distributed in the hope that it will be useful,\n" c;
 383        pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
 384        pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the\n" c;
 385        pr "%s GNU General Public License for more details.\n" c;
 386        pr "%s\n" c;
 387        pr "%s You should have received a copy of the GNU General Public License along\n" c;
 388        pr "%s with this program; if not, write to the Free Software Foundation, Inc.,\n" c;
 389        pr "%s 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n" c;
 390
 391    | LGPLv2 ->
 392        pr "%s This library is free software; you can redistribute it and/or\n" c;
 393        pr "%s modify it under the terms of the GNU Lesser General Public\n" c;
 394        pr "%s License as published by the Free Software Foundation; either\n" c;
 395        pr "%s version 2 of the License, or (at your option) any later version.\n" c;
 396        pr "%s\n" c;
 397        pr "%s This library is distributed in the hope that it will be useful,\n" c;
 398        pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
 399        pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU\n" c;
 400        pr "%s Lesser General Public License for more details.\n" c;
 401        pr "%s\n" c;
 402        pr "%s You should have received a copy of the GNU Lesser General Public\n" c;
 403        pr "%s License along with this library; if not, write to the Free Software\n" c;
 404        pr "%s Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA\n" c;
 405   );
 406   (match comment with
 407    | CStyle -> pr " */\n"
 408    | HashStyle -> ()
 409    | OCamlStyle -> pr " *)\n"
 410   );
 411   pr "\n"
 412
 413 (* Generate the pod documentation for the C API. *)
 414 and generate_actions_pod () =
 415   List.iter (
 416     fun (shortname, style, _, flags, _, longdesc) ->
 417       let name = "guestfs_" ^ shortname in
 418       pr "=head2 %s\n\n" name;
 419       pr " ";
 420       generate_prototype ~extern:false ~handle:"handle" name style;
 421       pr "\n\n";
 422       pr "%s\n\n" longdesc;
 423       (match fst style with
 424        | Err ->
 425            pr "This function returns 0 on success or -1 on error.\n\n"
 426        | RString _ ->
 427            pr "This function returns a string or NULL on error.
 428 I<The caller must free the returned string after use>.\n\n"
 429        | RStringList _ ->
 430            pr "This function returns a NULL-terminated array of strings
 431 (like L<environ(3)>), or NULL if there was an error.
 432 I<The caller must free the strings and the array after use>.\n\n"
 433        | RPVList _ ->
 434            pr "This function returns a C<struct guestfs_lvm_pv_list>.
 435 I<The caller must call C<guestfs_free_lvm_pv_list> after use.>.\n\n"
 436        | RVGList _ ->
 437            pr "This function returns a C<struct guestfs_lvm_vg_list>.
 438 I<The caller must call C<guestfs_free_lvm_vg_list> after use.>.\n\n"
 439        | RLVList _ ->
 440            pr "This function returns a C<struct guestfs_lvm_lv_list>.
 441 I<The caller must call C<guestfs_free_lvm_lv_list> after use.>.\n\n"
 442       );
 443       if List.mem ProtocolLimitWarning flags then
 444         pr "Because of the message protocol, there is a transfer limit
 445 of somewhere between 2MB and 4MB.  To transfer large files you should use
 446 FTP.\n\n";
 447   ) sorted_functions
 448
 449 and generate_structs_pod () =
 450   (* LVM structs documentation. *)
 451   List.iter (
 452     fun (typ, cols) ->
 453       pr "=head2 guestfs_lvm_%s\n" typ;
 454       pr "\n";
 455       pr " struct guestfs_lvm_%s {\n" typ;
 456       List.iter (
 457         function
 458         | name, `String -> pr "  char *%s;\n" name
 459         | name, `UUID ->
 460             pr "  /* The next field is NOT nul-terminated, be careful when printing it: */\n";
 461             pr "  char %s[32];\n" name
 462         | name, `Bytes -> pr "  uint64_t %s;\n" name
 463         | name, `Int -> pr "  int64_t %s;\n" name
 464         | name, `OptPercent ->
 465             pr "  /* The next field is [0..100] or -1 meaning 'not present': */\n";
 466             pr "  float %s;\n" name
 467       ) cols;
 468       pr " \n";
 469       pr " struct guestfs_lvm_%s_list {\n" typ;
 470       pr "   uint32_t len; /* Number of elements in list. */\n";
 471       pr "   struct guestfs_lvm_%s *val; /* Elements. */\n" typ;
 472       pr " };\n";
 473       pr " \n";
 474       pr " void guestfs_free_lvm_%s_list (struct guestfs_free_lvm_%s_list *);\n"
 475         typ typ;
 476       pr "\n"
 477   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols]
 478
 479 (* Generate the protocol (XDR) file, 'guestfs_protocol.x' and
 480  * indirectly 'guestfs_protocol.h' and 'guestfs_protocol.c'.  We
 481  * have to use an underscore instead of a dash because otherwise
 482  * rpcgen generates incorrect code.
 483  *
 484  * This header is NOT exported to clients, but see also generate_structs_h.
 485  *)
 486 and generate_xdr () =
 487   generate_header CStyle LGPLv2;
 488
 489   (* This has to be defined to get around a limitation in Sun's rpcgen. *)
 490   pr "typedef string str<>;\n";
 491   pr "\n";
 492
 493   (* LVM internal structures. *)
 494   List.iter (
 495     function
 496     | typ, cols ->
 497         pr "struct guestfs_lvm_int_%s {\n" typ;
 498         List.iter (function
 499                    | name, `String -> pr "  string %s<>;\n" name
 500                    | name, `UUID -> pr "  opaque %s[32];\n" name
 501                    | name, `Bytes -> pr "  hyper %s;\n" name
 502                    | name, `Int -> pr "  hyper %s;\n" name
 503                    | name, `OptPercent -> pr "  float %s;\n" name
 504                   ) cols;
 505         pr "};\n";
 506         pr "\n";
 507         pr "typedef struct guestfs_lvm_int_%s guestfs_lvm_int_%s_list<>;\n" typ typ;
 508         pr "\n";
 509   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols];
 510
 511   List.iter (
 512     fun (shortname, style, _, _, _, _) ->
 513       let name = "guestfs_" ^ shortname in
 514       pr "/* %s */\n\n" name;
 515       (match snd style with
 516        | P0 -> ()
 517        | args ->
 518            pr "struct %s_args {\n" name;
 519            iter_args (
 520              function
 521              | String name -> pr "  string %s<>;\n" name
 522            ) args;
 523            pr "};\n\n"
 524       );
 525       (match fst style with
 526        | Err -> ()
 527        | RString n ->
 528            pr "struct %s_ret {\n" name;
 529            pr "  string %s<>;\n" n;
 530            pr "};\n\n"
 531        | RStringList n ->
 532            pr "struct %s_ret {\n" name;
 533            pr "  str %s<>;\n" n;
 534            pr "};\n\n"
 535        | RPVList n ->
 536            pr "struct %s_ret {\n" name;
 537            pr "  guestfs_lvm_int_pv_list %s;\n" n;
 538            pr "};\n\n"
 539        | RVGList n ->
 540            pr "struct %s_ret {\n" name;
 541            pr "  guestfs_lvm_int_vg_list %s;\n" n;
 542            pr "};\n\n"
 543        | RLVList n ->
 544            pr "struct %s_ret {\n" name;
 545            pr "  guestfs_lvm_int_lv_list %s;\n" n;
 546            pr "};\n\n"
 547       );
 548   ) functions;
 549
 550   (* Table of procedure numbers. *)
 551   pr "enum guestfs_procedure {\n";
 552   List.iter (
 553     fun (shortname, _, proc_nr, _, _, _) ->
 554       pr "  GUESTFS_PROC_%s = %d,\n" (String.uppercase shortname) proc_nr
 555   ) functions;
 556   pr "  GUESTFS_PROC_dummy\n"; (* so we don't have a "hanging comma" *)
 557   pr "};\n";
 558   pr "\n";
 559
 560   (* Having to choose a maximum message size is annoying for several
 561    * reasons (it limits what we can do in the API), but it (a) makes
 562    * the protocol a lot simpler, and (b) provides a bound on the size
 563    * of the daemon which operates in limited memory space.  For large
 564    * file transfers you should use FTP.
 565    *)
 566   pr "const GUESTFS_MESSAGE_MAX = %d;\n" (4 * 1024 * 1024);
 567   pr "\n";
 568
 569   (* Message header, etc. *)
 570   pr "\
 571 const GUESTFS_PROGRAM = 0x2000F5F5;
 572 const GUESTFS_PROTOCOL_VERSION = 1;
 573
 574 enum guestfs_message_direction {
 575   GUESTFS_DIRECTION_CALL = 0,        /* client -> daemon */
 576   GUESTFS_DIRECTION_REPLY = 1        /* daemon -> client */
 577 };
 578
 579 enum guestfs_message_status {
 580   GUESTFS_STATUS_OK = 0,
 581   GUESTFS_STATUS_ERROR = 1
 582 };
 583
 584 const GUESTFS_ERROR_LEN = 256;
 585
 586 struct guestfs_message_error {
 587   string error<GUESTFS_ERROR_LEN>;   /* error message */
 588 };
 589
 590 struct guestfs_message_header {
 591   unsigned prog;                     /* GUESTFS_PROGRAM */
 592   unsigned vers;                     /* GUESTFS_PROTOCOL_VERSION */
 593   guestfs_procedure proc;            /* GUESTFS_PROC_x */
 594   guestfs_message_direction direction;
 595   unsigned serial;                   /* message serial number */
 596   guestfs_message_status status;
 597 };
 598 "
 599
 600 (* Generate the guestfs-structs.h file. *)
 601 and generate_structs_h () =
 602   generate_header CStyle LGPLv2;
 603
 604   (* This is a public exported header file containing various
 605    * structures.  The structures are carefully written to have
 606    * exactly the same in-memory format as the XDR structures that
 607    * we use on the wire to the daemon.  The reason for creating
 608    * copies of these structures here is just so we don't have to
 609    * export the whole of guestfs_protocol.h (which includes much
 610    * unrelated and XDR-dependent stuff that we don't want to be
 611    * public, or required by clients).
 612    *
 613    * To reiterate, we will pass these structures to and from the
 614    * client with a simple assignment or memcpy, so the format
 615    * must be identical to what rpcgen / the RFC defines.
 616    *)
 617
 618   (* LVM public structures. *)
 619   List.iter (
 620     function
 621     | typ, cols ->
 622         pr "struct guestfs_lvm_%s {\n" typ;
 623         List.iter (
 624           function
 625           | name, `String -> pr "  char *%s;\n" name
 626           | name, `UUID -> pr "  char %s[32]; /* this is NOT nul-terminated, be careful when printing */\n" name
 627           | name, `Bytes -> pr "  uint64_t %s;\n" name
 628           | name, `Int -> pr "  int64_t %s;\n" name
 629           | name, `OptPercent -> pr "  float %s; /* [0..100] or -1 */\n" name
 630         ) cols;
 631         pr "};\n";
 632         pr "\n";
 633         pr "struct guestfs_lvm_%s_list {\n" typ;
 634         pr "  uint32_t len;\n";
 635         pr "  struct guestfs_lvm_%s *val;\n" typ;
 636         pr "};\n";
 637         pr "\n"
 638   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols]
 639
 640 (* Generate the guestfs-actions.h file. *)
 641 and generate_actions_h () =
 642   generate_header CStyle LGPLv2;
 643   List.iter (
 644     fun (shortname, style, _, _, _, _) ->
 645       let name = "guestfs_" ^ shortname in
 646       generate_prototype ~single_line:true ~newline:true ~handle:"handle"
 647         name style
 648   ) functions
 649
 650 (* Generate the client-side dispatch stubs. *)
 651 and generate_client_actions () =
 652   generate_header CStyle LGPLv2;
 653
 654   (* Client-side stubs for each function. *)
 655   List.iter (
 656     fun (shortname, style, _, _, _, _) ->
 657       let name = "guestfs_" ^ shortname in
 658
 659       (* Generate the return value struct. *)
 660       pr "struct %s_rv {\n" shortname;
 661       pr "  int cb_done;  /* flag to indicate callback was called */\n";
 662       pr "  struct guestfs_message_header hdr;\n";
 663       pr "  struct guestfs_message_error err;\n";
 664       (match fst style with
 665        | Err -> ()
 666        | RString _ | RStringList _ | RPVList _ | RVGList _ | RLVList _ ->
 667            pr "  struct %s_ret ret;\n" name
 668       );
 669       pr "};\n\n";
 670
 671       (* Generate the callback function. *)
 672       pr "static void %s_cb (guestfs_h *g, void *data, XDR *xdr)\n" shortname;
 673       pr "{\n";
 674       pr "  struct %s_rv *rv = (struct %s_rv *) data;\n" shortname shortname;
 675       pr "\n";
 676       pr "  if (!xdr_guestfs_message_header (xdr, &rv->hdr)) {\n";
 677       pr "    error (g, \"%s: failed to parse reply header\");\n" name;
 678       pr "    return;\n";
 679       pr "  }\n";
 680       pr "  if (rv->hdr.status == GUESTFS_STATUS_ERROR) {\n";
 681       pr "    if (!xdr_guestfs_message_error (xdr, &rv->err)) {\n";
 682       pr "      error (g, \"%s: failed to parse reply error\");\n" name;
 683       pr "      return;\n";
 684       pr "    }\n";
 685       pr "    goto done;\n";
 686       pr "  }\n";
 687
 688       (match fst style with
 689        | Err -> ()
 690        | RString _ | RStringList _ | RPVList _ | RVGList _ | RLVList _ ->
 691             pr "  if (!xdr_%s_ret (xdr, &rv->ret)) {\n" name;
 692             pr "    error (g, \"%s: failed to parse reply\");\n" name;
 693             pr "    return;\n";
 694             pr "  }\n";
 695       );
 696
 697       pr " done:\n";
 698       pr "  rv->cb_done = 1;\n";
 699       pr "  main_loop.main_loop_quit (g);\n";
 700       pr "}\n\n";
 701
 702       (* Generate the action stub. *)
 703       generate_prototype ~extern:false ~semicolon:false ~newline:true
 704         ~handle:"g" name style;
 705
 706       let error_code =
 707         match fst style with
 708         | Err -> "-1"
 709         | RString _ | RStringList _ | RPVList _ | RVGList _ | RLVList _ ->
 710             "NULL" in
 711
 712       pr "{\n";
 713
 714       (match snd style with
 715        | P0 -> ()
 716        | _ -> pr "  struct %s_args args;\n" name
 717       );
 718
 719       pr "  struct %s_rv rv;\n" shortname;
 720       pr "  int serial;\n";
 721       pr "\n";
 722       pr "  if (g->state != READY) {\n";
 723       pr "    error (g, \"%s called from the wrong state, %%d != READY\",\n"
 724         name;
 725       pr "      g->state);\n";
 726       pr "    return %s;\n" error_code;
 727       pr "  }\n";
 728       pr "\n";
 729       pr "  memset (&rv, 0, sizeof rv);\n";
 730       pr "\n";
 731
 732       (match snd style with
 733        | P0 ->
 734            pr "  serial = dispatch (g, GUESTFS_PROC_%s, NULL, NULL);\n"
 735              (String.uppercase shortname)
 736        | args ->
 737            iter_args (
 738              function
 739              | String name -> pr "  args.%s = (char *) %s;\n" name name
 740            ) args;
 741            pr "  serial = dispatch (g, GUESTFS_PROC_%s,\n"
 742              (String.uppercase shortname);
 743            pr "                     (xdrproc_t) xdr_%s_args, (char *) &args);\n"
 744              name;
 745       );
 746       pr "  if (serial == -1)\n";
 747       pr "    return %s;\n" error_code;
 748       pr "\n";
 749
 750       pr "  rv.cb_done = 0;\n";
 751       pr "  g->reply_cb_internal = %s_cb;\n" shortname;
 752       pr "  g->reply_cb_internal_data = &rv;\n";
 753       pr "  main_loop.main_loop_run (g);\n";
 754       pr "  g->reply_cb_internal = NULL;\n";
 755       pr "  g->reply_cb_internal_data = NULL;\n";
 756       pr "  if (!rv.cb_done) {\n";
 757       pr "    error (g, \"%s failed, see earlier error messages\");\n" name;
 758       pr "    return %s;\n" error_code;
 759       pr "  }\n";
 760       pr "\n";
 761
 762       pr "  if (check_reply_header (g, &rv.hdr, GUESTFS_PROC_%s, serial) == -1)\n"
 763         (String.uppercase shortname);
 764       pr "    return %s;\n" error_code;
 765       pr "\n";
 766
 767       pr "  if (rv.hdr.status == GUESTFS_STATUS_ERROR) {\n";
 768       pr "    error (g, \"%%s\", rv.err.error);\n";
 769       pr "    return %s;\n" error_code;
 770       pr "  }\n";
 771       pr "\n";
 772
 773       (match fst style with
 774        | Err -> pr "  return 0;\n"
 775        | RString n ->
 776            pr "  return rv.ret.%s; /* caller will free */\n" n
 777        | RStringList n ->
 778            pr "  /* caller will free this, but we need to add a NULL entry */\n";
 779            pr "  rv.ret.%s.%s_val =" n n;
 780            pr "    safe_realloc (g, rv.ret.%s.%s_val,\n" n n;
 781            pr "                  sizeof (char *) * (rv.ret.%s.%s_len + 1));\n"
 782              n n;
 783            pr "  rv.ret.%s.%s_val[rv.ret.%s.%s_len] = NULL;\n" n n n n;
 784            pr "  return rv.ret.%s.%s_val;\n" n n
 785        | RPVList n ->
 786            pr "  /* caller will free this */\n";
 787            pr "  return safe_memdup (g, &rv.ret.%s, sizeof (rv.ret.%s));\n" n n
 788        | RVGList n ->
 789            pr "  /* caller will free this */\n";
 790            pr "  return safe_memdup (g, &rv.ret.%s, sizeof (rv.ret.%s));\n" n n
 791        | RLVList n ->
 792            pr "  /* caller will free this */\n";
 793            pr "  return safe_memdup (g, &rv.ret.%s, sizeof (rv.ret.%s));\n" n n
 794       );
 795
 796       pr "}\n\n"
 797   ) functions
 798
 799 (* Generate daemon/actions.h. *)
 800 and generate_daemon_actions_h () =
 801   generate_header CStyle GPLv2;
 802
 803   pr "#include \"../src/guestfs_protocol.h\"\n";
 804   pr "\n";
 805
 806   List.iter (
 807     fun (name, style, _, _, _, _) ->
 808       generate_prototype
 809         ~single_line:true ~newline:true ~in_daemon:true ("do_" ^ name) style;
 810   ) functions
 811
 812 (* Generate the server-side stubs. *)
 813 and generate_daemon_actions () =
 814   generate_header CStyle GPLv2;
 815
 816   pr "#define _GNU_SOURCE // for strchrnul\n";
 817   pr "\n";
 818   pr "#include <stdio.h>\n";
 819   pr "#include <stdlib.h>\n";
 820   pr "#include <string.h>\n";
 821   pr "#include <inttypes.h>\n";
 822   pr "#include <ctype.h>\n";
 823   pr "#include <rpc/types.h>\n";
 824   pr "#include <rpc/xdr.h>\n";
 825   pr "\n";
 826   pr "#include \"daemon.h\"\n";
 827   pr "#include \"../src/guestfs_protocol.h\"\n";
 828   pr "#include \"actions.h\"\n";
 829   pr "\n";
 830
 831   List.iter (
 832     fun (name, style, _, _, _, _) ->
 833       (* Generate server-side stubs. *)
 834       pr "static void %s_stub (XDR *xdr_in)\n" name;
 835       pr "{\n";
 836       let error_code =
 837         match fst style with
 838         | Err -> pr "  int r;\n"; "-1"
 839         | RString _ -> pr "  char *r;\n"; "NULL"
 840         | RStringList _ -> pr "  char **r;\n"; "NULL"
 841         | RPVList _ -> pr "  guestfs_lvm_int_pv_list *r;\n"; "NULL"
 842         | RVGList _ -> pr "  guestfs_lvm_int_vg_list *r;\n"; "NULL"
 843         | RLVList _ -> pr "  guestfs_lvm_int_lv_list *r;\n"; "NULL" in
 844
 845       (match snd style with
 846        | P0 -> ()
 847        | args ->
 848            pr "  struct guestfs_%s_args args;\n" name;
 849            iter_args (
 850              function
 851              | String name -> pr "  const char *%s;\n" name
 852            ) args
 853       );
 854       pr "\n";
 855
 856       (match snd style with
 857        | P0 -> ()
 858        | args ->
 859            pr "  memset (&args, 0, sizeof args);\n";
 860            pr "\n";
 861            pr "  if (!xdr_guestfs_%s_args (xdr_in, &args)) {\n" name;
 862            pr "    reply_with_error (\"%s: daemon failed to decode procedure arguments\");\n" name;
 863            pr "    return;\n";
 864            pr "  }\n";
 865            iter_args (
 866              function
 867              | String name -> pr "  %s = args.%s;\n" name name
 868            ) args;
 869            pr "\n"
 870       );
 871
 872       pr "  r = do_%s " name;
 873       generate_call_args style;
 874       pr ";\n";
 875
 876       pr "  if (r == %s)\n" error_code;
 877       pr "    /* do_%s has already called reply_with_error, so just return */\n" name;
 878       pr "    return;\n";
 879       pr "\n";
 880
 881       (match fst style with
 882        | Err -> pr "  reply (NULL, NULL);\n"
 883        | RString n ->
 884            pr "  struct guestfs_%s_ret ret;\n" name;
 885            pr "  ret.%s = r;\n" n;
 886            pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name;
 887            pr "  free (r);\n"
 888        | RStringList n ->
 889            pr "  struct guestfs_%s_ret ret;\n" name;
 890            pr "  ret.%s.%s_len = count_strings (r);\n" n n;
 891            pr "  ret.%s.%s_val = r;\n" n n;
 892            pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name;
 893            pr "  free_strings (r);\n"
 894        | RPVList n ->
 895            pr "  struct guestfs_%s_ret ret;\n" name;
 896            pr "  ret.%s = *r;\n" n;
 897            pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name;
 898            pr "  xdr_free ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n" name
 899        | RVGList n ->
 900            pr "  struct guestfs_%s_ret ret;\n" name;
 901            pr "  ret.%s = *r;\n" n;
 902            pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name;
 903            pr "  xdr_free ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n" name
 904        | RLVList n ->
 905            pr "  struct guestfs_%s_ret ret;\n" name;
 906            pr "  ret.%s = *r;\n" n;
 907            pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name;
 908            pr "  xdr_free ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n" name
 909       );
 910
 911       pr "}\n\n";
 912   ) functions;
 913
 914   (* Dispatch function. *)
 915   pr "void dispatch_incoming_message (XDR *xdr_in)\n";
 916   pr "{\n";
 917   pr "  switch (proc_nr) {\n";
 918
 919   List.iter (
 920     fun (name, style, _, _, _, _) ->
 921       pr "    case GUESTFS_PROC_%s:\n" (String.uppercase name);
 922       pr "      %s_stub (xdr_in);\n" name;
 923       pr "      break;\n"
 924   ) functions;
 925
 926   pr "    default:\n";
 927   pr "      reply_with_error (\"dispatch_incoming_message: unknown procedure number %%d\", proc_nr);\n";
 928   pr "  }\n";
 929   pr "}\n";
 930   pr "\n";
 931
 932   (* LVM columns and tokenization functions. *)
 933   (* XXX This generates crap code.  We should rethink how we
 934    * do this parsing.
 935    *)
 936   List.iter (
 937     function
 938     | typ, cols ->
 939         pr "static const char *lvm_%s_cols = \"%s\";\n"
 940           typ (String.concat "," (List.map fst cols));
 941         pr "\n";
 942
 943         pr "static int lvm_tokenize_%s (char *str, struct guestfs_lvm_int_%s *r)\n" typ typ;
 944         pr "{\n";
 945         pr "  char *tok, *p, *next;\n";
 946         pr "  int i, j;\n";
 947         pr "\n";
 948         (*
 949         pr "  fprintf (stderr, \"%%s: <<%%s>>\\n\", __func__, str);\n";
 950         pr "\n";
 951         *)
 952         pr "  if (!str) {\n";
 953         pr "    fprintf (stderr, \"%%s: failed: passed a NULL string\\n\", __func__);\n";
 954         pr "    return -1;\n";
 955         pr "  }\n";
 956         pr "  if (!*str || isspace (*str)) {\n";
 957         pr "    fprintf (stderr, \"%%s: failed: passed a empty string or one beginning with whitespace\\n\", __func__);\n";
 958         pr "    return -1;\n";
 959         pr "  }\n";
 960         pr "  tok = str;\n";
 961         List.iter (
 962           fun (name, coltype) ->
 963             pr "  if (!tok) {\n";
 964             pr "    fprintf (stderr, \"%%s: failed: string finished early, around token %%s\\n\", __func__, \"%s\");\n" name;
 965             pr "    return -1;\n";
 966             pr "  }\n";
 967             pr "  p = strchrnul (tok, ',');\n";
 968             pr "  if (*p) next = p+1; else next = NULL;\n";
 969             pr "  *p = '\\0';\n";
 970             (match coltype with
 971              | `String ->
 972                  pr "  r->%s = strdup (tok);\n" name;
 973                  pr "  if (r->%s == NULL) {\n" name;
 974                  pr "    perror (\"strdup\");\n";
 975                  pr "    return -1;\n";
 976                  pr "  }\n"
 977              | `UUID ->
 978                  pr "  for (i = j = 0; i < 32; ++j) {\n";
 979                  pr "    if (tok[j] == '\\0') {\n";
 980                  pr "      fprintf (stderr, \"%%s: failed to parse UUID from '%%s'\\n\", __func__, tok);\n";
 981                  pr "      return -1;\n";
 982                  pr "    } else if (tok[j] != '-')\n";
 983                  pr "      r->%s[i++] = tok[j];\n" name;
 984                  pr "  }\n";
 985              | `Bytes ->
 986                  pr "  if (sscanf (tok, \"%%\"SCNu64, &r->%s) != 1) {\n" name;
 987                  pr "    fprintf (stderr, \"%%s: failed to parse size '%%s' from token %%s\\n\", __func__, tok, \"%s\");\n" name;
 988                  pr "    return -1;\n";
 989                  pr "  }\n";
 990              | `Int ->
 991                  pr "  if (sscanf (tok, \"%%\"SCNi64, &r->%s) != 1) {\n" name;
 992                  pr "    fprintf (stderr, \"%%s: failed to parse int '%%s' from token %%s\\n\", __func__, tok, \"%s\");\n" name;
 993                  pr "    return -1;\n";
 994                  pr "  }\n";
 995              | `OptPercent ->
 996                  pr "  if (tok[0] == '\\0')\n";
 997                  pr "    r->%s = -1;\n" name;
 998                  pr "  else if (sscanf (tok, \"%%f\", &r->%s) != 1) {\n" name;
 999                  pr "    fprintf (stderr, \"%%s: failed to parse float '%%s' from token %%s\\n\", __func__, tok, \"%s\");\n" name;
1000                  pr "    return -1;\n";
1001                  pr "  }\n";
1002             );
1003             pr "  tok = next;\n";
1004         ) cols;
1005
1006         pr "  if (tok != NULL) {\n";
1007         pr "    fprintf (stderr, \"%%s: failed: extra tokens at end of string\\n\", __func__);\n";
1008         pr "    return -1;\n";
1009         pr "  }\n";
1010         pr "  return 0;\n";
1011         pr "}\n";
1012         pr "\n";
1013
1014         pr "guestfs_lvm_int_%s_list *\n" typ;
1015         pr "parse_command_line_%ss (void)\n" typ;
1016         pr "{\n";
1017         pr "  char *out, *err;\n";
1018         pr "  char *p, *pend;\n";
1019         pr "  int r, i;\n";
1020         pr "  guestfs_lvm_int_%s_list *ret;\n" typ;
1021         pr "  void *newp;\n";
1022         pr "\n";
1023         pr "  ret = malloc (sizeof *ret);\n";
1024         pr "  if (!ret) {\n";
1025         pr "    reply_with_perror (\"malloc\");\n";
1026         pr "    return NULL;\n";
1027         pr "  }\n";
1028         pr "\n";
1029         pr "  ret->guestfs_lvm_int_%s_list_len = 0;\n" typ;
1030         pr "  ret->guestfs_lvm_int_%s_list_val = NULL;\n" typ;
1031         pr "\n";
1032         pr "  r = command (&out, &err,\n";
1033         pr "           \"/sbin/lvm\", \"%ss\",\n" typ;
1034         pr "           \"-o\", lvm_%s_cols, \"--unbuffered\", \"--noheadings\",\n" typ;
1035         pr "           \"--nosuffix\", \"--separator\", \",\", \"--units\", \"b\", NULL);\n";
1036         pr "  if (r == -1) {\n";
1037         pr "    reply_with_error (\"%%s\", err);\n";
1038         pr "    free (out);\n";
1039         pr "    free (err);\n";
1040         pr "    return NULL;\n";
1041         pr "  }\n";
1042         pr "\n";
1043         pr "  free (err);\n";
1044         pr "\n";
1045         pr "  /* Tokenize each line of the output. */\n";
1046         pr "  p = out;\n";
1047         pr "  i = 0;\n";
1048         pr "  while (p) {\n";
1049         pr "    pend = strchr (p, '\\n');       /* Get the next line of output. */\n";
1050         pr "    if (pend) {\n";
1051         pr "      *pend = '\\0';\n";
1052         pr "      pend++;\n";
1053         pr "    }\n";
1054         pr "\n";
1055         pr "    while (*p && isspace (*p))      /* Skip any leading whitespace. */\n";
1056         pr "      p++;\n";
1057         pr "\n";
1058         pr "    if (!*p) {                      /* Empty line?  Skip it. */\n";
1059         pr "      p = pend;\n";
1060         pr "      continue;\n";
1061         pr "    }\n";
1062         pr "\n";
1063         pr "    /* Allocate some space to store this next entry. */\n";
1064         pr "    newp = realloc (ret->guestfs_lvm_int_%s_list_val,\n" typ;
1065         pr "                sizeof (guestfs_lvm_int_%s) * (i+1));\n" typ;
1066         pr "    if (newp == NULL) {\n";
1067         pr "      reply_with_perror (\"realloc\");\n";
1068         pr "      free (ret->guestfs_lvm_int_%s_list_val);\n" typ;
1069         pr "      free (ret);\n";
1070         pr "      free (out);\n";
1071         pr "      return NULL;\n";
1072         pr "    }\n";
1073         pr "    ret->guestfs_lvm_int_%s_list_val = newp;\n" typ;
1074         pr "\n";
1075         pr "    /* Tokenize the next entry. */\n";
1076         pr "    r = lvm_tokenize_%s (p, &ret->guestfs_lvm_int_%s_list_val[i]);\n" typ typ;
1077         pr "    if (r == -1) {\n";
1078         pr "      reply_with_error (\"failed to parse output of '%ss' command\");\n" typ;
1079         pr "      free (ret->guestfs_lvm_int_%s_list_val);\n" typ;
1080         pr "      free (ret);\n";
1081         pr "      free (out);\n";
1082         pr "      return NULL;\n";
1083         pr "    }\n";
1084         pr "\n";
1085         pr "    ++i;\n";
1086         pr "    p = pend;\n";
1087         pr "  }\n";
1088         pr "\n";
1089         pr "  ret->guestfs_lvm_int_%s_list_len = i;\n" typ;
1090         pr "\n";
1091         pr "  free (out);\n";
1092         pr "  return ret;\n";
1093         pr "}\n"
1094
1095   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols]
1096
1097 (* Generate a lot of different functions for guestfish. *)
1098 and generate_fish_cmds () =
1099   generate_header CStyle GPLv2;
1100
1101   pr "#include <stdio.h>\n";
1102   pr "#include <stdlib.h>\n";
1103   pr "#include <string.h>\n";
1104   pr "#include <inttypes.h>\n";
1105   pr "\n";
1106   pr "#include <guestfs.h>\n";
1107   pr "#include \"fish.h\"\n";
1108   pr "\n";
1109
1110   (* list_commands function, which implements guestfish -h *)
1111   pr "void list_commands (void)\n";
1112   pr "{\n";
1113   pr "  printf (\"    %%-16s     %%s\\n\", \"Command\", \"Description\");\n";
1114   pr "  list_builtin_commands ();\n";
1115   List.iter (
1116     fun (name, _, _, _, shortdesc, _) ->
1117       let name = replace_char name '_' '-' in
1118       pr "  printf (\"%%-20s %%s\\n\", \"%s\", \"%s\");\n"
1119         name shortdesc
1120   ) sorted_functions;
1121   pr "  printf (\"    Use -h <cmd> / help <cmd> to show detailed help for a command.\\n\");\n";
1122   pr "}\n";
1123   pr "\n";
1124
1125   (* display_command function, which implements guestfish -h cmd *)
1126   pr "void display_command (const char *cmd)\n";
1127   pr "{\n";
1128   List.iter (
1129     fun (name, style, _, flags, shortdesc, longdesc) ->
1130       let name2 = replace_char name '_' '-' in
1131       let longdesc = replace_str longdesc "C<guestfs_" "C<" in
1132       let synopsis =
1133         match snd style with
1134         | P0 -> name2
1135         | args ->
1136             sprintf "%s <%s>"
1137               name2 (
1138                 String.concat "> <" (
1139                   map_args (function
1140                             | String n -> n) args
1141                 )
1142               ) in
1143
1144       let warnings =
1145         if List.mem ProtocolLimitWarning flags then
1146           "\n\nBecause of the message protocol, there is a transfer limit
1147 of somewhere between 2MB and 4MB.  To transfer large files you should use
1148 FTP."
1149         else "" in
1150
1151       pr "  if (";
1152       pr "strcasecmp (cmd, \"%s\") == 0" name;
1153       if name <> name2 then
1154         pr " || strcasecmp (cmd, \"%s\") == 0" name2;
1155       pr ")\n";
1156       pr "    pod2text (\"%s - %s\", %S);\n"
1157         name2 shortdesc
1158         (" " ^ synopsis ^ "\n\n" ^ longdesc ^ warnings);
1159       pr "  else\n"
1160   ) functions;
1161   pr "    display_builtin_command (cmd);\n";
1162   pr "}\n";
1163   pr "\n";
1164
1165   (* print_{pv,vg,lv}_list functions *)
1166   List.iter (
1167     function
1168     | typ, cols ->
1169         pr "static void print_%s (struct guestfs_lvm_%s *%s)\n" typ typ typ;
1170         pr "{\n";
1171         pr "  int i;\n";
1172         pr "\n";
1173         List.iter (
1174           function
1175           | name, `String ->
1176               pr "  printf (\"%s: %%s\\n\", %s->%s);\n" name typ name
1177           | name, `UUID ->
1178               pr "  printf (\"%s: \");\n" name;
1179               pr "  for (i = 0; i < 32; ++i)\n";
1180               pr "    printf (\"%%c\", %s->%s[i]);\n" typ name;
1181               pr "  printf (\"\\n\");\n"
1182           | name, `Bytes ->
1183               pr "  printf (\"%s: %%\" PRIu64 \"\\n\", %s->%s);\n" name typ name
1184           | name, `Int ->
1185               pr "  printf (\"%s: %%\" PRIi64 \"\\n\", %s->%s);\n" name typ name
1186           | name, `OptPercent ->
1187               pr "  if (%s->%s >= 0) printf (\"%s: %%g %%%%\\n\", %s->%s);\n"
1188                 typ name name typ name;
1189               pr "  else printf (\"%s: \\n\");\n" name
1190         ) cols;
1191         pr "}\n";
1192         pr "\n";
1193         pr "static void print_%s_list (struct guestfs_lvm_%s_list *%ss)\n"
1194           typ typ typ;
1195         pr "{\n";
1196         pr "  int i;\n";
1197         pr "\n";
1198         pr "  for (i = 0; i < %ss->len; ++i)\n" typ;
1199         pr "    print_%s (&%ss->val[i]);\n" typ typ;
1200         pr "}\n";
1201         pr "\n";
1202   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols];
1203
1204   (* run_<action> actions *)
1205   List.iter (
1206     fun (name, style, _, _, _, _) ->
1207       pr "static int run_%s (const char *cmd, int argc, char *argv[])\n" name;
1208       pr "{\n";
1209       (match fst style with
1210        | Err -> pr "  int r;\n"
1211        | RString _ -> pr "  char *r;\n"
1212        | RStringList _ -> pr "  char **r;\n"
1213        | RPVList _ -> pr "  struct guestfs_lvm_pv_list *r;\n"
1214        | RVGList _ -> pr "  struct guestfs_lvm_vg_list *r;\n"
1215        | RLVList _ -> pr "  struct guestfs_lvm_lv_list *r;\n"
1216       );
1217       iter_args (
1218         function
1219         | String name -> pr "  const char *%s;\n" name
1220       ) (snd style);
1221
1222       (* Check and convert parameters. *)
1223       let argc_expected = nr_args (snd style) in
1224       pr "  if (argc != %d) {\n" argc_expected;
1225       pr "    fprintf (stderr, \"%%s should have %d parameter(s)\\n\", cmd);\n"
1226         argc_expected;
1227       pr "    fprintf (stderr, \"type 'help %%s' for help on %%s\\n\", cmd, cmd);\n";
1228       pr "    return -1;\n";
1229       pr "  }\n";
1230       iteri_args (
1231         fun i ->
1232           function
1233           | String name -> pr "  %s = argv[%d];\n" name i
1234       ) (snd style);
1235
1236       (* Call C API function. *)
1237       pr "  r = guestfs_%s " name;
1238       generate_call_args ~handle:"g" style;
1239       pr ";\n";
1240
1241       (* Check return value for errors and display command results. *)
1242       (match fst style with
1243        | Err -> pr "  return r;\n"
1244        | RString _ ->
1245            pr "  if (r == NULL) return -1;\n";
1246            pr "  printf (\"%%s\", r);\n";
1247            pr "  free (r);\n";
1248            pr "  return 0;\n"
1249        | RStringList _ ->
1250            pr "  if (r == NULL) return -1;\n";
1251            pr "  print_strings (r);\n";
1252            pr "  free_strings (r);\n";
1253            pr "  return 0;\n"
1254        | RPVList _ ->
1255            pr "  if (r == NULL) return -1;\n";
1256            pr "  print_pv_list (r);\n";
1257            pr "  guestfs_free_lvm_pv_list (r);\n";
1258            pr "  return 0;\n"
1259        | RVGList _ ->
1260            pr "  if (r == NULL) return -1;\n";
1261            pr "  print_vg_list (r);\n";
1262            pr "  guestfs_free_lvm_vg_list (r);\n";
1263            pr "  return 0;\n"
1264        | RLVList _ ->
1265            pr "  if (r == NULL) return -1;\n";
1266            pr "  print_lv_list (r);\n";
1267            pr "  guestfs_free_lvm_lv_list (r);\n";
1268            pr "  return 0;\n"
1269       );
1270       pr "}\n";
1271       pr "\n"
1272   ) functions;
1273
1274   (* run_action function *)
1275   pr "int run_action (const char *cmd, int argc, char *argv[])\n";
1276   pr "{\n";
1277   List.iter (
1278     fun (name, _, _, _, _, _) ->
1279       let name2 = replace_char name '_' '-' in
1280       pr "  if (";
1281       pr "strcasecmp (cmd, \"%s\") == 0" name;
1282       if name <> name2 then
1283         pr " || strcasecmp (cmd, \"%s\") == 0" name2;
1284       pr ")\n";
1285       pr "    return run_%s (cmd, argc, argv);\n" name;
1286       pr "  else\n";
1287   ) functions;
1288   pr "    {\n";
1289   pr "      fprintf (stderr, \"%%s: unknown command\\n\", cmd);\n";
1290   pr "      return -1;\n";
1291   pr "    }\n";
1292   pr "  return 0;\n";
1293   pr "}\n";
1294   pr "\n"
1295
1296 (* Generate the POD documentation for guestfish. *)
1297 and generate_fish_actions_pod () =
1298   List.iter (
1299     fun (name, style, _, _, _, longdesc) ->
1300       let longdesc = replace_str longdesc "C<guestfs_" "C<" in
1301       let name = replace_char name '_' '-' in
1302       pr "=head2 %s\n\n" name;
1303       pr " %s" name;
1304       iter_args (
1305         function
1306         | String n -> pr " %s" n
1307       ) (snd style);
1308       pr "\n";
1309       pr "\n";
1310       pr "%s\n\n" longdesc
1311   ) sorted_functions
1312
1313 (* Generate a C function prototype. *)
1314 and generate_prototype ?(extern = true) ?(static = false) ?(semicolon = true)
1315     ?(single_line = false) ?(newline = false) ?(in_daemon = false)
1316     ?handle name style =
1317   if extern then pr "extern ";
1318   if static then pr "static ";
1319   (match fst style with
1320    | Err -> pr "int "
1321    | RString _ -> pr "char *"
1322    | RStringList _ -> pr "char **"
1323    | RPVList _ ->
1324        if not in_daemon then pr "struct guestfs_lvm_pv_list *"
1325        else pr "guestfs_lvm_int_pv_list *"
1326    | RVGList _ ->
1327        if not in_daemon then pr "struct guestfs_lvm_vg_list *"
1328        else pr "guestfs_lvm_int_vg_list *"
1329    | RLVList _ ->
1330        if not in_daemon then pr "struct guestfs_lvm_lv_list *"
1331        else pr "guestfs_lvm_int_lv_list *"
1332   );
1333   pr "%s (" name;
1334   let comma = ref false in
1335   (match handle with
1336    | None -> ()
1337    | Some handle -> pr "guestfs_h *%s" handle; comma := true
1338   );
1339   let next () =
1340     if !comma then (
1341       if single_line then pr ", " else pr ",\n\t\t"
1342     );
1343     comma := true
1344   in
1345   iter_args (
1346     function
1347     | String name -> next (); pr "const char *%s" name
1348   ) (snd style);
1349   pr ")";
1350   if semicolon then pr ";";
1351   if newline then pr "\n"
1352
1353 (* Generate C call arguments, eg "(handle, foo, bar)" *)
1354 and generate_call_args ?handle style =
1355   pr "(";
1356   let comma = ref false in
1357   (match handle with
1358    | None -> ()
1359    | Some handle -> pr "%s" handle; comma := true
1360   );
1361   iter_args (
1362     fun arg ->
1363       if !comma then pr ", ";
1364       comma := true;
1365       match arg with
1366       | String name -> pr "%s" name
1367   ) (snd style);
1368   pr ")"
1369
1370 (* Generate the OCaml bindings interface. *)
1371 and generate_ocaml_mli () =
1372   generate_header OCamlStyle LGPLv2;
1373
1374   pr "\
1375 (** For API documentation you should refer to the C API
1376     in the guestfs(3) manual page.  The OCaml API uses almost
1377     exactly the same calls. *)
1378
1379 type t
1380 (** A [guestfs_h] handle. *)
1381
1382 exception Error of string
1383 (** This exception is raised when there is an error. *)
1384
1385 val create : unit -> t
1386
1387 val close : t -> unit
1388 (** Handles are closed by the garbage collector when they become
1389     unreferenced, but callers can also call this in order to
1390     provide predictable cleanup. *)
1391
1392 val launch : t -> unit
1393 val wait_ready : t -> unit
1394 val kill_subprocess : t -> unit
1395
1396 val add_drive : t -> string -> unit
1397 val add_cdrom : t -> string -> unit
1398 val config : t -> string -> string option -> unit
1399
1400 val set_path : t -> string option -> unit
1401 val get_path : t -> string
1402 val set_autosync : t -> bool -> unit
1403 val get_autosync : t -> bool
1404 val set_verbose : t -> bool -> unit
1405 val get_verbose : t -> bool
1406
1407 ";
1408   generate_ocaml_lvm_structure_decls ();
1409
1410   (* The actions. *)
1411   List.iter (
1412     fun (name, style, _, _, shortdesc, _) ->
1413       generate_ocaml_prototype name style;
1414       pr "(** %s *)\n" shortdesc;
1415       pr "\n"
1416   ) sorted_functions
1417
1418 (* Generate the OCaml bindings implementation. *)
1419 and generate_ocaml_ml () =
1420   generate_header OCamlStyle LGPLv2;
1421
1422   pr "\
1423 type t
1424 exception Error of string
1425 external create : unit -> t = \"ocaml_guestfs_create\"
1426 external close : t -> unit = \"ocaml_guestfs_create\"
1427 external launch : t -> unit = \"ocaml_guestfs_launch\"
1428 external wait_ready : t -> unit = \"ocaml_guestfs_wait_ready\"
1429 external kill_subprocess : t -> unit = \"ocaml_guestfs_kill_subprocess\"
1430 external add_drive : t -> string -> unit = \"ocaml_guestfs_add_drive\"
1431 external add_cdrom : t -> string -> unit = \"ocaml_guestfs_add_cdrom\"
1432 external config : t -> string -> string option -> unit = \"ocaml_guestfs_config\"
1433 external set_path : t -> string option -> unit = \"ocaml_guestfs_set_path\"
1434 external get_path : t -> string = \"ocaml_guestfs_get_path\"
1435 external set_autosync : t -> bool -> unit = \"ocaml_guestfs_set_autosync\"
1436 external get_autosync : t -> bool = \"ocaml_guestfs_get_autosync\"
1437 external set_verbose : t -> bool -> unit = \"ocaml_guestfs_set_verbose\"
1438 external get_verbose : t -> bool = \"ocaml_guestfs_get_verbose\"
1439
1440 ";
1441   generate_ocaml_lvm_structure_decls ();
1442
1443   (* The actions. *)
1444   List.iter (
1445     fun (name, style, _, _, shortdesc, _) ->
1446       generate_ocaml_prototype ~is_external:true name style;
1447   ) sorted_functions
1448
1449 (* Generate the OCaml bindings C implementation. *)
1450 and generate_ocaml_c () =
1451   generate_header CStyle LGPLv2;
1452
1453   pr "#include <stdio.h>\n";
1454   pr "#include <stdlib.h>\n";
1455   pr "\n";
1456   pr "#include <guestfs.h>\n";
1457   pr "\n";
1458   pr "#include <caml/config.h>\n";
1459   pr "#include <caml/alloc.h>\n";
1460   pr "#include <caml/callback.h>\n";
1461   pr "#include <caml/fail.h>\n";
1462   pr "#include <caml/memory.h>\n";
1463   pr "#include <caml/mlvalues.h>\n";
1464   pr "\n";
1465   pr "#include \"guestfs_c.h\"\n";
1466   pr "\n";
1467
1468   List.iter (
1469     fun (name, style, _, _, _, _) ->
1470       pr "CAMLprim value\n";
1471       pr "ocaml_guestfs_%s (value hv /* XXX */)\n" name;
1472       pr "{\n";
1473       pr "  CAMLparam1 (hv); /* XXX */\n";
1474       pr "/* XXX write something here */\n";
1475       pr "  CAMLreturn (Val_unit); /* XXX */\n";
1476       pr "}\n";
1477       pr "\n"
1478   ) sorted_functions
1479
1480 and generate_ocaml_lvm_structure_decls () =
1481   List.iter (
1482     fun (typ, cols) ->
1483       pr "type lvm_%s = {\n" typ;
1484       List.iter (
1485         function
1486         | name, `String -> pr "  %s : string;\n" name
1487         | name, `UUID -> pr "  %s : string;\n" name
1488         | name, `Bytes -> pr "  %s : int64;\n" name
1489         | name, `Int -> pr "  %s : int64;\n" name
1490         | name, `OptPercent -> pr "  %s : float option;\n" name
1491       ) cols;
1492       pr "}\n";
1493       pr "\n"
1494   ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols]
1495
1496 and generate_ocaml_prototype ?(is_external = false) name style =
1497   if is_external then pr "external " else pr "val ";
1498   pr "%s : t -> " name;
1499   iter_args (
1500     function
1501     | String _ -> pr "string -> " (* note String is not allowed to be NULL *)
1502   ) (snd style);
1503   (match fst style with
1504    | Err -> pr "unit" (* all errors are turned into exceptions *)
1505    | RString _ -> pr "string"
1506    | RStringList _ -> pr "string list"
1507    | RPVList _ -> pr "lvm_pv list"
1508    | RVGList _ -> pr "lvm_vg list"
1509    | RLVList _ -> pr "lvm_lv list"
1510   );
1511   if is_external then pr " = \"ocaml_guestfs_%s\"" name;
1512   pr "\n"
1513
1514 (* Generate Perl xs code, a sort of crazy variation of C with macros. *)
1515 and generate_perl_xs () =
1516   generate_header CStyle LGPLv2;
1517
1518   pr "\
1519 #include \"EXTERN.h\"
1520 #include \"perl.h\"
1521 #include \"XSUB.h\"
1522
1523 #include <guestfs.h>
1524
1525 #ifndef PRId64
1526 #define PRId64 \"lld\"
1527 #endif
1528
1529 static SV *
1530 my_newSVll(long long val) {
1531 #ifdef USE_64_BIT_ALL
1532   return newSViv(val);
1533 #else
1534   char buf[100];
1535   int len;
1536   len = snprintf(buf, 100, \"%%\" PRId64, val);
1537   return newSVpv(buf, len);
1538 #endif
1539 }
1540
1541 #ifndef PRIu64
1542 #define PRIu64 \"llu\"
1543 #endif
1544
1545 static SV *
1546 my_newSVull(unsigned long long val) {
1547 #ifdef USE_64_BIT_ALL
1548   return newSVuv(val);
1549 #else
1550   char buf[100];
1551   int len;
1552   len = snprintf(buf, 100, \"%%\" PRIu64, val);
1553   return newSVpv(buf, len);
1554 #endif
1555 }
1556
1557 /* XXX Not thread-safe, and in general not safe if the caller is
1558  * issuing multiple requests in parallel (on different guestfs
1559  * handles).  We should use the guestfs_h handle passed to the
1560  * error handle to distinguish these cases.
1561  */
1562 static char *last_error = NULL;
1563
1564 static void
1565 error_handler (guestfs_h *g,
1566                void *data,
1567                const char *msg)
1568 {
1569   if (last_error != NULL) free (last_error);
1570   last_error = strdup (msg);
1571 }
1572
1573 MODULE = Sys::Guestfs  PACKAGE = Sys::Guestfs
1574
1575 guestfs_h *
1576 _create ()
1577 CODE:
1578     RETVAL = guestfs_create ();
1579     if (!RETVAL)
1580       croak (\"could not create guestfs handle\");
1581     guestfs_set_error_handler (RETVAL, error_handler, NULL);
1582 OUTPUT:
1583     RETVAL
1584
1585 void
1586 DESTROY (g)
1587     guestfs_h *g;
1588 PPCODE:
1589     guestfs_close (g);
1590
1591 ";
1592
1593   List.iter (
1594     fun (name, style, _, _, _, _) ->
1595       (match fst style with
1596        | Err -> pr "void\n"
1597        | RString _ -> pr "SV *\n"
1598        | RStringList _
1599        | RPVList _ | RVGList _ | RLVList _ ->
1600            pr "void\n" (* all lists returned implictly on the stack *)
1601       );
1602       (* Call and arguments. *)
1603       pr "%s " name;
1604       generate_call_args ~handle:"g" style;
1605       pr "\n";
1606       pr "      guestfs_h *g;\n";
1607       iter_args (
1608         function
1609         | String n -> pr "      char *%s;\n" n
1610       ) (snd style);
1611       (* Code. *)
1612       (match fst style with
1613        | Err ->
1614            pr " PPCODE:\n";
1615            pr "      if (guestfs_%s " name;
1616            generate_call_args ~handle:"g" style;
1617            pr " == -1)\n";
1618            pr "        croak (\"%s: %%s\", last_error);\n" name
1619        | RString n ->
1620            pr "PREINIT:\n";
1621            pr "      char *%s;\n" n;
1622            pr "   CODE:\n";
1623            pr "      %s = guestfs_%s " n name;
1624            generate_call_args ~handle:"g" style;
1625            pr ";\n";
1626            pr "      if (%s == NULL)\n" n;
1627            pr "        croak (\"%s: %%s\", last_error);\n" name;
1628            pr "      RETVAL = newSVpv (%s, 0);\n" n;
1629            pr "      free (%s);\n" n;
1630            pr " OUTPUT:\n";
1631            pr "      RETVAL\n"
1632        | RStringList n ->
1633            pr "PREINIT:\n";
1634            pr "      char **%s;\n" n;
1635            pr "      int i, n;\n";
1636            pr " PPCODE:\n";
1637            pr "      %s = guestfs_%s " n name;
1638            generate_call_args ~handle:"g" style;
1639            pr ";\n";
1640            pr "      if (%s == NULL)\n" n;
1641            pr "        croak (\"%s: %%s\", last_error);\n" name;
1642            pr "      for (n = 0; %s[n] != NULL; ++n) /**/;\n" n;
1643            pr "      EXTEND (SP, n);\n";
1644            pr "      for (i = 0; i < n; ++i) {\n";
1645            pr "        PUSHs (sv_2mortal (newSVpv (%s[i], 0)));\n" n;
1646            pr "        free (%s[i]);\n" n;
1647            pr "      }\n";
1648            pr "      free (%s);\n" n;
1649        | RPVList n ->
1650            generate_perl_lvm_code "pv" pv_cols name style n;
1651        | RVGList n ->
1652            generate_perl_lvm_code "vg" vg_cols name style n;
1653        | RLVList n ->
1654            generate_perl_lvm_code "lv" lv_cols name style n;
1655       );
1656       pr "\n"
1657   ) functions
1658
1659 and generate_perl_lvm_code typ cols name style n =
1660   pr "PREINIT:\n";
1661   pr "      struct guestfs_lvm_%s_list *%s;\n" typ n;
1662   pr "      int i;\n";
1663   pr "      HV *hv;\n";
1664   pr " PPCODE:\n";
1665   pr "      %s = guestfs_%s " n name;
1666   generate_call_args ~handle:"g" style;
1667   pr ";\n";
1668   pr "      if (%s == NULL)\n" n;
1669   pr "        croak (\"%s: %%s\", last_error);\n" name;
1670   pr "      EXTEND (SP, %s->len);\n" n;
1671   pr "      for (i = 0; i < %s->len; ++i) {\n" n;
1672   pr "        hv = newHV ();\n";
1673   List.iter (
1674     function
1675     | name, `String ->
1676         pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (%s->val[i].%s, 0), 0);\n"
1677           name (String.length name) n name
1678     | name, `UUID ->
1679         pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (%s->val[i].%s, 32), 0);\n"
1680           name (String.length name) n name
1681     | name, `Bytes ->
1682         pr "        (void) hv_store (hv, \"%s\", %d, my_newSVull (%s->val[i].%s), 0);\n"
1683           name (String.length name) n name
1684     | name, `Int ->
1685         pr "        (void) hv_store (hv, \"%s\", %d, my_newSVll (%s->val[i].%s), 0);\n"
1686           name (String.length name) n name
1687     | name, `OptPercent ->
1688         pr "        (void) hv_store (hv, \"%s\", %d, newSVnv (%s->val[i].%s), 0);\n"
1689           name (String.length name) n name
1690   ) cols;
1691   pr "        PUSHs (sv_2mortal ((SV *) hv));\n";
1692   pr "      }\n";
1693   pr "      guestfs_free_lvm_%s_list (%s);\n" typ n
1694
1695 (* Generate Sys/Guestfs.pm. *)
1696 and generate_perl_pm () =
1697   generate_header HashStyle LGPLv2;
1698
1699   pr "\
1700 =pod
1701
1702 =head1 NAME
1703
1704 Sys::Guestfs - Perl bindings for libguestfs
1705
1706 =head1 SYNOPSIS
1707
1708  use Sys::Guestfs;
1709
1710  my $h = Sys::Guestfs->new ();
1711  $h->add_drive ('guest.img');
1712  $h->launch ();
1713  $h->wait_ready ();
1714  $h->mount ('/dev/sda1', '/');
1715  $h->touch ('/hello');
1716  $h->sync ();
1717
1718 =head1 DESCRIPTION
1719
1720 The C<Sys::Guestfs> module provides a Perl XS binding to the
1721 libguestfs API for examining and modifying virtual machine
1722 disk images.
1723
1724 Amongst the things this is good for: making batch configuration
1725 changes to guests, getting disk used/free statistics (see also:
1726 virt-df), migrating between virtualization systems (see also:
1727 virt-p2v), performing partial backups, performing partial guest
1728 clones, cloning guests and changing registry/UUID/hostname info, and
1729 much else besides.
1730
1731 Libguestfs uses Linux kernel and qemu code, and can access any type of
1732 guest filesystem that Linux and qemu can, including but not limited
1733 to: ext2/3/4, btrfs, FAT and NTFS, LVM, many different disk partition
1734 schemes, qcow, qcow2, vmdk.
1735
1736 Libguestfs provides ways to enumerate guest storage (eg. partitions,
1737 LVs, what filesystem is in each LV, etc.).  It can also run commands
1738 in the context of the guest.  Also you can access filesystems over FTP.
1739
1740 =head1 ERRORS
1741
1742 All errors turn into calls to C<croak> (see L<Carp(3)>).
1743
1744 =head1 METHODS
1745
1746 =over 4
1747
1748 =cut
1749
1750 package Sys::Guestfs;
1751
1752 use strict;
1753 use warnings;
1754
1755 require XSLoader;
1756 XSLoader::load ('Sys::Guestfs');
1757
1758 =item $h = Sys::Guestfs->new ();
1759
1760 Create a new guestfs handle.
1761
1762 =cut
1763
1764 sub new {
1765   my $proto = shift;
1766   my $class = ref ($proto) || $proto;
1767
1768   my $self = Sys::Guestfs::_create ();
1769   bless $self, $class;
1770   return $self;
1771 }
1772
1773 ";
1774
1775   (* Actions.  We only need to print documentation for these as
1776    * they are pulled in from the XS code automatically.
1777    *)
1778   List.iter (
1779     fun (name, style, _, flags, _, longdesc) ->
1780       let longdesc = replace_str longdesc "C<guestfs_" "C<$h-E<gt>" in
1781       pr "=item ";
1782       generate_perl_prototype name style;
1783       pr "\n\n";
1784       pr "%s\n\n" longdesc;
1785       if List.mem ProtocolLimitWarning flags then
1786         pr "Because of the message protocol, there is a transfer limit
1787 of somewhere between 2MB and 4MB.  To transfer large files you should use
1788 FTP.\n\n";
1789   ) sorted_functions;
1790
1791   (* End of file. *)
1792   pr "\
1793 =cut
1794
1795 1;
1796
1797 =back
1798
1799 =head1 COPYRIGHT
1800
1801 Copyright (C) 2009 Red Hat Inc.
1802
1803 =head1 LICENSE
1804
1805 Please see the file COPYING.LIB for the full license.
1806
1807 =head1 SEE ALSO
1808
1809 L<guestfs(3)>, L<guestfish(1)>.
1810
1811 =cut
1812 "
1813
1814 and generate_perl_prototype name style =
1815   (match fst style with
1816    | Err -> ()
1817    | RString n -> pr "$%s = " n
1818    | RStringList n
1819    | RPVList n
1820    | RVGList n
1821    | RLVList n -> pr "@%s = " n
1822   );
1823   pr "$h->%s (" name;
1824   let comma = ref false in
1825   iter_args (
1826     fun arg ->
1827       if !comma then pr ", ";
1828       comma := true;
1829       match arg with
1830       | String n -> pr "%s" n
1831   ) (snd style);
1832   pr ");"
1833
1834 let output_to filename =
1835   let filename_new = filename ^ ".new" in
1836   chan := open_out filename_new;
1837   let close () =
1838     close_out !chan;
1839     chan := stdout;
1840     Unix.rename filename_new filename;
1841     printf "written %s\n%!" filename;
1842   in
1843   close
1844
1845 (* Main program. *)
1846 let () =
1847   check_functions ();
1848
1849   let close = output_to "src/guestfs_protocol.x" in
1850   generate_xdr ();
1851   close ();
1852
1853   let close = output_to "src/guestfs-structs.h" in
1854   generate_structs_h ();
1855   close ();
1856
1857   let close = output_to "src/guestfs-actions.h" in
1858   generate_actions_h ();
1859   close ();
1860
1861   let close = output_to "src/guestfs-actions.c" in
1862   generate_client_actions ();
1863   close ();
1864
1865   let close = output_to "daemon/actions.h" in
1866   generate_daemon_actions_h ();
1867   close ();
1868
1869   let close = output_to "daemon/stubs.c" in
1870   generate_daemon_actions ();
1871   close ();
1872
1873   let close = output_to "fish/cmds.c" in
1874   generate_fish_cmds ();
1875   close ();
1876
1877   let close = output_to "guestfs-structs.pod" in
1878   generate_structs_pod ();
1879   close ();
1880
1881   let close = output_to "guestfs-actions.pod" in
1882   generate_actions_pod ();
1883   close ();
1884
1885   let close = output_to "guestfish-actions.pod" in
1886   generate_fish_actions_pod ();
1887   close ();
1888
1889   let close = output_to "ocaml/guestfs.mli" in
1890   generate_ocaml_mli ();
1891   close ();
1892
1893   let close = output_to "ocaml/guestfs.ml" in
1894   generate_ocaml_ml ();
1895   close ();
1896
1897   let close = output_to "ocaml/guestfs_c_actions.c" in
1898   generate_ocaml_c ();
1899   close ();
1900
1901   let close = output_to "perl/Guestfs.xs" in
1902   generate_perl_xs ();
1903   close ();
1904
1905   let close = output_to "perl/lib/Sys/Guestfs.pm" in
1906   generate_perl_pm ();
1907   close ();