[Libguestfs] [PATCH 3/4] common/mltools: allow fd for machine readable output

[Richard W.M. Jones]

On Fri, Mar 22, 2019 at 04:33:42PM +0100, Pino Toscano wrote:
> Allow to specify a file descriptor for the machine readable output.
> 
> Sadly, the OCaml C glue for the channels is not public API, so enable
> the internals for this...
> ---
>  common/mltools/tools_utils-c.c | 17 +++++++++++++++++
>  common/mltools/tools_utils.ml  | 10 +++++++++-
>  lib/guestfs.pod                |  5 +++++
>  3 files changed, 31 insertions(+), 1 deletion(-)
> 
> diff --git a/common/mltools/tools_utils-c.c b/common/mltools/tools_utils-c.c
> index c88c95082..553aa6631 100644
> --- a/common/mltools/tools_utils-c.c
> +++ b/common/mltools/tools_utils-c.c
> @@ -29,6 +29,9 @@
>  #include <caml/memory.h>
>  #include <caml/mlvalues.h>
>  #include <caml/unixsupport.h>
> +/* Evil ... */
> +#define CAML_INTERNALS
> +#include <caml/io.h>

I think this is not necessary.  On Unix-like platforms,
Unix.file_descr is really just an int, so you can cast between the two
using Val_int/Int_val (from C) or Obj.magic (from OCaml).  Note we
already rely on this in libguestfs, in
v2v/qemuopts-c.c:guestfs_int_qemuopts_to_chan

So I think this should work:

  | Fd of Unix.file_descr

...

  | Fd fd -> Some (Unix.out_channel_of_descr fd)

...

  | "fd" ->
    machine_readable_output := Fd (Obj.magic (int_of_string outname))

If you don't want to use Obj.magic, then something using /dev/fd/<N>
is another possibility.

Rich.

>  
>  #include <guestfs.h>
>  
> @@ -37,6 +40,7 @@
>  extern value guestfs_int_mllib_inspect_decrypt (value gv, value gpv, value keysv);
>  extern value guestfs_int_mllib_set_echo_keys (value unitv);
>  extern value guestfs_int_mllib_set_keys_from_stdin (value unitv);
> +extern value guestfs_int_mllib_open_out_channel_from_fd (value fdv);
>  
>  /* Interface with the guestfish inspection and decryption code. */
>  int echo_keys = 0;
> @@ -103,3 +107,16 @@ guestfs_int_mllib_set_keys_from_stdin (value unitv)
>    keys_from_stdin = 1;
>    return Val_unit;
>  }
> +
> +value
> +guestfs_int_mllib_open_out_channel_from_fd (value fdv)
> +{
> +  CAMLparam1 (fdv);
> +  struct channel *chan;
> +
> +  chan = caml_open_descriptor_out (Int_val (fdv));
> +  if (!chan)
> +    caml_raise_out_of_memory ();
> +
> +  CAMLreturn (caml_alloc_channel (chan));
> +}
> diff --git a/common/mltools/tools_utils.ml b/common/mltools/tools_utils.ml
> index ade4cb37f..3c54cd4a0 100644
> --- a/common/mltools/tools_utils.ml
> +++ b/common/mltools/tools_utils.ml
> @@ -32,6 +32,7 @@ and key_store_key =
>  external c_inspect_decrypt : Guestfs.t -> int64 -> (string * key_store_key) list -> unit = "guestfs_int_mllib_inspect_decrypt"
>  external c_set_echo_keys : unit -> unit = "guestfs_int_mllib_set_echo_keys" "noalloc"
>  external c_set_keys_from_stdin : unit -> unit = "guestfs_int_mllib_set_keys_from_stdin" "noalloc"
> +external c_out_channel_from_fd : int -> out_channel = "guestfs_int_mllib_open_out_channel_from_fd"
>  
>  type machine_readable_fn = {
>    pr : 'a. ('a, unit, string, unit) format4 -> 'a;
> @@ -41,6 +42,7 @@ type machine_readable_output_type =
>    | NoOutput
>    | Channel of out_channel
>    | File of string
> +  | Fd of int
>  let machine_readable_output = ref NoOutput
>  let machine_readable_channel = ref None
>  let machine_readable () =
> @@ -50,7 +52,8 @@ let machine_readable () =
>          match !machine_readable_output with
>          | NoOutput -> None
>          | Channel chan -> Some chan
> -        | File f -> Some (open_out f) in
> +        | File f -> Some (open_out f)
> +        | Fd fd -> Some (c_out_channel_from_fd fd) in
>        machine_readable_channel := chan
>      );
>      !machine_readable_channel
> @@ -296,6 +299,11 @@ let create_standard_options argspec ?anon_fun ?(key_opts = false) ?(machine_read
>            | n ->
>              error (f_"invalid output stream for --machine-readable: %s") fmt in
>          machine_readable_output := Channel chan
> +      | "fd" ->
> +        (try
> +          machine_readable_output := Fd (int_of_string outname)
> +        with Failure _ ->
> +          error (f_"invalid output fd for --machine-readable: %s") fmt)
>        | n ->
>          error (f_"invalid output for --machine-readable: %s") fmt
>        )
> diff --git a/lib/guestfs.pod b/lib/guestfs.pod
> index 53cece2da..f11028466 100644
> --- a/lib/guestfs.pod
> +++ b/lib/guestfs.pod
> @@ -3287,6 +3287,11 @@ The possible values are:
>  
>  =over 4
>  
> +=item B<fd:>I<fd>
> +
> +The output goes to the specified I<fd>, which is a file descriptor
> +already opened for writing.
> +
>  =item B<file:>F<filename>
>  
>  The output goes to the specified F<filename>.
> -- 
> 2.20.1
> 
> _______________________________________________
> Libguestfs mailing list
> Libguestfs at redhat.com
> https://www.redhat.com/mailman/listinfo/libguestfs

-- 
Richard Jones, Virtualization Group, Red Hat http://people.redhat.com/~rjones
Read my programming and virtualization blog: http://rwmj.wordpress.com
virt-df lists disk usage of guests without needing to install any
software inside the virtual machine.  Supports Linux and Windows.
http://people.redhat.com/~rjones/virt-df/