3 * Copyright (C) 2009 Red Hat Inc.
5 * This program is free software; you can redistribute it and/or modify
6 * it under the terms of the GNU General Public License as published by
7 * the Free Software Foundation; either version 2 of the License, or
8 * (at your option) any later version.
10 * This program is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 * GNU General Public License for more details.
15 * You should have received a copy of the GNU General Public License
16 * along with this program; if not, write to the Free Software
17 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
20 (* This script generates a large amount of code and documentation for
21 * all the daemon actions.
23 * To add a new action there are only two files you need to change,
24 * this one to describe the interface (see the big table below), and
25 * daemon/<somefile>.c to write the implementation.
27 * After editing this file, run it (./src/generator.ml) to regenerate
28 * all the output files.
30 * IMPORTANT: This script should NOT print any warnings. If it prints
31 * warnings, you should treat them as errors.
32 * [Need to add -warn-error to ocaml command line]
39 type style = ret * args
41 (* "RErr" as a return value means an int used as a simple error
42 * indication, ie. 0 or -1.
45 (* "RInt" as a return value means an int which is -1 for error
46 * or any value >= 0 on success. Only use this for smallish
47 * positive ints (0 <= i < 2^30).
50 (* "RInt64" is the same as RInt, but is guaranteed to be able
51 * to return a full 64 bit value, _except_ that -1 means error
52 * (so -1 cannot be a valid, non-error return value).
55 (* "RBool" is a bool return value which can be true/false or
59 (* "RConstString" is a string that refers to a constant value.
60 * Try to avoid using this. In particular you cannot use this
61 * for values returned from the daemon, because there is no
62 * thread-safe way to return them in the C API.
64 | RConstString of string
65 (* "RString" and "RStringList" are caller-frees. *)
67 | RStringList of string
68 (* Some limited tuples are possible: *)
69 | RIntBool of string * string
70 (* LVM PVs, VGs and LVs. *)
77 (* Key-value pairs of untyped strings. Turns into a hashtable or
78 * dictionary in languages which support it. DON'T use this as a
79 * general "bucket" for results. Prefer a stronger typed return
80 * value if one is available, or write a custom struct. Don't use
81 * this if the list could potentially be very long, since it is
82 * inefficient. Keys should be unique. NULLs are not permitted.
84 | RHashtable of string
86 and args = argt list (* Function parameters, guestfs handle is implicit. *)
88 (* Note in future we should allow a "variable args" parameter as
89 * the final parameter, to allow commands like
90 * chmod mode file [file(s)...]
91 * This is not implemented yet, but many commands (such as chmod)
92 * are currently defined with the argument order keeping this future
93 * possibility in mind.
96 | String of string (* const char *name, cannot be NULL *)
97 | OptString of string (* const char *name, may be NULL *)
98 | StringList of string(* list of strings (each string cannot be NULL) *)
99 | Bool of string (* boolean *)
100 | Int of string (* int (smallish ints, signed, <= 31 bits) *)
103 | ProtocolLimitWarning (* display warning about protocol size limits *)
104 | DangerWillRobinson (* flags particularly dangerous commands *)
105 | FishAlias of string (* provide an alias for this cmd in guestfish *)
106 | FishAction of string (* call this function in guestfish *)
107 | NotInFish (* do not export via guestfish *)
109 let protocol_limit_warning =
110 "Because of the message protocol, there is a transfer limit
111 of somewhere between 2MB and 4MB. To transfer large files you should use
114 let danger_will_robinson =
115 "B<This command is dangerous. Without careful use you
116 can easily destroy all your data>."
118 (* You can supply zero or as many tests as you want per API call.
120 * Note that the test environment has 3 block devices, of size 500MB,
121 * 50MB and 10MB (respectively /dev/sda, /dev/sdb, /dev/sdc).
122 * Note for partitioning purposes, the 500MB device has 63 cylinders.
124 * To be able to run the tests in a reasonable amount of time,
125 * the virtual machine and block devices are reused between tests.
126 * So don't try testing kill_subprocess :-x
128 * Between each test we umount-all and lvm-remove-all (except InitNone).
130 * Don't assume anything about the previous contents of the block
131 * devices. Use 'Init*' to create some initial scenarios.
133 type tests = (test_init * test) list
135 (* Run the command sequence and just expect nothing to fail. *)
137 (* Run the command sequence and expect the output of the final
138 * command to be the string.
140 | TestOutput of seq * string
141 (* Run the command sequence and expect the output of the final
142 * command to be the list of strings.
144 | TestOutputList of seq * string list
145 (* Run the command sequence and expect the output of the final
146 * command to be the integer.
148 | TestOutputInt of seq * int
149 (* Run the command sequence and expect the output of the final
150 * command to be a true value (!= 0 or != NULL).
152 | TestOutputTrue of seq
153 (* Run the command sequence and expect the output of the final
154 * command to be a false value (== 0 or == NULL, but not an error).
156 | TestOutputFalse of seq
157 (* Run the command sequence and expect the output of the final
158 * command to be a list of the given length (but don't care about
161 | TestOutputLength of seq * int
162 (* Run the command sequence and expect the output of the final
163 * command to be a structure.
165 | TestOutputStruct of seq * test_field_compare list
166 (* Run the command sequence and expect the final command (only)
169 | TestLastFail of seq
171 and test_field_compare =
172 | CompareWithInt of string * int
173 | CompareWithString of string * string
174 | CompareFieldsIntEq of string * string
175 | CompareFieldsStrEq of string * string
177 (* Some initial scenarios for testing. *)
179 (* Do nothing, block devices could contain random stuff including
180 * LVM PVs, and some filesystems might be mounted. This is usually
184 (* Block devices are empty and no filesystems are mounted. *)
186 (* /dev/sda contains a single partition /dev/sda1, which is formatted
187 * as ext2, empty [except for lost+found] and mounted on /.
188 * /dev/sdb and /dev/sdc may have random content.
193 * /dev/sda1 (is a PV):
194 * /dev/VG/LV (size 8MB):
195 * formatted as ext2, empty [except for lost+found], mounted on /
196 * /dev/sdb and /dev/sdc may have random content.
200 (* Sequence of commands for testing. *)
202 and cmd = string list
204 (* Note about long descriptions: When referring to another
205 * action, use the format C<guestfs_other> (ie. the full name of
206 * the C function). This will be replaced as appropriate in other
209 * Apart from that, long descriptions are just perldoc paragraphs.
212 let non_daemon_functions = [
213 ("launch", (RErr, []), -1, [FishAlias "run"; FishAction "launch"],
215 "launch the qemu subprocess",
217 Internally libguestfs is implemented by running a virtual machine
220 You should call this after configuring the handle
221 (eg. adding drives) but before performing any actions.");
223 ("wait_ready", (RErr, []), -1, [NotInFish],
225 "wait until the qemu subprocess launches",
227 Internally libguestfs is implemented by running a virtual machine
230 You should call this after C<guestfs_launch> to wait for the launch
233 ("kill_subprocess", (RErr, []), -1, [],
235 "kill the qemu subprocess",
237 This kills the qemu subprocess. You should never need to call this.");
239 ("add_drive", (RErr, [String "filename"]), -1, [FishAlias "add"],
241 "add an image to examine or modify",
243 This function adds a virtual machine disk image C<filename> to the
244 guest. The first time you call this function, the disk appears as IDE
245 disk 0 (C</dev/sda>) in the guest, the second time as C</dev/sdb>, and
248 You don't necessarily need to be root when using libguestfs. However
249 you obviously do need sufficient permissions to access the filename
250 for whatever operations you want to perform (ie. read access if you
251 just want to read the image or write access if you want to modify the
254 This is equivalent to the qemu parameter C<-drive file=filename>.");
256 ("add_cdrom", (RErr, [String "filename"]), -1, [FishAlias "cdrom"],
258 "add a CD-ROM disk image to examine",
260 This function adds a virtual CD-ROM disk image to the guest.
262 This is equivalent to the qemu parameter C<-cdrom filename>.");
264 ("config", (RErr, [String "qemuparam"; OptString "qemuvalue"]), -1, [],
266 "add qemu parameters",
268 This can be used to add arbitrary qemu command line parameters
269 of the form C<-param value>. Actually it's not quite arbitrary - we
270 prevent you from setting some parameters which would interfere with
271 parameters that we use.
273 The first character of C<param> string must be a C<-> (dash).
275 C<value> can be NULL.");
277 ("set_path", (RErr, [String "path"]), -1, [FishAlias "path"],
279 "set the search path",
281 Set the path that libguestfs searches for kernel and initrd.img.
283 The default is C<$libdir/guestfs> unless overridden by setting
284 C<LIBGUESTFS_PATH> environment variable.
286 The string C<path> is stashed in the libguestfs handle, so the caller
287 must make sure it remains valid for the lifetime of the handle.
289 Setting C<path> to C<NULL> restores the default path.");
291 ("get_path", (RConstString "path", []), -1, [],
293 "get the search path",
295 Return the current search path.
297 This is always non-NULL. If it wasn't set already, then this will
298 return the default path.");
300 ("set_autosync", (RErr, [Bool "autosync"]), -1, [FishAlias "autosync"],
304 If C<autosync> is true, this enables autosync. Libguestfs will make a
305 best effort attempt to run C<guestfs_sync> when the handle is closed
306 (also if the program exits without closing handles).");
308 ("get_autosync", (RBool "autosync", []), -1, [],
312 Get the autosync flag.");
314 ("set_verbose", (RErr, [Bool "verbose"]), -1, [FishAlias "verbose"],
318 If C<verbose> is true, this turns on verbose messages (to C<stderr>).
320 Verbose messages are disabled unless the environment variable
321 C<LIBGUESTFS_DEBUG> is defined and set to C<1>.");
323 ("get_verbose", (RBool "verbose", []), -1, [],
327 This returns the verbose messages flag.")
330 let daemon_functions = [
331 ("mount", (RErr, [String "device"; String "mountpoint"]), 1, [],
332 [InitEmpty, TestOutput (
333 [["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ","];
334 ["mkfs"; "ext2"; "/dev/sda1"];
335 ["mount"; "/dev/sda1"; "/"];
336 ["write_file"; "/new"; "new file contents"; "0"];
337 ["cat"; "/new"]], "new file contents")],
338 "mount a guest disk at a position in the filesystem",
340 Mount a guest disk at a position in the filesystem. Block devices
341 are named C</dev/sda>, C</dev/sdb> and so on, as they were added to
342 the guest. If those block devices contain partitions, they will have
343 the usual names (eg. C</dev/sda1>). Also LVM C</dev/VG/LV>-style
346 The rules are the same as for L<mount(2)>: A filesystem must
347 first be mounted on C</> before others can be mounted. Other
348 filesystems can only be mounted on directories which already
351 The mounted filesystem is writable, if we have sufficient permissions
352 on the underlying device.
354 The filesystem options C<sync> and C<noatime> are set with this
355 call, in order to improve reliability.");
357 ("sync", (RErr, []), 2, [],
358 [ InitEmpty, TestRun [["sync"]]],
359 "sync disks, writes are flushed through to the disk image",
361 This syncs the disk, so that any writes are flushed through to the
362 underlying disk image.
364 You should always call this if you have modified a disk image, before
365 closing the handle.");
367 ("touch", (RErr, [String "path"]), 3, [],
368 [InitBasicFS, TestOutputTrue (
370 ["exists"; "/new"]])],
371 "update file timestamps or create a new file",
373 Touch acts like the L<touch(1)> command. It can be used to
374 update the timestamps on a file, or, if the file does not exist,
375 to create a new zero-length file.");
377 ("cat", (RString "content", [String "path"]), 4, [ProtocolLimitWarning],
378 [InitBasicFS, TestOutput (
379 [["write_file"; "/new"; "new file contents"; "0"];
380 ["cat"; "/new"]], "new file contents")],
381 "list the contents of a file",
383 Return the contents of the file named C<path>.
385 Note that this function cannot correctly handle binary files
386 (specifically, files containing C<\\0> character which is treated
387 as end of string). For those you need to use the C<guestfs_read_file>
388 function which has a more complex interface.");
390 ("ll", (RString "listing", [String "directory"]), 5, [],
391 [], (* XXX Tricky to test because it depends on the exact format
392 * of the 'ls -l' command, which changes between F10 and F11.
394 "list the files in a directory (long format)",
396 List the files in C<directory> (relative to the root directory,
397 there is no cwd) in the format of 'ls -la'.
399 This command is mostly useful for interactive sessions. It
400 is I<not> intended that you try to parse the output string.");
402 ("ls", (RStringList "listing", [String "directory"]), 6, [],
403 [InitBasicFS, TestOutputList (
406 ["touch"; "/newest"];
407 ["ls"; "/"]], ["lost+found"; "new"; "newer"; "newest"])],
408 "list the files in a directory",
410 List the files in C<directory> (relative to the root directory,
411 there is no cwd). The '.' and '..' entries are not returned, but
412 hidden files are shown.
414 This command is mostly useful for interactive sessions. Programs
415 should probably use C<guestfs_readdir> instead.");
417 ("list_devices", (RStringList "devices", []), 7, [],
418 [InitEmpty, TestOutputList (
419 [["list_devices"]], ["/dev/sda"; "/dev/sdb"; "/dev/sdc"])],
420 "list the block devices",
422 List all the block devices.
424 The full block device names are returned, eg. C</dev/sda>");
426 ("list_partitions", (RStringList "partitions", []), 8, [],
427 [InitBasicFS, TestOutputList (
428 [["list_partitions"]], ["/dev/sda1"]);
429 InitEmpty, TestOutputList (
430 [["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ",10 ,20 ,"];
431 ["list_partitions"]], ["/dev/sda1"; "/dev/sda2"; "/dev/sda3"])],
432 "list the partitions",
434 List all the partitions detected on all block devices.
436 The full partition device names are returned, eg. C</dev/sda1>
438 This does not return logical volumes. For that you will need to
439 call C<guestfs_lvs>.");
441 ("pvs", (RStringList "physvols", []), 9, [],
442 [InitBasicFSonLVM, TestOutputList (
443 [["pvs"]], ["/dev/sda1"]);
444 InitEmpty, TestOutputList (
445 [["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ",10 ,20 ,"];
446 ["pvcreate"; "/dev/sda1"];
447 ["pvcreate"; "/dev/sda2"];
448 ["pvcreate"; "/dev/sda3"];
449 ["pvs"]], ["/dev/sda1"; "/dev/sda2"; "/dev/sda3"])],
450 "list the LVM physical volumes (PVs)",
452 List all the physical volumes detected. This is the equivalent
453 of the L<pvs(8)> command.
455 This returns a list of just the device names that contain
456 PVs (eg. C</dev/sda2>).
458 See also C<guestfs_pvs_full>.");
460 ("vgs", (RStringList "volgroups", []), 10, [],
461 [InitBasicFSonLVM, TestOutputList (
463 InitEmpty, TestOutputList (
464 [["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ",10 ,20 ,"];
465 ["pvcreate"; "/dev/sda1"];
466 ["pvcreate"; "/dev/sda2"];
467 ["pvcreate"; "/dev/sda3"];
468 ["vgcreate"; "VG1"; "/dev/sda1 /dev/sda2"];
469 ["vgcreate"; "VG2"; "/dev/sda3"];
470 ["vgs"]], ["VG1"; "VG2"])],
471 "list the LVM volume groups (VGs)",
473 List all the volumes groups detected. This is the equivalent
474 of the L<vgs(8)> command.
476 This returns a list of just the volume group names that were
477 detected (eg. C<VolGroup00>).
479 See also C<guestfs_vgs_full>.");
481 ("lvs", (RStringList "logvols", []), 11, [],
482 [InitBasicFSonLVM, TestOutputList (
483 [["lvs"]], ["/dev/VG/LV"]);
484 InitEmpty, TestOutputList (
485 [["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ",10 ,20 ,"];
486 ["pvcreate"; "/dev/sda1"];
487 ["pvcreate"; "/dev/sda2"];
488 ["pvcreate"; "/dev/sda3"];
489 ["vgcreate"; "VG1"; "/dev/sda1 /dev/sda2"];
490 ["vgcreate"; "VG2"; "/dev/sda3"];
491 ["lvcreate"; "LV1"; "VG1"; "50"];
492 ["lvcreate"; "LV2"; "VG1"; "50"];
493 ["lvcreate"; "LV3"; "VG2"; "50"];
494 ["lvs"]], ["/dev/VG1/LV1"; "/dev/VG1/LV2"; "/dev/VG2/LV3"])],
495 "list the LVM logical volumes (LVs)",
497 List all the logical volumes detected. This is the equivalent
498 of the L<lvs(8)> command.
500 This returns a list of the logical volume device names
501 (eg. C</dev/VolGroup00/LogVol00>).
503 See also C<guestfs_lvs_full>.");
505 ("pvs_full", (RPVList "physvols", []), 12, [],
506 [], (* XXX how to test? *)
507 "list the LVM physical volumes (PVs)",
509 List all the physical volumes detected. This is the equivalent
510 of the L<pvs(8)> command. The \"full\" version includes all fields.");
512 ("vgs_full", (RVGList "volgroups", []), 13, [],
513 [], (* XXX how to test? *)
514 "list the LVM volume groups (VGs)",
516 List all the volumes groups detected. This is the equivalent
517 of the L<vgs(8)> command. The \"full\" version includes all fields.");
519 ("lvs_full", (RLVList "logvols", []), 14, [],
520 [], (* XXX how to test? *)
521 "list the LVM logical volumes (LVs)",
523 List all the logical volumes detected. This is the equivalent
524 of the L<lvs(8)> command. The \"full\" version includes all fields.");
526 ("read_lines", (RStringList "lines", [String "path"]), 15, [],
527 [InitBasicFS, TestOutputList (
528 [["write_file"; "/new"; "line1\r\nline2\nline3"; "0"];
529 ["read_lines"; "/new"]], ["line1"; "line2"; "line3"]);
530 InitBasicFS, TestOutputList (
531 [["write_file"; "/new"; ""; "0"];
532 ["read_lines"; "/new"]], [])],
533 "read file as lines",
535 Return the contents of the file named C<path>.
537 The file contents are returned as a list of lines. Trailing
538 C<LF> and C<CRLF> character sequences are I<not> returned.
540 Note that this function cannot correctly handle binary files
541 (specifically, files containing C<\\0> character which is treated
542 as end of line). For those you need to use the C<guestfs_read_file>
543 function which has a more complex interface.");
545 ("aug_init", (RErr, [String "root"; Int "flags"]), 16, [],
546 [], (* XXX Augeas code needs tests. *)
547 "create a new Augeas handle",
549 Create a new Augeas handle for editing configuration files.
550 If there was any previous Augeas handle associated with this
551 guestfs session, then it is closed.
553 You must call this before using any other C<guestfs_aug_*>
556 C<root> is the filesystem root. C<root> must not be NULL,
559 The flags are the same as the flags defined in
560 E<lt>augeas.hE<gt>, the logical I<or> of the following
565 =item C<AUG_SAVE_BACKUP> = 1
567 Keep the original file with a C<.augsave> extension.
569 =item C<AUG_SAVE_NEWFILE> = 2
571 Save changes into a file with extension C<.augnew>, and
572 do not overwrite original. Overrides C<AUG_SAVE_BACKUP>.
574 =item C<AUG_TYPE_CHECK> = 4
576 Typecheck lenses (can be expensive).
578 =item C<AUG_NO_STDINC> = 8
580 Do not use standard load path for modules.
582 =item C<AUG_SAVE_NOOP> = 16
584 Make save a no-op, just record what would have been changed.
586 =item C<AUG_NO_LOAD> = 32
588 Do not load the tree in C<guestfs_aug_init>.
592 To close the handle, you can call C<guestfs_aug_close>.
594 To find out more about Augeas, see L<http://augeas.net/>.");
596 ("aug_close", (RErr, []), 26, [],
597 [], (* XXX Augeas code needs tests. *)
598 "close the current Augeas handle",
600 Close the current Augeas handle and free up any resources
601 used by it. After calling this, you have to call
602 C<guestfs_aug_init> again before you can use any other
605 ("aug_defvar", (RInt "nrnodes", [String "name"; OptString "expr"]), 17, [],
606 [], (* XXX Augeas code needs tests. *)
607 "define an Augeas variable",
609 Defines an Augeas variable C<name> whose value is the result
610 of evaluating C<expr>. If C<expr> is NULL, then C<name> is
613 On success this returns the number of nodes in C<expr>, or
614 C<0> if C<expr> evaluates to something which is not a nodeset.");
616 ("aug_defnode", (RIntBool ("nrnodes", "created"), [String "name"; String "expr"; String "val"]), 18, [],
617 [], (* XXX Augeas code needs tests. *)
618 "define an Augeas node",
620 Defines a variable C<name> whose value is the result of
623 If C<expr> evaluates to an empty nodeset, a node is created,
624 equivalent to calling C<guestfs_aug_set> C<expr>, C<value>.
625 C<name> will be the nodeset containing that single node.
627 On success this returns a pair containing the
628 number of nodes in the nodeset, and a boolean flag
629 if a node was created.");
631 ("aug_get", (RString "val", [String "path"]), 19, [],
632 [], (* XXX Augeas code needs tests. *)
633 "look up the value of an Augeas path",
635 Look up the value associated with C<path>. If C<path>
636 matches exactly one node, the C<value> is returned.");
638 ("aug_set", (RErr, [String "path"; String "val"]), 20, [],
639 [], (* XXX Augeas code needs tests. *)
640 "set Augeas path to value",
642 Set the value associated with C<path> to C<value>.");
644 ("aug_insert", (RErr, [String "path"; String "label"; Bool "before"]), 21, [],
645 [], (* XXX Augeas code needs tests. *)
646 "insert a sibling Augeas node",
648 Create a new sibling C<label> for C<path>, inserting it into
649 the tree before or after C<path> (depending on the boolean
652 C<path> must match exactly one existing node in the tree, and
653 C<label> must be a label, ie. not contain C</>, C<*> or end
654 with a bracketed index C<[N]>.");
656 ("aug_rm", (RInt "nrnodes", [String "path"]), 22, [],
657 [], (* XXX Augeas code needs tests. *)
658 "remove an Augeas path",
660 Remove C<path> and all of its children.
662 On success this returns the number of entries which were removed.");
664 ("aug_mv", (RErr, [String "src"; String "dest"]), 23, [],
665 [], (* XXX Augeas code needs tests. *)
668 Move the node C<src> to C<dest>. C<src> must match exactly
669 one node. C<dest> is overwritten if it exists.");
671 ("aug_match", (RStringList "matches", [String "path"]), 24, [],
672 [], (* XXX Augeas code needs tests. *)
673 "return Augeas nodes which match path",
675 Returns a list of paths which match the path expression C<path>.
676 The returned paths are sufficiently qualified so that they match
677 exactly one node in the current tree.");
679 ("aug_save", (RErr, []), 25, [],
680 [], (* XXX Augeas code needs tests. *)
681 "write all pending Augeas changes to disk",
683 This writes all pending changes to disk.
685 The flags which were passed to C<guestfs_aug_init> affect exactly
686 how files are saved.");
688 ("aug_load", (RErr, []), 27, [],
689 [], (* XXX Augeas code needs tests. *)
690 "load files into the tree",
692 Load files into the tree.
694 See C<aug_load> in the Augeas documentation for the full gory
697 ("aug_ls", (RStringList "matches", [String "path"]), 28, [],
698 [], (* XXX Augeas code needs tests. *)
699 "list Augeas nodes under a path",
701 This is just a shortcut for listing C<guestfs_aug_match>
702 C<path/*> and sorting the resulting nodes into alphabetical order.");
704 ("rm", (RErr, [String "path"]), 29, [],
705 [InitBasicFS, TestRun
708 InitBasicFS, TestLastFail
710 InitBasicFS, TestLastFail
715 Remove the single file C<path>.");
717 ("rmdir", (RErr, [String "path"]), 30, [],
718 [InitBasicFS, TestRun
721 InitBasicFS, TestLastFail
723 InitBasicFS, TestLastFail
726 "remove a directory",
728 Remove the single directory C<path>.");
730 ("rm_rf", (RErr, [String "path"]), 31, [],
731 [InitBasicFS, TestOutputFalse
733 ["mkdir"; "/new/foo"];
734 ["touch"; "/new/foo/bar"];
736 ["exists"; "/new"]]],
737 "remove a file or directory recursively",
739 Remove the file or directory C<path>, recursively removing the
740 contents if its a directory. This is like the C<rm -rf> shell
743 ("mkdir", (RErr, [String "path"]), 32, [],
744 [InitBasicFS, TestOutputTrue
747 InitBasicFS, TestLastFail
748 [["mkdir"; "/new/foo/bar"]]],
749 "create a directory",
751 Create a directory named C<path>.");
753 ("mkdir_p", (RErr, [String "path"]), 33, [],
754 [InitBasicFS, TestOutputTrue
755 [["mkdir_p"; "/new/foo/bar"];
756 ["is_dir"; "/new/foo/bar"]];
757 InitBasicFS, TestOutputTrue
758 [["mkdir_p"; "/new/foo/bar"];
759 ["is_dir"; "/new/foo"]];
760 InitBasicFS, TestOutputTrue
761 [["mkdir_p"; "/new/foo/bar"];
762 ["is_dir"; "/new"]]],
763 "create a directory and parents",
765 Create a directory named C<path>, creating any parent directories
766 as necessary. This is like the C<mkdir -p> shell command.");
768 ("chmod", (RErr, [Int "mode"; String "path"]), 34, [],
769 [], (* XXX Need stat command to test *)
772 Change the mode (permissions) of C<path> to C<mode>. Only
773 numeric modes are supported.");
775 ("chown", (RErr, [Int "owner"; Int "group"; String "path"]), 35, [],
776 [], (* XXX Need stat command to test *)
777 "change file owner and group",
779 Change the file owner to C<owner> and group to C<group>.
781 Only numeric uid and gid are supported. If you want to use
782 names, you will need to locate and parse the password file
783 yourself (Augeas support makes this relatively easy).");
785 ("exists", (RBool "existsflag", [String "path"]), 36, [],
786 [InitBasicFS, TestOutputTrue (
788 ["exists"; "/new"]]);
789 InitBasicFS, TestOutputTrue (
791 ["exists"; "/new"]])],
792 "test if file or directory exists",
794 This returns C<true> if and only if there is a file, directory
795 (or anything) with the given C<path> name.
797 See also C<guestfs_is_file>, C<guestfs_is_dir>, C<guestfs_stat>.");
799 ("is_file", (RBool "fileflag", [String "path"]), 37, [],
800 [InitBasicFS, TestOutputTrue (
802 ["is_file"; "/new"]]);
803 InitBasicFS, TestOutputFalse (
805 ["is_file"; "/new"]])],
806 "test if file exists",
808 This returns C<true> if and only if there is a file
809 with the given C<path> name. Note that it returns false for
810 other objects like directories.
812 See also C<guestfs_stat>.");
814 ("is_dir", (RBool "dirflag", [String "path"]), 38, [],
815 [InitBasicFS, TestOutputFalse (
817 ["is_dir"; "/new"]]);
818 InitBasicFS, TestOutputTrue (
820 ["is_dir"; "/new"]])],
821 "test if file exists",
823 This returns C<true> if and only if there is a directory
824 with the given C<path> name. Note that it returns false for
825 other objects like files.
827 See also C<guestfs_stat>.");
829 ("pvcreate", (RErr, [String "device"]), 39, [],
830 [InitEmpty, TestOutputList (
831 [["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ",10 ,20 ,"];
832 ["pvcreate"; "/dev/sda1"];
833 ["pvcreate"; "/dev/sda2"];
834 ["pvcreate"; "/dev/sda3"];
835 ["pvs"]], ["/dev/sda1"; "/dev/sda2"; "/dev/sda3"])],
836 "create an LVM physical volume",
838 This creates an LVM physical volume on the named C<device>,
839 where C<device> should usually be a partition name such
842 ("vgcreate", (RErr, [String "volgroup"; StringList "physvols"]), 40, [],
843 [InitEmpty, TestOutputList (
844 [["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ",10 ,20 ,"];
845 ["pvcreate"; "/dev/sda1"];
846 ["pvcreate"; "/dev/sda2"];
847 ["pvcreate"; "/dev/sda3"];
848 ["vgcreate"; "VG1"; "/dev/sda1 /dev/sda2"];
849 ["vgcreate"; "VG2"; "/dev/sda3"];
850 ["vgs"]], ["VG1"; "VG2"])],
851 "create an LVM volume group",
853 This creates an LVM volume group called C<volgroup>
854 from the non-empty list of physical volumes C<physvols>.");
856 ("lvcreate", (RErr, [String "logvol"; String "volgroup"; Int "mbytes"]), 41, [],
857 [InitEmpty, TestOutputList (
858 [["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ",10 ,20 ,"];
859 ["pvcreate"; "/dev/sda1"];
860 ["pvcreate"; "/dev/sda2"];
861 ["pvcreate"; "/dev/sda3"];
862 ["vgcreate"; "VG1"; "/dev/sda1 /dev/sda2"];
863 ["vgcreate"; "VG2"; "/dev/sda3"];
864 ["lvcreate"; "LV1"; "VG1"; "50"];
865 ["lvcreate"; "LV2"; "VG1"; "50"];
866 ["lvcreate"; "LV3"; "VG2"; "50"];
867 ["lvcreate"; "LV4"; "VG2"; "50"];
868 ["lvcreate"; "LV5"; "VG2"; "50"];
870 ["/dev/VG1/LV1"; "/dev/VG1/LV2";
871 "/dev/VG2/LV3"; "/dev/VG2/LV4"; "/dev/VG2/LV5"])],
872 "create an LVM volume group",
874 This creates an LVM volume group called C<logvol>
875 on the volume group C<volgroup>, with C<size> megabytes.");
877 ("mkfs", (RErr, [String "fstype"; String "device"]), 42, [],
878 [InitEmpty, TestOutput (
879 [["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ","];
880 ["mkfs"; "ext2"; "/dev/sda1"];
881 ["mount"; "/dev/sda1"; "/"];
882 ["write_file"; "/new"; "new file contents"; "0"];
883 ["cat"; "/new"]], "new file contents")],
886 This creates a filesystem on C<device> (usually a partition
887 of LVM logical volume). The filesystem type is C<fstype>, for
890 ("sfdisk", (RErr, [String "device";
891 Int "cyls"; Int "heads"; Int "sectors";
892 StringList "lines"]), 43, [DangerWillRobinson],
894 "create partitions on a block device",
896 This is a direct interface to the L<sfdisk(8)> program for creating
897 partitions on block devices.
899 C<device> should be a block device, for example C</dev/sda>.
901 C<cyls>, C<heads> and C<sectors> are the number of cylinders, heads
902 and sectors on the device, which are passed directly to sfdisk as
903 the I<-C>, I<-H> and I<-S> parameters. If you pass C<0> for any
904 of these, then the corresponding parameter is omitted. Usually for
905 'large' disks, you can just pass C<0> for these, but for small
906 (floppy-sized) disks, sfdisk (or rather, the kernel) cannot work
907 out the right geometry and you will need to tell it.
909 C<lines> is a list of lines that we feed to C<sfdisk>. For more
910 information refer to the L<sfdisk(8)> manpage.
912 To create a single partition occupying the whole disk, you would
913 pass C<lines> as a single element list, when the single element being
914 the string C<,> (comma).");
916 ("write_file", (RErr, [String "path"; String "content"; Int "size"]), 44, [ProtocolLimitWarning],
917 [InitBasicFS, TestOutput (
918 [["write_file"; "/new"; "new file contents"; "0"];
919 ["cat"; "/new"]], "new file contents");
920 InitBasicFS, TestOutput (
921 [["write_file"; "/new"; "\nnew file contents\n"; "0"];
922 ["cat"; "/new"]], "\nnew file contents\n");
923 InitBasicFS, TestOutput (
924 [["write_file"; "/new"; "\n\n"; "0"];
925 ["cat"; "/new"]], "\n\n");
926 InitBasicFS, TestOutput (
927 [["write_file"; "/new"; ""; "0"];
928 ["cat"; "/new"]], "");
929 InitBasicFS, TestOutput (
930 [["write_file"; "/new"; "\n\n\n"; "0"];
931 ["cat"; "/new"]], "\n\n\n");
932 InitBasicFS, TestOutput (
933 [["write_file"; "/new"; "\n"; "0"];
934 ["cat"; "/new"]], "\n")],
937 This call creates a file called C<path>. The contents of the
938 file is the string C<content> (which can contain any 8 bit data),
941 As a special case, if C<size> is C<0>
942 then the length is calculated using C<strlen> (so in this case
943 the content cannot contain embedded ASCII NULs).");
945 ("umount", (RErr, [String "pathordevice"]), 45, [FishAlias "unmount"],
946 [InitEmpty, TestOutputList (
947 [["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ","];
948 ["mkfs"; "ext2"; "/dev/sda1"];
949 ["mount"; "/dev/sda1"; "/"];
950 ["mounts"]], ["/dev/sda1"]);
951 InitEmpty, TestOutputList (
952 [["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ","];
953 ["mkfs"; "ext2"; "/dev/sda1"];
954 ["mount"; "/dev/sda1"; "/"];
957 "unmount a filesystem",
959 This unmounts the given filesystem. The filesystem may be
960 specified either by its mountpoint (path) or the device which
961 contains the filesystem.");
963 ("mounts", (RStringList "devices", []), 46, [],
964 [InitBasicFS, TestOutputList (
965 [["mounts"]], ["/dev/sda1"])],
966 "show mounted filesystems",
968 This returns the list of currently mounted filesystems. It returns
969 the list of devices (eg. C</dev/sda1>, C</dev/VG/LV>).
971 Some internal mounts are not shown.");
973 ("umount_all", (RErr, []), 47, [FishAlias "unmount-all"],
974 [InitBasicFS, TestOutputList (
977 "unmount all filesystems",
979 This unmounts all mounted filesystems.
981 Some internal mounts are not unmounted by this call.");
983 ("lvm_remove_all", (RErr, []), 48, [DangerWillRobinson],
985 "remove all LVM LVs, VGs and PVs",
987 This command removes all LVM logical volumes, volume groups
988 and physical volumes.");
990 ("file", (RString "description", [String "path"]), 49, [],
991 [InitBasicFS, TestOutput (
993 ["file"; "/new"]], "empty");
994 InitBasicFS, TestOutput (
995 [["write_file"; "/new"; "some content\n"; "0"];
996 ["file"; "/new"]], "ASCII text");
997 InitBasicFS, TestLastFail (
998 [["file"; "/nofile"]])],
999 "determine file type",
1001 This call uses the standard L<file(1)> command to determine
1002 the type or contents of the file. This also works on devices,
1003 for example to find out whether a partition contains a filesystem.
1005 The exact command which runs is C<file -bsL path>. Note in
1006 particular that the filename is not prepended to the output
1007 (the C<-b> option).");
1009 ("command", (RString "output", [StringList "arguments"]), 50, [],
1010 [], (* XXX how to test? *)
1011 "run a command from the guest filesystem",
1013 This call runs a command from the guest filesystem. The
1014 filesystem must be mounted, and must contain a compatible
1015 operating system (ie. something Linux, with the same
1016 or compatible processor architecture).
1018 The single parameter is an argv-style list of arguments.
1019 The first element is the name of the program to run.
1020 Subsequent elements are parameters. The list must be
1021 non-empty (ie. must contain a program name).
1023 The C<$PATH> environment variable will contain at least
1024 C</usr/bin> and C</bin>. If you require a program from
1025 another location, you should provide the full path in the
1028 Shared libraries and data files required by the program
1029 must be available on filesystems which are mounted in the
1030 correct places. It is the caller's responsibility to ensure
1031 all filesystems that are needed are mounted at the right
1034 ("command_lines", (RStringList "lines", [StringList "arguments"]), 51, [],
1035 [], (* XXX how to test? *)
1036 "run a command, returning lines",
1038 This is the same as C<guestfs_command>, but splits the
1039 result into a list of lines.");
1041 ("stat", (RStat "statbuf", [String "path"]), 52, [],
1042 [InitBasicFS, TestOutputStruct (
1044 ["stat"; "/new"]], [CompareWithInt ("size", 0)])],
1045 "get file information",
1047 Returns file information for the given C<path>.
1049 This is the same as the C<stat(2)> system call.");
1051 ("lstat", (RStat "statbuf", [String "path"]), 53, [],
1052 [InitBasicFS, TestOutputStruct (
1054 ["lstat"; "/new"]], [CompareWithInt ("size", 0)])],
1055 "get file information for a symbolic link",
1057 Returns file information for the given C<path>.
1059 This is the same as C<guestfs_stat> except that if C<path>
1060 is a symbolic link, then the link is stat-ed, not the file it
1063 This is the same as the C<lstat(2)> system call.");
1065 ("statvfs", (RStatVFS "statbuf", [String "path"]), 54, [],
1066 [InitBasicFS, TestOutputStruct (
1067 [["statvfs"; "/"]], [CompareWithInt ("bfree", 487702);
1068 CompareWithInt ("blocks", 490020);
1069 CompareWithInt ("bsize", 1024)])],
1070 "get file system statistics",
1072 Returns file system statistics for any mounted file system.
1073 C<path> should be a file or directory in the mounted file system
1074 (typically it is the mount point itself, but it doesn't need to be).
1076 This is the same as the C<statvfs(2)> system call.");
1078 ("tune2fs_l", (RHashtable "superblock", [String "device"]), 55, [],
1080 "get ext2/ext3 superblock details",
1082 This returns the contents of the ext2 or ext3 filesystem superblock
1085 It is the same as running C<tune2fs -l device>. See L<tune2fs(8)>
1086 manpage for more details. The list of fields returned isn't
1087 clearly defined, and depends on both the version of C<tune2fs>
1088 that libguestfs was built against, and the filesystem itself.");
1090 ("blockdev_setro", (RErr, [String "device"]), 56, [],
1091 [InitEmpty, TestOutputTrue (
1092 [["blockdev_setro"; "/dev/sda"];
1093 ["blockdev_getro"; "/dev/sda"]])],
1094 "set block device to read-only",
1096 Sets the block device named C<device> to read-only.
1098 This uses the L<blockdev(8)> command.");
1100 ("blockdev_setrw", (RErr, [String "device"]), 57, [],
1101 [InitEmpty, TestOutputFalse (
1102 [["blockdev_setrw"; "/dev/sda"];
1103 ["blockdev_getro"; "/dev/sda"]])],
1104 "set block device to read-write",
1106 Sets the block device named C<device> to read-write.
1108 This uses the L<blockdev(8)> command.");
1110 ("blockdev_getro", (RBool "ro", [String "device"]), 58, [],
1111 [InitEmpty, TestOutputTrue (
1112 [["blockdev_setro"; "/dev/sda"];
1113 ["blockdev_getro"; "/dev/sda"]])],
1114 "is block device set to read-only",
1116 Returns a boolean indicating if the block device is read-only
1117 (true if read-only, false if not).
1119 This uses the L<blockdev(8)> command.");
1121 ("blockdev_getss", (RInt "sectorsize", [String "device"]), 59, [],
1122 [InitEmpty, TestOutputInt (
1123 [["blockdev_getss"; "/dev/sda"]], 512)],
1124 "get sectorsize of block device",
1126 This returns the size of sectors on a block device.
1127 Usually 512, but can be larger for modern devices.
1129 (Note, this is not the size in sectors, use C<guestfs_blockdev_getsz>
1132 This uses the L<blockdev(8)> command.");
1134 ("blockdev_getbsz", (RInt "blocksize", [String "device"]), 60, [],
1135 [InitEmpty, TestOutputInt (
1136 [["blockdev_getbsz"; "/dev/sda"]], 4096)],
1137 "get blocksize of block device",
1139 This returns the block size of a device.
1141 (Note this is different from both I<size in blocks> and
1142 I<filesystem block size>).
1144 This uses the L<blockdev(8)> command.");
1146 ("blockdev_setbsz", (RErr, [String "device"; Int "blocksize"]), 61, [],
1148 "set blocksize of block device",
1150 This sets the block size of a device.
1152 (Note this is different from both I<size in blocks> and
1153 I<filesystem block size>).
1155 This uses the L<blockdev(8)> command.");
1157 ("blockdev_getsz", (RInt64 "sizeinsectors", [String "device"]), 62, [],
1158 [InitEmpty, TestOutputInt (
1159 [["blockdev_getsz"; "/dev/sda"]], 1024000)],
1160 "get total size of device in 512-byte sectors",
1162 This returns the size of the device in units of 512-byte sectors
1163 (even if the sectorsize isn't 512 bytes ... weird).
1165 See also C<guestfs_blockdev_getss> for the real sector size of
1166 the device, and C<guestfs_blockdev_getsize64> for the more
1167 useful I<size in bytes>.
1169 This uses the L<blockdev(8)> command.");
1171 ("blockdev_getsize64", (RInt64 "sizeinbytes", [String "device"]), 63, [],
1172 [InitEmpty, TestOutputInt (
1173 [["blockdev_getsize64"; "/dev/sda"]], 524288000)],
1174 "get total size of device in bytes",
1176 This returns the size of the device in bytes.
1178 See also C<guestfs_blockdev_getsz>.
1180 This uses the L<blockdev(8)> command.");
1182 ("blockdev_flushbufs", (RErr, [String "device"]), 64, [],
1184 [["blockdev_flushbufs"; "/dev/sda"]]],
1185 "flush device buffers",
1187 This tells the kernel to flush internal buffers associated
1190 This uses the L<blockdev(8)> command.");
1192 ("blockdev_rereadpt", (RErr, [String "device"]), 65, [],
1194 [["blockdev_rereadpt"; "/dev/sda"]]],
1195 "reread partition table",
1197 Reread the partition table on C<device>.
1199 This uses the L<blockdev(8)> command.");
1203 let all_functions = non_daemon_functions @ daemon_functions
1205 (* In some places we want the functions to be displayed sorted
1206 * alphabetically, so this is useful:
1208 let all_functions_sorted =
1209 List.sort (fun (n1,_,_,_,_,_,_) (n2,_,_,_,_,_,_) ->
1210 compare n1 n2) all_functions
1212 (* Column names and types from LVM PVs/VGs/LVs. *)
1221 "pv_attr", `String (* XXX *);
1222 "pv_pe_count", `Int;
1223 "pv_pe_alloc_count", `Int;
1226 "pv_mda_count", `Int;
1227 "pv_mda_free", `Bytes;
1228 (* Not in Fedora 10:
1229 "pv_mda_size", `Bytes;
1236 "vg_attr", `String (* XXX *);
1239 "vg_sysid", `String;
1240 "vg_extent_size", `Bytes;
1241 "vg_extent_count", `Int;
1242 "vg_free_count", `Int;
1250 "vg_mda_count", `Int;
1251 "vg_mda_free", `Bytes;
1252 (* Not in Fedora 10:
1253 "vg_mda_size", `Bytes;
1259 "lv_attr", `String (* XXX *);
1262 "lv_kernel_major", `Int;
1263 "lv_kernel_minor", `Int;
1267 "snap_percent", `OptPercent;
1268 "copy_percent", `OptPercent;
1271 "mirror_log", `String;
1275 (* Column names and types from stat structures.
1276 * NB. Can't use things like 'st_atime' because glibc header files
1277 * define some of these as macros. Ugh.
1294 let statvfs_cols = [
1308 (* Useful functions.
1309 * Note we don't want to use any external OCaml libraries which
1310 * makes this a bit harder than it should be.
1312 let failwithf fs = ksprintf failwith fs
1314 let replace_char s c1 c2 =
1315 let s2 = String.copy s in
1316 let r = ref false in
1317 for i = 0 to String.length s2 - 1 do
1318 if String.unsafe_get s2 i = c1 then (
1319 String.unsafe_set s2 i c2;
1323 if not !r then s else s2
1327 (* || c = '\f' *) || c = '\n' || c = '\r' || c = '\t' (* || c = '\v' *)
1329 let triml ?(test = isspace) str =
1331 let n = ref (String.length str) in
1332 while !n > 0 && test str.[!i]; do
1337 else String.sub str !i !n
1339 let trimr ?(test = isspace) str =
1340 let n = ref (String.length str) in
1341 while !n > 0 && test str.[!n-1]; do
1344 if !n = String.length str then str
1345 else String.sub str 0 !n
1347 let trim ?(test = isspace) str =
1348 trimr ~test (triml ~test str)
1350 let rec find s sub =
1351 let len = String.length s in
1352 let sublen = String.length sub in
1354 if i <= len-sublen then (
1356 if j < sublen then (
1357 if s.[i+j] = sub.[j] then loop2 (j+1)
1363 if r = -1 then loop (i+1) else r
1369 let rec replace_str s s1 s2 =
1370 let len = String.length s in
1371 let sublen = String.length s1 in
1372 let i = find s s1 in
1375 let s' = String.sub s 0 i in
1376 let s'' = String.sub s (i+sublen) (len-i-sublen) in
1377 s' ^ s2 ^ replace_str s'' s1 s2
1380 let rec string_split sep str =
1381 let len = String.length str in
1382 let seplen = String.length sep in
1383 let i = find str sep in
1384 if i = -1 then [str]
1386 let s' = String.sub str 0 i in
1387 let s'' = String.sub str (i+seplen) (len-i-seplen) in
1388 s' :: string_split sep s''
1391 let rec find_map f = function
1392 | [] -> raise Not_found
1396 | None -> find_map f xs
1399 let rec loop i = function
1401 | x :: xs -> f i x; loop (i+1) xs
1406 let rec loop i = function
1408 | x :: xs -> let r = f i x in r :: loop (i+1) xs
1412 let name_of_argt = function
1413 | String n | OptString n | StringList n | Bool n | Int n -> n
1415 let seq_of_test = function
1416 | TestRun s | TestOutput (s, _) | TestOutputList (s, _)
1417 | TestOutputInt (s, _) | TestOutputTrue s | TestOutputFalse s
1418 | TestOutputLength (s, _) | TestOutputStruct (s, _)
1419 | TestLastFail s -> s
1421 (* Check function names etc. for consistency. *)
1422 let check_functions () =
1423 let contains_uppercase str =
1424 let len = String.length str in
1426 if i >= len then false
1429 if c >= 'A' && c <= 'Z' then true
1436 (* Check function names. *)
1438 fun (name, _, _, _, _, _, _) ->
1439 if String.length name >= 7 && String.sub name 0 7 = "guestfs" then
1440 failwithf "function name %s does not need 'guestfs' prefix" name;
1441 if contains_uppercase name then
1442 failwithf "function name %s should not contain uppercase chars" name;
1443 if String.contains name '-' then
1444 failwithf "function name %s should not contain '-', use '_' instead."
1448 (* Check function parameter/return names. *)
1450 fun (name, style, _, _, _, _, _) ->
1451 let check_arg_ret_name n =
1452 if contains_uppercase n then
1453 failwithf "%s param/ret %s should not contain uppercase chars"
1455 if String.contains n '-' || String.contains n '_' then
1456 failwithf "%s param/ret %s should not contain '-' or '_'"
1459 failwithf "%s has a param/ret called 'value', which causes conflicts in the OCaml bindings, use something like 'val' or a more descriptive name" n;
1460 if n = "argv" || n = "args" then
1461 failwithf "%s has a param/ret called 'argv' or 'args', which will cause some conflicts in the generated code" n
1464 (match fst style with
1466 | RInt n | RInt64 n | RBool n | RConstString n | RString n
1467 | RStringList n | RPVList n | RVGList n | RLVList n
1468 | RStat n | RStatVFS n
1470 check_arg_ret_name n
1472 check_arg_ret_name n;
1473 check_arg_ret_name m
1475 List.iter (fun arg -> check_arg_ret_name (name_of_argt arg)) (snd style)
1478 (* Check short descriptions. *)
1480 fun (name, _, _, _, _, shortdesc, _) ->
1481 if shortdesc.[0] <> Char.lowercase shortdesc.[0] then
1482 failwithf "short description of %s should begin with lowercase." name;
1483 let c = shortdesc.[String.length shortdesc-1] in
1484 if c = '\n' || c = '.' then
1485 failwithf "short description of %s should not end with . or \\n." name
1488 (* Check long dscriptions. *)
1490 fun (name, _, _, _, _, _, longdesc) ->
1491 if longdesc.[String.length longdesc-1] = '\n' then
1492 failwithf "long description of %s should not end with \\n." name
1495 (* Check proc_nrs. *)
1497 fun (name, _, proc_nr, _, _, _, _) ->
1498 if proc_nr <= 0 then
1499 failwithf "daemon function %s should have proc_nr > 0" name
1503 fun (name, _, proc_nr, _, _, _, _) ->
1504 if proc_nr <> -1 then
1505 failwithf "non-daemon function %s should have proc_nr -1" name
1506 ) non_daemon_functions;
1509 List.map (fun (name, _, proc_nr, _, _, _, _) -> name, proc_nr)
1512 List.sort (fun (_,nr1) (_,nr2) -> compare nr1 nr2) proc_nrs in
1513 let rec loop = function
1516 | (name1,nr1) :: ((name2,nr2) :: _ as rest) when nr1 < nr2 ->
1518 | (name1,nr1) :: (name2,nr2) :: _ ->
1519 failwithf "%s and %s have conflicting procedure numbers (%d, %d)"
1527 (* Ignore functions that have no tests. We generate a
1528 * warning when the user does 'make check' instead.
1530 | name, _, _, _, [], _, _ -> ()
1531 | name, _, _, _, tests, _, _ ->
1535 match seq_of_test test with
1537 failwithf "%s has a test containing an empty sequence" name
1538 | cmds -> List.map List.hd cmds
1540 let funcs = List.flatten funcs in
1542 let tested = List.mem name funcs in
1545 failwithf "function %s has tests but does not test itself" name
1548 (* 'pr' prints to the current output file. *)
1549 let chan = ref stdout
1550 let pr fs = ksprintf (output_string !chan) fs
1552 (* Generate a header block in a number of standard styles. *)
1553 type comment_style = CStyle | HashStyle | OCamlStyle
1554 type license = GPLv2 | LGPLv2
1556 let generate_header comment license =
1557 let c = match comment with
1558 | CStyle -> pr "/* "; " *"
1559 | HashStyle -> pr "# "; "#"
1560 | OCamlStyle -> pr "(* "; " *" in
1561 pr "libguestfs generated file\n";
1562 pr "%s WARNING: THIS FILE IS GENERATED BY 'src/generator.ml'.\n" c;
1563 pr "%s ANY CHANGES YOU MAKE TO THIS FILE WILL BE LOST.\n" c;
1565 pr "%s Copyright (C) 2009 Red Hat Inc.\n" c;
1569 pr "%s This program is free software; you can redistribute it and/or modify\n" c;
1570 pr "%s it under the terms of the GNU General Public License as published by\n" c;
1571 pr "%s the Free Software Foundation; either version 2 of the License, or\n" c;
1572 pr "%s (at your option) any later version.\n" c;
1574 pr "%s This program is distributed in the hope that it will be useful,\n" c;
1575 pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
1576 pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the\n" c;
1577 pr "%s GNU General Public License for more details.\n" c;
1579 pr "%s You should have received a copy of the GNU General Public License along\n" c;
1580 pr "%s with this program; if not, write to the Free Software Foundation, Inc.,\n" c;
1581 pr "%s 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n" c;
1584 pr "%s This library is free software; you can redistribute it and/or\n" c;
1585 pr "%s modify it under the terms of the GNU Lesser General Public\n" c;
1586 pr "%s License as published by the Free Software Foundation; either\n" c;
1587 pr "%s version 2 of the License, or (at your option) any later version.\n" c;
1589 pr "%s This library is distributed in the hope that it will be useful,\n" c;
1590 pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
1591 pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU\n" c;
1592 pr "%s Lesser General Public License for more details.\n" c;
1594 pr "%s You should have received a copy of the GNU Lesser General Public\n" c;
1595 pr "%s License along with this library; if not, write to the Free Software\n" c;
1596 pr "%s Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA\n" c;
1599 | CStyle -> pr " */\n"
1601 | OCamlStyle -> pr " *)\n"
1605 (* Start of main code generation functions below this line. *)
1607 (* Generate the pod documentation for the C API. *)
1608 let rec generate_actions_pod () =
1610 fun (shortname, style, _, flags, _, _, longdesc) ->
1611 let name = "guestfs_" ^ shortname in
1612 pr "=head2 %s\n\n" name;
1614 generate_prototype ~extern:false ~handle:"handle" name style;
1616 pr "%s\n\n" longdesc;
1617 (match fst style with
1619 pr "This function returns 0 on success or -1 on error.\n\n"
1621 pr "On error this function returns -1.\n\n"
1623 pr "On error this function returns -1.\n\n"
1625 pr "This function returns a C truth value on success or -1 on error.\n\n"
1627 pr "This function returns a string, or NULL on error.
1628 The string is owned by the guest handle and must I<not> be freed.\n\n"
1630 pr "This function returns a string, or NULL on error.
1631 I<The caller must free the returned string after use>.\n\n"
1633 pr "This function returns a NULL-terminated array of strings
1634 (like L<environ(3)>), or NULL if there was an error.
1635 I<The caller must free the strings and the array after use>.\n\n"
1637 pr "This function returns a C<struct guestfs_int_bool *>,
1638 or NULL if there was an error.
1639 I<The caller must call C<guestfs_free_int_bool> after use>.\n\n"
1641 pr "This function returns a C<struct guestfs_lvm_pv_list *>
1642 (see E<lt>guestfs-structs.hE<gt>),
1643 or NULL if there was an error.
1644 I<The caller must call C<guestfs_free_lvm_pv_list> after use>.\n\n"
1646 pr "This function returns a C<struct guestfs_lvm_vg_list *>
1647 (see E<lt>guestfs-structs.hE<gt>),
1648 or NULL if there was an error.
1649 I<The caller must call C<guestfs_free_lvm_vg_list> after use>.\n\n"
1651 pr "This function returns a C<struct guestfs_lvm_lv_list *>
1652 (see E<lt>guestfs-structs.hE<gt>),
1653 or NULL if there was an error.
1654 I<The caller must call C<guestfs_free_lvm_lv_list> after use>.\n\n"
1656 pr "This function returns a C<struct guestfs_stat *>
1657 (see L<stat(2)> and E<lt>guestfs-structs.hE<gt>),
1658 or NULL if there was an error.
1659 I<The caller must call C<free> after use>.\n\n"
1661 pr "This function returns a C<struct guestfs_statvfs *>
1662 (see L<statvfs(2)> and E<lt>guestfs-structs.hE<gt>),
1663 or NULL if there was an error.
1664 I<The caller must call C<free> after use>.\n\n"
1666 pr "This function returns a NULL-terminated array of
1667 strings, or NULL if there was an error.
1668 The array of strings will always have length C<2n+1>, where
1669 C<n> keys and values alternate, followed by the trailing NULL entry.
1670 I<The caller must free the strings and the array after use>.\n\n"
1672 if List.mem ProtocolLimitWarning flags then
1673 pr "%s\n\n" protocol_limit_warning;
1674 if List.mem DangerWillRobinson flags then
1675 pr "%s\n\n" danger_will_robinson;
1676 ) all_functions_sorted
1678 and generate_structs_pod () =
1679 (* LVM structs documentation. *)
1682 pr "=head2 guestfs_lvm_%s\n" typ;
1684 pr " struct guestfs_lvm_%s {\n" typ;
1687 | name, `String -> pr " char *%s;\n" name
1689 pr " /* The next field is NOT nul-terminated, be careful when printing it: */\n";
1690 pr " char %s[32];\n" name
1691 | name, `Bytes -> pr " uint64_t %s;\n" name
1692 | name, `Int -> pr " int64_t %s;\n" name
1693 | name, `OptPercent ->
1694 pr " /* The next field is [0..100] or -1 meaning 'not present': */\n";
1695 pr " float %s;\n" name
1698 pr " struct guestfs_lvm_%s_list {\n" typ;
1699 pr " uint32_t len; /* Number of elements in list. */\n";
1700 pr " struct guestfs_lvm_%s *val; /* Elements. */\n" typ;
1703 pr " void guestfs_free_lvm_%s_list (struct guestfs_free_lvm_%s_list *);\n"
1706 ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols]
1708 (* Generate the protocol (XDR) file, 'guestfs_protocol.x' and
1709 * indirectly 'guestfs_protocol.h' and 'guestfs_protocol.c'.
1711 * We have to use an underscore instead of a dash because otherwise
1712 * rpcgen generates incorrect code.
1714 * This header is NOT exported to clients, but see also generate_structs_h.
1716 and generate_xdr () =
1717 generate_header CStyle LGPLv2;
1719 (* This has to be defined to get around a limitation in Sun's rpcgen. *)
1720 pr "typedef string str<>;\n";
1723 (* LVM internal structures. *)
1727 pr "struct guestfs_lvm_int_%s {\n" typ;
1729 | name, `String -> pr " string %s<>;\n" name
1730 | name, `UUID -> pr " opaque %s[32];\n" name
1731 | name, `Bytes -> pr " hyper %s;\n" name
1732 | name, `Int -> pr " hyper %s;\n" name
1733 | name, `OptPercent -> pr " float %s;\n" name
1737 pr "typedef struct guestfs_lvm_int_%s guestfs_lvm_int_%s_list<>;\n" typ typ;
1739 ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols];
1741 (* Stat internal structures. *)
1745 pr "struct guestfs_int_%s {\n" typ;
1747 | name, `Int -> pr " hyper %s;\n" name
1751 ) ["stat", stat_cols; "statvfs", statvfs_cols];
1754 fun (shortname, style, _, _, _, _, _) ->
1755 let name = "guestfs_" ^ shortname in
1757 (match snd style with
1760 pr "struct %s_args {\n" name;
1763 | String n -> pr " string %s<>;\n" n
1764 | OptString n -> pr " str *%s;\n" n
1765 | StringList n -> pr " str %s<>;\n" n
1766 | Bool n -> pr " bool %s;\n" n
1767 | Int n -> pr " int %s;\n" n
1771 (match fst style with
1774 pr "struct %s_ret {\n" name;
1778 pr "struct %s_ret {\n" name;
1779 pr " hyper %s;\n" n;
1782 pr "struct %s_ret {\n" name;
1786 failwithf "RConstString cannot be returned from a daemon function"
1788 pr "struct %s_ret {\n" name;
1789 pr " string %s<>;\n" n;
1792 pr "struct %s_ret {\n" name;
1793 pr " str %s<>;\n" n;
1796 pr "struct %s_ret {\n" name;
1801 pr "struct %s_ret {\n" name;
1802 pr " guestfs_lvm_int_pv_list %s;\n" n;
1805 pr "struct %s_ret {\n" name;
1806 pr " guestfs_lvm_int_vg_list %s;\n" n;
1809 pr "struct %s_ret {\n" name;
1810 pr " guestfs_lvm_int_lv_list %s;\n" n;
1813 pr "struct %s_ret {\n" name;
1814 pr " guestfs_int_stat %s;\n" n;
1817 pr "struct %s_ret {\n" name;
1818 pr " guestfs_int_statvfs %s;\n" n;
1821 pr "struct %s_ret {\n" name;
1822 pr " str %s<>;\n" n;
1827 (* Table of procedure numbers. *)
1828 pr "enum guestfs_procedure {\n";
1830 fun (shortname, _, proc_nr, _, _, _, _) ->
1831 pr " GUESTFS_PROC_%s = %d,\n" (String.uppercase shortname) proc_nr
1833 pr " GUESTFS_PROC_dummy\n"; (* so we don't have a "hanging comma" *)
1837 (* Having to choose a maximum message size is annoying for several
1838 * reasons (it limits what we can do in the API), but it (a) makes
1839 * the protocol a lot simpler, and (b) provides a bound on the size
1840 * of the daemon which operates in limited memory space. For large
1841 * file transfers you should use FTP.
1843 pr "const GUESTFS_MESSAGE_MAX = %d;\n" (4 * 1024 * 1024);
1846 (* Message header, etc. *)
1848 const GUESTFS_PROGRAM = 0x2000F5F5;
1849 const GUESTFS_PROTOCOL_VERSION = 1;
1851 enum guestfs_message_direction {
1852 GUESTFS_DIRECTION_CALL = 0, /* client -> daemon */
1853 GUESTFS_DIRECTION_REPLY = 1 /* daemon -> client */
1856 enum guestfs_message_status {
1857 GUESTFS_STATUS_OK = 0,
1858 GUESTFS_STATUS_ERROR = 1
1861 const GUESTFS_ERROR_LEN = 256;
1863 struct guestfs_message_error {
1864 string error<GUESTFS_ERROR_LEN>; /* error message */
1867 struct guestfs_message_header {
1868 unsigned prog; /* GUESTFS_PROGRAM */
1869 unsigned vers; /* GUESTFS_PROTOCOL_VERSION */
1870 guestfs_procedure proc; /* GUESTFS_PROC_x */
1871 guestfs_message_direction direction;
1872 unsigned serial; /* message serial number */
1873 guestfs_message_status status;
1877 (* Generate the guestfs-structs.h file. *)
1878 and generate_structs_h () =
1879 generate_header CStyle LGPLv2;
1881 (* This is a public exported header file containing various
1882 * structures. The structures are carefully written to have
1883 * exactly the same in-memory format as the XDR structures that
1884 * we use on the wire to the daemon. The reason for creating
1885 * copies of these structures here is just so we don't have to
1886 * export the whole of guestfs_protocol.h (which includes much
1887 * unrelated and XDR-dependent stuff that we don't want to be
1888 * public, or required by clients).
1890 * To reiterate, we will pass these structures to and from the
1891 * client with a simple assignment or memcpy, so the format
1892 * must be identical to what rpcgen / the RFC defines.
1895 (* guestfs_int_bool structure. *)
1896 pr "struct guestfs_int_bool {\n";
1902 (* LVM public structures. *)
1906 pr "struct guestfs_lvm_%s {\n" typ;
1909 | name, `String -> pr " char *%s;\n" name
1910 | name, `UUID -> pr " char %s[32]; /* this is NOT nul-terminated, be careful when printing */\n" name
1911 | name, `Bytes -> pr " uint64_t %s;\n" name
1912 | name, `Int -> pr " int64_t %s;\n" name
1913 | name, `OptPercent -> pr " float %s; /* [0..100] or -1 */\n" name
1917 pr "struct guestfs_lvm_%s_list {\n" typ;
1918 pr " uint32_t len;\n";
1919 pr " struct guestfs_lvm_%s *val;\n" typ;
1922 ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols];
1924 (* Stat structures. *)
1928 pr "struct guestfs_%s {\n" typ;
1931 | name, `Int -> pr " int64_t %s;\n" name
1935 ) ["stat", stat_cols; "statvfs", statvfs_cols]
1937 (* Generate the guestfs-actions.h file. *)
1938 and generate_actions_h () =
1939 generate_header CStyle LGPLv2;
1941 fun (shortname, style, _, _, _, _, _) ->
1942 let name = "guestfs_" ^ shortname in
1943 generate_prototype ~single_line:true ~newline:true ~handle:"handle"
1947 (* Generate the client-side dispatch stubs. *)
1948 and generate_client_actions () =
1949 generate_header CStyle LGPLv2;
1951 (* Client-side stubs for each function. *)
1953 fun (shortname, style, _, _, _, _, _) ->
1954 let name = "guestfs_" ^ shortname in
1956 (* Generate the return value struct. *)
1957 pr "struct %s_rv {\n" shortname;
1958 pr " int cb_done; /* flag to indicate callback was called */\n";
1959 pr " struct guestfs_message_header hdr;\n";
1960 pr " struct guestfs_message_error err;\n";
1961 (match fst style with
1964 failwithf "RConstString cannot be returned from a daemon function"
1966 | RBool _ | RString _ | RStringList _
1968 | RPVList _ | RVGList _ | RLVList _
1969 | RStat _ | RStatVFS _
1971 pr " struct %s_ret ret;\n" name
1975 (* Generate the callback function. *)
1976 pr "static void %s_cb (guestfs_h *g, void *data, XDR *xdr)\n" shortname;
1978 pr " struct %s_rv *rv = (struct %s_rv *) data;\n" shortname shortname;
1980 pr " if (!xdr_guestfs_message_header (xdr, &rv->hdr)) {\n";
1981 pr " error (g, \"%s: failed to parse reply header\");\n" name;
1984 pr " if (rv->hdr.status == GUESTFS_STATUS_ERROR) {\n";
1985 pr " if (!xdr_guestfs_message_error (xdr, &rv->err)) {\n";
1986 pr " error (g, \"%s: failed to parse reply error\");\n" name;
1992 (match fst style with
1995 failwithf "RConstString cannot be returned from a daemon function"
1997 | RBool _ | RString _ | RStringList _
1999 | RPVList _ | RVGList _ | RLVList _
2000 | RStat _ | RStatVFS _
2002 pr " if (!xdr_%s_ret (xdr, &rv->ret)) {\n" name;
2003 pr " error (g, \"%s: failed to parse reply\");\n" name;
2009 pr " rv->cb_done = 1;\n";
2010 pr " main_loop.main_loop_quit (g);\n";
2013 (* Generate the action stub. *)
2014 generate_prototype ~extern:false ~semicolon:false ~newline:true
2015 ~handle:"g" name style;
2018 match fst style with
2019 | RErr | RInt _ | RInt64 _ | RBool _ -> "-1"
2021 failwithf "RConstString cannot be returned from a daemon function"
2022 | RString _ | RStringList _ | RIntBool _
2023 | RPVList _ | RVGList _ | RLVList _
2024 | RStat _ | RStatVFS _
2030 (match snd style with
2032 | _ -> pr " struct %s_args args;\n" name
2035 pr " struct %s_rv rv;\n" shortname;
2036 pr " int serial;\n";
2038 pr " if (g->state != READY) {\n";
2039 pr " error (g, \"%s called from the wrong state, %%d != READY\",\n"
2042 pr " return %s;\n" error_code;
2045 pr " memset (&rv, 0, sizeof rv);\n";
2048 (match snd style with
2050 pr " serial = dispatch (g, GUESTFS_PROC_%s, NULL, NULL);\n"
2051 (String.uppercase shortname)
2056 pr " args.%s = (char *) %s;\n" n n
2058 pr " args.%s = %s ? (char **) &%s : NULL;\n" n n n
2060 pr " args.%s.%s_val = (char **) %s;\n" n n n;
2061 pr " for (args.%s.%s_len = 0; %s[args.%s.%s_len]; args.%s.%s_len++) ;\n" n n n n n n n;
2063 pr " args.%s = %s;\n" n n
2065 pr " args.%s = %s;\n" n n
2067 pr " serial = dispatch (g, GUESTFS_PROC_%s,\n"
2068 (String.uppercase shortname);
2069 pr " (xdrproc_t) xdr_%s_args, (char *) &args);\n"
2072 pr " if (serial == -1)\n";
2073 pr " return %s;\n" error_code;
2076 pr " rv.cb_done = 0;\n";
2077 pr " g->reply_cb_internal = %s_cb;\n" shortname;
2078 pr " g->reply_cb_internal_data = &rv;\n";
2079 pr " main_loop.main_loop_run (g);\n";
2080 pr " g->reply_cb_internal = NULL;\n";
2081 pr " g->reply_cb_internal_data = NULL;\n";
2082 pr " if (!rv.cb_done) {\n";
2083 pr " error (g, \"%s failed, see earlier error messages\");\n" name;
2084 pr " return %s;\n" error_code;
2088 pr " if (check_reply_header (g, &rv.hdr, GUESTFS_PROC_%s, serial) == -1)\n"
2089 (String.uppercase shortname);
2090 pr " return %s;\n" error_code;
2093 pr " if (rv.hdr.status == GUESTFS_STATUS_ERROR) {\n";
2094 pr " error (g, \"%%s\", rv.err.error);\n";
2095 pr " return %s;\n" error_code;
2099 (match fst style with
2100 | RErr -> pr " return 0;\n"
2101 | RInt n | RInt64 n | RBool n ->
2102 pr " return rv.ret.%s;\n" n
2104 failwithf "RConstString cannot be returned from a daemon function"
2106 pr " return rv.ret.%s; /* caller will free */\n" n
2107 | RStringList n | RHashtable n ->
2108 pr " /* caller will free this, but we need to add a NULL entry */\n";
2109 pr " rv.ret.%s.%s_val =" n n;
2110 pr " safe_realloc (g, rv.ret.%s.%s_val,\n" n n;
2111 pr " sizeof (char *) * (rv.ret.%s.%s_len + 1));\n"
2113 pr " rv.ret.%s.%s_val[rv.ret.%s.%s_len] = NULL;\n" n n n n;
2114 pr " return rv.ret.%s.%s_val;\n" n n
2116 pr " /* caller with free this */\n";
2117 pr " return safe_memdup (g, &rv.ret, sizeof (rv.ret));\n"
2118 | RPVList n | RVGList n | RLVList n
2119 | RStat n | RStatVFS n ->
2120 pr " /* caller will free this */\n";
2121 pr " return safe_memdup (g, &rv.ret.%s, sizeof (rv.ret.%s));\n" n n
2127 (* Generate daemon/actions.h. *)
2128 and generate_daemon_actions_h () =
2129 generate_header CStyle GPLv2;
2131 pr "#include \"../src/guestfs_protocol.h\"\n";
2135 fun (name, style, _, _, _, _, _) ->
2137 ~single_line:true ~newline:true ~in_daemon:true ~prefix:"do_"
2141 (* Generate the server-side stubs. *)
2142 and generate_daemon_actions () =
2143 generate_header CStyle GPLv2;
2145 pr "#define _GNU_SOURCE // for strchrnul\n";
2147 pr "#include <stdio.h>\n";
2148 pr "#include <stdlib.h>\n";
2149 pr "#include <string.h>\n";
2150 pr "#include <inttypes.h>\n";
2151 pr "#include <ctype.h>\n";
2152 pr "#include <rpc/types.h>\n";
2153 pr "#include <rpc/xdr.h>\n";
2155 pr "#include \"daemon.h\"\n";
2156 pr "#include \"../src/guestfs_protocol.h\"\n";
2157 pr "#include \"actions.h\"\n";
2161 fun (name, style, _, _, _, _, _) ->
2162 (* Generate server-side stubs. *)
2163 pr "static void %s_stub (XDR *xdr_in)\n" name;
2166 match fst style with
2167 | RErr | RInt _ -> pr " int r;\n"; "-1"
2168 | RInt64 _ -> pr " int64_t r;\n"; "-1"
2169 | RBool _ -> pr " int r;\n"; "-1"
2171 failwithf "RConstString cannot be returned from a daemon function"
2172 | RString _ -> pr " char *r;\n"; "NULL"
2173 | RStringList _ | RHashtable _ -> pr " char **r;\n"; "NULL"
2174 | RIntBool _ -> pr " guestfs_%s_ret *r;\n" name; "NULL"
2175 | RPVList _ -> pr " guestfs_lvm_int_pv_list *r;\n"; "NULL"
2176 | RVGList _ -> pr " guestfs_lvm_int_vg_list *r;\n"; "NULL"
2177 | RLVList _ -> pr " guestfs_lvm_int_lv_list *r;\n"; "NULL"
2178 | RStat _ -> pr " guestfs_int_stat *r;\n"; "NULL"
2179 | RStatVFS _ -> pr " guestfs_int_statvfs *r;\n"; "NULL" in
2181 (match snd style with
2184 pr " struct guestfs_%s_args args;\n" name;
2188 | OptString n -> pr " const char *%s;\n" n
2189 | StringList n -> pr " char **%s;\n" n
2190 | Bool n -> pr " int %s;\n" n
2191 | Int n -> pr " int %s;\n" n
2196 (match snd style with
2199 pr " memset (&args, 0, sizeof args);\n";
2201 pr " if (!xdr_guestfs_%s_args (xdr_in, &args)) {\n" name;
2202 pr " reply_with_error (\"%%s: daemon failed to decode procedure arguments\", \"%s\");\n" name;
2207 | String n -> pr " %s = args.%s;\n" n n
2208 | OptString n -> pr " %s = args.%s ? *args.%s : NULL;\n" n n n
2210 pr " args.%s.%s_val = realloc (args.%s.%s_val, sizeof (char *) * (args.%s.%s_len+1));\n" n n n n n n;
2211 pr " args.%s.%s_val[args.%s.%s_len] = NULL;\n" n n n n;
2212 pr " %s = args.%s.%s_val;\n" n n n
2213 | Bool n -> pr " %s = args.%s;\n" n n
2214 | Int n -> pr " %s = args.%s;\n" n n
2219 pr " r = do_%s " name;
2220 generate_call_args style;
2223 pr " if (r == %s)\n" error_code;
2224 pr " /* do_%s has already called reply_with_error */\n" name;
2228 (match fst style with
2229 | RErr -> pr " reply (NULL, NULL);\n"
2230 | RInt n | RInt64 n | RBool n ->
2231 pr " struct guestfs_%s_ret ret;\n" name;
2232 pr " ret.%s = r;\n" n;
2233 pr " reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name
2235 failwithf "RConstString cannot be returned from a daemon function"
2237 pr " struct guestfs_%s_ret ret;\n" name;
2238 pr " ret.%s = r;\n" n;
2239 pr " reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name;
2241 | RStringList n | RHashtable n ->
2242 pr " struct guestfs_%s_ret ret;\n" name;
2243 pr " ret.%s.%s_len = count_strings (r);\n" n n;
2244 pr " ret.%s.%s_val = r;\n" n n;
2245 pr " reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name;
2246 pr " free_strings (r);\n"
2248 pr " reply ((xdrproc_t) xdr_guestfs_%s_ret, (char *) r);\n" name;
2249 pr " xdr_free ((xdrproc_t) xdr_guestfs_%s_ret, (char *) r);\n" name
2250 | RPVList n | RVGList n | RLVList n
2251 | RStat n | RStatVFS n ->
2252 pr " struct guestfs_%s_ret ret;\n" name;
2253 pr " ret.%s = *r;\n" n;
2254 pr " reply ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n" name;
2255 pr " xdr_free ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n" name
2258 (* Free the args. *)
2259 (match snd style with
2264 pr " xdr_free ((xdrproc_t) xdr_guestfs_%s_args, (char *) &args);\n"
2271 (* Dispatch function. *)
2272 pr "void dispatch_incoming_message (XDR *xdr_in)\n";
2274 pr " switch (proc_nr) {\n";
2277 fun (name, style, _, _, _, _, _) ->
2278 pr " case GUESTFS_PROC_%s:\n" (String.uppercase name);
2279 pr " %s_stub (xdr_in);\n" name;
2284 pr " reply_with_error (\"dispatch_incoming_message: unknown procedure number %%d\", proc_nr);\n";
2289 (* LVM columns and tokenization functions. *)
2290 (* XXX This generates crap code. We should rethink how we
2296 pr "static const char *lvm_%s_cols = \"%s\";\n"
2297 typ (String.concat "," (List.map fst cols));
2300 pr "static int lvm_tokenize_%s (char *str, struct guestfs_lvm_int_%s *r)\n" typ typ;
2302 pr " char *tok, *p, *next;\n";
2306 pr " fprintf (stderr, \"%%s: <<%%s>>\\n\", __func__, str);\n";
2309 pr " if (!str) {\n";
2310 pr " fprintf (stderr, \"%%s: failed: passed a NULL string\\n\", __func__);\n";
2313 pr " if (!*str || isspace (*str)) {\n";
2314 pr " fprintf (stderr, \"%%s: failed: passed a empty string or one beginning with whitespace\\n\", __func__);\n";
2319 fun (name, coltype) ->
2320 pr " if (!tok) {\n";
2321 pr " fprintf (stderr, \"%%s: failed: string finished early, around token %%s\\n\", __func__, \"%s\");\n" name;
2324 pr " p = strchrnul (tok, ',');\n";
2325 pr " if (*p) next = p+1; else next = NULL;\n";
2326 pr " *p = '\\0';\n";
2329 pr " r->%s = strdup (tok);\n" name;
2330 pr " if (r->%s == NULL) {\n" name;
2331 pr " perror (\"strdup\");\n";
2335 pr " for (i = j = 0; i < 32; ++j) {\n";
2336 pr " if (tok[j] == '\\0') {\n";
2337 pr " fprintf (stderr, \"%%s: failed to parse UUID from '%%s'\\n\", __func__, tok);\n";
2339 pr " } else if (tok[j] != '-')\n";
2340 pr " r->%s[i++] = tok[j];\n" name;
2343 pr " if (sscanf (tok, \"%%\"SCNu64, &r->%s) != 1) {\n" name;
2344 pr " fprintf (stderr, \"%%s: failed to parse size '%%s' from token %%s\\n\", __func__, tok, \"%s\");\n" name;
2348 pr " if (sscanf (tok, \"%%\"SCNi64, &r->%s) != 1) {\n" name;
2349 pr " fprintf (stderr, \"%%s: failed to parse int '%%s' from token %%s\\n\", __func__, tok, \"%s\");\n" name;
2353 pr " if (tok[0] == '\\0')\n";
2354 pr " r->%s = -1;\n" name;
2355 pr " else if (sscanf (tok, \"%%f\", &r->%s) != 1) {\n" name;
2356 pr " fprintf (stderr, \"%%s: failed to parse float '%%s' from token %%s\\n\", __func__, tok, \"%s\");\n" name;
2360 pr " tok = next;\n";
2363 pr " if (tok != NULL) {\n";
2364 pr " fprintf (stderr, \"%%s: failed: extra tokens at end of string\\n\", __func__);\n";
2371 pr "guestfs_lvm_int_%s_list *\n" typ;
2372 pr "parse_command_line_%ss (void)\n" typ;
2374 pr " char *out, *err;\n";
2375 pr " char *p, *pend;\n";
2377 pr " guestfs_lvm_int_%s_list *ret;\n" typ;
2378 pr " void *newp;\n";
2380 pr " ret = malloc (sizeof *ret);\n";
2381 pr " if (!ret) {\n";
2382 pr " reply_with_perror (\"malloc\");\n";
2383 pr " return NULL;\n";
2386 pr " ret->guestfs_lvm_int_%s_list_len = 0;\n" typ;
2387 pr " ret->guestfs_lvm_int_%s_list_val = NULL;\n" typ;
2389 pr " r = command (&out, &err,\n";
2390 pr " \"/sbin/lvm\", \"%ss\",\n" typ;
2391 pr " \"-o\", lvm_%s_cols, \"--unbuffered\", \"--noheadings\",\n" typ;
2392 pr " \"--nosuffix\", \"--separator\", \",\", \"--units\", \"b\", NULL);\n";
2393 pr " if (r == -1) {\n";
2394 pr " reply_with_error (\"%%s\", err);\n";
2395 pr " free (out);\n";
2396 pr " free (err);\n";
2397 pr " return NULL;\n";
2400 pr " free (err);\n";
2402 pr " /* Tokenize each line of the output. */\n";
2405 pr " while (p) {\n";
2406 pr " pend = strchr (p, '\\n'); /* Get the next line of output. */\n";
2407 pr " if (pend) {\n";
2408 pr " *pend = '\\0';\n";
2412 pr " while (*p && isspace (*p)) /* Skip any leading whitespace. */\n";
2415 pr " if (!*p) { /* Empty line? Skip it. */\n";
2420 pr " /* Allocate some space to store this next entry. */\n";
2421 pr " newp = realloc (ret->guestfs_lvm_int_%s_list_val,\n" typ;
2422 pr " sizeof (guestfs_lvm_int_%s) * (i+1));\n" typ;
2423 pr " if (newp == NULL) {\n";
2424 pr " reply_with_perror (\"realloc\");\n";
2425 pr " free (ret->guestfs_lvm_int_%s_list_val);\n" typ;
2426 pr " free (ret);\n";
2427 pr " free (out);\n";
2428 pr " return NULL;\n";
2430 pr " ret->guestfs_lvm_int_%s_list_val = newp;\n" typ;
2432 pr " /* Tokenize the next entry. */\n";
2433 pr " r = lvm_tokenize_%s (p, &ret->guestfs_lvm_int_%s_list_val[i]);\n" typ typ;
2434 pr " if (r == -1) {\n";
2435 pr " reply_with_error (\"failed to parse output of '%ss' command\");\n" typ;
2436 pr " free (ret->guestfs_lvm_int_%s_list_val);\n" typ;
2437 pr " free (ret);\n";
2438 pr " free (out);\n";
2439 pr " return NULL;\n";
2446 pr " ret->guestfs_lvm_int_%s_list_len = i;\n" typ;
2448 pr " free (out);\n";
2449 pr " return ret;\n";
2452 ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols]
2454 (* Generate the tests. *)
2455 and generate_tests () =
2456 generate_header CStyle GPLv2;
2463 #include <sys/types.h>
2466 #include \"guestfs.h\"
2468 static guestfs_h *g;
2469 static int suppress_error = 0;
2471 static void print_error (guestfs_h *g, void *data, const char *msg)
2473 if (!suppress_error)
2474 fprintf (stderr, \"%%s\\n\", msg);
2477 static void print_strings (char * const * const argv)
2481 for (argc = 0; argv[argc] != NULL; ++argc)
2482 printf (\"\\t%%s\\n\", argv[argc]);
2486 static void print_table (char * const * const argv)
2490 for (i = 0; argv[i] != NULL; i += 2)
2491 printf (\"%%s: %%s\\n\", argv[i], argv[i+1]);
2495 static void no_test_warnings (void)
2501 | name, _, _, _, [], _, _ ->
2502 pr " fprintf (stderr, \"warning: \\\"guestfs_%s\\\" has no tests\\n\");\n" name
2503 | name, _, _, _, tests, _, _ -> ()
2509 (* Generate the actual tests. Note that we generate the tests
2510 * in reverse order, deliberately, so that (in general) the
2511 * newest tests run first. This makes it quicker and easier to
2516 fun (name, _, _, _, tests, _, _) ->
2517 mapi (generate_one_test name) tests
2518 ) (List.rev all_functions) in
2519 let test_names = List.concat test_names in
2520 let nr_tests = List.length test_names in
2523 int main (int argc, char *argv[])
2530 int nr_tests, test_num = 0;
2532 no_test_warnings ();
2534 g = guestfs_create ();
2536 printf (\"guestfs_create FAILED\\n\");
2540 guestfs_set_error_handler (g, print_error, NULL);
2542 srcdir = getenv (\"srcdir\");
2543 if (!srcdir) srcdir = \".\";
2544 guestfs_set_path (g, srcdir);
2546 snprintf (buf, sizeof buf, \"%%s/test1.img\", srcdir);
2547 fd = open (buf, O_WRONLY|O_CREAT|O_NOCTTY|O_NONBLOCK|O_TRUNC, 0666);
2552 if (lseek (fd, %d, SEEK_SET) == -1) {
2558 if (write (fd, &c, 1) == -1) {
2564 if (close (fd) == -1) {
2569 if (guestfs_add_drive (g, buf) == -1) {
2570 printf (\"guestfs_add_drive %%s FAILED\\n\", buf);
2574 snprintf (buf, sizeof buf, \"%%s/test2.img\", srcdir);
2575 fd = open (buf, O_WRONLY|O_CREAT|O_NOCTTY|O_NONBLOCK|O_TRUNC, 0666);
2580 if (lseek (fd, %d, SEEK_SET) == -1) {
2586 if (write (fd, &c, 1) == -1) {
2592 if (close (fd) == -1) {
2597 if (guestfs_add_drive (g, buf) == -1) {
2598 printf (\"guestfs_add_drive %%s FAILED\\n\", buf);
2602 snprintf (buf, sizeof buf, \"%%s/test3.img\", srcdir);
2603 fd = open (buf, O_WRONLY|O_CREAT|O_NOCTTY|O_NONBLOCK|O_TRUNC, 0666);
2608 if (lseek (fd, %d, SEEK_SET) == -1) {
2614 if (write (fd, &c, 1) == -1) {
2620 if (close (fd) == -1) {
2625 if (guestfs_add_drive (g, buf) == -1) {
2626 printf (\"guestfs_add_drive %%s FAILED\\n\", buf);
2630 if (guestfs_launch (g) == -1) {
2631 printf (\"guestfs_launch FAILED\\n\");
2634 if (guestfs_wait_ready (g) == -1) {
2635 printf (\"guestfs_wait_ready FAILED\\n\");
2641 " (500 * 1024 * 1024) (50 * 1024 * 1024) (10 * 1024 * 1024) nr_tests;
2645 pr " test_num++;\n";
2646 pr " printf (\"%%3d/%%3d %s\\n\", test_num, nr_tests);\n" test_name;
2647 pr " if (%s () == -1) {\n" test_name;
2648 pr " printf (\"%s FAILED\\n\");\n" test_name;
2654 pr " guestfs_close (g);\n";
2655 pr " snprintf (buf, sizeof buf, \"%%s/test1.img\", srcdir);\n";
2656 pr " unlink (buf);\n";
2657 pr " snprintf (buf, sizeof buf, \"%%s/test2.img\", srcdir);\n";
2658 pr " unlink (buf);\n";
2659 pr " snprintf (buf, sizeof buf, \"%%s/test3.img\", srcdir);\n";
2660 pr " unlink (buf);\n";
2663 pr " if (failed > 0) {\n";
2664 pr " printf (\"***** %%d / %%d tests FAILED *****\\n\", failed, nr_tests);\n";
2672 and generate_one_test name i (init, test) =
2673 let test_name = sprintf "test_%s_%d" name i in
2675 pr "static int %s (void)\n" test_name;
2681 pr " /* InitEmpty for %s (%d) */\n" name i;
2682 List.iter (generate_test_command_call test_name)
2686 pr " /* InitBasicFS for %s (%d): create ext2 on /dev/sda1 */\n" name i;
2687 List.iter (generate_test_command_call test_name)
2690 ["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ","];
2691 ["mkfs"; "ext2"; "/dev/sda1"];
2692 ["mount"; "/dev/sda1"; "/"]]
2693 | InitBasicFSonLVM ->
2694 pr " /* InitBasicFSonLVM for %s (%d): create ext2 on /dev/VG/LV */\n"
2696 List.iter (generate_test_command_call test_name)
2699 ["sfdisk"; "/dev/sda"; "0"; "0"; "0"; ","];
2700 ["pvcreate"; "/dev/sda1"];
2701 ["vgcreate"; "VG"; "/dev/sda1"];
2702 ["lvcreate"; "LV"; "VG"; "8"];
2703 ["mkfs"; "ext2"; "/dev/VG/LV"];
2704 ["mount"; "/dev/VG/LV"; "/"]]
2707 let get_seq_last = function
2709 failwithf "%s: you cannot use [] (empty list) when expecting a command"
2712 let seq = List.rev seq in
2713 List.rev (List.tl seq), List.hd seq
2718 pr " /* TestRun for %s (%d) */\n" name i;
2719 List.iter (generate_test_command_call test_name) seq
2720 | TestOutput (seq, expected) ->
2721 pr " /* TestOutput for %s (%d) */\n" name i;
2722 let seq, last = get_seq_last seq in
2724 pr " if (strcmp (r, \"%s\") != 0) {\n" (c_quote expected);
2725 pr " fprintf (stderr, \"%s: expected \\\"%s\\\" but got \\\"%%s\\\"\\n\", r);\n" test_name (c_quote expected);
2729 List.iter (generate_test_command_call test_name) seq;
2730 generate_test_command_call ~test test_name last
2731 | TestOutputList (seq, expected) ->
2732 pr " /* TestOutputList for %s (%d) */\n" name i;
2733 let seq, last = get_seq_last seq in
2737 pr " if (!r[%d]) {\n" i;
2738 pr " fprintf (stderr, \"%s: short list returned from command\\n\");\n" test_name;
2739 pr " print_strings (r);\n";
2742 pr " if (strcmp (r[%d], \"%s\") != 0) {\n" i (c_quote str);
2743 pr " fprintf (stderr, \"%s: expected \\\"%s\\\" but got \\\"%%s\\\"\\n\", r[%d]);\n" test_name (c_quote str) i;
2747 pr " if (r[%d] != NULL) {\n" (List.length expected);
2748 pr " fprintf (stderr, \"%s: extra elements returned from command\\n\");\n"
2750 pr " print_strings (r);\n";
2754 List.iter (generate_test_command_call test_name) seq;
2755 generate_test_command_call ~test test_name last
2756 | TestOutputInt (seq, expected) ->
2757 pr " /* TestOutputInt for %s (%d) */\n" name i;
2758 let seq, last = get_seq_last seq in
2760 pr " if (r != %d) {\n" expected;
2761 pr " fprintf (stderr, \"%s: expected %d but got %%d\\n\","
2767 List.iter (generate_test_command_call test_name) seq;
2768 generate_test_command_call ~test test_name last
2769 | TestOutputTrue seq ->
2770 pr " /* TestOutputTrue for %s (%d) */\n" name i;
2771 let seq, last = get_seq_last seq in
2774 pr " fprintf (stderr, \"%s: expected true, got false\\n\");\n"
2779 List.iter (generate_test_command_call test_name) seq;
2780 generate_test_command_call ~test test_name last
2781 | TestOutputFalse seq ->
2782 pr " /* TestOutputFalse for %s (%d) */\n" name i;
2783 let seq, last = get_seq_last seq in
2786 pr " fprintf (stderr, \"%s: expected false, got true\\n\");\n"
2791 List.iter (generate_test_command_call test_name) seq;
2792 generate_test_command_call ~test test_name last
2793 | TestOutputLength (seq, expected) ->
2794 pr " /* TestOutputLength for %s (%d) */\n" name i;
2795 let seq, last = get_seq_last seq in
2798 pr " for (j = 0; j < %d; ++j)\n" expected;
2799 pr " if (r[j] == NULL) {\n";
2800 pr " fprintf (stderr, \"%s: short list returned\\n\");\n"
2802 pr " print_strings (r);\n";
2805 pr " if (r[j] != NULL) {\n";
2806 pr " fprintf (stderr, \"%s: long list returned\\n\");\n"
2808 pr " print_strings (r);\n";
2812 List.iter (generate_test_command_call test_name) seq;
2813 generate_test_command_call ~test test_name last
2814 | TestOutputStruct (seq, checks) ->
2815 pr " /* TestOutputStruct for %s (%d) */\n" name i;
2816 let seq, last = get_seq_last seq in
2820 | CompareWithInt (field, expected) ->
2821 pr " if (r->%s != %d) {\n" field expected;
2822 pr " fprintf (stderr, \"%s: %s was %%d, expected %d\\n\",\n"
2823 test_name field expected;
2824 pr " (int) r->%s);\n" field;
2827 | CompareWithString (field, expected) ->
2828 pr " if (strcmp (r->%s, \"%s\") != 0) {\n" field expected;
2829 pr " fprintf (stderr, \"%s: %s was \"%%s\", expected \"%s\"\\n\",\n"
2830 test_name field expected;
2831 pr " r->%s);\n" field;
2834 | CompareFieldsIntEq (field1, field2) ->
2835 pr " if (r->%s != r->%s) {\n" field1 field2;
2836 pr " fprintf (stderr, \"%s: %s (%%d) <> %s (%%d)\\n\",\n"
2837 test_name field1 field2;
2838 pr " (int) r->%s, (int) r->%s);\n" field1 field2;
2841 | CompareFieldsStrEq (field1, field2) ->
2842 pr " if (strcmp (r->%s, r->%s) != 0) {\n" field1 field2;
2843 pr " fprintf (stderr, \"%s: %s (\"%%s\") <> %s (\"%%s\")\\n\",\n"
2844 test_name field1 field2;
2845 pr " r->%s, r->%s);\n" field1 field2;
2850 List.iter (generate_test_command_call test_name) seq;
2851 generate_test_command_call ~test test_name last
2852 | TestLastFail seq ->
2853 pr " /* TestLastFail for %s (%d) */\n" name i;
2854 let seq, last = get_seq_last seq in
2855 List.iter (generate_test_command_call test_name) seq;
2856 generate_test_command_call test_name ~expect_error:true last
2864 (* Generate the code to run a command, leaving the result in 'r'.
2865 * If you expect to get an error then you should set expect_error:true.
2867 and generate_test_command_call ?(expect_error = false) ?test test_name cmd =
2869 | [] -> assert false
2871 (* Look up the command to find out what args/ret it has. *)
2874 let _, style, _, _, _, _, _ =
2875 List.find (fun (n, _, _, _, _, _, _) -> n = name) all_functions in
2878 failwithf "%s: in test, command %s was not found" test_name name in
2880 if List.length (snd style) <> List.length args then
2881 failwithf "%s: in test, wrong number of args given to %s"
2892 | StringList n, arg ->
2893 pr " char *%s[] = {\n" n;
2894 let strs = string_split " " arg in
2896 fun str -> pr " \"%s\",\n" (c_quote str)
2900 ) (List.combine (snd style) args);
2903 match fst style with
2904 | RErr | RInt _ | RBool _ -> pr " int r;\n"; "-1"
2905 | RInt64 _ -> pr " int64_t r;\n"; "-1"
2906 | RConstString _ -> pr " const char *r;\n"; "NULL"
2907 | RString _ -> pr " char *r;\n"; "NULL"
2908 | RStringList _ | RHashtable _ ->
2913 pr " struct guestfs_int_bool *r;\n"; "NULL"
2915 pr " struct guestfs_lvm_pv_list *r;\n"; "NULL"
2917 pr " struct guestfs_lvm_vg_list *r;\n"; "NULL"
2919 pr " struct guestfs_lvm_lv_list *r;\n"; "NULL"
2921 pr " struct guestfs_stat *r;\n"; "NULL"
2923 pr " struct guestfs_statvfs *r;\n"; "NULL" in
2925 pr " suppress_error = %d;\n" (if expect_error then 1 else 0);
2926 pr " r = guestfs_%s (g" name;
2928 (* Generate the parameters. *)
2931 | String _, arg -> pr ", \"%s\"" (c_quote arg)
2932 | OptString _, arg ->
2933 if arg = "NULL" then pr ", NULL" else pr ", \"%s\"" (c_quote arg)
2934 | StringList n, _ ->
2938 try int_of_string arg
2939 with Failure "int_of_string" ->
2940 failwithf "%s: expecting an int, but got '%s'" test_name arg in
2943 let b = bool_of_string arg in pr ", %d" (if b then 1 else 0)
2944 ) (List.combine (snd style) args);
2947 if not expect_error then
2948 pr " if (r == %s)\n" error_code
2950 pr " if (r != %s)\n" error_code;
2953 (* Insert the test code. *)
2959 (match fst style with
2960 | RErr | RInt _ | RInt64 _ | RBool _ | RConstString _ -> ()
2961 | RString _ -> pr " free (r);\n"
2962 | RStringList _ | RHashtable _ ->
2963 pr " for (i = 0; r[i] != NULL; ++i)\n";
2964 pr " free (r[i]);\n";
2967 pr " guestfs_free_int_bool (r);\n"
2969 pr " guestfs_free_lvm_pv_list (r);\n"
2971 pr " guestfs_free_lvm_vg_list (r);\n"
2973 pr " guestfs_free_lvm_lv_list (r);\n"
2974 | RStat _ | RStatVFS _ ->
2981 let str = replace_str str "\r" "\\r" in
2982 let str = replace_str str "\n" "\\n" in
2983 let str = replace_str str "\t" "\\t" in
2986 (* Generate a lot of different functions for guestfish. *)
2987 and generate_fish_cmds () =
2988 generate_header CStyle GPLv2;
2992 fun (_, _, _, flags, _, _, _) -> not (List.mem NotInFish flags)
2994 let all_functions_sorted =
2996 fun (_, _, _, flags, _, _, _) -> not (List.mem NotInFish flags)
2997 ) all_functions_sorted in
2999 pr "#include <stdio.h>\n";
3000 pr "#include <stdlib.h>\n";
3001 pr "#include <string.h>\n";
3002 pr "#include <inttypes.h>\n";
3004 pr "#include <guestfs.h>\n";
3005 pr "#include \"fish.h\"\n";
3008 (* list_commands function, which implements guestfish -h *)
3009 pr "void list_commands (void)\n";
3011 pr " printf (\" %%-16s %%s\\n\", \"Command\", \"Description\");\n";
3012 pr " list_builtin_commands ();\n";
3014 fun (name, _, _, flags, _, shortdesc, _) ->
3015 let name = replace_char name '_' '-' in
3016 pr " printf (\"%%-20s %%s\\n\", \"%s\", \"%s\");\n"
3018 ) all_functions_sorted;
3019 pr " printf (\" Use -h <cmd> / help <cmd> to show detailed help for a command.\\n\");\n";
3023 (* display_command function, which implements guestfish -h cmd *)
3024 pr "void display_command (const char *cmd)\n";
3027 fun (name, style, _, flags, _, shortdesc, longdesc) ->
3028 let name2 = replace_char name '_' '-' in
3030 try find_map (function FishAlias n -> Some n | _ -> None) flags
3031 with Not_found -> name in
3032 let longdesc = replace_str longdesc "C<guestfs_" "C<" in
3034 match snd style with
3038 name2 (String.concat "> <" (List.map name_of_argt args)) in
3041 if List.mem ProtocolLimitWarning flags then
3042 ("\n\n" ^ protocol_limit_warning)
3045 (* For DangerWillRobinson commands, we should probably have
3046 * guestfish prompt before allowing you to use them (especially
3047 * in interactive mode). XXX
3051 if List.mem DangerWillRobinson flags then
3052 ("\n\n" ^ danger_will_robinson)
3055 let describe_alias =
3056 if name <> alias then
3057 sprintf "\n\nYou can use '%s' as an alias for this command." alias
3061 pr "strcasecmp (cmd, \"%s\") == 0" name;
3062 if name <> name2 then
3063 pr " || strcasecmp (cmd, \"%s\") == 0" name2;
3064 if name <> alias then
3065 pr " || strcasecmp (cmd, \"%s\") == 0" alias;
3067 pr " pod2text (\"%s - %s\", %S);\n"
3069 (" " ^ synopsis ^ "\n\n" ^ longdesc ^ warnings ^ describe_alias);
3072 pr " display_builtin_command (cmd);\n";
3076 (* print_{pv,vg,lv}_list functions *)
3080 pr "static void print_%s (struct guestfs_lvm_%s *%s)\n" typ typ typ;
3087 pr " printf (\"%s: %%s\\n\", %s->%s);\n" name typ name
3089 pr " printf (\"%s: \");\n" name;
3090 pr " for (i = 0; i < 32; ++i)\n";
3091 pr " printf (\"%%c\", %s->%s[i]);\n" typ name;
3092 pr " printf (\"\\n\");\n"
3094 pr " printf (\"%s: %%\" PRIu64 \"\\n\", %s->%s);\n" name typ name
3096 pr " printf (\"%s: %%\" PRIi64 \"\\n\", %s->%s);\n" name typ name
3097 | name, `OptPercent ->
3098 pr " if (%s->%s >= 0) printf (\"%s: %%g %%%%\\n\", %s->%s);\n"
3099 typ name name typ name;
3100 pr " else printf (\"%s: \\n\");\n" name
3104 pr "static void print_%s_list (struct guestfs_lvm_%s_list *%ss)\n"
3109 pr " for (i = 0; i < %ss->len; ++i)\n" typ;
3110 pr " print_%s (&%ss->val[i]);\n" typ typ;
3113 ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols];
3115 (* print_{stat,statvfs} functions *)
3119 pr "static void print_%s (struct guestfs_%s *%s)\n" typ typ typ;
3124 pr " printf (\"%s: %%\" PRIi64 \"\\n\", %s->%s);\n" name typ name
3128 ) ["stat", stat_cols; "statvfs", statvfs_cols];
3130 (* run_<action> actions *)
3132 fun (name, style, _, flags, _, _, _) ->
3133 pr "static int run_%s (const char *cmd, int argc, char *argv[])\n" name;
3135 (match fst style with
3138 | RBool _ -> pr " int r;\n"
3139 | RInt64 _ -> pr " int64_t r;\n"
3140 | RConstString _ -> pr " const char *r;\n"
3141 | RString _ -> pr " char *r;\n"
3142 | RStringList _ | RHashtable _ -> pr " char **r;\n"
3143 | RIntBool _ -> pr " struct guestfs_int_bool *r;\n"
3144 | RPVList _ -> pr " struct guestfs_lvm_pv_list *r;\n"
3145 | RVGList _ -> pr " struct guestfs_lvm_vg_list *r;\n"
3146 | RLVList _ -> pr " struct guestfs_lvm_lv_list *r;\n"
3147 | RStat _ -> pr " struct guestfs_stat *r;\n"
3148 | RStatVFS _ -> pr " struct guestfs_statvfs *r;\n"
3153 | OptString n -> pr " const char *%s;\n" n
3154 | StringList n -> pr " char **%s;\n" n
3155 | Bool n -> pr " int %s;\n" n
3156 | Int n -> pr " int %s;\n" n
3159 (* Check and convert parameters. *)
3160 let argc_expected = List.length (snd style) in
3161 pr " if (argc != %d) {\n" argc_expected;
3162 pr " fprintf (stderr, \"%%s should have %d parameter(s)\\n\", cmd);\n"
3164 pr " fprintf (stderr, \"type 'help %%s' for help on %%s\\n\", cmd, cmd);\n";
3170 | String name -> pr " %s = argv[%d];\n" name i
3172 pr " %s = strcmp (argv[%d], \"\") != 0 ? argv[%d] : NULL;\n"
3174 | StringList name ->
3175 pr " %s = parse_string_list (argv[%d]);\n" name i
3177 pr " %s = is_true (argv[%d]) ? 1 : 0;\n" name i
3179 pr " %s = atoi (argv[%d]);\n" name i
3182 (* Call C API function. *)
3184 try find_map (function FishAction n -> Some n | _ -> None) flags
3185 with Not_found -> sprintf "guestfs_%s" name in
3187 generate_call_args ~handle:"g" style;
3190 (* Check return value for errors and display command results. *)
3191 (match fst style with
3192 | RErr -> pr " return r;\n"
3194 pr " if (r == -1) return -1;\n";
3195 pr " printf (\"%%d\\n\", r);\n";
3198 pr " if (r == -1) return -1;\n";
3199 pr " printf (\"%%\" PRIi64 \"\\n\", r);\n";
3202 pr " if (r == -1) return -1;\n";
3203 pr " if (r) printf (\"true\\n\"); else printf (\"false\\n\");\n";
3206 pr " if (r == NULL) return -1;\n";
3207 pr " printf (\"%%s\\n\", r);\n";
3210 pr " if (r == NULL) return -1;\n";
3211 pr " printf (\"%%s\\n\", r);\n";
3215 pr " if (r == NULL) return -1;\n";
3216 pr " print_strings (r);\n";
3217 pr " free_strings (r);\n";
3220 pr " if (r == NULL) return -1;\n";
3221 pr " printf (\"%%d, %%s\\n\", r->i,\n";
3222 pr " r->b ? \"true\" : \"false\");\n";
3223 pr " guestfs_free_int_bool (r);\n";
3226 pr " if (r == NULL) return -1;\n";
3227 pr " print_pv_list (r);\n";
3228 pr " guestfs_free_lvm_pv_list (r);\n";
3231 pr " if (r == NULL) return -1;\n";
3232 pr " print_vg_list (r);\n";
3233 pr " guestfs_free_lvm_vg_list (r);\n";
3236 pr " if (r == NULL) return -1;\n";
3237 pr " print_lv_list (r);\n";
3238 pr " guestfs_free_lvm_lv_list (r);\n";
3241 pr " if (r == NULL) return -1;\n";
3242 pr " print_stat (r);\n";
3246 pr " if (r == NULL) return -1;\n";
3247 pr " print_statvfs (r);\n";
3251 pr " if (r == NULL) return -1;\n";
3252 pr " print_table (r);\n";
3253 pr " free_strings (r);\n";
3260 (* run_action function *)
3261 pr "int run_action (const char *cmd, int argc, char *argv[])\n";
3264 fun (name, _, _, flags, _, _, _) ->
3265 let name2 = replace_char name '_' '-' in
3267 try find_map (function FishAlias n -> Some n | _ -> None) flags
3268 with Not_found -> name in
3270 pr "strcasecmp (cmd, \"%s\") == 0" name;
3271 if name <> name2 then
3272 pr " || strcasecmp (cmd, \"%s\") == 0" name2;
3273 if name <> alias then
3274 pr " || strcasecmp (cmd, \"%s\") == 0" alias;
3276 pr " return run_%s (cmd, argc, argv);\n" name;
3280 pr " fprintf (stderr, \"%%s: unknown command\\n\", cmd);\n";
3287 (* Readline completion for guestfish. *)
3288 and generate_fish_completion () =
3289 generate_header CStyle GPLv2;
3293 fun (_, _, _, flags, _, _, _) -> not (List.mem NotInFish flags)
3303 #ifdef HAVE_LIBREADLINE
3304 #include <readline/readline.h>
3309 #ifdef HAVE_LIBREADLINE
3311 static const char *commands[] = {
3314 (* Get the commands and sort them, including the aliases. *)
3317 fun (name, _, _, flags, _, _, _) ->
3318 let name2 = replace_char name '_' '-' in
3320 try find_map (function FishAlias n -> Some n | _ -> None) flags
3321 with Not_found -> name in
3323 if name <> alias then [name2; alias] else [name2]
3325 let commands = List.flatten commands in
3326 let commands = List.sort compare commands in
3328 List.iter (pr " \"%s\",\n") commands;
3334 generator (const char *text, int state)
3336 static int index, len;
3341 len = strlen (text);
3344 while ((name = commands[index]) != NULL) {
3346 if (strncasecmp (name, text, len) == 0)
3347 return strdup (name);
3353 #endif /* HAVE_LIBREADLINE */
3355 char **do_completion (const char *text, int start, int end)
3357 char **matches = NULL;
3359 #ifdef HAVE_LIBREADLINE
3361 matches = rl_completion_matches (text, generator);
3368 (* Generate the POD documentation for guestfish. *)
3369 and generate_fish_actions_pod () =
3370 let all_functions_sorted =
3372 fun (_, _, _, flags, _, _, _) -> not (List.mem NotInFish flags)
3373 ) all_functions_sorted in
3376 fun (name, style, _, flags, _, _, longdesc) ->
3377 let longdesc = replace_str longdesc "C<guestfs_" "C<" in
3378 let name = replace_char name '_' '-' in
3380 try find_map (function FishAlias n -> Some n | _ -> None) flags
3381 with Not_found -> name in
3383 pr "=head2 %s" name;
3384 if name <> alias then
3391 | String n -> pr " %s" n
3392 | OptString n -> pr " %s" n
3393 | StringList n -> pr " %s,..." n
3394 | Bool _ -> pr " true|false"
3395 | Int n -> pr " %s" n
3399 pr "%s\n\n" longdesc;
3401 if List.mem ProtocolLimitWarning flags then
3402 pr "%s\n\n" protocol_limit_warning;
3404 if List.mem DangerWillRobinson flags then
3405 pr "%s\n\n" danger_will_robinson
3406 ) all_functions_sorted
3408 (* Generate a C function prototype. *)
3409 and generate_prototype ?(extern = true) ?(static = false) ?(semicolon = true)
3410 ?(single_line = false) ?(newline = false) ?(in_daemon = false)
3412 ?handle name style =
3413 if extern then pr "extern ";
3414 if static then pr "static ";
3415 (match fst style with
3417 | RInt _ -> pr "int "
3418 | RInt64 _ -> pr "int64_t "
3419 | RBool _ -> pr "int "
3420 | RConstString _ -> pr "const char *"
3421 | RString _ -> pr "char *"
3422 | RStringList _ | RHashtable _ -> pr "char **"
3424 if not in_daemon then pr "struct guestfs_int_bool *"
3425 else pr "guestfs_%s_ret *" name
3427 if not in_daemon then pr "struct guestfs_lvm_pv_list *"
3428 else pr "guestfs_lvm_int_pv_list *"
3430 if not in_daemon then pr "struct guestfs_lvm_vg_list *"
3431 else pr "guestfs_lvm_int_vg_list *"
3433 if not in_daemon then pr "struct guestfs_lvm_lv_list *"
3434 else pr "guestfs_lvm_int_lv_list *"
3436 if not in_daemon then pr "struct guestfs_stat *"
3437 else pr "guestfs_int_stat *"
3439 if not in_daemon then pr "struct guestfs_statvfs *"
3440 else pr "guestfs_int_statvfs *"
3442 pr "%s%s (" prefix name;
3443 if handle = None && List.length (snd style) = 0 then
3446 let comma = ref false in
3449 | Some handle -> pr "guestfs_h *%s" handle; comma := true
3453 if single_line then pr ", " else pr ",\n\t\t"
3459 | String n -> next (); pr "const char *%s" n
3460 | OptString n -> next (); pr "const char *%s" n
3461 | StringList n -> next (); pr "char * const* const %s" n
3462 | Bool n -> next (); pr "int %s" n
3463 | Int n -> next (); pr "int %s" n
3467 if semicolon then pr ";";
3468 if newline then pr "\n"
3470 (* Generate C call arguments, eg "(handle, foo, bar)" *)
3471 and generate_call_args ?handle style =
3473 let comma = ref false in
3476 | Some handle -> pr "%s" handle; comma := true
3480 if !comma then pr ", ";
3487 | Int n -> pr "%s" n
3491 (* Generate the OCaml bindings interface. *)
3492 and generate_ocaml_mli () =
3493 generate_header OCamlStyle LGPLv2;
3496 (** For API documentation you should refer to the C API
3497 in the guestfs(3) manual page. The OCaml API uses almost
3498 exactly the same calls. *)
3501 (** A [guestfs_h] handle. *)
3503 exception Error of string
3504 (** This exception is raised when there is an error. *)
3506 val create : unit -> t
3508 val close : t -> unit
3509 (** Handles are closed by the garbage collector when they become
3510 unreferenced, but callers can also call this in order to
3511 provide predictable cleanup. *)
3514 generate_ocaml_lvm_structure_decls ();
3516 generate_ocaml_stat_structure_decls ();
3520 fun (name, style, _, _, _, shortdesc, _) ->
3521 generate_ocaml_prototype name style;
3522 pr "(** %s *)\n" shortdesc;
3526 (* Generate the OCaml bindings implementation. *)
3527 and generate_ocaml_ml () =
3528 generate_header OCamlStyle LGPLv2;
3532 exception Error of string
3533 external create : unit -> t = \"ocaml_guestfs_create\"
3534 external close : t -> unit = \"ocaml_guestfs_close\"
3537 Callback.register_exception \"ocaml_guestfs_error\" (Error \"\")
3541 generate_ocaml_lvm_structure_decls ();
3543 generate_ocaml_stat_structure_decls ();
3547 fun (name, style, _, _, _, shortdesc, _) ->
3548 generate_ocaml_prototype ~is_external:true name style;
3551 (* Generate the OCaml bindings C implementation. *)
3552 and generate_ocaml_c () =
3553 generate_header CStyle LGPLv2;
3560 #include <caml/config.h>
3561 #include <caml/alloc.h>
3562 #include <caml/callback.h>
3563 #include <caml/fail.h>
3564 #include <caml/memory.h>
3565 #include <caml/mlvalues.h>
3566 #include <caml/signals.h>
3568 #include <guestfs.h>
3570 #include \"guestfs_c.h\"
3572 /* Copy a hashtable of string pairs into an assoc-list. We return
3573 * the list in reverse order, but hashtables aren't supposed to be
3576 static CAMLprim value
3577 copy_table (char * const * argv)
3580 CAMLlocal5 (rv, pairv, kv, vv, cons);
3584 for (i = 0; argv[i] != NULL; i += 2) {
3585 kv = caml_copy_string (argv[i]);
3586 vv = caml_copy_string (argv[i+1]);
3587 pairv = caml_alloc (2, 0);
3588 Store_field (pairv, 0, kv);
3589 Store_field (pairv, 1, vv);
3590 cons = caml_alloc (2, 0);
3591 Store_field (cons, 1, rv);
3593 Store_field (cons, 0, pairv);
3601 (* LVM struct copy functions. *)
3604 let has_optpercent_col =
3605 List.exists (function (_, `OptPercent) -> true | _ -> false) cols in
3607 pr "static CAMLprim value\n";
3608 pr "copy_lvm_%s (const struct guestfs_lvm_%s *%s)\n" typ typ typ;
3610 pr " CAMLparam0 ();\n";
3611 if has_optpercent_col then
3612 pr " CAMLlocal3 (rv, v, v2);\n"
3614 pr " CAMLlocal2 (rv, v);\n";
3616 pr " rv = caml_alloc (%d, 0);\n" (List.length cols);
3621 pr " v = caml_copy_string (%s->%s);\n" typ name
3623 pr " v = caml_alloc_string (32);\n";
3624 pr " memcpy (String_val (v), %s->%s, 32);\n" typ name
3627 pr " v = caml_copy_int64 (%s->%s);\n" typ name
3628 | name, `OptPercent ->
3629 pr " if (%s->%s >= 0) { /* Some %s */\n" typ name name;
3630 pr " v2 = caml_copy_double (%s->%s);\n" typ name;
3631 pr " v = caml_alloc (1, 0);\n";
3632 pr " Store_field (v, 0, v2);\n";
3633 pr " } else /* None */\n";
3634 pr " v = Val_int (0);\n";
3636 pr " Store_field (rv, %d, v);\n" i
3638 pr " CAMLreturn (rv);\n";
3642 pr "static CAMLprim value\n";
3643 pr "copy_lvm_%s_list (const struct guestfs_lvm_%s_list *%ss)\n"
3646 pr " CAMLparam0 ();\n";
3647 pr " CAMLlocal2 (rv, v);\n";
3650 pr " if (%ss->len == 0)\n" typ;
3651 pr " CAMLreturn (Atom (0));\n";
3653 pr " rv = caml_alloc (%ss->len, 0);\n" typ;
3654 pr " for (i = 0; i < %ss->len; ++i) {\n" typ;
3655 pr " v = copy_lvm_%s (&%ss->val[i]);\n" typ typ;
3656 pr " caml_modify (&Field (rv, i), v);\n";
3658 pr " CAMLreturn (rv);\n";
3662 ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols];
3664 (* Stat copy functions. *)
3667 pr "static CAMLprim value\n";
3668 pr "copy_%s (const struct guestfs_%s *%s)\n" typ typ typ;
3670 pr " CAMLparam0 ();\n";
3671 pr " CAMLlocal2 (rv, v);\n";
3673 pr " rv = caml_alloc (%d, 0);\n" (List.length cols);
3678 pr " v = caml_copy_int64 (%s->%s);\n" typ name
3680 pr " Store_field (rv, %d, v);\n" i
3682 pr " CAMLreturn (rv);\n";
3685 ) ["stat", stat_cols; "statvfs", statvfs_cols];
3689 fun (name, style, _, _, _, _, _) ->
3691 "gv" :: List.map (fun arg -> name_of_argt arg ^ "v") (snd style) in
3693 pr "CAMLprim value\n";
3694 pr "ocaml_guestfs_%s (value %s" name (List.hd params);
3695 List.iter (pr ", value %s") (List.tl params);
3700 | p1 :: p2 :: p3 :: p4 :: p5 :: rest ->
3701 pr " CAMLparam5 (%s);\n" (String.concat ", " [p1; p2; p3; p4; p5]);
3702 pr " CAMLxparam%d (%s);\n"
3703 (List.length rest) (String.concat ", " rest)
3705 pr " CAMLparam%d (%s);\n" (List.length ps) (String.concat ", " ps)
3707 pr " CAMLlocal1 (rv);\n";
3710 pr " guestfs_h *g = Guestfs_val (gv);\n";
3711 pr " if (g == NULL)\n";
3712 pr " caml_failwith (\"%s: used handle after closing it\");\n" name;
3718 pr " const char *%s = String_val (%sv);\n" n n
3720 pr " const char *%s =\n" n;
3721 pr " %sv != Val_int (0) ? String_val (Field (%sv, 0)) : NULL;\n"
3724 pr " char **%s = ocaml_guestfs_strings_val (%sv);\n" n n
3726 pr " int %s = Bool_val (%sv);\n" n n
3728 pr " int %s = Int_val (%sv);\n" n n
3731 match fst style with
3732 | RErr -> pr " int r;\n"; "-1"
3733 | RInt _ -> pr " int r;\n"; "-1"
3734 | RInt64 _ -> pr " int64_t r;\n"; "-1"
3735 | RBool _ -> pr " int r;\n"; "-1"
3736 | RConstString _ -> pr " const char *r;\n"; "NULL"
3737 | RString _ -> pr " char *r;\n"; "NULL"
3743 pr " struct guestfs_int_bool *r;\n"; "NULL"
3745 pr " struct guestfs_lvm_pv_list *r;\n"; "NULL"
3747 pr " struct guestfs_lvm_vg_list *r;\n"; "NULL"
3749 pr " struct guestfs_lvm_lv_list *r;\n"; "NULL"
3751 pr " struct guestfs_stat *r;\n"; "NULL"
3753 pr " struct guestfs_statvfs *r;\n"; "NULL"
3760 pr " caml_enter_blocking_section ();\n";
3761 pr " r = guestfs_%s " name;
3762 generate_call_args ~handle:"g" style;
3764 pr " caml_leave_blocking_section ();\n";
3769 pr " ocaml_guestfs_free_strings (%s);\n" n;
3770 | String _ | OptString _ | Bool _ | Int _ -> ()
3773 pr " if (r == %s)\n" error_code;
3774 pr " ocaml_guestfs_raise_error (g, \"%s\");\n" name;
3777 (match fst style with
3778 | RErr -> pr " rv = Val_unit;\n"
3779 | RInt _ -> pr " rv = Val_int (r);\n"
3781 pr " rv = caml_copy_int64 (r);\n"
3782 | RBool _ -> pr " rv = Val_bool (r);\n"
3783 | RConstString _ -> pr " rv = caml_copy_string (r);\n"
3785 pr " rv = caml_copy_string (r);\n";
3788 pr " rv = caml_copy_string_array ((const char **) r);\n";
3789 pr " for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
3792 pr " rv = caml_alloc (2, 0);\n";
3793 pr " Store_field (rv, 0, Val_int (r->i));\n";
3794 pr " Store_field (rv, 1, Val_bool (r->b));\n";
3795 pr " guestfs_free_int_bool (r);\n";
3797 pr " rv = copy_lvm_pv_list (r);\n";
3798 pr " guestfs_free_lvm_pv_list (r);\n";
3800 pr " rv = copy_lvm_vg_list (r);\n";
3801 pr " guestfs_free_lvm_vg_list (r);\n";
3803 pr " rv = copy_lvm_lv_list (r);\n";
3804 pr " guestfs_free_lvm_lv_list (r);\n";
3806 pr " rv = copy_stat (r);\n";
3809 pr " rv = copy_statvfs (r);\n";
3812 pr " rv = copy_table (r);\n";
3813 pr " for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
3817 pr " CAMLreturn (rv);\n";
3821 if List.length params > 5 then (
3822 pr "CAMLprim value\n";
3823 pr "ocaml_guestfs_%s_byte (value *argv, int argn)\n" name;
3825 pr " return ocaml_guestfs_%s (argv[0]" name;
3826 iteri (fun i _ -> pr ", argv[%d]" i) (List.tl params);
3833 and generate_ocaml_lvm_structure_decls () =
3836 pr "type lvm_%s = {\n" typ;
3839 | name, `String -> pr " %s : string;\n" name
3840 | name, `UUID -> pr " %s : string;\n" name
3841 | name, `Bytes -> pr " %s : int64;\n" name
3842 | name, `Int -> pr " %s : int64;\n" name
3843 | name, `OptPercent -> pr " %s : float option;\n" name
3847 ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols]
3849 and generate_ocaml_stat_structure_decls () =
3852 pr "type %s = {\n" typ;
3855 | name, `Int -> pr " %s : int64;\n" name
3859 ) ["stat", stat_cols; "statvfs", statvfs_cols]
3861 and generate_ocaml_prototype ?(is_external = false) name style =
3862 if is_external then pr "external " else pr "val ";
3863 pr "%s : t -> " name;
3866 | String _ -> pr "string -> "
3867 | OptString _ -> pr "string option -> "
3868 | StringList _ -> pr "string array -> "
3869 | Bool _ -> pr "bool -> "
3870 | Int _ -> pr "int -> "
3872 (match fst style with
3873 | RErr -> pr "unit" (* all errors are turned into exceptions *)
3874 | RInt _ -> pr "int"
3875 | RInt64 _ -> pr "int64"
3876 | RBool _ -> pr "bool"
3877 | RConstString _ -> pr "string"
3878 | RString _ -> pr "string"
3879 | RStringList _ -> pr "string array"
3880 | RIntBool _ -> pr "int * bool"
3881 | RPVList _ -> pr "lvm_pv array"
3882 | RVGList _ -> pr "lvm_vg array"
3883 | RLVList _ -> pr "lvm_lv array"
3884 | RStat _ -> pr "stat"
3885 | RStatVFS _ -> pr "statvfs"
3886 | RHashtable _ -> pr "(string * string) list"
3888 if is_external then (
3890 if List.length (snd style) + 1 > 5 then
3891 pr "\"ocaml_guestfs_%s_byte\" " name;
3892 pr "\"ocaml_guestfs_%s\"" name
3896 (* Generate Perl xs code, a sort of crazy variation of C with macros. *)
3897 and generate_perl_xs () =
3898 generate_header CStyle LGPLv2;
3901 #include \"EXTERN.h\"
3905 #include <guestfs.h>
3908 #define PRId64 \"lld\"
3912 my_newSVll(long long val) {
3913 #ifdef USE_64_BIT_ALL
3914 return newSViv(val);
3918 len = snprintf(buf, 100, \"%%\" PRId64, val);
3919 return newSVpv(buf, len);
3924 #define PRIu64 \"llu\"
3928 my_newSVull(unsigned long long val) {
3929 #ifdef USE_64_BIT_ALL
3930 return newSVuv(val);
3934 len = snprintf(buf, 100, \"%%\" PRIu64, val);
3935 return newSVpv(buf, len);
3939 /* http://www.perlmonks.org/?node_id=680842 */
3941 XS_unpack_charPtrPtr (SV *arg) {
3946 if (!arg || !SvOK (arg) || !SvROK (arg) || SvTYPE (SvRV (arg)) != SVt_PVAV) {
3947 croak (\"array reference expected\");
3950 av = (AV *)SvRV (arg);
3951 ret = (char **)malloc (av_len (av) + 1 + 1);
3953 for (i = 0; i <= av_len (av); i++) {
3954 SV **elem = av_fetch (av, i, 0);
3956 if (!elem || !*elem)
3957 croak (\"missing element in list\");
3959 ret[i] = SvPV_nolen (*elem);
3967 MODULE = Sys::Guestfs PACKAGE = Sys::Guestfs
3972 RETVAL = guestfs_create ();
3974 croak (\"could not create guestfs handle\");
3975 guestfs_set_error_handler (RETVAL, NULL, NULL);
3988 fun (name, style, _, _, _, _, _) ->
3989 (match fst style with
3990 | RErr -> pr "void\n"
3991 | RInt _ -> pr "SV *\n"
3992 | RInt64 _ -> pr "SV *\n"
3993 | RBool _ -> pr "SV *\n"
3994 | RConstString _ -> pr "SV *\n"
3995 | RString _ -> pr "SV *\n"
3998 | RPVList _ | RVGList _ | RLVList _
3999 | RStat _ | RStatVFS _
4001 pr "void\n" (* all lists returned implictly on the stack *)
4003 (* Call and arguments. *)
4005 generate_call_args ~handle:"g" style;
4007 pr " guestfs_h *g;\n";
4010 | String n -> pr " char *%s;\n" n
4011 | OptString n -> pr " char *%s;\n" n
4012 | StringList n -> pr " char **%s;\n" n
4013 | Bool n -> pr " int %s;\n" n
4014 | Int n -> pr " int %s;\n" n
4017 let do_cleanups () =
4024 | StringList n -> pr " free (%s);\n" n
4029 (match fst style with
4034 pr " r = guestfs_%s " name;
4035 generate_call_args ~handle:"g" style;
4038 pr " if (r == -1)\n";
4039 pr " croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
4045 pr " %s = guestfs_%s " n name;
4046 generate_call_args ~handle:"g" style;
4049 pr " if (%s == -1)\n" n;
4050 pr " croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
4051 pr " RETVAL = newSViv (%s);\n" n;
4056 pr " int64_t %s;\n" n;
4058 pr " %s = guestfs_%s " n name;
4059 generate_call_args ~handle:"g" style;
4062 pr " if (%s == -1)\n" n;
4063 pr " croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
4064 pr " RETVAL = my_newSVll (%s);\n" n;
4069 pr " const char *%s;\n" n;
4071 pr " %s = guestfs_%s " n name;
4072 generate_call_args ~handle:"g" style;
4075 pr " if (%s == NULL)\n" n;
4076 pr " croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
4077 pr " RETVAL = newSVpv (%s, 0);\n" n;
4082 pr " char *%s;\n" n;
4084 pr " %s = guestfs_%s " n name;
4085 generate_call_args ~handle:"g" style;
4088 pr " if (%s == NULL)\n" n;
4089 pr " croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
4090 pr " RETVAL = newSVpv (%s, 0);\n" n;
4091 pr " free (%s);\n" n;
4094 | RStringList n | RHashtable n ->
4096 pr " char **%s;\n" n;
4099 pr " %s = guestfs_%s " n name;
4100 generate_call_args ~handle:"g" style;
4103 pr " if (%s == NULL)\n" n;
4104 pr " croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
4105 pr " for (n = 0; %s[n] != NULL; ++n) /**/;\n" n;
4106 pr " EXTEND (SP, n);\n";
4107 pr " for (i = 0; i < n; ++i) {\n";
4108 pr " PUSHs (sv_2mortal (newSVpv (%s[i], 0)));\n" n;
4109 pr " free (%s[i]);\n" n;
4111 pr " free (%s);\n" n;
4114 pr " struct guestfs_int_bool *r;\n";
4116 pr " r = guestfs_%s " name;
4117 generate_call_args ~handle:"g" style;
4120 pr " if (r == NULL)\n";
4121 pr " croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
4122 pr " EXTEND (SP, 2);\n";
4123 pr " PUSHs (sv_2mortal (newSViv (r->i)));\n";
4124 pr " PUSHs (sv_2mortal (newSViv (r->b)));\n";
4125 pr " guestfs_free_int_bool (r);\n";
4127 generate_perl_lvm_code "pv" pv_cols name style n do_cleanups
4129 generate_perl_lvm_code "vg" vg_cols name style n do_cleanups
4131 generate_perl_lvm_code "lv" lv_cols name style n do_cleanups
4133 generate_perl_stat_code "stat" stat_cols name style n do_cleanups
4135 generate_perl_stat_code
4136 "statvfs" statvfs_cols name style n do_cleanups
4142 and generate_perl_lvm_code typ cols name style n do_cleanups =
4144 pr " struct guestfs_lvm_%s_list *%s;\n" typ n;
4148 pr " %s = guestfs_%s " n name;
4149 generate_call_args ~handle:"g" style;
4152 pr " if (%s == NULL)\n" n;
4153 pr " croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
4154 pr " EXTEND (SP, %s->len);\n" n;
4155 pr " for (i = 0; i < %s->len; ++i) {\n" n;
4156 pr " hv = newHV ();\n";
4160 pr " (void) hv_store (hv, \"%s\", %d, newSVpv (%s->val[i].%s, 0), 0);\n"
4161 name (String.length name) n name
4163 pr " (void) hv_store (hv, \"%s\", %d, newSVpv (%s->val[i].%s, 32), 0);\n"
4164 name (String.length name) n name
4166 pr " (void) hv_store (hv, \"%s\", %d, my_newSVull (%s->val[i].%s), 0);\n"
4167 name (String.length name) n name
4169 pr " (void) hv_store (hv, \"%s\", %d, my_newSVll (%s->val[i].%s), 0);\n"
4170 name (String.length name) n name
4171 | name, `OptPercent ->
4172 pr " (void) hv_store (hv, \"%s\", %d, newSVnv (%s->val[i].%s), 0);\n"
4173 name (String.length name) n name
4175 pr " PUSHs (sv_2mortal ((SV *) hv));\n";
4177 pr " guestfs_free_lvm_%s_list (%s);\n" typ n
4179 and generate_perl_stat_code typ cols name style n do_cleanups =
4181 pr " struct guestfs_%s *%s;\n" typ n;
4183 pr " %s = guestfs_%s " n name;
4184 generate_call_args ~handle:"g" style;
4187 pr " if (%s == NULL)\n" n;
4188 pr " croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
4189 pr " EXTEND (SP, %d);\n" (List.length cols);
4193 pr " PUSHs (sv_2mortal (my_newSVll (%s->%s)));\n" n name
4195 pr " free (%s);\n" n
4197 (* Generate Sys/Guestfs.pm. *)
4198 and generate_perl_pm () =
4199 generate_header HashStyle LGPLv2;
4206 Sys::Guestfs - Perl bindings for libguestfs
4212 my $h = Sys::Guestfs->new ();
4213 $h->add_drive ('guest.img');
4216 $h->mount ('/dev/sda1', '/');
4217 $h->touch ('/hello');
4222 The C<Sys::Guestfs> module provides a Perl XS binding to the
4223 libguestfs API for examining and modifying virtual machine
4226 Amongst the things this is good for: making batch configuration
4227 changes to guests, getting disk used/free statistics (see also:
4228 virt-df), migrating between virtualization systems (see also:
4229 virt-p2v), performing partial backups, performing partial guest
4230 clones, cloning guests and changing registry/UUID/hostname info, and
4233 Libguestfs uses Linux kernel and qemu code, and can access any type of
4234 guest filesystem that Linux and qemu can, including but not limited
4235 to: ext2/3/4, btrfs, FAT and NTFS, LVM, many different disk partition
4236 schemes, qcow, qcow2, vmdk.
4238 Libguestfs provides ways to enumerate guest storage (eg. partitions,
4239 LVs, what filesystem is in each LV, etc.). It can also run commands
4240 in the context of the guest. Also you can access filesystems over FTP.
4244 All errors turn into calls to C<croak> (see L<Carp(3)>).
4252 package Sys::Guestfs;
4258 XSLoader::load ('Sys::Guestfs');
4260 =item $h = Sys::Guestfs->new ();
4262 Create a new guestfs handle.
4268 my $class = ref ($proto) || $proto;
4270 my $self = Sys::Guestfs::_create ();
4271 bless $self, $class;
4277 (* Actions. We only need to print documentation for these as
4278 * they are pulled in from the XS code automatically.
4281 fun (name, style, _, flags, _, _, longdesc) ->
4282 let longdesc = replace_str longdesc "C<guestfs_" "C<$h-E<gt>" in
4284 generate_perl_prototype name style;
4286 pr "%s\n\n" longdesc;
4287 if List.mem ProtocolLimitWarning flags then
4288 pr "%s\n\n" protocol_limit_warning;
4289 if List.mem DangerWillRobinson flags then
4290 pr "%s\n\n" danger_will_robinson
4291 ) all_functions_sorted;
4303 Copyright (C) 2009 Red Hat Inc.
4307 Please see the file COPYING.LIB for the full license.
4311 L<guestfs(3)>, L<guestfish(1)>.
4316 and generate_perl_prototype name style =
4317 (match fst style with
4323 | RString n -> pr "$%s = " n
4324 | RIntBool (n, m) -> pr "($%s, $%s) = " n m
4328 | RLVList n -> pr "@%s = " n
4331 | RHashtable n -> pr "%%%s = " n
4334 let comma = ref false in
4337 if !comma then pr ", ";
4340 | String n | OptString n | Bool n | Int n ->
4347 (* Generate Python C module. *)
4348 and generate_python_c () =
4349 generate_header CStyle LGPLv2;
4358 #include \"guestfs.h\"
4366 get_handle (PyObject *obj)
4369 assert (obj != Py_None);
4370 return ((Pyguestfs_Object *) obj)->g;
4374 put_handle (guestfs_h *g)
4378 PyCObject_FromVoidPtrAndDesc ((void *) g, (char *) \"guestfs_h\", NULL);
4381 /* This list should be freed (but not the strings) after use. */
4382 static const char **
4383 get_string_list (PyObject *obj)
4390 if (!PyList_Check (obj)) {
4391 PyErr_SetString (PyExc_RuntimeError, \"expecting a list parameter\");
4395 len = PyList_Size (obj);
4396 r = malloc (sizeof (char *) * (len+1));
4398 PyErr_SetString (PyExc_RuntimeError, \"get_string_list: out of memory\");
4402 for (i = 0; i < len; ++i)
4403 r[i] = PyString_AsString (PyList_GetItem (obj, i));
4410 put_string_list (char * const * const argv)
4415 for (argc = 0; argv[argc] != NULL; ++argc)
4418 list = PyList_New (argc);
4419 for (i = 0; i < argc; ++i)
4420 PyList_SetItem (list, i, PyString_FromString (argv[i]));
4426 put_table (char * const * const argv)
4428 PyObject *list, *item;
4431 for (argc = 0; argv[argc] != NULL; ++argc)
4434 list = PyList_New (argc >> 1);
4435 for (i = 0; i < argc; i += 2) {
4437 item = PyTuple_New (2);
4438 PyTuple_SetItem (item, 0, PyString_FromString (argv[i]));
4439 PyTuple_SetItem (item, 1, PyString_FromString (argv[i+1]));
4440 PyList_SetItem (list, i >> 1, item);
4447 free_strings (char **argv)
4451 for (argc = 0; argv[argc] != NULL; ++argc)
4457 py_guestfs_create (PyObject *self, PyObject *args)
4461 g = guestfs_create ();
4463 PyErr_SetString (PyExc_RuntimeError,
4464 \"guestfs.create: failed to allocate handle\");
4467 guestfs_set_error_handler (g, NULL, NULL);
4468 return put_handle (g);
4472 py_guestfs_close (PyObject *self, PyObject *args)
4477 if (!PyArg_ParseTuple (args, (char *) \"O:guestfs_close\", &py_g))
4479 g = get_handle (py_g);
4483 Py_INCREF (Py_None);
4489 (* LVM structures, turned into Python dictionaries. *)
4492 pr "static PyObject *\n";
4493 pr "put_lvm_%s (struct guestfs_lvm_%s *%s)\n" typ typ typ;
4495 pr " PyObject *dict;\n";
4497 pr " dict = PyDict_New ();\n";
4501 pr " PyDict_SetItemString (dict, \"%s\",\n" name;
4502 pr " PyString_FromString (%s->%s));\n"
4505 pr " PyDict_SetItemString (dict, \"%s\",\n" name;
4506 pr " PyString_FromStringAndSize (%s->%s, 32));\n"
4509 pr " PyDict_SetItemString (dict, \"%s\",\n" name;
4510 pr " PyLong_FromUnsignedLongLong (%s->%s));\n"
4513 pr " PyDict_SetItemString (dict, \"%s\",\n" name;
4514 pr " PyLong_FromLongLong (%s->%s));\n"
4516 | name, `OptPercent ->
4517 pr " if (%s->%s >= 0)\n" typ name;
4518 pr " PyDict_SetItemString (dict, \"%s\",\n" name;
4519 pr " PyFloat_FromDouble ((double) %s->%s));\n"
4522 pr " Py_INCREF (Py_None);\n";
4523 pr " PyDict_SetItemString (dict, \"%s\", Py_None);" name;
4526 pr " return dict;\n";
4530 pr "static PyObject *\n";
4531 pr "put_lvm_%s_list (struct guestfs_lvm_%s_list *%ss)\n" typ typ typ;
4533 pr " PyObject *list;\n";
4536 pr " list = PyList_New (%ss->len);\n" typ;
4537 pr " for (i = 0; i < %ss->len; ++i)\n" typ;
4538 pr " PyList_SetItem (list, i, put_lvm_%s (&%ss->val[i]));\n" typ typ;
4539 pr " return list;\n";
4542 ) ["pv", pv_cols; "vg", vg_cols; "lv", lv_cols];
4544 (* Stat structures, turned into Python dictionaries. *)
4547 pr "static PyObject *\n";
4548 pr "put_%s (struct guestfs_%s *%s)\n" typ typ typ;
4550 pr " PyObject *dict;\n";
4552 pr " dict = PyDict_New ();\n";
4556 pr " PyDict_SetItemString (dict, \"%s\",\n" name;
4557 pr " PyLong_FromLongLong (%s->%s));\n"
4560 pr " return dict;\n";
4563 ) ["stat", stat_cols; "statvfs", statvfs_cols];
4565 (* Python wrapper functions. *)
4567 fun (name, style, _, _, _, _, _) ->
4568 pr "static PyObject *\n";
4569 pr "py_guestfs_%s (PyObject *self, PyObject *args)\n" name;
4572 pr " PyObject *py_g;\n";
4573 pr " guestfs_h *g;\n";
4574 pr " PyObject *py_r;\n";
4577 match fst style with
4578 | RErr | RInt _ | RBool _ -> pr " int r;\n"; "-1"
4579 | RInt64 _ -> pr " int64_t r;\n"; "-1"
4580 | RConstString _ -> pr " const char *r;\n"; "NULL"
4581 | RString _ -> pr " char *r;\n"; "NULL"
4582 | RStringList _ | RHashtable _ -> pr " char **r;\n"; "NULL"
4583 | RIntBool _ -> pr " struct guestfs_int_bool *r;\n"; "NULL"
4584 | RPVList n -> pr " struct guestfs_lvm_pv_list *r;\n"; "NULL"
4585 | RVGList n -> pr " struct guestfs_lvm_vg_list *r;\n"; "NULL"
4586 | RLVList n -> pr " struct guestfs_lvm_lv_list *r;\n"; "NULL"
4587 | RStat n -> pr " struct guestfs_stat *r;\n"; "NULL"
4588 | RStatVFS n -> pr " struct guestfs_statvfs *r;\n"; "NULL" in
4592 | String n -> pr " const char *%s;\n" n
4593 | OptString n -> pr " const char *%s;\n" n
4595 pr " PyObject *py_%s;\n" n;
4596 pr " const char **%s;\n" n
4597 | Bool n -> pr " int %s;\n" n
4598 | Int n -> pr " int %s;\n" n
4603 (* Convert the parameters. *)
4604 pr " if (!PyArg_ParseTuple (args, (char *) \"O";
4607 | String _ -> pr "s"
4608 | OptString _ -> pr "z"
4609 | StringList _ -> pr "O"
4610 | Bool _ -> pr "i" (* XXX Python has booleans? *)
4613 pr ":guestfs_%s\",\n" name;
4617 | String n -> pr ", &%s" n
4618 | OptString n -> pr ", &%s" n
4619 | StringList n -> pr ", &py_%s" n
4620 | Bool n -> pr ", &%s" n
4621 | Int n -> pr ", &%s" n
4625 pr " return NULL;\n";
4627 pr " g = get_handle (py_g);\n";
4630 | String _ | OptString _ | Bool _ | Int _ -> ()
4632 pr " %s = get_string_list (py_%s);\n" n n;
4633 pr " if (!%s) return NULL;\n" n
4638 pr " r = guestfs_%s " name;
4639 generate_call_args ~handle:"g" style;
4644 | String _ | OptString _ | Bool _ | Int _ -> ()
4646 pr " free (%s);\n" n
4649 pr " if (r == %s) {\n" error_code;
4650 pr " PyErr_SetString (PyExc_RuntimeError, guestfs_last_error (g));\n";
4651 pr " return NULL;\n";
4655 (match fst style with
4657 pr " Py_INCREF (Py_None);\n";
4658 pr " py_r = Py_None;\n"
4660 | RBool _ -> pr " py_r = PyInt_FromLong ((long) r);\n"
4661 | RInt64 _ -> pr " py_r = PyLong_FromLongLong (r);\n"
4662 | RConstString _ -> pr " py_r = PyString_FromString (r);\n"
4664 pr " py_r = PyString_FromString (r);\n";
4667 pr " py_r = put_string_list (r);\n";
4668 pr " free_strings (r);\n"
4670 pr " py_r = PyTuple_New (2);\n";
4671 pr " PyTuple_SetItem (py_r, 0, PyInt_FromLong ((long) r->i));\n";
4672 pr " PyTuple_SetItem (py_r, 1, PyInt_FromLong ((long) r->b));\n";
4673 pr " guestfs_free_int_bool (r);\n"
4675 pr " py_r = put_lvm_pv_list (r);\n";
4676 pr " guestfs_free_lvm_pv_list (r);\n"
4678 pr " py_r = put_lvm_vg_list (r);\n";
4679 pr " guestfs_free_lvm_vg_list (r);\n"
4681 pr " py_r = put_lvm_lv_list (r);\n";
4682 pr " guestfs_free_lvm_lv_list (r);\n"
4684 pr " py_r = put_stat (r);\n";
4687 pr " py_r = put_statvfs (r);\n";
4690 pr " py_r = put_table (r);\n";
4691 pr " free_strings (r);\n"
4694 pr " return py_r;\n";
4699 (* Table of functions. *)
4700 pr "static PyMethodDef methods[] = {\n";
4701 pr " { (char *) \"create\", py_guestfs_create, METH_VARARGS, NULL },\n";
4702 pr " { (char *) \"close\", py_guestfs_close, METH_VARARGS, NULL },\n";
4704 fun (name, _, _, _, _, _, _) ->
4705 pr " { (char *) \"%s\", py_guestfs_%s, METH_VARARGS, NULL },\n"
4708 pr " { NULL, NULL, 0, NULL }\n";
4712 (* Init function. *)
4715 initlibguestfsmod (void)
4717 static int initialized = 0;
4719 if (initialized) return;
4720 Py_InitModule ((char *) \"libguestfsmod\", methods);
4725 (* Generate Python module. *)
4726 and generate_python_py () =
4727 generate_header HashStyle LGPLv2;
4730 u\"\"\"Python bindings for libguestfs
4733 g = guestfs.GuestFS ()
4734 g.add_drive (\"guest.img\")
4737 parts = g.list_partitions ()
4739 The guestfs module provides a Python binding to the libguestfs API
4740 for examining and modifying virtual machine disk images.
4742 Amongst the things this is good for: making batch configuration
4743 changes to guests, getting disk used/free statistics (see also:
4744 virt-df), migrating between virtualization systems (see also:
4745 virt-p2v), performing partial backups, performing partial guest
4746 clones, cloning guests and changing registry/UUID/hostname info, and
4749 Libguestfs uses Linux kernel and qemu code, and can access any type of
4750 guest filesystem that Linux and qemu can, including but not limited
4751 to: ext2/3/4, btrfs, FAT and NTFS, LVM, many different disk partition
4752 schemes, qcow, qcow2, vmdk.
4754 Libguestfs provides ways to enumerate guest storage (eg. partitions,
4755 LVs, what filesystem is in each LV, etc.). It can also run commands
4756 in the context of the guest. Also you can access filesystems over FTP.
4758 Errors which happen while using the API are turned into Python
4759 RuntimeError exceptions.
4761 To create a guestfs handle you usually have to perform the following
4764 # Create the handle, call add_drive at least once, and possibly
4765 # several times if the guest has multiple block devices:
4766 g = guestfs.GuestFS ()
4767 g.add_drive (\"guest.img\")
4769 # Launch the qemu subprocess and wait for it to become ready:
4773 # Now you can issue commands, for example:
4778 import libguestfsmod
4781 \"\"\"Instances of this class are libguestfs API handles.\"\"\"
4783 def __init__ (self):
4784 \"\"\"Create a new libguestfs handle.\"\"\"
4785 self._o = libguestfsmod.create ()
4788 libguestfsmod.close (self._o)
4793 fun (name, style, _, flags, _, _, longdesc) ->
4794 let doc = replace_str longdesc "C<guestfs_" "C<g." in
4796 match fst style with
4797 | RErr | RInt _ | RInt64 _ | RBool _ | RConstString _
4800 doc ^ "\n\nThis function returns a list of strings."
4802 doc ^ "\n\nThis function returns a tuple (int, bool).\n"
4804 doc ^ "\n\nThis function returns a list of PVs. Each PV is represented as a dictionary."
4806 doc ^ "\n\nThis function returns a list of VGs. Each VG is represented as a dictionary."
4808 doc ^ "\n\nThis function returns a list of LVs. Each LV is represented as a dictionary."
4810 doc ^ "\n\nThis function returns a dictionary, with keys matching the various fields in the stat structure."
4812 doc ^ "\n\nThis function returns a dictionary, with keys matching the various fields in the statvfs structure."
4814 doc ^ "\n\nThis function returns a dictionary." in
4816 if List.mem ProtocolLimitWarning flags then
4817 doc ^ "\n\n" ^ protocol_limit_warning
4820 if List.mem DangerWillRobinson flags then
4821 doc ^ "\n\n" ^ danger_will_robinson
4823 let doc = pod2text ~width:60 name doc in
4824 let doc = List.map (fun line -> replace_str line "\\" "\\\\") doc in
4825 let doc = String.concat "\n " doc in
4828 generate_call_args ~handle:"self" style;
4830 pr " u\"\"\"%s\"\"\"\n" doc;
4831 pr " return libguestfsmod.%s " name;
4832 generate_call_args ~handle:"self._o" style;
4837 (* Useful if you need the longdesc POD text as plain text. Returns a
4840 and pod2text ~width name longdesc =
4841 let filename, chan = Filename.open_temp_file "gen" ".tmp" in
4842 fprintf chan "=head1 %s\n\n%s\n" name longdesc;
4844 let cmd = sprintf "pod2text -w %d %s" width (Filename.quote filename) in
4845 let chan = Unix.open_process_in cmd in
4846 let lines = ref [] in
4848 let line = input_line chan in
4849 if i = 1 then (* discard the first line of output *)
4852 let line = triml line in
4853 lines := line :: !lines;
4856 let lines = try loop 1 with End_of_file -> List.rev !lines in
4857 Unix.unlink filename;
4858 match Unix.close_process_in chan with
4859 | Unix.WEXITED 0 -> lines
4861 failwithf "pod2text: process exited with non-zero status (%d)" i
4862 | Unix.WSIGNALED i | Unix.WSTOPPED i ->
4863 failwithf "pod2text: process signalled or stopped by signal %d" i
4865 let output_to filename =
4866 let filename_new = filename ^ ".new" in
4867 chan := open_out filename_new;
4871 Unix.rename filename_new filename;
4872 printf "written %s\n%!" filename;
4880 if not (Sys.file_exists "configure.ac") then (
4882 You are probably running this from the wrong directory.
4883 Run it from the top source directory using the command
4889 let close = output_to "src/guestfs_protocol.x" in
4893 let close = output_to "src/guestfs-structs.h" in
4894 generate_structs_h ();
4897 let close = output_to "src/guestfs-actions.h" in
4898 generate_actions_h ();
4901 let close = output_to "src/guestfs-actions.c" in
4902 generate_client_actions ();
4905 let close = output_to "daemon/actions.h" in
4906 generate_daemon_actions_h ();
4909 let close = output_to "daemon/stubs.c" in
4910 generate_daemon_actions ();
4913 let close = output_to "tests.c" in
4917 let close = output_to "fish/cmds.c" in
4918 generate_fish_cmds ();
4921 let close = output_to "fish/completion.c" in
4922 generate_fish_completion ();
4925 let close = output_to "guestfs-structs.pod" in
4926 generate_structs_pod ();
4929 let close = output_to "guestfs-actions.pod" in
4930 generate_actions_pod ();
4933 let close = output_to "guestfish-actions.pod" in
4934 generate_fish_actions_pod ();
4937 let close = output_to "ocaml/guestfs.mli" in
4938 generate_ocaml_mli ();
4941 let close = output_to "ocaml/guestfs.ml" in
4942 generate_ocaml_ml ();
4945 let close = output_to "ocaml/guestfs_c_actions.c" in
4946 generate_ocaml_c ();
4949 let close = output_to "perl/Guestfs.xs" in
4950 generate_perl_xs ();
4953 let close = output_to "perl/lib/Sys/Guestfs.pm" in
4954 generate_perl_pm ();
4957 let close = output_to "python/guestfs-py.c" in
4958 generate_python_c ();
4961 let close = output_to "python/guestfs.py" in
4962 generate_python_py ();