X-Git-Url: http://git.annexia.org/?p=libguestfs.git;a=blobdiff_plain;f=src%2Fgenerator.ml;h=743118be17733a1836f27dfb699dc9ae4e172c4e;hp=571870da326b68203890d98e0968165530bacf67;hb=867319ec5f9030d3c14c32e3302606f2bf11ac27;hpb=eb566f7dc7974b42ac65729a2e5e5bcee329a0a9 diff --git a/src/generator.ml b/src/generator.ml index 571870d..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 *) @@ -551,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 @@ -850,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 @@ -934,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 @@ -1963,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"]; @@ -2323,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"]; @@ -4318,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")], @@ -4501,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"]; @@ -4514,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", @@ -4693,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")], @@ -4818,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 @@ -4830,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."); ] @@ -5253,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 @@ -5276,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." @@ -5581,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. @@ -5610,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 @@ -5686,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. *) @@ -5719,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 @@ -5754,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; @@ -5766,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; @@ -5800,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 */ @@ -5816,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; }; @@ -5838,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. *) @@ -5924,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, @@ -6005,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; @@ -6034,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 *) @@ -6047,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 @@ -6140,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 @@ -6336,12 +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 @@ -6349,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) @@ -6418,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 @@ -6475,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 @@ -6632,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"; @@ -6857,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]); @@ -6866,7 +7429,7 @@ 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]); @@ -7487,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); @@ -7521,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" @@ -7542,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 @@ -7668,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 @@ -7833,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 @@ -7844,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; @@ -7852,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"; @@ -7879,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. *) @@ -7925,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 @@ -8101,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) { @@ -8182,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" @@ -8190,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"; @@ -8199,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; @@ -8253,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 -> @@ -8339,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 (); @@ -8363,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 \"\"); @@ -8395,7 +9015,7 @@ and generate_ocaml_c () = #include #include -#include +#include \"guestfs.h\" #include \"guestfs_c.h\" @@ -8408,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) { @@ -8562,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 -> @@ -8590,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) -> @@ -8598,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 _ -> @@ -8613,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; @@ -8706,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 -> " @@ -8806,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 @@ -8833,19 +9497,34 @@ DESTROY (sv) SV **svp = hv_fetch (hv, \"_g\", 2, 0); if (svp != NULL) { guestfs_h *g = (guestfs_h *) SvIV (*svp); - assert (g != NULL); - guestfs_close (g); + _close_handle (g); } void close (g) guestfs_h *g; PPCODE: - guestfs_close (g); + _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: + _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); + "; List.iter ( @@ -8875,7 +9554,7 @@ close (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; @@ -8898,7 +9577,7 @@ close (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 @@ -8986,7 +9665,7 @@ close (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; @@ -9030,7 +9709,7 @@ close (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; @@ -9219,6 +9898,25 @@ 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; @@ -9294,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 @@ -9321,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); @@ -9356,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\"); @@ -9428,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); } @@ -9454,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; @@ -9560,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 @@ -9581,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? *) @@ -9595,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 @@ -9610,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 -> @@ -9626,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 -> @@ -9933,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; @@ -9952,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; @@ -9994,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 -> @@ -10024,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"; @@ -10041,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"; @@ -10110,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 ( @@ -10311,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 @@ -10434,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 @@ -10491,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; @@ -10517,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"; @@ -10528,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 @@ -10565,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; @@ -10846,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 @@ -10862,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 @@ -10913,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" @@ -11107,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 -> @@ -11131,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 -> @@ -11169,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 _ @@ -11206,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) { @@ -11235,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"; @@ -11621,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 @@ -12168,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; @@ -12188,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;