8751bb5a23c36d5d7c63c010b40abe9d86b3dec7
[libguestfs.git] / generator.ml
1 #!/usr/bin/env ocaml
2 (* libguestfs
3  * Copyright (C) 2009 Red Hat Inc.
4  *
5  * This program is free software; you can redistribute it and/or modify
6  * it under the terms of the GNU General Public License as published by
7  * the Free Software Foundation; either version 2 of the License, or
8  * (at your option) any later version.
9  *
10  * This program is distributed in the hope that it will be useful,
11  * but WITHOUT ANY WARRANTY; without even the implied warranty of
12  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13  * GNU General Public License for more details.
14  *
15  * You should have received a copy of the GNU General Public License
16  * along with this program; if not, write to the Free Software
17  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
18  *)
19
20 (* This script generates a large amount of code and documentation for
21  * all the daemon actions.
22  *
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.
26  *
27  * After editing this file, run it (./src/generator.ml) to regenerate all the
28  * output files.  Note that if you are using a separate build directory you
29  * must run generator.ml from the _source_ directory.
30  *
31  * IMPORTANT: This script should NOT print any warnings.  If it prints
32  * warnings, you should treat them as errors.
33  * [Need to add -warn-error to ocaml command line]
34  *)
35
36 #load "unix.cma";;
37 #load "str.cma";;
38
39 open Printf
40
41 type style = ret * args
42 and ret =
43     (* "RErr" as a return value means an int used as a simple error
44      * indication, ie. 0 or -1.
45      *)
46   | RErr
47     (* "RInt" as a return value means an int which is -1 for error
48      * or any value >= 0 on success.  Only use this for smallish
49      * positive ints (0 <= i < 2^30).
50      *)
51   | RInt of string
52     (* "RInt64" is the same as RInt, but is guaranteed to be able
53      * to return a full 64 bit value, _except_ that -1 means error
54      * (so -1 cannot be a valid, non-error return value).
55      *)
56   | RInt64 of string
57     (* "RBool" is a bool return value which can be true/false or
58      * -1 for error.
59      *)
60   | RBool of string
61     (* "RConstString" is a string that refers to a constant value.
62      * Try to avoid using this.  In particular you cannot use this
63      * for values returned from the daemon, because there is no
64      * thread-safe way to return them in the C API.
65      *)
66   | RConstString of string
67     (* "RString" and "RStringList" are caller-frees. *)
68   | RString of string
69   | RStringList of string
70     (* "RStruct" is a function which returns a single named structure
71      * or an error indication (in C, a struct, and in other languages
72      * with varying representations, but usually very efficient).  See
73      * after the function list below for the structures. 
74      *)
75   | RStruct of string * string          (* name of retval, name of struct *)
76     (* "RStructList" is a function which returns either a list/array
77      * of structures (could be zero-length), or an error indication.
78      *)
79   | RStructList of string * string      (* name of retval, name of struct *)
80     (* Key-value pairs of untyped strings.  Turns into a hashtable or
81      * dictionary in languages which support it.  DON'T use this as a
82      * general "bucket" for results.  Prefer a stronger typed return
83      * value if one is available, or write a custom struct.  Don't use
84      * this if the list could potentially be very long, since it is
85      * inefficient.  Keys should be unique.  NULLs are not permitted.
86      *)
87   | RHashtable of string
88     (* "RBufferOut" is handled almost exactly like RString, but
89      * it allows the string to contain arbitrary 8 bit data including
90      * ASCII NUL.  In the C API this causes an implicit extra parameter
91      * to be added of type <size_t *size_r>.  The extra parameter
92      * returns the actual size of the return buffer in bytes.
93      *
94      * Other programming languages support strings with arbitrary 8 bit
95      * data.
96      *
97      * At the RPC layer we have to use the opaque<> type instead of
98      * string<>.  Returned data is still limited to the max message
99      * size (ie. ~ 2 MB).
100      *)
101   | RBufferOut of string
102
103 and args = argt list    (* Function parameters, guestfs handle is implicit. *)
104
105     (* Note in future we should allow a "variable args" parameter as
106      * the final parameter, to allow commands like
107      *   chmod mode file [file(s)...]
108      * This is not implemented yet, but many commands (such as chmod)
109      * are currently defined with the argument order keeping this future
110      * possibility in mind.
111      *)
112 and argt =
113   | String of string    (* const char *name, cannot be NULL *)
114   | OptString of string (* const char *name, may be NULL *)
115   | StringList of string(* list of strings (each string cannot be NULL) *)
116   | Bool of string      (* boolean *)
117   | Int of string       (* int (smallish ints, signed, <= 31 bits) *)
118     (* These are treated as filenames (simple string parameters) in
119      * the C API and bindings.  But in the RPC protocol, we transfer
120      * the actual file content up to or down from the daemon.
121      * FileIn: local machine -> daemon (in request)
122      * FileOut: daemon -> local machine (in reply)
123      * In guestfish (only), the special name "-" means read from
124      * stdin or write to stdout.
125      *)
126   | FileIn of string
127   | FileOut of string
128 (* Not implemented:
129     (* Opaque buffer which can contain arbitrary 8 bit data.
130      * In the C API, this is expressed as <char *, int> pair.
131      * Most other languages have a string type which can contain
132      * ASCII NUL.  We use whatever type is appropriate for each
133      * language.
134      * Buffers are limited by the total message size.  To transfer
135      * large blocks of data, use FileIn/FileOut parameters instead.
136      * To return an arbitrary buffer, use RBufferOut.
137      *)
138   | BufferIn of string
139 *)
140
141 type flags =
142   | ProtocolLimitWarning  (* display warning about protocol size limits *)
143   | DangerWillRobinson    (* flags particularly dangerous commands *)
144   | FishAlias of string   (* provide an alias for this cmd in guestfish *)
145   | FishAction of string  (* call this function in guestfish *)
146   | NotInFish             (* do not export via guestfish *)
147   | NotInDocs             (* do not add this function to documentation *)
148
149 let protocol_limit_warning =
150   "Because of the message protocol, there is a transfer limit
151 of somewhere between 2MB and 4MB.  To transfer large files you should use
152 FTP."
153
154 let danger_will_robinson =
155   "B<This command is dangerous.  Without careful use you
156 can easily destroy all your data>."
157
158 (* You can supply zero or as many tests as you want per API call.
159  *
160  * Note that the test environment has 3 block devices, of size 500MB,
161  * 50MB and 10MB (respectively /dev/sda, /dev/sdb, /dev/sdc), and
162  * a fourth squashfs block device with some known files on it (/dev/sdd).
163  *
164  * Note for partitioning purposes, the 500MB device has 1015 cylinders.
165  * Number of cylinders was 63 for IDE emulated disks with precisely
166  * the same size.  How exactly this is calculated is a mystery.
167  *
168  * The squashfs block device (/dev/sdd) comes from images/test.sqsh.
169  *
170  * To be able to run the tests in a reasonable amount of time,
171  * the virtual machine and block devices are reused between tests.
172  * So don't try testing kill_subprocess :-x
173  *
174  * Between each test we blockdev-setrw, umount-all, lvm-remove-all.
175  *
176  * Don't assume anything about the previous contents of the block
177  * devices.  Use 'Init*' to create some initial scenarios.
178  *
179  * You can add a prerequisite clause to any individual test.  This
180  * is a run-time check, which, if it fails, causes the test to be
181  * skipped.  Useful if testing a command which might not work on
182  * all variations of libguestfs builds.  A test that has prerequisite
183  * of 'Always' is run unconditionally.
184  *
185  * In addition, packagers can skip individual tests by setting the
186  * environment variables:     eg:
187  *   SKIP_TEST_<CMD>_<NUM>=1  SKIP_TEST_COMMAND_3=1  (skips test #3 of command)
188  *   SKIP_TEST_<CMD>=1        SKIP_TEST_ZEROFREE=1   (skips all zerofree tests)
189  *)
190 type tests = (test_init * test_prereq * test) list
191 and test =
192     (* Run the command sequence and just expect nothing to fail. *)
193   | TestRun of seq
194     (* Run the command sequence and expect the output of the final
195      * command to be the string.
196      *)
197   | TestOutput of seq * string
198     (* Run the command sequence and expect the output of the final
199      * command to be the list of strings.
200      *)
201   | TestOutputList of seq * string list
202     (* Run the command sequence and expect the output of the final
203      * command to be the list of block devices (could be either
204      * "/dev/sd.." or "/dev/hd.." form - we don't check the 5th
205      * character of each string).
206      *)
207   | TestOutputListOfDevices of seq * string list
208     (* Run the command sequence and expect the output of the final
209      * command to be the integer.
210      *)
211   | TestOutputInt of seq * int
212     (* Run the command sequence and expect the output of the final
213      * command to be <op> <int>, eg. ">=", "1".
214      *)
215   | TestOutputIntOp of seq * string * int
216     (* Run the command sequence and expect the output of the final
217      * command to be a true value (!= 0 or != NULL).
218      *)
219   | TestOutputTrue of seq
220     (* Run the command sequence and expect the output of the final
221      * command to be a false value (== 0 or == NULL, but not an error).
222      *)
223   | TestOutputFalse of seq
224     (* Run the command sequence and expect the output of the final
225      * command to be a list of the given length (but don't care about
226      * content).
227      *)
228   | TestOutputLength of seq * int
229     (* Run the command sequence and expect the output of the final
230      * command to be a structure.
231      *)
232   | TestOutputStruct of seq * test_field_compare list
233     (* Run the command sequence and expect the final command (only)
234      * to fail.
235      *)
236   | TestLastFail of seq
237
238 and test_field_compare =
239   | CompareWithInt of string * int
240   | CompareWithIntOp of string * string * int
241   | CompareWithString of string * string
242   | CompareFieldsIntEq of string * string
243   | CompareFieldsStrEq of string * string
244
245 (* Test prerequisites. *)
246 and test_prereq =
247     (* Test always runs. *)
248   | Always
249     (* Test is currently disabled - eg. it fails, or it tests some
250      * unimplemented feature.
251      *)
252   | Disabled
253     (* 'string' is some C code (a function body) that should return
254      * true or false.  The test will run if the code returns true.
255      *)
256   | If of string
257     (* As for 'If' but the test runs _unless_ the code returns true. *)
258   | Unless of string
259
260 (* Some initial scenarios for testing. *)
261 and test_init =
262     (* Do nothing, block devices could contain random stuff including
263      * LVM PVs, and some filesystems might be mounted.  This is usually
264      * a bad idea.
265      *)
266   | InitNone
267     (* Block devices are empty and no filesystems are mounted. *)
268   | InitEmpty
269     (* /dev/sda contains a single partition /dev/sda1, which is formatted
270      * as ext2, empty [except for lost+found] and mounted on /.
271      * /dev/sdb and /dev/sdc may have random content.
272      * No LVM.
273      *)
274   | InitBasicFS
275     (* /dev/sda:
276      *   /dev/sda1 (is a PV):
277      *     /dev/VG/LV (size 8MB):
278      *       formatted as ext2, empty [except for lost+found], mounted on /
279      * /dev/sdb and /dev/sdc may have random content.
280      *)
281   | InitBasicFSonLVM
282
283 (* Sequence of commands for testing. *)
284 and seq = cmd list
285 and cmd = string list
286
287 (* Note about long descriptions: When referring to another
288  * action, use the format C<guestfs_other> (ie. the full name of
289  * the C function).  This will be replaced as appropriate in other
290  * language bindings.
291  *
292  * Apart from that, long descriptions are just perldoc paragraphs.
293  *)
294
295 (* These test functions are used in the language binding tests. *)
296
297 let test_all_args = [
298   String "str";
299   OptString "optstr";
300   StringList "strlist";
301   Bool "b";
302   Int "integer";
303   FileIn "filein";
304   FileOut "fileout";
305 ]
306
307 let test_all_rets = [
308   (* except for RErr, which is tested thoroughly elsewhere *)
309   "test0rint",         RInt "valout";
310   "test0rint64",       RInt64 "valout";
311   "test0rbool",        RBool "valout";
312   "test0rconststring", RConstString "valout";
313   "test0rstring",      RString "valout";
314   "test0rstringlist",  RStringList "valout";
315   "test0rstruct",      RStruct ("valout", "lvm_pv");
316   "test0rstructlist",  RStructList ("valout", "lvm_pv");
317   "test0rhashtable",   RHashtable "valout";
318 ]
319
320 let test_functions = [
321   ("test0", (RErr, test_all_args), -1, [NotInFish; NotInDocs],
322    [],
323    "internal test function - do not use",
324    "\
325 This is an internal test function which is used to test whether
326 the automatically generated bindings can handle every possible
327 parameter type correctly.
328
329 It echos the contents of each parameter to stdout.
330
331 You probably don't want to call this function.");
332 ] @ List.flatten (
333   List.map (
334     fun (name, ret) ->
335       [(name, (ret, [String "val"]), -1, [NotInFish; NotInDocs],
336         [],
337         "internal test function - do not use",
338         "\
339 This is an internal test function which is used to test whether
340 the automatically generated bindings can handle every possible
341 return type correctly.
342
343 It converts string C<val> to the return type.
344
345 You probably don't want to call this function.");
346        (name ^ "err", (ret, []), -1, [NotInFish; NotInDocs],
347         [],
348         "internal test function - do not use",
349         "\
350 This is an internal test function which is used to test whether
351 the automatically generated bindings can handle every possible
352 return type correctly.
353
354 This function always returns an error.
355
356 You probably don't want to call this function.")]
357   ) test_all_rets
358 )
359
360 (* non_daemon_functions are any functions which don't get processed
361  * in the daemon, eg. functions for setting and getting local
362  * configuration values.
363  *)
364
365 let non_daemon_functions = test_functions @ [
366   ("launch", (RErr, []), -1, [FishAlias "run"; FishAction "launch"],
367    [],
368    "launch the qemu subprocess",
369    "\
370 Internally libguestfs is implemented by running a virtual machine
371 using L<qemu(1)>.
372
373 You should call this after configuring the handle
374 (eg. adding drives) but before performing any actions.");
375
376   ("wait_ready", (RErr, []), -1, [NotInFish],
377    [],
378    "wait until the qemu subprocess launches",
379    "\
380 Internally libguestfs is implemented by running a virtual machine
381 using L<qemu(1)>.
382
383 You should call this after C<guestfs_launch> to wait for the launch
384 to complete.");
385
386   ("kill_subprocess", (RErr, []), -1, [],
387    [],
388    "kill the qemu subprocess",
389    "\
390 This kills the qemu subprocess.  You should never need to call this.");
391
392   ("add_drive", (RErr, [String "filename"]), -1, [FishAlias "add"],
393    [],
394    "add an image to examine or modify",
395    "\
396 This function adds a virtual machine disk image C<filename> to the
397 guest.  The first time you call this function, the disk appears as IDE
398 disk 0 (C</dev/sda>) in the guest, the second time as C</dev/sdb>, and
399 so on.
400
401 You don't necessarily need to be root when using libguestfs.  However
402 you obviously do need sufficient permissions to access the filename
403 for whatever operations you want to perform (ie. read access if you
404 just want to read the image or write access if you want to modify the
405 image).
406
407 This is equivalent to the qemu parameter
408 C<-drive file=filename,cache=off,if=...>.
409
410 Note that this call checks for the existence of C<filename>.  This
411 stops you from specifying other types of drive which are supported
412 by qemu such as C<nbd:> and C<http:> URLs.  To specify those, use
413 the general C<guestfs_config> call instead.");
414
415   ("add_cdrom", (RErr, [String "filename"]), -1, [FishAlias "cdrom"],
416    [],
417    "add a CD-ROM disk image to examine",
418    "\
419 This function adds a virtual CD-ROM disk image to the guest.
420
421 This is equivalent to the qemu parameter C<-cdrom filename>.
422
423 Note that this call checks for the existence of C<filename>.  This
424 stops you from specifying other types of drive which are supported
425 by qemu such as C<nbd:> and C<http:> URLs.  To specify those, use
426 the general C<guestfs_config> call instead.");
427
428   ("add_drive_ro", (RErr, [String "filename"]), -1, [FishAlias "add-ro"],
429    [],
430    "add a drive in snapshot mode (read-only)",
431    "\
432 This adds a drive in snapshot mode, making it effectively
433 read-only.
434
435 Note that writes to the device are allowed, and will be seen for
436 the duration of the guestfs handle, but they are written
437 to a temporary file which is discarded as soon as the guestfs
438 handle is closed.  We don't currently have any method to enable
439 changes to be committed, although qemu can support this.
440
441 This is equivalent to the qemu parameter
442 C<-drive file=filename,snapshot=on,if=...>.
443
444 Note that this call checks for the existence of C<filename>.  This
445 stops you from specifying other types of drive which are supported
446 by qemu such as C<nbd:> and C<http:> URLs.  To specify those, use
447 the general C<guestfs_config> call instead.");
448
449   ("config", (RErr, [String "qemuparam"; OptString "qemuvalue"]), -1, [],
450    [],
451    "add qemu parameters",
452    "\
453 This can be used to add arbitrary qemu command line parameters
454 of the form C<-param value>.  Actually it's not quite arbitrary - we
455 prevent you from setting some parameters which would interfere with
456 parameters that we use.
457
458 The first character of C<param> string must be a C<-> (dash).
459
460 C<value> can be NULL.");
461
462   ("set_qemu", (RErr, [String "qemu"]), -1, [FishAlias "qemu"],
463    [],
464    "set the qemu binary",
465    "\
466 Set the qemu binary that we will use.
467
468 The default is chosen when the library was compiled by the
469 configure script.
470
471 You can also override this by setting the C<LIBGUESTFS_QEMU>
472 environment variable.
473
474 Setting C<qemu> to C<NULL> restores the default qemu binary.");
475
476   ("get_qemu", (RConstString "qemu", []), -1, [],
477    [InitNone, Always, TestRun (
478       [["get_qemu"]])],
479    "get the qemu binary",
480    "\
481 Return the current qemu binary.
482
483 This is always non-NULL.  If it wasn't set already, then this will
484 return the default qemu binary name.");
485
486   ("set_path", (RErr, [String "path"]), -1, [FishAlias "path"],
487    [],
488    "set the search path",
489    "\
490 Set the path that libguestfs searches for kernel and initrd.img.
491
492 The default is C<$libdir/guestfs> unless overridden by setting
493 C<LIBGUESTFS_PATH> environment variable.
494
495 Setting C<path> to C<NULL> restores the default path.");
496
497   ("get_path", (RConstString "path", []), -1, [],
498    [InitNone, Always, TestRun (
499       [["get_path"]])],
500    "get the search path",
501    "\
502 Return the current search path.
503
504 This is always non-NULL.  If it wasn't set already, then this will
505 return the default path.");
506
507   ("set_append", (RErr, [String "append"]), -1, [FishAlias "append"],
508    [],
509    "add options to kernel command line",
510    "\
511 This function is used to add additional options to the
512 guest kernel command line.
513
514 The default is C<NULL> unless overridden by setting
515 C<LIBGUESTFS_APPEND> environment variable.
516
517 Setting C<append> to C<NULL> means I<no> additional options
518 are passed (libguestfs always adds a few of its own).");
519
520   ("get_append", (RConstString "append", []), -1, [],
521    (* This cannot be tested with the current framework.  The
522     * function can return NULL in normal operations, which the
523     * test framework interprets as an error.
524     *)
525    [],
526    "get the additional kernel options",
527    "\
528 Return the additional kernel options which are added to the
529 guest kernel command line.
530
531 If C<NULL> then no options are added.");
532
533   ("set_autosync", (RErr, [Bool "autosync"]), -1, [FishAlias "autosync"],
534    [],
535    "set autosync mode",
536    "\
537 If C<autosync> is true, this enables autosync.  Libguestfs will make a
538 best effort attempt to run C<guestfs_umount_all> followed by
539 C<guestfs_sync> when the handle is closed
540 (also if the program exits without closing handles).
541
542 This is disabled by default (except in guestfish where it is
543 enabled by default).");
544
545   ("get_autosync", (RBool "autosync", []), -1, [],
546    [InitNone, Always, TestRun (
547       [["get_autosync"]])],
548    "get autosync mode",
549    "\
550 Get the autosync flag.");
551
552   ("set_verbose", (RErr, [Bool "verbose"]), -1, [FishAlias "verbose"],
553    [],
554    "set verbose mode",
555    "\
556 If C<verbose> is true, this turns on verbose messages (to C<stderr>).
557
558 Verbose messages are disabled unless the environment variable
559 C<LIBGUESTFS_DEBUG> is defined and set to C<1>.");
560
561   ("get_verbose", (RBool "verbose", []), -1, [],
562    [],
563    "get verbose mode",
564    "\
565 This returns the verbose messages flag.");
566
567   ("is_ready", (RBool "ready", []), -1, [],
568    [InitNone, Always, TestOutputTrue (
569       [["is_ready"]])],
570    "is ready to accept commands",
571    "\
572 This returns true iff this handle is ready to accept commands
573 (in the C<READY> state).
574
575 For more information on states, see L<guestfs(3)>.");
576
577   ("is_config", (RBool "config", []), -1, [],
578    [InitNone, Always, TestOutputFalse (
579       [["is_config"]])],
580    "is in configuration state",
581    "\
582 This returns true iff this handle is being configured
583 (in the C<CONFIG> state).
584
585 For more information on states, see L<guestfs(3)>.");
586
587   ("is_launching", (RBool "launching", []), -1, [],
588    [InitNone, Always, TestOutputFalse (
589       [["is_launching"]])],
590    "is launching subprocess",
591    "\
592 This returns true iff this handle is launching the subprocess
593 (in the C<LAUNCHING> state).
594
595 For more information on states, see L<guestfs(3)>.");
596
597   ("is_busy", (RBool "busy", []), -1, [],
598    [InitNone, Always, TestOutputFalse (
599       [["is_busy"]])],
600    "is busy processing a command",
601    "\
602 This returns true iff this handle is busy processing a command
603 (in the C<BUSY> state).
604
605 For more information on states, see L<guestfs(3)>.");
606
607   ("get_state", (RInt "state", []), -1, [],
608    [],
609    "get the current state",
610    "\
611 This returns the current state as an opaque integer.  This is
612 only useful for printing debug and internal error messages.
613
614 For more information on states, see L<guestfs(3)>.");
615
616   ("set_busy", (RErr, []), -1, [NotInFish],
617    [],
618    "set state to busy",
619    "\
620 This sets the state to C<BUSY>.  This is only used when implementing
621 actions using the low-level API.
622
623 For more information on states, see L<guestfs(3)>.");
624
625   ("set_ready", (RErr, []), -1, [NotInFish],
626    [],
627    "set state to ready",
628    "\
629 This sets the state to C<READY>.  This is only used when implementing
630 actions using the low-level API.
631
632 For more information on states, see L<guestfs(3)>.");
633
634   ("end_busy", (RErr, []), -1, [NotInFish],
635    [],
636    "leave the busy state",
637    "\
638 This sets the state to C<READY>, or if in C<CONFIG> then it leaves the
639 state as is.  This is only used when implementing
640 actions using the low-level API.
641
642 For more information on states, see L<guestfs(3)>.");
643
644   ("set_memsize", (RErr, [Int "memsize"]), -1, [FishAlias "memsize"],
645    [InitNone, Always, TestOutputInt (
646       [["set_memsize"; "500"];
647        ["get_memsize"]], 500)],
648    "set memory allocated to the qemu subprocess",
649    "\
650 This sets the memory size in megabytes allocated to the
651 qemu subprocess.  This only has any effect if called before
652 C<guestfs_launch>.
653
654 You can also change this by setting the environment
655 variable C<LIBGUESTFS_MEMSIZE> before the handle is
656 created.
657
658 For more information on the architecture of libguestfs,
659 see L<guestfs(3)>.");
660
661   ("get_memsize", (RInt "memsize", []), -1, [],
662    [InitNone, Always, TestOutputIntOp (
663       [["get_memsize"]], ">=", 256)],
664    "get memory allocated to the qemu subprocess",
665    "\
666 This gets the memory size in megabytes allocated to the
667 qemu subprocess.
668
669 If C<guestfs_set_memsize> was not called
670 on this handle, and if C<LIBGUESTFS_MEMSIZE> was not set,
671 then this returns the compiled-in default value for memsize.
672
673 For more information on the architecture of libguestfs,
674 see L<guestfs(3)>.");
675
676   ("get_pid", (RInt "pid", []), -1, [FishAlias "pid"],
677    [InitNone, Always, TestOutputIntOp (
678       [["get_pid"]], ">=", 1)],
679    "get PID of qemu subprocess",
680    "\
681 Return the process ID of the qemu subprocess.  If there is no
682 qemu subprocess, then this will return an error.
683
684 This is an internal call used for debugging and testing.");
685
686   ("version", (RStruct ("version", "version"), []), -1, [],
687    [InitNone, Always, TestOutputStruct (
688       [["version"]], [CompareWithInt ("major", 1)])],
689    "get the library version number",
690    "\
691 Return the libguestfs version number that the program is linked
692 against.
693
694 Note that because of dynamic linking this is not necessarily
695 the version of libguestfs that you compiled against.  You can
696 compile the program, and then at runtime dynamically link
697 against a completely different C<libguestfs.so> library.
698
699 This call was added in version C<1.0.58>.  In previous
700 versions of libguestfs there was no way to get the version
701 number.  From C code you can use ELF weak linking tricks to find out if
702 this symbol exists (if it doesn't, then it's an earlier version).
703
704 The call returns a structure with four elements.  The first
705 three (C<major>, C<minor> and C<release>) are numbers and
706 correspond to the usual version triplet.  The fourth element
707 (C<extra>) is a string and is normally empty, but may be
708 used for distro-specific information.
709
710 To construct the original version string:
711 C<$major.$minor.$release$extra>
712
713 I<Note:> Don't use this call to test for availability
714 of features.  Distro backports makes this unreliable.");
715
716 ]
717
718 (* daemon_functions are any functions which cause some action
719  * to take place in the daemon.
720  *)
721
722 let daemon_functions = [
723   ("mount", (RErr, [String "device"; String "mountpoint"]), 1, [],
724    [InitEmpty, Always, TestOutput (
725       [["sfdiskM"; "/dev/sda"; ","];
726        ["mkfs"; "ext2"; "/dev/sda1"];
727        ["mount"; "/dev/sda1"; "/"];
728        ["write_file"; "/new"; "new file contents"; "0"];
729        ["cat"; "/new"]], "new file contents")],
730    "mount a guest disk at a position in the filesystem",
731    "\
732 Mount a guest disk at a position in the filesystem.  Block devices
733 are named C</dev/sda>, C</dev/sdb> and so on, as they were added to
734 the guest.  If those block devices contain partitions, they will have
735 the usual names (eg. C</dev/sda1>).  Also LVM C</dev/VG/LV>-style
736 names can be used.
737
738 The rules are the same as for L<mount(2)>:  A filesystem must
739 first be mounted on C</> before others can be mounted.  Other
740 filesystems can only be mounted on directories which already
741 exist.
742
743 The mounted filesystem is writable, if we have sufficient permissions
744 on the underlying device.
745
746 The filesystem options C<sync> and C<noatime> are set with this
747 call, in order to improve reliability.");
748
749   ("sync", (RErr, []), 2, [],
750    [ InitEmpty, Always, TestRun [["sync"]]],
751    "sync disks, writes are flushed through to the disk image",
752    "\
753 This syncs the disk, so that any writes are flushed through to the
754 underlying disk image.
755
756 You should always call this if you have modified a disk image, before
757 closing the handle.");
758
759   ("touch", (RErr, [String "path"]), 3, [],
760    [InitBasicFS, Always, TestOutputTrue (
761       [["touch"; "/new"];
762        ["exists"; "/new"]])],
763    "update file timestamps or create a new file",
764    "\
765 Touch acts like the L<touch(1)> command.  It can be used to
766 update the timestamps on a file, or, if the file does not exist,
767 to create a new zero-length file.");
768
769   ("cat", (RString "content", [String "path"]), 4, [ProtocolLimitWarning],
770    [InitBasicFS, Always, TestOutput (
771       [["write_file"; "/new"; "new file contents"; "0"];
772        ["cat"; "/new"]], "new file contents")],
773    "list the contents of a file",
774    "\
775 Return the contents of the file named C<path>.
776
777 Note that this function cannot correctly handle binary files
778 (specifically, files containing C<\\0> character which is treated
779 as end of string).  For those you need to use the C<guestfs_read_file>
780 or C<guestfs_download> functions which have a more complex interface.");
781
782   ("ll", (RString "listing", [String "directory"]), 5, [],
783    [], (* XXX Tricky to test because it depends on the exact format
784         * of the 'ls -l' command, which changes between F10 and F11.
785         *)
786    "list the files in a directory (long format)",
787    "\
788 List the files in C<directory> (relative to the root directory,
789 there is no cwd) in the format of 'ls -la'.
790
791 This command is mostly useful for interactive sessions.  It
792 is I<not> intended that you try to parse the output string.");
793
794   ("ls", (RStringList "listing", [String "directory"]), 6, [],
795    [InitBasicFS, Always, TestOutputList (
796       [["touch"; "/new"];
797        ["touch"; "/newer"];
798        ["touch"; "/newest"];
799        ["ls"; "/"]], ["lost+found"; "new"; "newer"; "newest"])],
800    "list the files in a directory",
801    "\
802 List the files in C<directory> (relative to the root directory,
803 there is no cwd).  The '.' and '..' entries are not returned, but
804 hidden files are shown.
805
806 This command is mostly useful for interactive sessions.  Programs
807 should probably use C<guestfs_readdir> instead.");
808
809   ("list_devices", (RStringList "devices", []), 7, [],
810    [InitEmpty, Always, TestOutputListOfDevices (
811       [["list_devices"]], ["/dev/sda"; "/dev/sdb"; "/dev/sdc"; "/dev/sdd"])],
812    "list the block devices",
813    "\
814 List all the block devices.
815
816 The full block device names are returned, eg. C</dev/sda>");
817
818   ("list_partitions", (RStringList "partitions", []), 8, [],
819    [InitBasicFS, Always, TestOutputListOfDevices (
820       [["list_partitions"]], ["/dev/sda1"]);
821     InitEmpty, Always, TestOutputListOfDevices (
822       [["sfdiskM"; "/dev/sda"; ",100 ,200 ,"];
823        ["list_partitions"]], ["/dev/sda1"; "/dev/sda2"; "/dev/sda3"])],
824    "list the partitions",
825    "\
826 List all the partitions detected on all block devices.
827
828 The full partition device names are returned, eg. C</dev/sda1>
829
830 This does not return logical volumes.  For that you will need to
831 call C<guestfs_lvs>.");
832
833   ("pvs", (RStringList "physvols", []), 9, [],
834    [InitBasicFSonLVM, Always, TestOutputListOfDevices (
835       [["pvs"]], ["/dev/sda1"]);
836     InitEmpty, Always, TestOutputListOfDevices (
837       [["sfdiskM"; "/dev/sda"; ",100 ,200 ,"];
838        ["pvcreate"; "/dev/sda1"];
839        ["pvcreate"; "/dev/sda2"];
840        ["pvcreate"; "/dev/sda3"];
841        ["pvs"]], ["/dev/sda1"; "/dev/sda2"; "/dev/sda3"])],
842    "list the LVM physical volumes (PVs)",
843    "\
844 List all the physical volumes detected.  This is the equivalent
845 of the L<pvs(8)> command.
846
847 This returns a list of just the device names that contain
848 PVs (eg. C</dev/sda2>).
849
850 See also C<guestfs_pvs_full>.");
851
852   ("vgs", (RStringList "volgroups", []), 10, [],
853    [InitBasicFSonLVM, Always, TestOutputList (
854       [["vgs"]], ["VG"]);
855     InitEmpty, Always, TestOutputList (
856       [["sfdiskM"; "/dev/sda"; ",100 ,200 ,"];
857        ["pvcreate"; "/dev/sda1"];
858        ["pvcreate"; "/dev/sda2"];
859        ["pvcreate"; "/dev/sda3"];
860        ["vgcreate"; "VG1"; "/dev/sda1 /dev/sda2"];
861        ["vgcreate"; "VG2"; "/dev/sda3"];
862        ["vgs"]], ["VG1"; "VG2"])],
863    "list the LVM volume groups (VGs)",
864    "\
865 List all the volumes groups detected.  This is the equivalent
866 of the L<vgs(8)> command.
867
868 This returns a list of just the volume group names that were
869 detected (eg. C<VolGroup00>).
870
871 See also C<guestfs_vgs_full>.");
872
873   ("lvs", (RStringList "logvols", []), 11, [],
874    [InitBasicFSonLVM, Always, TestOutputList (
875       [["lvs"]], ["/dev/VG/LV"]);
876     InitEmpty, Always, TestOutputList (
877       [["sfdiskM"; "/dev/sda"; ",100 ,200 ,"];
878        ["pvcreate"; "/dev/sda1"];
879        ["pvcreate"; "/dev/sda2"];
880        ["pvcreate"; "/dev/sda3"];
881        ["vgcreate"; "VG1"; "/dev/sda1 /dev/sda2"];
882        ["vgcreate"; "VG2"; "/dev/sda3"];
883        ["lvcreate"; "LV1"; "VG1"; "50"];
884        ["lvcreate"; "LV2"; "VG1"; "50"];
885        ["lvcreate"; "LV3"; "VG2"; "50"];
886        ["lvs"]], ["/dev/VG1/LV1"; "/dev/VG1/LV2"; "/dev/VG2/LV3"])],
887    "list the LVM logical volumes (LVs)",
888    "\
889 List all the logical volumes detected.  This is the equivalent
890 of the L<lvs(8)> command.
891
892 This returns a list of the logical volume device names
893 (eg. C</dev/VolGroup00/LogVol00>).
894
895 See also C<guestfs_lvs_full>.");
896
897   ("pvs_full", (RStructList ("physvols", "lvm_pv"), []), 12, [],
898    [], (* XXX how to test? *)
899    "list the LVM physical volumes (PVs)",
900    "\
901 List all the physical volumes detected.  This is the equivalent
902 of the L<pvs(8)> command.  The \"full\" version includes all fields.");
903
904   ("vgs_full", (RStructList ("volgroups", "lvm_vg"), []), 13, [],
905    [], (* XXX how to test? *)
906    "list the LVM volume groups (VGs)",
907    "\
908 List all the volumes groups detected.  This is the equivalent
909 of the L<vgs(8)> command.  The \"full\" version includes all fields.");
910
911   ("lvs_full", (RStructList ("logvols", "lvm_lv"), []), 14, [],
912    [], (* XXX how to test? *)
913    "list the LVM logical volumes (LVs)",
914    "\
915 List all the logical volumes detected.  This is the equivalent
916 of the L<lvs(8)> command.  The \"full\" version includes all fields.");
917
918   ("read_lines", (RStringList "lines", [String "path"]), 15, [],
919    [InitBasicFS, Always, TestOutputList (
920       [["write_file"; "/new"; "line1\r\nline2\nline3"; "0"];
921        ["read_lines"; "/new"]], ["line1"; "line2"; "line3"]);
922     InitBasicFS, Always, TestOutputList (
923       [["write_file"; "/new"; ""; "0"];
924        ["read_lines"; "/new"]], [])],
925    "read file as lines",
926    "\
927 Return the contents of the file named C<path>.
928
929 The file contents are returned as a list of lines.  Trailing
930 C<LF> and C<CRLF> character sequences are I<not> returned.
931
932 Note that this function cannot correctly handle binary files
933 (specifically, files containing C<\\0> character which is treated
934 as end of line).  For those you need to use the C<guestfs_read_file>
935 function which has a more complex interface.");
936
937   ("aug_init", (RErr, [String "root"; Int "flags"]), 16, [],
938    [], (* XXX Augeas code needs tests. *)
939    "create a new Augeas handle",
940    "\
941 Create a new Augeas handle for editing configuration files.
942 If there was any previous Augeas handle associated with this
943 guestfs session, then it is closed.
944
945 You must call this before using any other C<guestfs_aug_*>
946 commands.
947
948 C<root> is the filesystem root.  C<root> must not be NULL,
949 use C</> instead.
950
951 The flags are the same as the flags defined in
952 E<lt>augeas.hE<gt>, the logical I<or> of the following
953 integers:
954
955 =over 4
956
957 =item C<AUG_SAVE_BACKUP> = 1
958
959 Keep the original file with a C<.augsave> extension.
960
961 =item C<AUG_SAVE_NEWFILE> = 2
962
963 Save changes into a file with extension C<.augnew>, and
964 do not overwrite original.  Overrides C<AUG_SAVE_BACKUP>.
965
966 =item C<AUG_TYPE_CHECK> = 4
967
968 Typecheck lenses (can be expensive).
969
970 =item C<AUG_NO_STDINC> = 8
971
972 Do not use standard load path for modules.
973
974 =item C<AUG_SAVE_NOOP> = 16
975
976 Make save a no-op, just record what would have been changed.
977
978 =item C<AUG_NO_LOAD> = 32
979
980 Do not load the tree in C<guestfs_aug_init>.
981
982 =back
983
984 To close the handle, you can call C<guestfs_aug_close>.
985
986 To find out more about Augeas, see L<http://augeas.net/>.");
987
988   ("aug_close", (RErr, []), 26, [],
989    [], (* XXX Augeas code needs tests. *)
990    "close the current Augeas handle",
991    "\
992 Close the current Augeas handle and free up any resources
993 used by it.  After calling this, you have to call
994 C<guestfs_aug_init> again before you can use any other
995 Augeas functions.");
996
997   ("aug_defvar", (RInt "nrnodes", [String "name"; OptString "expr"]), 17, [],
998    [], (* XXX Augeas code needs tests. *)
999    "define an Augeas variable",
1000    "\
1001 Defines an Augeas variable C<name> whose value is the result
1002 of evaluating C<expr>.  If C<expr> is NULL, then C<name> is
1003 undefined.
1004
1005 On success this returns the number of nodes in C<expr>, or
1006 C<0> if C<expr> evaluates to something which is not a nodeset.");
1007
1008   ("aug_defnode", (RStruct ("nrnodescreated", "int_bool"), [String "name"; String "expr"; String "val"]), 18, [],
1009    [], (* XXX Augeas code needs tests. *)
1010    "define an Augeas node",
1011    "\
1012 Defines a variable C<name> whose value is the result of
1013 evaluating C<expr>.
1014
1015 If C<expr> evaluates to an empty nodeset, a node is created,
1016 equivalent to calling C<guestfs_aug_set> C<expr>, C<value>.
1017 C<name> will be the nodeset containing that single node.
1018
1019 On success this returns a pair containing the
1020 number of nodes in the nodeset, and a boolean flag
1021 if a node was created.");
1022
1023   ("aug_get", (RString "val", [String "path"]), 19, [],
1024    [], (* XXX Augeas code needs tests. *)
1025    "look up the value of an Augeas path",
1026    "\
1027 Look up the value associated with C<path>.  If C<path>
1028 matches exactly one node, the C<value> is returned.");
1029
1030   ("aug_set", (RErr, [String "path"; String "val"]), 20, [],
1031    [], (* XXX Augeas code needs tests. *)
1032    "set Augeas path to value",
1033    "\
1034 Set the value associated with C<path> to C<value>.");
1035
1036   ("aug_insert", (RErr, [String "path"; String "label"; Bool "before"]), 21, [],
1037    [], (* XXX Augeas code needs tests. *)
1038    "insert a sibling Augeas node",
1039    "\
1040 Create a new sibling C<label> for C<path>, inserting it into
1041 the tree before or after C<path> (depending on the boolean
1042 flag C<before>).
1043
1044 C<path> must match exactly one existing node in the tree, and
1045 C<label> must be a label, ie. not contain C</>, C<*> or end
1046 with a bracketed index C<[N]>.");
1047
1048   ("aug_rm", (RInt "nrnodes", [String "path"]), 22, [],
1049    [], (* XXX Augeas code needs tests. *)
1050    "remove an Augeas path",
1051    "\
1052 Remove C<path> and all of its children.
1053
1054 On success this returns the number of entries which were removed.");
1055
1056   ("aug_mv", (RErr, [String "src"; String "dest"]), 23, [],
1057    [], (* XXX Augeas code needs tests. *)
1058    "move Augeas node",
1059    "\
1060 Move the node C<src> to C<dest>.  C<src> must match exactly
1061 one node.  C<dest> is overwritten if it exists.");
1062
1063   ("aug_match", (RStringList "matches", [String "path"]), 24, [],
1064    [], (* XXX Augeas code needs tests. *)
1065    "return Augeas nodes which match path",
1066    "\
1067 Returns a list of paths which match the path expression C<path>.
1068 The returned paths are sufficiently qualified so that they match
1069 exactly one node in the current tree.");
1070
1071   ("aug_save", (RErr, []), 25, [],
1072    [], (* XXX Augeas code needs tests. *)
1073    "write all pending Augeas changes to disk",
1074    "\
1075 This writes all pending changes to disk.
1076
1077 The flags which were passed to C<guestfs_aug_init> affect exactly
1078 how files are saved.");
1079
1080   ("aug_load", (RErr, []), 27, [],
1081    [], (* XXX Augeas code needs tests. *)
1082    "load files into the tree",
1083    "\
1084 Load files into the tree.
1085
1086 See C<aug_load> in the Augeas documentation for the full gory
1087 details.");
1088
1089   ("aug_ls", (RStringList "matches", [String "path"]), 28, [],
1090    [], (* XXX Augeas code needs tests. *)
1091    "list Augeas nodes under a path",
1092    "\
1093 This is just a shortcut for listing C<guestfs_aug_match>
1094 C<path/*> and sorting the resulting nodes into alphabetical order.");
1095
1096   ("rm", (RErr, [String "path"]), 29, [],
1097    [InitBasicFS, Always, TestRun
1098       [["touch"; "/new"];
1099        ["rm"; "/new"]];
1100     InitBasicFS, Always, TestLastFail
1101       [["rm"; "/new"]];
1102     InitBasicFS, Always, TestLastFail
1103       [["mkdir"; "/new"];
1104        ["rm"; "/new"]]],
1105    "remove a file",
1106    "\
1107 Remove the single file C<path>.");
1108
1109   ("rmdir", (RErr, [String "path"]), 30, [],
1110    [InitBasicFS, Always, TestRun
1111       [["mkdir"; "/new"];
1112        ["rmdir"; "/new"]];
1113     InitBasicFS, Always, TestLastFail
1114       [["rmdir"; "/new"]];
1115     InitBasicFS, Always, TestLastFail
1116       [["touch"; "/new"];
1117        ["rmdir"; "/new"]]],
1118    "remove a directory",
1119    "\
1120 Remove the single directory C<path>.");
1121
1122   ("rm_rf", (RErr, [String "path"]), 31, [],
1123    [InitBasicFS, Always, TestOutputFalse
1124       [["mkdir"; "/new"];
1125        ["mkdir"; "/new/foo"];
1126        ["touch"; "/new/foo/bar"];
1127        ["rm_rf"; "/new"];
1128        ["exists"; "/new"]]],
1129    "remove a file or directory recursively",
1130    "\
1131 Remove the file or directory C<path>, recursively removing the
1132 contents if its a directory.  This is like the C<rm -rf> shell
1133 command.");
1134
1135   ("mkdir", (RErr, [String "path"]), 32, [],
1136    [InitBasicFS, Always, TestOutputTrue
1137       [["mkdir"; "/new"];
1138        ["is_dir"; "/new"]];
1139     InitBasicFS, Always, TestLastFail
1140       [["mkdir"; "/new/foo/bar"]]],
1141    "create a directory",
1142    "\
1143 Create a directory named C<path>.");
1144
1145   ("mkdir_p", (RErr, [String "path"]), 33, [],
1146    [InitBasicFS, Always, TestOutputTrue
1147       [["mkdir_p"; "/new/foo/bar"];
1148        ["is_dir"; "/new/foo/bar"]];
1149     InitBasicFS, Always, TestOutputTrue
1150       [["mkdir_p"; "/new/foo/bar"];
1151        ["is_dir"; "/new/foo"]];
1152     InitBasicFS, Always, TestOutputTrue
1153       [["mkdir_p"; "/new/foo/bar"];
1154        ["is_dir"; "/new"]];
1155     (* Regression tests for RHBZ#503133: *)
1156     InitBasicFS, Always, TestRun
1157       [["mkdir"; "/new"];
1158        ["mkdir_p"; "/new"]];
1159     InitBasicFS, Always, TestLastFail
1160       [["touch"; "/new"];
1161        ["mkdir_p"; "/new"]]],
1162    "create a directory and parents",
1163    "\
1164 Create a directory named C<path>, creating any parent directories
1165 as necessary.  This is like the C<mkdir -p> shell command.");
1166
1167   ("chmod", (RErr, [Int "mode"; String "path"]), 34, [],
1168    [], (* XXX Need stat command to test *)
1169    "change file mode",
1170    "\
1171 Change the mode (permissions) of C<path> to C<mode>.  Only
1172 numeric modes are supported.");
1173
1174   ("chown", (RErr, [Int "owner"; Int "group"; String "path"]), 35, [],
1175    [], (* XXX Need stat command to test *)
1176    "change file owner and group",
1177    "\
1178 Change the file owner to C<owner> and group to C<group>.
1179
1180 Only numeric uid and gid are supported.  If you want to use
1181 names, you will need to locate and parse the password file
1182 yourself (Augeas support makes this relatively easy).");
1183
1184   ("exists", (RBool "existsflag", [String "path"]), 36, [],
1185    [InitBasicFS, Always, TestOutputTrue (
1186       [["touch"; "/new"];
1187        ["exists"; "/new"]]);
1188     InitBasicFS, Always, TestOutputTrue (
1189       [["mkdir"; "/new"];
1190        ["exists"; "/new"]])],
1191    "test if file or directory exists",
1192    "\
1193 This returns C<true> if and only if there is a file, directory
1194 (or anything) with the given C<path> name.
1195
1196 See also C<guestfs_is_file>, C<guestfs_is_dir>, C<guestfs_stat>.");
1197
1198   ("is_file", (RBool "fileflag", [String "path"]), 37, [],
1199    [InitBasicFS, Always, TestOutputTrue (
1200       [["touch"; "/new"];
1201        ["is_file"; "/new"]]);
1202     InitBasicFS, Always, TestOutputFalse (
1203       [["mkdir"; "/new"];
1204        ["is_file"; "/new"]])],
1205    "test if file exists",
1206    "\
1207 This returns C<true> if and only if there is a file
1208 with the given C<path> name.  Note that it returns false for
1209 other objects like directories.
1210
1211 See also C<guestfs_stat>.");
1212
1213   ("is_dir", (RBool "dirflag", [String "path"]), 38, [],
1214    [InitBasicFS, Always, TestOutputFalse (
1215       [["touch"; "/new"];
1216        ["is_dir"; "/new"]]);
1217     InitBasicFS, Always, TestOutputTrue (
1218       [["mkdir"; "/new"];
1219        ["is_dir"; "/new"]])],
1220    "test if file exists",
1221    "\
1222 This returns C<true> if and only if there is a directory
1223 with the given C<path> name.  Note that it returns false for
1224 other objects like files.
1225
1226 See also C<guestfs_stat>.");
1227
1228   ("pvcreate", (RErr, [String "device"]), 39, [],
1229    [InitEmpty, Always, TestOutputListOfDevices (
1230       [["sfdiskM"; "/dev/sda"; ",100 ,200 ,"];
1231        ["pvcreate"; "/dev/sda1"];
1232        ["pvcreate"; "/dev/sda2"];
1233        ["pvcreate"; "/dev/sda3"];
1234        ["pvs"]], ["/dev/sda1"; "/dev/sda2"; "/dev/sda3"])],
1235    "create an LVM physical volume",
1236    "\
1237 This creates an LVM physical volume on the named C<device>,
1238 where C<device> should usually be a partition name such
1239 as C</dev/sda1>.");
1240
1241   ("vgcreate", (RErr, [String "volgroup"; StringList "physvols"]), 40, [],
1242    [InitEmpty, Always, TestOutputList (
1243       [["sfdiskM"; "/dev/sda"; ",100 ,200 ,"];
1244        ["pvcreate"; "/dev/sda1"];
1245        ["pvcreate"; "/dev/sda2"];
1246        ["pvcreate"; "/dev/sda3"];
1247        ["vgcreate"; "VG1"; "/dev/sda1 /dev/sda2"];
1248        ["vgcreate"; "VG2"; "/dev/sda3"];
1249        ["vgs"]], ["VG1"; "VG2"])],
1250    "create an LVM volume group",
1251    "\
1252 This creates an LVM volume group called C<volgroup>
1253 from the non-empty list of physical volumes C<physvols>.");
1254
1255   ("lvcreate", (RErr, [String "logvol"; String "volgroup"; Int "mbytes"]), 41, [],
1256    [InitEmpty, Always, TestOutputList (
1257       [["sfdiskM"; "/dev/sda"; ",100 ,200 ,"];
1258        ["pvcreate"; "/dev/sda1"];
1259        ["pvcreate"; "/dev/sda2"];
1260        ["pvcreate"; "/dev/sda3"];
1261        ["vgcreate"; "VG1"; "/dev/sda1 /dev/sda2"];
1262        ["vgcreate"; "VG2"; "/dev/sda3"];
1263        ["lvcreate"; "LV1"; "VG1"; "50"];
1264        ["lvcreate"; "LV2"; "VG1"; "50"];
1265        ["lvcreate"; "LV3"; "VG2"; "50"];
1266        ["lvcreate"; "LV4"; "VG2"; "50"];
1267        ["lvcreate"; "LV5"; "VG2"; "50"];
1268        ["lvs"]],
1269       ["/dev/VG1/LV1"; "/dev/VG1/LV2";
1270        "/dev/VG2/LV3"; "/dev/VG2/LV4"; "/dev/VG2/LV5"])],
1271    "create an LVM volume group",
1272    "\
1273 This creates an LVM volume group called C<logvol>
1274 on the volume group C<volgroup>, with C<size> megabytes.");
1275
1276   ("mkfs", (RErr, [String "fstype"; String "device"]), 42, [],
1277    [InitEmpty, Always, TestOutput (
1278       [["sfdiskM"; "/dev/sda"; ","];
1279        ["mkfs"; "ext2"; "/dev/sda1"];
1280        ["mount"; "/dev/sda1"; "/"];
1281        ["write_file"; "/new"; "new file contents"; "0"];
1282        ["cat"; "/new"]], "new file contents")],
1283    "make a filesystem",
1284    "\
1285 This creates a filesystem on C<device> (usually a partition
1286 or LVM logical volume).  The filesystem type is C<fstype>, for
1287 example C<ext3>.");
1288
1289   ("sfdisk", (RErr, [String "device";
1290                      Int "cyls"; Int "heads"; Int "sectors";
1291                      StringList "lines"]), 43, [DangerWillRobinson],
1292    [],
1293    "create partitions on a block device",
1294    "\
1295 This is a direct interface to the L<sfdisk(8)> program for creating
1296 partitions on block devices.
1297
1298 C<device> should be a block device, for example C</dev/sda>.
1299
1300 C<cyls>, C<heads> and C<sectors> are the number of cylinders, heads
1301 and sectors on the device, which are passed directly to sfdisk as
1302 the I<-C>, I<-H> and I<-S> parameters.  If you pass C<0> for any
1303 of these, then the corresponding parameter is omitted.  Usually for
1304 'large' disks, you can just pass C<0> for these, but for small
1305 (floppy-sized) disks, sfdisk (or rather, the kernel) cannot work
1306 out the right geometry and you will need to tell it.
1307
1308 C<lines> is a list of lines that we feed to C<sfdisk>.  For more
1309 information refer to the L<sfdisk(8)> manpage.
1310
1311 To create a single partition occupying the whole disk, you would
1312 pass C<lines> as a single element list, when the single element being
1313 the string C<,> (comma).
1314
1315 See also: C<guestfs_sfdisk_l>, C<guestfs_sfdisk_N>");
1316
1317   ("write_file", (RErr, [String "path"; String "content"; Int "size"]), 44, [ProtocolLimitWarning],
1318    [InitBasicFS, Always, TestOutput (
1319       [["write_file"; "/new"; "new file contents"; "0"];
1320        ["cat"; "/new"]], "new file contents");
1321     InitBasicFS, Always, TestOutput (
1322       [["write_file"; "/new"; "\nnew file contents\n"; "0"];
1323        ["cat"; "/new"]], "\nnew file contents\n");
1324     InitBasicFS, Always, TestOutput (
1325       [["write_file"; "/new"; "\n\n"; "0"];
1326        ["cat"; "/new"]], "\n\n");
1327     InitBasicFS, Always, TestOutput (
1328       [["write_file"; "/new"; ""; "0"];
1329        ["cat"; "/new"]], "");
1330     InitBasicFS, Always, TestOutput (
1331       [["write_file"; "/new"; "\n\n\n"; "0"];
1332        ["cat"; "/new"]], "\n\n\n");
1333     InitBasicFS, Always, TestOutput (
1334       [["write_file"; "/new"; "\n"; "0"];
1335        ["cat"; "/new"]], "\n")],
1336    "create a file",
1337    "\
1338 This call creates a file called C<path>.  The contents of the
1339 file is the string C<content> (which can contain any 8 bit data),
1340 with length C<size>.
1341
1342 As a special case, if C<size> is C<0>
1343 then the length is calculated using C<strlen> (so in this case
1344 the content cannot contain embedded ASCII NULs).
1345
1346 I<NB.> Owing to a bug, writing content containing ASCII NUL
1347 characters does I<not> work, even if the length is specified.
1348 We hope to resolve this bug in a future version.  In the meantime
1349 use C<guestfs_upload>.");
1350
1351   ("umount", (RErr, [String "pathordevice"]), 45, [FishAlias "unmount"],
1352    [InitEmpty, Always, TestOutputListOfDevices (
1353       [["sfdiskM"; "/dev/sda"; ","];
1354        ["mkfs"; "ext2"; "/dev/sda1"];
1355        ["mount"; "/dev/sda1"; "/"];
1356        ["mounts"]], ["/dev/sda1"]);
1357     InitEmpty, Always, TestOutputList (
1358       [["sfdiskM"; "/dev/sda"; ","];
1359        ["mkfs"; "ext2"; "/dev/sda1"];
1360        ["mount"; "/dev/sda1"; "/"];
1361        ["umount"; "/"];
1362        ["mounts"]], [])],
1363    "unmount a filesystem",
1364    "\
1365 This unmounts the given filesystem.  The filesystem may be
1366 specified either by its mountpoint (path) or the device which
1367 contains the filesystem.");
1368
1369   ("mounts", (RStringList "devices", []), 46, [],
1370    [InitBasicFS, Always, TestOutputListOfDevices (
1371       [["mounts"]], ["/dev/sda1"])],
1372    "show mounted filesystems",
1373    "\
1374 This returns the list of currently mounted filesystems.  It returns
1375 the list of devices (eg. C</dev/sda1>, C</dev/VG/LV>).
1376
1377 Some internal mounts are not shown.
1378
1379 See also: C<guestfs_mountpoints>");
1380
1381   ("umount_all", (RErr, []), 47, [FishAlias "unmount-all"],
1382    [InitBasicFS, Always, TestOutputList (
1383       [["umount_all"];
1384        ["mounts"]], []);
1385     (* check that umount_all can unmount nested mounts correctly: *)
1386     InitEmpty, Always, TestOutputList (
1387       [["sfdiskM"; "/dev/sda"; ",100 ,200 ,"];
1388        ["mkfs"; "ext2"; "/dev/sda1"];
1389        ["mkfs"; "ext2"; "/dev/sda2"];
1390        ["mkfs"; "ext2"; "/dev/sda3"];
1391        ["mount"; "/dev/sda1"; "/"];
1392        ["mkdir"; "/mp1"];
1393        ["mount"; "/dev/sda2"; "/mp1"];
1394        ["mkdir"; "/mp1/mp2"];
1395        ["mount"; "/dev/sda3"; "/mp1/mp2"];
1396        ["mkdir"; "/mp1/mp2/mp3"];
1397        ["umount_all"];
1398        ["mounts"]], [])],
1399    "unmount all filesystems",
1400    "\
1401 This unmounts all mounted filesystems.
1402
1403 Some internal mounts are not unmounted by this call.");
1404
1405   ("lvm_remove_all", (RErr, []), 48, [DangerWillRobinson],
1406    [],
1407    "remove all LVM LVs, VGs and PVs",
1408    "\
1409 This command removes all LVM logical volumes, volume groups
1410 and physical volumes.");
1411
1412   ("file", (RString "description", [String "path"]), 49, [],
1413    [InitBasicFS, Always, TestOutput (
1414       [["touch"; "/new"];
1415        ["file"; "/new"]], "empty");
1416     InitBasicFS, Always, TestOutput (
1417       [["write_file"; "/new"; "some content\n"; "0"];
1418        ["file"; "/new"]], "ASCII text");
1419     InitBasicFS, Always, TestLastFail (
1420       [["file"; "/nofile"]])],
1421    "determine file type",
1422    "\
1423 This call uses the standard L<file(1)> command to determine
1424 the type or contents of the file.  This also works on devices,
1425 for example to find out whether a partition contains a filesystem.
1426
1427 The exact command which runs is C<file -bsL path>.  Note in
1428 particular that the filename is not prepended to the output
1429 (the C<-b> option).");
1430
1431   ("command", (RString "output", [StringList "arguments"]), 50, [ProtocolLimitWarning],
1432    [InitBasicFS, Always, TestOutput (
1433       [["upload"; "test-command"; "/test-command"];
1434        ["chmod"; "0o755"; "/test-command"];
1435        ["command"; "/test-command 1"]], "Result1");
1436     InitBasicFS, Always, TestOutput (
1437       [["upload"; "test-command"; "/test-command"];
1438        ["chmod"; "0o755"; "/test-command"];
1439        ["command"; "/test-command 2"]], "Result2\n");
1440     InitBasicFS, Always, TestOutput (
1441       [["upload"; "test-command"; "/test-command"];
1442        ["chmod"; "0o755"; "/test-command"];
1443        ["command"; "/test-command 3"]], "\nResult3");
1444     InitBasicFS, Always, TestOutput (
1445       [["upload"; "test-command"; "/test-command"];
1446        ["chmod"; "0o755"; "/test-command"];
1447        ["command"; "/test-command 4"]], "\nResult4\n");
1448     InitBasicFS, Always, TestOutput (
1449       [["upload"; "test-command"; "/test-command"];
1450        ["chmod"; "0o755"; "/test-command"];
1451        ["command"; "/test-command 5"]], "\nResult5\n\n");
1452     InitBasicFS, Always, TestOutput (
1453       [["upload"; "test-command"; "/test-command"];
1454        ["chmod"; "0o755"; "/test-command"];
1455        ["command"; "/test-command 6"]], "\n\nResult6\n\n");
1456     InitBasicFS, Always, TestOutput (
1457       [["upload"; "test-command"; "/test-command"];
1458        ["chmod"; "0o755"; "/test-command"];
1459        ["command"; "/test-command 7"]], "");
1460     InitBasicFS, Always, TestOutput (
1461       [["upload"; "test-command"; "/test-command"];
1462        ["chmod"; "0o755"; "/test-command"];
1463        ["command"; "/test-command 8"]], "\n");
1464     InitBasicFS, Always, TestOutput (
1465       [["upload"; "test-command"; "/test-command"];
1466        ["chmod"; "0o755"; "/test-command"];
1467        ["command"; "/test-command 9"]], "\n\n");
1468     InitBasicFS, Always, TestOutput (
1469       [["upload"; "test-command"; "/test-command"];
1470        ["chmod"; "0o755"; "/test-command"];
1471        ["command"; "/test-command 10"]], "Result10-1\nResult10-2\n");
1472     InitBasicFS, Always, TestOutput (
1473       [["upload"; "test-command"; "/test-command"];
1474        ["chmod"; "0o755"; "/test-command"];
1475        ["command"; "/test-command 11"]], "Result11-1\nResult11-2");
1476     InitBasicFS, Always, TestLastFail (
1477       [["upload"; "test-command"; "/test-command"];
1478        ["chmod"; "0o755"; "/test-command"];
1479        ["command"; "/test-command"]])],
1480    "run a command from the guest filesystem",
1481    "\
1482 This call runs a command from the guest filesystem.  The
1483 filesystem must be mounted, and must contain a compatible
1484 operating system (ie. something Linux, with the same
1485 or compatible processor architecture).
1486
1487 The single parameter is an argv-style list of arguments.
1488 The first element is the name of the program to run.
1489 Subsequent elements are parameters.  The list must be
1490 non-empty (ie. must contain a program name).  Note that
1491 the command runs directly, and is I<not> invoked via
1492 the shell (see C<guestfs_sh>).
1493
1494 The return value is anything printed to I<stdout> by
1495 the command.
1496
1497 If the command returns a non-zero exit status, then
1498 this function returns an error message.  The error message
1499 string is the content of I<stderr> from the command.
1500
1501 The C<$PATH> environment variable will contain at least
1502 C</usr/bin> and C</bin>.  If you require a program from
1503 another location, you should provide the full path in the
1504 first parameter.
1505
1506 Shared libraries and data files required by the program
1507 must be available on filesystems which are mounted in the
1508 correct places.  It is the caller's responsibility to ensure
1509 all filesystems that are needed are mounted at the right
1510 locations.");
1511
1512   ("command_lines", (RStringList "lines", [StringList "arguments"]), 51, [ProtocolLimitWarning],
1513    [InitBasicFS, Always, TestOutputList (
1514       [["upload"; "test-command"; "/test-command"];
1515        ["chmod"; "0o755"; "/test-command"];
1516        ["command_lines"; "/test-command 1"]], ["Result1"]);
1517     InitBasicFS, Always, TestOutputList (
1518       [["upload"; "test-command"; "/test-command"];
1519        ["chmod"; "0o755"; "/test-command"];
1520        ["command_lines"; "/test-command 2"]], ["Result2"]);
1521     InitBasicFS, Always, TestOutputList (
1522       [["upload"; "test-command"; "/test-command"];
1523        ["chmod"; "0o755"; "/test-command"];
1524        ["command_lines"; "/test-command 3"]], ["";"Result3"]);
1525     InitBasicFS, Always, TestOutputList (
1526       [["upload"; "test-command"; "/test-command"];
1527        ["chmod"; "0o755"; "/test-command"];
1528        ["command_lines"; "/test-command 4"]], ["";"Result4"]);
1529     InitBasicFS, Always, TestOutputList (
1530       [["upload"; "test-command"; "/test-command"];
1531        ["chmod"; "0o755"; "/test-command"];
1532        ["command_lines"; "/test-command 5"]], ["";"Result5";""]);
1533     InitBasicFS, Always, TestOutputList (
1534       [["upload"; "test-command"; "/test-command"];
1535        ["chmod"; "0o755"; "/test-command"];
1536        ["command_lines"; "/test-command 6"]], ["";"";"Result6";""]);
1537     InitBasicFS, Always, TestOutputList (
1538       [["upload"; "test-command"; "/test-command"];
1539        ["chmod"; "0o755"; "/test-command"];
1540        ["command_lines"; "/test-command 7"]], []);
1541     InitBasicFS, Always, TestOutputList (
1542       [["upload"; "test-command"; "/test-command"];
1543        ["chmod"; "0o755"; "/test-command"];
1544        ["command_lines"; "/test-command 8"]], [""]);
1545     InitBasicFS, Always, TestOutputList (
1546       [["upload"; "test-command"; "/test-command"];
1547        ["chmod"; "0o755"; "/test-command"];
1548        ["command_lines"; "/test-command 9"]], ["";""]);
1549     InitBasicFS, Always, TestOutputList (
1550       [["upload"; "test-command"; "/test-command"];
1551        ["chmod"; "0o755"; "/test-command"];
1552        ["command_lines"; "/test-command 10"]], ["Result10-1";"Result10-2"]);
1553     InitBasicFS, Always, TestOutputList (
1554       [["upload"; "test-command"; "/test-command"];
1555        ["chmod"; "0o755"; "/test-command"];
1556        ["command_lines"; "/test-command 11"]], ["Result11-1";"Result11-2"])],
1557    "run a command, returning lines",
1558    "\
1559 This is the same as C<guestfs_command>, but splits the
1560 result into a list of lines.
1561
1562 See also: C<guestfs_sh_lines>");
1563
1564   ("stat", (RStruct ("statbuf", "stat"), [String "path"]), 52, [],
1565    [InitBasicFS, Always, TestOutputStruct (
1566       [["touch"; "/new"];
1567        ["stat"; "/new"]], [CompareWithInt ("size", 0)])],
1568    "get file information",
1569    "\
1570 Returns file information for the given C<path>.
1571
1572 This is the same as the C<stat(2)> system call.");
1573
1574   ("lstat", (RStruct ("statbuf", "stat"), [String "path"]), 53, [],
1575    [InitBasicFS, Always, TestOutputStruct (
1576       [["touch"; "/new"];
1577        ["lstat"; "/new"]], [CompareWithInt ("size", 0)])],
1578    "get file information for a symbolic link",
1579    "\
1580 Returns file information for the given C<path>.
1581
1582 This is the same as C<guestfs_stat> except that if C<path>
1583 is a symbolic link, then the link is stat-ed, not the file it
1584 refers to.
1585
1586 This is the same as the C<lstat(2)> system call.");
1587
1588   ("statvfs", (RStruct ("statbuf", "statvfs"), [String "path"]), 54, [],
1589    [InitBasicFS, Always, TestOutputStruct (
1590       [["statvfs"; "/"]], [CompareWithInt ("namemax", 255);
1591                            CompareWithInt ("bsize", 1024)])],
1592    "get file system statistics",
1593    "\
1594 Returns file system statistics for any mounted file system.
1595 C<path> should be a file or directory in the mounted file system
1596 (typically it is the mount point itself, but it doesn't need to be).
1597
1598 This is the same as the C<statvfs(2)> system call.");
1599
1600   ("tune2fs_l", (RHashtable "superblock", [String "device"]), 55, [],
1601    [], (* XXX test *)
1602    "get ext2/ext3/ext4 superblock details",
1603    "\
1604 This returns the contents of the ext2, ext3 or ext4 filesystem
1605 superblock on C<device>.
1606
1607 It is the same as running C<tune2fs -l device>.  See L<tune2fs(8)>
1608 manpage for more details.  The list of fields returned isn't
1609 clearly defined, and depends on both the version of C<tune2fs>
1610 that libguestfs was built against, and the filesystem itself.");
1611
1612   ("blockdev_setro", (RErr, [String "device"]), 56, [],
1613    [InitEmpty, Always, TestOutputTrue (
1614       [["blockdev_setro"; "/dev/sda"];
1615        ["blockdev_getro"; "/dev/sda"]])],
1616    "set block device to read-only",
1617    "\
1618 Sets the block device named C<device> to read-only.
1619
1620 This uses the L<blockdev(8)> command.");
1621
1622   ("blockdev_setrw", (RErr, [String "device"]), 57, [],
1623    [InitEmpty, Always, TestOutputFalse (
1624       [["blockdev_setrw"; "/dev/sda"];
1625        ["blockdev_getro"; "/dev/sda"]])],
1626    "set block device to read-write",
1627    "\
1628 Sets the block device named C<device> to read-write.
1629
1630 This uses the L<blockdev(8)> command.");
1631
1632   ("blockdev_getro", (RBool "ro", [String "device"]), 58, [],
1633    [InitEmpty, Always, TestOutputTrue (
1634       [["blockdev_setro"; "/dev/sda"];
1635        ["blockdev_getro"; "/dev/sda"]])],
1636    "is block device set to read-only",
1637    "\
1638 Returns a boolean indicating if the block device is read-only
1639 (true if read-only, false if not).
1640
1641 This uses the L<blockdev(8)> command.");
1642
1643   ("blockdev_getss", (RInt "sectorsize", [String "device"]), 59, [],
1644    [InitEmpty, Always, TestOutputInt (
1645       [["blockdev_getss"; "/dev/sda"]], 512)],
1646    "get sectorsize of block device",
1647    "\
1648 This returns the size of sectors on a block device.
1649 Usually 512, but can be larger for modern devices.
1650
1651 (Note, this is not the size in sectors, use C<guestfs_blockdev_getsz>
1652 for that).
1653
1654 This uses the L<blockdev(8)> command.");
1655
1656   ("blockdev_getbsz", (RInt "blocksize", [String "device"]), 60, [],
1657    [InitEmpty, Always, TestOutputInt (
1658       [["blockdev_getbsz"; "/dev/sda"]], 4096)],
1659    "get blocksize of block device",
1660    "\
1661 This returns the block size of a device.
1662
1663 (Note this is different from both I<size in blocks> and
1664 I<filesystem block size>).
1665
1666 This uses the L<blockdev(8)> command.");
1667
1668   ("blockdev_setbsz", (RErr, [String "device"; Int "blocksize"]), 61, [],
1669    [], (* XXX test *)
1670    "set blocksize of block device",
1671    "\
1672 This sets the block size of a device.
1673
1674 (Note this is different from both I<size in blocks> and
1675 I<filesystem block size>).
1676
1677 This uses the L<blockdev(8)> command.");
1678
1679   ("blockdev_getsz", (RInt64 "sizeinsectors", [String "device"]), 62, [],
1680    [InitEmpty, Always, TestOutputInt (
1681       [["blockdev_getsz"; "/dev/sda"]], 1024000)],
1682    "get total size of device in 512-byte sectors",
1683    "\
1684 This returns the size of the device in units of 512-byte sectors
1685 (even if the sectorsize isn't 512 bytes ... weird).
1686
1687 See also C<guestfs_blockdev_getss> for the real sector size of
1688 the device, and C<guestfs_blockdev_getsize64> for the more
1689 useful I<size in bytes>.
1690
1691 This uses the L<blockdev(8)> command.");
1692
1693   ("blockdev_getsize64", (RInt64 "sizeinbytes", [String "device"]), 63, [],
1694    [InitEmpty, Always, TestOutputInt (
1695       [["blockdev_getsize64"; "/dev/sda"]], 524288000)],
1696    "get total size of device in bytes",
1697    "\
1698 This returns the size of the device in bytes.
1699
1700 See also C<guestfs_blockdev_getsz>.
1701
1702 This uses the L<blockdev(8)> command.");
1703
1704   ("blockdev_flushbufs", (RErr, [String "device"]), 64, [],
1705    [InitEmpty, Always, TestRun
1706       [["blockdev_flushbufs"; "/dev/sda"]]],
1707    "flush device buffers",
1708    "\
1709 This tells the kernel to flush internal buffers associated
1710 with C<device>.
1711
1712 This uses the L<blockdev(8)> command.");
1713
1714   ("blockdev_rereadpt", (RErr, [String "device"]), 65, [],
1715    [InitEmpty, Always, TestRun
1716       [["blockdev_rereadpt"; "/dev/sda"]]],
1717    "reread partition table",
1718    "\
1719 Reread the partition table on C<device>.
1720
1721 This uses the L<blockdev(8)> command.");
1722
1723   ("upload", (RErr, [FileIn "filename"; String "remotefilename"]), 66, [],
1724    [InitBasicFS, Always, TestOutput (
1725       (* Pick a file from cwd which isn't likely to change. *)
1726       [["upload"; "../COPYING.LIB"; "/COPYING.LIB"];
1727        ["checksum"; "md5"; "/COPYING.LIB"]], "e3eda01d9815f8d24aae2dbd89b68b06")],
1728    "upload a file from the local machine",
1729    "\
1730 Upload local file C<filename> to C<remotefilename> on the
1731 filesystem.
1732
1733 C<filename> can also be a named pipe.
1734
1735 See also C<guestfs_download>.");
1736
1737   ("download", (RErr, [String "remotefilename"; FileOut "filename"]), 67, [],
1738    [InitBasicFS, Always, TestOutput (
1739       (* Pick a file from cwd which isn't likely to change. *)
1740       [["upload"; "../COPYING.LIB"; "/COPYING.LIB"];
1741        ["download"; "/COPYING.LIB"; "testdownload.tmp"];
1742        ["upload"; "testdownload.tmp"; "/upload"];
1743        ["checksum"; "md5"; "/upload"]], "e3eda01d9815f8d24aae2dbd89b68b06")],
1744    "download a file to the local machine",
1745    "\
1746 Download file C<remotefilename> and save it as C<filename>
1747 on the local machine.
1748
1749 C<filename> can also be a named pipe.
1750
1751 See also C<guestfs_upload>, C<guestfs_cat>.");
1752
1753   ("checksum", (RString "checksum", [String "csumtype"; String "path"]), 68, [],
1754    [InitBasicFS, Always, TestOutput (
1755       [["write_file"; "/new"; "test\n"; "0"];
1756        ["checksum"; "crc"; "/new"]], "935282863");
1757     InitBasicFS, Always, TestLastFail (
1758       [["checksum"; "crc"; "/new"]]);
1759     InitBasicFS, Always, TestOutput (
1760       [["write_file"; "/new"; "test\n"; "0"];
1761        ["checksum"; "md5"; "/new"]], "d8e8fca2dc0f896fd7cb4cb0031ba249");
1762     InitBasicFS, Always, TestOutput (
1763       [["write_file"; "/new"; "test\n"; "0"];
1764        ["checksum"; "sha1"; "/new"]], "4e1243bd22c66e76c2ba9eddc1f91394e57f9f83");
1765     InitBasicFS, Always, TestOutput (
1766       [["write_file"; "/new"; "test\n"; "0"];
1767        ["checksum"; "sha224"; "/new"]], "52f1bf093f4b7588726035c176c0cdb4376cfea53819f1395ac9e6ec");
1768     InitBasicFS, Always, TestOutput (
1769       [["write_file"; "/new"; "test\n"; "0"];
1770        ["checksum"; "sha256"; "/new"]], "f2ca1bb6c7e907d06dafe4687e579fce76b37e4e93b7605022da52e6ccc26fd2");
1771     InitBasicFS, Always, TestOutput (
1772       [["write_file"; "/new"; "test\n"; "0"];
1773        ["checksum"; "sha384"; "/new"]], "109bb6b5b6d5547c1ce03c7a8bd7d8f80c1cb0957f50c4f7fda04692079917e4f9cad52b878f3d8234e1a170b154b72d");
1774     InitBasicFS, Always, TestOutput (
1775       [["write_file"; "/new"; "test\n"; "0"];
1776        ["checksum"; "sha512"; "/new"]], "0e3e75234abc68f4378a86b3f4b32a198ba301845b0cd6e50106e874345700cc6663a86c1ea125dc5e92be17c98f9a0f85ca9d5f595db2012f7cc3571945c123");
1777     InitBasicFS, Always, TestOutput (
1778       (* RHEL 5 thinks this is an HFS+ filesystem unless we give
1779        * the type explicitly.
1780        *)
1781       [["mount_vfs"; "ro"; "squashfs"; "/dev/sdd"; "/"];
1782        ["checksum"; "md5"; "/known-3"]], "46d6ca27ee07cdc6fa99c2e138cc522c")],
1783    "compute MD5, SHAx or CRC checksum of file",
1784    "\
1785 This call computes the MD5, SHAx or CRC checksum of the
1786 file named C<path>.
1787
1788 The type of checksum to compute is given by the C<csumtype>
1789 parameter which must have one of the following values:
1790
1791 =over 4
1792
1793 =item C<crc>
1794
1795 Compute the cyclic redundancy check (CRC) specified by POSIX
1796 for the C<cksum> command.
1797
1798 =item C<md5>
1799
1800 Compute the MD5 hash (using the C<md5sum> program).
1801
1802 =item C<sha1>
1803
1804 Compute the SHA1 hash (using the C<sha1sum> program).
1805
1806 =item C<sha224>
1807
1808 Compute the SHA224 hash (using the C<sha224sum> program).
1809
1810 =item C<sha256>
1811
1812 Compute the SHA256 hash (using the C<sha256sum> program).
1813
1814 =item C<sha384>
1815
1816 Compute the SHA384 hash (using the C<sha384sum> program).
1817
1818 =item C<sha512>
1819
1820 Compute the SHA512 hash (using the C<sha512sum> program).
1821
1822 =back
1823
1824 The checksum is returned as a printable string.");
1825
1826   ("tar_in", (RErr, [FileIn "tarfile"; String "directory"]), 69, [],
1827    [InitBasicFS, Always, TestOutput (
1828       [["tar_in"; "../images/helloworld.tar"; "/"];
1829        ["cat"; "/hello"]], "hello\n")],
1830    "unpack tarfile to directory",
1831    "\
1832 This command uploads and unpacks local file C<tarfile> (an
1833 I<uncompressed> tar file) into C<directory>.
1834
1835 To upload a compressed tarball, use C<guestfs_tgz_in>.");
1836
1837   ("tar_out", (RErr, [String "directory"; FileOut "tarfile"]), 70, [],
1838    [],
1839    "pack directory into tarfile",
1840    "\
1841 This command packs the contents of C<directory> and downloads
1842 it to local file C<tarfile>.
1843
1844 To download a compressed tarball, use C<guestfs_tgz_out>.");
1845
1846   ("tgz_in", (RErr, [FileIn "tarball"; String "directory"]), 71, [],
1847    [InitBasicFS, Always, TestOutput (
1848       [["tgz_in"; "../images/helloworld.tar.gz"; "/"];
1849        ["cat"; "/hello"]], "hello\n")],
1850    "unpack compressed tarball to directory",
1851    "\
1852 This command uploads and unpacks local file C<tarball> (a
1853 I<gzip compressed> tar file) into C<directory>.
1854
1855 To upload an uncompressed tarball, use C<guestfs_tar_in>.");
1856
1857   ("tgz_out", (RErr, [String "directory"; FileOut "tarball"]), 72, [],
1858    [],
1859    "pack directory into compressed tarball",
1860    "\
1861 This command packs the contents of C<directory> and downloads
1862 it to local file C<tarball>.
1863
1864 To download an uncompressed tarball, use C<guestfs_tar_out>.");
1865
1866   ("mount_ro", (RErr, [String "device"; String "mountpoint"]), 73, [],
1867    [InitBasicFS, Always, TestLastFail (
1868       [["umount"; "/"];
1869        ["mount_ro"; "/dev/sda1"; "/"];
1870        ["touch"; "/new"]]);
1871     InitBasicFS, Always, TestOutput (
1872       [["write_file"; "/new"; "data"; "0"];
1873        ["umount"; "/"];
1874        ["mount_ro"; "/dev/sda1"; "/"];
1875        ["cat"; "/new"]], "data")],
1876    "mount a guest disk, read-only",
1877    "\
1878 This is the same as the C<guestfs_mount> command, but it
1879 mounts the filesystem with the read-only (I<-o ro>) flag.");
1880
1881   ("mount_options", (RErr, [String "options"; String "device"; String "mountpoint"]), 74, [],
1882    [],
1883    "mount a guest disk with mount options",
1884    "\
1885 This is the same as the C<guestfs_mount> command, but it
1886 allows you to set the mount options as for the
1887 L<mount(8)> I<-o> flag.");
1888
1889   ("mount_vfs", (RErr, [String "options"; String "vfstype"; String "device"; String "mountpoint"]), 75, [],
1890    [],
1891    "mount a guest disk with mount options and vfstype",
1892    "\
1893 This is the same as the C<guestfs_mount> command, but it
1894 allows you to set both the mount options and the vfstype
1895 as for the L<mount(8)> I<-o> and I<-t> flags.");
1896
1897   ("debug", (RString "result", [String "subcmd"; StringList "extraargs"]), 76, [],
1898    [],
1899    "debugging and internals",
1900    "\
1901 The C<guestfs_debug> command exposes some internals of
1902 C<guestfsd> (the guestfs daemon) that runs inside the
1903 qemu subprocess.
1904
1905 There is no comprehensive help for this command.  You have
1906 to look at the file C<daemon/debug.c> in the libguestfs source
1907 to find out what you can do.");
1908
1909   ("lvremove", (RErr, [String "device"]), 77, [],
1910    [InitEmpty, Always, TestOutputList (
1911       [["sfdiskM"; "/dev/sda"; ","];
1912        ["pvcreate"; "/dev/sda1"];
1913        ["vgcreate"; "VG"; "/dev/sda1"];
1914        ["lvcreate"; "LV1"; "VG"; "50"];
1915        ["lvcreate"; "LV2"; "VG"; "50"];
1916        ["lvremove"; "/dev/VG/LV1"];
1917        ["lvs"]], ["/dev/VG/LV2"]);
1918     InitEmpty, Always, TestOutputList (
1919       [["sfdiskM"; "/dev/sda"; ","];
1920        ["pvcreate"; "/dev/sda1"];
1921        ["vgcreate"; "VG"; "/dev/sda1"];
1922        ["lvcreate"; "LV1"; "VG"; "50"];
1923        ["lvcreate"; "LV2"; "VG"; "50"];
1924        ["lvremove"; "/dev/VG"];
1925        ["lvs"]], []);
1926     InitEmpty, Always, TestOutputList (
1927       [["sfdiskM"; "/dev/sda"; ","];
1928        ["pvcreate"; "/dev/sda1"];
1929        ["vgcreate"; "VG"; "/dev/sda1"];
1930        ["lvcreate"; "LV1"; "VG"; "50"];
1931        ["lvcreate"; "LV2"; "VG"; "50"];
1932        ["lvremove"; "/dev/VG"];
1933        ["vgs"]], ["VG"])],
1934    "remove an LVM logical volume",
1935    "\
1936 Remove an LVM logical volume C<device>, where C<device> is
1937 the path to the LV, such as C</dev/VG/LV>.
1938
1939 You can also remove all LVs in a volume group by specifying
1940 the VG name, C</dev/VG>.");
1941
1942   ("vgremove", (RErr, [String "vgname"]), 78, [],
1943    [InitEmpty, Always, TestOutputList (
1944       [["sfdiskM"; "/dev/sda"; ","];
1945        ["pvcreate"; "/dev/sda1"];
1946        ["vgcreate"; "VG"; "/dev/sda1"];
1947        ["lvcreate"; "LV1"; "VG"; "50"];
1948        ["lvcreate"; "LV2"; "VG"; "50"];
1949        ["vgremove"; "VG"];
1950        ["lvs"]], []);
1951     InitEmpty, Always, TestOutputList (
1952       [["sfdiskM"; "/dev/sda"; ","];
1953        ["pvcreate"; "/dev/sda1"];
1954        ["vgcreate"; "VG"; "/dev/sda1"];
1955        ["lvcreate"; "LV1"; "VG"; "50"];
1956        ["lvcreate"; "LV2"; "VG"; "50"];
1957        ["vgremove"; "VG"];
1958        ["vgs"]], [])],
1959    "remove an LVM volume group",
1960    "\
1961 Remove an LVM volume group C<vgname>, (for example C<VG>).
1962
1963 This also forcibly removes all logical volumes in the volume
1964 group (if any).");
1965
1966   ("pvremove", (RErr, [String "device"]), 79, [],
1967    [InitEmpty, Always, TestOutputListOfDevices (
1968       [["sfdiskM"; "/dev/sda"; ","];
1969        ["pvcreate"; "/dev/sda1"];
1970        ["vgcreate"; "VG"; "/dev/sda1"];
1971        ["lvcreate"; "LV1"; "VG"; "50"];
1972        ["lvcreate"; "LV2"; "VG"; "50"];
1973        ["vgremove"; "VG"];
1974        ["pvremove"; "/dev/sda1"];
1975        ["lvs"]], []);
1976     InitEmpty, Always, TestOutputListOfDevices (
1977       [["sfdiskM"; "/dev/sda"; ","];
1978        ["pvcreate"; "/dev/sda1"];
1979        ["vgcreate"; "VG"; "/dev/sda1"];
1980        ["lvcreate"; "LV1"; "VG"; "50"];
1981        ["lvcreate"; "LV2"; "VG"; "50"];
1982        ["vgremove"; "VG"];
1983        ["pvremove"; "/dev/sda1"];
1984        ["vgs"]], []);
1985     InitEmpty, Always, TestOutputListOfDevices (
1986       [["sfdiskM"; "/dev/sda"; ","];
1987        ["pvcreate"; "/dev/sda1"];
1988        ["vgcreate"; "VG"; "/dev/sda1"];
1989        ["lvcreate"; "LV1"; "VG"; "50"];
1990        ["lvcreate"; "LV2"; "VG"; "50"];
1991        ["vgremove"; "VG"];
1992        ["pvremove"; "/dev/sda1"];
1993        ["pvs"]], [])],
1994    "remove an LVM physical volume",
1995    "\
1996 This wipes a physical volume C<device> so that LVM will no longer
1997 recognise it.
1998
1999 The implementation uses the C<pvremove> command which refuses to
2000 wipe physical volumes that contain any volume groups, so you have
2001 to remove those first.");
2002
2003   ("set_e2label", (RErr, [String "device"; String "label"]), 80, [],
2004    [InitBasicFS, Always, TestOutput (
2005       [["set_e2label"; "/dev/sda1"; "testlabel"];
2006        ["get_e2label"; "/dev/sda1"]], "testlabel")],
2007    "set the ext2/3/4 filesystem label",
2008    "\
2009 This sets the ext2/3/4 filesystem label of the filesystem on
2010 C<device> to C<label>.  Filesystem labels are limited to
2011 16 characters.
2012
2013 You can use either C<guestfs_tune2fs_l> or C<guestfs_get_e2label>
2014 to return the existing label on a filesystem.");
2015
2016   ("get_e2label", (RString "label", [String "device"]), 81, [],
2017    [],
2018    "get the ext2/3/4 filesystem label",
2019    "\
2020 This returns the ext2/3/4 filesystem label of the filesystem on
2021 C<device>.");
2022
2023   ("set_e2uuid", (RErr, [String "device"; String "uuid"]), 82, [],
2024    [InitBasicFS, Always, TestOutput (
2025       [["set_e2uuid"; "/dev/sda1"; "a3a61220-882b-4f61-89f4-cf24dcc7297d"];
2026        ["get_e2uuid"; "/dev/sda1"]], "a3a61220-882b-4f61-89f4-cf24dcc7297d");
2027     InitBasicFS, Always, TestOutput (
2028       [["set_e2uuid"; "/dev/sda1"; "clear"];
2029        ["get_e2uuid"; "/dev/sda1"]], "");
2030     (* We can't predict what UUIDs will be, so just check the commands run. *)
2031     InitBasicFS, Always, TestRun (
2032       [["set_e2uuid"; "/dev/sda1"; "random"]]);
2033     InitBasicFS, Always, TestRun (
2034       [["set_e2uuid"; "/dev/sda1"; "time"]])],
2035    "set the ext2/3/4 filesystem UUID",
2036    "\
2037 This sets the ext2/3/4 filesystem UUID of the filesystem on
2038 C<device> to C<uuid>.  The format of the UUID and alternatives
2039 such as C<clear>, C<random> and C<time> are described in the
2040 L<tune2fs(8)> manpage.
2041
2042 You can use either C<guestfs_tune2fs_l> or C<guestfs_get_e2uuid>
2043 to return the existing UUID of a filesystem.");
2044
2045   ("get_e2uuid", (RString "uuid", [String "device"]), 83, [],
2046    [],
2047    "get the ext2/3/4 filesystem UUID",
2048    "\
2049 This returns the ext2/3/4 filesystem UUID of the filesystem on
2050 C<device>.");
2051
2052   ("fsck", (RInt "status", [String "fstype"; String "device"]), 84, [],
2053    [InitBasicFS, Always, TestOutputInt (
2054       [["umount"; "/dev/sda1"];
2055        ["fsck"; "ext2"; "/dev/sda1"]], 0);
2056     InitBasicFS, Always, TestOutputInt (
2057       [["umount"; "/dev/sda1"];
2058        ["zero"; "/dev/sda1"];
2059        ["fsck"; "ext2"; "/dev/sda1"]], 8)],
2060    "run the filesystem checker",
2061    "\
2062 This runs the filesystem checker (fsck) on C<device> which
2063 should have filesystem type C<fstype>.
2064
2065 The returned integer is the status.  See L<fsck(8)> for the
2066 list of status codes from C<fsck>.
2067
2068 Notes:
2069
2070 =over 4
2071
2072 =item *
2073
2074 Multiple status codes can be summed together.
2075
2076 =item *
2077
2078 A non-zero return code can mean \"success\", for example if
2079 errors have been corrected on the filesystem.
2080
2081 =item *
2082
2083 Checking or repairing NTFS volumes is not supported
2084 (by linux-ntfs).
2085
2086 =back
2087
2088 This command is entirely equivalent to running C<fsck -a -t fstype device>.");
2089
2090   ("zero", (RErr, [String "device"]), 85, [],
2091    [InitBasicFS, Always, TestOutput (
2092       [["umount"; "/dev/sda1"];
2093        ["zero"; "/dev/sda1"];
2094        ["file"; "/dev/sda1"]], "data")],
2095    "write zeroes to the device",
2096    "\
2097 This command writes zeroes over the first few blocks of C<device>.
2098
2099 How many blocks are zeroed isn't specified (but it's I<not> enough
2100 to securely wipe the device).  It should be sufficient to remove
2101 any partition tables, filesystem superblocks and so on.
2102
2103 See also: C<guestfs_scrub_device>.");
2104
2105   ("grub_install", (RErr, [String "root"; String "device"]), 86, [],
2106    (* Test disabled because grub-install incompatible with virtio-blk driver.
2107     * See also: https://bugzilla.redhat.com/show_bug.cgi?id=479760
2108     *)
2109    [InitBasicFS, Disabled, TestOutputTrue (
2110       [["grub_install"; "/"; "/dev/sda1"];
2111        ["is_dir"; "/boot"]])],
2112    "install GRUB",
2113    "\
2114 This command installs GRUB (the Grand Unified Bootloader) on
2115 C<device>, with the root directory being C<root>.");
2116
2117   ("cp", (RErr, [String "src"; String "dest"]), 87, [],
2118    [InitBasicFS, Always, TestOutput (
2119       [["write_file"; "/old"; "file content"; "0"];
2120        ["cp"; "/old"; "/new"];
2121        ["cat"; "/new"]], "file content");
2122     InitBasicFS, Always, TestOutputTrue (
2123       [["write_file"; "/old"; "file content"; "0"];
2124        ["cp"; "/old"; "/new"];
2125        ["is_file"; "/old"]]);
2126     InitBasicFS, Always, TestOutput (
2127       [["write_file"; "/old"; "file content"; "0"];
2128        ["mkdir"; "/dir"];
2129        ["cp"; "/old"; "/dir/new"];
2130        ["cat"; "/dir/new"]], "file content")],
2131    "copy a file",
2132    "\
2133 This copies a file from C<src> to C<dest> where C<dest> is
2134 either a destination filename or destination directory.");
2135
2136   ("cp_a", (RErr, [String "src"; String "dest"]), 88, [],
2137    [InitBasicFS, Always, TestOutput (
2138       [["mkdir"; "/olddir"];
2139        ["mkdir"; "/newdir"];
2140        ["write_file"; "/olddir/file"; "file content"; "0"];
2141        ["cp_a"; "/olddir"; "/newdir"];
2142        ["cat"; "/newdir/olddir/file"]], "file content")],
2143    "copy a file or directory recursively",
2144    "\
2145 This copies a file or directory from C<src> to C<dest>
2146 recursively using the C<cp -a> command.");
2147
2148   ("mv", (RErr, [String "src"; String "dest"]), 89, [],
2149    [InitBasicFS, Always, TestOutput (
2150       [["write_file"; "/old"; "file content"; "0"];
2151        ["mv"; "/old"; "/new"];
2152        ["cat"; "/new"]], "file content");
2153     InitBasicFS, Always, TestOutputFalse (
2154       [["write_file"; "/old"; "file content"; "0"];
2155        ["mv"; "/old"; "/new"];
2156        ["is_file"; "/old"]])],
2157    "move a file",
2158    "\
2159 This moves a file from C<src> to C<dest> where C<dest> is
2160 either a destination filename or destination directory.");
2161
2162   ("drop_caches", (RErr, [Int "whattodrop"]), 90, [],
2163    [InitEmpty, Always, TestRun (
2164       [["drop_caches"; "3"]])],
2165    "drop kernel page cache, dentries and inodes",
2166    "\
2167 This instructs the guest kernel to drop its page cache,
2168 and/or dentries and inode caches.  The parameter C<whattodrop>
2169 tells the kernel what precisely to drop, see
2170 L<http://linux-mm.org/Drop_Caches>
2171
2172 Setting C<whattodrop> to 3 should drop everything.
2173
2174 This automatically calls L<sync(2)> before the operation,
2175 so that the maximum guest memory is freed.");
2176
2177   ("dmesg", (RString "kmsgs", []), 91, [],
2178    [InitEmpty, Always, TestRun (
2179       [["dmesg"]])],
2180    "return kernel messages",
2181    "\
2182 This returns the kernel messages (C<dmesg> output) from
2183 the guest kernel.  This is sometimes useful for extended
2184 debugging of problems.
2185
2186 Another way to get the same information is to enable
2187 verbose messages with C<guestfs_set_verbose> or by setting
2188 the environment variable C<LIBGUESTFS_DEBUG=1> before
2189 running the program.");
2190
2191   ("ping_daemon", (RErr, []), 92, [],
2192    [InitEmpty, Always, TestRun (
2193       [["ping_daemon"]])],
2194    "ping the guest daemon",
2195    "\
2196 This is a test probe into the guestfs daemon running inside
2197 the qemu subprocess.  Calling this function checks that the
2198 daemon responds to the ping message, without affecting the daemon
2199 or attached block device(s) in any other way.");
2200
2201   ("equal", (RBool "equality", [String "file1"; String "file2"]), 93, [],
2202    [InitBasicFS, Always, TestOutputTrue (
2203       [["write_file"; "/file1"; "contents of a file"; "0"];
2204        ["cp"; "/file1"; "/file2"];
2205        ["equal"; "/file1"; "/file2"]]);
2206     InitBasicFS, Always, TestOutputFalse (
2207       [["write_file"; "/file1"; "contents of a file"; "0"];
2208        ["write_file"; "/file2"; "contents of another file"; "0"];
2209        ["equal"; "/file1"; "/file2"]]);
2210     InitBasicFS, Always, TestLastFail (
2211       [["equal"; "/file1"; "/file2"]])],
2212    "test if two files have equal contents",
2213    "\
2214 This compares the two files C<file1> and C<file2> and returns
2215 true if their content is exactly equal, or false otherwise.
2216
2217 The external L<cmp(1)> program is used for the comparison.");
2218
2219   ("strings", (RStringList "stringsout", [String "path"]), 94, [ProtocolLimitWarning],
2220    [InitBasicFS, Always, TestOutputList (
2221       [["write_file"; "/new"; "hello\nworld\n"; "0"];
2222        ["strings"; "/new"]], ["hello"; "world"]);
2223     InitBasicFS, Always, TestOutputList (
2224       [["touch"; "/new"];
2225        ["strings"; "/new"]], [])],
2226    "print the printable strings in a file",
2227    "\
2228 This runs the L<strings(1)> command on a file and returns
2229 the list of printable strings found.");
2230
2231   ("strings_e", (RStringList "stringsout", [String "encoding"; String "path"]), 95, [ProtocolLimitWarning],
2232    [InitBasicFS, Always, TestOutputList (
2233       [["write_file"; "/new"; "hello\nworld\n"; "0"];
2234        ["strings_e"; "b"; "/new"]], []);
2235     InitBasicFS, Disabled, TestOutputList (
2236       [["write_file"; "/new"; "\000h\000e\000l\000l\000o\000\n\000w\000o\000r\000l\000d\000\n"; "24"];
2237        ["strings_e"; "b"; "/new"]], ["hello"; "world"])],
2238    "print the printable strings in a file",
2239    "\
2240 This is like the C<guestfs_strings> command, but allows you to
2241 specify the encoding.
2242
2243 See the L<strings(1)> manpage for the full list of encodings.
2244
2245 Commonly useful encodings are C<l> (lower case L) which will
2246 show strings inside Windows/x86 files.
2247
2248 The returned strings are transcoded to UTF-8.");
2249
2250   ("hexdump", (RString "dump", [String "path"]), 96, [ProtocolLimitWarning],
2251    [InitBasicFS, Always, TestOutput (
2252       [["write_file"; "/new"; "hello\nworld\n"; "12"];
2253        ["hexdump"; "/new"]], "00000000  68 65 6c 6c 6f 0a 77 6f  72 6c 64 0a              |hello.world.|\n0000000c\n");
2254     (* Test for RHBZ#501888c2 regression which caused large hexdump
2255      * commands to segfault.
2256      *)
2257     InitBasicFS, Always, TestRun (
2258       [["mount_vfs"; "ro"; "squashfs"; "/dev/sdd"; "/"];
2259        ["hexdump"; "/100krandom"]])],
2260    "dump a file in hexadecimal",
2261    "\
2262 This runs C<hexdump -C> on the given C<path>.  The result is
2263 the human-readable, canonical hex dump of the file.");
2264
2265   ("zerofree", (RErr, [String "device"]), 97, [],
2266    [InitNone, Always, TestOutput (
2267       [["sfdiskM"; "/dev/sda"; ","];
2268        ["mkfs"; "ext3"; "/dev/sda1"];
2269        ["mount"; "/dev/sda1"; "/"];
2270        ["write_file"; "/new"; "test file"; "0"];
2271        ["umount"; "/dev/sda1"];
2272        ["zerofree"; "/dev/sda1"];
2273        ["mount"; "/dev/sda1"; "/"];
2274        ["cat"; "/new"]], "test file")],
2275    "zero unused inodes and disk blocks on ext2/3 filesystem",
2276    "\
2277 This runs the I<zerofree> program on C<device>.  This program
2278 claims to zero unused inodes and disk blocks on an ext2/3
2279 filesystem, thus making it possible to compress the filesystem
2280 more effectively.
2281
2282 You should B<not> run this program if the filesystem is
2283 mounted.
2284
2285 It is possible that using this program can damage the filesystem
2286 or data on the filesystem.");
2287
2288   ("pvresize", (RErr, [String "device"]), 98, [],
2289    [],
2290    "resize an LVM physical volume",
2291    "\
2292 This resizes (expands or shrinks) an existing LVM physical
2293 volume to match the new size of the underlying device.");
2294
2295   ("sfdisk_N", (RErr, [String "device"; Int "partnum";
2296                        Int "cyls"; Int "heads"; Int "sectors";
2297                        String "line"]), 99, [DangerWillRobinson],
2298    [],
2299    "modify a single partition on a block device",
2300    "\
2301 This runs L<sfdisk(8)> option to modify just the single
2302 partition C<n> (note: C<n> counts from 1).
2303
2304 For other parameters, see C<guestfs_sfdisk>.  You should usually
2305 pass C<0> for the cyls/heads/sectors parameters.");
2306
2307   ("sfdisk_l", (RString "partitions", [String "device"]), 100, [],
2308    [],
2309    "display the partition table",
2310    "\
2311 This displays the partition table on C<device>, in the
2312 human-readable output of the L<sfdisk(8)> command.  It is
2313 not intended to be parsed.");
2314
2315   ("sfdisk_kernel_geometry", (RString "partitions", [String "device"]), 101, [],
2316    [],
2317    "display the kernel geometry",
2318    "\
2319 This displays the kernel's idea of the geometry of C<device>.
2320
2321 The result is in human-readable format, and not designed to
2322 be parsed.");
2323
2324   ("sfdisk_disk_geometry", (RString "partitions", [String "device"]), 102, [],
2325    [],
2326    "display the disk geometry from the partition table",
2327    "\
2328 This displays the disk geometry of C<device> read from the
2329 partition table.  Especially in the case where the underlying
2330 block device has been resized, this can be different from the
2331 kernel's idea of the geometry (see C<guestfs_sfdisk_kernel_geometry>).
2332
2333 The result is in human-readable format, and not designed to
2334 be parsed.");
2335
2336   ("vg_activate_all", (RErr, [Bool "activate"]), 103, [],
2337    [],
2338    "activate or deactivate all volume groups",
2339    "\
2340 This command activates or (if C<activate> is false) deactivates
2341 all logical volumes in all volume groups.
2342 If activated, then they are made known to the
2343 kernel, ie. they appear as C</dev/mapper> devices.  If deactivated,
2344 then those devices disappear.
2345
2346 This command is the same as running C<vgchange -a y|n>");
2347
2348   ("vg_activate", (RErr, [Bool "activate"; StringList "volgroups"]), 104, [],
2349    [],
2350    "activate or deactivate some volume groups",
2351    "\
2352 This command activates or (if C<activate> is false) deactivates
2353 all logical volumes in the listed volume groups C<volgroups>.
2354 If activated, then they are made known to the
2355 kernel, ie. they appear as C</dev/mapper> devices.  If deactivated,
2356 then those devices disappear.
2357
2358 This command is the same as running C<vgchange -a y|n volgroups...>
2359
2360 Note that if C<volgroups> is an empty list then B<all> volume groups
2361 are activated or deactivated.");
2362
2363   ("lvresize", (RErr, [String "device"; Int "mbytes"]), 105, [],
2364    [InitNone, Always, TestOutput (
2365       [["sfdiskM"; "/dev/sda"; ","];
2366        ["pvcreate"; "/dev/sda1"];
2367        ["vgcreate"; "VG"; "/dev/sda1"];
2368        ["lvcreate"; "LV"; "VG"; "10"];
2369        ["mkfs"; "ext2"; "/dev/VG/LV"];
2370        ["mount"; "/dev/VG/LV"; "/"];
2371        ["write_file"; "/new"; "test content"; "0"];
2372        ["umount"; "/"];
2373        ["lvresize"; "/dev/VG/LV"; "20"];
2374        ["e2fsck_f"; "/dev/VG/LV"];
2375        ["resize2fs"; "/dev/VG/LV"];
2376        ["mount"; "/dev/VG/LV"; "/"];
2377        ["cat"; "/new"]], "test content")],
2378    "resize an LVM logical volume",
2379    "\
2380 This resizes (expands or shrinks) an existing LVM logical
2381 volume to C<mbytes>.  When reducing, data in the reduced part
2382 is lost.");
2383
2384   ("resize2fs", (RErr, [String "device"]), 106, [],
2385    [], (* lvresize tests this *)
2386    "resize an ext2/ext3 filesystem",
2387    "\
2388 This resizes an ext2 or ext3 filesystem to match the size of
2389 the underlying device.
2390
2391 I<Note:> It is sometimes required that you run C<guestfs_e2fsck_f>
2392 on the C<device> before calling this command.  For unknown reasons
2393 C<resize2fs> sometimes gives an error about this and sometimes not.
2394 In any case, it is always safe to call C<guestfs_e2fsck_f> before
2395 calling this function.");
2396
2397   ("find", (RStringList "names", [String "directory"]), 107, [],
2398    [InitBasicFS, Always, TestOutputList (
2399       [["find"; "/"]], ["lost+found"]);
2400     InitBasicFS, Always, TestOutputList (
2401       [["touch"; "/a"];
2402        ["mkdir"; "/b"];
2403        ["touch"; "/b/c"];
2404        ["find"; "/"]], ["a"; "b"; "b/c"; "lost+found"]);
2405     InitBasicFS, Always, TestOutputList (
2406       [["mkdir_p"; "/a/b/c"];
2407        ["touch"; "/a/b/c/d"];
2408        ["find"; "/a/b/"]], ["c"; "c/d"])],
2409    "find all files and directories",
2410    "\
2411 This command lists out all files and directories, recursively,
2412 starting at C<directory>.  It is essentially equivalent to
2413 running the shell command C<find directory -print> but some
2414 post-processing happens on the output, described below.
2415
2416 This returns a list of strings I<without any prefix>.  Thus
2417 if the directory structure was:
2418
2419  /tmp/a
2420  /tmp/b
2421  /tmp/c/d
2422
2423 then the returned list from C<guestfs_find> C</tmp> would be
2424 4 elements:
2425
2426  a
2427  b
2428  c
2429  c/d
2430
2431 If C<directory> is not a directory, then this command returns
2432 an error.
2433
2434 The returned list is sorted.");
2435
2436   ("e2fsck_f", (RErr, [String "device"]), 108, [],
2437    [], (* lvresize tests this *)
2438    "check an ext2/ext3 filesystem",
2439    "\
2440 This runs C<e2fsck -p -f device>, ie. runs the ext2/ext3
2441 filesystem checker on C<device>, noninteractively (C<-p>),
2442 even if the filesystem appears to be clean (C<-f>).
2443
2444 This command is only needed because of C<guestfs_resize2fs>
2445 (q.v.).  Normally you should use C<guestfs_fsck>.");
2446
2447   ("sleep", (RErr, [Int "secs"]), 109, [],
2448    [InitNone, Always, TestRun (
2449       [["sleep"; "1"]])],
2450    "sleep for some seconds",
2451    "\
2452 Sleep for C<secs> seconds.");
2453
2454   ("ntfs_3g_probe", (RInt "status", [Bool "rw"; String "device"]), 110, [],
2455    [InitNone, Always, TestOutputInt (
2456       [["sfdiskM"; "/dev/sda"; ","];
2457        ["mkfs"; "ntfs"; "/dev/sda1"];
2458        ["ntfs_3g_probe"; "true"; "/dev/sda1"]], 0);
2459     InitNone, Always, TestOutputInt (
2460       [["sfdiskM"; "/dev/sda"; ","];
2461        ["mkfs"; "ext2"; "/dev/sda1"];
2462        ["ntfs_3g_probe"; "true"; "/dev/sda1"]], 12)],
2463    "probe NTFS volume",
2464    "\
2465 This command runs the L<ntfs-3g.probe(8)> command which probes
2466 an NTFS C<device> for mountability.  (Not all NTFS volumes can
2467 be mounted read-write, and some cannot be mounted at all).
2468
2469 C<rw> is a boolean flag.  Set it to true if you want to test
2470 if the volume can be mounted read-write.  Set it to false if
2471 you want to test if the volume can be mounted read-only.
2472
2473 The return value is an integer which C<0> if the operation
2474 would succeed, or some non-zero value documented in the
2475 L<ntfs-3g.probe(8)> manual page.");
2476
2477   ("sh", (RString "output", [String "command"]), 111, [],
2478    [], (* XXX needs tests *)
2479    "run a command via the shell",
2480    "\
2481 This call runs a command from the guest filesystem via the
2482 guest's C</bin/sh>.
2483
2484 This is like C<guestfs_command>, but passes the command to:
2485
2486  /bin/sh -c \"command\"
2487
2488 Depending on the guest's shell, this usually results in
2489 wildcards being expanded, shell expressions being interpolated
2490 and so on.
2491
2492 All the provisos about C<guestfs_command> apply to this call.");
2493
2494   ("sh_lines", (RStringList "lines", [String "command"]), 112, [],
2495    [], (* XXX needs tests *)
2496    "run a command via the shell returning lines",
2497    "\
2498 This is the same as C<guestfs_sh>, but splits the result
2499 into a list of lines.
2500
2501 See also: C<guestfs_command_lines>");
2502
2503   ("glob_expand", (RStringList "paths", [String "pattern"]), 113, [],
2504    [InitBasicFS, Always, TestOutputList (
2505       [["mkdir_p"; "/a/b/c"];
2506        ["touch"; "/a/b/c/d"];
2507        ["touch"; "/a/b/c/e"];
2508        ["glob_expand"; "/a/b/c/*"]], ["/a/b/c/d"; "/a/b/c/e"]);
2509     InitBasicFS, Always, TestOutputList (
2510       [["mkdir_p"; "/a/b/c"];
2511        ["touch"; "/a/b/c/d"];
2512        ["touch"; "/a/b/c/e"];
2513        ["glob_expand"; "/a/*/c/*"]], ["/a/b/c/d"; "/a/b/c/e"]);
2514     InitBasicFS, Always, TestOutputList (
2515       [["mkdir_p"; "/a/b/c"];
2516        ["touch"; "/a/b/c/d"];
2517        ["touch"; "/a/b/c/e"];
2518        ["glob_expand"; "/a/*/x/*"]], [])],
2519    "expand a wildcard path",
2520    "\
2521 This command searches for all the pathnames matching
2522 C<pattern> according to the wildcard expansion rules
2523 used by the shell.
2524
2525 If no paths match, then this returns an empty list
2526 (note: not an error).
2527
2528 It is just a wrapper around the C L<glob(3)> function
2529 with flags C<GLOB_MARK|GLOB_BRACE>.
2530 See that manual page for more details.");
2531
2532   ("scrub_device", (RErr, [String "device"]), 114, [DangerWillRobinson],
2533    [InitNone, Always, TestRun ( (* use /dev/sdc because it's smaller *)
2534       [["scrub_device"; "/dev/sdc"]])],
2535    "scrub (securely wipe) a device",
2536    "\
2537 This command writes patterns over C<device> to make data retrieval
2538 more difficult.
2539
2540 It is an interface to the L<scrub(1)> program.  See that
2541 manual page for more details.");
2542
2543   ("scrub_file", (RErr, [String "file"]), 115, [],
2544    [InitBasicFS, Always, TestRun (
2545       [["write_file"; "/file"; "content"; "0"];
2546        ["scrub_file"; "/file"]])],
2547    "scrub (securely wipe) a file",
2548    "\
2549 This command writes patterns over a file to make data retrieval
2550 more difficult.
2551
2552 The file is I<removed> after scrubbing.
2553
2554 It is an interface to the L<scrub(1)> program.  See that
2555 manual page for more details.");
2556
2557   ("scrub_freespace", (RErr, [String "dir"]), 116, [],
2558    [], (* XXX needs testing *)
2559    "scrub (securely wipe) free space",
2560    "\
2561 This command creates the directory C<dir> and then fills it
2562 with files until the filesystem is full, and scrubs the files
2563 as for C<guestfs_scrub_file>, and deletes them.
2564 The intention is to scrub any free space on the partition
2565 containing C<dir>.
2566
2567 It is an interface to the L<scrub(1)> program.  See that
2568 manual page for more details.");
2569
2570   ("mkdtemp", (RString "dir", [String "template"]), 117, [],
2571    [InitBasicFS, Always, TestRun (
2572       [["mkdir"; "/tmp"];
2573        ["mkdtemp"; "/tmp/tmpXXXXXX"]])],
2574    "create a temporary directory",
2575    "\
2576 This command creates a temporary directory.  The
2577 C<template> parameter should be a full pathname for the
2578 temporary directory name with the final six characters being
2579 \"XXXXXX\".
2580
2581 For example: \"/tmp/myprogXXXXXX\" or \"/Temp/myprogXXXXXX\",
2582 the second one being suitable for Windows filesystems.
2583
2584 The name of the temporary directory that was created
2585 is returned.
2586
2587 The temporary directory is created with mode 0700
2588 and is owned by root.
2589
2590 The caller is responsible for deleting the temporary
2591 directory and its contents after use.
2592
2593 See also: L<mkdtemp(3)>");
2594
2595   ("wc_l", (RInt "lines", [String "path"]), 118, [],
2596    [InitBasicFS, Always, TestOutputInt (
2597       [["mount_vfs"; "ro"; "squashfs"; "/dev/sdd"; "/"];
2598        ["wc_l"; "/10klines"]], 10000)],
2599    "count lines in a file",
2600    "\
2601 This command counts the lines in a file, using the
2602 C<wc -l> external command.");
2603
2604   ("wc_w", (RInt "words", [String "path"]), 119, [],
2605    [InitBasicFS, Always, TestOutputInt (
2606       [["mount_vfs"; "ro"; "squashfs"; "/dev/sdd"; "/"];
2607        ["wc_w"; "/10klines"]], 10000)],
2608    "count words in a file",
2609    "\
2610 This command counts the words in a file, using the
2611 C<wc -w> external command.");
2612
2613   ("wc_c", (RInt "chars", [String "path"]), 120, [],
2614    [InitBasicFS, Always, TestOutputInt (
2615       [["mount_vfs"; "ro"; "squashfs"; "/dev/sdd"; "/"];
2616        ["wc_c"; "/100kallspaces"]], 102400)],
2617    "count characters in a file",
2618    "\
2619 This command counts the characters in a file, using the
2620 C<wc -c> external command.");
2621
2622   ("head", (RStringList "lines", [String "path"]), 121, [ProtocolLimitWarning],
2623    [InitBasicFS, Always, TestOutputList (
2624       [["mount_vfs"; "ro"; "squashfs"; "/dev/sdd"; "/"];
2625        ["head"; "/10klines"]], ["0abcdefghijklmnopqrstuvwxyz";"1abcdefghijklmnopqrstuvwxyz";"2abcdefghijklmnopqrstuvwxyz";"3abcdefghijklmnopqrstuvwxyz";"4abcdefghijklmnopqrstuvwxyz";"5abcdefghijklmnopqrstuvwxyz";"6abcdefghijklmnopqrstuvwxyz";"7abcdefghijklmnopqrstuvwxyz";"8abcdefghijklmnopqrstuvwxyz";"9abcdefghijklmnopqrstuvwxyz"])],
2626    "return first 10 lines of a file",
2627    "\
2628 This command returns up to the first 10 lines of a file as
2629 a list of strings.");
2630
2631   ("head_n", (RStringList "lines", [Int "nrlines"; String "path"]), 122, [ProtocolLimitWarning],
2632    [InitBasicFS, Always, TestOutputList (
2633       [["mount_vfs"; "ro"; "squashfs"; "/dev/sdd"; "/"];
2634        ["head_n"; "3"; "/10klines"]], ["0abcdefghijklmnopqrstuvwxyz";"1abcdefghijklmnopqrstuvwxyz";"2abcdefghijklmnopqrstuvwxyz"]);
2635     InitBasicFS, Always, TestOutputList (
2636       [["mount_vfs"; "ro"; "squashfs"; "/dev/sdd"; "/"];
2637        ["head_n"; "-9997"; "/10klines"]], ["0abcdefghijklmnopqrstuvwxyz";"1abcdefghijklmnopqrstuvwxyz";"2abcdefghijklmnopqrstuvwxyz"]);
2638     InitBasicFS, Always, TestOutputList (
2639       [["mount_vfs"; "ro"; "squashfs"; "/dev/sdd"; "/"];
2640        ["head_n"; "0"; "/10klines"]], [])],
2641    "return first N lines of a file",
2642    "\
2643 If the parameter C<nrlines> is a positive number, this returns the first
2644 C<nrlines> lines of the file C<path>.
2645
2646 If the parameter C<nrlines> is a negative number, this returns lines
2647 from the file C<path>, excluding the last C<nrlines> lines.
2648
2649 If the parameter C<nrlines> is zero, this returns an empty list.");
2650
2651   ("tail", (RStringList "lines", [String "path"]), 123, [ProtocolLimitWarning],
2652    [InitBasicFS, Always, TestOutputList (
2653       [["mount_vfs"; "ro"; "squashfs"; "/dev/sdd"; "/"];
2654        ["tail"; "/10klines"]], ["9990abcdefghijklmnopqrstuvwxyz";"9991abcdefghijklmnopqrstuvwxyz";"9992abcdefghijklmnopqrstuvwxyz";"9993abcdefghijklmnopqrstuvwxyz";"9994abcdefghijklmnopqrstuvwxyz";"9995abcdefghijklmnopqrstuvwxyz";"9996abcdefghijklmnopqrstuvwxyz";"9997abcdefghijklmnopqrstuvwxyz";"9998abcdefghijklmnopqrstuvwxyz";"9999abcdefghijklmnopqrstuvwxyz"])],
2655    "return last 10 lines of a file",
2656    "\
2657 This command returns up to the last 10 lines of a file as
2658 a list of strings.");
2659
2660   ("tail_n", (RStringList "lines", [Int "nrlines"; String "path"]), 124, [ProtocolLimitWarning],
2661    [InitBasicFS, Always, TestOutputList (
2662       [["mount_vfs"; "ro"; "squashfs"; "/dev/sdd"; "/"];
2663        ["tail_n"; "3"; "/10klines"]], ["9997abcdefghijklmnopqrstuvwxyz";"9998abcdefghijklmnopqrstuvwxyz";"9999abcdefghijklmnopqrstuvwxyz"]);
2664     InitBasicFS, Always, TestOutputList (
2665       [["mount_vfs"; "ro"; "squashfs"; "/dev/sdd"; "/"];
2666        ["tail_n"; "-9998"; "/10klines"]], ["9997abcdefghijklmnopqrstuvwxyz";"9998abcdefghijklmnopqrstuvwxyz";"9999abcdefghijklmnopqrstuvwxyz"]);
2667     InitBasicFS, Always, TestOutputList (
2668       [["mount_vfs"; "ro"; "squashfs"; "/dev/sdd"; "/"];
2669        ["tail_n"; "0"; "/10klines"]], [])],
2670    "return last N lines of a file",
2671    "\
2672 If the parameter C<nrlines> is a positive number, this returns the last
2673 C<nrlines> lines of the file C<path>.
2674
2675 If the parameter C<nrlines> is a negative number, this returns lines
2676 from the file C<path>, starting with the C<-nrlines>th line.
2677
2678 If the parameter C<nrlines> is zero, this returns an empty list.");
2679
2680   ("df", (RString "output", []), 125, [],
2681    [], (* XXX Tricky to test because it depends on the exact format
2682         * of the 'df' command and other imponderables.
2683         *)
2684    "report file system disk space usage",
2685    "\
2686 This command runs the C<df> command to report disk space used.
2687
2688 This command is mostly useful for interactive sessions.  It
2689 is I<not> intended that you try to parse the output string.
2690 Use C<statvfs> from programs.");
2691
2692   ("df_h", (RString "output", []), 126, [],
2693    [], (* XXX Tricky to test because it depends on the exact format
2694         * of the 'df' command and other imponderables.
2695         *)
2696    "report file system disk space usage (human readable)",
2697    "\
2698 This command runs the C<df -h> command to report disk space used
2699 in human-readable format.
2700
2701 This command is mostly useful for interactive sessions.  It
2702 is I<not> intended that you try to parse the output string.
2703 Use C<statvfs> from programs.");
2704
2705   ("du", (RInt64 "sizekb", [String "path"]), 127, [],
2706    [InitBasicFS, Always, TestOutputInt (
2707       [["mkdir"; "/p"];
2708        ["du"; "/p"]], 1 (* ie. 1 block, so depends on ext3 blocksize *))],
2709    "estimate file space usage",
2710    "\
2711 This command runs the C<du -s> command to estimate file space
2712 usage for C<path>.
2713
2714 C<path> can be a file or a directory.  If C<path> is a directory
2715 then the estimate includes the contents of the directory and all
2716 subdirectories (recursively).
2717
2718 The result is the estimated size in I<kilobytes>
2719 (ie. units of 1024 bytes).");
2720
2721   ("initrd_list", (RStringList "filenames", [String "path"]), 128, [],
2722    [InitBasicFS, Always, TestOutputList (
2723       [["mount_vfs"; "ro"; "squashfs"; "/dev/sdd"; "/"];
2724        ["initrd_list"; "/initrd"]], ["empty";"known-1";"known-2";"known-3"])],
2725    "list files in an initrd",
2726    "\
2727 This command lists out files contained in an initrd.
2728
2729 The files are listed without any initial C</> character.  The
2730 files are listed in the order they appear (not necessarily
2731 alphabetical).  Directory names are listed as separate items.
2732
2733 Old Linux kernels (2.4 and earlier) used a compressed ext2
2734 filesystem as initrd.  We I<only> support the newer initramfs
2735 format (compressed cpio files).");
2736
2737   ("mount_loop", (RErr, [String "file"; String "mountpoint"]), 129, [],
2738    [],
2739    "mount a file using the loop device",
2740    "\
2741 This command lets you mount C<file> (a filesystem image
2742 in a file) on a mount point.  It is entirely equivalent to
2743 the command C<mount -o loop file mountpoint>.");
2744
2745   ("mkswap", (RErr, [String "device"]), 130, [],
2746    [InitEmpty, Always, TestRun (
2747       [["sfdiskM"; "/dev/sda"; ","];
2748        ["mkswap"; "/dev/sda1"]])],
2749    "create a swap partition",
2750    "\
2751 Create a swap partition on C<device>.");
2752
2753   ("mkswap_L", (RErr, [String "label"; String "device"]), 131, [],
2754    [InitEmpty, Always, TestRun (
2755       [["sfdiskM"; "/dev/sda"; ","];
2756        ["mkswap_L"; "hello"; "/dev/sda1"]])],
2757    "create a swap partition with a label",
2758    "\
2759 Create a swap partition on C<device> with label C<label>.");
2760
2761   ("mkswap_U", (RErr, [String "uuid"; String "device"]), 132, [],
2762    [InitEmpty, Always, TestRun (
2763       [["sfdiskM"; "/dev/sda"; ","];
2764        ["mkswap_U"; "a3a61220-882b-4f61-89f4-cf24dcc7297d"; "/dev/sda1"]])],
2765    "create a swap partition with an explicit UUID",
2766    "\
2767 Create a swap partition on C<device> with UUID C<uuid>.");
2768
2769   ("mknod", (RErr, [Int "mode"; Int "devmajor"; Int "devminor"; String "path"]), 133, [],
2770    [InitBasicFS, Always, TestOutputStruct (
2771       [["mknod"; "0o10777"; "0"; "0"; "/node"];
2772        (* NB: default umask 022 means 0777 -> 0755 in these tests *)
2773        ["stat"; "/node"]], [CompareWithInt ("mode", 0o10755)]);
2774     InitBasicFS, Always, TestOutputStruct (
2775       [["mknod"; "0o60777"; "66"; "99"; "/node"];
2776        ["stat"; "/node"]], [CompareWithInt ("mode", 0o60755)])],
2777    "make block, character or FIFO devices",
2778    "\
2779 This call creates block or character special devices, or
2780 named pipes (FIFOs).
2781
2782 The C<mode> parameter should be the mode, using the standard
2783 constants.  C<devmajor> and C<devminor> are the
2784 device major and minor numbers, only used when creating block
2785 and character special devices.");
2786
2787   ("mkfifo", (RErr, [Int "mode"; String "path"]), 134, [],
2788    [InitBasicFS, Always, TestOutputStruct (
2789       [["mkfifo"; "0o777"; "/node"];
2790        ["stat"; "/node"]], [CompareWithInt ("mode", 0o10755)])],
2791    "make FIFO (named pipe)",
2792    "\
2793 This call creates a FIFO (named pipe) called C<path> with
2794 mode C<mode>.  It is just a convenient wrapper around
2795 C<guestfs_mknod>.");
2796
2797   ("mknod_b", (RErr, [Int "mode"; Int "devmajor"; Int "devminor"; String "path"]), 135, [],
2798    [InitBasicFS, Always, TestOutputStruct (
2799       [["mknod_b"; "0o777"; "99"; "66"; "/node"];
2800        ["stat"; "/node"]], [CompareWithInt ("mode", 0o60755)])],
2801    "make block device node",
2802    "\
2803 This call creates a block device node called C<path> with
2804 mode C<mode> and device major/minor C<devmajor> and C<devminor>.
2805 It is just a convenient wrapper around C<guestfs_mknod>.");
2806
2807   ("mknod_c", (RErr, [Int "mode"; Int "devmajor"; Int "devminor"; String "path"]), 136, [],
2808    [InitBasicFS, Always, TestOutputStruct (
2809       [["mknod_c"; "0o777"; "99"; "66"; "/node"];
2810        ["stat"; "/node"]], [CompareWithInt ("mode", 0o20755)])],
2811    "make char device node",
2812    "\
2813 This call creates a char device node called C<path> with
2814 mode C<mode> and device major/minor C<devmajor> and C<devminor>.
2815 It is just a convenient wrapper around C<guestfs_mknod>.");
2816
2817   ("umask", (RInt "oldmask", [Int "mask"]), 137, [],
2818    [], (* XXX umask is one of those stateful things that we should
2819         * reset between each test.
2820         *)
2821    "set file mode creation mask (umask)",
2822    "\
2823 This function sets the mask used for creating new files and
2824 device nodes to C<mask & 0777>.
2825
2826 Typical umask values would be C<022> which creates new files
2827 with permissions like \"-rw-r--r--\" or \"-rwxr-xr-x\", and
2828 C<002> which creates new files with permissions like
2829 \"-rw-rw-r--\" or \"-rwxrwxr-x\".
2830
2831 The default umask is C<022>.  This is important because it
2832 means that directories and device nodes will be created with
2833 C<0644> or C<0755> mode even if you specify C<0777>.
2834
2835 See also L<umask(2)>, C<guestfs_mknod>, C<guestfs_mkdir>.
2836
2837 This call returns the previous umask.");
2838
2839   ("readdir", (RStructList ("entries", "dirent"), [String "dir"]), 138, [],
2840    [],
2841    "read directories entries",
2842    "\
2843 This returns the list of directory entries in directory C<dir>.
2844
2845 All entries in the directory are returned, including C<.> and
2846 C<..>.  The entries are I<not> sorted, but returned in the same
2847 order as the underlying filesystem.
2848
2849 Also this call returns basic file type information about each
2850 file.  The C<ftyp> field will contain one of the following characters:
2851
2852 =over 4
2853
2854 =item 'b'
2855
2856 Block special
2857
2858 =item 'c'
2859
2860 Char special
2861
2862 =item 'd'
2863
2864 Directory
2865
2866 =item 'f'
2867
2868 FIFO (named pipe)
2869
2870 =item 'l'
2871
2872 Symbolic link
2873
2874 =item 'r'
2875
2876 Regular file
2877
2878 =item 's'
2879
2880 Socket
2881
2882 =item 'u'
2883
2884 Unknown file type
2885
2886 =item '?'
2887
2888 The L<readdir(3)> returned a C<d_type> field with an
2889 unexpected value
2890
2891 =back
2892
2893 This function is primarily intended for use by programs.  To
2894 get a simple list of names, use C<guestfs_ls>.  To get a printable
2895 directory for human consumption, use C<guestfs_ll>.");
2896
2897   ("sfdiskM", (RErr, [String "device"; StringList "lines"]), 139, [DangerWillRobinson],
2898    [],
2899    "create partitions on a block device",
2900    "\
2901 This is a simplified interface to the C<guestfs_sfdisk>
2902 command, where partition sizes are specified in megabytes
2903 only (rounded to the nearest cylinder) and you don't need
2904 to specify the cyls, heads and sectors parameters which
2905 were rarely if ever used anyway.
2906
2907 See also C<guestfs_sfdisk> and the L<sfdisk(8)> manpage.");
2908
2909   ("zfile", (RString "description", [String "method"; String "path"]), 140, [],
2910    [],
2911    "determine file type inside a compressed file",
2912    "\
2913 This command runs C<file> after first decompressing C<path>
2914 using C<method>.
2915
2916 C<method> must be one of C<gzip>, C<compress> or C<bzip2>.
2917
2918 See also: C<guestfs_file>");
2919
2920   ("getxattrs", (RStructList ("xattrs", "xattr"), [String "path"]), 141, [],
2921    [],
2922    "list extended attributes of a file or directory",
2923    "\
2924 This call lists the extended attributes of the file or directory
2925 C<path>.
2926
2927 At the system call level, this is a combination of the
2928 L<listxattr(2)> and L<getxattr(2)> calls.
2929
2930 See also: C<guestfs_lgetxattrs>, L<attr(5)>.");
2931
2932   ("lgetxattrs", (RStructList ("xattrs", "xattr"), [String "path"]), 142, [],
2933    [],
2934    "list extended attributes of a file or directory",
2935    "\
2936 This is the same as C<guestfs_getxattrs>, but if C<path>
2937 is a symbolic link, then it returns the extended attributes
2938 of the link itself.");
2939
2940   ("setxattr", (RErr, [String "xattr";
2941                        String "val"; Int "vallen"; (* will be BufferIn *)
2942                        String "path"]), 143, [],
2943    [],
2944    "set extended attribute of a file or directory",
2945    "\
2946 This call sets the extended attribute named C<xattr>
2947 of the file C<path> to the value C<val> (of length C<vallen>).
2948 The value is arbitrary 8 bit data.
2949
2950 See also: C<guestfs_lsetxattr>, L<attr(5)>.");
2951
2952   ("lsetxattr", (RErr, [String "xattr";
2953                         String "val"; Int "vallen"; (* will be BufferIn *)
2954                         String "path"]), 144, [],
2955    [],
2956    "set extended attribute of a file or directory",
2957    "\
2958 This is the same as C<guestfs_setxattr>, but if C<path>
2959 is a symbolic link, then it sets an extended attribute
2960 of the link itself.");
2961
2962   ("removexattr", (RErr, [String "xattr"; String "path"]), 145, [],
2963    [],
2964    "remove extended attribute of a file or directory",
2965    "\
2966 This call removes the extended attribute named C<xattr>
2967 of the file C<path>.
2968
2969 See also: C<guestfs_lremovexattr>, L<attr(5)>.");
2970
2971   ("lremovexattr", (RErr, [String "xattr"; String "path"]), 146, [],
2972    [],
2973    "remove extended attribute of a file or directory",
2974    "\
2975 This is the same as C<guestfs_removexattr>, but if C<path>
2976 is a symbolic link, then it removes an extended attribute
2977 of the link itself.");
2978
2979   ("mountpoints", (RHashtable "mps", []), 147, [],
2980    [],
2981    "show mountpoints",
2982    "\
2983 This call is similar to C<guestfs_mounts>.  That call returns
2984 a list of devices.  This one returns a hash table (map) of
2985 device name to directory where the device is mounted.");
2986
2987   ("mkmountpoint", (RErr, [String "path"]), 148, [],
2988    [],
2989    "create a mountpoint",
2990    "\
2991 C<guestfs_mkmountpoint> and C<guestfs_rmmountpoint> are
2992 specialized calls that can be used to create extra mountpoints
2993 before mounting the first filesystem.
2994
2995 These calls are I<only> necessary in some very limited circumstances,
2996 mainly the case where you want to mount a mix of unrelated and/or
2997 read-only filesystems together.
2998
2999 For example, live CDs often contain a \"Russian doll\" nest of
3000 filesystems, an ISO outer layer, with a squashfs image inside, with
3001 an ext2/3 image inside that.  You can unpack this as follows
3002 in guestfish:
3003
3004  add-ro Fedora-11-i686-Live.iso
3005  run
3006  mkmountpoint /cd
3007  mkmountpoint /squash
3008  mkmountpoint /ext3
3009  mount /dev/sda /cd
3010  mount-loop /cd/LiveOS/squashfs.img /squash
3011  mount-loop /squash/LiveOS/ext3fs.img /ext3
3012
3013 The inner filesystem is now unpacked under the /ext3 mountpoint.");
3014
3015   ("rmmountpoint", (RErr, [String "path"]), 149, [],
3016    [],
3017    "remove a mountpoint",
3018    "\
3019 This calls removes a mountpoint that was previously created
3020 with C<guestfs_mkmountpoint>.  See C<guestfs_mkmountpoint>
3021 for full details.");
3022
3023   ("read_file", (RBufferOut "content", [String "path"]), 150, [ProtocolLimitWarning],
3024    [InitBasicFS, Always, TestOutput (
3025       [["write_file"; "/new"; "new file contents"; "0"];
3026        ["read_file"; "/new"]], "new file contents")],
3027    "read a file",
3028    "\
3029 This calls returns the contents of the file C<path> as a
3030 buffer.
3031
3032 Unlike C<guestfs_cat>, this function can correctly
3033 handle files that contain embedded ASCII NUL characters.
3034 However unlike C<guestfs_download>, this function is limited
3035 in the total size of file that can be handled.");
3036
3037 ]
3038
3039 let all_functions = non_daemon_functions @ daemon_functions
3040
3041 (* In some places we want the functions to be displayed sorted
3042  * alphabetically, so this is useful:
3043  *)
3044 let all_functions_sorted =
3045   List.sort (fun (n1,_,_,_,_,_,_) (n2,_,_,_,_,_,_) ->
3046                compare n1 n2) all_functions
3047
3048 (* Field types for structures. *)
3049 type field =
3050   | FChar                       (* C 'char' (really, a 7 bit byte). *)
3051   | FString                     (* nul-terminated ASCII string. *)
3052   | FBuffer                     (* opaque buffer of bytes, (char *, int) pair *)
3053   | FUInt32
3054   | FInt32
3055   | FUInt64
3056   | FInt64
3057   | FBytes                      (* Any int measure that counts bytes. *)
3058   | FUUID                       (* 32 bytes long, NOT nul-terminated. *)
3059   | FOptPercent                 (* [0..100], or -1 meaning "not present". *)
3060
3061 (* Because we generate extra parsing code for LVM command line tools,
3062  * we have to pull out the LVM columns separately here.
3063  *)
3064 let lvm_pv_cols = [
3065   "pv_name", FString;
3066   "pv_uuid", FUUID;
3067   "pv_fmt", FString;
3068   "pv_size", FBytes;
3069   "dev_size", FBytes;
3070   "pv_free", FBytes;
3071   "pv_used", FBytes;
3072   "pv_attr", FString (* XXX *);
3073   "pv_pe_count", FInt64;
3074   "pv_pe_alloc_count", FInt64;
3075   "pv_tags", FString;
3076   "pe_start", FBytes;
3077   "pv_mda_count", FInt64;
3078   "pv_mda_free", FBytes;
3079   (* Not in Fedora 10:
3080      "pv_mda_size", FBytes;
3081   *)
3082 ]
3083 let lvm_vg_cols = [
3084   "vg_name", FString;
3085   "vg_uuid", FUUID;
3086   "vg_fmt", FString;
3087   "vg_attr", FString (* XXX *);
3088   "vg_size", FBytes;
3089   "vg_free", FBytes;
3090   "vg_sysid", FString;
3091   "vg_extent_size", FBytes;
3092   "vg_extent_count", FInt64;
3093   "vg_free_count", FInt64;
3094   "max_lv", FInt64;
3095   "max_pv", FInt64;
3096   "pv_count", FInt64;
3097   "lv_count", FInt64;
3098   "snap_count", FInt64;
3099   "vg_seqno", FInt64;
3100   "vg_tags", FString;
3101   "vg_mda_count", FInt64;
3102   "vg_mda_free", FBytes;
3103   (* Not in Fedora 10:
3104      "vg_mda_size", FBytes;
3105   *)
3106 ]
3107 let lvm_lv_cols = [
3108   "lv_name", FString;
3109   "lv_uuid", FUUID;
3110   "lv_attr", FString (* XXX *);
3111   "lv_major", FInt64;
3112   "lv_minor", FInt64;
3113   "lv_kernel_major", FInt64;
3114   "lv_kernel_minor", FInt64;
3115   "lv_size", FBytes;
3116   "seg_count", FInt64;
3117   "origin", FString;
3118   "snap_percent", FOptPercent;
3119   "copy_percent", FOptPercent;
3120   "move_pv", FString;
3121   "lv_tags", FString;
3122   "mirror_log", FString;
3123   "modules", FString;
3124 ]
3125
3126 (* Names and fields in all structures (in RStruct and RStructList)
3127  * that we support.
3128  *)
3129 let structs = [
3130   (* The old RIntBool return type, only ever used for aug_defnode.  Do
3131    * not use this struct in any new code.
3132    *)
3133   "int_bool", [
3134     "i", FInt32;                (* for historical compatibility *)
3135     "b", FInt32;                (* for historical compatibility *)
3136   ];
3137
3138   (* LVM PVs, VGs, LVs. *)
3139   "lvm_pv", lvm_pv_cols;
3140   "lvm_vg", lvm_vg_cols;
3141   "lvm_lv", lvm_lv_cols;
3142
3143   (* Column names and types from stat structures.
3144    * NB. Can't use things like 'st_atime' because glibc header files
3145    * define some of these as macros.  Ugh.
3146    *)
3147   "stat", [
3148     "dev", FInt64;
3149     "ino", FInt64;
3150     "mode", FInt64;
3151     "nlink", FInt64;
3152     "uid", FInt64;
3153     "gid", FInt64;
3154     "rdev", FInt64;
3155     "size", FInt64;
3156     "blksize", FInt64;
3157     "blocks", FInt64;
3158     "atime", FInt64;
3159     "mtime", FInt64;
3160     "ctime", FInt64;
3161   ];
3162   "statvfs", [
3163     "bsize", FInt64;
3164     "frsize", FInt64;
3165     "blocks", FInt64;
3166     "bfree", FInt64;
3167     "bavail", FInt64;
3168     "files", FInt64;
3169     "ffree", FInt64;
3170     "favail", FInt64;
3171     "fsid", FInt64;
3172     "flag", FInt64;
3173     "namemax", FInt64;
3174   ];
3175
3176   (* Column names in dirent structure. *)
3177   "dirent", [
3178     "ino", FInt64;
3179     (* 'b' 'c' 'd' 'f' (FIFO) 'l' 'r' (regular file) 's' 'u' '?' *)
3180     "ftyp", FChar;
3181     "name", FString;
3182   ];
3183
3184   (* Version numbers. *)
3185   "version", [
3186     "major", FInt64;
3187     "minor", FInt64;
3188     "release", FInt64;
3189     "extra", FString;
3190   ];
3191
3192   (* Extended attribute. *)
3193   "xattr", [
3194     "attrname", FString;
3195     "attrval", FBuffer;
3196   ];
3197 ] (* end of structs *)
3198
3199 (* Ugh, Java has to be different ..
3200  * These names are also used by the Haskell bindings.
3201  *)
3202 let java_structs = [
3203   "int_bool", "IntBool";
3204   "lvm_pv", "PV";
3205   "lvm_vg", "VG";
3206   "lvm_lv", "LV";
3207   "stat", "Stat";
3208   "statvfs", "StatVFS";
3209   "dirent", "Dirent";
3210   "version", "Version";
3211   "xattr", "XAttr";
3212 ]
3213
3214 (* Used for testing language bindings. *)
3215 type callt =
3216   | CallString of string
3217   | CallOptString of string option
3218   | CallStringList of string list
3219   | CallInt of int
3220   | CallBool of bool
3221
3222 (* Used to memoize the result of pod2text. *)
3223 let pod2text_memo_filename = "src/.pod2text.data"
3224 let pod2text_memo : ((int * string * string), string list) Hashtbl.t =
3225   try
3226     let chan = open_in pod2text_memo_filename in
3227     let v = input_value chan in
3228     close_in chan;
3229     v
3230   with
3231     _ -> Hashtbl.create 13
3232
3233 (* Useful functions.
3234  * Note we don't want to use any external OCaml libraries which
3235  * makes this a bit harder than it should be.
3236  *)
3237 let failwithf fs = ksprintf failwith fs
3238
3239 let replace_char s c1 c2 =
3240   let s2 = String.copy s in
3241   let r = ref false in
3242   for i = 0 to String.length s2 - 1 do
3243     if String.unsafe_get s2 i = c1 then (
3244       String.unsafe_set s2 i c2;
3245       r := true
3246     )
3247   done;
3248   if not !r then s else s2
3249
3250 let isspace c =
3251   c = ' '
3252   (* || c = '\f' *) || c = '\n' || c = '\r' || c = '\t' (* || c = '\v' *)
3253
3254 let triml ?(test = isspace) str =
3255   let i = ref 0 in
3256   let n = ref (String.length str) in
3257   while !n > 0 && test str.[!i]; do
3258     decr n;
3259     incr i
3260   done;
3261   if !i = 0 then str
3262   else String.sub str !i !n
3263
3264 let trimr ?(test = isspace) str =
3265   let n = ref (String.length str) in
3266   while !n > 0 && test str.[!n-1]; do
3267     decr n
3268   done;
3269   if !n = String.length str then str
3270   else String.sub str 0 !n
3271
3272 let trim ?(test = isspace) str =
3273   trimr ~test (triml ~test str)
3274
3275 let rec find s sub =
3276   let len = String.length s in
3277   let sublen = String.length sub in
3278   let rec loop i =
3279     if i <= len-sublen then (
3280       let rec loop2 j =
3281         if j < sublen then (
3282           if s.[i+j] = sub.[j] then loop2 (j+1)
3283           else -1
3284         ) else
3285           i (* found *)
3286       in
3287       let r = loop2 0 in
3288       if r = -1 then loop (i+1) else r
3289     ) else
3290       -1 (* not found *)
3291   in
3292   loop 0
3293
3294 let rec replace_str s s1 s2 =
3295   let len = String.length s in
3296   let sublen = String.length s1 in
3297   let i = find s s1 in
3298   if i = -1 then s
3299   else (
3300     let s' = String.sub s 0 i in
3301     let s'' = String.sub s (i+sublen) (len-i-sublen) in
3302     s' ^ s2 ^ replace_str s'' s1 s2
3303   )
3304
3305 let rec string_split sep str =
3306   let len = String.length str in
3307   let seplen = String.length sep in
3308   let i = find str sep in
3309   if i = -1 then [str]
3310   else (
3311     let s' = String.sub str 0 i in
3312     let s'' = String.sub str (i+seplen) (len-i-seplen) in
3313     s' :: string_split sep s''
3314   )
3315
3316 let files_equal n1 n2 =
3317   let cmd = sprintf "cmp -s %s %s" (Filename.quote n1) (Filename.quote n2) in
3318   match Sys.command cmd with
3319   | 0 -> true
3320   | 1 -> false
3321   | i -> failwithf "%s: failed with error code %d" cmd i
3322
3323 let rec find_map f = function
3324   | [] -> raise Not_found
3325   | x :: xs ->
3326       match f x with
3327       | Some y -> y
3328       | None -> find_map f xs
3329
3330 let iteri f xs =
3331   let rec loop i = function
3332     | [] -> ()
3333     | x :: xs -> f i x; loop (i+1) xs
3334   in
3335   loop 0 xs
3336
3337 let mapi f xs =
3338   let rec loop i = function
3339     | [] -> []
3340     | x :: xs -> let r = f i x in r :: loop (i+1) xs
3341   in
3342   loop 0 xs
3343
3344 let name_of_argt = function
3345   | String n | OptString n | StringList n | Bool n | Int n
3346   | FileIn n | FileOut n -> n
3347
3348 let java_name_of_struct typ =
3349   try List.assoc typ java_structs
3350   with Not_found ->
3351     failwithf
3352       "java_name_of_struct: no java_structs entry corresponding to %s" typ
3353
3354 let cols_of_struct typ =
3355   try List.assoc typ structs
3356   with Not_found ->
3357     failwithf "cols_of_struct: unknown struct %s" typ
3358
3359 let seq_of_test = function
3360   | TestRun s | TestOutput (s, _) | TestOutputList (s, _)
3361   | TestOutputListOfDevices (s, _)
3362   | TestOutputInt (s, _) | TestOutputIntOp (s, _, _)
3363   | TestOutputTrue s | TestOutputFalse s
3364   | TestOutputLength (s, _) | TestOutputStruct (s, _)
3365   | TestLastFail s -> s
3366
3367 (* Check function names etc. for consistency. *)
3368 let check_functions () =
3369   let contains_uppercase str =
3370     let len = String.length str in
3371     let rec loop i =
3372       if i >= len then false
3373       else (
3374         let c = str.[i] in
3375         if c >= 'A' && c <= 'Z' then true
3376         else loop (i+1)
3377       )
3378     in
3379     loop 0
3380   in
3381
3382   (* Check function names. *)
3383   List.iter (
3384     fun (name, _, _, _, _, _, _) ->
3385       if String.length name >= 7 && String.sub name 0 7 = "guestfs" then
3386         failwithf "function name %s does not need 'guestfs' prefix" name;
3387       if name = "" then
3388         failwithf "function name is empty";
3389       if name.[0] < 'a' || name.[0] > 'z' then
3390         failwithf "function name %s must start with lowercase a-z" name;
3391       if String.contains name '-' then
3392         failwithf "function name %s should not contain '-', use '_' instead."
3393           name
3394   ) all_functions;
3395
3396   (* Check function parameter/return names. *)
3397   List.iter (
3398     fun (name, style, _, _, _, _, _) ->
3399       let check_arg_ret_name n =
3400         if contains_uppercase n then
3401           failwithf "%s param/ret %s should not contain uppercase chars"
3402             name n;
3403         if String.contains n '-' || String.contains n '_' then
3404           failwithf "%s param/ret %s should not contain '-' or '_'"
3405             name n;
3406         if n = "value" then
3407           failwithf "%s has a param/ret called 'value', which causes conflicts in the OCaml bindings, use something like 'val' or a more descriptive name" name;
3408         if n = "int" || n = "char" || n = "short" || n = "long" then
3409           failwithf "%s has a param/ret which conflicts with a C type (eg. 'int', 'char' etc.)" name;
3410         if n = "i" || n = "n" then
3411           failwithf "%s has a param/ret called 'i' or 'n', which will cause some conflicts in the generated code" name;
3412         if n = "argv" || n = "args" then
3413           failwithf "%s has a param/ret called 'argv' or 'args', which will cause some conflicts in the generated code" name
3414       in
3415
3416       (match fst style with
3417        | RErr -> ()
3418        | RInt n | RInt64 n | RBool n | RConstString n | RString n
3419        | RStringList n | RStruct (n, _) | RStructList (n, _)
3420        | RHashtable n | RBufferOut n ->
3421            check_arg_ret_name n
3422       );
3423       List.iter (fun arg -> check_arg_ret_name (name_of_argt arg)) (snd style)
3424   ) all_functions;
3425
3426   (* Check short descriptions. *)
3427   List.iter (
3428     fun (name, _, _, _, _, shortdesc, _) ->
3429       if shortdesc.[0] <> Char.lowercase shortdesc.[0] then
3430         failwithf "short description of %s should begin with lowercase." name;
3431       let c = shortdesc.[String.length shortdesc-1] in
3432       if c = '\n' || c = '.' then
3433         failwithf "short description of %s should not end with . or \\n." name
3434   ) all_functions;
3435
3436   (* Check long dscriptions. *)
3437   List.iter (
3438     fun (name, _, _, _, _, _, longdesc) ->
3439       if longdesc.[String.length longdesc-1] = '\n' then
3440         failwithf "long description of %s should not end with \\n." name
3441   ) all_functions;
3442
3443   (* Check proc_nrs. *)
3444   List.iter (
3445     fun (name, _, proc_nr, _, _, _, _) ->
3446       if proc_nr <= 0 then
3447         failwithf "daemon function %s should have proc_nr > 0" name
3448   ) daemon_functions;
3449
3450   List.iter (
3451     fun (name, _, proc_nr, _, _, _, _) ->
3452       if proc_nr <> -1 then
3453         failwithf "non-daemon function %s should have proc_nr -1" name
3454   ) non_daemon_functions;
3455
3456   let proc_nrs =
3457     List.map (fun (name, _, proc_nr, _, _, _, _) -> name, proc_nr)
3458       daemon_functions in
3459   let proc_nrs =
3460     List.sort (fun (_,nr1) (_,nr2) -> compare nr1 nr2) proc_nrs in
3461   let rec loop = function
3462     | [] -> ()
3463     | [_] -> ()
3464     | (name1,nr1) :: ((name2,nr2) :: _ as rest) when nr1 < nr2 ->
3465         loop rest
3466     | (name1,nr1) :: (name2,nr2) :: _ ->
3467         failwithf "%s and %s have conflicting procedure numbers (%d, %d)"
3468           name1 name2 nr1 nr2
3469   in
3470   loop proc_nrs;
3471
3472   (* Check tests. *)
3473   List.iter (
3474     function
3475       (* Ignore functions that have no tests.  We generate a
3476        * warning when the user does 'make check' instead.
3477        *)
3478     | name, _, _, _, [], _, _ -> ()
3479     | name, _, _, _, tests, _, _ ->
3480         let funcs =
3481           List.map (
3482             fun (_, _, test) ->
3483               match seq_of_test test with
3484               | [] ->
3485                   failwithf "%s has a test containing an empty sequence" name
3486               | cmds -> List.map List.hd cmds
3487           ) tests in
3488         let funcs = List.flatten funcs in
3489
3490         let tested = List.mem name funcs in
3491
3492         if not tested then
3493           failwithf "function %s has tests but does not test itself" name
3494   ) all_functions
3495
3496 (* 'pr' prints to the current output file. *)
3497 let chan = ref stdout
3498 let pr fs = ksprintf (output_string !chan) fs
3499
3500 (* Generate a header block in a number of standard styles. *)
3501 type comment_style = CStyle | HashStyle | OCamlStyle | HaskellStyle
3502 type license = GPLv2 | LGPLv2
3503
3504 let generate_header comment license =
3505   let c = match comment with
3506     | CStyle ->     pr "/* "; " *"
3507     | HashStyle ->  pr "# ";  "#"
3508     | OCamlStyle -> pr "(* "; " *"
3509     | HaskellStyle -> pr "{- "; "  " in
3510   pr "libguestfs generated file\n";
3511   pr "%s WARNING: THIS FILE IS GENERATED BY 'src/generator.ml'.\n" c;
3512   pr "%s ANY CHANGES YOU MAKE TO THIS FILE WILL BE LOST.\n" c;
3513   pr "%s\n" c;
3514   pr "%s Copyright (C) 2009 Red Hat Inc.\n" c;
3515   pr "%s\n" c;
3516   (match license with
3517    | GPLv2 ->
3518        pr "%s This program is free software; you can redistribute it and/or modify\n" c;
3519        pr "%s it under the terms of the GNU General Public License as published by\n" c;
3520        pr "%s the Free Software Foundation; either version 2 of the License, or\n" c;
3521        pr "%s (at your option) any later version.\n" c;
3522        pr "%s\n" c;
3523        pr "%s This program is distributed in the hope that it will be useful,\n" c;
3524        pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
3525        pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the\n" c;
3526        pr "%s GNU General Public License for more details.\n" c;
3527        pr "%s\n" c;
3528        pr "%s You should have received a copy of the GNU General Public License along\n" c;
3529        pr "%s with this program; if not, write to the Free Software Foundation, Inc.,\n" c;
3530        pr "%s 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.\n" c;
3531
3532    | LGPLv2 ->
3533        pr "%s This library is free software; you can redistribute it and/or\n" c;
3534        pr "%s modify it under the terms of the GNU Lesser General Public\n" c;
3535        pr "%s License as published by the Free Software Foundation; either\n" c;
3536        pr "%s version 2 of the License, or (at your option) any later version.\n" c;
3537        pr "%s\n" c;
3538        pr "%s This library is distributed in the hope that it will be useful,\n" c;
3539        pr "%s but WITHOUT ANY WARRANTY; without even the implied warranty of\n" c;
3540        pr "%s MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU\n" c;
3541        pr "%s Lesser General Public License for more details.\n" c;
3542        pr "%s\n" c;
3543        pr "%s You should have received a copy of the GNU Lesser General Public\n" c;
3544        pr "%s License along with this library; if not, write to the Free Software\n" c;
3545        pr "%s Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA\n" c;
3546   );
3547   (match comment with
3548    | CStyle -> pr " */\n"
3549    | HashStyle -> ()
3550    | OCamlStyle -> pr " *)\n"
3551    | HaskellStyle -> pr "-}\n"
3552   );
3553   pr "\n"
3554
3555 (* Start of main code generation functions below this line. *)
3556
3557 (* Generate the pod documentation for the C API. *)
3558 let rec generate_actions_pod () =
3559   List.iter (
3560     fun (shortname, style, _, flags, _, _, longdesc) ->
3561       if not (List.mem NotInDocs flags) then (
3562         let name = "guestfs_" ^ shortname in
3563         pr "=head2 %s\n\n" name;
3564         pr " ";
3565         generate_prototype ~extern:false ~handle:"handle" name style;
3566         pr "\n\n";
3567         pr "%s\n\n" longdesc;
3568         (match fst style with
3569          | RErr ->
3570              pr "This function returns 0 on success or -1 on error.\n\n"
3571          | RInt _ ->
3572              pr "On error this function returns -1.\n\n"
3573          | RInt64 _ ->
3574              pr "On error this function returns -1.\n\n"
3575          | RBool _ ->
3576              pr "This function returns a C truth value on success or -1 on error.\n\n"
3577          | RConstString _ ->
3578              pr "This function returns a string, or NULL on error.
3579 The string is owned by the guest handle and must I<not> be freed.\n\n"
3580          | RString _ ->
3581              pr "This function returns a string, or NULL on error.
3582 I<The caller must free the returned string after use>.\n\n"
3583          | RStringList _ ->
3584              pr "This function returns a NULL-terminated array of strings
3585 (like L<environ(3)>), or NULL if there was an error.
3586 I<The caller must free the strings and the array after use>.\n\n"
3587          | RStruct (_, typ) ->
3588              pr "This function returns a C<struct guestfs_%s *>,
3589 or NULL if there was an error.
3590 I<The caller must call C<guestfs_free_%s> after use>.\n\n" typ typ
3591          | RStructList (_, typ) ->
3592              pr "This function returns a C<struct guestfs_%s_list *>
3593 (see E<lt>guestfs-structs.hE<gt>),
3594 or NULL if there was an error.
3595 I<The caller must call C<guestfs_free_%s_list> after use>.\n\n" typ typ
3596          | RHashtable _ ->
3597              pr "This function returns a NULL-terminated array of
3598 strings, or NULL if there was an error.
3599 The array of strings will always have length C<2n+1>, where
3600 C<n> keys and values alternate, followed by the trailing NULL entry.
3601 I<The caller must free the strings and the array after use>.\n\n"
3602          | RBufferOut _ ->
3603              pr "This function returns a buffer, or NULL on error.
3604 The size of the returned buffer is written to C<*size_r>.
3605 I<The caller must free the returned buffer after use>.\n\n"
3606         );
3607         if List.mem ProtocolLimitWarning flags then
3608           pr "%s\n\n" protocol_limit_warning;
3609         if List.mem DangerWillRobinson flags then
3610           pr "%s\n\n" danger_will_robinson
3611       )
3612   ) all_functions_sorted
3613
3614 and generate_structs_pod () =
3615   (* Structs documentation. *)
3616   List.iter (
3617     fun (typ, cols) ->
3618       pr "=head2 guestfs_%s\n" typ;
3619       pr "\n";
3620       pr " struct guestfs_%s {\n" typ;
3621       List.iter (
3622         function
3623         | name, FChar -> pr "   char %s;\n" name
3624         | name, FUInt32 -> pr "   uint32_t %s;\n" name
3625         | name, FInt32 -> pr "   int32_t %s;\n" name
3626         | name, (FUInt64|FBytes) -> pr "   uint64_t %s;\n" name
3627         | name, FInt64 -> pr "   int64_t %s;\n" name
3628         | name, FString -> pr "   char *%s;\n" name
3629         | name, FBuffer ->
3630             pr "   /* The next two fields describe a byte array. */\n";
3631             pr "   uint32_t %s_len;\n" name;
3632             pr "   char *%s;\n" name
3633         | name, FUUID ->
3634             pr "   /* The next field is NOT nul-terminated, be careful when printing it: */\n";
3635             pr "   char %s[32];\n" name
3636         | name, FOptPercent ->
3637             pr "   /* The next field is [0..100] or -1 meaning 'not present': */\n";
3638             pr "   float %s;\n" name
3639       ) cols;
3640       pr " };\n";
3641       pr " \n";
3642       pr " struct guestfs_%s_list {\n" typ;
3643       pr "   uint32_t len; /* Number of elements in list. */\n";
3644       pr "   struct guestfs_%s *val; /* Elements. */\n" typ;
3645       pr " };\n";
3646       pr " \n";
3647       pr " void guestfs_free_%s (struct guestfs_free_%s *);\n" typ typ;
3648       pr " void guestfs_free_%s_list (struct guestfs_free_%s_list *);\n"
3649         typ typ;
3650       pr "\n"
3651   ) structs
3652
3653 (* Generate the protocol (XDR) file, 'guestfs_protocol.x' and
3654  * indirectly 'guestfs_protocol.h' and 'guestfs_protocol.c'.
3655  *
3656  * We have to use an underscore instead of a dash because otherwise
3657  * rpcgen generates incorrect code.
3658  *
3659  * This header is NOT exported to clients, but see also generate_structs_h.
3660  *)
3661 and generate_xdr () =
3662   generate_header CStyle LGPLv2;
3663
3664   (* This has to be defined to get around a limitation in Sun's rpcgen. *)
3665   pr "typedef string str<>;\n";
3666   pr "\n";
3667
3668   (* Internal structures. *)
3669   List.iter (
3670     function
3671     | typ, cols ->
3672         pr "struct guestfs_int_%s {\n" typ;
3673         List.iter (function
3674                    | name, FChar -> pr "  char %s;\n" name
3675                    | name, FString -> pr "  string %s<>;\n" name
3676                    | name, FBuffer -> pr "  opaque %s<>;\n" name
3677                    | name, FUUID -> pr "  opaque %s[32];\n" name
3678                    | name, (FInt32|FUInt32) -> pr "  int %s;\n" name
3679                    | name, (FInt64|FUInt64|FBytes) -> pr "  hyper %s;\n" name
3680                    | name, FOptPercent -> pr "  float %s;\n" name
3681                   ) cols;
3682         pr "};\n";
3683         pr "\n";
3684         pr "typedef struct guestfs_int_%s guestfs_int_%s_list<>;\n" typ typ;
3685         pr "\n";
3686   ) structs;
3687
3688   List.iter (
3689     fun (shortname, style, _, _, _, _, _) ->
3690       let name = "guestfs_" ^ shortname in
3691
3692       (match snd style with
3693        | [] -> ()
3694        | args ->
3695            pr "struct %s_args {\n" name;
3696            List.iter (
3697              function
3698              | String n -> pr "  string %s<>;\n" n
3699              | OptString n -> pr "  str *%s;\n" n
3700              | StringList n -> pr "  str %s<>;\n" n
3701              | Bool n -> pr "  bool %s;\n" n
3702              | Int n -> pr "  int %s;\n" n
3703              | FileIn _ | FileOut _ -> ()
3704            ) args;
3705            pr "};\n\n"
3706       );
3707       (match fst style with
3708        | RErr -> ()
3709        | RInt n ->
3710            pr "struct %s_ret {\n" name;
3711            pr "  int %s;\n" n;
3712            pr "};\n\n"
3713        | RInt64 n ->
3714            pr "struct %s_ret {\n" name;
3715            pr "  hyper %s;\n" n;
3716            pr "};\n\n"
3717        | RBool n ->
3718            pr "struct %s_ret {\n" name;
3719            pr "  bool %s;\n" n;
3720            pr "};\n\n"
3721        | RConstString _ ->
3722            failwithf "RConstString cannot be returned from a daemon function"
3723        | RString n ->
3724            pr "struct %s_ret {\n" name;
3725            pr "  string %s<>;\n" n;
3726            pr "};\n\n"
3727        | RStringList n ->
3728            pr "struct %s_ret {\n" name;
3729            pr "  str %s<>;\n" n;
3730            pr "};\n\n"
3731        | RStruct (n, typ) ->
3732            pr "struct %s_ret {\n" name;
3733            pr "  guestfs_int_%s %s;\n" typ n;
3734            pr "};\n\n"
3735        | RStructList (n, typ) ->
3736            pr "struct %s_ret {\n" name;
3737            pr "  guestfs_int_%s_list %s;\n" typ n;
3738            pr "};\n\n"
3739        | RHashtable n ->
3740            pr "struct %s_ret {\n" name;
3741            pr "  str %s<>;\n" n;
3742            pr "};\n\n"
3743        | RBufferOut n ->
3744            pr "struct %s_ret {\n" name;
3745            pr "  opaque %s<>;\n" n;
3746            pr "};\n\n"
3747       );
3748   ) daemon_functions;
3749
3750   (* Table of procedure numbers. *)
3751   pr "enum guestfs_procedure {\n";
3752   List.iter (
3753     fun (shortname, _, proc_nr, _, _, _, _) ->
3754       pr "  GUESTFS_PROC_%s = %d,\n" (String.uppercase shortname) proc_nr
3755   ) daemon_functions;
3756   pr "  GUESTFS_PROC_NR_PROCS\n";
3757   pr "};\n";
3758   pr "\n";
3759
3760   (* Having to choose a maximum message size is annoying for several
3761    * reasons (it limits what we can do in the API), but it (a) makes
3762    * the protocol a lot simpler, and (b) provides a bound on the size
3763    * of the daemon which operates in limited memory space.  For large
3764    * file transfers you should use FTP.
3765    *)
3766   pr "const GUESTFS_MESSAGE_MAX = %d;\n" (4 * 1024 * 1024);
3767   pr "\n";
3768
3769   (* Message header, etc. *)
3770   pr "\
3771 /* The communication protocol is now documented in the guestfs(3)
3772  * manpage.
3773  */
3774
3775 const GUESTFS_PROGRAM = 0x2000F5F5;
3776 const GUESTFS_PROTOCOL_VERSION = 1;
3777
3778 /* These constants must be larger than any possible message length. */
3779 const GUESTFS_LAUNCH_FLAG = 0xf5f55ff5;
3780 const GUESTFS_CANCEL_FLAG = 0xffffeeee;
3781
3782 enum guestfs_message_direction {
3783   GUESTFS_DIRECTION_CALL = 0,        /* client -> daemon */
3784   GUESTFS_DIRECTION_REPLY = 1        /* daemon -> client */
3785 };
3786
3787 enum guestfs_message_status {
3788   GUESTFS_STATUS_OK = 0,
3789   GUESTFS_STATUS_ERROR = 1
3790 };
3791
3792 const GUESTFS_ERROR_LEN = 256;
3793
3794 struct guestfs_message_error {
3795   string error_message<GUESTFS_ERROR_LEN>;
3796 };
3797
3798 struct guestfs_message_header {
3799   unsigned prog;                     /* GUESTFS_PROGRAM */
3800   unsigned vers;                     /* GUESTFS_PROTOCOL_VERSION */
3801   guestfs_procedure proc;            /* GUESTFS_PROC_x */
3802   guestfs_message_direction direction;
3803   unsigned serial;                   /* message serial number */
3804   guestfs_message_status status;
3805 };
3806
3807 const GUESTFS_MAX_CHUNK_SIZE = 8192;
3808
3809 struct guestfs_chunk {
3810   int cancel;                        /* if non-zero, transfer is cancelled */
3811   /* data size is 0 bytes if the transfer has finished successfully */
3812   opaque data<GUESTFS_MAX_CHUNK_SIZE>;
3813 };
3814 "
3815
3816 (* Generate the guestfs-structs.h file. *)
3817 and generate_structs_h () =
3818   generate_header CStyle LGPLv2;
3819
3820   (* This is a public exported header file containing various
3821    * structures.  The structures are carefully written to have
3822    * exactly the same in-memory format as the XDR structures that
3823    * we use on the wire to the daemon.  The reason for creating
3824    * copies of these structures here is just so we don't have to
3825    * export the whole of guestfs_protocol.h (which includes much
3826    * unrelated and XDR-dependent stuff that we don't want to be
3827    * public, or required by clients).
3828    *
3829    * To reiterate, we will pass these structures to and from the
3830    * client with a simple assignment or memcpy, so the format
3831    * must be identical to what rpcgen / the RFC defines.
3832    *)
3833
3834   (* Public structures. *)
3835   List.iter (
3836     fun (typ, cols) ->
3837       pr "struct guestfs_%s {\n" typ;
3838       List.iter (
3839         function
3840         | name, FChar -> pr "  char %s;\n" name
3841         | name, FString -> pr "  char *%s;\n" name
3842         | name, FBuffer ->
3843             pr "  uint32_t %s_len;\n" name;
3844             pr "  char *%s;\n" name
3845         | name, FUUID -> pr "  char %s[32]; /* this is NOT nul-terminated, be careful when printing */\n" name
3846         | name, FUInt32 -> pr "  uint32_t %s;\n" name
3847         | name, FInt32 -> pr "  int32_t %s;\n" name
3848         | name, (FUInt64|FBytes) -> pr "  uint64_t %s;\n" name
3849         | name, FInt64 -> pr "  int64_t %s;\n" name
3850         | name, FOptPercent -> pr "  float %s; /* [0..100] or -1 */\n" name
3851       ) cols;
3852       pr "};\n";
3853       pr "\n";
3854       pr "struct guestfs_%s_list {\n" typ;
3855       pr "  uint32_t len;\n";
3856       pr "  struct guestfs_%s *val;\n" typ;
3857       pr "};\n";
3858       pr "\n";
3859       pr "extern void guestfs_free_%s (struct guestfs_%s *);\n" typ typ;
3860       pr "extern void guestfs_free_%s_list (struct guestfs_%s_list *);\n" typ typ;
3861       pr "\n"
3862   ) structs
3863
3864 (* Generate the guestfs-actions.h file. *)
3865 and generate_actions_h () =
3866   generate_header CStyle LGPLv2;
3867   List.iter (
3868     fun (shortname, style, _, _, _, _, _) ->
3869       let name = "guestfs_" ^ shortname in
3870       generate_prototype ~single_line:true ~newline:true ~handle:"handle"
3871         name style
3872   ) all_functions
3873
3874 (* Generate the client-side dispatch stubs. *)
3875 and generate_client_actions () =
3876   generate_header CStyle LGPLv2;
3877
3878   pr "\
3879 #include <stdio.h>
3880 #include <stdlib.h>
3881
3882 #include \"guestfs.h\"
3883 #include \"guestfs_protocol.h\"
3884
3885 #define error guestfs_error
3886 #define perrorf guestfs_perrorf
3887 #define safe_malloc guestfs_safe_malloc
3888 #define safe_realloc guestfs_safe_realloc
3889 #define safe_strdup guestfs_safe_strdup
3890 #define safe_memdup guestfs_safe_memdup
3891
3892 /* Check the return message from a call for validity. */
3893 static int
3894 check_reply_header (guestfs_h *g,
3895                     const struct guestfs_message_header *hdr,
3896                     int proc_nr, int serial)
3897 {
3898   if (hdr->prog != GUESTFS_PROGRAM) {
3899     error (g, \"wrong program (%%d/%%d)\", hdr->prog, GUESTFS_PROGRAM);
3900     return -1;
3901   }
3902   if (hdr->vers != GUESTFS_PROTOCOL_VERSION) {
3903     error (g, \"wrong protocol version (%%d/%%d)\",
3904            hdr->vers, GUESTFS_PROTOCOL_VERSION);
3905     return -1;
3906   }
3907   if (hdr->direction != GUESTFS_DIRECTION_REPLY) {
3908     error (g, \"unexpected message direction (%%d/%%d)\",
3909            hdr->direction, GUESTFS_DIRECTION_REPLY);
3910     return -1;
3911   }
3912   if (hdr->proc != proc_nr) {
3913     error (g, \"unexpected procedure number (%%d/%%d)\", hdr->proc, proc_nr);
3914     return -1;
3915   }
3916   if (hdr->serial != serial) {
3917     error (g, \"unexpected serial (%%d/%%d)\", hdr->serial, serial);
3918     return -1;
3919   }
3920
3921   return 0;
3922 }
3923
3924 /* Check we are in the right state to run a high-level action. */
3925 static int
3926 check_state (guestfs_h *g, const char *caller)
3927 {
3928   if (!guestfs_is_ready (g)) {
3929     if (guestfs_is_config (g))
3930       error (g, \"%%s: call launch before using this function\\n(in guestfish, don't forget to use the 'run' command)\",
3931         caller);
3932     else if (guestfs_is_launching (g))
3933       error (g, \"%%s: call wait_ready() before using this function\",
3934         caller);
3935     else
3936       error (g, \"%%s called from the wrong state, %%d != READY\",
3937         caller, guestfs_get_state (g));
3938     return -1;
3939   }
3940   return 0;
3941 }
3942
3943 ";
3944
3945   (* Client-side stubs for each function. *)
3946   List.iter (
3947     fun (shortname, style, _, _, _, _, _) ->
3948       let name = "guestfs_" ^ shortname in
3949
3950       (* Generate the context struct which stores the high-level
3951        * state between callback functions.
3952        *)
3953       pr "struct %s_ctx {\n" shortname;
3954       pr "  /* This flag is set by the callbacks, so we know we've done\n";
3955       pr "   * the callbacks as expected, and in the right sequence.\n";
3956       pr "   * 0 = not called, 1 = reply_cb called.\n";
3957       pr "   */\n";
3958       pr "  int cb_sequence;\n";
3959       pr "  struct guestfs_message_header hdr;\n";
3960       pr "  struct guestfs_message_error err;\n";
3961       (match fst style with
3962        | RErr -> ()
3963        | RConstString _ ->
3964            failwithf "RConstString cannot be returned from a daemon function"
3965        | RInt _ | RInt64 _
3966        | RBool _ | RString _ | RStringList _
3967        | RStruct _ | RStructList _
3968        | RHashtable _ | RBufferOut _ ->
3969            pr "  struct %s_ret ret;\n" name
3970       );
3971       pr "};\n";
3972       pr "\n";
3973
3974       (* Generate the reply callback function. *)
3975       pr "static void %s_reply_cb (guestfs_h *g, void *data, XDR *xdr)\n" shortname;
3976       pr "{\n";
3977       pr "  guestfs_main_loop *ml = guestfs_get_main_loop (g);\n";
3978       pr "  struct %s_ctx *ctx = (struct %s_ctx *) data;\n" shortname shortname;
3979       pr "\n";
3980       pr "  /* This should definitely not happen. */\n";
3981       pr "  if (ctx->cb_sequence != 0) {\n";
3982       pr "    ctx->cb_sequence = 9999;\n";
3983       pr "    error (g, \"%%s: internal error: reply callback called twice\", \"%s\");\n" name;
3984       pr "    return;\n";
3985       pr "  }\n";
3986       pr "\n";
3987       pr "  ml->main_loop_quit (ml, g);\n";
3988       pr "\n";
3989       pr "  if (!xdr_guestfs_message_header (xdr, &ctx->hdr)) {\n";
3990       pr "    error (g, \"%%s: failed to parse reply header\", \"%s\");\n" name;
3991       pr "    return;\n";
3992       pr "  }\n";
3993       pr "  if (ctx->hdr.status == GUESTFS_STATUS_ERROR) {\n";
3994       pr "    if (!xdr_guestfs_message_error (xdr, &ctx->err)) {\n";
3995       pr "      error (g, \"%%s: failed to parse reply error\", \"%s\");\n"
3996         name;
3997       pr "      return;\n";
3998       pr "    }\n";
3999       pr "    goto done;\n";
4000       pr "  }\n";
4001
4002       (match fst style with
4003        | RErr -> ()
4004        | RConstString _ ->
4005            failwithf "RConstString cannot be returned from a daemon function"
4006        | RInt _ | RInt64 _
4007        | RBool _ | RString _ | RStringList _
4008        | RStruct _ | RStructList _
4009        | RHashtable _ | RBufferOut _ ->
4010            pr "  if (!xdr_%s_ret (xdr, &ctx->ret)) {\n" name;
4011            pr "    error (g, \"%%s: failed to parse reply\", \"%s\");\n" name;
4012            pr "    return;\n";
4013            pr "  }\n";
4014       );
4015
4016       pr " done:\n";
4017       pr "  ctx->cb_sequence = 1;\n";
4018       pr "}\n\n";
4019
4020       (* Generate the action stub. *)
4021       generate_prototype ~extern:false ~semicolon:false ~newline:true
4022         ~handle:"g" name style;
4023
4024       let error_code =
4025         match fst style with
4026         | RErr | RInt _ | RInt64 _ | RBool _ -> "-1"
4027         | RConstString _ ->
4028             failwithf "RConstString cannot be returned from a daemon function"
4029         | RString _ | RStringList _
4030         | RStruct _ | RStructList _
4031         | RHashtable _ | RBufferOut _ ->
4032             "NULL" in
4033
4034       pr "{\n";
4035
4036       (match snd style with
4037        | [] -> ()
4038        | _ -> pr "  struct %s_args args;\n" name
4039       );
4040
4041       pr "  struct %s_ctx ctx;\n" shortname;
4042       pr "  guestfs_main_loop *ml = guestfs_get_main_loop (g);\n";
4043       pr "  int serial;\n";
4044       pr "\n";
4045       pr "  if (check_state (g, \"%s\") == -1) return %s;\n" name error_code;
4046       pr "  guestfs_set_busy (g);\n";
4047       pr "\n";
4048       pr "  memset (&ctx, 0, sizeof ctx);\n";
4049       pr "\n";
4050
4051       (* Send the main header and arguments. *)
4052       (match snd style with
4053        | [] ->
4054            pr "  serial = guestfs__send_sync (g, GUESTFS_PROC_%s, NULL, NULL);\n"
4055              (String.uppercase shortname)
4056        | args ->
4057            List.iter (
4058              function
4059              | String n ->
4060                  pr "  args.%s = (char *) %s;\n" n n
4061              | OptString n ->
4062                  pr "  args.%s = %s ? (char **) &%s : NULL;\n" n n n
4063              | StringList n ->
4064                  pr "  args.%s.%s_val = (char **) %s;\n" n n n;
4065                  pr "  for (args.%s.%s_len = 0; %s[args.%s.%s_len]; args.%s.%s_len++) ;\n" n n n n n n n;
4066              | Bool n ->
4067                  pr "  args.%s = %s;\n" n n
4068              | Int n ->
4069                  pr "  args.%s = %s;\n" n n
4070              | FileIn _ | FileOut _ -> ()
4071            ) args;
4072            pr "  serial = guestfs__send_sync (g, GUESTFS_PROC_%s,\n"
4073              (String.uppercase shortname);
4074            pr "        (xdrproc_t) xdr_%s_args, (char *) &args);\n"
4075              name;
4076       );
4077       pr "  if (serial == -1) {\n";
4078       pr "    guestfs_end_busy (g);\n";
4079       pr "    return %s;\n" error_code;
4080       pr "  }\n";
4081       pr "\n";
4082
4083       (* Send any additional files (FileIn) requested. *)
4084       let need_read_reply_label = ref false in
4085       List.iter (
4086         function
4087         | FileIn n ->
4088             pr "  {\n";
4089             pr "    int r;\n";
4090             pr "\n";
4091             pr "    r = guestfs__send_file_sync (g, %s);\n" n;
4092             pr "    if (r == -1) {\n";
4093             pr "      guestfs_end_busy (g);\n";
4094             pr "      return %s;\n" error_code;
4095             pr "    }\n";
4096             pr "    if (r == -2) /* daemon cancelled */\n";
4097             pr "      goto read_reply;\n";
4098             need_read_reply_label := true;
4099             pr "  }\n";
4100             pr "\n";
4101         | _ -> ()
4102       ) (snd style);
4103
4104       (* Wait for the reply from the remote end. *)
4105       if !need_read_reply_label then pr " read_reply:\n";
4106       pr "  guestfs__switch_to_receiving (g);\n";
4107       pr "  ctx.cb_sequence = 0;\n";
4108       pr "  guestfs_set_reply_callback (g, %s_reply_cb, &ctx);\n" shortname;
4109       pr "  (void) ml->main_loop_run (ml, g);\n";
4110       pr "  guestfs_set_reply_callback (g, NULL, NULL);\n";
4111       pr "  if (ctx.cb_sequence != 1) {\n";
4112       pr "    error (g, \"%%s reply failed, see earlier error messages\", \"%s\");\n" name;
4113       pr "    guestfs_end_busy (g);\n";
4114       pr "    return %s;\n" error_code;
4115       pr "  }\n";
4116       pr "\n";
4117
4118       pr "  if (check_reply_header (g, &ctx.hdr, GUESTFS_PROC_%s, serial) == -1) {\n"
4119         (String.uppercase shortname);
4120       pr "    guestfs_end_busy (g);\n";
4121       pr "    return %s;\n" error_code;
4122       pr "  }\n";
4123       pr "\n";
4124
4125       pr "  if (ctx.hdr.status == GUESTFS_STATUS_ERROR) {\n";
4126       pr "    error (g, \"%%s\", ctx.err.error_message);\n";
4127       pr "    free (ctx.err.error_message);\n";
4128       pr "    guestfs_end_busy (g);\n";
4129       pr "    return %s;\n" error_code;
4130       pr "  }\n";
4131       pr "\n";
4132
4133       (* Expecting to receive further files (FileOut)? *)
4134       List.iter (
4135         function
4136         | FileOut n ->
4137             pr "  if (guestfs__receive_file_sync (g, %s) == -1) {\n" n;
4138             pr "    guestfs_end_busy (g);\n";
4139             pr "    return %s;\n" error_code;
4140             pr "  }\n";
4141             pr "\n";
4142         | _ -> ()
4143       ) (snd style);
4144
4145       pr "  guestfs_end_busy (g);\n";
4146
4147       (match fst style with
4148        | RErr -> pr "  return 0;\n"
4149        | RInt n | RInt64 n | RBool n ->
4150            pr "  return ctx.ret.%s;\n" n
4151        | RConstString _ ->
4152            failwithf "RConstString cannot be returned from a daemon function"
4153        | RString n ->
4154            pr "  return ctx.ret.%s; /* caller will free */\n" n
4155        | RStringList n | RHashtable n ->
4156            pr "  /* caller will free this, but we need to add a NULL entry */\n";
4157            pr "  ctx.ret.%s.%s_val =\n" n n;
4158            pr "    safe_realloc (g, ctx.ret.%s.%s_val,\n" n n;
4159            pr "                  sizeof (char *) * (ctx.ret.%s.%s_len + 1));\n"
4160              n n;
4161            pr "  ctx.ret.%s.%s_val[ctx.ret.%s.%s_len] = NULL;\n" n n n n;
4162            pr "  return ctx.ret.%s.%s_val;\n" n n
4163        | RStruct (n, _) ->
4164            pr "  /* caller will free this */\n";
4165            pr "  return safe_memdup (g, &ctx.ret.%s, sizeof (ctx.ret.%s));\n" n n
4166        | RStructList (n, _) ->
4167            pr "  /* caller will free this */\n";
4168            pr "  return safe_memdup (g, &ctx.ret.%s, sizeof (ctx.ret.%s));\n" n n
4169        | RBufferOut n ->
4170            pr "  *size_r = ctx.ret.%s.%s_len;\n" n n;
4171            pr "  return ctx.ret.%s.%s_val; /* caller will free */\n" n n
4172       );
4173
4174       pr "}\n\n"
4175   ) daemon_functions;
4176
4177   (* Functions to free structures. *)
4178   pr "/* Structure-freeing functions.  These rely on the fact that the\n";
4179   pr " * structure format is identical to the XDR format.  See note in\n";
4180   pr " * generator.ml.\n";
4181   pr " */\n";
4182   pr "\n";
4183
4184   List.iter (
4185     fun (typ, _) ->
4186       pr "void\n";
4187       pr "guestfs_free_%s (struct guestfs_%s *x)\n" typ typ;
4188       pr "{\n";
4189       pr "  xdr_free ((xdrproc_t) xdr_guestfs_int_%s, (char *) x);\n" typ;
4190       pr "  free (x);\n";
4191       pr "}\n";
4192       pr "\n";
4193
4194       pr "void\n";
4195       pr "guestfs_free_%s_list (struct guestfs_%s_list *x)\n" typ typ;
4196       pr "{\n";
4197       pr "  xdr_free ((xdrproc_t) xdr_guestfs_int_%s_list, (char *) x);\n" typ;
4198       pr "  free (x);\n";
4199       pr "}\n";
4200       pr "\n";
4201
4202   ) structs;
4203
4204 (* Generate daemon/actions.h. *)
4205 and generate_daemon_actions_h () =
4206   generate_header CStyle GPLv2;
4207
4208   pr "#include \"../src/guestfs_protocol.h\"\n";
4209   pr "\n";
4210
4211   List.iter (
4212     fun (name, style, _, _, _, _, _) ->
4213       generate_prototype
4214         ~single_line:true ~newline:true ~in_daemon:true ~prefix:"do_"
4215         name style;
4216   ) daemon_functions
4217
4218 (* Generate the server-side stubs. *)
4219 and generate_daemon_actions () =
4220   generate_header CStyle GPLv2;
4221
4222   pr "#include <config.h>\n";
4223   pr "\n";
4224   pr "#include <stdio.h>\n";
4225   pr "#include <stdlib.h>\n";
4226   pr "#include <string.h>\n";
4227   pr "#include <inttypes.h>\n";
4228   pr "#include <ctype.h>\n";
4229   pr "#include <rpc/types.h>\n";
4230   pr "#include <rpc/xdr.h>\n";
4231   pr "\n";
4232   pr "#include \"daemon.h\"\n";
4233   pr "#include \"../src/guestfs_protocol.h\"\n";
4234   pr "#include \"actions.h\"\n";
4235   pr "\n";
4236
4237   List.iter (
4238     fun (name, style, _, _, _, _, _) ->
4239       (* Generate server-side stubs. *)
4240       pr "static void %s_stub (XDR *xdr_in)\n" name;
4241       pr "{\n";
4242       let error_code =
4243         match fst style with
4244         | RErr | RInt _ -> pr "  int r;\n"; "-1"
4245         | RInt64 _ -> pr "  int64_t r;\n"; "-1"
4246         | RBool _ -> pr "  int r;\n"; "-1"
4247         | RConstString _ ->
4248             failwithf "RConstString cannot be returned from a daemon function"
4249         | RString _ -> pr "  char *r;\n"; "NULL"
4250         | RStringList _ | RHashtable _ -> pr "  char **r;\n"; "NULL"
4251         | RStruct (_, typ) -> pr "  guestfs_int_%s *r;\n" typ; "NULL"
4252         | RStructList (_, typ) -> pr "  guestfs_int_%s_list *r;\n" typ; "NULL"
4253         | RBufferOut _ ->
4254             pr "  size_t size;\n";
4255             pr "  char *r;\n";
4256             "NULL" in
4257
4258       (match snd style with
4259        | [] -> ()
4260        | args ->
4261            pr "  struct guestfs_%s_args args;\n" name;
4262            List.iter (
4263              function
4264                (* Note we allow the string to be writable, in order to
4265                 * allow device name translation.  This is safe because
4266                 * we can modify the string (passed from RPC).
4267                 *)
4268              | String n
4269              | OptString n -> pr "  char *%s;\n" n
4270              | StringList n -> pr "  char **%s;\n" n
4271              | Bool n -> pr "  int %s;\n" n
4272              | Int n -> pr "  int %s;\n" n
4273              | FileIn _ | FileOut _ -> ()
4274            ) args
4275       );
4276       pr "\n";
4277
4278       (match snd style with
4279        | [] -> ()
4280        | args ->
4281            pr "  memset (&args, 0, sizeof args);\n";
4282            pr "\n";
4283            pr "  if (!xdr_guestfs_%s_args (xdr_in, &args)) {\n" name;
4284            pr "    reply_with_error (\"%%s: daemon failed to decode procedure arguments\", \"%s\");\n" name;
4285            pr "    return;\n";
4286            pr "  }\n";
4287            List.iter (
4288              function
4289              | String n -> pr "  %s = args.%s;\n" n n
4290              | OptString n -> pr "  %s = args.%s ? *args.%s : NULL;\n" n n n
4291              | StringList n ->
4292                  pr "  %s = realloc (args.%s.%s_val,\n" n n n;
4293                  pr "                sizeof (char *) * (args.%s.%s_len+1));\n" n n;
4294                  pr "  if (%s == NULL) {\n" n;
4295                  pr "    reply_with_perror (\"realloc\");\n";
4296                  pr "    goto done;\n";
4297                  pr "  }\n";
4298                  pr "  %s[args.%s.%s_len] = NULL;\n" n n n;
4299                  pr "  args.%s.%s_val = %s;\n" n n n;
4300              | Bool n -> pr "  %s = args.%s;\n" n n
4301              | Int n -> pr "  %s = args.%s;\n" n n
4302              | FileIn _ | FileOut _ -> ()
4303            ) args;
4304            pr "\n"
4305       );
4306
4307       (* Don't want to call the impl with any FileIn or FileOut
4308        * parameters, since these go "outside" the RPC protocol.
4309        *)
4310       let args' =
4311         List.filter (function FileIn _ | FileOut _ -> false | _ -> true)
4312           (snd style) in
4313       pr "  r = do_%s " name;
4314       generate_c_call_args (fst style, args');
4315       pr ";\n";
4316
4317       pr "  if (r == %s)\n" error_code;
4318       pr "    /* do_%s has already called reply_with_error */\n" name;
4319       pr "    goto done;\n";
4320       pr "\n";
4321
4322       (* If there are any FileOut parameters, then the impl must
4323        * send its own reply.
4324        *)
4325       let no_reply =
4326         List.exists (function FileOut _ -> true | _ -> false) (snd style) in
4327       if no_reply then
4328         pr "  /* do_%s has already sent a reply */\n" name
4329       else (
4330         match fst style with
4331         | RErr -> pr "  reply (NULL, NULL);\n"
4332         | RInt n | RInt64 n | RBool n ->
4333             pr "  struct guestfs_%s_ret ret;\n" name;
4334             pr "  ret.%s = r;\n" n;
4335             pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n"
4336               name
4337         | RConstString _ ->
4338             failwithf "RConstString cannot be returned from a daemon function"
4339         | RString n ->
4340             pr "  struct guestfs_%s_ret ret;\n" name;
4341             pr "  ret.%s = r;\n" n;
4342             pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n"
4343               name;
4344             pr "  free (r);\n"
4345         | RStringList n | RHashtable n ->
4346             pr "  struct guestfs_%s_ret ret;\n" name;
4347             pr "  ret.%s.%s_len = count_strings (r);\n" n n;
4348             pr "  ret.%s.%s_val = r;\n" n n;
4349             pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n"
4350               name;
4351             pr "  free_strings (r);\n"
4352         | RStruct (n, _) ->
4353             pr "  struct guestfs_%s_ret ret;\n" name;
4354             pr "  ret.%s = *r;\n" n;
4355             pr "  reply ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n"
4356               name;
4357             pr "  xdr_free ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n"
4358               name
4359         | RStructList (n, _) ->
4360             pr "  struct guestfs_%s_ret ret;\n" name;
4361             pr "  ret.%s = *r;\n" n;
4362             pr "  reply ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n"
4363               name;
4364             pr "  xdr_free ((xdrproc_t) xdr_guestfs_%s_ret, (char *) &ret);\n"
4365               name
4366         | RBufferOut n ->
4367             pr "  struct guestfs_%s_ret ret;\n" name;
4368             pr "  ret.%s.%s_val = r;\n" n n;
4369             pr "  ret.%s.%s_len = size;\n" n n;
4370             pr "  reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n"
4371               name;
4372             pr "  free (r);\n"
4373       );
4374
4375       (* Free the args. *)
4376       (match snd style with
4377        | [] ->
4378            pr "done: ;\n";
4379        | _ ->
4380            pr "done:\n";
4381            pr "  xdr_free ((xdrproc_t) xdr_guestfs_%s_args, (char *) &args);\n"
4382              name
4383       );
4384
4385       pr "}\n\n";
4386   ) daemon_functions;
4387
4388   (* Dispatch function. *)
4389   pr "void dispatch_incoming_message (XDR *xdr_in)\n";
4390   pr "{\n";
4391   pr "  switch (proc_nr) {\n";
4392
4393   List.iter (
4394     fun (name, style, _, _, _, _, _) ->
4395       pr "    case GUESTFS_PROC_%s:\n" (String.uppercase name);
4396       pr "      %s_stub (xdr_in);\n" name;
4397       pr "      break;\n"
4398   ) daemon_functions;
4399
4400   pr "    default:\n";
4401   pr "      reply_with_error (\"dispatch_incoming_message: unknown procedure number %%d, set LIBGUESTFS_PATH to point to the matching libguestfs appliance directory\", proc_nr);\n";
4402   pr "  }\n";
4403   pr "}\n";
4404   pr "\n";
4405
4406   (* LVM columns and tokenization functions. *)
4407   (* XXX This generates crap code.  We should rethink how we
4408    * do this parsing.
4409    *)
4410   List.iter (
4411     function
4412     | typ, cols ->
4413         pr "static const char *lvm_%s_cols = \"%s\";\n"
4414           typ (String.concat "," (List.map fst cols));
4415         pr "\n";
4416
4417         pr "static int lvm_tokenize_%s (char *str, guestfs_int_lvm_%s *r)\n" typ typ;
4418         pr "{\n";
4419         pr "  char *tok, *p, *next;\n";
4420         pr "  int i, j;\n";
4421         pr "\n";
4422         (*
4423           pr "  fprintf (stderr, \"%%s: <<%%s>>\\n\", __func__, str);\n";
4424           pr "\n";
4425         *)
4426         pr "  if (!str) {\n";
4427         pr "    fprintf (stderr, \"%%s: failed: passed a NULL string\\n\", __func__);\n";
4428         pr "    return -1;\n";
4429         pr "  }\n";
4430         pr "  if (!*str || isspace (*str)) {\n";
4431         pr "    fprintf (stderr, \"%%s: failed: passed a empty string or one beginning with whitespace\\n\", __func__);\n";
4432         pr "    return -1;\n";
4433         pr "  }\n";
4434         pr "  tok = str;\n";
4435         List.iter (
4436           fun (name, coltype) ->
4437             pr "  if (!tok) {\n";
4438             pr "    fprintf (stderr, \"%%s: failed: string finished early, around token %%s\\n\", __func__, \"%s\");\n" name;
4439             pr "    return -1;\n";
4440             pr "  }\n";
4441             pr "  p = strchrnul (tok, ',');\n";
4442             pr "  if (*p) next = p+1; else next = NULL;\n";
4443             pr "  *p = '\\0';\n";
4444             (match coltype with
4445              | FString ->
4446                  pr "  r->%s = strdup (tok);\n" name;
4447                  pr "  if (r->%s == NULL) {\n" name;
4448                  pr "    perror (\"strdup\");\n";
4449                  pr "    return -1;\n";
4450                  pr "  }\n"
4451              | FUUID ->
4452                  pr "  for (i = j = 0; i < 32; ++j) {\n";
4453                  pr "    if (tok[j] == '\\0') {\n";
4454                  pr "      fprintf (stderr, \"%%s: failed to parse UUID from '%%s'\\n\", __func__, tok);\n";
4455                  pr "      return -1;\n";
4456                  pr "    } else if (tok[j] != '-')\n";
4457                  pr "      r->%s[i++] = tok[j];\n" name;
4458                  pr "  }\n";
4459              | FBytes ->
4460                  pr "  if (sscanf (tok, \"%%\"SCNu64, &r->%s) != 1) {\n" name;
4461                  pr "    fprintf (stderr, \"%%s: failed to parse size '%%s' from token %%s\\n\", __func__, tok, \"%s\");\n" name;
4462                  pr "    return -1;\n";
4463                  pr "  }\n";
4464              | FInt64 ->
4465                  pr "  if (sscanf (tok, \"%%\"SCNi64, &r->%s) != 1) {\n" name;
4466                  pr "    fprintf (stderr, \"%%s: failed to parse int '%%s' from token %%s\\n\", __func__, tok, \"%s\");\n" name;
4467                  pr "    return -1;\n";
4468                  pr "  }\n";
4469              | FOptPercent ->
4470                  pr "  if (tok[0] == '\\0')\n";
4471                  pr "    r->%s = -1;\n" name;
4472                  pr "  else if (sscanf (tok, \"%%f\", &r->%s) != 1) {\n" name;
4473                  pr "    fprintf (stderr, \"%%s: failed to parse float '%%s' from token %%s\\n\", __func__, tok, \"%s\");\n" name;
4474                  pr "    return -1;\n";
4475                  pr "  }\n";
4476              | FBuffer | FInt32 | FUInt32 | FUInt64 | FChar ->
4477                  assert false (* can never be an LVM column *)
4478             );
4479             pr "  tok = next;\n";
4480         ) cols;
4481
4482         pr "  if (tok != NULL) {\n";
4483         pr "    fprintf (stderr, \"%%s: failed: extra tokens at end of string\\n\", __func__);\n";
4484         pr "    return -1;\n";
4485         pr "  }\n";
4486         pr "  return 0;\n";
4487         pr "}\n";
4488         pr "\n";
4489
4490         pr "guestfs_int_lvm_%s_list *\n" typ;
4491         pr "parse_command_line_%ss (void)\n" typ;
4492         pr "{\n";
4493         pr "  char *out, *err;\n";
4494         pr "  char *p, *pend;\n";
4495         pr "  int r, i;\n";
4496         pr "  guestfs_int_lvm_%s_list *ret;\n" typ;
4497         pr "  void *newp;\n";
4498         pr "\n";
4499         pr "  ret = malloc (sizeof *ret);\n";
4500         pr "  if (!ret) {\n";
4501         pr "    reply_with_perror (\"malloc\");\n";
4502         pr "    return NULL;\n";
4503         pr "  }\n";
4504         pr "\n";
4505         pr "  ret->guestfs_int_lvm_%s_list_len = 0;\n" typ;
4506         pr "  ret->guestfs_int_lvm_%s_list_val = NULL;\n" typ;
4507         pr "\n";
4508         pr "  r = command (&out, &err,\n";
4509         pr "           \"/sbin/lvm\", \"%ss\",\n" typ;
4510         pr "           \"-o\", lvm_%s_cols, \"--unbuffered\", \"--noheadings\",\n" typ;
4511         pr "           \"--nosuffix\", \"--separator\", \",\", \"--units\", \"b\", NULL);\n";
4512         pr "  if (r == -1) {\n";
4513         pr "    reply_with_error (\"%%s\", err);\n";
4514         pr "    free (out);\n";
4515         pr "    free (err);\n";
4516         pr "    free (ret);\n";
4517         pr "    return NULL;\n";
4518         pr "  }\n";
4519         pr "\n";
4520         pr "  free (err);\n";
4521         pr "\n";
4522         pr "  /* Tokenize each line of the output. */\n";
4523         pr "  p = out;\n";
4524         pr "  i = 0;\n";
4525         pr "  while (p) {\n";
4526         pr "    pend = strchr (p, '\\n');       /* Get the next line of output. */\n";
4527         pr "    if (pend) {\n";
4528         pr "      *pend = '\\0';\n";
4529         pr "      pend++;\n";
4530         pr "    }\n";
4531         pr "\n";
4532         pr "    while (*p && isspace (*p))      /* Skip any leading whitespace. */\n";
4533         pr "      p++;\n";
4534         pr "\n";
4535         pr "    if (!*p) {                      /* Empty line?  Skip it. */\n";
4536         pr "      p = pend;\n";
4537         pr "      continue;\n";
4538         pr "    }\n";
4539         pr "\n";
4540         pr "    /* Allocate some space to store this next entry. */\n";
4541         pr "    newp = realloc (ret->guestfs_int_lvm_%s_list_val,\n" typ;
4542         pr "                sizeof (guestfs_int_lvm_%s) * (i+1));\n" typ;
4543         pr "    if (newp == NULL) {\n";
4544         pr "      reply_with_perror (\"realloc\");\n";
4545         pr "      free (ret->guestfs_int_lvm_%s_list_val);\n" typ;
4546         pr "      free (ret);\n";
4547         pr "      free (out);\n";
4548         pr "      return NULL;\n";
4549         pr "    }\n";
4550         pr "    ret->guestfs_int_lvm_%s_list_val = newp;\n" typ;
4551         pr "\n";
4552         pr "    /* Tokenize the next entry. */\n";
4553         pr "    r = lvm_tokenize_%s (p, &ret->guestfs_int_lvm_%s_list_val[i]);\n" typ typ;
4554         pr "    if (r == -1) {\n";
4555         pr "      reply_with_error (\"failed to parse output of '%ss' command\");\n" typ;
4556         pr "      free (ret->guestfs_int_lvm_%s_list_val);\n" typ;
4557         pr "      free (ret);\n";
4558         pr "      free (out);\n";
4559         pr "      return NULL;\n";
4560         pr "    }\n";
4561         pr "\n";
4562         pr "    ++i;\n";
4563         pr "    p = pend;\n";
4564         pr "  }\n";
4565         pr "\n";
4566         pr "  ret->guestfs_int_lvm_%s_list_len = i;\n" typ;
4567         pr "\n";
4568         pr "  free (out);\n";
4569         pr "  return ret;\n";
4570         pr "}\n"
4571
4572   ) ["pv", lvm_pv_cols; "vg", lvm_vg_cols; "lv", lvm_lv_cols]
4573
4574 (* Generate a list of function names, for debugging in the daemon.. *)
4575 and generate_daemon_names () =
4576   generate_header CStyle GPLv2;
4577
4578   pr "#include <config.h>\n";
4579   pr "\n";
4580   pr "#include \"daemon.h\"\n";
4581   pr "\n";
4582
4583   pr "/* This array is indexed by proc_nr.  See guestfs_protocol.x. */\n";
4584   pr "const char *function_names[] = {\n";
4585   List.iter (
4586     fun (name, _, proc_nr, _, _, _, _) -> pr "  [%d] = \"%s\",\n" proc_nr name
4587   ) daemon_functions;
4588   pr "};\n";
4589
4590 (* Generate the tests. *)
4591 and generate_tests () =
4592   generate_header CStyle GPLv2;
4593
4594   pr "\
4595 #include <stdio.h>
4596 #include <stdlib.h>
4597 #include <string.h>
4598 #include <unistd.h>
4599 #include <sys/types.h>
4600 #include <fcntl.h>
4601
4602 #include \"guestfs.h\"
4603
4604 static guestfs_h *g;
4605 static int suppress_error = 0;
4606
4607 static void print_error (guestfs_h *g, void *data, const char *msg)
4608 {
4609   if (!suppress_error)
4610     fprintf (stderr, \"%%s\\n\", msg);
4611 }
4612
4613 static void print_strings (char * const * const argv)
4614 {
4615   int argc;
4616
4617   for (argc = 0; argv[argc] != NULL; ++argc)
4618     printf (\"\\t%%s\\n\", argv[argc]);
4619 }
4620
4621 /*
4622 static void print_table (char * const * const argv)
4623 {
4624   int i;
4625
4626   for (i = 0; argv[i] != NULL; i += 2)
4627     printf (\"%%s: %%s\\n\", argv[i], argv[i+1]);
4628 }
4629 */
4630
4631 static void no_test_warnings (void)
4632 {
4633 ";
4634
4635   List.iter (
4636     function
4637     | name, _, _, _, [], _, _ ->
4638         pr "  fprintf (stderr, \"warning: \\\"guestfs_%s\\\" has no tests\\n\");\n" name
4639     | name, _, _, _, tests, _, _ -> ()
4640   ) all_functions;
4641
4642   pr "}\n";
4643   pr "\n";
4644
4645   (* Generate the actual tests.  Note that we generate the tests
4646    * in reverse order, deliberately, so that (in general) the
4647    * newest tests run first.  This makes it quicker and easier to
4648    * debug them.
4649    *)
4650   let test_names =
4651     List.map (
4652       fun (name, _, _, _, tests, _, _) ->
4653         mapi (generate_one_test name) tests
4654     ) (List.rev all_functions) in
4655   let test_names = List.concat test_names in
4656   let nr_tests = List.length test_names in
4657
4658   pr "\
4659 int main (int argc, char *argv[])
4660 {
4661   char c = 0;
4662   int failed = 0;
4663   const char *filename;
4664   int fd;
4665   int nr_tests, test_num = 0;
4666
4667   setbuf (stdout, NULL);
4668
4669   no_test_warnings ();
4670
4671   g = guestfs_create ();
4672   if (g == NULL) {
4673     printf (\"guestfs_create FAILED\\n\");
4674     exit (1);
4675   }
4676
4677   guestfs_set_error_handler (g, print_error, NULL);
4678
4679   guestfs_set_path (g, \"../appliance\");
4680
4681   filename = \"test1.img\";
4682   fd = open (filename, O_WRONLY|O_CREAT|O_NOCTTY|O_NONBLOCK|O_TRUNC, 0666);
4683   if (fd == -1) {
4684     perror (filename);
4685     exit (1);
4686   }
4687   if (lseek (fd, %d, SEEK_SET) == -1) {
4688     perror (\"lseek\");
4689     close (fd);
4690     unlink (filename);
4691     exit (1);
4692   }
4693   if (write (fd, &c, 1) == -1) {
4694     perror (\"write\");
4695     close (fd);
4696     unlink (filename);
4697     exit (1);
4698   }
4699   if (close (fd) == -1) {
4700     perror (filename);
4701     unlink (filename);
4702     exit (1);
4703   }
4704   if (guestfs_add_drive (g, filename) == -1) {
4705     printf (\"guestfs_add_drive %%s FAILED\\n\", filename);
4706     exit (1);
4707   }
4708
4709   filename = \"test2.img\";
4710   fd = open (filename, O_WRONLY|O_CREAT|O_NOCTTY|O_NONBLOCK|O_TRUNC, 0666);
4711   if (fd == -1) {
4712     perror (filename);
4713     exit (1);
4714   }
4715   if (lseek (fd, %d, SEEK_SET) == -1) {
4716     perror (\"lseek\");
4717     close (fd);
4718     unlink (filename);
4719     exit (1);
4720   }
4721   if (write (fd, &c, 1) == -1) {
4722     perror (\"write\");
4723     close (fd);
4724     unlink (filename);
4725     exit (1);
4726   }
4727   if (close (fd) == -1) {
4728     perror (filename);
4729     unlink (filename);
4730     exit (1);
4731   }
4732   if (guestfs_add_drive (g, filename) == -1) {
4733     printf (\"guestfs_add_drive %%s FAILED\\n\", filename);
4734     exit (1);
4735   }
4736
4737   filename = \"test3.img\";
4738   fd = open (filename, O_WRONLY|O_CREAT|O_NOCTTY|O_NONBLOCK|O_TRUNC, 0666);
4739   if (fd == -1) {
4740     perror (filename);
4741     exit (1);
4742   }
4743   if (lseek (fd, %d, SEEK_SET) == -1) {
4744     perror (\"lseek\");
4745     close (fd);
4746     unlink (filename);
4747     exit (1);
4748   }
4749   if (write (fd, &c, 1) == -1) {
4750     perror (\"write\");
4751     close (fd);
4752     unlink (filename);
4753     exit (1);
4754   }
4755   if (close (fd) == -1) {
4756     perror (filename);
4757     unlink (filename);
4758     exit (1);
4759   }
4760   if (guestfs_add_drive (g, filename) == -1) {
4761     printf (\"guestfs_add_drive %%s FAILED\\n\", filename);
4762     exit (1);
4763   }
4764
4765   if (guestfs_add_drive_ro (g, \"../images/test.sqsh\") == -1) {
4766     printf (\"guestfs_add_drive_ro ../images/test.sqsh FAILED\\n\");
4767     exit (1);
4768   }
4769
4770   if (guestfs_launch (g) == -1) {
4771     printf (\"guestfs_launch FAILED\\n\");
4772     exit (1);
4773   }
4774
4775   /* Set a timeout in case qemu hangs during launch (RHBZ#505329). */
4776   alarm (600);
4777
4778   if (guestfs_wait_ready (g) == -1) {
4779     printf (\"guestfs_wait_ready FAILED\\n\");
4780     exit (1);
4781   }
4782
4783   /* Cancel previous alarm. */
4784   alarm (0);
4785
4786   nr_tests = %d;
4787
4788 " (500 * 1024 * 1024) (50 * 1024 * 1024) (10 * 1024 * 1024) nr_tests;
4789
4790   iteri (
4791     fun i test_name ->
4792       pr "  test_num++;\n";
4793       pr "  printf (\"%%3d/%%3d %s\\n\", test_num, nr_tests);\n" test_name;
4794       pr "  if (%s () == -1) {\n" test_name;
4795       pr "    printf (\"%s FAILED\\n\");\n" test_name;
4796       pr "    failed++;\n";
4797       pr "  }\n";
4798   ) test_names;
4799   pr "\n";
4800
4801   pr "  guestfs_close (g);\n";
4802   pr "  unlink (\"test1.img\");\n";
4803   pr "  unlink (\"test2.img\");\n";
4804   pr "  unlink (\"test3.img\");\n";
4805   pr "\n";
4806
4807   pr "  if (failed > 0) {\n";
4808   pr "    printf (\"***** %%d / %%d tests FAILED *****\\n\", failed, nr_tests);\n";
4809   pr "    exit (1);\n";
4810   pr "  }\n";
4811   pr "\n";
4812
4813   pr "  exit (0);\n";
4814   pr "}\n"
4815
4816 and generate_one_test name i (init, prereq, test) =
4817   let test_name = sprintf "test_%s_%d" name i in
4818
4819   pr "\
4820 static int %s_skip (void)
4821 {
4822   const char *str;
4823
4824   str = getenv (\"TEST_ONLY\");
4825   if (str)
4826     return strstr (str, \"%s\") == NULL;
4827   str = getenv (\"SKIP_%s\");
4828   if (str && strcmp (str, \"1\") == 0) return 1;
4829   str = getenv (\"SKIP_TEST_%s\");
4830   if (str && strcmp (str, \"1\") == 0) return 1;
4831   return 0;
4832 }
4833
4834 " test_name name (String.uppercase test_name) (String.uppercase name);
4835
4836   (match prereq with
4837    | Disabled | Always -> ()
4838    | If code | Unless code ->
4839        pr "static int %s_prereq (void)\n" test_name;
4840        pr "{\n";
4841        pr "  %s\n" code;
4842        pr "}\n";
4843        pr "\n";
4844   );
4845
4846   pr "\
4847 static int %s (void)
4848 {
4849   if (%s_skip ()) {
4850     printf (\"        %%s skipped (reason: environment variable set)\\n\", \"%s\");
4851     return 0;
4852   }
4853
4854 " test_name test_name test_name;
4855
4856   (match prereq with
4857    | Disabled ->
4858        pr "  printf (\"        %%s skipped (reason: test disabled in generator)\\n\", \"%s\");\n" test_name
4859    | If _ ->
4860        pr "  if (! %s_prereq ()) {\n" test_name;
4861        pr "    printf (\"        %%s skipped (reason: test prerequisite)\\n\", \"%s\");\n" test_name;
4862        pr "    return 0;\n";
4863        pr "  }\n";
4864        pr "\n";
4865        generate_one_test_body name i test_name init test;
4866    | Unless _ ->
4867        pr "  if (%s_prereq ()) {\n" test_name;
4868        pr "    printf (\"        %%s skipped (reason: test prerequisite)\\n\", \"%s\");\n" test_name;
4869        pr "    return 0;\n";
4870        pr "  }\n";
4871        pr "\n";
4872        generate_one_test_body name i test_name init test;
4873    | Always ->
4874        generate_one_test_body name i test_name init test
4875   );
4876
4877   pr "  return 0;\n";
4878   pr "}\n";
4879   pr "\n";
4880   test_name
4881
4882 and generate_one_test_body name i test_name init test =
4883   (match init with
4884    | InitNone (* XXX at some point, InitNone and InitEmpty became
4885                * folded together as the same thing.  Really we should
4886                * make InitNone do nothing at all, but the tests may
4887                * need to be checked to make sure this is OK.
4888                *)
4889    | InitEmpty ->
4890        pr "  /* InitNone|InitEmpty for %s */\n" test_name;
4891        List.iter (generate_test_command_call test_name)
4892          [["blockdev_setrw"; "/dev/sda"];
4893           ["umount_all"];
4894           ["lvm_remove_all"]]
4895    | InitBasicFS ->
4896        pr "  /* InitBasicFS for %s: create ext2 on /dev/sda1 */\n" test_name;
4897        List.iter (generate_test_command_call test_name)
4898          [["blockdev_setrw"; "/dev/sda"];
4899           ["umount_all"];
4900           ["lvm_remove_all"];
4901           ["sfdiskM"; "/dev/sda"; ","];
4902           ["mkfs"; "ext2"; "/dev/sda1"];
4903           ["mount"; "/dev/sda1"; "/"]]
4904    | InitBasicFSonLVM ->
4905        pr "  /* InitBasicFSonLVM for %s: create ext2 on /dev/VG/LV */\n"
4906          test_name;
4907        List.iter (generate_test_command_call test_name)
4908          [["blockdev_setrw"; "/dev/sda"];
4909           ["umount_all"];
4910           ["lvm_remove_all"];
4911           ["sfdiskM"; "/dev/sda"; ","];
4912           ["pvcreate"; "/dev/sda1"];
4913           ["vgcreate"; "VG"; "/dev/sda1"];
4914           ["lvcreate"; "LV"; "VG"; "8"];
4915           ["mkfs"; "ext2"; "/dev/VG/LV"];
4916           ["mount"; "/dev/VG/LV"; "/"]]
4917   );
4918
4919   let get_seq_last = function
4920     | [] ->
4921         failwithf "%s: you cannot use [] (empty list) when expecting a command"
4922           test_name
4923     | seq ->
4924         let seq = List.rev seq in
4925         List.rev (List.tl seq), List.hd seq
4926   in
4927
4928   match test with
4929   | TestRun seq ->
4930       pr "  /* TestRun for %s (%d) */\n" name i;
4931       List.iter (generate_test_command_call test_name) seq
4932   | TestOutput (seq, expected) ->
4933       pr "  /* TestOutput for %s (%d) */\n" name i;
4934       pr "  const char *expected = \"%s\";\n" (c_quote expected);
4935       let seq, last = get_seq_last seq in
4936       let test () =
4937         pr "    if (strcmp (r, expected) != 0) {\n";
4938         pr "      fprintf (stderr, \"%s: expected \\\"%%s\\\" but got \\\"%%s\\\"\\n\", expected, r);\n" test_name;
4939         pr "      return -1;\n";
4940         pr "    }\n"
4941       in
4942       List.iter (generate_test_command_call test_name) seq;
4943       generate_test_command_call ~test test_name last
4944   | TestOutputList (seq, expected) ->
4945       pr "  /* TestOutputList for %s (%d) */\n" name i;
4946       let seq, last = get_seq_last seq in
4947       let test () =
4948         iteri (
4949           fun i str ->
4950             pr "    if (!r[%d]) {\n" i;
4951             pr "      fprintf (stderr, \"%s: short list returned from command\\n\");\n" test_name;
4952             pr "      print_strings (r);\n";
4953             pr "      return -1;\n";
4954             pr "    }\n";
4955             pr "    {\n";
4956             pr "      const char *expected = \"%s\";\n" (c_quote str);
4957             pr "      if (strcmp (r[%d], expected) != 0) {\n" i;
4958             pr "        fprintf (stderr, \"%s: expected \\\"%%s\\\" but got \\\"%%s\\\"\\n\", expected, r[%d]);\n" test_name i;
4959             pr "        return -1;\n";
4960             pr "      }\n";
4961             pr "    }\n"
4962         ) expected;
4963         pr "    if (r[%d] != NULL) {\n" (List.length expected);
4964         pr "      fprintf (stderr, \"%s: extra elements returned from command\\n\");\n"
4965           test_name;
4966         pr "      print_strings (r);\n";
4967         pr "      return -1;\n";
4968         pr "    }\n"
4969       in
4970       List.iter (generate_test_command_call test_name) seq;
4971       generate_test_command_call ~test test_name last
4972   | TestOutputListOfDevices (seq, expected) ->
4973       pr "  /* TestOutputListOfDevices for %s (%d) */\n" name i;
4974       let seq, last = get_seq_last seq in
4975       let test () =
4976         iteri (
4977           fun i str ->
4978             pr "    if (!r[%d]) {\n" i;
4979             pr "      fprintf (stderr, \"%s: short list returned from command\\n\");\n" test_name;
4980             pr "      print_strings (r);\n";
4981             pr "      return -1;\n";
4982             pr "    }\n";
4983             pr "    {\n";
4984             pr "      const char *expected = \"%s\";\n" (c_quote str);
4985             pr "      r[%d][5] = 's';\n" i;
4986             pr "      if (strcmp (r[%d], expected) != 0) {\n" i;
4987             pr "        fprintf (stderr, \"%s: expected \\\"%%s\\\" but got \\\"%%s\\\"\\n\", expected, r[%d]);\n" test_name i;
4988             pr "        return -1;\n";
4989             pr "      }\n";
4990             pr "    }\n"
4991         ) expected;
4992         pr "    if (r[%d] != NULL) {\n" (List.length expected);
4993         pr "      fprintf (stderr, \"%s: extra elements returned from command\\n\");\n"
4994           test_name;
4995         pr "      print_strings (r);\n";
4996         pr "      return -1;\n";
4997         pr "    }\n"
4998       in
4999       List.iter (generate_test_command_call test_name) seq;
5000       generate_test_command_call ~test test_name last
5001   | TestOutputInt (seq, expected) ->
5002       pr "  /* TestOutputInt for %s (%d) */\n" name i;
5003       let seq, last = get_seq_last seq in
5004       let test () =
5005         pr "    if (r != %d) {\n" expected;
5006         pr "      fprintf (stderr, \"%s: expected %d but got %%d\\n\","
5007           test_name expected;
5008         pr "               (int) r);\n";
5009         pr "      return -1;\n";
5010         pr "    }\n"
5011       in
5012       List.iter (generate_test_command_call test_name) seq;
5013       generate_test_command_call ~test test_name last
5014   | TestOutputIntOp (seq, op, expected) ->
5015       pr "  /* TestOutputIntOp for %s (%d) */\n" name i;
5016       let seq, last = get_seq_last seq in
5017       let test () =
5018         pr "    if (! (r %s %d)) {\n" op expected;
5019         pr "      fprintf (stderr, \"%s: expected %s %d but got %%d\\n\","
5020           test_name op expected;
5021         pr "               (int) r);\n";
5022         pr "      return -1;\n";
5023         pr "    }\n"
5024       in
5025       List.iter (generate_test_command_call test_name) seq;
5026       generate_test_command_call ~test test_name last
5027   | TestOutputTrue seq ->
5028       pr "  /* TestOutputTrue for %s (%d) */\n" name i;
5029       let seq, last = get_seq_last seq in
5030       let test () =
5031         pr "    if (!r) {\n";
5032         pr "      fprintf (stderr, \"%s: expected true, got false\\n\");\n"
5033           test_name;
5034         pr "      return -1;\n";
5035         pr "    }\n"
5036       in
5037       List.iter (generate_test_command_call test_name) seq;
5038       generate_test_command_call ~test test_name last
5039   | TestOutputFalse seq ->
5040       pr "  /* TestOutputFalse for %s (%d) */\n" name i;
5041       let seq, last = get_seq_last seq in
5042       let test () =
5043         pr "    if (r) {\n";
5044         pr "      fprintf (stderr, \"%s: expected false, got true\\n\");\n"
5045           test_name;
5046         pr "      return -1;\n";
5047         pr "    }\n"
5048       in
5049       List.iter (generate_test_command_call test_name) seq;
5050       generate_test_command_call ~test test_name last
5051   | TestOutputLength (seq, expected) ->
5052       pr "  /* TestOutputLength for %s (%d) */\n" name i;
5053       let seq, last = get_seq_last seq in
5054       let test () =
5055         pr "    int j;\n";
5056         pr "    for (j = 0; j < %d; ++j)\n" expected;
5057         pr "      if (r[j] == NULL) {\n";
5058         pr "        fprintf (stderr, \"%s: short list returned\\n\");\n"
5059           test_name;
5060         pr "        print_strings (r);\n";
5061         pr "        return -1;\n";
5062         pr "      }\n";
5063         pr "    if (r[j] != NULL) {\n";
5064         pr "      fprintf (stderr, \"%s: long list returned\\n\");\n"
5065           test_name;
5066         pr "      print_strings (r);\n";
5067         pr "      return -1;\n";
5068         pr "    }\n"
5069       in
5070       List.iter (generate_test_command_call test_name) seq;
5071       generate_test_command_call ~test test_name last
5072   | TestOutputStruct (seq, checks) ->
5073       pr "  /* TestOutputStruct for %s (%d) */\n" name i;
5074       let seq, last = get_seq_last seq in
5075       let test () =
5076         List.iter (
5077           function
5078           | CompareWithInt (field, expected) ->
5079               pr "    if (r->%s != %d) {\n" field expected;
5080               pr "      fprintf (stderr, \"%s: %s was %%d, expected %d\\n\",\n"
5081                 test_name field expected;
5082               pr "               (int) r->%s);\n" field;
5083               pr "      return -1;\n";
5084               pr "    }\n"
5085           | CompareWithIntOp (field, op, expected) ->
5086               pr "    if (!(r->%s %s %d)) {\n" field op expected;
5087               pr "      fprintf (stderr, \"%s: %s was %%d, expected %s %d\\n\",\n"
5088                 test_name field op expected;
5089               pr "               (int) r->%s);\n" field;
5090               pr "      return -1;\n";
5091               pr "    }\n"
5092           | CompareWithString (field, expected) ->
5093               pr "    if (strcmp (r->%s, \"%s\") != 0) {\n" field expected;
5094               pr "      fprintf (stderr, \"%s: %s was \"%%s\", expected \"%s\"\\n\",\n"
5095                 test_name field expected;
5096               pr "               r->%s);\n" field;
5097               pr "      return -1;\n";
5098               pr "    }\n"
5099           | CompareFieldsIntEq (field1, field2) ->
5100               pr "    if (r->%s != r->%s) {\n" field1 field2;
5101               pr "      fprintf (stderr, \"%s: %s (%%d) <> %s (%%d)\\n\",\n"
5102                 test_name field1 field2;
5103               pr "               (int) r->%s, (int) r->%s);\n" field1 field2;
5104               pr "      return -1;\n";
5105               pr "    }\n"
5106           | CompareFieldsStrEq (field1, field2) ->
5107               pr "    if (strcmp (r->%s, r->%s) != 0) {\n" field1 field2;
5108               pr "      fprintf (stderr, \"%s: %s (\"%%s\") <> %s (\"%%s\")\\n\",\n"
5109                 test_name field1 field2;
5110               pr "               r->%s, r->%s);\n" field1 field2;
5111               pr "      return -1;\n";
5112               pr "    }\n"
5113         ) checks
5114       in
5115       List.iter (generate_test_command_call test_name) seq;
5116       generate_test_command_call ~test test_name last
5117   | TestLastFail seq ->
5118       pr "  /* TestLastFail for %s (%d) */\n" name i;
5119       let seq, last = get_seq_last seq in
5120       List.iter (generate_test_command_call test_name) seq;
5121       generate_test_command_call test_name ~expect_error:true last
5122
5123 (* Generate the code to run a command, leaving the result in 'r'.
5124  * If you expect to get an error then you should set expect_error:true.
5125  *)
5126 and generate_test_command_call ?(expect_error = false) ?test test_name cmd =
5127   match cmd with
5128   | [] -> assert false
5129   | name :: args ->
5130       (* Look up the command to find out what args/ret it has. *)
5131       let style =
5132         try
5133           let _, style, _, _, _, _, _ =
5134             List.find (fun (n, _, _, _, _, _, _) -> n = name) all_functions in
5135           style
5136         with Not_found ->
5137           failwithf "%s: in test, command %s was not found" test_name name in
5138
5139       if List.length (snd style) <> List.length args then
5140         failwithf "%s: in test, wrong number of args given to %s"
5141           test_name name;
5142
5143       pr "  {\n";
5144
5145       List.iter (
5146         function
5147         | OptString n, "NULL" -> ()
5148         | String n, arg
5149         | OptString n, arg ->
5150             pr "    const char *%s = \"%s\";\n" n (c_quote arg);
5151         | Int _, _
5152         | Bool _, _
5153         | FileIn _, _ | FileOut _, _ -> ()
5154         | StringList n, arg ->
5155             let strs = string_split " " arg in
5156             iteri (
5157               fun i str ->
5158                 pr "    const char *%s_%d = \"%s\";\n" n i (c_quote str);
5159             ) strs;
5160             pr "    const char *%s[] = {\n" n;
5161             iteri (
5162               fun i _ -> pr "      %s_%d,\n" n i
5163             ) strs;
5164             pr "      NULL\n";
5165             pr "    };\n";
5166       ) (List.combine (snd style) args);
5167
5168       let error_code =
5169         match fst style with
5170         | RErr | RInt _ | RBool _ -> pr "    int r;\n"; "-1"
5171         | RInt64 _ -> pr "    int64_t r;\n"; "-1"
5172         | RConstString _ -> pr "    const char *r;\n"; "NULL"
5173         | RString _ -> pr "    char *r;\n"; "NULL"
5174         | RStringList _ | RHashtable _ ->
5175             pr "    char **r;\n";
5176             pr "    int i;\n";
5177             "NULL"
5178         | RStruct (_, typ) ->
5179             pr "    struct guestfs_%s *r;\n" typ; "NULL"
5180         | RStructList (_, typ) ->
5181             pr "    struct guestfs_%s_list *r;\n" typ; "NULL"
5182         | RBufferOut _ ->
5183             pr "    char *r;\n";
5184             pr "    size_t size;\n";
5185             "NULL" in
5186
5187       pr "    suppress_error = %d;\n" (if expect_error then 1 else 0);
5188       pr "    r = guestfs_%s (g" name;
5189
5190       (* Generate the parameters. *)
5191       List.iter (
5192         function
5193         | OptString _, "NULL" -> pr ", NULL"
5194         | String n, _
5195         | OptString n, _ ->
5196             pr ", %s" n
5197         | FileIn _, arg | FileOut _, arg ->
5198             pr ", \"%s\"" (c_quote arg)
5199         | StringList n, _ ->
5200             pr ", %s" n
5201         | Int _, arg ->
5202             let i =
5203               try int_of_string arg
5204               with Failure "int_of_string" ->
5205                 failwithf "%s: expecting an int, but got '%s'" test_name arg in
5206             pr ", %d" i
5207         | Bool _, arg ->
5208             let b = bool_of_string arg in pr ", %d" (if b then 1 else 0)
5209       ) (List.combine (snd style) args);
5210
5211       (match fst style with
5212        | RBufferOut _ -> pr ", &size"
5213        | _ -> ()
5214       );
5215
5216       pr ");\n";
5217
5218       if not expect_error then
5219         pr "    if (r == %s)\n" error_code
5220       else
5221         pr "    if (r != %s)\n" error_code;
5222       pr "      return -1;\n";
5223
5224       (* Insert the test code. *)
5225       (match test with
5226        | None -> ()
5227        | Some f -> f ()
5228       );
5229
5230       (match fst style with
5231        | RErr | RInt _ | RInt64 _ | RBool _ | RConstString _ -> ()
5232        | RString _ | RBufferOut _ -> pr "    free (r);\n"
5233        | RStringList _ | RHashtable _ ->
5234            pr "    for (i = 0; r[i] != NULL; ++i)\n";
5235            pr "      free (r[i]);\n";
5236            pr "    free (r);\n"
5237        | RStruct (_, typ) ->
5238            pr "    guestfs_free_%s (r);\n" typ
5239        | RStructList (_, typ) ->
5240            pr "    guestfs_free_%s_list (r);\n" typ
5241       );
5242
5243       pr "  }\n"
5244
5245 and c_quote str =
5246   let str = replace_str str "\r" "\\r" in
5247   let str = replace_str str "\n" "\\n" in
5248   let str = replace_str str "\t" "\\t" in
5249   let str = replace_str str "\000" "\\0" in
5250   str
5251
5252 (* Generate a lot of different functions for guestfish. *)
5253 and generate_fish_cmds () =
5254   generate_header CStyle GPLv2;
5255
5256   let all_functions =
5257     List.filter (
5258       fun (_, _, _, flags, _, _, _) -> not (List.mem NotInFish flags)
5259     ) all_functions in
5260   let all_functions_sorted =
5261     List.filter (
5262       fun (_, _, _, flags, _, _, _) -> not (List.mem NotInFish flags)
5263     ) all_functions_sorted in
5264
5265   pr "#include <stdio.h>\n";
5266   pr "#include <stdlib.h>\n";
5267   pr "#include <string.h>\n";
5268   pr "#include <inttypes.h>\n";
5269   pr "#include <ctype.h>\n";
5270   pr "\n";
5271   pr "#include <guestfs.h>\n";
5272   pr "#include \"fish.h\"\n";
5273   pr "\n";
5274
5275   (* list_commands function, which implements guestfish -h *)
5276   pr "void list_commands (void)\n";
5277   pr "{\n";
5278   pr "  printf (\"    %%-16s     %%s\\n\", \"Command\", \"Description\");\n";
5279   pr "  list_builtin_commands ();\n";
5280   List.iter (
5281     fun (name, _, _, flags, _, shortdesc, _) ->
5282       let name = replace_char name '_' '-' in
5283       pr "  printf (\"%%-20s %%s\\n\", \"%s\", \"%s\");\n"
5284         name shortdesc
5285   ) all_functions_sorted;
5286   pr "  printf (\"    Use -h <cmd> / help <cmd> to show detailed help for a command.\\n\");\n";
5287   pr "}\n";
5288   pr "\n";
5289
5290   (* display_command function, which implements guestfish -h cmd *)
5291   pr "void display_command (const char *cmd)\n";
5292   pr "{\n";
5293   List.iter (
5294     fun (name, style, _, flags, _, shortdesc, longdesc) ->
5295       let name2 = replace_char name '_' '-' in
5296       let alias =
5297         try find_map (function FishAlias n -> Some n | _ -> None) flags
5298         with Not_found -> name in
5299       let longdesc = replace_str longdesc "C<guestfs_" "C<" in
5300       let synopsis =
5301         match snd style with
5302         | [] -> name2
5303         | args ->
5304             sprintf "%s <%s>"
5305               name2 (String.concat "> <" (List.map name_of_argt args)) in
5306
5307       let warnings =
5308         if List.mem ProtocolLimitWarning flags then
5309           ("\n\n" ^ protocol_limit_warning)
5310         else "" in
5311
5312       (* For DangerWillRobinson commands, we should probably have
5313        * guestfish prompt before allowing you to use them (especially
5314        * in interactive mode). XXX
5315        *)
5316       let warnings =
5317         warnings ^
5318           if List.mem DangerWillRobinson flags then
5319             ("\n\n" ^ danger_will_robinson)
5320           else "" in
5321
5322       let describe_alias =
5323         if name <> alias then
5324           sprintf "\n\nYou can use '%s' as an alias for this command." alias
5325         else "" in
5326
5327       pr "  if (";
5328       pr "strcasecmp (cmd, \"%s\") == 0" name;
5329       if name <> name2 then
5330         pr " || strcasecmp (cmd, \"%s\") == 0" name2;
5331       if name <> alias then
5332         pr " || strcasecmp (cmd, \"%s\") == 0" alias;
5333       pr ")\n";
5334       pr "    pod2text (\"%s - %s\", %S);\n"
5335         name2 shortdesc
5336         (" " ^ synopsis ^ "\n\n" ^ longdesc ^ warnings ^ describe_alias);
5337       pr "  else\n"
5338   ) all_functions;
5339   pr "    display_builtin_command (cmd);\n";
5340   pr "}\n";
5341   pr "\n";
5342
5343   (* print_* functions *)
5344   List.iter (
5345     fun (typ, cols) ->
5346       let needs_i =
5347         List.exists (function (_, (FUUID|FBuffer)) -> true | _ -> false) cols in
5348
5349       pr "static void print_%s (struct guestfs_%s *%s)\n" typ typ typ;
5350       pr "{\n";
5351       if needs_i then (
5352         pr "  int i;\n";
5353         pr "\n"
5354       );
5355       List.iter (
5356         function
5357         | name, FString ->
5358             pr "  printf (\"%s: %%s\\n\", %s->%s);\n" name typ name
5359         | name, FUUID ->
5360             pr "  printf (\"%s: \");\n" name;
5361             pr "  for (i = 0; i < 32; ++i)\n";
5362             pr "    printf (\"%%c\", %s->%s[i]);\n" typ name;
5363             pr "  printf (\"\\n\");\n"
5364         | name, FBuffer ->
5365             pr "  printf (\"%s: \");\n" name;
5366             pr "  for (i = 0; i < %s->%s_len; ++i)\n" typ name;
5367             pr "    if (isprint (%s->%s[i]))\n" typ name;
5368             pr "      printf (\"%%c\", %s->%s[i]);\n" typ name;
5369             pr "    else\n";
5370             pr "      printf (\"\\\\x%%02x\", %s->%s[i]);\n" typ name;
5371             pr "  printf (\"\\n\");\n"
5372         | name, (FUInt64|FBytes) ->
5373             pr "  printf (\"%s: %%\" PRIu64 \"\\n\", %s->%s);\n" name typ name
5374         | name, FInt64 ->
5375             pr "  printf (\"%s: %%\" PRIi64 \"\\n\", %s->%s);\n" name typ name
5376         | name, FUInt32 ->
5377             pr "  printf (\"%s: %%\" PRIu32 \"\\n\", %s->%s);\n" name typ name
5378         | name, FInt32 ->
5379             pr "  printf (\"%s: %%\" PRIi32 \"\\n\", %s->%s);\n" name typ name
5380         | name, FChar ->
5381             pr "  printf (\"%s: %%c\\n\", %s->%s);\n" name typ name
5382         | name, FOptPercent ->
5383             pr "  if (%s->%s >= 0) printf (\"%s: %%g %%%%\\n\", %s->%s);\n"
5384               typ name name typ name;
5385             pr "  else printf (\"%s: \\n\");\n" name
5386       ) cols;
5387       pr "}\n";
5388       pr "\n";
5389       pr "static void print_%s_list (struct guestfs_%s_list *%ss)\n"
5390         typ typ typ;
5391       pr "{\n";
5392       pr "  int i;\n";
5393       pr "\n";
5394       pr "  for (i = 0; i < %ss->len; ++i)\n" typ;
5395       pr "    print_%s (&%ss->val[i]);\n" typ typ;
5396       pr "}\n";
5397       pr "\n";
5398   ) structs;
5399
5400   (* run_<action> actions *)
5401   List.iter (
5402     fun (name, style, _, flags, _, _, _) ->
5403       pr "static int run_%s (const char *cmd, int argc, char *argv[])\n" name;
5404       pr "{\n";
5405       (match fst style with
5406        | RErr
5407        | RInt _
5408        | RBool _ -> pr "  int r;\n"
5409        | RInt64 _ -> pr "  int64_t r;\n"
5410        | RConstString _ -> pr "  const char *r;\n"
5411        | RString _ -> pr "  char *r;\n"
5412        | RStringList _ | RHashtable _ -> pr "  char **r;\n"
5413        | RStruct (_, typ) -> pr "  struct guestfs_%s *r;\n" typ
5414        | RStructList (_, typ) -> pr "  struct guestfs_%s_list *r;\n" typ
5415        | RBufferOut _ ->
5416            pr "  char *r;\n";
5417            pr "  size_t size;\n";
5418       );
5419       List.iter (
5420         function
5421         | String n
5422         | OptString n
5423         | FileIn n
5424         | FileOut n -> pr "  const char *%s;\n" n
5425         | StringList n -> pr "  char **%s;\n" n
5426         | Bool n -> pr "  int %s;\n" n
5427         | Int n -> pr "  int %s;\n" n
5428       ) (snd style);
5429
5430       (* Check and convert parameters. *)
5431       let argc_expected = List.length (snd style) in
5432       pr "  if (argc != %d) {\n" argc_expected;
5433       pr "    fprintf (stderr, \"%%s should have %d parameter(s)\\n\", cmd);\n"
5434         argc_expected;
5435       pr "    fprintf (stderr, \"type 'help %%s' for help on %%s\\n\", cmd, cmd);\n";
5436       pr "    return -1;\n";
5437       pr "  }\n";
5438       iteri (
5439         fun i ->
5440           function
5441           | String name -> pr "  %s = argv[%d];\n" name i
5442           | OptString name ->
5443               pr "  %s = strcmp (argv[%d], \"\") != 0 ? argv[%d] : NULL;\n"
5444                 name i i
5445           | FileIn name ->
5446               pr "  %s = strcmp (argv[%d], \"-\") != 0 ? argv[%d] : \"/dev/stdin\";\n"
5447                 name i i
5448           | FileOut name ->
5449               pr "  %s = strcmp (argv[%d], \"-\") != 0 ? argv[%d] : \"/dev/stdout\";\n"
5450                 name i i
5451           | StringList name ->
5452               pr "  %s = parse_string_list (argv[%d]);\n" name i
5453           | Bool name ->
5454               pr "  %s = is_true (argv[%d]) ? 1 : 0;\n" name i
5455           | Int name ->
5456               pr "  %s = atoi (argv[%d]);\n" name i
5457       ) (snd style);
5458
5459       (* Call C API function. *)
5460       let fn =
5461         try find_map (function FishAction n -> Some n | _ -> None) flags
5462         with Not_found -> sprintf "guestfs_%s" name in
5463       pr "  r = %s " fn;
5464       generate_c_call_args ~handle:"g" style;
5465       pr ";\n";
5466
5467       (* Check return value for errors and display command results. *)
5468       (match fst style with
5469        | RErr -> pr "  return r;\n"
5470        | RInt _ ->
5471            pr "  if (r == -1) return -1;\n";
5472            pr "  printf (\"%%d\\n\", r);\n";
5473            pr "  return 0;\n"
5474        | RInt64 _ ->
5475            pr "  if (r == -1) return -1;\n";
5476            pr "  printf (\"%%\" PRIi64 \"\\n\", r);\n";
5477            pr "  return 0;\n"
5478        | RBool _ ->
5479            pr "  if (r == -1) return -1;\n";
5480            pr "  if (r) printf (\"true\\n\"); else printf (\"false\\n\");\n";
5481            pr "  return 0;\n"
5482        | RConstString _ ->
5483            pr "  if (r == NULL) return -1;\n";
5484            pr "  printf (\"%%s\\n\", r);\n";
5485            pr "  return 0;\n"
5486        | RString _ ->
5487            pr "  if (r == NULL) return -1;\n";
5488            pr "  printf (\"%%s\\n\", r);\n";
5489            pr "  free (r);\n";
5490            pr "  return 0;\n"
5491        | RStringList _ ->
5492            pr "  if (r == NULL) return -1;\n";
5493            pr "  print_strings (r);\n";
5494            pr "  free_strings (r);\n";
5495            pr "  return 0;\n"
5496        | RStruct (_, typ) ->
5497            pr "  if (r == NULL) return -1;\n";
5498            pr "  print_%s (r);\n" typ;
5499            pr "  guestfs_free_%s (r);\n" typ;
5500            pr "  return 0;\n"
5501        | RStructList (_, typ) ->
5502            pr "  if (r == NULL) return -1;\n";
5503            pr "  print_%s_list (r);\n" typ;
5504            pr "  guestfs_free_%s_list (r);\n" typ;
5505            pr "  return 0;\n"
5506        | RHashtable _ ->
5507            pr "  if (r == NULL) return -1;\n";
5508            pr "  print_table (r);\n";
5509            pr "  free_strings (r);\n";
5510            pr "  return 0;\n"
5511        | RBufferOut _ ->
5512            pr "  if (r == NULL) return -1;\n";
5513            pr "  fwrite (r, size, 1, stdout);\n";
5514            pr "  free (r);\n";
5515            pr "  return 0;\n"
5516       );
5517       pr "}\n";
5518       pr "\n"
5519   ) all_functions;
5520
5521   (* run_action function *)
5522   pr "int run_action (const char *cmd, int argc, char *argv[])\n";
5523   pr "{\n";
5524   List.iter (
5525     fun (name, _, _, flags, _, _, _) ->
5526       let name2 = replace_char name '_' '-' in
5527       let alias =
5528         try find_map (function FishAlias n -> Some n | _ -> None) flags
5529         with Not_found -> name in
5530       pr "  if (";
5531       pr "strcasecmp (cmd, \"%s\") == 0" name;
5532       if name <> name2 then
5533         pr " || strcasecmp (cmd, \"%s\") == 0" name2;
5534       if name <> alias then
5535         pr " || strcasecmp (cmd, \"%s\") == 0" alias;
5536       pr ")\n";
5537       pr "    return run_%s (cmd, argc, argv);\n" name;
5538       pr "  else\n";
5539   ) all_functions;
5540   pr "    {\n";
5541   pr "      fprintf (stderr, \"%%s: unknown command\\n\", cmd);\n";
5542   pr "      return -1;\n";
5543   pr "    }\n";
5544   pr "  return 0;\n";
5545   pr "}\n";
5546   pr "\n"
5547
5548 (* Readline completion for guestfish. *)
5549 and generate_fish_completion () =
5550   generate_header CStyle GPLv2;
5551
5552   let all_functions =
5553     List.filter (
5554       fun (_, _, _, flags, _, _, _) -> not (List.mem NotInFish flags)
5555     ) all_functions in
5556
5557   pr "\
5558 #include <config.h>
5559
5560 #include <stdio.h>
5561 #include <stdlib.h>
5562 #include <string.h>
5563
5564 #ifdef HAVE_LIBREADLINE
5565 #include <readline/readline.h>
5566 #endif
5567
5568 #include \"fish.h\"
5569
5570 #ifdef HAVE_LIBREADLINE
5571
5572 static const char *const commands[] = {
5573   BUILTIN_COMMANDS_FOR_COMPLETION,
5574 ";
5575
5576   (* Get the commands, including the aliases.  They don't need to be
5577    * sorted - the generator() function just does a dumb linear search.
5578    *)
5579   let commands =
5580     List.map (
5581       fun (name, _, _, flags, _, _, _) ->
5582         let name2 = replace_char name '_' '-' in
5583         let alias =
5584           try find_map (function FishAlias n -> Some n | _ -> None) flags
5585           with Not_found -> name in
5586
5587         if name <> alias then [name2; alias] else [name2]
5588     ) all_functions in
5589   let commands = List.flatten commands in
5590
5591   List.iter (pr "  \"%s\",\n") commands;
5592
5593   pr "  NULL
5594 };
5595
5596 static char *
5597 generator (const char *text, int state)
5598 {
5599   static int index, len;
5600   const char *name;
5601
5602   if (!state) {
5603     index = 0;
5604     len = strlen (text);
5605   }
5606
5607   rl_attempted_completion_over = 1;
5608
5609   while ((name = commands[index]) != NULL) {
5610     index++;
5611     if (strncasecmp (name, text, len) == 0)
5612       return strdup (name);
5613   }
5614
5615   return NULL;
5616 }
5617
5618 #endif /* HAVE_LIBREADLINE */
5619
5620 char **do_completion (const char *text, int start, int end)
5621 {
5622   char **matches = NULL;
5623
5624 #ifdef HAVE_LIBREADLINE
5625   rl_completion_append_character = ' ';
5626
5627   if (start == 0)
5628     matches = rl_completion_matches (text, generator);
5629   else if (complete_dest_paths)
5630     matches = rl_completion_matches (text, complete_dest_paths_generator);
5631 #endif
5632
5633   return matches;
5634 }
5635 ";
5636
5637 (* Generate the POD documentation for guestfish. *)
5638 and generate_fish_actions_pod () =
5639   let all_functions_sorted =
5640     List.filter (
5641       fun (_, _, _, flags, _, _, _) ->
5642         not (List.mem NotInFish flags || List.mem NotInDocs flags)
5643     ) all_functions_sorted in
5644
5645   let rex = Str.regexp "C<guestfs_\\([^>]+\\)>" in
5646
5647   List.iter (
5648     fun (name, style, _, flags, _, _, longdesc) ->
5649       let longdesc =
5650         Str.global_substitute rex (
5651           fun s ->
5652             let sub =
5653               try Str.matched_group 1 s
5654               with Not_found ->
5655                 failwithf "error substituting C<guestfs_...> in longdesc of function %s" name in
5656             "C<" ^ replace_char sub '_' '-' ^ ">"
5657         ) longdesc in
5658       let name = replace_char name '_' '-' in
5659       let alias =
5660         try find_map (function FishAlias n -> Some n | _ -> None) flags
5661         with Not_found -> name in
5662
5663       pr "=head2 %s" name;
5664       if name <> alias then
5665         pr " | %s" alias;
5666       pr "\n";
5667       pr "\n";
5668       pr " %s" name;
5669       List.iter (
5670         function
5671         | String n -> pr " %s" n
5672         | OptString n -> pr " %s" n
5673         | StringList n -> pr " '%s ...'" n
5674         | Bool _ -> pr " true|false"
5675         | Int n -> pr " %s" n
5676         | FileIn n | FileOut n -> pr " (%s|-)" n
5677       ) (snd style);
5678       pr "\n";
5679       pr "\n";
5680       pr "%s\n\n" longdesc;
5681
5682       if List.exists (function FileIn _ | FileOut _ -> true
5683                       | _ -> false) (snd style) then
5684         pr "Use C<-> instead of a filename to read/write from stdin/stdout.\n\n";
5685
5686       if List.mem ProtocolLimitWarning flags then
5687         pr "%s\n\n" protocol_limit_warning;
5688
5689       if List.mem DangerWillRobinson flags then
5690         pr "%s\n\n" danger_will_robinson
5691   ) all_functions_sorted
5692
5693 (* Generate a C function prototype. *)
5694 and generate_prototype ?(extern = true) ?(static = false) ?(semicolon = true)
5695     ?(single_line = false) ?(newline = false) ?(in_daemon = false)
5696     ?(prefix = "")
5697     ?handle name style =
5698   if extern then pr "extern ";
5699   if static then pr "static ";
5700   (match fst style with
5701    | RErr -> pr "int "
5702    | RInt _ -> pr "int "
5703    | RInt64 _ -> pr "int64_t "
5704    | RBool _ -> pr "int "
5705    | RConstString _ -> pr "const char *"
5706    | RString _ | RBufferOut _ -> pr "char *"
5707    | RStringList _ | RHashtable _ -> pr "char **"
5708    | RStruct (_, typ) ->
5709        if not in_daemon then pr "struct guestfs_%s *" typ
5710        else pr "guestfs_int_%s *" typ
5711    | RStructList (_, typ) ->
5712        if not in_daemon then pr "struct guestfs_%s_list *" typ
5713        else pr "guestfs_int_%s_list *" typ
5714   );
5715   let is_RBufferOut = match fst style with RBufferOut _ -> true | _ -> false in
5716   pr "%s%s (" prefix name;
5717   if handle = None && List.length (snd style) = 0 && not is_RBufferOut then
5718     pr "void"
5719   else (
5720     let comma = ref false in
5721     (match handle with
5722      | None -> ()
5723      | Some handle -> pr "guestfs_h *%s" handle; comma := true
5724     );
5725     let next () =
5726       if !comma then (
5727         if single_line then pr ", " else pr ",\n\t\t"
5728       );
5729       comma := true
5730     in
5731     List.iter (
5732       function
5733       | String n
5734       | OptString n ->
5735           next ();
5736           if not in_daemon then pr "const char *%s" n
5737           else pr "char *%s" n
5738       | StringList n ->
5739           next ();
5740           if not in_daemon then pr "char * const* const %s" n
5741           else pr "char **%s" n
5742       | Bool n -> next (); pr "int %s" n
5743       | Int n -> next (); pr "int %s" n
5744       | FileIn n
5745       | FileOut n ->
5746           if not in_daemon then (next (); pr "const char *%s" n)
5747     ) (snd style);
5748     if is_RBufferOut then (next (); pr "size_t *size_r");
5749   );
5750   pr ")";
5751   if semicolon then pr ";";
5752   if newline then pr "\n"
5753
5754 (* Generate C call arguments, eg "(handle, foo, bar)" *)
5755 and generate_c_call_args ?handle ?(decl = false) style =
5756   pr "(";
5757   let comma = ref false in
5758   let next () =
5759     if !comma then pr ", ";
5760     comma := true
5761   in
5762   (match handle with
5763    | None -> ()
5764    | Some handle -> pr "%s" handle; comma := true
5765   );
5766   List.iter (
5767     fun arg ->
5768       next ();
5769       pr "%s" (name_of_argt arg)
5770   ) (snd style);
5771   (* For RBufferOut calls, add implicit &size parameter. *)
5772   if not decl then (
5773     match fst style with
5774     | RBufferOut _ ->
5775         next ();
5776         pr "&size"
5777     | _ -> ()
5778   );
5779   pr ")"
5780
5781 (* Generate the OCaml bindings interface. *)
5782 and generate_ocaml_mli () =
5783   generate_header OCamlStyle LGPLv2;
5784
5785   pr "\
5786 (** For API documentation you should refer to the C API
5787     in the guestfs(3) manual page.  The OCaml API uses almost
5788     exactly the same calls. *)
5789
5790 type t
5791 (** A [guestfs_h] handle. *)
5792
5793 exception Error of string
5794 (** This exception is raised when there is an error. *)
5795
5796 val create : unit -> t
5797
5798 val close : t -> unit
5799 (** Handles are closed by the garbage collector when they become
5800     unreferenced, but callers can also call this in order to
5801     provide predictable cleanup. *)
5802
5803 ";
5804   generate_ocaml_structure_decls ();
5805
5806   (* The actions. *)
5807   List.iter (
5808     fun (name, style, _, _, _, shortdesc, _) ->
5809       generate_ocaml_prototype name style;
5810       pr "(** %s *)\n" shortdesc;
5811       pr "\n"
5812   ) all_functions
5813
5814 (* Generate the OCaml bindings implementation. *)
5815 and generate_ocaml_ml () =
5816   generate_header OCamlStyle LGPLv2;
5817
5818   pr "\
5819 type t
5820 exception Error of string
5821 external create : unit -> t = \"ocaml_guestfs_create\"
5822 external close : t -> unit = \"ocaml_guestfs_close\"
5823
5824 let () =
5825   Callback.register_exception \"ocaml_guestfs_error\" (Error \"\")
5826
5827 ";
5828
5829   generate_ocaml_structure_decls ();
5830
5831   (* The actions. *)
5832   List.iter (
5833     fun (name, style, _, _, _, shortdesc, _) ->
5834       generate_ocaml_prototype ~is_external:true name style;
5835   ) all_functions
5836
5837 (* Generate the OCaml bindings C implementation. *)
5838 and generate_ocaml_c () =
5839   generate_header CStyle LGPLv2;
5840
5841   pr "\
5842 #include <stdio.h>
5843 #include <stdlib.h>
5844 #include <string.h>
5845
5846 #include <caml/config.h>
5847 #include <caml/alloc.h>
5848 #include <caml/callback.h>
5849 #include <caml/fail.h>
5850 #include <caml/memory.h>
5851 #include <caml/mlvalues.h>
5852 #include <caml/signals.h>
5853
5854 #include <guestfs.h>
5855
5856 #include \"guestfs_c.h\"
5857
5858 /* Copy a hashtable of string pairs into an assoc-list.  We return
5859  * the list in reverse order, but hashtables aren't supposed to be
5860  * ordered anyway.
5861  */
5862 static CAMLprim value
5863 copy_table (char * const * argv)
5864 {
5865   CAMLparam0 ();
5866   CAMLlocal5 (rv, pairv, kv, vv, cons);
5867   int i;
5868
5869   rv = Val_int (0);
5870   for (i = 0; argv[i] != NULL; i += 2) {
5871     kv = caml_copy_string (argv[i]);
5872     vv = caml_copy_string (argv[i+1]);
5873     pairv = caml_alloc (2, 0);
5874     Store_field (pairv, 0, kv);
5875     Store_field (pairv, 1, vv);
5876     cons = caml_alloc (2, 0);
5877     Store_field (cons, 1, rv);
5878     rv = cons;
5879     Store_field (cons, 0, pairv);
5880   }
5881
5882   CAMLreturn (rv);
5883 }
5884
5885 ";
5886
5887   (* Struct copy functions. *)
5888   List.iter (
5889     fun (typ, cols) ->
5890       let has_optpercent_col =
5891         List.exists (function (_, FOptPercent) -> true | _ -> false) cols in
5892
5893       pr "static CAMLprim value\n";
5894       pr "copy_%s (const struct guestfs_%s *%s)\n" typ typ typ;
5895       pr "{\n";
5896       pr "  CAMLparam0 ();\n";
5897       if has_optpercent_col then
5898         pr "  CAMLlocal3 (rv, v, v2);\n"
5899       else
5900         pr "  CAMLlocal2 (rv, v);\n";
5901       pr "\n";
5902       pr "  rv = caml_alloc (%d, 0);\n" (List.length cols);
5903       iteri (
5904         fun i col ->
5905           (match col with
5906            | name, FString ->
5907                pr "  v = caml_copy_string (%s->%s);\n" typ name
5908            | name, FBuffer ->
5909                pr "  v = caml_alloc_string (%s->%s_len);\n" typ name;
5910                pr "  memcpy (String_val (v), %s->%s, %s->%s_len);\n"
5911                  typ name typ name
5912            | name, FUUID ->
5913                pr "  v = caml_alloc_string (32);\n";
5914                pr "  memcpy (String_val (v), %s->%s, 32);\n" typ name
5915            | name, (FBytes|FInt64|FUInt64) ->
5916                pr "  v = caml_copy_int64 (%s->%s);\n" typ name
5917            | name, (FInt32|FUInt32) ->
5918                pr "  v = caml_copy_int32 (%s->%s);\n" typ name
5919            | name, FOptPercent ->
5920                pr "  if (%s->%s >= 0) { /* Some %s */\n" typ name name;
5921                pr "    v2 = caml_copy_double (%s->%s);\n" typ name;
5922                pr "    v = caml_alloc (1, 0);\n";
5923                pr "    Store_field (v, 0, v2);\n";
5924                pr "  } else /* None */\n";
5925                pr "    v = Val_int (0);\n";
5926            | name, FChar ->
5927                pr "  v = Val_int (%s->%s);\n" typ name
5928           );
5929           pr "  Store_field (rv, %d, v);\n" i
5930       ) cols;
5931       pr "  CAMLreturn (rv);\n";
5932       pr "}\n";
5933       pr "\n";
5934
5935       pr "static CAMLprim value\n";
5936       pr "copy_%s_list (const struct guestfs_%s_list *%ss)\n"
5937         typ typ typ;
5938       pr "{\n";
5939       pr "  CAMLparam0 ();\n";
5940       pr "  CAMLlocal2 (rv, v);\n";
5941       pr "  int i;\n";
5942       pr "\n";
5943       pr "  if (%ss->len == 0)\n" typ;
5944       pr "    CAMLreturn (Atom (0));\n";
5945       pr "  else {\n";
5946       pr "    rv = caml_alloc (%ss->len, 0);\n" typ;
5947       pr "    for (i = 0; i < %ss->len; ++i) {\n" typ;
5948       pr "      v = copy_%s (&%ss->val[i]);\n" typ typ;
5949       pr "      caml_modify (&Field (rv, i), v);\n";
5950       pr "    }\n";
5951       pr "    CAMLreturn (rv);\n";
5952       pr "  }\n";
5953       pr "}\n";
5954       pr "\n";
5955   ) structs;
5956
5957   (* The wrappers. *)
5958   List.iter (
5959     fun (name, style, _, _, _, _, _) ->
5960       let params =
5961         "gv" :: List.map (fun arg -> name_of_argt arg ^ "v") (snd style) in
5962
5963       pr "CAMLprim value\n";
5964       pr "ocaml_guestfs_%s (value %s" name (List.hd params);
5965       List.iter (pr ", value %s") (List.tl params);
5966       pr ")\n";
5967       pr "{\n";
5968
5969       (match params with
5970        | [p1; p2; p3; p4; p5] ->
5971            pr "  CAMLparam5 (%s);\n" (String.concat ", " params)
5972        | p1 :: p2 :: p3 :: p4 :: p5 :: rest ->
5973            pr "  CAMLparam5 (%s);\n" (String.concat ", " [p1; p2; p3; p4; p5]);
5974            pr "  CAMLxparam%d (%s);\n"
5975              (List.length rest) (String.concat ", " rest)
5976        | ps ->
5977            pr "  CAMLparam%d (%s);\n" (List.length ps) (String.concat ", " ps)
5978       );
5979       pr "  CAMLlocal1 (rv);\n";
5980       pr "\n";
5981
5982       pr "  guestfs_h *g = Guestfs_val (gv);\n";
5983       pr "  if (g == NULL)\n";
5984       pr "    caml_failwith (\"%s: used handle after closing it\");\n" name;
5985       pr "\n";
5986
5987       List.iter (
5988         function
5989         | String n
5990         | FileIn n
5991         | FileOut n ->
5992             pr "  const char *%s = String_val (%sv);\n" n n
5993         | OptString n ->
5994             pr "  const char *%s =\n" n;
5995             pr "    %sv != Val_int (0) ? String_val (Field (%sv, 0)) : NULL;\n"
5996               n n
5997         | StringList n ->
5998             pr "  char **%s = ocaml_guestfs_strings_val (g, %sv);\n" n n
5999         | Bool n ->
6000             pr "  int %s = Bool_val (%sv);\n" n n
6001         | Int n ->
6002             pr "  int %s = Int_val (%sv);\n" n n
6003       ) (snd style);
6004       let error_code =
6005         match fst style with
6006         | RErr -> pr "  int r;\n"; "-1"
6007         | RInt _ -> pr "  int r;\n"; "-1"
6008         | RInt64 _ -> pr "  int64_t r;\n"; "-1"
6009         | RBool _ -> pr "  int r;\n"; "-1"
6010         | RConstString _ -> pr "  const char *r;\n"; "NULL"
6011         | RString _ -> pr "  char *r;\n"; "NULL"
6012         | RStringList _ ->
6013             pr "  int i;\n";
6014             pr "  char **r;\n";
6015             "NULL"
6016         | RStruct (_, typ) ->
6017             pr "  struct guestfs_%s *r;\n" typ; "NULL"
6018         | RStructList (_, typ) ->
6019             pr "  struct guestfs_%s_list *r;\n" typ; "NULL"
6020         | RHashtable _ ->
6021             pr "  int i;\n";
6022             pr "  char **r;\n";
6023             "NULL"
6024         | RBufferOut _ ->
6025             pr "  char *r;\n";
6026             pr "  size_t size;\n";
6027             "NULL" in
6028       pr "\n";
6029
6030       pr "  caml_enter_blocking_section ();\n";
6031       pr "  r = guestfs_%s " name;
6032       generate_c_call_args ~handle:"g" style;
6033       pr ";\n";
6034       pr "  caml_leave_blocking_section ();\n";
6035
6036       List.iter (
6037         function
6038         | StringList n ->
6039             pr "  ocaml_guestfs_free_strings (%s);\n" n;
6040         | String _ | OptString _ | Bool _ | Int _ | FileIn _ | FileOut _ -> ()
6041       ) (snd style);
6042
6043       pr "  if (r == %s)\n" error_code;
6044       pr "    ocaml_guestfs_raise_error (g, \"%s\");\n" name;
6045       pr "\n";
6046
6047       (match fst style with
6048        | RErr -> pr "  rv = Val_unit;\n"
6049        | RInt _ -> pr "  rv = Val_int (r);\n"
6050        | RInt64 _ ->
6051            pr "  rv = caml_copy_int64 (r);\n"
6052        | RBool _ -> pr "  rv = Val_bool (r);\n"
6053        | RConstString _ -> pr "  rv = caml_copy_string (r);\n"
6054        | RString _ ->
6055            pr "  rv = caml_copy_string (r);\n";
6056            pr "  free (r);\n"
6057        | RStringList _ ->
6058            pr "  rv = caml_copy_string_array ((const char **) r);\n";
6059            pr "  for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
6060            pr "  free (r);\n"
6061        | RStruct (_, typ) ->
6062            pr "  rv = copy_%s (r);\n" typ;
6063            pr "  guestfs_free_%s (r);\n" typ;
6064        | RStructList (_, typ) ->
6065            pr "  rv = copy_%s_list (r);\n" typ;
6066            pr "  guestfs_free_%s_list (r);\n" typ;
6067        | RHashtable _ ->
6068            pr "  rv = copy_table (r);\n";
6069            pr "  for (i = 0; r[i] != NULL; ++i) free (r[i]);\n";
6070            pr "  free (r);\n";
6071        | RBufferOut _ ->
6072            pr "  rv = caml_alloc_string (size);\n";
6073            pr "  memcpy (String_val (rv), r, size);\n";
6074       );
6075
6076       pr "  CAMLreturn (rv);\n";
6077       pr "}\n";
6078       pr "\n";
6079
6080       if List.length params > 5 then (
6081         pr "CAMLprim value\n";
6082         pr "ocaml_guestfs_%s_byte (value *argv, int argn)\n" name;
6083         pr "{\n";
6084         pr "  return ocaml_guestfs_%s (argv[0]" name;
6085         iteri (fun i _ -> pr ", argv[%d]" i) (List.tl params);
6086         pr ");\n";
6087         pr "}\n";
6088         pr "\n"
6089       )
6090   ) all_functions
6091
6092 and generate_ocaml_structure_decls () =
6093   List.iter (
6094     fun (typ, cols) ->
6095       pr "type %s = {\n" typ;
6096       List.iter (
6097         function
6098         | name, FString -> pr "  %s : string;\n" name
6099         | name, FBuffer -> pr "  %s : string;\n" name
6100         | name, FUUID -> pr "  %s : string;\n" name
6101         | name, (FBytes|FInt64|FUInt64) -> pr "  %s : int64;\n" name
6102         | name, (FInt32|FUInt32) -> pr "  %s : int32;\n" name
6103         | name, FChar -> pr "  %s : char;\n" name
6104         | name, FOptPercent -> pr "  %s : float option;\n" name
6105       ) cols;
6106       pr "}\n";
6107       pr "\n"
6108   ) structs
6109
6110 and generate_ocaml_prototype ?(is_external = false) name style =
6111   if is_external then pr "external " else pr "val ";
6112   pr "%s : t -> " name;
6113   List.iter (
6114     function
6115     | String _ | FileIn _ | FileOut _ -> pr "string -> "
6116     | OptString _ -> pr "string option -> "
6117     | StringList _ -> pr "string array -> "
6118     | Bool _ -> pr "bool -> "
6119     | Int _ -> pr "int -> "
6120   ) (snd style);
6121   (match fst style with
6122    | RErr -> pr "unit" (* all errors are turned into exceptions *)
6123    | RInt _ -> pr "int"
6124    | RInt64 _ -> pr "int64"
6125    | RBool _ -> pr "bool"
6126    | RConstString _ -> pr "string"
6127    | RString _ | RBufferOut _ -> pr "string"
6128    | RStringList _ -> pr "string array"
6129    | RStruct (_, typ) -> pr "%s" typ
6130    | RStructList (_, typ) -> pr "%s array" typ
6131    | RHashtable _ -> pr "(string * string) list"
6132   );
6133   if is_external then (
6134     pr " = ";
6135     if List.length (snd style) + 1 > 5 then
6136       pr "\"ocaml_guestfs_%s_byte\" " name;
6137     pr "\"ocaml_guestfs_%s\"" name
6138   );
6139   pr "\n"
6140
6141 (* Generate Perl xs code, a sort of crazy variation of C with macros. *)
6142 and generate_perl_xs () =
6143   generate_header CStyle LGPLv2;
6144
6145   pr "\
6146 #include \"EXTERN.h\"
6147 #include \"perl.h\"
6148 #include \"XSUB.h\"
6149
6150 #include <guestfs.h>
6151
6152 #ifndef PRId64
6153 #define PRId64 \"lld\"
6154 #endif
6155
6156 static SV *
6157 my_newSVll(long long val) {
6158 #ifdef USE_64_BIT_ALL
6159   return newSViv(val);
6160 #else
6161   char buf[100];
6162   int len;
6163   len = snprintf(buf, 100, \"%%\" PRId64, val);
6164   return newSVpv(buf, len);
6165 #endif
6166 }
6167
6168 #ifndef PRIu64
6169 #define PRIu64 \"llu\"
6170 #endif
6171
6172 static SV *
6173 my_newSVull(unsigned long long val) {
6174 #ifdef USE_64_BIT_ALL
6175   return newSVuv(val);
6176 #else
6177   char buf[100];
6178   int len;
6179   len = snprintf(buf, 100, \"%%\" PRIu64, val);
6180   return newSVpv(buf, len);
6181 #endif
6182 }
6183
6184 /* http://www.perlmonks.org/?node_id=680842 */
6185 static char **
6186 XS_unpack_charPtrPtr (SV *arg) {
6187   char **ret;
6188   AV *av;
6189   I32 i;
6190
6191   if (!arg || !SvOK (arg) || !SvROK (arg) || SvTYPE (SvRV (arg)) != SVt_PVAV)
6192     croak (\"array reference expected\");
6193
6194   av = (AV *)SvRV (arg);
6195   ret = malloc ((av_len (av) + 1 + 1) * sizeof (char *));
6196   if (!ret)
6197     croak (\"malloc failed\");
6198
6199   for (i = 0; i <= av_len (av); i++) {
6200     SV **elem = av_fetch (av, i, 0);
6201
6202     if (!elem || !*elem)
6203       croak (\"missing element in list\");
6204
6205     ret[i] = SvPV_nolen (*elem);
6206   }
6207
6208   ret[i] = NULL;
6209
6210   return ret;
6211 }
6212
6213 MODULE = Sys::Guestfs  PACKAGE = Sys::Guestfs
6214
6215 PROTOTYPES: ENABLE
6216
6217 guestfs_h *
6218 _create ()
6219    CODE:
6220       RETVAL = guestfs_create ();
6221       if (!RETVAL)
6222         croak (\"could not create guestfs handle\");
6223       guestfs_set_error_handler (RETVAL, NULL, NULL);
6224  OUTPUT:
6225       RETVAL
6226
6227 void
6228 DESTROY (g)
6229       guestfs_h *g;
6230  PPCODE:
6231       guestfs_close (g);
6232
6233 ";
6234
6235   List.iter (
6236     fun (name, style, _, _, _, _, _) ->
6237       (match fst style with
6238        | RErr -> pr "void\n"
6239        | RInt _ -> pr "SV *\n"
6240        | RInt64 _ -> pr "SV *\n"
6241        | RBool _ -> pr "SV *\n"
6242        | RConstString _ -> pr "SV *\n"
6243        | RString _ -> pr "SV *\n"
6244        | RBufferOut _ -> pr "SV *\n"
6245        | RStringList _
6246        | RStruct _ | RStructList _
6247        | RHashtable _ ->
6248            pr "void\n" (* all lists returned implictly on the stack *)
6249       );
6250       (* Call and arguments. *)
6251       pr "%s " name;
6252       generate_c_call_args ~handle:"g" ~decl:true style;
6253       pr "\n";
6254       pr "      guestfs_h *g;\n";
6255       iteri (
6256         fun i ->
6257           function
6258           | String n | FileIn n | FileOut n -> pr "      char *%s;\n" n
6259           | OptString n ->
6260               (* http://www.perlmonks.org/?node_id=554277
6261                * Note that the implicit handle argument means we have
6262                * to add 1 to the ST(x) operator.
6263                *)
6264               pr "      char *%s = SvOK(ST(%d)) ? SvPV_nolen(ST(%d)) : NULL;\n" n (i+1) (i+1)
6265           | StringList n -> pr "      char **%s;\n" n
6266           | Bool n -> pr "      int %s;\n" n
6267           | Int n -> pr "      int %s;\n" n
6268       ) (snd style);
6269
6270       let do_cleanups () =
6271         List.iter (
6272           function
6273           | String _ | OptString _ | Bool _ | Int _
6274           | FileIn _ | FileOut _ -> ()
6275           | StringList n -> pr "      free (%s);\n" n
6276         ) (snd style)
6277       in
6278
6279       (* Code. *)
6280       (match fst style with
6281        | RErr ->
6282            pr "PREINIT:\n";
6283            pr "      int r;\n";
6284            pr " PPCODE:\n";
6285            pr "      r = guestfs_%s " name;
6286            generate_c_call_args ~handle:"g" style;
6287            pr ";\n";
6288            do_cleanups ();
6289            pr "      if (r == -1)\n";
6290            pr "        croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
6291        | RInt n
6292        | RBool n ->
6293            pr "PREINIT:\n";
6294            pr "      int %s;\n" n;
6295            pr "   CODE:\n";
6296            pr "      %s = guestfs_%s " n name;
6297            generate_c_call_args ~handle:"g" style;
6298            pr ";\n";
6299            do_cleanups ();
6300            pr "      if (%s == -1)\n" n;
6301            pr "        croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
6302            pr "      RETVAL = newSViv (%s);\n" n;
6303            pr " OUTPUT:\n";
6304            pr "      RETVAL\n"
6305        | RInt64 n ->
6306            pr "PREINIT:\n";
6307            pr "      int64_t %s;\n" n;
6308            pr "   CODE:\n";
6309            pr "      %s = guestfs_%s " n name;
6310            generate_c_call_args ~handle:"g" style;
6311            pr ";\n";
6312            do_cleanups ();
6313            pr "      if (%s == -1)\n" n;
6314            pr "        croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
6315            pr "      RETVAL = my_newSVll (%s);\n" n;
6316            pr " OUTPUT:\n";
6317            pr "      RETVAL\n"
6318        | RConstString n ->
6319            pr "PREINIT:\n";
6320            pr "      const char *%s;\n" n;
6321            pr "   CODE:\n";
6322            pr "      %s = guestfs_%s " n name;
6323            generate_c_call_args ~handle:"g" style;
6324            pr ";\n";
6325            do_cleanups ();
6326            pr "      if (%s == NULL)\n" n;
6327            pr "        croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
6328            pr "      RETVAL = newSVpv (%s, 0);\n" n;
6329            pr " OUTPUT:\n";
6330            pr "      RETVAL\n"
6331        | RString n ->
6332            pr "PREINIT:\n";
6333            pr "      char *%s;\n" n;
6334            pr "   CODE:\n";
6335            pr "      %s = guestfs_%s " n name;
6336            generate_c_call_args ~handle:"g" style;
6337            pr ";\n";
6338            do_cleanups ();
6339            pr "      if (%s == NULL)\n" n;
6340            pr "        croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
6341            pr "      RETVAL = newSVpv (%s, 0);\n" n;
6342            pr "      free (%s);\n" n;
6343            pr " OUTPUT:\n";
6344            pr "      RETVAL\n"
6345        | RStringList n | RHashtable n ->
6346            pr "PREINIT:\n";
6347            pr "      char **%s;\n" n;
6348            pr "      int i, n;\n";
6349            pr " PPCODE:\n";
6350            pr "      %s = guestfs_%s " n name;
6351            generate_c_call_args ~handle:"g" style;
6352            pr ";\n";
6353            do_cleanups ();
6354            pr "      if (%s == NULL)\n" n;
6355            pr "        croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
6356            pr "      for (n = 0; %s[n] != NULL; ++n) /**/;\n" n;
6357            pr "      EXTEND (SP, n);\n";
6358            pr "      for (i = 0; i < n; ++i) {\n";
6359            pr "        PUSHs (sv_2mortal (newSVpv (%s[i], 0)));\n" n;
6360            pr "        free (%s[i]);\n" n;
6361            pr "      }\n";
6362            pr "      free (%s);\n" n;
6363        | RStruct (n, typ) ->
6364            let cols = cols_of_struct typ in
6365            generate_perl_struct_code typ cols name style n do_cleanups
6366        | RStructList (n, typ) ->
6367            let cols = cols_of_struct typ in
6368            generate_perl_struct_list_code typ cols name style n do_cleanups
6369        | RBufferOut n ->
6370            pr "PREINIT:\n";
6371            pr "      char *%s;\n" n;
6372            pr "      size_t size;\n";
6373            pr "   CODE:\n";
6374            pr "      %s = guestfs_%s " n name;
6375            generate_c_call_args ~handle:"g" style;
6376            pr ";\n";
6377            do_cleanups ();
6378            pr "      if (%s == NULL)\n" n;
6379            pr "        croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
6380            pr "      RETVAL = newSVpv (%s, size);\n" n;
6381            pr "      free (%s);\n" n;
6382            pr " OUTPUT:\n";
6383            pr "      RETVAL\n"
6384       );
6385
6386       pr "\n"
6387   ) all_functions
6388
6389 and generate_perl_struct_list_code typ cols name style n do_cleanups =
6390   pr "PREINIT:\n";
6391   pr "      struct guestfs_%s_list *%s;\n" typ n;
6392   pr "      int i;\n";
6393   pr "      HV *hv;\n";
6394   pr " PPCODE:\n";
6395   pr "      %s = guestfs_%s " n name;
6396   generate_c_call_args ~handle:"g" style;
6397   pr ";\n";
6398   do_cleanups ();
6399   pr "      if (%s == NULL)\n" n;
6400   pr "        croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
6401   pr "      EXTEND (SP, %s->len);\n" n;
6402   pr "      for (i = 0; i < %s->len; ++i) {\n" n;
6403   pr "        hv = newHV ();\n";
6404   List.iter (
6405     function
6406     | name, FString ->
6407         pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (%s->val[i].%s, 0), 0);\n"
6408           name (String.length name) n name
6409     | name, FUUID ->
6410         pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (%s->val[i].%s, 32), 0);\n"
6411           name (String.length name) n name
6412     | name, FBuffer ->
6413         pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (%s->val[i].%s, %s->val[i].%s_len), 0);\n"
6414           name (String.length name) n name n name
6415     | name, (FBytes|FUInt64) ->
6416         pr "        (void) hv_store (hv, \"%s\", %d, my_newSVull (%s->val[i].%s), 0);\n"
6417           name (String.length name) n name
6418     | name, FInt64 ->
6419         pr "        (void) hv_store (hv, \"%s\", %d, my_newSVll (%s->val[i].%s), 0);\n"
6420           name (String.length name) n name
6421     | name, (FInt32|FUInt32) ->
6422         pr "        (void) hv_store (hv, \"%s\", %d, newSVnv (%s->val[i].%s), 0);\n"
6423           name (String.length name) n name
6424     | name, FChar ->
6425         pr "        (void) hv_store (hv, \"%s\", %d, newSVpv (&%s->val[i].%s, 1), 0);\n"
6426           name (String.length name) n name
6427     | name, FOptPercent ->
6428         pr "        (void) hv_store (hv, \"%s\", %d, newSVnv (%s->val[i].%s), 0);\n"
6429           name (String.length name) n name
6430   ) cols;
6431   pr "        PUSHs (sv_2mortal (newRV ((SV *) hv)));\n";
6432   pr "      }\n";
6433   pr "      guestfs_free_%s_list (%s);\n" typ n
6434
6435 and generate_perl_struct_code typ cols name style n do_cleanups =
6436   pr "PREINIT:\n";
6437   pr "      struct guestfs_%s *%s;\n" typ n;
6438   pr " PPCODE:\n";
6439   pr "      %s = guestfs_%s " n name;
6440   generate_c_call_args ~handle:"g" style;
6441   pr ";\n";
6442   do_cleanups ();
6443   pr "      if (%s == NULL)\n" n;
6444   pr "        croak (\"%s: %%s\", guestfs_last_error (g));\n" name;
6445   pr "      EXTEND (SP, 2 * %d);\n" (List.length cols);
6446   List.iter (
6447     fun ((name, _) as col) ->
6448       pr "      PUSHs (sv_2mortal (newSVpv (\"%s\", 0)));\n" name;
6449
6450       match col with
6451       | name, FString ->
6452           pr "      PUSHs (sv_2mortal (newSVpv (%s->%s, 0)));\n"
6453             n name
6454       | name, FBuffer ->
6455           pr "      PUSHs (sv_2mortal (newSVpv (%s->%s, %s->%s_len)));\n"
6456             n name n name
6457       | name, FUUID ->
6458           pr "      PUSHs (sv_2mortal (newSVpv (%s->%s, 32)));\n"
6459             n name
6460       | name, (FBytes|FUInt64) ->
6461           pr "      PUSHs (sv_2mortal (my_newSVull (%s->%s)));\n"
6462             n name
6463       | name, FInt64 ->
6464           pr "      PUSHs (sv_2mortal (my_newSVll (%s->%s)));\n"
6465             n name
6466       | name, (FInt32|FUInt32) ->
6467           pr "      PUSHs (sv_2mortal (newSVnv (%s->%s)));\n"
6468             n name
6469       | name, FChar ->
6470           pr "      PUSHs (sv_2mortal (newSVpv (&%s->%s, 1)));\n"
6471             n name
6472       | name, FOptPercent ->
6473           pr "      PUSHs (sv_2mortal (newSVnv (%s->%s)));\n"
6474             n name
6475   ) cols;
6476   pr "      free (%s);\n" n
6477
6478 (* Generate Sys/Guestfs.pm. *)
6479 and generate_perl_pm () =
6480   generate_header HashStyle LGPLv2;
6481
6482   pr "\
6483 =pod
6484
6485 =head1 NAME
6486
6487 Sys::Guestfs - Perl bindings for libguestfs
6488
6489 =head1 SYNOPSIS
6490
6491  use Sys::Guestfs;
6492
6493  my $h = Sys::Guestfs->new ();
6494  $h->add_drive ('guest.img');
6495  $h->launch ();
6496  $h->wait_ready ();
6497  $h->mount ('/dev/sda1', '/');
6498  $h->touch ('/hello');
6499  $h->sync ();
6500
6501 =head1 DESCRIPTION
6502
6503 The C<Sys::Guestfs> module provides a Perl XS binding to the
6504 libguestfs API for examining and modifying virtual machine
6505 disk images.
6506
6507 Amongst the things this is good for: making batch configuration
6508 changes to guests, getting disk used/free statistics (see also:
6509 virt-df), migrating between virtualization systems (see also:
6510 virt-p2v), performing partial backups, performing partial guest
6511 clones, cloning guests and changing registry/UUID/hostname info, and
6512 much else besides.
6513
6514 Libguestfs uses Linux kernel and qemu code, and can access any type of
6515 guest filesystem that Linux and qemu can, including but not limited
6516 to: ext2/3/4, btrfs, FAT and NTFS, LVM, many different disk partition
6517 schemes, qcow, qcow2, vmdk.
6518
6519 Libguestfs provides ways to enumerate guest storage (eg. partitions,
6520 LVs, what filesystem is in each LV, etc.).  It can also run commands
6521 in the context of the guest.  Also you can access filesystems over FTP.
6522
6523 See also L<Sys::Guestfs::Lib(3)> for a set of useful library
6524 functions for using libguestfs from Perl, including integration
6525 with libvirt.
6526
6527 =head1 ERRORS
6528
6529 All errors turn into calls to C<croak> (see L<Carp(3)>).
6530
6531 =head1 METHODS
6532
6533 =over 4
6534
6535 =cut
6536
6537 package Sys::Guestfs;
6538
6539 use strict;
6540 use warnings;
6541
6542 require XSLoader;
6543 XSLoader::load ('Sys::Guestfs');
6544
6545 =item $h = Sys::Guestfs->new ();
6546
6547 Create a new guestfs handle.
6548
6549 =cut
6550
6551 sub new {
6552   my $proto = shift;
6553   my $class = ref ($proto) || $proto;
6554
6555   my $self = Sys::Guestfs::_create ();
6556   bless $self, $class;
6557   return $self;
6558 }
6559
6560 ";
6561
6562   (* Actions.  We only need to print documentation for these as
6563    * they are pulled in from the XS code automatically.
6564    *)
6565   List.iter (
6566     fun (name, style, _, flags, _, _, longdesc) ->
6567       if not (List.mem NotInDocs flags) then (
6568         let longdesc = replace_str longdesc "C<guestfs_" "C<$h-E<gt>" in
6569         pr "=item ";
6570         generate_perl_prototype name style;
6571         pr "\n\n";
6572         pr "%s\n\n" longdesc;
6573         if List.mem ProtocolLimitWarning flags then
6574           pr "%s\n\n" protocol_limit_warning;
6575         if List.mem DangerWillRobinson flags then
6576           pr "%s\n\n" danger_will_robinson
6577       )
6578   ) all_functions_sorted;
6579
6580   (* End of file. *)
6581   pr "\
6582 =cut
6583
6584 1;
6585
6586 =back
6587
6588 =head1 COPYRIGHT
6589
6590 Copyright (C) 2009 Red Hat Inc.
6591
6592 =head1 LICENSE
6593
6594 Please see the file COPYING.LIB for the full license.
6595
6596 =head1 SEE ALSO
6597
6598 L<guestfs(3)>,
6599 L<guestfish(1)>,
6600 L<http://libguestfs.org>,
6601 L<Sys::Guestfs::Lib(3)>.
6602
6603 =cut
6604 "
6605
6606 and generate_perl_prototype name style =
6607   (match fst style with
6608    | RErr -> ()
6609    | RBool n
6610    | RInt n
6611    | RInt64 n
6612    | RConstString n
6613    | RString n
6614    | RBufferOut n -> pr "$%s = " n
6615    | RStruct (n,_)
6616    | RHashtable n -> pr "%%%s = " n
6617    | RStringList n
6618    | RStructList (n,_) -> pr "@%s = " n
6619   );
6620   pr "$h->%s (" name;
6621   let comma = ref false in
6622   List.iter (
6623     fun arg ->
6624       if !comma then pr ", ";
6625       comma := true;
6626       match arg with
6627       | String n | OptString n | Bool n | Int n | FileIn n | FileOut n ->
6628           pr "$%s" n
6629       | StringList n ->
6630           pr "\\@%s" n
6631   ) (snd style);
6632   pr ");"
6633
6634 (* Generate Python C module. *)
6635 and generate_python_c () =
6636   generate_header CStyle LGPLv2;
6637
6638   pr "\
6639 #include <stdio.h>
6640 #include <stdlib.h>
6641 #include <assert.h>
6642
6643 #include <Python.h>
6644
6645 #include \"guestfs.h\"
6646
6647 typedef struct {
6648   PyObject_HEAD
6649   guestfs_h *g;
6650 } Pyguestfs_Object;
6651
6652 static guestfs_h *
6653 get_handle (PyObject *obj)
6654 {
6655   assert (obj);
6656   assert (obj != Py_None);
6657   return ((Pyguestfs_Object *) obj)->g;
6658 }
6659
6660 static PyObject *
6661 put_handle (guestfs_h *g)
6662 {
6663   assert (g);
6664   return
6665     PyCObject_FromVoidPtrAndDesc ((void *) g, (char *) \"guestfs_h\", NULL);
6666 }
6667
6668 /* This list should be freed (but not the strings) after use. */
6669 static const char **
6670 get_string_list (PyObject *obj)
6671 {
6672   int i, len;
6673   const char **r;
6674
6675   assert (obj);
6676
6677   if (!PyList_Check (obj)) {
6678     PyErr_SetString (PyExc_RuntimeError, \"expecting a list parameter\");
6679     return NULL;
6680   }
6681
6682   len = PyList_Size (obj);
6683   r = malloc (sizeof (char *) * (len+1));
6684   if (r == NULL) {
6685     PyErr_SetString (PyExc_RuntimeError, \"get_string_list: out of memory\");
6686     return NULL;
6687   }
6688
6689   for (i = 0; i < len; ++i)
6690     r[i] = PyString_AsString (PyList_GetItem (obj, i));
6691   r[len] = NULL;
6692
6693   return r;
6694 }
6695
6696 static PyObject *
6697 put_string_list (char * const * const argv)
6698 {
6699   PyObject *list;
6700   int argc, i;
6701
6702   for (argc = 0; argv[argc] != NULL; ++argc)
6703     ;
6704
6705   list = PyList_New (argc);
6706   for (i = 0; i < argc; ++i)
6707     PyList_SetItem (list, i, PyString_FromString (argv[i]));
6708
6709   return list;
6710 }
6711
6712 static PyObject *
6713 put_table (char * const * const argv)
6714 {
6715   PyObject *list, *item;
6716   int argc, i;
6717
6718   for (argc = 0; argv[argc] != NULL; ++argc)
6719     ;
6720
6721   list = PyList_New (argc >> 1);
6722   for (i = 0; i < argc; i += 2) {
6723     item = PyTuple_New (2);
6724     PyTuple_SetItem (item, 0, PyString_FromString (argv[i]));
6725     PyTuple_SetItem (item, 1, PyString_FromString (argv[i+1]));
6726     PyList_SetItem (list, i >> 1, item);
6727   }
6728
6729   return list;
6730 }
6731
6732 static void
6733 free_strings (char **argv)
6734 {
6735   int argc;
6736
6737   for (argc = 0; argv[argc] != NULL; ++argc)
6738     free (argv[argc]);
6739   free (argv);
6740 }
6741
6742 static PyObject *
6743 py_guestfs_create (PyObject *self, PyObject *args)
6744 {
6745   guestfs_h *g;
6746
6747   g = guestfs_create ();
6748   if (g == NULL) {
6749     PyErr_SetString (PyExc_RuntimeError,
6750                      \"guestfs.create: failed to allocate handle\");
6751     return NULL;
6752   }
6753   guestfs_set_error_handler (g, NULL, NULL);
6754   return put_handle (g);
6755 }
6756
6757 static PyObject *
6758 py_guestfs_close (PyObject *self, PyObject *args)
6759 {
6760   PyObject *py_g;
6761   guestfs_h *g;
6762
6763   if (!PyArg_ParseTuple (args, (char *) \"O:guestfs_close\", &py_g))
6764     return NULL;
6765   g = get_handle (py_g);
6766
6767   guestfs_close (g);
6768
6769   Py_INCREF (Py_None);
6770   return Py_None;
6771 }
6772
6773 ";
6774
6775   (* Structures, turned into Python dictionaries. *)
6776   List.iter (
6777     fun (typ, cols) ->
6778       pr "static PyObject *\n";
6779       pr "put_%s (struct guestfs_%s *%s)\n" typ typ typ;
6780       pr "{\n";
6781       pr "  PyObject *dict;\n";
6782       pr "\n";
6783       pr "  dict = PyDict_New ();\n";
6784       List.iter (
6785         function
6786         | name, FString ->
6787             pr "  PyDict_SetItemString (dict, \"%s\",\n" name;
6788             pr "                        PyString_FromString (%s->%s));\n"
6789               typ name
6790         | name, FBuffer ->
6791             pr "  PyDict_SetItemString (dict, \"%s\",\n" name;
6792             pr "                        PyString_FromStringAndSize (%s->%s, %s->%s_len));\n"
6793               typ name typ name
6794         | name, FUUID ->
6795             pr "  PyDict_SetItemString (dict, \"%s\",\n" name;
6796             pr "                        PyString_FromStringAndSize (%s->%s, 32));\n"
6797               typ name
6798         | name, (FBytes|FUInt64) ->
6799             pr "  PyDict_SetItemString (dict, \"%s\",\n" name;
6800             pr "                        PyLong_FromUnsignedLongLong (%s->%s));\n"
6801               typ name
6802         | name, FInt64 ->
6803             pr "  PyDict_SetItemString (dict, \"%s\",\n" name;
6804             pr "                        PyLong_FromLongLong (%s->%s));\n"
6805               typ name
6806         | name, FUInt32 ->
6807             pr "  PyDict_SetItemString (dict, \"%s\",\n" name;
6808             pr "                        PyLong_FromUnsignedLong (%s->%s));\n"
6809               typ name
6810         | name, FInt32 ->
6811             pr "  PyDict_SetItemString (dict, \"%s\",\n" name;
6812             pr "                        PyLong_FromLong (%s->%s));\n"
6813               typ name
6814         | name, FOptPercent ->
6815             pr "  if (%s->%s >= 0)\n" typ name;
6816             pr "    PyDict_SetItemString (dict, \"%s\",\n" name;
6817             pr "                          PyFloat_FromDouble ((double) %s->%s));\n"
6818               typ name;
6819             pr "  else {\n";
6820             pr "    Py_INCREF (Py_None);\n";
6821             pr "    PyDict_SetItemString (dict, \"%s\", Py_None);" name;
6822             pr "  }\n"
6823         | name, FChar ->
6824             pr "  PyDict_SetItemString (dict, \"%s\",\n" name;
6825             pr "                        PyString_FromStringAndSize (&dirent->%s, 1));\n" name
6826       ) cols;
6827       pr "  return dict;\n";
6828       pr "};\n";
6829       pr "\n";
6830
6831       pr "static PyObject *\n";
6832       pr "put_%s_list (struct guestfs_%s_list *%ss)\n" typ typ typ;
6833       pr "{\n";
6834       pr "  PyObject *list;\n";
6835       pr "  int i;\n";
6836       pr "\n";
6837       pr "  list = PyList_New (%ss->len);\n" typ;
6838       pr "  for (i = 0; i < %ss->len; ++i)\n" typ;
6839       pr "    PyList_SetItem (list, i, put_%s (&%ss->val[i]));\n" typ typ;
6840       pr "  return list;\n";
6841       pr "};\n";
6842       pr "\n"
6843   ) structs;
6844
6845   (* Python wrapper functions. *)
6846   List.iter (
6847     fun (name, style, _, _, _, _, _) ->
6848       pr "static PyObject *\n";
6849       pr "py_guestfs_%s (PyObject *self, PyObject *args)\n" name;
6850       pr "{\n";
6851
6852       pr "  PyObject *py_g;\n";
6853       pr "  guestfs_h *g;\n";
6854       pr "  PyObject *py_r;\n";
6855
6856       let error_code =
6857         match fst style with
6858         | RErr | RInt _ | RBool _ -> pr "  int r;\n"; "-1"
6859         | RInt64 _ -> pr "  int64_t r;\n"; "-1"
6860         | RConstString _ -> pr "  const char *r;\n"; "NULL"
6861         | RString _ -> pr "  char *r;\n"; "NULL"
6862         | RStringList _ | RHashtable _ -> pr "  char **r;\n"; "NULL"
6863         | RStruct (_, typ) -> pr "  struct guestfs_%s *r;\n" typ; "NULL"
6864         | RStructList (_, typ) ->
6865             pr "  struct guestfs_%s_list *r;\n" typ; "NULL"
6866         | RBufferOut _ ->
6867             pr "  char *r;\n";
6868             pr "  size_t size;\n";
6869             "NULL" in
6870
6871       List.iter (
6872         function
6873         | String n | FileIn n | FileOut n -> pr "  const char *%s;\n" n
6874         | OptString n -> pr "  const char *%s;\n" n
6875         | StringList n ->
6876             pr "  PyObject *py_%s;\n" n;
6877             pr "  const char **%s;\n" n
6878         | Bool n -> pr "  int %s;\n" n
6879         | Int n -> pr "  int %s;\n" n
6880       ) (snd style);
6881
6882       pr "\n";
6883
6884       (* Convert the parameters. *)
6885       pr "  if (!PyArg_ParseTuple (args, (char *) \"O";
6886       List.iter (
6887         function
6888         | String _ | FileIn _ | FileOut _ -> pr "s"
6889         | OptString _ -> pr "z"
6890         | StringList _ -> pr "O"
6891         | Bool _ -> pr "i" (* XXX Python has booleans? *)
6892         | Int _ -> pr "i"
6893       ) (snd style);
6894       pr ":guestfs_%s\",\n" name;
6895       pr "                         &py_g";
6896       List.iter (
6897         function
6898         | String n | FileIn n | FileOut n -> pr ", &%s" n
6899         | OptString n -> pr ", &%s" n
6900         | StringList n -> pr ", &py_%s" n
6901         | Bool n -> pr ", &%s" n
6902         | Int n -> pr ", &%s" n
6903       ) (snd style);
6904
6905       pr "))\n";
6906       pr "    return NULL;\n";
6907
6908       pr "  g = get_handle (py_g);\n";
6909       List.iter (
6910         function
6911         | String _ | FileIn _ | FileOut _ | OptString _ | Bool _ | Int _ -> ()
6912         | StringList n ->
6913             pr "  %s = get_string_list (py_%s);\n" n n;
6914             pr "  if (!%s) return NULL;\n" n
6915       ) (snd style);
6916
6917       pr "\n";
6918
6919       pr "  r = guestfs_%s " name;
6920       generate_c_call_args ~handle:"g" style;
6921       pr ";\n";
6922
6923       List.iter (
6924         function
6925         | String _ | FileIn _ | FileOut _ | OptString _ | Bool _ | Int _ -> ()
6926         | StringList n ->
6927             pr "  free (%s);\n" n
6928       ) (snd style);
6929
6930       pr "  if (r == %s) {\n" error_code;
6931       pr "    PyErr_SetString (PyExc_RuntimeError, guestfs_last_error (g));\n";
6932       pr "    return NULL;\n";
6933       pr "  }\n";
6934       pr "\n";
6935
6936       (match fst style with
6937        | RErr ->
6938            pr "  Py_INCREF (Py_None);\n";
6939            pr "  py_r = Py_None;\n"
6940        | RInt _
6941        | RBool _ -> pr "  py_r = PyInt_FromLong ((long) r);\n"
6942        | RInt64 _ -> pr "  py_r = PyLong_FromLongLong (r);\n"
6943        | RConstString _ -> pr "  py_r = PyString_FromString (r);\n"
6944        | RString _ ->
6945            pr "  py_r = PyString_FromString (r);\n";
6946            pr "  free (r);\n"
6947        | RStringList _ ->
6948            pr "  py_r = put_string_list (r);\n";
6949            pr "  free_strings (r);\n"
6950        | RStruct (_, typ) ->
6951            pr "  py_r = put_%s (r);\n" typ;
6952            pr "  guestfs_free_%s (r);\n" typ
6953        | RStructList (_, typ) ->
6954            pr "  py_r = put_%s_list (r);\n" typ;
6955            pr "  guestfs_free_%s_list (r);\n" typ
6956        | RHashtable n ->
6957            pr "  py_r = put_table (r);\n";
6958            pr "  free_strings (r);\n"
6959        | RBufferOut _ ->
6960            pr "  py_r = PyString_FromStringAndSize (r, size);\n";
6961            pr "  free (r);\n"
6962       );
6963
6964       pr "  return py_r;\n";
6965       pr "}\n";
6966       pr "\n"
6967   ) all_functions;
6968
6969   (* Table of functions. *)
6970   pr "static PyMethodDef methods[] = {\n";
6971   pr "  { (char *) \"create\", py_guestfs_create, METH_VARARGS, NULL },\n";
6972   pr "  { (char *) \"close\", py_guestfs_close, METH_VARARGS, NULL },\n";
6973   List.iter (
6974     fun (name, _, _, _, _, _, _) ->
6975       pr "  { (char *) \"%s\", py_guestfs_%s, METH_VARARGS, NULL },\n"
6976         name name
6977   ) all_functions;
6978   pr "  { NULL, NULL, 0, NULL }\n";
6979   pr "};\n";
6980   pr "\n";
6981
6982   (* Init function. *)
6983   pr "\
6984 void
6985 initlibguestfsmod (void)
6986 {
6987   static int initialized = 0;
6988
6989   if (initialized) return;
6990   Py_InitModule ((char *) \"libguestfsmod\", methods);
6991   initialized = 1;
6992 }
6993 "
6994
6995 (* Generate Python module. *)
6996 and generate_python_py () =
6997   generate_header HashStyle LGPLv2;
6998
6999   pr "\
7000 u\"\"\"Python bindings for libguestfs
7001
7002 import guestfs
7003 g = guestfs.GuestFS ()
7004 g.add_drive (\"guest.img\")
7005 g.launch ()
7006 g.wait_ready ()
7007 parts = g.list_partitions ()
7008
7009 The guestfs module provides a Python binding to the libguestfs API
7010 for examining and modifying virtual machine disk images.
7011
7012 Amongst the things this is good for: making batch configuration
7013 changes to guests, getting disk used/free statistics (see also:
7014 virt-df), migrating between virtualization systems (see also:
7015 virt-p2v), performing partial backups, performing partial guest
7016 clones, cloning guests and changing registry/UUID/hostname info, and
7017 much else besides.
7018
7019 Libguestfs uses Linux kernel and qemu code, and can access any type of
7020 guest filesystem that Linux and qemu can, including but not limited
7021 to: ext2/3/4, btrfs, FAT and NTFS, LVM, many different disk partition
7022 schemes, qcow, qcow2, vmdk.
7023
7024 Libguestfs provides ways to enumerate guest storage (eg. partitions,
7025 LVs, what filesystem is in each LV, etc.).  It can also run commands
7026 in the context of the guest.  Also you can access filesystems over FTP.
7027
7028 Errors which happen while using the API are turned into Python
7029 RuntimeError exceptions.
7030
7031 To create a guestfs handle you usually have to perform the following
7032 sequence of calls:
7033
7034 # Create the handle, call add_drive at least once, and possibly
7035 # several times if the guest has multiple block devices:
7036 g = guestfs.GuestFS ()
7037 g.add_drive (\"guest.img\")
7038
7039 # Launch the qemu subprocess and wait for it to become ready:
7040 g.launch ()
7041 g.wait_ready ()
7042
7043 # Now you can issue commands, for example:
7044 logvols = g.lvs ()
7045
7046 \"\"\"
7047
7048 import libguestfsmod
7049
7050 class GuestFS:
7051     \"\"\"Instances of this class are libguestfs API handles.\"\"\"
7052
7053     def __init__ (self):
7054         \"\"\"Create a new libguestfs handle.\"\"\"
7055         self._o = libguestfsmod.create ()
7056
7057     def __del__ (self):
7058         libguestfsmod.close (self._o)
7059
7060 ";
7061
7062   List.iter (
7063     fun (name, style, _, flags, _, _, longdesc) ->
7064       pr "    def %s " name;
7065       generate_py_call_args ~handle:"self" (snd style);
7066       pr ":\n";
7067
7068       if not (List.mem NotInDocs flags) then (
7069         let doc = replace_str longdesc "C<guestfs_" "C<g." in
7070         let doc =
7071           match fst style with
7072           | RErr | RInt _ | RInt64 _ | RBool _ | RConstString _
7073           | RString _ | RBufferOut _ -> doc
7074           | RStringList _ ->
7075               doc ^ "\n\nThis function returns a list of strings."
7076           | RStruct (_, typ) ->
7077               doc ^ sprintf "\n\nThis function returns a dictionary, with keys matching the various fields in the guestfs_%s structure." typ
7078           | RStructList (_, typ) ->
7079               doc ^ sprintf "\n\nThis function returns a list of %ss.  Each %s is represented as a dictionary." typ typ
7080           | RHashtable _ ->
7081               doc ^ "\n\nThis function returns a dictionary." in
7082         let doc =
7083           if List.mem ProtocolLimitWarning flags then
7084             doc ^ "\n\n" ^ protocol_limit_warning
7085           else doc in
7086         let doc =
7087           if List.mem DangerWillRobinson flags then
7088             doc ^ "\n\n" ^ danger_will_robinson
7089           else doc in
7090         let doc = pod2text ~width:60 name doc in
7091         let doc = List.map (fun line -> replace_str line "\\" "\\\\") doc in
7092         let doc = String.concat "\n        " doc in
7093         pr "        u\"\"\"%s\"\"\"\n" doc;
7094       );
7095       pr "        return libguestfsmod.%s " name;
7096       generate_py_call_args ~handle:"self._o" (snd style);
7097       pr "\n";
7098       pr "\n";
7099   ) all_functions
7100
7101 (* Generate Python call arguments, eg "(handle, foo, bar)" *)
7102 and generate_py_call_args ~handle args =
7103   pr "(%s" handle;
7104   List.iter (fun arg -> pr ", %s" (name_of_argt arg)) args;
7105   pr ")"
7106
7107 (* Useful if you need the longdesc POD text as plain text.  Returns a
7108  * list of lines.
7109  *
7110  * Because this is very slow (the slowest part of autogeneration),
7111  * we memoize the results.
7112  *)
7113 and pod2text ~width name longdesc =
7114   let key = width, name, longdesc in
7115   try Hashtbl.find pod2text_memo key
7116   with Not_found ->
7117     let filename, chan = Filename.open_temp_file "gen" ".tmp" in
7118     fprintf chan "=head1 %s\n\n%s\n" name longdesc;
7119     close_out chan;
7120     let cmd = sprintf "pod2text -w %d %s" width (Filename.quote filename) in
7121     let chan = Unix.open_process_in cmd in
7122     let lines = ref [] in
7123     let rec loop i =
7124       let line = input_line chan in
7125       if i = 1 then             (* discard the first line of output *)
7126         loop (i+1)
7127       else (
7128         let line = triml line in
7129         lines := line :: !lines;
7130         loop (i+1)
7131       ) in
7132     let lines = try loop 1 with End_of_file -> List.rev !lines in
7133     Unix.unlink filename;
7134     (match Unix.close_process_in chan with
7135      | Unix.WEXITED 0 -> ()
7136      | Unix.WEXITED i ->
7137          failwithf "pod2text: process exited with non-zero status (%d)" i
7138      | Unix.WSIGNALED i | Unix.WSTOPPED i ->
7139          failwithf "pod2text: process signalled or stopped by signal %d" i
7140     );
7141     Hashtbl.add pod2text_memo key lines;
7142     let chan = open_out pod2text_memo_filename in
7143     output_value chan pod2text_memo;
7144     close_out chan;
7145     lines
7146
7147 (* Generate ruby bindings. *)
7148 and generate_ruby_c () =
7149   generate_header CStyle LGPLv2;
7150
7151   pr "\
7152 #include <stdio.h>
7153 #include <stdlib.h>
7154
7155 #include <ruby.h>
7156
7157 #include \"guestfs.h\"
7158
7159 #include \"extconf.h\"
7160
7161 /* For Ruby < 1.9 */
7162 #ifndef RARRAY_LEN
7163 #define RARRAY_LEN(r) (RARRAY((r))->len)
7164 #endif
7165
7166 static VALUE m_guestfs;                 /* guestfs module */
7167 static VALUE c_guestfs;                 /* guestfs_h handle */
7168 static VALUE e_Error;                   /* used for all errors */
7169
7170 static void ruby_guestfs_free (void *p)
7171 {
7172   if (!p) return;
7173   guestfs_close ((guestfs_h *) p);
7174 }
7175
7176 static VALUE ruby_guestfs_create (VALUE m)
7177 {
7178   guestfs_h *g;
7179
7180   g = guestfs_create ();
7181   if (!g)
7182     rb_raise (e_Error, \"failed to create guestfs handle\");
7183
7184   /* Don't print error messages to stderr by default. */
7185   guestfs_set_error_handler (g, NULL, NULL);
7186
7187   /* Wrap it, and make sure the close function is called when the
7188    * handle goes away.
7189    */
7190   return Data_Wrap_Struct (c_guestfs, NULL, ruby_guestfs_free, g);
7191 }
7192
7193 static VALUE ruby_guestfs_close (VALUE gv)
7194 {
7195   guestfs_h *g;
7196   Data_Get_Struct (gv, guestfs_h, g);
7197
7198   ruby_guestfs_free (g);
7199   DATA_PTR (gv) = NULL;
7200
7201   return Qnil;
7202 }
7203
7204 ";
7205
7206   List.iter (
7207     fun (name, style, _, _, _, _, _) ->
7208       pr "static VALUE ruby_guestfs_%s (VALUE gv" name;
7209       List.iter (fun arg -> pr ", VALUE %sv" (name_of_argt arg)) (snd style);
7210       pr ")\n";
7211       pr "{\n";
7212       pr "  guestfs_h *g;\n";
7213       pr "  Data_Get_Struct (gv, guestfs_h, g);\n";
7214       pr "  if (!g)\n";
7215       pr "    rb_raise (rb_eArgError, \"%%s: used handle after closing it\", \"%s\");\n"
7216         name;
7217       pr "\n";
7218
7219       List.iter (
7220         function
7221         | String n | FileIn n | FileOut n ->
7222             pr "  Check_Type (%sv, T_STRING);\n" n;
7223             pr "  const char *%s = StringValueCStr (%sv);\n" n n;
7224             pr "  if (!%s)\n" n;
7225             pr "    rb_raise (rb_eTypeError, \"expected string for parameter %%s of %%s\",\n";
7226             pr "              \"%s\", \"%s\");\n" n name
7227         | OptString n ->
7228             pr "  const char *%s = !NIL_P (%sv) ? StringValueCStr (%sv) : NULL;\n" n n n
7229         | StringList n ->
7230             pr "  char **%s;\n" n;
7231             pr "  Check_Type (%sv, T_ARRAY);\n" n;
7232             pr "  {\n";
7233             pr "    int i, len;\n";
7234             pr "    len = RARRAY_LEN (%sv);\n" n;
7235             pr "    %s = guestfs_safe_malloc (g, sizeof (char *) * (len+1));\n"
7236               n;
7237             pr "    for (i = 0; i < len; ++i) {\n";
7238             pr "      VALUE v = rb_ary_entry (%sv, i);\n" n;
7239             pr "      %s[i] = StringValueCStr (v);\n" n;
7240             pr "    }\n";
7241             pr "    %s[len] = NULL;\n" n;
7242             pr "  }\n";
7243         | Bool n ->
7244             pr "  int %s = RTEST (%sv);\n" n n
7245         | Int n ->
7246             pr "  int %s = NUM2INT (%sv);\n" n n
7247       ) (snd style);
7248       pr "\n";
7249
7250       let error_code =
7251         match fst style with
7252         | RErr | RInt _ | RBool _ -> pr "  int r;\n"; "-1"
7253         | RInt64 _ -> pr "  int64_t r;\n"; "-1"
7254         | RConstString _ -> pr "  const char *r;\n"; "NULL"
7255         | RString _ -> pr "  char *r;\n"; "NULL"
7256         | RStringList _ | RHashtable _ -> pr "  char **r;\n"; "NULL"
7257         | RStruct (_, typ) -> pr "  struct guestfs_%s *r;\n" typ; "NULL"
7258         | RStructList (_, typ) ->
7259             pr "  struct guestfs_%s_list *r;\n" typ; "NULL"
7260         | RBufferOut _ ->
7261             pr "  char *r;\n";
7262             pr "  size_t size;\n";
7263             "NULL" in
7264       pr "\n";
7265
7266       pr "  r = guestfs_%s " name;
7267       generate_c_call_args ~handle:"g" style;
7268       pr ";\n";
7269
7270       List.iter (
7271         function
7272         | String _ | FileIn _ | FileOut _ | OptString _ | Bool _ | Int _ -> ()
7273         | StringList n ->
7274             pr "  free (%s);\n" n
7275       ) (snd style);
7276
7277       pr "  if (r == %s)\n" error_code;
7278       pr "    rb_raise (e_Error, \"%%s\", guestfs_last_error (g));\n";
7279       pr "\n";
7280
7281       (match fst style with
7282        | RErr ->
7283            pr "  return Qnil;\n"
7284        | RInt _ | RBool _ ->
7285            pr "  return INT2NUM (r);\n"
7286        | RInt64 _ ->
7287            pr "  return ULL2NUM (r);\n"
7288        | RConstString _ ->
7289            pr "  return rb_str_new2 (r);\n";
7290        | RString _ ->
7291            pr "  VALUE rv = rb_str_new2 (r);\n";
7292            pr "  free (r);\n";
7293            pr "  return rv;\n";
7294        | RStringList _ ->
7295            pr "  int i, len = 0;\n";
7296            pr "  for (i = 0; r[i] != NULL; ++i) len++;\n";
7297            pr "  VALUE rv = rb_ary_new2 (len);\n";
7298            pr "  for (i = 0; r[i] != NULL; ++i) {\n";
7299            pr "    rb_ary_push (rv, rb_str_new2 (r[i]));\n";
7300            pr "    free (r[i]);\n";
7301            pr "  }\n";
7302            pr "  free (r);\n";
7303            pr "  return rv;\n"
7304        | RStruct (_, typ) ->
7305            let cols = cols_of_struct typ in
7306            generate_ruby_struct_code typ cols
7307        | RStructList (_, typ) ->
7308            let cols = cols_of_struct typ in
7309            generate_ruby_struct_list_code typ cols
7310        | RHashtable _ ->
7311            pr "  VALUE rv = rb_hash_new ();\n";
7312            pr "  int i;\n";
7313            pr "  for (i = 0; r[i] != NULL; i+=2) {\n";
7314            pr "    rb_hash_aset (rv, rb_str_new2 (r[i]), rb_str_new2 (r[i+1]));\n";
7315            pr "    free (r[i]);\n";
7316            pr "    free (r[i+1]);\n";
7317            pr "  }\n";
7318            pr "  free (r);\n";
7319            pr "  return rv;\n"
7320        | RBufferOut _ ->
7321            pr "  VALUE rv = rb_str_new (r, size);\n";
7322            pr "  free (r);\n";
7323            pr "  return rv;\n";
7324       );
7325
7326       pr "}\n";
7327       pr "\n"
7328   ) all_functions;
7329
7330   pr "\
7331 /* Initialize the module. */
7332 void Init__guestfs ()
7333 {
7334   m_guestfs = rb_define_module (\"Guestfs\");
7335   c_guestfs = rb_define_class_under (m_guestfs, \"Guestfs\", rb_cObject);
7336   e_Error = rb_define_class_under (m_guestfs, \"Error\", rb_eStandardError);
7337
7338   rb_define_module_function (m_guestfs, \"create\", ruby_guestfs_create, 0);
7339   rb_define_method (c_guestfs, \"close\", ruby_guestfs_close, 0);
7340
7341 ";
7342   (* Define the rest of the methods. *)
7343   List.iter (
7344     fun (name, style, _, _, _, _, _) ->
7345       pr "  rb_define_method (c_guestfs, \"%s\",\n" name;
7346       pr "        ruby_guestfs_%s, %d);\n" name (List.length (snd style))
7347   ) all_functions;
7348
7349   pr "}\n"
7350
7351 (* Ruby code to return a struct. *)
7352 and generate_ruby_struct_code typ cols =
7353   pr "  VALUE rv = rb_hash_new ();\n";
7354   List.iter (
7355     function
7356     | name, FString ->
7357         pr "  rb_hash_aset (rv, rb_str_new2 (\"%s\"), rb_str_new2 (r->%s));\n" name name
7358     | name, FBuffer ->
7359         pr "  rb_hash_aset (rv, rb_str_new2 (\"%s\"), rb_str_new (r->%s, r->%s_len));\n" name name name
7360     | name, FUUID ->
7361         pr "  rb_hash_aset (rv, rb_str_new2 (\"%s\"), rb_str_new (r->%s, 32));\n" name name
7362     | name, (FBytes|FUInt64) ->
7363         pr "  rb_hash_aset (rv, rb_str_new2 (\"%s\"), ULL2NUM (r->%s));\n" name name
7364     | name, FInt64 ->
7365         pr "  rb_hash_aset (rv, rb_str_new2 (\"%s\"), LL2NUM (r->%s));\n" name name
7366     | name, FUInt32 ->
7367         pr "  rb_hash_aset (rv, rb_str_new2 (\"%s\"), UINT2NUM (r->%s));\n" name name
7368     | name, FInt32 ->
7369         pr "  rb_hash_aset (rv, rb_str_new2 (\"%s\"), INT2NUM (r->%s));\n" name name
7370     | name, FOptPercent ->
7371         pr "  rb_hash_aset (rv, rb_str_new2 (\"%s\"), rb_dbl2big (r->%s));\n" name name
7372     | name, FChar -> (* XXX wrong? *)
7373         pr "  rb_hash_aset (rv, rb_str_new2 (\"%s\"), ULL2NUM (r->%s));\n" name name
7374   ) cols;
7375   pr "  guestfs_free_%s (r);\n" typ;
7376   pr "  return rv;\n"
7377
7378 (* Ruby code to return a struct list. *)
7379 and generate_ruby_struct_list_code typ cols =
7380   pr "  VALUE rv = rb_ary_new2 (r->len);\n";
7381   pr "  int i;\n";
7382   pr "  for (i = 0; i < r->len; ++i) {\n";
7383   pr "    VALUE hv = rb_hash_new ();\n";
7384   List.iter (
7385     function
7386     | name, FString ->
7387         pr "    rb_hash_aset (hv, rb_str_new2 (\"%s\"), rb_str_new2 (r->val[i].%s));\n" name name
7388     | name, FBuffer ->
7389         pr "    rb_hash_aset (hv, rb_str_new2 (\"%s\"), rb_str_new (r->val[i].%s, r->val[i].%s_len));\n" name name name
7390     | name, FUUID ->
7391         pr "    rb_hash_aset (hv, rb_str_new2 (\"%s\"), rb_str_new (r->val[i].%s, 32));\n" name name
7392     | name, (FBytes|FUInt64) ->
7393         pr "    rb_hash_aset (hv, rb_str_new2 (\"%s\"), ULL2NUM (r->val[i].%s));\n" name name
7394     | name, FInt64 ->
7395         pr "    rb_hash_aset (hv, rb_str_new2 (\"%s\"), LL2NUM (r->val[i].%s));\n" name name
7396     | name, FUInt32 ->
7397         pr "    rb_hash_aset (hv, rb_str_new2 (\"%s\"), UINT2NUM (r->val[i].%s));\n" name name
7398     | name, FInt32 ->
7399         pr "    rb_hash_aset (hv, rb_str_new2 (\"%s\"), INT2NUM (r->val[i].%s));\n" name name
7400     | name, FOptPercent ->
7401         pr "    rb_hash_aset (hv, rb_str_new2 (\"%s\"), rb_dbl2big (r->val[i].%s));\n" name name
7402     | name, FChar -> (* XXX wrong? *)
7403         pr "    rb_hash_aset (hv, rb_str_new2 (\"%s\"), ULL2NUM (r->val[i].%s));\n" name name
7404   ) cols;
7405   pr "    rb_ary_push (rv, hv);\n";
7406   pr "  }\n";
7407   pr "  guestfs_free_%s_list (r);\n" typ;
7408   pr "  return rv;\n"
7409
7410 (* Generate Java bindings GuestFS.java file. *)
7411 and generate_java_java () =
7412   generate_header CStyle LGPLv2;
7413
7414   pr "\
7415 package com.redhat.et.libguestfs;
7416
7417 import java.util.HashMap;
7418 import com.redhat.et.libguestfs.LibGuestFSException;
7419 import com.redhat.et.libguestfs.PV;
7420 import com.redhat.et.libguestfs.VG;
7421 import com.redhat.et.libguestfs.LV;
7422 import com.redhat.et.libguestfs.Stat;
7423 import com.redhat.et.libguestfs.StatVFS;
7424 import com.redhat.et.libguestfs.IntBool;
7425 import com.redhat.et.libguestfs.Dirent;
7426
7427 /**
7428  * The GuestFS object is a libguestfs handle.
7429  *
7430  * @author rjones
7431  */
7432 public class GuestFS {
7433   // Load the native code.
7434   static {
7435     System.loadLibrary (\"guestfs_jni\");
7436   }
7437
7438   /**
7439    * The native guestfs_h pointer.
7440    */
7441   long g;
7442
7443   /**
7444    * Create a libguestfs handle.
7445    *
7446    * @throws LibGuestFSException
7447    */
7448   public GuestFS () throws LibGuestFSException
7449   {
7450     g = _create ();
7451   }
7452   private native long _create () throws LibGuestFSException;
7453
7454   /**
7455    * Close a libguestfs handle.
7456    *
7457    * You can also leave handles to be collected by the garbage
7458    * collector, but this method ensures that the resources used
7459    * by the handle are freed up immediately.  If you call any
7460    * other methods after closing the handle, you will get an
7461    * exception.
7462    *
7463    * @throws LibGuestFSException
7464    */
7465   public void close () throws LibGuestFSException
7466   {
7467     if (g != 0)
7468       _close (g);
7469     g = 0;
7470   }
7471   private native void _close (long g) throws LibGuestFSException;
7472
7473   public void finalize () throws LibGuestFSException
7474   {
7475     close ();
7476   }
7477
7478 ";
7479
7480   List.iter (
7481     fun (name, style, _, flags, _, shortdesc, longdesc) ->
7482       if not (List.mem NotInDocs flags); then (
7483         let doc = replace_str longdesc "C<guestfs_" "C<g." in
7484         let doc =
7485           if List.mem ProtocolLimitWarning flags then
7486             doc ^ "\n\n" ^ protocol_limit_warning
7487           else doc in
7488         let doc =
7489           if List.mem DangerWillRobinson flags then
7490             doc ^ "\n\n" ^ danger_will_robinson
7491           else doc in
7492         let doc = pod2text ~width:60 name doc in
7493         let doc = List.map (            (* RHBZ#501883 *)
7494           function
7495           | "" -> "<p>"
7496           | nonempty -> nonempty
7497         ) doc in
7498         let doc = String.concat "\n   * " doc in
7499
7500         pr "  /**\n";
7501         pr "   * %s\n" shortdesc;
7502         pr "   * <p>\n";
7503         pr "   * %s\n" doc;
7504         pr "   * @throws LibGuestFSException\n";
7505         pr "   */\n";
7506         pr "  ";
7507       );
7508       generate_java_prototype ~public:true ~semicolon:false name style;
7509       pr "\n";
7510       pr "  {\n";
7511       pr "    if (g == 0)\n";
7512       pr "      throw new LibGuestFSException (\"%s: handle is closed\");\n"
7513         name;
7514       pr "    ";
7515       if fst style <> RErr then pr "return ";
7516       pr "_%s " name;
7517       generate_java_call_args ~handle:"g" (snd style);
7518       pr ";\n";
7519       pr "  }\n";
7520       pr "  ";
7521       generate_java_prototype ~privat:true ~native:true name style;
7522       pr "\n";
7523       pr "\n";
7524   ) all_functions;
7525
7526   pr "}\n"
7527
7528 (* Generate Java call arguments, eg "(handle, foo, bar)" *)
7529 and generate_java_call_args ~handle args =
7530   pr "(%s" handle;
7531   List.iter (fun arg -> pr ", %s" (name_of_argt arg)) args;
7532   pr ")"
7533
7534 and generate_java_prototype ?(public=false) ?(privat=false) ?(native=false)
7535     ?(semicolon=true) name style =
7536   if privat then pr "private ";
7537   if public then pr "public ";
7538   if native then pr "native ";
7539
7540   (* return type *)
7541   (match fst style with
7542    | RErr -> pr "void ";
7543    | RInt _ -> pr "int ";
7544    | RInt64 _ -> pr "long ";
7545    | RBool _ -> pr "boolean ";
7546    | RConstString _ | RString _ | RBufferOut _ -> pr "String ";
7547    | RStringList _ -> pr "String[] ";
7548    | RStruct (_, typ) ->
7549        let name = java_name_of_struct typ in
7550        pr "%s " name;
7551    | RStructList (_, typ) ->
7552        let name = java_name_of_struct typ in
7553        pr "%s[] " name;
7554    | RHashtable _ -> pr "HashMap<String,String> ";
7555   );
7556
7557   if native then pr "_%s " name else pr "%s " name;
7558   pr "(";
7559   let needs_comma = ref false in
7560   if native then (
7561     pr "long g";
7562     needs_comma := true
7563   );
7564
7565   (* args *)
7566   List.iter (
7567     fun arg ->
7568       if !needs_comma then pr ", ";
7569       needs_comma := true;
7570
7571       match arg with
7572       | String n
7573       | OptString n
7574       | FileIn n
7575       | FileOut n ->
7576           pr "String %s" n
7577       | StringList n ->
7578           pr "String[] %s" n
7579       | Bool n ->
7580           pr "boolean %s" n
7581       | Int n ->
7582           pr "int %s" n
7583   ) (snd style);
7584
7585   pr ")\n";
7586   pr "    throws LibGuestFSException";
7587   if semicolon then pr ";"
7588
7589 and generate_java_struct jtyp cols =
7590   generate_header CStyle LGPLv2;
7591
7592   pr "\
7593 package com.redhat.et.libguestfs;
7594
7595 /**
7596  * Libguestfs %s structure.
7597  *
7598  * @author rjones
7599  * @see GuestFS
7600  */
7601 public class %s {
7602 " jtyp jtyp;
7603
7604   List.iter (
7605     function
7606     | name, FString
7607     | name, FUUID
7608     | name, FBuffer -> pr "  public String %s;\n" name
7609     | name, (FBytes|FUInt64|FInt64) -> pr "  public long %s;\n" name
7610     | name, (FUInt32|FInt32) -> pr "  public int %s;\n" name
7611     | name, FChar -> pr "  public char %s;\n" name
7612     | name, FOptPercent ->
7613         pr "  /* The next field is [0..100] or -1 meaning 'not present': */\n";
7614         pr "  public float %s;\n" name
7615   ) cols;
7616
7617   pr "}\n"
7618
7619 and generate_java_c () =
7620   generate_header CStyle LGPLv2;
7621
7622   pr "\
7623 #include <stdio.h>
7624 #include <stdlib.h>
7625 #include <string.h>
7626
7627 #include \"com_redhat_et_libguestfs_GuestFS.h\"
7628 #include \"guestfs.h\"
7629
7630 /* Note that this function returns.  The exception is not thrown
7631  * until after the wrapper function returns.
7632  */
7633 static void
7634 throw_exception (JNIEnv *env, const char *msg)
7635 {
7636   jclass cl;
7637   cl = (*env)->FindClass (env,
7638                           \"com/redhat/et/libguestfs/LibGuestFSException\");
7639   (*env)->ThrowNew (env, cl, msg);
7640 }
7641
7642 JNIEXPORT jlong JNICALL
7643 Java_com_redhat_et_libguestfs_GuestFS__1create
7644   (JNIEnv *env, jobject obj)
7645 {
7646   guestfs_h *g;
7647
7648   g = guestfs_create ();
7649   if (g == NULL) {
7650     throw_exception (env, \"GuestFS.create: failed to allocate handle\");
7651     return 0;
7652   }
7653   guestfs_set_error_handler (g, NULL, NULL);
7654   return (jlong) (long) g;
7655 }
7656
7657 JNIEXPORT void JNICALL
7658 Java_com_redhat_et_libguestfs_GuestFS__1close
7659   (JNIEnv *env, jobject obj, jlong jg)
7660 {
7661   guestfs_h *g = (guestfs_h *) (long) jg;
7662   guestfs_close (g);
7663 }
7664
7665 ";
7666
7667   List.iter (
7668     fun (name, style, _, _, _, _, _) ->
7669       pr "JNIEXPORT ";
7670       (match fst style with
7671        | RErr -> pr "void ";
7672        | RInt _ -> pr "jint ";
7673        | RInt64 _ -> pr "jlong ";
7674        | RBool _ -> pr "jboolean ";
7675        | RConstString _ | RString _ | RBufferOut _ -> pr "jstring ";
7676        | RStruct _ | RHashtable _ ->
7677            pr "jobject ";
7678        | RStringList _ | RStructList _ ->
7679            pr "jobjectArray ";
7680       );
7681       pr "JNICALL\n";
7682       pr "Java_com_redhat_et_libguestfs_GuestFS_";
7683       pr "%s" (replace_str ("_" ^ name) "_" "_1");
7684       pr "\n";
7685       pr "  (JNIEnv *env, jobject obj, jlong jg";
7686       List.iter (
7687         function
7688         | String n
7689         | OptString n
7690         | FileIn n
7691         | FileOut n ->
7692             pr ", jstring j%s" n
7693         | StringList n ->
7694             pr ", jobjectArray j%s" n
7695         | Bool n ->
7696             pr ", jboolean j%s" n
7697         | Int n ->
7698             pr ", jint j%s" n
7699       ) (snd style);
7700       pr ")\n";
7701       pr "{\n";
7702       pr "  guestfs_h *g = (guestfs_h *) (long) jg;\n";
7703       let error_code, no_ret =
7704         match fst style with
7705         | RErr -> pr "  int r;\n"; "-1", ""
7706         | RBool _
7707         | RInt _ -> pr "  int r;\n"; "-1", "0"
7708         | RInt64 _ -> pr "  int64_t r;\n"; "-1", "0"
7709         | RConstString _ -> pr "  const char *r;\n"; "NULL", "NULL"
7710         | RString _ ->
7711             pr "  jstring jr;\n";
7712             pr "  char *r;\n"; "NULL", "NULL"
7713         | RStringList _ ->
7714             pr "  jobjectArray jr;\n";
7715             pr "  int r_len;\n";
7716             pr "  jclass cl;\n";
7717             pr "  jstring jstr;\n";
7718             pr "  char **r;\n"; "NULL", "NULL"
7719         | RStruct (_, typ) ->
7720             pr "  jobject jr;\n";
7721             pr "  jclass cl;\n";
7722             pr "  jfieldID fl;\n";
7723             pr "  struct guestfs_%s *r;\n" typ; "NULL", "NULL"
7724         | RStructList (_, typ) ->
7725             pr "  jobjectArray jr;\n";
7726             pr "  jclass cl;\n";
7727             pr "  jfieldID fl;\n";
7728             pr "  jobject jfl;\n";
7729             pr "  struct guestfs_%s_list *r;\n" typ; "NULL", "NULL"
7730         | RHashtable _ -> pr "  char **r;\n"; "NULL", "NULL"
7731         | RBufferOut _ ->
7732             pr "  jstring jr;\n";
7733             pr "  char *r;\n";
7734             pr "  size_t size;\n";
7735             "NULL", "NULL" in
7736       List.iter (
7737         function
7738         | String n
7739         | OptString n
7740         | FileIn n
7741         | FileOut n ->
7742             pr "  const char *%s;\n" n
7743         | StringList n ->
7744             pr "  int %s_len;\n" n;
7745             pr "  const char **%s;\n" n
7746         | Bool n
7747         | Int n ->
7748             pr "  int %s;\n" n
7749       ) (snd style);
7750
7751       let needs_i =
7752         (match fst style with
7753          | RStringList _ | RStructList _ -> true
7754          | RErr | RBool _ | RInt _ | RInt64 _ | RConstString _
7755          | RString _ | RBufferOut _ | RStruct _ | RHashtable _ -> false) ||
7756           List.exists (function StringList _ -> true | _ -> false) (snd style) in
7757       if needs_i then
7758         pr "  int i;\n";
7759
7760       pr "\n";
7761
7762       (* Get the parameters. *)
7763       List.iter (
7764         function
7765         | String n
7766         | FileIn n
7767         | FileOut n ->
7768             pr "  %s = (*env)->GetStringUTFChars (env, j%s, NULL);\n" n n
7769         | OptString n ->
7770             (* This is completely undocumented, but Java null becomes
7771              * a NULL parameter.
7772              *)
7773             pr "  %s = j%s ? (*env)->GetStringUTFChars (env, j%s, NULL) : NULL;\n" n n n
7774         | StringList n ->
7775             pr "  %s_len = (*env)->GetArrayLength (env, j%s);\n" n n;
7776             pr "  %s = guestfs_safe_malloc (g, sizeof (char *) * (%s_len+1));\n" n n;
7777             pr "  for (i = 0; i < %s_len; ++i) {\n" n;
7778             pr "    jobject o = (*env)->GetObjectArrayElement (env, j%s, i);\n"
7779               n;
7780             pr "    %s[i] = (*env)->GetStringUTFChars (env, o, NULL);\n" n;
7781             pr "  }\n";
7782             pr "  %s[%s_len] = NULL;\n" n n;
7783         | Bool n
7784         | Int n ->
7785             pr "  %s = j%s;\n" n n
7786       ) (snd style);
7787
7788       (* Make the call. *)
7789       pr "  r = guestfs_%s " name;
7790       generate_c_call_args ~handle:"g" style;
7791       pr ";\n";
7792
7793       (* Release the parameters. *)
7794       List.iter (
7795         function
7796         | String n
7797         | FileIn n
7798         | FileOut n ->
7799             pr "  (*env)->ReleaseStringUTFChars (env, j%s, %s);\n" n n
7800         | OptString n ->
7801             pr "  if (j%s)\n" n;
7802             pr "    (*env)->ReleaseStringUTFChars (env, j%s, %s);\n" n n
7803         | StringList n ->
7804             pr "  for (i = 0; i < %s_len; ++i) {\n" n;
7805             pr "    jobject o = (*env)->GetObjectArrayElement (env, j%s, i);\n"
7806               n;
7807             pr "    (*env)->ReleaseStringUTFChars (env, o, %s[i]);\n" n;
7808             pr "  }\n";
7809             pr "  free (%s);\n" n
7810         | Bool n
7811         | Int n -> ()
7812       ) (snd style);
7813
7814       (* Check for errors. *)
7815       pr "  if (r == %s) {\n" error_code;
7816       pr "    throw_exception (env, guestfs_last_error (g));\n";
7817       pr "    return %s;\n" no_ret;
7818       pr "  }\n";
7819
7820       (* Return value. *)
7821       (match fst style with
7822        | RErr -> ()
7823        | RInt _ -> pr "  return (jint) r;\n"
7824        | RBool _ -> pr "  return (jboolean) r;\n"
7825        | RInt64 _ -> pr "  return (jlong) r;\n"
7826        | RConstString _ -> pr "  return (*env)->NewStringUTF (env, r);\n"
7827        | RString _ ->
7828            pr "  jr = (*env)->NewStringUTF (env, r);\n";
7829            pr "  free (r);\n";
7830            pr "  return jr;\n"
7831        | RStringList _ ->
7832            pr "  for (r_len = 0; r[r_len] != NULL; ++r_len) ;\n";
7833            pr "  cl = (*env)->FindClass (env, \"java/lang/String\");\n";
7834            pr "  jstr = (*env)->NewStringUTF (env, \"\");\n";
7835            pr "  jr = (*env)->NewObjectArray (env, r_len, cl, jstr);\n";
7836            pr "  for (i = 0; i < r_len; ++i) {\n";
7837            pr "    jstr = (*env)->NewStringUTF (env, r[i]);\n";
7838            pr "    (*env)->SetObjectArrayElement (env, jr, i, jstr);\n";
7839            pr "    free (r[i]);\n";
7840            pr "  }\n";
7841            pr "  free (r);\n";
7842            pr "  return jr;\n"
7843        | RStruct (_, typ) ->
7844            let jtyp = java_name_of_struct typ in
7845            let cols = cols_of_struct typ in
7846            generate_java_struct_return typ jtyp cols
7847        | RStructList (_, typ) ->
7848            let jtyp = java_name_of_struct typ in
7849            let cols = cols_of_struct typ in
7850            generate_java_struct_list_return typ jtyp cols
7851        | RHashtable _ ->
7852            (* XXX *)
7853            pr "  throw_exception (env, \"%s: internal error: please let us know how to make a Java HashMap from JNI bindings!\");\n" name;
7854            pr "  return NULL;\n"
7855        | RBufferOut _ ->
7856            pr "  jr = (*env)->NewStringUTF (env, r); /* XXX size */\n";
7857            pr "  free (r);\n";
7858            pr "  return jr;\n"
7859       );
7860
7861       pr "}\n";
7862       pr "\n"
7863   ) all_functions
7864
7865 and generate_java_struct_return typ jtyp cols =
7866   pr "  cl = (*env)->FindClass (env, \"com/redhat/et/libguestfs/%s\");\n" jtyp;
7867   pr "  jr = (*env)->AllocObject (env, cl);\n";
7868   List.iter (
7869     function
7870     | name, FString ->
7871         pr "  fl = (*env)->GetFieldID (env, cl, \"%s\", \"Ljava/lang/String;\");\n" name;
7872         pr "  (*env)->SetObjectField (env, jr, fl, (*env)->NewStringUTF (env, r->%s));\n" name;
7873     | name, FUUID ->
7874         pr "  {\n";
7875         pr "    char s[33];\n";
7876         pr "    memcpy (s, r->%s, 32);\n" name;
7877         pr "    s[32] = 0;\n";
7878         pr "    fl = (*env)->GetFieldID (env, cl, \"%s\", \"Ljava/lang/String;\");\n" name;
7879         pr "    (*env)->SetObjectField (env, jr, fl, (*env)->NewStringUTF (env, s));\n";
7880         pr "  }\n";
7881     | name, FBuffer ->
7882         pr "  {\n";
7883         pr "    int len = r->%s_len;\n" name;
7884         pr "    char s[len+1];\n";
7885         pr "    memcpy (s, r->%s, len);\n" name;
7886         pr "    s[len] = 0;\n";
7887         pr "    fl = (*env)->GetFieldID (env, cl, \"%s\", \"Ljava/lang/String;\");\n" name;
7888         pr "    (*env)->SetObjectField (env, jr, fl, (*env)->NewStringUTF (env, s));\n";
7889         pr "  }\n";
7890     | name, (FBytes|FUInt64|FInt64) ->
7891         pr "  fl = (*env)->GetFieldID (env, cl, \"%s\", \"J\");\n" name;
7892         pr "  (*env)->SetLongField (env, jr, fl, r->%s);\n" name;
7893     | name, (FUInt32|FInt32) ->
7894         pr "  fl = (*env)->GetFieldID (env, cl, \"%s\", \"I\");\n" name;
7895         pr "  (*env)->SetLongField (env, jr, fl, r->%s);\n" name;
7896     | name, FOptPercent ->
7897         pr "  fl = (*env)->GetFieldID (env, cl, \"%s\", \"F\");\n" name;
7898         pr "  (*env)->SetFloatField (env, jr, fl, r->%s);\n" name;
7899     | name, FChar ->
7900         pr "  fl = (*env)->GetFieldID (env, cl, \"%s\", \"C\");\n" name;
7901         pr "  (*env)->SetLongField (env, jr, fl, r->%s);\n" name;
7902   ) cols;
7903   pr "  free (r);\n";
7904   pr "  return jr;\n"
7905
7906 and generate_java_struct_list_return typ jtyp cols =
7907   pr "  cl = (*env)->FindClass (env, \"com/redhat/et/libguestfs/%s\");\n" jtyp;
7908   pr "  jr = (*env)->NewObjectArray (env, r->len, cl, NULL);\n";
7909   pr "  for (i = 0; i < r->len; ++i) {\n";
7910   pr "    jfl = (*env)->AllocObject (env, cl);\n";
7911   List.iter (
7912     function
7913     | name, FString ->
7914         pr "    fl = (*env)->GetFieldID (env, cl, \"%s\", \"Ljava/lang/String;\");\n" name;
7915         pr "    (*env)->SetObjectField (env, jfl, fl, (*env)->NewStringUTF (env, r->val[i].%s));\n" name;
7916     | name, FUUID ->
7917         pr "    {\n";
7918         pr "      char s[33];\n";
7919         pr "      memcpy (s, r->val[i].%s, 32);\n" name;
7920         pr "      s[32] = 0;\n";
7921         pr "      fl = (*env)->GetFieldID (env, cl, \"%s\", \"Ljava/lang/String;\");\n" name;
7922         pr "      (*env)->SetObjectField (env, jfl, fl, (*env)->NewStringUTF (env, s));\n";
7923         pr "    }\n";
7924     | name, FBuffer ->
7925         pr "    {\n";
7926         pr "      int len = r->val[i].%s_len;\n" name;
7927         pr "      char s[len+1];\n";
7928         pr "      memcpy (s, r->val[i].%s, len);\n" name;
7929         pr "      s[len] = 0;\n";
7930         pr "      fl = (*env)->GetFieldID (env, cl, \"%s\", \"Ljava/lang/String;\");\n" name;
7931         pr "      (*env)->SetObjectField (env, jfl, fl, (*env)->NewStringUTF (env, s));\n";
7932         pr "    }\n";
7933     | name, (FBytes|FUInt64|FInt64) ->
7934         pr "    fl = (*env)->GetFieldID (env, cl, \"%s\", \"J\");\n" name;
7935         pr "    (*env)->SetLongField (env, jfl, fl, r->val[i].%s);\n" name;
7936     | name, (FUInt32|FInt32) ->
7937         pr "    fl = (*env)->GetFieldID (env, cl, \"%s\", \"I\");\n" name;
7938         pr "    (*env)->SetLongField (env, jfl, fl, r->val[i].%s);\n" name;
7939     | name, FOptPercent ->
7940         pr "    fl = (*env)->GetFieldID (env, cl, \"%s\", \"F\");\n" name;
7941         pr "    (*env)->SetFloatField (env, jfl, fl, r->val[i].%s);\n" name;
7942     | name, FChar ->
7943         pr "    fl = (*env)->GetFieldID (env, cl, \"%s\", \"C\");\n" name;
7944         pr "    (*env)->SetLongField (env, jfl, fl, r->val[i].%s);\n" name;
7945   ) cols;
7946   pr "    (*env)->SetObjectArrayElement (env, jfl, i, jfl);\n";
7947   pr "  }\n";
7948   pr "  guestfs_free_%s_list (r);\n" typ;
7949   pr "  return jr;\n"
7950
7951 and generate_haskell_hs () =
7952   generate_header HaskellStyle LGPLv2;
7953
7954   (* XXX We only know how to generate partial FFI for Haskell
7955    * at the moment.  Please help out!
7956    *)
7957   let can_generate style =
7958     match style with
7959     | RErr, _
7960     | RInt _, _
7961     | RInt64 _, _ -> true
7962     | RBool _, _
7963     | RConstString _, _
7964     | RString _, _
7965     | RStringList _, _
7966     | RStruct _, _
7967     | RStructList _, _
7968     | RHashtable _, _
7969     | RBufferOut _, _ -> false in
7970
7971   pr "\
7972 {-# INCLUDE <guestfs.h> #-}
7973 {-# LANGUAGE ForeignFunctionInterface #-}
7974
7975 module Guestfs (
7976   create";
7977
7978   (* List out the names of the actions we want to export. *)
7979   List.iter (
7980     fun (name, style, _, _, _, _, _) ->
7981       if can_generate style then pr ",\n  %s" name
7982   ) all_functions;
7983
7984   pr "
7985   ) where
7986 import Foreign
7987 import Foreign.C
7988 import Foreign.C.Types
7989 import IO
7990 import Control.Exception
7991 import Data.Typeable
7992
7993 data GuestfsS = GuestfsS            -- represents the opaque C struct
7994 type GuestfsP = Ptr GuestfsS        -- guestfs_h *
7995 type GuestfsH = ForeignPtr GuestfsS -- guestfs_h * with attached finalizer
7996
7997 -- XXX define properly later XXX
7998 data PV = PV
7999 data VG = VG
8000 data LV = LV
8001 data IntBool = IntBool
8002 data Stat = Stat
8003 data StatVFS = StatVFS
8004 data Hashtable = Hashtable
8005
8006 foreign import ccall unsafe \"guestfs_create\" c_create
8007   :: IO GuestfsP
8008 foreign import ccall unsafe \"&guestfs_close\" c_close
8009   :: FunPtr (GuestfsP -> IO ())
8010 foreign import ccall unsafe \"guestfs_set_error_handler\" c_set_error_handler
8011   :: GuestfsP -> Ptr CInt -> Ptr CInt -> IO ()
8012
8013 create :: IO GuestfsH
8014 create = do
8015   p <- c_create
8016   c_set_error_handler p nullPtr nullPtr
8017   h <- newForeignPtr c_close p
8018   return h
8019
8020 foreign import ccall unsafe \"guestfs_last_error\" c_last_error
8021   :: GuestfsP -> IO CString
8022
8023 -- last_error :: GuestfsH -> IO (Maybe String)
8024 -- last_error h = do
8025 --   str <- withForeignPtr h (\\p -> c_last_error p)
8026 --   maybePeek peekCString str
8027
8028 last_error :: GuestfsH -> IO (String)
8029 last_error h = do
8030   str <- withForeignPtr h (\\p -> c_last_error p)
8031   if (str == nullPtr)
8032     then return \"no error\"
8033     else peekCString str
8034
8035 ";
8036
8037   (* Generate wrappers for each foreign function. *)
8038   List.iter (
8039     fun (name, style, _, _, _, _, _) ->
8040       if can_generate style then (
8041         pr "foreign import ccall unsafe \"guestfs_%s\" c_%s\n" name name;
8042         pr "  :: ";
8043         generate_haskell_prototype ~handle:"GuestfsP" style;
8044         pr "\n";
8045         pr "\n";
8046         pr "%s :: " name;
8047         generate_haskell_prototype ~handle:"GuestfsH" ~hs:true style;
8048         pr "\n";
8049         pr "%s %s = do\n" name
8050           (String.concat " " ("h" :: List.map name_of_argt (snd style)));
8051         pr "  r <- ";
8052         (* Convert pointer arguments using with* functions. *)
8053         List.iter (
8054           function
8055           | FileIn n
8056           | FileOut n
8057           | String n -> pr "withCString %s $ \\%s -> " n n
8058           | OptString n -> pr "maybeWith withCString %s $ \\%s -> " n n
8059           | StringList n -> pr "withMany withCString %s $ \\%s -> withArray0 nullPtr %s $ \\%s -> " n n n n
8060           | Bool _ | Int _ -> ()
8061         ) (snd style);
8062         (* Convert integer arguments. *)
8063         let args =
8064           List.map (
8065             function
8066             | Bool n -> sprintf "(fromBool %s)" n
8067             | Int n -> sprintf "(fromIntegral %s)" n
8068             | FileIn n | FileOut n | String n | OptString n | StringList n -> n
8069           ) (snd style) in
8070         pr "withForeignPtr h (\\p -> c_%s %s)\n" name
8071           (String.concat " " ("p" :: args));
8072         (match fst style with
8073          | RErr | RInt _ | RInt64 _ | RBool _ ->
8074              pr "  if (r == -1)\n";
8075              pr "    then do\n";
8076              pr "      err <- last_error h\n";
8077              pr "      fail err\n";
8078          | RConstString _ | RString _ | RStringList _ | RStruct _
8079          | RStructList _ | RHashtable _ | RBufferOut _ ->
8080              pr "  if (r == nullPtr)\n";
8081              pr "    then do\n";
8082              pr "      err <- last_error h\n";
8083              pr "      fail err\n";
8084         );
8085         (match fst style with
8086          | RErr ->
8087              pr "    else return ()\n"
8088          | RInt _ ->
8089              pr "    else return (fromIntegral r)\n"
8090          | RInt64 _ ->
8091              pr "    else return (fromIntegral r)\n"
8092          | RBool _ ->
8093              pr "    else return (toBool r)\n"
8094          | RConstString _
8095          | RString _
8096          | RStringList _
8097          | RStruct _
8098          | RStructList _
8099          | RHashtable _
8100          | RBufferOut _ ->
8101              pr "    else return ()\n" (* XXXXXXXXXXXXXXXXXXXX *)
8102         );
8103         pr "\n";
8104       )
8105   ) all_functions
8106
8107 and generate_haskell_prototype ~handle ?(hs = false) style =
8108   pr "%s -> " handle;
8109   let string = if hs then "String" else "CString" in
8110   let int = if hs then "Int" else "CInt" in
8111   let bool = if hs then "Bool" else "CInt" in
8112   let int64 = if hs then "Integer" else "Int64" in
8113   List.iter (
8114     fun arg ->
8115       (match arg with
8116        | String _ -> pr "%s" string
8117        | OptString _ -> if hs then pr "Maybe String" else pr "CString"
8118        | StringList _ -> if hs then pr "[String]" else pr "Ptr CString"
8119        | Bool _ -> pr "%s" bool
8120        | Int _ -> pr "%s" int
8121        | FileIn _ -> pr "%s" string
8122        | FileOut _ -> pr "%s" string
8123       );
8124       pr " -> ";
8125   ) (snd style);
8126   pr "IO (";
8127   (match fst style with
8128    | RErr -> if not hs then pr "CInt"
8129    | RInt _ -> pr "%s" int
8130    | RInt64 _ -> pr "%s" int64
8131    | RBool _ -> pr "%s" bool
8132    | RConstString _ -> pr "%s" string
8133    | RString _ -> pr "%s" string
8134    | RStringList _ -> pr "[%s]" string
8135    | RStruct (_, typ) ->
8136        let name = java_name_of_struct typ in
8137        pr "%s" name
8138    | RStructList (_, typ) ->
8139        let name = java_name_of_struct typ in
8140        pr "[%s]" name
8141    | RHashtable _ -> pr "Hashtable"
8142    | RBufferOut _ -> pr "%s" string
8143   );
8144   pr ")"
8145
8146 and generate_bindtests () =
8147   generate_header CStyle LGPLv2;
8148
8149   pr "\
8150 #include <stdio.h>
8151 #include <stdlib.h>
8152 #include <inttypes.h>
8153 #include <string.h>
8154
8155 #include \"guestfs.h\"
8156 #include \"guestfs_protocol.h\"
8157
8158 #define error guestfs_error
8159 #define safe_calloc guestfs_safe_calloc
8160 #define safe_malloc guestfs_safe_malloc
8161
8162 static void
8163 print_strings (char * const* const argv)
8164 {
8165   int argc;
8166
8167   printf (\"[\");
8168   for (argc = 0; argv[argc] != NULL; ++argc) {
8169     if (argc > 0) printf (\", \");
8170     printf (\"\\\"%%s\\\"\", argv[argc]);
8171   }
8172   printf (\"]\\n\");
8173 }
8174
8175 /* The test0 function prints its parameters to stdout. */
8176 ";
8177
8178   let test0, tests =
8179     match test_functions with
8180     | [] -> assert false
8181     | test0 :: tests -> test0, tests in
8182
8183   let () =
8184     let (name, style, _, _, _, _, _) = test0 in
8185     generate_prototype ~extern:false ~semicolon:false ~newline:true
8186       ~handle:"g" ~prefix:"guestfs_" name style;
8187     pr "{\n";
8188     List.iter (
8189       function
8190       | String n
8191       | FileIn n
8192       | FileOut n -> pr "  printf (\"%%s\\n\", %s);\n" n
8193       | OptString n -> pr "  printf (\"%%s\\n\", %s ? %s : \"null\");\n" n n
8194       | StringList n -> pr "  print_strings (%s);\n" n
8195       | Bool n -> pr "  printf (\"%%s\\n\", %s ? \"true\" : \"false\");\n" n
8196       | Int n -> pr "  printf (\"%%d\\n\", %s);\n" n
8197     ) (snd style);
8198     pr "  /* Java changes stdout line buffering so we need this: */\n";
8199     pr "  fflush (stdout);\n";
8200     pr "  return 0;\n";
8201     pr "}\n";
8202     pr "\n" in
8203
8204   List.iter (
8205     fun (name, style, _, _, _, _, _) ->
8206       if String.sub name (String.length name - 3) 3 <> "err" then (
8207         pr "/* Test normal return. */\n";
8208         generate_prototype ~extern:false ~semicolon:false ~newline:true
8209           ~handle:"g" ~prefix:"guestfs_" name style;
8210         pr "{\n";
8211         (match fst style with
8212          | RErr ->
8213              pr "  return 0;\n"
8214          | RInt _ ->
8215              pr "  int r;\n";
8216              pr "  sscanf (val, \"%%d\", &r);\n";
8217              pr "  return r;\n"
8218          | RInt64 _ ->
8219              pr "  int64_t r;\n";
8220              pr "  sscanf (val, \"%%\" SCNi64, &r);\n";
8221              pr "  return r;\n"
8222          | RBool _ ->
8223              pr "  return strcmp (val, \"true\") == 0;\n"
8224          | RConstString _ ->
8225              (* Can't return the input string here.  Return a static
8226               * string so we ensure we get a segfault if the caller
8227               * tries to free it.
8228               *)
8229              pr "  return \"static string\";\n"
8230          | RString _ ->
8231              pr "  return strdup (val);\n"
8232          | RStringList _ ->
8233              pr "  char **strs;\n";
8234              pr "  int n, i;\n";
8235              pr "  sscanf (val, \"%%d\", &n);\n";
8236              pr "  strs = safe_malloc (g, (n+1) * sizeof (char *));\n";
8237              pr "  for (i = 0; i < n; ++i) {\n";
8238              pr "    strs[i] = safe_malloc (g, 16);\n";
8239              pr "    snprintf (strs[i], 16, \"%%d\", i);\n";
8240              pr "  }\n";
8241              pr "  strs[n] = NULL;\n";
8242              pr "  return strs;\n"
8243          | RStruct (_, typ) ->
8244              pr "  struct guestfs_%s *r;\n" typ;
8245              pr "  r = safe_calloc (g, sizeof *r, 1);\n";
8246              pr "  return r;\n"
8247          | RStructList (_, typ) ->
8248              pr "  struct guestfs_%s_list *r;\n" typ;
8249              pr "  r = safe_calloc (g, sizeof *r, 1);\n";
8250              pr "  sscanf (val, \"%%d\", &r->len);\n";
8251              pr "  r->val = safe_calloc (g, r->len, sizeof *r->val);\n";
8252              pr "  return r;\n"
8253          | RHashtable _ ->
8254              pr "  char **strs;\n";
8255              pr "  int n, i;\n";
8256              pr "  sscanf (val, \"%%d\", &n);\n";
8257              pr "  strs = safe_malloc (g, (n*2+1) * sizeof (*strs));\n";
8258              pr "  for (i = 0; i < n; ++i) {\n";
8259              pr "    strs[i*2] = safe_malloc (g, 16);\n";
8260              pr "    strs[i*2+1] = safe_malloc (g, 16);\n";
8261              pr "    snprintf (strs[i*2], 16, \"%%d\", i);\n";
8262              pr "    snprintf (strs[i*2+1], 16, \"%%d\", i);\n";
8263              pr "  }\n";
8264              pr "  strs[n*2] = NULL;\n";
8265              pr "  return strs;\n"
8266          | RBufferOut _ ->
8267              pr "  return strdup (val);\n"
8268         );
8269         pr "}\n";
8270         pr "\n"
8271       ) else (
8272         pr "/* Test error return. */\n";
8273         generate_prototype ~extern:false ~semicolon:false ~newline:true
8274           ~handle:"g" ~prefix:"guestfs_" name style;
8275         pr "{\n";
8276         pr "  error (g, \"error\");\n";
8277         (match fst style with
8278          | RErr | RInt _ | RInt64 _ | RBool _ ->
8279              pr "  return -1;\n"
8280          | RConstString _
8281          | RString _ | RStringList _ | RStruct _
8282          | RStructList _
8283          | RHashtable _
8284          | RBufferOut _ ->
8285              pr "  return NULL;\n"
8286         );
8287         pr "}\n";
8288         pr "\n"
8289       )
8290   ) tests
8291
8292 and generate_ocaml_bindtests () =
8293   generate_header OCamlStyle GPLv2;
8294
8295   pr "\
8296 let () =
8297   let g = Guestfs.create () in
8298 ";
8299
8300   let mkargs args =
8301     String.concat " " (
8302       List.map (
8303         function
8304         | CallString s -> "\"" ^ s ^ "\""
8305         | CallOptString None -> "None"
8306         | CallOptString (Some s) -> sprintf "(Some \"%s\")" s
8307         | CallStringList xs ->
8308             "[|" ^ String.concat ";" (List.map (sprintf "\"%s\"") xs) ^ "|]"
8309         | CallInt i when i >= 0 -> string_of_int i
8310         | CallInt i (* when i < 0 *) -> "(" ^ string_of_int i ^ ")"
8311         | CallBool b -> string_of_bool b
8312       ) args
8313     )
8314   in
8315
8316   generate_lang_bindtests (
8317     fun f args -> pr "  Guestfs.%s g %s;\n" f (mkargs args)
8318   );
8319
8320   pr "print_endline \"EOF\"\n"
8321
8322 and generate_perl_bindtests () =
8323   pr "#!/usr/bin/perl -w\n";
8324   generate_header HashStyle GPLv2;
8325
8326   pr "\
8327 use strict;
8328
8329 use Sys::Guestfs;
8330
8331 my $g = Sys::Guestfs->new ();
8332 ";
8333
8334   let mkargs args =
8335     String.concat ", " (
8336       List.map (
8337         function
8338         | CallString s -> "\"" ^ s ^ "\""
8339         | CallOptString None -> "undef"
8340         | CallOptString (Some s) -> sprintf "\"%s\"" s
8341         | CallStringList xs ->
8342             "[" ^ String.concat "," (List.map (sprintf "\"%s\"") xs) ^ "]"
8343         | CallInt i -> string_of_int i
8344         | CallBool b -> if b then "1" else "0"
8345       ) args
8346     )
8347   in
8348
8349   generate_lang_bindtests (
8350     fun f args -> pr "$g->%s (%s);\n" f (mkargs args)
8351   );
8352
8353   pr "print \"EOF\\n\"\n"
8354
8355 and generate_python_bindtests () =
8356   generate_header HashStyle GPLv2;
8357
8358   pr "\
8359 import guestfs
8360
8361 g = guestfs.GuestFS ()
8362 ";
8363
8364   let mkargs args =
8365     String.concat ", " (
8366       List.map (
8367         function
8368         | CallString s -> "\"" ^ s ^ "\""
8369         | CallOptString None -> "None"
8370         | CallOptString (Some s) -> sprintf "\"%s\"" s
8371         | CallStringList xs ->
8372             "[" ^ String.concat "," (List.map (sprintf "\"%s\"") xs) ^ "]"
8373         | CallInt i -> string_of_int i
8374         | CallBool b -> if b then "1" else "0"
8375       ) args
8376     )
8377   in
8378
8379   generate_lang_bindtests (
8380     fun f args -> pr "g.%s (%s)\n" f (mkargs args)
8381   );
8382
8383   pr "print \"EOF\"\n"
8384
8385 and generate_ruby_bindtests () =
8386   generate_header HashStyle GPLv2;
8387
8388   pr "\
8389 require 'guestfs'
8390
8391 g = Guestfs::create()
8392 ";
8393
8394   let mkargs args =
8395     String.concat ", " (
8396       List.map (
8397         function
8398         | CallString s -> "\"" ^ s ^ "\""
8399         | CallOptString None -> "nil"
8400         | CallOptString (Some s) -> sprintf "\"%s\"" s
8401         | CallStringList xs ->
8402             "[" ^ String.concat "," (List.map (sprintf "\"%s\"") xs) ^ "]"
8403         | CallInt i -> string_of_int i
8404         | CallBool b -> string_of_bool b
8405       ) args
8406     )
8407   in
8408
8409   generate_lang_bindtests (
8410     fun f args -> pr "g.%s(%s)\n" f (mkargs args)
8411   );
8412
8413   pr "print \"EOF\\n\"\n"
8414
8415 and generate_java_bindtests () =
8416   generate_header CStyle GPLv2;
8417
8418   pr "\
8419 import com.redhat.et.libguestfs.*;
8420
8421 public class Bindtests {
8422     public static void main (String[] argv)
8423     {
8424         try {
8425             GuestFS g = new GuestFS ();
8426 ";
8427
8428   let mkargs args =
8429     String.concat ", " (
8430       List.map (
8431         function
8432         | CallString s -> "\"" ^ s ^ "\""
8433         | CallOptString None -> "null"
8434         | CallOptString (Some s) -> sprintf "\"%s\"" s
8435         | CallStringList xs ->
8436             "new String[]{" ^
8437               String.concat "," (List.map (sprintf "\"%s\"") xs) ^ "}"
8438         | CallInt i -> string_of_int i
8439         | CallBool b -> string_of_bool b
8440       ) args
8441     )
8442   in
8443
8444   generate_lang_bindtests (
8445     fun f args -> pr "            g.%s (%s);\n" f (mkargs args)
8446   );
8447
8448   pr "
8449             System.out.println (\"EOF\");
8450         }
8451         catch (Exception exn) {
8452             System.err.println (exn);
8453             System.exit (1);
8454         }
8455     }
8456 }
8457 "
8458
8459 and generate_haskell_bindtests () =
8460   generate_header HaskellStyle GPLv2;
8461
8462   pr "\
8463 module Bindtests where
8464 import qualified Guestfs
8465
8466 main = do
8467   g <- Guestfs.create
8468 ";
8469
8470   let mkargs args =
8471     String.concat " " (
8472       List.map (
8473         function
8474         | CallString s -> "\"" ^ s ^ "\""
8475         | CallOptString None -> "Nothing"
8476         | CallOptString (Some s) -> sprintf "(Just \"%s\")" s
8477         | CallStringList xs ->
8478             "[" ^ String.concat "," (List.map (sprintf "\"%s\"") xs) ^ "]"
8479         | CallInt i when i < 0 -> "(" ^ string_of_int i ^ ")"
8480         | CallInt i -> string_of_int i
8481         | CallBool true -> "True"
8482         | CallBool false -> "False"
8483       ) args
8484     )
8485   in
8486
8487   generate_lang_bindtests (
8488     fun f args -> pr "  Guestfs.%s g %s\n" f (mkargs args)
8489   );
8490
8491   pr "  putStrLn \"EOF\"\n"
8492
8493 (* Language-independent bindings tests - we do it this way to
8494  * ensure there is parity in testing bindings across all languages.
8495  *)
8496 and generate_lang_bindtests call =
8497   call "test0" [CallString "abc"; CallOptString (Some "def");
8498                 CallStringList []; CallBool false;
8499                 CallInt 0; CallString "123"; CallString "456"];
8500   call "test0" [CallString "abc"; CallOptString None;
8501                 CallStringList []; CallBool false;
8502                 CallInt 0; CallString "123"; CallString "456"];
8503   call "test0" [CallString ""; CallOptString (Some "def");
8504                 CallStringList []; CallBool false;
8505                 CallInt 0; CallString "123"; CallString "456"];
8506   call "test0" [CallString ""; CallOptString (Some "");
8507                 CallStringList []; CallBool false;
8508                 CallInt 0; CallString "123"; CallString "456"];
8509   call "test0" [CallString "abc"; CallOptString (Some "def");
8510                 CallStringList ["1"]; CallBool false;
8511                 CallInt 0; CallString "123"; CallString "456"];
8512   call "test0" [CallString "abc"; CallOptString (Some "def");
8513                 CallStringList ["1"; "2"]; CallBool false;
8514                 CallInt 0; CallString "123"; CallString "456"];
8515   call "test0" [CallString "abc"; CallOptString (Some "def");
8516                 CallStringList ["1"]; CallBool true;
8517                 CallInt 0; CallString "123"; CallString "456"];
8518   call "test0" [CallString "abc"; CallOptString (Some "def");
8519                 CallStringList ["1"]; CallBool false;
8520                 CallInt (-1); CallString "123"; CallString "456"];
8521   call "test0" [CallString "abc"; CallOptString (Some "def");
8522                 CallStringList ["1"]; CallBool false;
8523                 CallInt (-2); CallString "123"; CallString "456"];
8524   call "test0" [CallString "abc"; CallOptString (Some "def");
8525                 CallStringList ["1"]; CallBool false;
8526                 CallInt 1; CallString "123"; CallString "456"];
8527   call "test0" [CallString "abc"; CallOptString (Some "def");
8528                 CallStringList ["1"]; CallBool false;
8529                 CallInt 2; CallString "123"; CallString "456"];
8530   call "test0" [CallString "abc"; CallOptString (Some "def");
8531                 CallStringList ["1"]; CallBool false;
8532                 CallInt 4095; CallString "123"; CallString "456"];
8533   call "test0" [CallString "abc"; CallOptString (Some "def");
8534                 CallStringList ["1"]; CallBool false;
8535                 CallInt 0; CallString ""; CallString ""]
8536
8537 (* XXX Add here tests of the return and error functions. *)
8538
8539 (* This is used to generate the src/MAX_PROC_NR file which
8540  * contains the maximum procedure number, a surrogate for the
8541  * ABI version number.  See src/Makefile.am for the details.
8542  *)
8543 and generate_max_proc_nr () =
8544   let proc_nrs = List.map (
8545     fun (_, _, proc_nr, _, _, _, _) -> proc_nr
8546   ) daemon_functions in
8547
8548   let max_proc_nr = List.fold_left max 0 proc_nrs in
8549
8550   pr "%d\n" max_proc_nr
8551
8552 let output_to filename =
8553   let filename_new = filename ^ ".new" in
8554   chan := open_out filename_new;
8555   let close () =
8556     close_out !chan;
8557     chan := stdout;
8558
8559     (* Is the new file different from the current file? *)
8560     if Sys.file_exists filename && files_equal filename filename_new then
8561       Unix.unlink filename_new          (* same, so skip it *)
8562     else (
8563       (* different, overwrite old one *)
8564       (try Unix.chmod filename 0o644 with Unix.Unix_error _ -> ());
8565       Unix.rename filename_new filename;
8566       Unix.chmod filename 0o444;
8567       printf "written %s\n%!" filename;
8568     )
8569   in
8570   close
8571
8572 (* Main program. *)
8573 let () =
8574   check_functions ();
8575
8576   if not (Sys.file_exists "HACKING") then (
8577     eprintf "\
8578 You are probably running this from the wrong directory.
8579 Run it from the top source directory using the command
8580   src/generator.ml
8581 ";
8582     exit 1
8583   );
8584
8585   let close = output_to "src/guestfs_protocol.x" in
8586   generate_xdr ();
8587   close ();
8588
8589   let close = output_to "src/guestfs-structs.h" in
8590   generate_structs_h ();
8591   close ();
8592
8593   let close = output_to "src/guestfs-actions.h" in
8594   generate_actions_h ();
8595   close ();
8596
8597   let close = output_to "src/guestfs-actions.c" in
8598   generate_client_actions ();
8599   close ();
8600
8601   let close = output_to "daemon/actions.h" in
8602   generate_daemon_actions_h ();
8603   close ();
8604
8605   let close = output_to "daemon/stubs.c" in
8606   generate_daemon_actions ();
8607   close ();
8608
8609   let close = output_to "daemon/names.c" in
8610   generate_daemon_names ();
8611   close ();
8612
8613   let close = output_to "capitests/tests.c" in
8614   generate_tests ();
8615   close ();
8616
8617   let close = output_to "src/guestfs-bindtests.c" in
8618   generate_bindtests ();
8619   close ();
8620
8621   let close = output_to "fish/cmds.c" in
8622   generate_fish_cmds ();
8623   close ();
8624
8625   let close = output_to "fish/completion.c" in
8626   generate_fish_completion ();
8627   close ();
8628
8629   let close = output_to "guestfs-structs.pod" in
8630   generate_structs_pod ();
8631   close ();
8632
8633   let close = output_to "guestfs-actions.pod" in
8634   generate_actions_pod ();
8635   close ();
8636
8637   let close = output_to "guestfish-actions.pod" in
8638   generate_fish_actions_pod ();
8639   close ();
8640
8641   let close = output_to "ocaml/guestfs.mli" in
8642   generate_ocaml_mli ();
8643   close ();
8644
8645   let close = output_to "ocaml/guestfs.ml" in
8646   generate_ocaml_ml ();
8647   close ();
8648
8649   let close = output_to "ocaml/guestfs_c_actions.c" in
8650   generate_ocaml_c ();
8651   close ();
8652
8653   let close = output_to "ocaml/bindtests.ml" in
8654   generate_ocaml_bindtests ();
8655   close ();
8656
8657   let close = output_to "perl/Guestfs.xs" in
8658   generate_perl_xs ();
8659   close ();
8660
8661   let close = output_to "perl/lib/Sys/Guestfs.pm" in
8662   generate_perl_pm ();
8663   close ();
8664
8665   let close = output_to "perl/bindtests.pl" in
8666   generate_perl_bindtests ();
8667   close ();
8668
8669   let close = output_to "python/guestfs-py.c" in
8670   generate_python_c ();
8671   close ();
8672
8673   let close = output_to "python/guestfs.py" in
8674   generate_python_py ();
8675   close ();
8676
8677   let close = output_to "python/bindtests.py" in
8678   generate_python_bindtests ();
8679   close ();
8680
8681   let close = output_to "ruby/ext/guestfs/_guestfs.c" in
8682   generate_ruby_c ();
8683   close ();
8684
8685   let close = output_to "ruby/bindtests.rb" in
8686   generate_ruby_bindtests ();
8687   close ();
8688
8689   let close = output_to "java/com/redhat/et/libguestfs/GuestFS.java" in
8690   generate_java_java ();
8691   close ();
8692
8693   List.iter (
8694     fun (typ, jtyp) ->
8695       let cols = cols_of_struct typ in
8696       let filename = sprintf "java/com/redhat/et/libguestfs/%s.java" jtyp in
8697       let close = output_to filename in
8698       generate_java_struct jtyp cols;
8699       close ();
8700   ) java_structs;
8701
8702   let close = output_to "java/Makefile.inc" in
8703   pr "java_built_sources =";
8704   List.iter (
8705     fun (typ, jtyp) ->
8706         pr " com/redhat/et/libguestfs/%s.java" jtyp;
8707   ) java_structs;
8708   pr " com/redhat/et/libguestfs/GuestFS.java\n";
8709   close ();
8710
8711   let close = output_to "java/com_redhat_et_libguestfs_GuestFS.c" in
8712   generate_java_c ();
8713   close ();
8714
8715   let close = output_to "java/Bindtests.java" in
8716   generate_java_bindtests ();
8717   close ();
8718
8719   let close = output_to "haskell/Guestfs.hs" in
8720   generate_haskell_hs ();
8721   close ();
8722
8723   let close = output_to "haskell/Bindtests.hs" in
8724   generate_haskell_bindtests ();
8725   close ();
8726
8727   let close = output_to "src/MAX_PROC_NR" in
8728   generate_max_proc_nr ();
8729   close ();
8730
8731   (* Always generate this file last, and unconditionally.  It's used
8732    * by the Makefile to know when we must re-run the generator.
8733    *)
8734   let chan = open_out "src/stamp-generator" in
8735   fprintf chan "1\n";
8736   close_out chan