OCaml tools: add output selection for --machine-readable

Add an optional argument for --machine-readable to select the output,
adding a new function to specifically write data to that output stream.
The possible choices are:
* --machine-readable: to stdout, like before
* --machine-readable=file:name-of-file: to the specified file
* --machine-readable=stream:stdout: explicitly to stdout
* --machine-readable=stream:stderr: explicitly to stderr

Adapt all the OCaml-based tools to use the new function, so the
--machine-readable choice is respected.

.gitignore

@@ -146,6 +146,7 @@ Makefile.in
 /common/mltools/getopt_tests
 /common/mltools/JSON_tests
 /common/mltools/JSON_parser_tests
+/common/mltools/machine_readable_tests
 /common/mltools/tools_utils_tests
 /common/mltools/oUnit-*
 /common/mlutils/.depend

builder/cmdline.ml

@@ -217,14 +217,16 @@ read the man page virt-builder(1).
   let warn_if_partition = !warn_if_partition in
 
   (* No arguments and machine-readable mode?  Print some facts. *)
-  if args = [] && machine_readable () then (
-    printf "virt-builder\n";
-    printf "arch\n";
-    printf "config-file\n";
-    printf "customize\n";
-    printf "json-list\n";
-    if Pxzcat.using_parallel_xzcat () then printf "pxzcat\n";
+  (match args, machine_readable () with
+  | [], Some { pr } ->
+    pr "virt-builder\n";
+    pr "arch\n";
+    pr "config-file\n";
+    pr "customize\n";
+    pr "json-list\n";
+    if Pxzcat.using_parallel_xzcat () then pr "pxzcat\n";
     exit 0
+  | _, _ -> ()
   );
 
   (* Check options. *)

builder/repository_main.ml

@@ -74,9 +74,11 @@ read the man page virt-builder-repository(1).
   (* Machine-readable mode?  Print out some facts about what
    * this binary supports.
    *)
-  if machine_readable () then (
-    printf "virt-builder-repository\n";
+  (match machine_readable () with
+  | Some { pr } ->
+    pr "virt-builder-repository\n";
     exit 0
+  | None -> ()
   );
 
   (* Dereference options. *)

builder/virt-builder-repository.pod

@@ -133,6 +133,8 @@ Don’t compress the template images.
 
 =item B<--machine-readable>
 
+=item B<--machine-readable>=format
+
 This option is used to make the output more machine friendly
 when being parsed by other programs.  See
 L</MACHINE READABLE OUTPUT> below.
@@ -188,6 +190,9 @@ virt-builder-repository binary.  Typical output looks like this:
 A list of features is printed, one per line, and the program exits
 with status 0.
 
+It is possible to specify a format string for controlling the output;
+see L<guestfs(3)/ADVANCED MACHINE READABLE OUTPUT>.
+
 =head1 EXIT STATUS
 
 This program returns 0 if successful, or non-zero if there was an

builder/virt-builder.pod

@@ -369,6 +369,8 @@ See also: I<--source>, I<--notes>, L</SOURCES OF TEMPLATES>.
 
 =item B<--machine-readable>
 
+=item B<--machine-readable>=format
+
 This option is used to make the output more machine friendly
 when being parsed by other programs.  See
 L</MACHINE READABLE OUTPUT> below.
@@ -1803,6 +1805,9 @@ virt-builder binary.  Typical output looks like this:
 A list of features is printed, one per line, and the program exits
 with status 0.
 
+It is possible to specify a format string for controlling the output;
+see L<guestfs(3)/ADVANCED MACHINE READABLE OUTPUT>.
+
 =head1 ENVIRONMENT VARIABLES
 
 For other environment variables which affect all libguestfs programs,

common/mlstdutils/std_utils.ml

@@ -645,10 +645,6 @@ let verbose = ref false
 let set_verbose () = verbose := true
 let verbose () = !verbose
 
-let machine_readable = ref false
-let set_machine_readable () = machine_readable := true
-let machine_readable () = !machine_readable
-
 let with_open_in filename f =
   let chan = open_in filename in
   protect ~f:(fun () -> f chan) ~finally:(fun () -> close_in chan)

common/mlstdutils/std_utils.mli

@@ -374,11 +374,8 @@ val set_trace : unit -> unit
 val trace : unit -> bool
 val set_verbose : unit -> unit
 val verbose : unit -> bool
-val set_machine_readable : unit -> unit
-val machine_readable : unit -> bool
-(** Stores the colours ([--colours]), quiet ([--quiet]), trace ([-x]),
-    verbose ([-v]), and machine readable ([--machine-readable]) flags
-    in global variables. *)
+(** Stores the colours ([--colours]), quiet ([--quiet]), trace ([-x]) and
+    verbose ([-v]) flags in global variables. *)
 
 val with_open_in : string -> (in_channel -> 'a) -> 'a
 (** [with_open_in filename f] calls function [f] with [filename]

common/mltools/Makefile.am

@@ -24,6 +24,7 @@ EXTRA_DIST = \
 	getopt_tests.ml \
 	JSON_tests.ml \
 	JSON_parser_tests.ml \
+	machine_readable_tests.ml \
 	test-getopt.sh \
 	tools_utils_tests.ml
 
@@ -185,6 +186,15 @@ JSON_parser_tests_BOBJECTS = \
 	JSON_parser_tests.cmo
 JSON_parser_tests_XOBJECTS = $(JSON_parser_tests_BOBJECTS:.cmo=.cmx)
 
+machine_readable_tests_SOURCES = dummy.c
+machine_readable_tests_CPPFLAGS = \
+	-I. \
+	-I$(top_builddir) \
+	-I$(shell $(OCAMLC) -where) \
+	-I$(top_srcdir)/lib
+machine_readable_tests_BOBJECTS = machine_readable_tests.cmo
+machine_readable_tests_XOBJECTS = $(machine_readable_tests_BOBJECTS:.cmo=.cmx)
+
 # Can't call the following as <test>_OBJECTS because automake gets confused.
 if !HAVE_OCAMLOPT
 tools_utils_tests_THEOBJECTS = $(tools_utils_tests_BOBJECTS)
@@ -198,6 +208,9 @@ JSON_tests.cmo: OCAMLPACKAGES += $(OCAMLPACKAGES_TESTS)
 
 JSON_parser_tests_THEOBJECTS = $(JSON_parser_tests_BOBJECTS)
 JSON_parser_tests.cmo: OCAMLPACKAGES += $(OCAMLPACKAGES_TESTS)
+
+machine_readable_tests_THEOBJECTS = $(machine_readable_tests_BOBJECTS)
+machine_readable_tests.cmo: OCAMLPACKAGES += $(OCAMLPACKAGES_TESTS)
 else
 tools_utils_tests_THEOBJECTS = $(tools_utils_tests_XOBJECTS)
 tools_utils_tests.cmx: OCAMLPACKAGES += $(OCAMLPACKAGES_TESTS)
@@ -210,6 +223,9 @@ JSON_tests.cmx: OCAMLPACKAGES += $(OCAMLPACKAGES_TESTS)
 
 JSON_parser_tests_THEOBJECTS = $(JSON_parser_tests_XOBJECTS)
 JSON_parser_tests.cmx: OCAMLPACKAGES += $(OCAMLPACKAGES_TESTS)
+
+machine_readable_tests_THEOBJECTS = $(machine_readable_tests_XOBJECTS)
+machine_readable_tests.cmx: OCAMLPACKAGES += $(OCAMLPACKAGES_TESTS)
 endif
 
 OCAMLLINKFLAGS = \
@@ -272,12 +288,27 @@ JSON_parser_tests_LINK = \
 	  $(OCAMLPACKAGES) $(OCAMLPACKAGES_TESTS) \
 	  $(JSON_parser_tests_THEOBJECTS) -o $@
 
+machine_readable_tests_DEPENDENCIES = \
+	$(machine_readable_tests_THEOBJECTS) \
+	../mlstdutils/mlstdutils.$(MLARCHIVE) \
+	../mlgettext/mlgettext.$(MLARCHIVE) \
+	../mlpcre/mlpcre.$(MLARCHIVE) \
+	$(MLTOOLS_CMA) \
+	$(top_srcdir)/ocaml-link.sh
+machine_readable_tests_LINK = \
+	$(top_srcdir)/ocaml-link.sh -cclib '-lutils -lgnu' -- \
+	  $(OCAMLFIND) $(BEST) $(OCAMLFLAGS) $(OCAMLLINKFLAGS) \
+	  $(OCAMLPACKAGES) $(OCAMLPACKAGES_TESTS) \
+	  $(machine_readable_tests_THEOBJECTS) -o $@
+
 TESTS_ENVIRONMENT = $(top_builddir)/run --test
 
 TESTS = \
-	test-getopt.sh
+	test-getopt.sh \
+	test-machine-readable.sh
 check_PROGRAMS = \
-	getopt_tests
+	getopt_tests \
+	machine_readable_tests
 
 if HAVE_OCAML_PKG_OUNIT
 check_PROGRAMS += JSON_tests JSON_parser_tests tools_utils_tests

common/mltools/machine_readable_tests.ml

@@ -0,0 +1,41 @@
+(*
+ * Copyright (C) 2018 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+(* Test the --machine-readable functionality of the module Tools_utils.
+ * The tests are controlled by the test-machine_readable.sh script.
+ *)
+
+open Printf
+
+open Std_utils
+open Tools_utils
+open Getopt.OptionName
+
+let usage_msg = sprintf "%s: test the --machine-readable functionality" prog
+
+let opthandle = create_standard_options [] ~machine_readable:true usage_msg
+let () =
+  Getopt.parse opthandle;
+
+  print_endline "on-stdout";
+  prerr_endline "on-stderr";
+
+  match machine_readable () with
+  | Some { pr } ->
+    pr "machine-readable\n"
+  | None -> ()

common/mltools/test-machine-readable.sh

@@ -0,0 +1,67 @@
+#!/bin/bash -
+# libguestfs
+# Copyright (C) 2018 Red Hat Inc.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+# Test the --machine-readable functionality of the module Tools_utils.
+# See also: machine_readable_tests.ml
+
+set -e
+set -x
+
+$TEST_FUNCTIONS
+skip_if_skipped
+
+t=./machine_readable_tests
+
+tmpdir="$(mktemp -d)"
+mkdir -p "$tmpdir"
+
+# Clean up if the script is killed or exits early.
+cleanup ()
+{
+    status=$?
+    rm -rf "$tmpdir"
+    exit $status
+}
+trap cleanup INT QUIT TERM EXIT ERR
+
+# Program works.
+$t
+
+# No machine-readable output.
+$t | grep 'machine-readable' && test $? = 1
+test $($t | wc -l) -eq 1
+test $($t |& wc -l) -eq 2
+
+# Default output: stdout.
+$t --machine-readable | grep 'machine-readable'
+test $($t --machine-readable | wc -l) -eq 2
+test $($t --machine-readable |& wc -l) -eq 3
+
+# Output "file:".
+fn="$tmpdir/file"
+$t --machine-readable=file:"$fn"
+test $(cat "$fn" | wc -l) -eq 1
+
+# Output "stream:stdout".
+$t --machine-readable=stream:stdout | grep 'machine-readable'
+test $($t --machine-readable=stream:stdout | wc -l) -eq 2
+test $($t --machine-readable=stream:stdout |& wc -l) -eq 3
+
+# Output "stream:stderr".
+$t --machine-readable=stream:stderr 2>&1 >/dev/null | grep 'machine-readable'
+test $($t --machine-readable=stream:stderr 2>&1 >/dev/null | wc -l) -eq 2

common/mltools/tools_utils.ml

@@ -229,10 +229,61 @@ let human_size i =
     )
   )
 
+type machine_readable_fn = {
+  pr : 'a. ('a, unit, string, unit) format4 -> 'a;
+} (* [@@unboxed] *)
+
+type machine_readable_output_type =
+  | NoOutput
+  | Channel of out_channel
+  | File of string
+let machine_readable_output = ref NoOutput
+let machine_readable_channel = ref None
+let machine_readable () =
+  let chan =
+    if !machine_readable_channel = None then (
+      let chan =
+        match !machine_readable_output with
+        | NoOutput -> None
+        | Channel chan -> Some chan
+        | File f -> Some (open_out f) in
+      machine_readable_channel := chan
+    );
+    !machine_readable_channel
+  in
+  match chan with
+  | None -> None
+  | Some chan ->
+    let pr fs =
+      ksprintf (output_string chan) fs
+    in
+    Some { pr }
+
 let create_standard_options argspec ?anon_fun ?(key_opts = false) ?(machine_readable = false) usage_msg =
   (** Install an exit hook to check gc consistency for --debug-gc *)
   let set_debug_gc () =
     at_exit (fun () -> Gc.compact()) in
+  let parse_machine_readable = function
+    | None ->
+      machine_readable_output := Channel stdout
+    | Some fmt ->
+      let outtype, outname = String.split ":" fmt in
+      if outname = "" then
+        error (f_"invalid format string for --machine-readable: %s") fmt;
+      (match outtype with
+      | "file" -> machine_readable_output := File outname
+      | "stream" ->
+        let chan =
+          match outname with
+          | "stdout" -> stdout
+          | "stderr" -> stderr
+          | n ->
+            error (f_"invalid output stream for --machine-readable: %s") fmt in
+        machine_readable_output := Channel chan
+      | n ->
+        error (f_"invalid output for --machine-readable: %s") fmt
+      )
+  in
   let argspec = [
     [ S 'V'; L"version" ], Getopt.Unit print_version_and_exit, s_"Display version and exit";
     [ S 'v'; L"verbose" ], Getopt.Unit set_verbose,  s_"Enable libguestfs debugging messages";
@@ -252,7 +303,7 @@ let create_standard_options argspec ?anon_fun ?(key_opts = false) ?(machine_read
       else []) @
       (if machine_readable then
       [
-        [ L"machine-readable" ], Getopt.Unit set_machine_readable, s_"Make output machine readable";
+        [ L"machine-readable" ], Getopt.OptString ("format", parse_machine_readable), s_"Make output machine readable";
       ]
       else []) in
   Getopt.create argspec ?anon_fun usage_msg

common/mltools/tools_utils.mli

@@ -64,6 +64,16 @@ val parse_resize : int64 -> string -> int64
 val human_size : int64 -> string
 (** Converts a size in bytes to a human-readable string. *)
 
+type machine_readable_fn = {
+  pr : 'a. ('a, unit, string, unit) format4 -> 'a;
+} (* [@@unboxed] *)
+(** Helper type for {!machine_readable}, used to workaround
+    limitations in returned values. *)
+val machine_readable : unit -> machine_readable_fn option
+(** Returns the printf-like function to use to write all the machine
+    readable output to, in case it was enabled via
+    [--machine-readable]. *)
+
 val create_standard_options : Getopt.speclist -> ?anon_fun:Getopt.anon_fun -> ?key_opts:bool -> ?machine_readable:bool -> Getopt.usage_msg -> Getopt.t
 (** Adds the standard libguestfs command line options to the specified ones,
     sorting them, and setting [long_options] to them.

dib/cmdline.ml

@@ -228,11 +228,13 @@ read the man page virt-dib(1).
   let python = !python in
 
   (* No elements and machine-readable mode?  Print some facts. *)
-  if elements = [] && machine_readable () then (
-    printf "virt-dib\n";
+  (match elements, machine_readable () with
+  | [], Some { pr } ->
+    pr "virt-dib\n";
     let formats_list = Output_format.list_formats () in
-    List.iter (printf "output:%s\n") formats_list;
+    List.iter (pr "output:%s\n") formats_list;
     exit 0
+  | _, _ -> ()
   );
 
   if basepath = "" then