X-Git-Url: http://git.annexia.org/?p=libguestfs.git;a=blobdiff_plain;f=src%2Fgenerator.ml;h=743118be17733a1836f27dfb699dc9ae4e172c4e;hp=ff772f525e2ed1109dd7b331d6d7747c5888bccc;hb=867319ec5f9030d3c14c32e3302606f2bf11ac27;hpb=da4812ab6b44c29cb3cf181c7aa896420ecb8aa6 diff --git a/src/generator.ml b/src/generator.ml index ff772f5..743118b 100755 --- a/src/generator.ml +++ b/src/generator.ml @@ -174,6 +174,14 @@ and argt = * To return an arbitrary buffer, use RBufferOut. *) | BufferIn of string + (* Key material / passphrase. Eventually we should treat this + * as sensitive and mlock it into physical RAM. However this + * is highly complex because of all the places that XDR-encoded + * strings can end up. So currently the only difference from + * 'String' is the way that guestfish requests these parameters + * from the user. + *) + | Key of string type flags = | ProtocolLimitWarning (* display warning about protocol size limits *) @@ -184,6 +192,7 @@ type flags = | NotInDocs (* do not add this function to documentation *) | DeprecatedBy of string (* function is deprecated, use .. instead *) | Optional of string (* function is part of an optional group *) + | Progress (* function can generate progress messages *) and fish_output_t = | FishOutputOctal (* for int return, print in octal *) @@ -309,6 +318,9 @@ and test_prereq = (* As for 'If' but the test runs _unless_ the code returns true. *) | Unless of string + (* Run the test only if 'string' is available in the daemon. *) + | IfAvailable of string + (* Some initial scenarios for testing. *) and test_init = (* Do nothing, block devices could contain random stuff including @@ -548,15 +560,13 @@ handle is closed. We don't currently have any method to enable changes to be committed, although qemu can support this. This is equivalent to the qemu parameter -C<-drive file=filename,snapshot=on,readonly=on,if=...>. +C<-drive file=filename,snapshot=on,if=...>. C is set at compile time by the configuration option C<./configure --with-drive-if=...>. In the rare case where you might need to change this at run time, use C or C. -C is only added where qemu supports this option. - Note that this call checks for the existence of C. This stops you from specifying other types of drive which are supported by qemu such as C and C URLs. To specify those, use @@ -847,7 +857,7 @@ see L."); "enable or disable command traces", "\ If the command trace flag is set to 1, then commands are -printed on stdout before they are executed in a format +printed on stderr before they are executed in a format which is very similar to the one used by guestfish. In other words, you can run a program with this enabled, and you will get out a script which you can feed to guestfish @@ -931,6 +941,374 @@ to specify the QEMU interface emulation to use at run time."); This is the same as C but it allows you to specify the QEMU interface emulation to use at run time."); + ("file_architecture", (RString "arch", [Pathname "filename"]), -1, [], + [InitISOFS, Always, TestOutput ( + [["file_architecture"; "/bin-i586-dynamic"]], "i386"); + InitISOFS, Always, TestOutput ( + [["file_architecture"; "/bin-sparc-dynamic"]], "sparc"); + InitISOFS, Always, TestOutput ( + [["file_architecture"; "/bin-win32.exe"]], "i386"); + InitISOFS, Always, TestOutput ( + [["file_architecture"; "/bin-win64.exe"]], "x86_64"); + InitISOFS, Always, TestOutput ( + [["file_architecture"; "/bin-x86_64-dynamic"]], "x86_64"); + InitISOFS, Always, TestOutput ( + [["file_architecture"; "/lib-i586.so"]], "i386"); + InitISOFS, Always, TestOutput ( + [["file_architecture"; "/lib-sparc.so"]], "sparc"); + InitISOFS, Always, TestOutput ( + [["file_architecture"; "/lib-win32.dll"]], "i386"); + InitISOFS, Always, TestOutput ( + [["file_architecture"; "/lib-win64.dll"]], "x86_64"); + InitISOFS, Always, TestOutput ( + [["file_architecture"; "/lib-x86_64.so"]], "x86_64"); + InitISOFS, Always, TestOutput ( + [["file_architecture"; "/initrd-x86_64.img"]], "x86_64"); + InitISOFS, Always, TestOutput ( + [["file_architecture"; "/initrd-x86_64.img.gz"]], "x86_64");], + "detect the architecture of a binary file", + "\ +This detects the architecture of the binary C, +and returns it if known. + +Currently defined architectures are: + +=over 4 + +=item \"i386\" + +This string is returned for all 32 bit i386, i486, i586, i686 binaries +irrespective of the precise processor requirements of the binary. + +=item \"x86_64\" + +64 bit x86-64. + +=item \"sparc\" + +32 bit SPARC. + +=item \"sparc64\" + +64 bit SPARC V9 and above. + +=item \"ia64\" + +Intel Itanium. + +=item \"ppc\" + +32 bit Power PC. + +=item \"ppc64\" + +64 bit Power PC. + +=back + +Libguestfs may return other architecture strings in future. + +The function works on at least the following types of files: + +=over 4 + +=item * + +many types of Un*x and Linux binary + +=item * + +many types of Un*x and Linux shared library + +=item * + +Windows Win32 and Win64 binaries + +=item * + +Windows Win32 and Win64 DLLs + +Win32 binaries and DLLs return C. + +Win64 binaries and DLLs return C. + +=item * + +Linux kernel modules + +=item * + +Linux new-style initrd images + +=item * + +some non-x86 Linux vmlinuz kernels + +=back + +What it can't do currently: + +=over 4 + +=item * + +static libraries (libfoo.a) + +=item * + +Linux old-style initrd as compressed ext2 filesystem (RHEL 3) + +=item * + +x86 Linux vmlinuz kernels + +x86 vmlinuz images (bzImage format) consist of a mix of 16-, 32- and +compressed code, and are horribly hard to unpack. If you want to find +the architecture of a kernel, use the architecture of the associated +initrd or kernel module(s) instead. + +=back"); + + ("inspect_os", (RStringList "roots", []), -1, [], + [], + "inspect disk and return list of operating systems found", + "\ +This function uses other libguestfs functions and certain +heuristics to inspect the disk(s) (usually disks belonging to +a virtual machine), looking for operating systems. + +The list returned is empty if no operating systems were found. + +If one operating system was found, then this returns a list with +a single element, which is the name of the root filesystem of +this operating system. It is also possible for this function +to return a list containing more than one element, indicating +a dual-boot or multi-boot virtual machine, with each element being +the root filesystem of one of the operating systems. + +You can pass the root string(s) returned to other +C functions in order to query further +information about each operating system, such as the name +and version. + +This function uses other libguestfs features such as +C and C in order to mount +and unmount filesystems and look at the contents. This should +be called with no disks currently mounted. The function may also +use Augeas, so any existing Augeas handle will be closed. + +This function cannot decrypt encrypted disks. The caller +must do that first (supplying the necessary keys) if the +disk is encrypted. + +Please read L for more details."); + + ("inspect_get_type", (RString "name", [Device "root"]), -1, [], + [], + "get type of inspected operating system", + "\ +This function should only be called with a root device string +as returned by C. + +This returns the type of the inspected operating system. +Currently defined types are: + +=over 4 + +=item \"linux\" + +Any Linux-based operating system. + +=item \"windows\" + +Any Microsoft Windows operating system. + +=item \"unknown\" + +The operating system type could not be determined. + +=back + +Future versions of libguestfs may return other strings here. +The caller should be prepared to handle any string. + +Please read L for more details."); + + ("inspect_get_arch", (RString "arch", [Device "root"]), -1, [], + [], + "get architecture of inspected operating system", + "\ +This function should only be called with a root device string +as returned by C. + +This returns the architecture of the inspected operating system. +The possible return values are listed under +C. + +If the architecture could not be determined, then the +string C is returned. + +Please read L for more details."); + + ("inspect_get_distro", (RString "distro", [Device "root"]), -1, [], + [], + "get distro of inspected operating system", + "\ +This function should only be called with a root device string +as returned by C. + +This returns the distro (distribution) of the inspected operating +system. + +Currently defined distros are: + +=over 4 + +=item \"debian\" + +Debian or a Debian-derived distro such as Ubuntu. + +=item \"fedora\" + +Fedora. + +=item \"redhat-based\" + +Some Red Hat-derived distro. + +=item \"rhel\" + +Red Hat Enterprise Linux and some derivatives. + +=item \"windows\" + +Windows does not have distributions. This string is +returned if the OS type is Windows. + +=item \"unknown\" + +The distro could not be determined. + +=back + +Future versions of libguestfs may return other strings here. +The caller should be prepared to handle any string. + +Please read L for more details."); + + ("inspect_get_major_version", (RInt "major", [Device "root"]), -1, [], + [], + "get major version of inspected operating system", + "\ +This function should only be called with a root device string +as returned by C. + +This returns the major version number of the inspected operating +system. + +Windows uses a consistent versioning scheme which is I +reflected in the popular public names used by the operating system. +Notably the operating system known as \"Windows 7\" is really +version 6.1 (ie. major = 6, minor = 1). You can find out the +real versions corresponding to releases of Windows by consulting +Wikipedia or MSDN. + +If the version could not be determined, then C<0> is returned. + +Please read L for more details."); + + ("inspect_get_minor_version", (RInt "minor", [Device "root"]), -1, [], + [], + "get minor version of inspected operating system", + "\ +This function should only be called with a root device string +as returned by C. + +This returns the minor version number of the inspected operating +system. + +If the version could not be determined, then C<0> is returned. + +Please read L for more details. +See also C."); + + ("inspect_get_product_name", (RString "product", [Device "root"]), -1, [], + [], + "get product name of inspected operating system", + "\ +This function should only be called with a root device string +as returned by C. + +This returns the product name of the inspected operating +system. The product name is generally some freeform string +which can be displayed to the user, but should not be +parsed by programs. + +If the product name could not be determined, then the +string C is returned. + +Please read L for more details."); + + ("inspect_get_mountpoints", (RHashtable "mountpoints", [Device "root"]), -1, [], + [], + "get mountpoints of inspected operating system", + "\ +This function should only be called with a root device string +as returned by C. + +This returns a hash of where we think the filesystems +associated with this operating system should be mounted. +Callers should note that this is at best an educated guess +made by reading configuration files such as C. + +Each element in the returned hashtable has a key which +is the path of the mountpoint (eg. C) and a value +which is the filesystem that would be mounted there +(eg. C). + +Non-mounted devices such as swap devices are I +returned in this list. + +Please read L for more details. +See also C."); + + ("inspect_get_filesystems", (RStringList "filesystems", [Device "root"]), -1, [], + [], + "get filesystems associated with inspected operating system", + "\ +This function should only be called with a root device string +as returned by C. + +This returns a list of all the filesystems that we think +are associated with this operating system. This includes +the root filesystem, other ordinary filesystems, and +non-mounted devices like swap partitions. + +In the case of a multi-boot virtual machine, it is possible +for a filesystem to be shared between operating systems. + +Please read L for more details. +See also C."); + + ("set_network", (RErr, [Bool "network"]), -1, [FishAlias "network"], + [], + "set enable network flag", + "\ +If C is true, then the network is enabled in the +libguestfs appliance. The default is false. + +This affects whether commands are able to access the network +(see L). + +You must call this before calling C, otherwise +it has no effect."); + + ("get_network", (RBool "network", []), -1, [], + [], + "get enable network flag", + "\ +This returns the enable network flag."); + ] (* daemon_functions are any functions which cause some action @@ -989,7 +1367,10 @@ closing the handle."); "\ Touch acts like the L command. It can be used to update the timestamps on a file, or, if the file does not exist, -to create a new zero-length file."); +to create a new zero-length file. + +This command only works on regular files, and will fail on other +file types such as directories, symbolic links, block special etc."); ("cat", (RString "content", [Pathname "path"]), 4, [ProtocolLimitWarning], [InitISOFS, Always, TestOutput ( @@ -1543,7 +1924,9 @@ See also: C, C, C"); ("write_file", (RErr, [Pathname "path"; String "content"; Int "size"]), 44, [ProtocolLimitWarning; DeprecatedBy "write"], - [], + (* Regression test for RHBZ#597135. *) + [InitBasicFS, Always, TestLastFail + [["write_file"; "/new"; "abc"; "10000"]]], "create a file", "\ This call creates a file called C. The contents of the @@ -1624,19 +2007,32 @@ and physical volumes."); InitISOFS, Always, TestOutput ( [["file"; "/known-1"]], "ASCII text"); InitISOFS, Always, TestLastFail ( - [["file"; "/notexists"]])], + [["file"; "/notexists"]]); + InitISOFS, Always, TestOutput ( + [["file"; "/abssymlink"]], "symbolic link"); + InitISOFS, Always, TestOutput ( + [["file"; "/directory"]], "directory")], "determine file type", "\ This call uses the standard L command to determine -the type or contents of the file. This also works on devices, -for example to find out whether a partition contains a filesystem. +the type or contents of the file. This call will also transparently look inside various types of compressed file. -The exact command which runs is C. Note in +The exact command which runs is C. Note in particular that the filename is not prepended to the output -(the C<-b> option)."); +(the C<-b> option). + +This command can also be used on C devices +(and partitions, LV names). You can for example use this +to determine if a device contains a filesystem, although +it's usually better to use C. + +If the C does not begin with C then +this command only works for the content of regular files. +For other file types (directory, symbolic link etc) it +will just return the string C etc."); ("command", (RString "output", [StringList "arguments"]), 50, [ProtocolLimitWarning], [InitBasicFS, Always, TestOutput ( @@ -1942,7 +2338,7 @@ C can also be a named pipe. See also C."); - ("download", (RErr, [Dev_or_Path "remotefilename"; FileOut "filename"]), 67, [], + ("download", (RErr, [Dev_or_Path "remotefilename"; FileOut "filename"]), 67, [Progress], [InitBasicFS, Always, TestOutput ( (* Pick a file from cwd which isn't likely to change. *) [["upload"; "../COPYING.LIB"; "/COPYING.LIB"]; @@ -2302,7 +2698,7 @@ Checking or repairing NTFS volumes is not supported This command is entirely equivalent to running C."); - ("zero", (RErr, [Device "device"]), 85, [], + ("zero", (RErr, [Device "device"]), 85, [Progress], [InitBasicFS, Always, TestOutput ( [["umount"; "/dev/sda1"]; ["zero"; "/dev/sda1"]; @@ -2318,16 +2714,30 @@ any partition tables, filesystem superblocks and so on. See also: C, C."); ("grub_install", (RErr, [Pathname "root"; Device "device"]), 86, [], - (* Test disabled because grub-install incompatible with virtio-blk driver. - * See also: https://bugzilla.redhat.com/show_bug.cgi?id=479760 + (* See: + * https://bugzilla.redhat.com/show_bug.cgi?id=484986 + * https://bugzilla.redhat.com/show_bug.cgi?id=479760 *) - [InitBasicFS, Disabled, TestOutputTrue ( - [["grub_install"; "/"; "/dev/sda1"]; + [InitBasicFS, Always, TestOutputTrue ( + [["mkdir_p"; "/boot/grub"]; + ["write"; "/boot/grub/device.map"; "(hd0) /dev/vda"]; + ["grub_install"; "/"; "/dev/vda"]; ["is_dir"; "/boot"]])], "install GRUB", "\ This command installs GRUB (the Grand Unified Bootloader) on -C, with the root directory being C."); +C, with the root directory being C. + +Note: If grub-install reports the error +\"No suitable drive was found in the generated device map.\" +it may be that you need to create a C +file first that contains the mapping between grub device names +and Linux device names. It is usually sufficient to create +a file containing: + + (hd0) /dev/vda + +replacing C with the name of the installation device."); ("cp", (RErr, [Pathname "src"; Pathname "dest"]), 87, [], [InitBasicFS, Always, TestOutput ( @@ -2639,9 +3049,9 @@ is lost."); ("resize2fs", (RErr, [Device "device"]), 106, [], [], (* lvresize tests this *) - "resize an ext2/ext3 filesystem", + "resize an ext2, ext3 or ext4 filesystem", "\ -This resizes an ext2 or ext3 filesystem to match the size of +This resizes an ext2, ext3 or ext4 filesystem to match the size of the underlying device. I It is sometimes required that you run C @@ -3713,13 +4123,28 @@ and C"); ["mkfs_b"; "ext2"; "4096"; "/dev/sda1"]; ["mount_options"; ""; "/dev/sda1"; "/"]; ["write"; "/new"; "new file contents"]; - ["cat"; "/new"]], "new file contents")], + ["cat"; "/new"]], "new file contents"); + InitEmpty, Always, TestRun ( + [["part_disk"; "/dev/sda"; "mbr"]; + ["mkfs_b"; "vfat"; "32768"; "/dev/sda1"]]); + InitEmpty, Always, TestLastFail ( + [["part_disk"; "/dev/sda"; "mbr"]; + ["mkfs_b"; "vfat"; "32769"; "/dev/sda1"]]); + InitEmpty, Always, TestLastFail ( + [["part_disk"; "/dev/sda"; "mbr"]; + ["mkfs_b"; "vfat"; "33280"; "/dev/sda1"]]); + InitEmpty, IfAvailable "ntfsprogs", TestRun ( + [["part_disk"; "/dev/sda"; "mbr"]; + ["mkfs_b"; "ntfs"; "32768"; "/dev/sda1"]])], "make a filesystem with block size", "\ This call is similar to C, but it allows you to control the block size of the resulting filesystem. Supported block sizes depend on the filesystem type, but typically they -are C<1024>, C<2048> or C<4096> only."); +are C<1024>, C<2048> or C<4096> only. + +For VFAT and NTFS the C parameter is treated as +the requested cluster size."); ("mke2journal", (RErr, [Int "blocksize"; Device "device"]), 188, [], [InitEmpty, Always, TestOutput ( @@ -4268,7 +4693,7 @@ partition table), C (a GPT/EFI-style partition table). Other values are possible, although unusual. See C for a full list."); - ("fill", (RErr, [Int "c"; Int "len"; Pathname "path"]), 215, [], + ("fill", (RErr, [Int "c"; Int "len"; Pathname "path"]), 215, [Progress], [InitBasicFS, Always, TestOutputBuffer ( [["fill"; "0x63"; "10"; "/test"]; ["read_file"; "/test"]], "cccccccccc")], @@ -4451,7 +4876,7 @@ calls to associate logical volumes and volume groups. See also C."); - ("copy_size", (RErr, [Dev_or_Path "src"; Dev_or_Path "dest"; Int64 "size"]), 227, [], + ("copy_size", (RErr, [Dev_or_Path "src"; Dev_or_Path "dest"; Int64 "size"]), 227, [Progress], [InitBasicFS, Always, TestOutputBuffer ( [["write"; "/src"; "hello, world"]; ["copy_size"; "/src"; "/dest"; "5"]; @@ -4464,7 +4889,7 @@ or file C to another destination device or file C. Note this will fail if the source is too short or if the destination is not large enough."); - ("zero_device", (RErr, [Device "device"]), 228, [DangerWillRobinson], + ("zero_device", (RErr, [Device "device"]), 228, [DangerWillRobinson; Progress], [InitBasicFSonLVM, Always, TestRun ( [["zero_device"; "/dev/VG/LV"]])], "write zeroes to an entire device", @@ -4643,7 +5068,7 @@ filename is not printable, coreutils uses a special backslash syntax. For more information, see the GNU coreutils info file."); - ("fill_pattern", (RErr, [String "pattern"; Int "len"; Pathname "path"]), 245, [], + ("fill_pattern", (RErr, [String "pattern"; Int "len"; Pathname "path"]), 245, [Progress], [InitBasicFS, Always, TestOutputBuffer ( [["fill_pattern"; "abcdefghijklmnopqrstuvwxyz"; "28"; "/test"]; ["read_file"; "/test"]], "abcdefghijklmnopqrstuvwxyzab")], @@ -4706,7 +5131,7 @@ See also C."); ("resize2fs_size", (RErr, [Device "device"; Int64 "size"]), 248, [], [], - "resize an ext2/ext3 filesystem (with size)", + "resize an ext2, ext3 or ext4 filesystem (with size)", "\ This command is the same as C except that it allows you to specify the new size (in bytes) explicitly."); @@ -4768,7 +5193,9 @@ a file in the host and attach it as a device."); This returns the filesystem label of the filesystem on C. -If the filesystem is unlabeled, this returns the empty string."); +If the filesystem is unlabeled, this returns the empty string. + +To find a filesystem from the label, use C."); ("vfs_uuid", (RString "uuid", [Device "device"]), 254, [], (let uuid = uuidgen () in @@ -4780,7 +5207,154 @@ If the filesystem is unlabeled, this returns the empty string."); This returns the filesystem UUID of the filesystem on C. -If the filesystem does not have a UUID, this returns the empty string."); +If the filesystem does not have a UUID, this returns the empty string. + +To find a filesystem from the UUID, use C."); + + ("lvm_set_filter", (RErr, [DeviceList "devices"]), 255, [Optional "lvm2"], + (* Can't be tested with the current framework because + * the VG is being used by the mounted filesystem, so + * the vgchange -an command we do first will fail. + *) + [], + "set LVM device filter", + "\ +This sets the LVM device filter so that LVM will only be +able to \"see\" the block devices in the list C, +and will ignore all other attached block devices. + +Where disk image(s) contain duplicate PVs or VGs, this +command is useful to get LVM to ignore the duplicates, otherwise +LVM can get confused. Note also there are two types +of duplication possible: either cloned PVs/VGs which have +identical UUIDs; or VGs that are not cloned but just happen +to have the same name. In normal operation you cannot +create this situation, but you can do it outside LVM, eg. +by cloning disk images or by bit twiddling inside the LVM +metadata. + +This command also clears the LVM cache and performs a volume +group scan. + +You can filter whole block devices or individual partitions. + +You cannot use this if any VG is currently in use (eg. +contains a mounted filesystem), even if you are not +filtering out that VG."); + + ("lvm_clear_filter", (RErr, []), 256, [], + [], (* see note on lvm_set_filter *) + "clear LVM device filter", + "\ +This undoes the effect of C. LVM +will be able to see every block device. + +This command also clears the LVM cache and performs a volume +group scan."); + + ("luks_open", (RErr, [Device "device"; Key "key"; String "mapname"]), 257, [Optional "luks"], + [], + "open a LUKS-encrypted block device", + "\ +This command opens a block device which has been encrypted +according to the Linux Unified Key Setup (LUKS) standard. + +C is the encrypted block device or partition. + +The caller must supply one of the keys associated with the +LUKS block device, in the C parameter. + +This creates a new block device called C. +Reads and writes to this block device are decrypted from and +encrypted to the underlying C respectively. + +If this block device contains LVM volume groups, then +calling C followed by C +will make them visible."); + + ("luks_open_ro", (RErr, [Device "device"; Key "key"; String "mapname"]), 258, [Optional "luks"], + [], + "open a LUKS-encrypted block device read-only", + "\ +This is the same as C except that a read-only +mapping is created."); + + ("luks_close", (RErr, [Device "device"]), 259, [Optional "luks"], + [], + "close a LUKS device", + "\ +This closes a LUKS device that was created earlier by +C or C. The +C parameter must be the name of the LUKS mapping +device (ie. C) and I the name +of the underlying block device."); + + ("luks_format", (RErr, [Device "device"; Key "key"; Int "keyslot"]), 260, [Optional "luks"; DangerWillRobinson], + [], + "format a block device as a LUKS encrypted device", + "\ +This command erases existing data on C and formats +the device as a LUKS encrypted device. C is the +initial key, which is added to key slot C. (LUKS +supports 8 key slots, numbered 0-7)."); + + ("luks_format_cipher", (RErr, [Device "device"; Key "key"; Int "keyslot"; String "cipher"]), 261, [Optional "luks"; DangerWillRobinson], + [], + "format a block device as a LUKS encrypted device", + "\ +This command is the same as C but +it also allows you to set the C used."); + + ("luks_add_key", (RErr, [Device "device"; Key "key"; Key "newkey"; Int "keyslot"]), 262, [Optional "luks"], + [], + "add a key on a LUKS encrypted device", + "\ +This command adds a new key on LUKS device C. +C is any existing key, and is used to access the device. +C is the new key to add. C is the key slot +that will be replaced. + +Note that if C already contains a key, then this +command will fail. You have to use C +first to remove that key."); + + ("luks_kill_slot", (RErr, [Device "device"; Key "key"; Int "keyslot"]), 263, [Optional "luks"], + [], + "remove a key from a LUKS encrypted device", + "\ +This command deletes the key in key slot C from the +encrypted LUKS device C. C must be one of the +I keys."); + + ("is_lv", (RBool "lvflag", [Device "device"]), 264, [Optional "lvm2"], + [InitBasicFSonLVM, IfAvailable "lvm2", TestOutputTrue ( + [["is_lv"; "/dev/VG/LV"]]); + InitBasicFSonLVM, IfAvailable "lvm2", TestOutputFalse ( + [["is_lv"; "/dev/sda1"]])], + "test if device is a logical volume", + "\ +This command tests whether C is a logical volume, and +returns true iff this is the case."); + + ("findfs_uuid", (RString "device", [String "uuid"]), 265, [], + [], + "find a filesystem by UUID", + "\ +This command searches the filesystems and returns the one +which has the given UUID. An error is returned if no such +filesystem can be found. + +To find the UUID of a filesystem, use C."); + + ("findfs_label", (RString "device", [String "label"]), 266, [], + [], + "find a filesystem by label", + "\ +This command searches the filesystems and returns the one +which has the given label. An error is returned if no such +filesystem can be found. + +To find the label of a filesystem, use C."); ] @@ -5203,7 +5777,7 @@ let map_chars f str = let name_of_argt = function | Pathname n | Device n | Dev_or_Path n | String n | OptString n | StringList n | DeviceList n | Bool n | Int n | Int64 n - | FileIn n | FileOut n | BufferIn n -> n + | FileIn n | FileOut n | BufferIn n | Key n -> n let java_name_of_struct typ = try List.assoc typ java_structs @@ -5226,6 +5800,12 @@ let seq_of_test = function | TestLastFail s -> s (* Handling for function flags. *) +let progress_message = + "This long-running command can generate progress notification messages +so that the caller can display a progress bar or indicator. +To receive these messages, the caller must register a progress +callback. See L." + let protocol_limit_warning = "Because of the message protocol, there is a transfer limit of somewhere between 2MB and 4MB. See L." @@ -5531,7 +6111,7 @@ let rec generate_actions_pod () = The string is owned by the guest handle and must I be freed.\n\n" | RConstOptString _ -> pr "This function returns a string which may be NULL. -There is way to return an error from this function. +There is no way to return an error from this function. The string is owned by the guest handle and must I be freed.\n\n" | RString _ -> pr "This function returns a string, or NULL on error. @@ -5560,10 +6140,16 @@ I.\n\n" The size of the returned buffer is written to C<*size_r>. I.\n\n" ); + if List.mem Progress flags then + pr "%s\n\n" progress_message; if List.mem ProtocolLimitWarning flags then pr "%s\n\n" protocol_limit_warning; if List.mem DangerWillRobinson flags then pr "%s\n\n" danger_will_robinson; + if List.exists (function Key _ -> true | _ -> false) (snd style) then + pr "This function takes a key or passphrase parameter which +could contain sensitive material. Read the section +L for more information.\n\n"; match deprecation_notice flags with | None -> () | Some txt -> pr "%s\n\n" txt @@ -5636,7 +6222,7 @@ and generate_xdr () = generate_header CStyle LGPLv2plus; (* This has to be defined to get around a limitation in Sun's rpcgen. *) - pr "typedef string str<>;\n"; + pr "typedef string guestfs_str<>;\n"; pr "\n"; (* Internal structures. *) @@ -5669,10 +6255,10 @@ and generate_xdr () = pr "struct %s_args {\n" name; List.iter ( function - | Pathname n | Device n | Dev_or_Path n | String n -> + | Pathname n | Device n | Dev_or_Path n | String n | Key n -> pr " string %s<>;\n" n - | OptString n -> pr " str *%s;\n" n - | StringList n | DeviceList n -> pr " str %s<>;\n" n + | OptString n -> pr " guestfs_str *%s;\n" n + | StringList n | DeviceList n -> pr " guestfs_str %s<>;\n" n | Bool n -> pr " bool %s;\n" n | Int n -> pr " int %s;\n" n | Int64 n -> pr " hyper %s;\n" n @@ -5704,7 +6290,7 @@ and generate_xdr () = pr "};\n\n" | RStringList n -> pr "struct %s_ret {\n" name; - pr " str %s<>;\n" n; + pr " guestfs_str %s<>;\n" n; pr "};\n\n" | RStruct (n, typ) -> pr "struct %s_ret {\n" name; @@ -5716,7 +6302,7 @@ and generate_xdr () = pr "};\n\n" | RHashtable n -> pr "struct %s_ret {\n" name; - pr " str %s<>;\n" n; + pr " guestfs_str %s<>;\n" n; pr "};\n\n" | RBufferOut n -> pr "struct %s_ret {\n" name; @@ -5750,11 +6336,12 @@ and generate_xdr () = */ const GUESTFS_PROGRAM = 0x2000F5F5; -const GUESTFS_PROTOCOL_VERSION = 1; +const GUESTFS_PROTOCOL_VERSION = 2; /* These constants must be larger than any possible message length. */ const GUESTFS_LAUNCH_FLAG = 0xf5f55ff5; const GUESTFS_CANCEL_FLAG = 0xffffeeee; +const GUESTFS_PROGRESS_FLAG = 0xffff5555; enum guestfs_message_direction { GUESTFS_DIRECTION_CALL = 0, /* client -> daemon */ @@ -5766,9 +6353,14 @@ enum guestfs_message_status { GUESTFS_STATUS_ERROR = 1 }; -const GUESTFS_ERROR_LEN = 256; +"; + pr "const GUESTFS_ERROR_LEN = %d;\n" (64 * 1024); + pr "\n"; + + pr "\ struct guestfs_message_error { + int linux_errno; /* Linux errno if available. */ string error_message; }; @@ -5788,6 +6380,23 @@ struct guestfs_chunk { /* data size is 0 bytes if the transfer has finished successfully */ opaque data; }; + +/* Progress notifications. Daemon self-limits these messages to + * at most one per second. The daemon can send these messages + * at any time, and the caller should discard unexpected messages. + * 'position' and 'total' have undefined units; however they may + * have meaning for some calls. + * + * NB. guestfs___recv_from_daemon assumes the XDR-encoded + * structure is 24 bytes long. + */ +struct guestfs_progress { + guestfs_procedure proc; /* @0: GUESTFS_PROC_x */ + unsigned serial; /* @4: message serial number */ + unsigned hyper position; /* @8: 0 <= position <= total */ + unsigned hyper total; /* @16: total size of operation */ + /* @24: size of structure */ +}; " (* Generate the guestfs-structs.h file. *) @@ -5874,13 +6483,6 @@ and generate_client_actions () = #include \"guestfs-internal-actions.h\" #include \"guestfs_protocol.h\" -#define error guestfs_error -//#define perrorf guestfs_perrorf -#define safe_malloc guestfs_safe_malloc -#define safe_realloc guestfs_safe_realloc -//#define safe_strdup guestfs_safe_strdup -#define safe_memdup guestfs_safe_memdup - /* Check the return message from a call for validity. */ static int check_reply_header (guestfs_h *g, @@ -5955,7 +6557,8 @@ check_state (guestfs_h *g, const char *caller) | FileOut n | BufferIn n | StringList n - | DeviceList n -> + | DeviceList n + | Key n -> pr " if (%s == NULL) {\n" n; pr " error (g, \"%%s: %%s: parameter cannot be NULL\",\n"; pr " \"%s\", \"%s\");\n" shortname n; @@ -5984,11 +6587,11 @@ check_state (guestfs_h *g, const char *caller) | StringList _ | DeviceList _ -> true | _ -> false) (snd style) in if needs_i then ( - pr " int i;\n"; + pr " size_t i;\n"; pr "\n" ); - pr " printf (\"%s\");\n" shortname; + pr " fprintf (stderr, \"%s\");\n" shortname; List.iter ( function | String n (* strings *) @@ -5997,29 +6600,30 @@ check_state (guestfs_h *g, const char *caller) | Dev_or_Path n | FileIn n | FileOut n - | BufferIn n -> + | BufferIn n + | Key n -> (* guestfish doesn't support string escaping, so neither do we *) - pr " printf (\" \\\"%%s\\\"\", %s);\n" n + pr " fprintf (stderr, \" \\\"%%s\\\"\", %s);\n" n | OptString n -> (* string option *) - pr " if (%s) printf (\" \\\"%%s\\\"\", %s);\n" n n; - pr " else printf (\" null\");\n" + pr " if (%s) fprintf (stderr, \" \\\"%%s\\\"\", %s);\n" n n; + pr " else fprintf (stderr, \" null\");\n" | StringList n | DeviceList n -> (* string list *) - pr " putchar (' ');\n"; - pr " putchar ('\"');\n"; + pr " fputc (' ', stderr);\n"; + pr " fputc ('\"', stderr);\n"; pr " for (i = 0; %s[i]; ++i) {\n" n; - pr " if (i > 0) putchar (' ');\n"; - pr " fputs (%s[i], stdout);\n" n; + pr " if (i > 0) fputc (' ', stderr);\n"; + pr " fputs (%s[i], stderr);\n" n; pr " }\n"; - pr " putchar ('\"');\n"; + pr " fputc ('\"', stderr);\n"; | Bool n -> (* boolean *) - pr " fputs (%s ? \" true\" : \" false\", stdout);\n" n + pr " fputs (%s ? \" true\" : \" false\", stderr);\n" n | Int n -> (* int *) - pr " printf (\" %%d\", %s);\n" n + pr " fprintf (stderr, \" %%d\", %s);\n" n | Int64 n -> - pr " printf (\" %%\" PRIi64, %s);\n" n + pr " fprintf (stderr, \" %%\" PRIi64, %s);\n" n ) (snd style); - pr " putchar ('\\n');\n"; + pr " fputc ('\\n', stderr);\n"; pr " }\n"; pr "\n"; in @@ -6090,7 +6694,7 @@ check_state (guestfs_h *g, const char *caller) | args -> List.iter ( function - | Pathname n | Device n | Dev_or_Path n | String n -> + | Pathname n | Device n | Dev_or_Path n | String n | Key n -> pr " args.%s = (char *) %s;\n" n n | OptString n -> pr " args.%s = %s ? (char **) &%s : NULL;\n" n n n @@ -6286,11 +6890,15 @@ and generate_linker_script () = "guestfs_close"; "guestfs_get_error_handler"; "guestfs_get_out_of_memory_handler"; + "guestfs_get_private"; "guestfs_last_error"; + "guestfs_set_close_callback"; "guestfs_set_error_handler"; "guestfs_set_launch_done_callback"; "guestfs_set_log_message_callback"; "guestfs_set_out_of_memory_handler"; + "guestfs_set_private"; + "guestfs_set_progress_callback"; "guestfs_set_subprocess_quit_callback"; (* Unofficial parts of the API: the bindings code use these @@ -6298,6 +6906,8 @@ and generate_linker_script () = *) "guestfs_safe_calloc"; "guestfs_safe_malloc"; + "guestfs_safe_strdup"; + "guestfs_safe_memdup"; ] in let functions = List.map (fun (name, _, _, _, _, _, _) -> "guestfs_" ^ name) @@ -6367,7 +6977,8 @@ and generate_daemon_actions () = function | Device n | Dev_or_Path n | Pathname n - | String n -> () + | String n + | Key n -> () | OptString n -> pr " char *%s;\n" n | StringList n | DeviceList n -> pr " char **%s;\n" n | Bool n -> pr " int %s;\n" n @@ -6424,16 +7035,19 @@ and generate_daemon_actions () = pr_args n; pr " REQUIRE_ROOT_OR_RESOLVE_DEVICE (%s, %s, goto done);\n" n (if is_filein then "cancel_receive ()" else "0"); - | String n -> pr_args n + | String n | Key n -> pr_args n | OptString n -> pr " %s = args.%s ? *args.%s : NULL;\n" n n n | StringList n -> pr_list_handling_code n; | DeviceList n -> pr_list_handling_code n; pr " /* Ensure that each is a device,\n"; - pr " * and perform device name translation. */\n"; - pr " { int pvi; for (pvi = 0; physvols[pvi] != NULL; ++pvi)\n"; - pr " RESOLVE_DEVICE (physvols[pvi], %s, goto done);\n" + pr " * and perform device name translation.\n"; + pr " */\n"; + pr " {\n"; + pr " size_t i;\n"; + pr " for (i = 0; %s[i] != NULL; ++i)\n" n; + pr " RESOLVE_DEVICE (%s[i], %s, goto done);\n" n (if is_filein then "cancel_receive ()" else "0"); pr " }\n"; | Bool n -> pr " %s = args.%s;\n" n n @@ -6581,7 +7195,7 @@ and generate_daemon_actions () = pr "static int lvm_tokenize_%s (char *str, guestfs_int_lvm_%s *r)\n" typ typ; pr "{\n"; pr " char *tok, *p, *next;\n"; - pr " int i, j;\n"; + pr " size_t i, j;\n"; pr "\n"; (* pr " fprintf (stderr, \"%%s: <<%%s>>\\n\", __func__, str);\n"; @@ -6806,7 +7420,7 @@ static void print_error (guestfs_h *g, void *data, const char *msg) /* FIXME: nearly identical code appears in fish.c */ static void print_strings (char *const *argv) { - int argc; + size_t argc; for (argc = 0; argv[argc] != NULL; ++argc) printf (\"\\t%%s\\n\", argv[argc]); @@ -6815,13 +7429,33 @@ static void print_strings (char *const *argv) /* static void print_table (char const *const *argv) { - int i; + size_t i; for (i = 0; argv[i] != NULL; i += 2) printf (\"%%s: %%s\\n\", argv[i], argv[i+1]); } */ +static int +is_available (const char *group) +{ + const char *groups[] = { group, NULL }; + int r; + + suppress_error = 1; + r = guestfs_available (g, (char **) groups); + suppress_error = 0; + + return r == 0; +} + +static void +incr (guestfs_h *g, void *iv) +{ + int *i = (int *) iv; + (*i)++; +} + "; (* Generate a list of commands which are not tested anywhere. *) @@ -6833,7 +7467,7 @@ static void print_table (char const *const *argv) fun (_, _, _, _, tests, _, _) -> let tests = filter_map ( function - | (_, (Always|If _|Unless _), test) -> Some test + | (_, (Always|If _|Unless _|IfAvailable _), test) -> Some test | (_, Disabled, _) -> None ) tests in let seq = List.concat (List.map seq_of_test tests) in @@ -7003,11 +7637,22 @@ int main (int argc, char *argv[]) ) test_names; pr "\n"; - pr " guestfs_close (g);\n"; - pr " unlink (\"test1.img\");\n"; - pr " unlink (\"test2.img\");\n"; - pr " unlink (\"test3.img\");\n"; - pr "\n"; + pr " /* Check close callback is called. */ + int close_sentinel = 1; + guestfs_set_close_callback (g, incr, &close_sentinel); + + guestfs_close (g); + + if (close_sentinel != 2) { + fprintf (stderr, \"close callback was not called\\n\"); + exit (EXIT_FAILURE); + } + + unlink (\"test1.img\"); + unlink (\"test2.img\"); + unlink (\"test3.img\"); + +"; pr " if (n_failed > 0) {\n"; pr " printf (\"***** %%lu / %%d tests FAILED *****\\n\", n_failed, nr_tests);\n"; @@ -7039,7 +7684,7 @@ static int %s_skip (void) " test_name name (String.uppercase test_name) (String.uppercase name); (match prereq with - | Disabled | Always -> () + | Disabled | Always | IfAvailable _ -> () | If code | Unless code -> pr "static int %s_prereq (void)\n" test_name; pr "{\n"; @@ -7064,16 +7709,9 @@ static int %s (void) List.iter ( function | Optional group -> - pr " {\n"; - pr " const char *groups[] = { \"%s\", NULL };\n" group; - pr " int r;\n"; - pr " suppress_error = 1;\n"; - pr " r = guestfs_available (g, (char **) groups);\n"; - pr " suppress_error = 0;\n"; - pr " if (r == -1) {\n"; - pr " printf (\" %%s skipped (reason: group %%s not available in daemon)\\n\", \"%s\", groups[0]);\n" test_name; - pr " return 0;\n"; - pr " }\n"; + pr " if (!is_available (\"%s\")) {\n" group; + pr " printf (\" %%s skipped (reason: group %%s not available in daemon)\\n\", \"%s\", \"%s\");\n" test_name group; + pr " return 0;\n"; pr " }\n"; | _ -> () ) flags; @@ -7095,6 +7733,13 @@ static int %s (void) pr " }\n"; pr "\n"; generate_one_test_body name i test_name init test; + | IfAvailable group -> + pr " if (!is_available (\"%s\")) {\n" group; + pr " printf (\" %%s skipped (reason: %%s not available)\\n\", \"%s\", \"%s\");\n" test_name group; + pr " return 0;\n"; + pr " }\n"; + pr "\n"; + generate_one_test_body name i test_name init test; | Always -> generate_one_test_body name i test_name init test ); @@ -7405,7 +8050,8 @@ and generate_test_command_call ?(expect_error = false) ?test test_name cmd = | Device n, arg | Dev_or_Path n, arg | String n, arg - | OptString n, arg -> + | OptString n, arg + | Key n, arg -> pr " const char *%s = \"%s\";\n" n (c_quote arg); | BufferIn n, arg -> pr " const char *%s = \"%s\";\n" n (c_quote arg); @@ -7439,7 +8085,7 @@ and generate_test_command_call ?(expect_error = false) ?test test_name cmd = | RString _ -> pr " char *r;\n"; "NULL" | RStringList _ | RHashtable _ -> pr " char **r;\n"; - pr " int i;\n"; + pr " size_t i;\n"; "NULL" | RStruct (_, typ) -> pr " struct guestfs_%s *r;\n" typ; "NULL" @@ -7460,7 +8106,8 @@ and generate_test_command_call ?(expect_error = false) ?test test_name cmd = | Pathname n, _ | Device n, _ | Dev_or_Path n, _ | String n, _ - | OptString n, _ -> + | OptString n, _ + | Key n, _ -> pr ", %s" n | BufferIn n, _ -> pr ", %s, %s_size" n n @@ -7573,7 +8220,7 @@ and generate_fish_cmds () = pr "\n"; (* display_command function, which implements guestfish -h cmd *) - pr "void display_command (const char *cmd)\n"; + pr "int display_command (const char *cmd)\n"; pr "{\n"; List.iter ( fun (name, style, _, flags, _, shortdesc, longdesc) -> @@ -7586,14 +8233,22 @@ and generate_fish_cmds () = match snd style with | [] -> name2 | args -> + let args = List.filter (function Key _ -> false | _ -> true) args in sprintf "%s %s" name2 (String.concat " " (List.map name_of_argt args)) in let warnings = - if List.mem ProtocolLimitWarning flags then - ("\n\n" ^ protocol_limit_warning) + if List.exists (function Key _ -> true | _ -> false) (snd style) then + "\n\nThis command has one or more key or passphrase parameters. +Guestfish will prompt for these separately." else "" in + let warnings = + warnings ^ + if List.mem ProtocolLimitWarning flags then + ("\n\n" ^ protocol_limit_warning) + else "" in + (* For DangerWillRobinson commands, we should probably have * guestfish prompt before allowing you to use them (especially * in interactive mode). XXX @@ -7621,15 +8276,17 @@ and generate_fish_cmds () = pr " || STRCASEEQ (cmd, \"%s\")" name2; if name <> alias then pr " || STRCASEEQ (cmd, \"%s\")" alias; - pr ")\n"; + pr ") {\n"; pr " pod2text (\"%s\", _(\"%s\"), %S);\n" name2 shortdesc ("=head1 SYNOPSIS\n\n " ^ synopsis ^ "\n\n" ^ "=head1 DESCRIPTION\n\n" ^ longdesc ^ warnings ^ describe_alias); + pr " return 0;\n"; + pr " }\n"; pr " else\n" ) all_functions; - pr " display_builtin_command (cmd);\n"; + pr " return display_builtin_command (cmd);\n"; pr "}\n"; pr "\n"; @@ -7749,7 +8406,8 @@ and generate_fish_cmds () = | Pathname n | Dev_or_Path n | FileIn n - | FileOut n -> pr " char *%s;\n" n + | FileOut n + | Key n -> pr " char *%s;\n" n | BufferIn n -> pr " const char *%s;\n" n; pr " size_t %s_size;\n" n @@ -7760,7 +8418,10 @@ and generate_fish_cmds () = ) (snd style); (* Check and convert parameters. *) - let argc_expected = List.length (snd style) in + let argc_expected = + let args_no_keys = + List.filter (function Key _ -> false | _ -> true) (snd style) in + List.length args_no_keys in pr " if (argc != %d) {\n" argc_expected; pr " fprintf (stderr, _(\"%%s should have %%d parameter(s)\\n\"), cmd, %d);\n" argc_expected; @@ -7768,12 +8429,12 @@ and generate_fish_cmds () = pr " return -1;\n"; pr " }\n"; - let parse_integer fn fntyp rtyp range name i = + let parse_integer fn fntyp rtyp range name = pr " {\n"; pr " strtol_error xerr;\n"; pr " %s r;\n" fntyp; pr "\n"; - pr " xerr = %s (argv[%d], NULL, 0, &r, xstrtol_suffixes);\n" fn i; + pr " xerr = %s (argv[i++], NULL, 0, &r, xstrtol_suffixes);\n" fn; pr " if (xerr != LONGINT_OK) {\n"; pr " fprintf (stderr,\n"; pr " _(\"%%s: %%s: invalid integer parameter (%%s returned %%d)\\n\"),\n"; @@ -7795,43 +8456,49 @@ and generate_fish_cmds () = pr " }\n"; in - iteri ( - fun i -> - function - | Device name - | String name -> - pr " %s = argv[%d];\n" name i - | Pathname name - | Dev_or_Path name -> - pr " %s = resolve_win_path (argv[%d]);\n" name i; - pr " if (%s == NULL) return -1;\n" name - | OptString name -> - pr " %s = STRNEQ (argv[%d], \"\") ? argv[%d] : NULL;\n" - name i i - | BufferIn name -> - pr " %s = argv[%d];\n" name i; - pr " %s_size = strlen (argv[%d]);\n" name i - | FileIn name -> - pr " %s = file_in (argv[%d]);\n" name i; - pr " if (%s == NULL) return -1;\n" name - | FileOut name -> - pr " %s = file_out (argv[%d]);\n" name i; - pr " if (%s == NULL) return -1;\n" name - | StringList name | DeviceList name -> - pr " %s = parse_string_list (argv[%d]);\n" name i; - pr " if (%s == NULL) return -1;\n" name; - | Bool name -> - pr " %s = is_true (argv[%d]) ? 1 : 0;\n" name i - | Int name -> - let range = - let min = "(-(2LL<<30))" - and max = "((2LL<<30)-1)" - and comment = - "The Int type in the generator is a signed 31 bit int." in - Some (min, max, comment) in - parse_integer "xstrtoll" "long long" "int" range name i - | Int64 name -> - parse_integer "xstrtoll" "long long" "int64_t" None name i + if snd style <> [] then + pr " size_t i = 0;\n"; + + List.iter ( + function + | Device name + | String name -> + pr " %s = argv[i++];\n" name + | Pathname name + | Dev_or_Path name -> + pr " %s = resolve_win_path (argv[i++]);\n" name; + pr " if (%s == NULL) return -1;\n" name + | OptString name -> + pr " %s = STRNEQ (argv[i], \"\") ? argv[i] : NULL;\n" name; + pr " i++;\n" + | BufferIn name -> + pr " %s = argv[i];\n" name; + pr " %s_size = strlen (argv[i]);\n" name; + pr " i++;\n" + | FileIn name -> + pr " %s = file_in (argv[i++]);\n" name; + pr " if (%s == NULL) return -1;\n" name + | FileOut name -> + pr " %s = file_out (argv[i++]);\n" name; + pr " if (%s == NULL) return -1;\n" name + | StringList name | DeviceList name -> + pr " %s = parse_string_list (argv[i++]);\n" name; + pr " if (%s == NULL) return -1;\n" name + | Key name -> + pr " %s = read_key (\"%s\");\n" name name; + pr " if (%s == NULL) return -1;\n" name + | Bool name -> + pr " %s = is_true (argv[i++]) ? 1 : 0;\n" name + | Int name -> + let range = + let min = "(-(2LL<<30))" + and max = "((2LL<<30)-1)" + and comment = + "The Int type in the generator is a signed 31 bit int." in + Some (min, max, comment) in + parse_integer "xstrtoll" "long long" "int" range name + | Int64 name -> + parse_integer "xstrtoll" "long long" "int64_t" None name ) (snd style); (* Call C API function. *) @@ -7841,11 +8508,12 @@ and generate_fish_cmds () = List.iter ( function - | Device name | String name - | OptString name | Bool name - | Int name | Int64 name - | BufferIn name -> () - | Pathname name | Dev_or_Path name | FileOut name -> + | Device _ | String _ + | OptString _ | Bool _ + | Int _ | Int64 _ + | BufferIn _ -> () + | Pathname name | Dev_or_Path name | FileOut name + | Key name -> pr " free (%s);\n" name | FileIn name -> pr " free_file_in (%s);\n" name @@ -8017,7 +8685,7 @@ static const char *const commands[] = { static char * generator (const char *text, int state) { - static int index, len; + static size_t index, len; const char *name; if (!state) { @@ -8098,7 +8766,8 @@ and generate_fish_actions_pod () = pr " %s" name; List.iter ( function - | Pathname n | Device n | Dev_or_Path n | String n -> pr " %s" n + | Pathname n | Device n | Dev_or_Path n | String n -> + pr " %s" n | OptString n -> pr " %s" n | StringList n | DeviceList n -> pr " '%s ...'" n | Bool _ -> pr " true|false" @@ -8106,6 +8775,7 @@ and generate_fish_actions_pod () = | Int64 n -> pr " %s" n | FileIn n | FileOut n -> pr " (%s|-)" n | BufferIn n -> pr " %s" n + | Key _ -> () (* keys are entered at a prompt *) ) (snd style); pr "\n"; pr "\n"; @@ -8115,6 +8785,10 @@ and generate_fish_actions_pod () = | _ -> false) (snd style) then pr "Use C<-> instead of a filename to read/write from stdin/stdout.\n\n"; + if List.exists (function Key _ -> true | _ -> false) (snd style) then + pr "This command has one or more key or passphrase parameters. +Guestfish will prompt for these separately.\n\n"; + if List.mem ProtocolLimitWarning flags then pr "%s\n\n" protocol_limit_warning; @@ -8169,7 +8843,8 @@ and generate_prototype ?(extern = true) ?(static = false) ?(semicolon = true) | Pathname n | Device n | Dev_or_Path n | String n - | OptString n -> + | OptString n + | Key n -> next (); pr "const char *%s" n | StringList n | DeviceList n -> @@ -8255,6 +8930,28 @@ val close : t -> unit unreferenced, but callers can call this in order to provide predictable cleanup. *) +type progress_cb = int -> int -> int64 -> int64 -> unit + +val set_progress_callback : t -> progress_cb -> unit +(** [set_progress_callback g f] sets [f] as the progress callback function. + For some long-running functions, [f] will be called repeatedly + during the function with progress updates. + + The callback is [f proc_nr serial position total]. See + the description of [guestfs_set_progress_callback] in guestfs(3) + for the meaning of these four numbers. + + Note that if the closure captures a reference to the handle, + this reference will prevent the handle from being + automatically closed by the garbage collector. There are + three ways to avoid this: be careful not to capture the handle + in the closure, or use a weak reference, or call + {!Guestfs.clear_progress_callback} to remove the reference. *) + +val clear_progress_callback : t -> unit +(** [clear_progress_callback g] removes any progress callback function + associated with the handle. See {!Guestfs.set_progress_callback}. *) + "; generate_ocaml_structure_decls (); @@ -8279,6 +8976,13 @@ exception Handle_closed of string external create : unit -> t = \"ocaml_guestfs_create\" external close : t -> unit = \"ocaml_guestfs_close\" +type progress_cb = int -> int -> int64 -> int64 -> unit + +external set_progress_callback : t -> progress_cb -> unit + = \"ocaml_guestfs_set_progress_callback\" +external clear_progress_callback : t -> unit + = \"ocaml_guestfs_clear_progress_callback\" + (* Give the exceptions names, so they can be raised from the C code. *) let () = Callback.register_exception \"ocaml_guestfs_error\" (Error \"\"); @@ -8311,7 +9015,7 @@ and generate_ocaml_c () = #include #include -#include +#include \"guestfs.h\" #include \"guestfs_c.h\" @@ -8324,7 +9028,7 @@ copy_table (char * const * argv) { CAMLparam0 (); CAMLlocal5 (rv, pairv, kv, vv, cons); - int i; + size_t i; rv = Val_int (0); for (i = 0; argv[i] != NULL; i += 2) { @@ -8478,15 +9182,17 @@ copy_table (char * const * argv) | Device n | Dev_or_Path n | String n | FileIn n - | FileOut n -> - pr " const char *%s = String_val (%sv);\n" n n + | FileOut n + | Key n -> + (* Copy strings in case the GC moves them: RHBZ#604691 *) + pr " char *%s = guestfs_safe_strdup (g, String_val (%sv));\n" n n | OptString n -> - pr " const char *%s =\n" n; - pr " %sv != Val_int (0) ? String_val (Field (%sv, 0)) : NULL;\n" - n n + pr " char *%s =\n" n; + pr " %sv != Val_int (0) ?" n; + pr " guestfs_safe_strdup (g, String_val (Field (%sv, 0))) : NULL;\n" n | BufferIn n -> - pr " const char *%s = String_val (%sv);\n" n n; - pr " size_t %s_size = caml_string_length (%sv);\n" n n + pr " size_t %s_size = caml_string_length (%sv);\n" n n; + pr " char *%s = guestfs_safe_memdup (g, String_val (%sv), %s_size);\n" n n n | StringList n | DeviceList n -> pr " char **%s = ocaml_guestfs_strings_val (g, %sv);\n" n n | Bool n -> @@ -8506,7 +9212,7 @@ copy_table (char * const * argv) pr " const char *r;\n"; "NULL" | RString _ -> pr " char *r;\n"; "NULL" | RStringList _ -> - pr " int i;\n"; + pr " size_t i;\n"; pr " char **r;\n"; "NULL" | RStruct (_, typ) -> @@ -8514,7 +9220,7 @@ copy_table (char * const * argv) | RStructList (_, typ) -> pr " struct guestfs_%s_list *r;\n" typ; "NULL" | RHashtable _ -> - pr " int i;\n"; + pr " size_t i;\n"; pr " char **r;\n"; "NULL" | RBufferOut _ -> @@ -8529,13 +9235,15 @@ copy_table (char * const * argv) pr ";\n"; pr " caml_leave_blocking_section ();\n"; + (* Free strings if we copied them above. *) List.iter ( function + | Pathname n | Device n | Dev_or_Path n | String n | OptString n + | FileIn n | FileOut n | BufferIn n | Key n -> + pr " free (%s);\n" n | StringList n | DeviceList n -> pr " ocaml_guestfs_free_strings (%s);\n" n; - | Pathname _ | Device _ | Dev_or_Path _ | String _ | OptString _ - | Bool _ | Int _ | Int64 _ - | FileIn _ | FileOut _ | BufferIn _ -> () + | Bool _ | Int _ | Int64 _ -> () ) (snd style); pr " if (r == %s)\n" error_code; @@ -8622,7 +9330,7 @@ and generate_ocaml_prototype ?(is_external = false) name style = List.iter ( function | Pathname _ | Device _ | Dev_or_Path _ | String _ | FileIn _ | FileOut _ - | BufferIn _ -> pr "string -> " + | BufferIn _ | Key _ -> pr "string -> " | OptString _ -> pr "string option -> " | StringList _ | DeviceList _ -> pr "string array -> " | Bool _ -> pr "bool -> " @@ -8722,6 +9430,46 @@ XS_unpack_charPtrPtr (SV *arg) { return ret; } +#define PROGRESS_KEY \"_perl_progress_cb\" + +static void +_clear_progress_callback (guestfs_h *g) +{ + guestfs_set_progress_callback (g, NULL, NULL); + SV *cb = guestfs_get_private (g, PROGRESS_KEY); + if (cb) { + guestfs_set_private (g, PROGRESS_KEY, NULL); + SvREFCNT_dec (cb); + } +} + +/* http://www.perlmonks.org/?node=338857 */ +static void +_progress_callback (guestfs_h *g, void *cb, + int proc_nr, int serial, uint64_t position, uint64_t total) +{ + dSP; + ENTER; + SAVETMPS; + PUSHMARK (SP); + XPUSHs (sv_2mortal (newSViv (proc_nr))); + XPUSHs (sv_2mortal (newSViv (serial))); + XPUSHs (sv_2mortal (my_newSVull (position))); + XPUSHs (sv_2mortal (my_newSVull (total))); + PUTBACK; + call_sv ((SV *) cb, G_VOID | G_DISCARD | G_EVAL); + FREETMPS; + LEAVE; +} + +static void +_close_handle (guestfs_h *g) +{ + assert (g != NULL); + _clear_progress_callback (g); + guestfs_close (g); +} + MODULE = Sys::Guestfs PACKAGE = Sys::Guestfs PROTOTYPES: ENABLE @@ -8737,10 +9485,45 @@ _create () RETVAL void -DESTROY (g) +DESTROY (sv) + SV *sv; + PPCODE: + /* For the 'g' argument above we do the conversion explicitly and + * don't rely on the typemap, because if the handle has been + * explicitly closed we don't want the typemap conversion to + * display an error. + */ + HV *hv = (HV *) SvRV (sv); + SV **svp = hv_fetch (hv, \"_g\", 2, 0); + if (svp != NULL) { + guestfs_h *g = (guestfs_h *) SvIV (*svp); + _close_handle (g); + } + +void +close (g) + guestfs_h *g; + PPCODE: + _close_handle (g); + /* Avoid double-free in DESTROY method. */ + HV *hv = (HV *) SvRV (ST(0)); + (void) hv_delete (hv, \"_g\", 2, G_DISCARD); + +void +set_progress_callback (g, cb) guestfs_h *g; + SV *cb; PPCODE: - guestfs_close (g); + _clear_progress_callback (g); + SvREFCNT_inc (cb); + guestfs_set_private (g, PROGRESS_KEY, cb); + guestfs_set_progress_callback (g, _progress_callback, cb); + +void +clear_progress_callback (g) + guestfs_h *g; + PPCODE: + _clear_progress_callback (g); "; @@ -8771,7 +9554,7 @@ DESTROY (g) fun i -> function | Pathname n | Device n | Dev_or_Path n | String n - | FileIn n | FileOut n -> + | FileIn n | FileOut n | Key n -> pr " char *%s;\n" n | BufferIn n -> pr " char *%s;\n" n; @@ -8794,7 +9577,7 @@ DESTROY (g) | Pathname _ | Device _ | Dev_or_Path _ | String _ | OptString _ | Bool _ | Int _ | Int64 _ | FileIn _ | FileOut _ - | BufferIn _ -> () + | BufferIn _ | Key _ -> () | StringList n | DeviceList n -> pr " free (%s);\n" n ) (snd style) in @@ -8882,7 +9665,7 @@ DESTROY (g) | RStringList n | RHashtable n -> pr "PREINIT:\n"; pr " char **%s;\n" n; - pr " int i, n;\n"; + pr " size_t i, n;\n"; pr " PPCODE:\n"; pr " %s = guestfs_%s " n name; generate_c_call_args ~handle:"g" style; @@ -8926,7 +9709,7 @@ DESTROY (g) and generate_perl_struct_list_code typ cols name style n do_cleanups = pr "PREINIT:\n"; pr " struct guestfs_%s_list *%s;\n" typ n; - pr " int i;\n"; + pr " size_t i;\n"; pr " HV *hv;\n"; pr " PPCODE:\n"; pr " %s = guestfs_%s " n name; @@ -9095,11 +9878,47 @@ sub new { my $proto = shift; my $class = ref ($proto) || $proto; - my $self = Sys::Guestfs::_create (); + my $g = Sys::Guestfs::_create (); + my $self = { _g => $g }; bless $self, $class; return $self; } +=item $h->close (); + +Explicitly close the guestfs handle. + +B You should not usually call this function. The handle will +be closed implicitly when its reference count goes to zero (eg. +when it goes out of scope or the program ends). This call is +only required in some exceptional cases, such as where the program +may contain cached references to the handle 'somewhere' and you +really have to have the close happen right away. After calling +C the program must not call any method (including C) +on the handle (but the implicit call to C that happens +when the final reference is cleaned up is OK). + +=item $h->set_progress_callback (\\&cb); + +Set the progress notification callback for this handle +to the Perl closure C. + +C will be called whenever a long-running operation +generates a progress notification message. The 4 parameters +to the function are: C, C, C +and C. + +You should carefully read the documentation for +L before using +this function. + +=item $h->clear_progress_callback (); + +This removes any progress callback function associated with +the handle. + +=cut + " max_proc_nr; (* Actions. We only need to print documentation for these as @@ -9173,7 +9992,7 @@ and generate_perl_prototype name style = match arg with | Pathname n | Device n | Dev_or_Path n | String n | OptString n | Bool n | Int n | Int64 n | FileIn n | FileOut n - | BufferIn n -> + | BufferIn n | Key n -> pr "$%s" n | StringList n | DeviceList n -> pr "\\@%s" n @@ -9200,32 +10019,42 @@ typedef int Py_ssize_t; #include \"guestfs.h\" +#ifndef HAVE_PYCAPSULE_NEW typedef struct { PyObject_HEAD guestfs_h *g; } Pyguestfs_Object; +#endif static guestfs_h * get_handle (PyObject *obj) { assert (obj); assert (obj != Py_None); +#ifndef HAVE_PYCAPSULE_NEW return ((Pyguestfs_Object *) obj)->g; +#else + return (guestfs_h*) PyCapsule_GetPointer(obj, \"guestfs_h\"); +#endif } static PyObject * put_handle (guestfs_h *g) { assert (g); +#ifndef HAVE_PYCAPSULE_NEW return PyCObject_FromVoidPtrAndDesc ((void *) g, (char *) \"guestfs_h\", NULL); +#else + return PyCapsule_New ((void *) g, \"guestfs_h\", NULL); +#endif } /* This list should be freed (but not the strings) after use. */ static char ** get_string_list (PyObject *obj) { - int i, len; + size_t i, len; char **r; assert (obj); @@ -9235,7 +10064,12 @@ get_string_list (PyObject *obj) return NULL; } - len = PyList_Size (obj); + Py_ssize_t slen = PyList_Size (obj); + if (slen == -1) { + PyErr_SetString (PyExc_RuntimeError, \"get_string_list: PyList_Size failure\"); + return NULL; + } + len = (size_t) slen; r = malloc (sizeof (char *) * (len+1)); if (r == NULL) { PyErr_SetString (PyExc_RuntimeError, \"get_string_list: out of memory\"); @@ -9307,6 +10141,9 @@ py_guestfs_create (PyObject *self, PyObject *args) return NULL; } guestfs_set_error_handler (g, NULL, NULL); + /* This can return NULL, but in that case put_handle will have + * set the Python error string. + */ return put_handle (g); } @@ -9333,7 +10170,7 @@ py_guestfs_close (PyObject *self, PyObject *args) pr "put_%s_list (struct guestfs_%s_list *%ss)\n" typ typ typ; pr "{\n"; pr " PyObject *list;\n"; - pr " int i;\n"; + pr " size_t i;\n"; pr "\n"; pr " list = PyList_New (%ss->len);\n" typ; pr " for (i = 0; i < %ss->len; ++i)\n" typ; @@ -9439,7 +10276,7 @@ py_guestfs_close (PyObject *self, PyObject *args) List.iter ( function - | Pathname n | Device n | Dev_or_Path n | String n + | Pathname n | Device n | Dev_or_Path n | String n | Key n | FileIn n | FileOut n -> pr " const char *%s;\n" n | OptString n -> pr " const char *%s;\n" n @@ -9460,7 +10297,8 @@ py_guestfs_close (PyObject *self, PyObject *args) pr " if (!PyArg_ParseTuple (args, (char *) \"O"; List.iter ( function - | Pathname _ | Device _ | Dev_or_Path _ | String _ | FileIn _ | FileOut _ -> pr "s" + | Pathname _ | Device _ | Dev_or_Path _ | String _ | Key _ + | FileIn _ | FileOut _ -> pr "s" | OptString _ -> pr "z" | StringList _ | DeviceList _ -> pr "O" | Bool _ -> pr "i" (* XXX Python has booleans? *) @@ -9474,7 +10312,8 @@ py_guestfs_close (PyObject *self, PyObject *args) pr " &py_g"; List.iter ( function - | Pathname n | Device n | Dev_or_Path n | String n | FileIn n | FileOut n -> pr ", &%s" n + | Pathname n | Device n | Dev_or_Path n | String n | Key n + | FileIn n | FileOut n -> pr ", &%s" n | OptString n -> pr ", &%s" n | StringList n | DeviceList n -> pr ", &py_%s" n | Bool n -> pr ", &%s" n @@ -9489,7 +10328,7 @@ py_guestfs_close (PyObject *self, PyObject *args) pr " g = get_handle (py_g);\n"; List.iter ( function - | Pathname _ | Device _ | Dev_or_Path _ | String _ + | Pathname _ | Device _ | Dev_or_Path _ | String _ | Key _ | FileIn _ | FileOut _ | OptString _ | Bool _ | Int _ | Int64 _ | BufferIn _ -> () | StringList n | DeviceList n -> @@ -9505,7 +10344,7 @@ py_guestfs_close (PyObject *self, PyObject *args) List.iter ( function - | Pathname _ | Device _ | Dev_or_Path _ | String _ + | Pathname _ | Device _ | Dev_or_Path _ | String _ | Key _ | FileIn _ | FileOut _ | OptString _ | Bool _ | Int _ | Int64 _ | BufferIn _ -> () | StringList n | DeviceList n -> @@ -9812,7 +10651,8 @@ static VALUE ruby_guestfs_close (VALUE gv) List.iter ( function - | Pathname n | Device n | Dev_or_Path n | String n | FileIn n | FileOut n -> + | Pathname n | Device n | Dev_or_Path n | String n | Key n + | FileIn n | FileOut n -> pr " Check_Type (%sv, T_STRING);\n" n; pr " const char *%s = StringValueCStr (%sv);\n" n n; pr " if (!%s)\n" n; @@ -9831,7 +10671,7 @@ static VALUE ruby_guestfs_close (VALUE gv) pr " char **%s;\n" n; pr " Check_Type (%sv, T_ARRAY);\n" n; pr " {\n"; - pr " int i, len;\n"; + pr " size_t i, len;\n"; pr " len = RARRAY_LEN (%sv);\n" n; pr " %s = guestfs_safe_malloc (g, sizeof (char *) * (len+1));\n" n; @@ -9873,7 +10713,7 @@ static VALUE ruby_guestfs_close (VALUE gv) List.iter ( function - | Pathname _ | Device _ | Dev_or_Path _ | String _ + | Pathname _ | Device _ | Dev_or_Path _ | String _ | Key _ | FileIn _ | FileOut _ | OptString _ | Bool _ | Int _ | Int64 _ | BufferIn _ -> () | StringList n | DeviceList n -> @@ -9903,7 +10743,7 @@ static VALUE ruby_guestfs_close (VALUE gv) pr " free (r);\n"; pr " return rv;\n"; | RStringList _ -> - pr " int i, len = 0;\n"; + pr " size_t i, len = 0;\n"; pr " for (i = 0; r[i] != NULL; ++i) len++;\n"; pr " VALUE rv = rb_ary_new2 (len);\n"; pr " for (i = 0; r[i] != NULL; ++i) {\n"; @@ -9920,7 +10760,7 @@ static VALUE ruby_guestfs_close (VALUE gv) generate_ruby_struct_list_code typ cols | RHashtable _ -> pr " VALUE rv = rb_hash_new ();\n"; - pr " int i;\n"; + pr " size_t i;\n"; pr " for (i = 0; r[i] != NULL; i+=2) {\n"; pr " rb_hash_aset (rv, rb_str_new2 (r[i]), rb_str_new2 (r[i+1]));\n"; pr " free (r[i]);\n"; @@ -9989,7 +10829,7 @@ and generate_ruby_struct_code typ cols = (* Ruby code to return a struct list. *) and generate_ruby_struct_list_code typ cols = pr " VALUE rv = rb_ary_new2 (r->len);\n"; - pr " int i;\n"; + pr " size_t i;\n"; pr " for (i = 0; i < r->len; ++i) {\n"; pr " VALUE hv = rb_hash_new ();\n"; List.iter ( @@ -10190,7 +11030,8 @@ and generate_java_prototype ?(public=false) ?(privat=false) ?(native=false) | String n | OptString n | FileIn n - | FileOut n -> + | FileOut n + | Key n -> pr "String %s" n | BufferIn n -> pr "byte[] %s" n @@ -10313,7 +11154,8 @@ Java_com_redhat_et_libguestfs_GuestFS__1close | String n | OptString n | FileIn n - | FileOut n -> + | FileOut n + | Key n -> pr ", jstring j%s" n | BufferIn n -> pr ", jbyteArray j%s" n @@ -10370,7 +11212,8 @@ Java_com_redhat_et_libguestfs_GuestFS__1close | String n | OptString n | FileIn n - | FileOut n -> + | FileOut n + | Key n -> pr " const char *%s;\n" n | BufferIn n -> pr " jbyte *%s;\n" n; @@ -10396,7 +11239,7 @@ Java_com_redhat_et_libguestfs_GuestFS__1close | DeviceList _ -> true | _ -> false) (snd style) in if needs_i then - pr " int i;\n"; + pr " size_t i;\n"; pr "\n"; @@ -10407,7 +11250,8 @@ Java_com_redhat_et_libguestfs_GuestFS__1close | Device n | Dev_or_Path n | String n | FileIn n - | FileOut n -> + | FileOut n + | Key n -> pr " %s = (*env)->GetStringUTFChars (env, j%s, NULL);\n" n n | OptString n -> (* This is completely undocumented, but Java null becomes @@ -10444,7 +11288,8 @@ Java_com_redhat_et_libguestfs_GuestFS__1close | Device n | Dev_or_Path n | String n | FileIn n - | FileOut n -> + | FileOut n + | Key n -> pr " (*env)->ReleaseStringUTFChars (env, j%s, %s);\n" n n | OptString n -> pr " if (j%s)\n" n; @@ -10725,7 +11570,7 @@ last_error h = do function | FileIn n | FileOut n - | Pathname n | Device n | Dev_or_Path n | String n -> + | Pathname n | Device n | Dev_or_Path n | String n | Key n -> pr "withCString %s $ \\%s -> " n n | BufferIn n -> pr "withCStringLen %s $ \\(%s, %s_size) -> " n n n @@ -10741,7 +11586,10 @@ last_error h = do | Int n -> sprintf "(fromIntegral %s)" n | Int64 n -> sprintf "(fromIntegral %s)" n | FileIn n | FileOut n - | Pathname n | Device n | Dev_or_Path n | String n | OptString n | StringList n | DeviceList n -> n + | Pathname n | Device n | Dev_or_Path n + | String n | OptString n + | StringList n | DeviceList n + | Key n -> n | BufferIn n -> sprintf "%s (fromIntegral %s_size)" n n ) (snd style) in pr "withForeignPtr h (\\p -> c_%s %s)\n" name @@ -10792,7 +11640,8 @@ and generate_haskell_prototype ~handle ?(hs = false) style = List.iter ( fun arg -> (match arg with - | Pathname _ | Device _ | Dev_or_Path _ | String _ -> pr "%s" string + | Pathname _ | Device _ | Dev_or_Path _ | String _ | Key _ -> + pr "%s" string | BufferIn _ -> if hs then pr "String" else pr "CString -> CInt" @@ -10986,6 +11835,7 @@ namespace Guestfs function | Pathname n | Device n | Dev_or_Path n | String n | OptString n | FileIn n | FileOut n + | Key n | BufferIn n -> pr ", [In] string %s" n | StringList n | DeviceList n -> @@ -11010,6 +11860,7 @@ namespace Guestfs function | Pathname n | Device n | Dev_or_Path n | String n | OptString n | FileIn n | FileOut n + | Key n | BufferIn n -> next (); pr "string %s" n | StringList n | DeviceList n -> @@ -11048,7 +11899,7 @@ namespace Guestfs pr " return r != 0 ? true : false;\n" | RHashtable _ -> pr " Hashtable rr = new Hashtable ();\n"; - pr " for (int i = 0; i < r.Length; i += 2)\n"; + pr " for (size_t i = 0; i < r.Length; i += 2)\n"; pr " rr.Add (r[i], r[i+1]);\n"; pr " return rr;\n" | RInt _ | RInt64 _ | RConstString _ | RConstOptString _ @@ -11085,7 +11936,7 @@ and generate_bindtests () = static void print_strings (char *const *argv) { - int argc; + size_t argc; printf (\"[\"); for (argc = 0; argv[argc] != NULL; ++argc) { @@ -11114,7 +11965,8 @@ print_strings (char *const *argv) | Device n | Dev_or_Path n | String n | FileIn n - | FileOut n -> pr " printf (\"%%s\\n\", %s);\n" n + | FileOut n + | Key n -> pr " printf (\"%%s\\n\", %s);\n" n | BufferIn n -> pr " {\n"; pr " size_t i;\n"; @@ -11500,494 +12352,6 @@ and generate_lang_bindtests call = (* XXX Add here tests of the return and error functions. *) -(* Code to generator bindings for virt-inspector. Currently only - * implemented for OCaml code (for virt-p2v 2.0). - *) -let rng_input = "inspector/virt-inspector.rng" - -(* Read the input file and parse it into internal structures. This is - * by no means a complete RELAX NG parser, but is just enough to be - * able to parse the specific input file. - *) -type rng = - | Element of string * rng list (* *) - | Attribute of string * rng list (* *) - | Interleave of rng list (* *) - | ZeroOrMore of rng (* *) - | OneOrMore of rng (* *) - | Optional of rng (* *) - | Choice of string list (* * *) - | Value of string (* str *) - | Text (* *) - -let rec string_of_rng = function - | Element (name, xs) -> - "Element (\"" ^ name ^ "\", (" ^ string_of_rng_list xs ^ "))" - | Attribute (name, xs) -> - "Attribute (\"" ^ name ^ "\", (" ^ string_of_rng_list xs ^ "))" - | Interleave xs -> "Interleave (" ^ string_of_rng_list xs ^ ")" - | ZeroOrMore rng -> "ZeroOrMore (" ^ string_of_rng rng ^ ")" - | OneOrMore rng -> "OneOrMore (" ^ string_of_rng rng ^ ")" - | Optional rng -> "Optional (" ^ string_of_rng rng ^ ")" - | Choice values -> "Choice [" ^ String.concat ", " values ^ "]" - | Value value -> "Value \"" ^ value ^ "\"" - | Text -> "Text" - -and string_of_rng_list xs = - String.concat ", " (List.map string_of_rng xs) - -let rec parse_rng ?defines context = function - | [] -> [] - | Xml.Element ("element", ["name", name], children) :: rest -> - Element (name, parse_rng ?defines context children) - :: parse_rng ?defines context rest - | Xml.Element ("attribute", ["name", name], children) :: rest -> - Attribute (name, parse_rng ?defines context children) - :: parse_rng ?defines context rest - | Xml.Element ("interleave", [], children) :: rest -> - Interleave (parse_rng ?defines context children) - :: parse_rng ?defines context rest - | Xml.Element ("zeroOrMore", [], [child]) :: rest -> - let rng = parse_rng ?defines context [child] in - (match rng with - | [child] -> ZeroOrMore child :: parse_rng ?defines context rest - | _ -> - failwithf "%s: contains more than one child element" - context - ) - | Xml.Element ("oneOrMore", [], [child]) :: rest -> - let rng = parse_rng ?defines context [child] in - (match rng with - | [child] -> OneOrMore child :: parse_rng ?defines context rest - | _ -> - failwithf "%s: contains more than one child element" - context - ) - | Xml.Element ("optional", [], [child]) :: rest -> - let rng = parse_rng ?defines context [child] in - (match rng with - | [child] -> Optional child :: parse_rng ?defines context rest - | _ -> - failwithf "%s: contains more than one child element" - context - ) - | Xml.Element ("choice", [], children) :: rest -> - let values = List.map ( - function Xml.Element ("value", [], [Xml.PCData value]) -> value - | _ -> - failwithf "%s: can't handle anything except in " - context - ) children in - Choice values - :: parse_rng ?defines context rest - | Xml.Element ("value", [], [Xml.PCData value]) :: rest -> - Value value :: parse_rng ?defines context rest - | Xml.Element ("text", [], []) :: rest -> - Text :: parse_rng ?defines context rest - | Xml.Element ("ref", ["name", name], []) :: rest -> - (* Look up the reference. Because of limitations in this parser, - * we can't handle arbitrarily nested yet. You can only - * use from inside . - *) - (match defines with - | None -> - failwithf "%s: contains , but no refs are defined yet" context - | Some map -> - let rng = StringMap.find name map in - rng @ parse_rng ?defines context rest - ) - | x :: _ -> - failwithf "%s: can't handle '%s' in schema" context (Xml.to_string x) - -let grammar = - let xml = Xml.parse_file rng_input in - match xml with - | Xml.Element ("grammar", _, - Xml.Element ("start", _, gram) :: defines) -> - (* The elements are referenced in the section, - * so build a map of those first. - *) - let defines = List.fold_left ( - fun map -> - function Xml.Element ("define", ["name", name], defn) -> - StringMap.add name defn map - | _ -> - failwithf "%s: expected " rng_input - ) StringMap.empty defines in - let defines = StringMap.mapi parse_rng defines in - - (* Parse the clause, passing the defines. *) - parse_rng ~defines "" gram - | _ -> - failwithf "%s: input is not *" - rng_input - -let name_of_field = function - | Element (name, _) | Attribute (name, _) - | ZeroOrMore (Element (name, _)) - | OneOrMore (Element (name, _)) - | Optional (Element (name, _)) -> name - | Optional (Attribute (name, _)) -> name - | Text -> (* an unnamed field in an element *) - "data" - | rng -> - failwithf "name_of_field failed at: %s" (string_of_rng rng) - -(* At the moment this function only generates OCaml types. However we - * should parameterize it later so it can generate types/structs in a - * variety of languages. - *) -let generate_types xs = - (* A simple type is one that can be printed out directly, eg. - * "string option". A complex type is one which has a name and has - * to be defined via another toplevel definition, eg. a struct. - * - * generate_type generates code for either simple or complex types. - * In the simple case, it returns the string ("string option"). In - * the complex case, it returns the name ("mountpoint"). In the - * complex case it has to print out the definition before returning, - * so it should only be called when we are at the beginning of a - * new line (BOL context). - *) - let rec generate_type = function - | Text -> (* string *) - "string", true - | Choice values -> (* [`val1|`val2|...] *) - "[" ^ String.concat "|" (List.map ((^)"`") values) ^ "]", true - | ZeroOrMore rng -> (* list *) - let t, is_simple = generate_type rng in - t ^ " list (* 0 or more *)", is_simple - | OneOrMore rng -> (* list *) - let t, is_simple = generate_type rng in - t ^ " list (* 1 or more *)", is_simple - (* virt-inspector hack: bool *) - | Optional (Attribute (name, [Value "1"])) -> - "bool", true - | Optional rng -> (* list *) - let t, is_simple = generate_type rng in - t ^ " option", is_simple - (* type name = { fields ... } *) - | Element (name, fields) when is_attrs_interleave fields -> - generate_type_struct name (get_attrs_interleave fields) - | Element (name, [field]) (* type name = field *) - | Attribute (name, [field]) -> - let t, is_simple = generate_type field in - if is_simple then (t, true) - else ( - pr "type %s = %s\n" name t; - name, false - ) - | Element (name, fields) -> (* type name = { fields ... } *) - generate_type_struct name fields - | rng -> - failwithf "generate_type failed at: %s" (string_of_rng rng) - - and is_attrs_interleave = function - | [Interleave _] -> true - | Attribute _ :: fields -> is_attrs_interleave fields - | Optional (Attribute _) :: fields -> is_attrs_interleave fields - | _ -> false - - and get_attrs_interleave = function - | [Interleave fields] -> fields - | ((Attribute _) as field) :: fields - | ((Optional (Attribute _)) as field) :: fields -> - field :: get_attrs_interleave fields - | _ -> assert false - - and generate_types xs = - List.iter (fun x -> ignore (generate_type x)) xs - - and generate_type_struct name fields = - (* Calculate the types of the fields first. We have to do this - * before printing anything so we are still in BOL context. - *) - let types = List.map fst (List.map generate_type fields) in - - (* Special case of a struct containing just a string and another - * field. Turn it into an assoc list. - *) - match types with - | ["string"; other] -> - let fname1, fname2 = - match fields with - | [f1; f2] -> name_of_field f1, name_of_field f2 - | _ -> assert false in - pr "type %s = string * %s (* %s -> %s *)\n" name other fname1 fname2; - name, false - - | types -> - pr "type %s = {\n" name; - List.iter ( - fun (field, ftype) -> - let fname = name_of_field field in - pr " %s_%s : %s;\n" name fname ftype - ) (List.combine fields types); - pr "}\n"; - (* Return the name of this type, and - * false because it's not a simple type. - *) - name, false - in - - generate_types xs - -let generate_parsers xs = - (* As for generate_type above, generate_parser makes a parser for - * some type, and returns the name of the parser it has generated. - * Because it (may) need to print something, it should always be - * called in BOL context. - *) - let rec generate_parser = function - | Text -> (* string *) - "string_child_or_empty" - | Choice values -> (* [`val1|`val2|...] *) - sprintf "(fun x -> match Xml.pcdata (first_child x) with %s | str -> failwith (\"unexpected field value: \" ^ str))" - (String.concat "|" - (List.map (fun v -> sprintf "%S -> `%s" v v) values)) - | ZeroOrMore rng -> (* list *) - let pa = generate_parser rng in - sprintf "(fun x -> List.map %s (Xml.children x))" pa - | OneOrMore rng -> (* list *) - let pa = generate_parser rng in - sprintf "(fun x -> List.map %s (Xml.children x))" pa - (* virt-inspector hack: bool *) - | Optional (Attribute (name, [Value "1"])) -> - sprintf "(fun x -> try ignore (Xml.attrib x %S); true with Xml.No_attribute _ -> false)" name - | Optional rng -> (* list *) - let pa = generate_parser rng in - sprintf "(function None -> None | Some x -> Some (%s x))" pa - (* type name = { fields ... } *) - | Element (name, fields) when is_attrs_interleave fields -> - generate_parser_struct name (get_attrs_interleave fields) - | Element (name, [field]) -> (* type name = field *) - let pa = generate_parser field in - let parser_name = sprintf "parse_%s_%d" name (unique ()) in - pr "let %s =\n" parser_name; - pr " %s\n" pa; - pr "let parse_%s = %s\n" name parser_name; - parser_name - | Attribute (name, [field]) -> - let pa = generate_parser field in - let parser_name = sprintf "parse_%s_%d" name (unique ()) in - pr "let %s =\n" parser_name; - pr " %s\n" pa; - pr "let parse_%s = %s\n" name parser_name; - parser_name - | Element (name, fields) -> (* type name = { fields ... } *) - generate_parser_struct name ([], fields) - | rng -> - failwithf "generate_parser failed at: %s" (string_of_rng rng) - - and is_attrs_interleave = function - | [Interleave _] -> true - | Attribute _ :: fields -> is_attrs_interleave fields - | Optional (Attribute _) :: fields -> is_attrs_interleave fields - | _ -> false - - and get_attrs_interleave = function - | [Interleave fields] -> [], fields - | ((Attribute _) as field) :: fields - | ((Optional (Attribute _)) as field) :: fields -> - let attrs, interleaves = get_attrs_interleave fields in - (field :: attrs), interleaves - | _ -> assert false - - and generate_parsers xs = - List.iter (fun x -> ignore (generate_parser x)) xs - - and generate_parser_struct name (attrs, interleaves) = - (* Generate parsers for the fields first. We have to do this - * before printing anything so we are still in BOL context. - *) - let fields = attrs @ interleaves in - let pas = List.map generate_parser fields in - - (* Generate an intermediate tuple from all the fields first. - * If the type is just a string + another field, then we will - * return this directly, otherwise it is turned into a record. - * - * RELAX NG note: This code treats and plain lists of - * fields the same. In other words, it doesn't bother enforcing - * any ordering of fields in the XML. - *) - pr "let parse_%s x =\n" name; - pr " let t = (\n "; - let comma = ref false in - List.iter ( - fun x -> - if !comma then pr ",\n "; - comma := true; - match x with - | Optional (Attribute (fname, [field])), pa -> - pr "%s x" pa - | Optional (Element (fname, [field])), pa -> - pr "%s (optional_child %S x)" pa fname - | Attribute (fname, [Text]), _ -> - pr "attribute %S x" fname - | (ZeroOrMore _ | OneOrMore _), pa -> - pr "%s x" pa - | Text, pa -> - pr "%s x" pa - | (field, pa) -> - let fname = name_of_field field in - pr "%s (child %S x)" pa fname - ) (List.combine fields pas); - pr "\n ) in\n"; - - (match fields with - | [Element (_, [Text]) | Attribute (_, [Text]); _] -> - pr " t\n" - - | _ -> - pr " (Obj.magic t : %s)\n" name -(* - List.iter ( - function - | (Optional (Attribute (fname, [field])), pa) -> - pr " %s_%s =\n" name fname; - pr " %s x;\n" pa - | (Optional (Element (fname, [field])), pa) -> - pr " %s_%s =\n" name fname; - pr " (let x = optional_child %S x in\n" fname; - pr " %s x);\n" pa - | (field, pa) -> - let fname = name_of_field field in - pr " %s_%s =\n" name fname; - pr " (let x = child %S x in\n" fname; - pr " %s x);\n" pa - ) (List.combine fields pas); - pr "}\n" -*) - ); - sprintf "parse_%s" name - in - - generate_parsers xs - -(* Generate ocaml/guestfs_inspector.mli. *) -let generate_ocaml_inspector_mli () = - generate_header ~extra_inputs:[rng_input] OCamlStyle LGPLv2plus; - - pr "\ -(** This is an OCaml language binding to the external [virt-inspector] - program. - - For more information, please read the man page [virt-inspector(1)]. -*) - -"; - - generate_types grammar; - pr "(** The nested information returned from the {!inspect} function. *)\n"; - pr "\n"; - - pr "\ -val inspect : ?connect:string -> ?xml:string -> string list -> operatingsystems -(** To inspect a libvirt domain called [name], pass a singleton - list: [inspect [name]]. When using libvirt only, you may - optionally pass a libvirt URI using [inspect ~connect:uri ...]. - - To inspect a disk image or images, pass a list of the filenames - of the disk images: [inspect filenames] - - This function inspects the given guest or disk images and - returns a list of operating system(s) found and a large amount - of information about them. In the vast majority of cases, - a virtual machine only contains a single operating system. - - If the optional [~xml] parameter is given, then this function - skips running the external virt-inspector program and just - parses the given XML directly (which is expected to be XML - produced from a previous run of virt-inspector). The list of - names and connect URI are ignored in this case. - - This function can throw a wide variety of exceptions, for example - if the external virt-inspector program cannot be found, or if - it doesn't generate valid XML. -*) -" - -(* Generate ocaml/guestfs_inspector.ml. *) -let generate_ocaml_inspector_ml () = - generate_header ~extra_inputs:[rng_input] OCamlStyle LGPLv2plus; - - pr "open Unix\n"; - pr "\n"; - - generate_types grammar; - pr "\n"; - - pr "\ -(* Misc functions which are used by the parser code below. *) -let first_child = function - | Xml.Element (_, _, c::_) -> c - | Xml.Element (name, _, []) -> - failwith (\"expected <\" ^ name ^ \"/> to have a child node\") - | Xml.PCData str -> - failwith (\"expected XML tag, but read PCDATA '\" ^ str ^ \"' instead\") - -let string_child_or_empty = function - | Xml.Element (_, _, [Xml.PCData s]) -> s - | Xml.Element (_, _, []) -> \"\" - | Xml.Element (x, _, _) -> - failwith (\"expected XML tag with a single PCDATA child, but got \" ^ - x ^ \" instead\") - | Xml.PCData str -> - failwith (\"expected XML tag, but read PCDATA '\" ^ str ^ \"' instead\") - -let optional_child name xml = - let children = Xml.children xml in - try - Some (List.find (function - | Xml.Element (n, _, _) when n = name -> true - | _ -> false) children) - with - Not_found -> None - -let child name xml = - match optional_child name xml with - | Some c -> c - | None -> - failwith (\"mandatory field <\" ^ name ^ \"/> missing in XML output\") - -let attribute name xml = - try Xml.attrib xml name - with Xml.No_attribute _ -> - failwith (\"mandatory attribute \" ^ name ^ \" missing in XML output\") - -"; - - generate_parsers grammar; - pr "\n"; - - pr "\ -(* Run external virt-inspector, then use parser to parse the XML. *) -let inspect ?connect ?xml names = - let xml = - match xml with - | None -> - if names = [] then invalid_arg \"inspect: no names given\"; - let cmd = [ \"virt-inspector\"; \"--xml\" ] @ - (match connect with None -> [] | Some uri -> [ \"--connect\"; uri ]) @ - names in - let cmd = List.map Filename.quote cmd in - let cmd = String.concat \" \" cmd in - let chan = open_process_in cmd in - let xml = Xml.parse_in chan in - (match close_process_in chan with - | WEXITED 0 -> () - | WEXITED _ -> failwith \"external virt-inspector command failed\" - | WSIGNALED i | WSTOPPED i -> - failwith (\"external virt-inspector command died or stopped on sig \" ^ - string_of_int i) - ); - xml - | Some doc -> - Xml.parse_string doc in - parse_operatingsystems xml -" - and generate_max_proc_nr () = pr "%d\n" max_proc_nr @@ -12047,8 +12411,8 @@ Run it from the top source directory using the command output_to "src/guestfs-structs.h" generate_structs_h; output_to "src/guestfs-actions.h" generate_actions_h; output_to "src/guestfs-internal-actions.h" generate_internal_actions_h; - output_to "src/guestfs-actions.c" generate_client_actions; - output_to "src/guestfs-bindtests.c" generate_bindtests; + output_to "src/actions.c" generate_client_actions; + output_to "src/bindtests.c" generate_bindtests; output_to "src/guestfs-structs.pod" generate_structs_pod; output_to "src/guestfs-actions.pod" generate_actions_pod; output_to "src/guestfs-availability.pod" generate_availability_pod; @@ -12067,8 +12431,6 @@ Run it from the top source directory using the command output_to "ocaml/guestfs.ml" generate_ocaml_ml; output_to "ocaml/guestfs_c_actions.c" generate_ocaml_c; output_to "ocaml/bindtests.ml" generate_ocaml_bindtests; - output_to "ocaml/guestfs_inspector.mli" generate_ocaml_inspector_mli; - output_to "ocaml/guestfs_inspector.ml" generate_ocaml_inspector_ml; output_to "perl/Guestfs.xs" generate_perl_xs; output_to "perl/lib/Sys/Guestfs.pm" generate_perl_pm; output_to "perl/bindtests.pl" generate_perl_bindtests;