Libguestfs - Aug 2018 - [PATCH 2/2] OCaml tools: add output selection for --machine-readable

Hi,

this is a first approach (hence RFC, since it misses tests &
documentation) in selecting the output for --machine-readable.

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

This makes it possible to add additional output for machine-readable in
the tools, with the possibility for users to get it separately from the
rest of the output/errors of the tool used.
For example, the proposed --print-estimate for virt-v2v [1] could print
human output (just like the --print-source), while printing e.g. JSON to
the machine-readable stream.

[1] https://www.redhat.com/archives/libguestfs/2018-August/msg00158.html

Thanks,


Pino Toscano (2):
  common/mltools: getopt: add Getopt.OptString
  OCaml tools: add output selection for --machine-readable

 builder/cmdline.ml             | 12 ++++----
 builder/repository_main.ml     |  2 +-
 common/mltools/getopt-c.c      | 20 ++++++++++++-
 common/mltools/getopt.ml       |  5 +++-
 common/mltools/getopt.mli      |  4 +++
 common/mltools/getopt_tests.ml | 18 +++++++++++-
 common/mltools/test-getopt.sh  | 11 +++++++
 common/mltools/tools_utils.ml  | 52 +++++++++++++++++++++++++++++++++-
 common/mltools/tools_utils.mli |  6 ++++
 dib/cmdline.ml                 |  4 +--
 get-kernel/get_kernel.ml       |  2 +-
 resize/resize.ml               | 22 +++++++-------
 sparsify/cmdline.ml            | 16 +++++------
 v2v/cmdline.ml                 | 28 +++++++++---------
 14 files changed, 155 insertions(+), 47 deletions(-)

-- 
2.17.1

Introduce a new type of option with an optional string argument.
---
 common/mltools/getopt-c.c      | 20 +++++++++++++++++++-
 common/mltools/getopt.ml       |  5 ++++-
 common/mltools/getopt.mli      |  4 ++++
 common/mltools/getopt_tests.ml | 18 +++++++++++++++++-
 common/mltools/test-getopt.sh  | 11 +++++++++++
 5 files changed, 55 insertions(+), 3 deletions(-)

diff --git a/common/mltools/getopt-c.c b/common/mltools/getopt-c.c
index 7b7e39be2..5fa703428 100644
--- a/common/mltools/getopt-c.c
+++ b/common/mltools/getopt-c.c
@@ -274,6 +274,10 @@ guestfs_int_mllib_getopt_parse (value argsv, value specsv,
value anon_funv, valu
         has_arg = 1;
         break;
 
+      case 8:  /* OptString of string * (string option -> unit) */
+        has_arg = 2;
+        break;
+
       default:
         error (EXIT_FAILURE, 0,
                "internal error: unhandled Tag_val (actionv) = %d",
@@ -286,8 +290,11 @@ guestfs_int_mllib_getopt_parse (value argsv, value specsv,
value anon_funv, valu
           caml_raise_out_of_memory ();
         optstring = newstring;
         optstring[optstring_len++] = key[0];
-        if (has_arg)
+        if (has_arg > 0) {
           optstring[optstring_len++] = ':';
+          if (has_arg > 1)
+            optstring[optstring_len++] = ':';
+        }
       } else {
         struct option *newopts = realloc (longopts, (longopts_len + 1 + 1) *
sizeof (*longopts));
         if (newopts == NULL)
@@ -393,6 +400,17 @@ guestfs_int_mllib_getopt_parse (value argsv, value specsv,
value anon_funv, valu
       do_call1 (v, v2);
       break;
 
+    case 8:  /* OptString of string * (string option -> unit) */
+      v = Field (actionv, 1);
+      if (optarg) {
+        v2 = caml_alloc (1, 0);
+        Store_field (v2, 0, caml_copy_string (optarg));
+      } else {
+        v2 = Val_none;
+      }
+      do_call1 (v, v2);
+      break;
+
     default:
       error (EXIT_FAILURE, 0,
              "internal error: unhandled Tag_val (actionv) = %d",
diff --git a/common/mltools/getopt.ml b/common/mltools/getopt.ml
index 9d20855f7..da461457b 100644
--- a/common/mltools/getopt.ml
+++ b/common/mltools/getopt.ml
@@ -31,6 +31,7 @@ type spec    | Int of string * (int -> unit)
   | Set_int of string * int ref
   | Symbol of string * string list * (string -> unit)
+  | OptString of string * (string option -> unit)
 
 module OptionName = struct
   type option_name = S of char | L of string | M of string
@@ -97,7 +98,8 @@ let show_help h ()          | Set_string (arg, _)
         | Int (arg, _)
         | Set_int (arg, _)
-        | Symbol (arg, _, _) -> Some arg in
+        | Symbol (arg, _, _)
+        | OptString (arg, _) -> Some arg in
       (match arg with
       | None -> ()
       | Some arg ->
@@ -181,6 +183,7 @@ let create specs ?anon_fun usage_msg      | Set_string _
-> ()
     | Int _ -> ()
     | Set_int _ -> ()
+    | OptString _ -> ()
     | Symbol (_, elements, _) ->
       List.iter (
         fun e ->
diff --git a/common/mltools/getopt.mli b/common/mltools/getopt.mli
index 2cae19bb8..b4a4f261f 100644
--- a/common/mltools/getopt.mli
+++ b/common/mltools/getopt.mli
@@ -44,6 +44,10 @@ type spec          element in the tuple is the documentation
string of the
         argument, the second is the list of allowed strings,
         and the third is the function to call. *)
+  | OptString of string * (string option -> unit)
+    (** Option with an optional argument; the first element in the
+        tuple is the documentation string of the argument, and the
+        second is the function to call. *)
 
 module OptionName : sig
   type option_name diff --git a/common/mltools/getopt_tests.ml
b/common/mltools/getopt_tests.ml
index 751bf1d5f..1617b3056 100644
--- a/common/mltools/getopt_tests.ml
+++ b/common/mltools/getopt_tests.ml
@@ -40,6 +40,15 @@ let set_flag = ref false
 let si = ref 42
 let ss = ref "not set"
 
+type optstring_value +  | Unset
+  | NoValue
+  | Value of string
+let optstr = ref Unset
+let set_optstr = function
+  | None -> optstr := NoValue
+  | Some s -> optstr := Value s
+
 let argspec = [
   [ S 'a'; L"add" ],  Getopt.String ("string",
add_string), "Add string";
   [ S 'c'; L"clear" ], Getopt.Clear clear_flag, "Clear
flag";
@@ -47,10 +56,16 @@ let argspec = [
   [ M"ii"; L"set-int" ], Getopt.Set_int ("int",
si), "Set int";
   [ M"is"; L"set-string"], Getopt.Set_string
("string", ss), "Set string";
   [ S 't'; L"set" ], Getopt.Set set_flag, "Set
flag";
+  [ S 'o'; L"optstr" ], Getopt.OptString ("string",
set_optstr), "Set optional string";
 ]
 
 let usage_msg = sprintf "%s: test the Getopt parser" prog
 
+let print_optstring_value = function
+  | Unset -> "not set"
+  | NoValue -> "<none>"
+  | Value s -> s
+
 let opthandle = create_standard_options argspec ~anon_fun usage_msg
 let ()    Getopt.parse opthandle;
@@ -66,4 +81,5 @@ let ()    printf "clear_flag = %b\n" !clear_flag;
   printf "set_flag = %b\n" !set_flag;
   printf "set_int = %d\n" !si;
-  printf "set_string = %s\n" !ss
+  printf "set_string = %s\n" !ss;
+  printf "set_optstring = %s\n" (print_optstring_value !optstr)
diff --git a/common/mltools/test-getopt.sh b/common/mltools/test-getopt.sh
index 9db18fb44..58e2d0d59 100755
--- a/common/mltools/test-getopt.sh
+++ b/common/mltools/test-getopt.sh
@@ -52,6 +52,7 @@ $t --help | grep -- '-i, --int <int>'
 $t --help | grep -- '-ii, --set-int <int>'
 $t --help | grep -- '-v, --verbose'
 $t --help | grep -- '-x'
+$t --help | grep -- '-o, --optstr <string>'
 
 # --version
 $t --version | grep '^getopt_tests 1\.'
@@ -60,6 +61,7 @@ $t --version | grep '^getopt_tests 1\.'
 $t --short-options | grep '^-a'
 $t --short-options | grep '^-c'
 $t --short-options | grep '^-i'
+$t --short-options | grep '^-o'
 $t --short-options | grep '^-q'
 $t --short-options | grep '^-ii'
 $t --short-options | grep '^-is'
@@ -78,6 +80,7 @@ $t --long-options | grep '^--colour'
 $t --long-options | grep '^--colours'
 $t --long-options | grep '^--debug-gc'
 $t --long-options | grep '^--int'
+$t --long-options | grep '^--optstr'
 $t --long-options | grep '^--quiet'
 $t --long-options | grep '^--set'
 $t --long-options | grep '^--set-int'
@@ -157,6 +160,14 @@ $t --set-string B | grep '^set_string = B'
 expect_fail $t --is
 expect_fail $t --set-string
 
+# -o/--optstr parameter.
+$t | grep '^set_optstring = not set'
+$t -o | grep '^set_optstring = <none>'
+$t --optstr | grep '^set_optstring = <none>'
+$t -o=A | grep '^set_optstring = A'
+$t --optstr=A | grep '^set_optstring = A'
+$t --optstr=A --optstr | grep '^set_optstring = <none>'
+
 # Anonymous parameters.
 $t | grep '^anons = \[\]'
 $t 1 | grep '^anons = \[1\]'
-- 
2.17.1

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.
---
 builder/cmdline.ml             | 12 ++++----
 builder/repository_main.ml     |  2 +-
 common/mltools/tools_utils.ml  | 52 +++++++++++++++++++++++++++++++++-
 common/mltools/tools_utils.mli |  6 ++++
 dib/cmdline.ml                 |  4 +--
 get-kernel/get_kernel.ml       |  2 +-
 resize/resize.ml               | 22 +++++++-------
 sparsify/cmdline.ml            | 16 +++++------
 v2v/cmdline.ml                 | 28 +++++++++---------
 9 files changed, 100 insertions(+), 44 deletions(-)

diff --git a/builder/cmdline.ml b/builder/cmdline.ml
index 9c854ed49..1771ef046 100644
--- a/builder/cmdline.ml
+++ b/builder/cmdline.ml
@@ -218,12 +218,12 @@ read the man page virt-builder(1).
 
   (* 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";
+    machine_readable_printf "virt-builder\n";
+    machine_readable_printf "arch\n";
+    machine_readable_printf "config-file\n";
+    machine_readable_printf "customize\n";
+    machine_readable_printf "json-list\n";
+    if Pxzcat.using_parallel_xzcat () then machine_readable_printf
"pxzcat\n";
     exit 0
   );
 
diff --git a/builder/repository_main.ml b/builder/repository_main.ml
index 49612d7b9..393c47d43 100644
--- a/builder/repository_main.ml
+++ b/builder/repository_main.ml
@@ -75,7 +75,7 @@ read the man page virt-builder-repository(1).
    * this binary supports.
    *)
   if machine_readable () then (
-    printf "virt-builder-repository\n";
+    machine_readable_printf "virt-builder-repository\n";
     exit 0
   );
 
diff --git a/common/mltools/tools_utils.ml b/common/mltools/tools_utils.ml
index 920977e42..271e7d55f 100644
--- a/common/mltools/tools_utils.ml
+++ b/common/mltools/tools_utils.ml
@@ -229,10 +229,60 @@ let human_size i      )
   )
 
+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_printf fs +  let get_machine_readable_channel () +    let
open_machine_readable_channel () +      match !machine_readable_output with
+      | NoOutput ->
+        (* Trying to use machine_readable_printf when --machine-readable was
+         * not enabled, and thus machine_readable () returns false.
+         *)
+        failwith "internal error: machine_readable_printf used with no
--machine-readable"
+      | Channel chan -> chan
+      | File f -> open_out f
+    in
+    match !machine_readable_channel with
+    | Some chan -> chan
+    | None ->
+      let chan = open_machine_readable_channel () in
+      machine_readable_channel := Some chan;
+      chan
+  in
+  fprintf (get_machine_readable_channel ()) fs
+
 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;
+      set_machine_readable ()
+    | 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
+      );
+      set_machine_readable ()
+  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 +302,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
diff --git a/common/mltools/tools_utils.mli b/common/mltools/tools_utils.mli
index c56f7b660..871911c6e 100644
--- a/common/mltools/tools_utils.mli
+++ b/common/mltools/tools_utils.mli
@@ -64,6 +64,12 @@ val parse_resize : int64 -> string -> int64
 val human_size : int64 -> string
 (** Converts a size in bytes to a human-readable string. *)
 
+val machine_readable_printf : ('a, out_channel, unit) format -> 'a
+(** Function to output something to the separate machine-readable
+    stream.
+
+    It must be used {b only} when {!machine_readable} is [true]. *)
+
 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.
diff --git a/dib/cmdline.ml b/dib/cmdline.ml
index f5e8ec9cb..cbb1f48be 100644
--- a/dib/cmdline.ml
+++ b/dib/cmdline.ml
@@ -229,9 +229,9 @@ read the man page virt-dib(1).
 
   (* No elements and machine-readable mode?  Print some facts. *)
   if elements = [] && machine_readable () then (
-    printf "virt-dib\n";
+    machine_readable_printf "virt-dib\n";
     let formats_list = Output_format.list_formats () in
-    List.iter (printf "output:%s\n") formats_list;
+    List.iter (machine_readable_printf "output:%s\n") formats_list;
     exit 0
   );
 
diff --git a/get-kernel/get_kernel.ml b/get-kernel/get_kernel.ml
index f2949da89..34300d802 100644
--- a/get-kernel/get_kernel.ml
+++ b/get-kernel/get_kernel.ml
@@ -76,7 +76,7 @@ read the man page virt-get-kernel(1).
    * this binary supports.
    *)
   if machine_readable () then (
-    printf "virt-get-kernel\n";
+    machine_readable_printf "virt-get-kernel\n";
     exit 0
   );
 
diff --git a/resize/resize.ml b/resize/resize.ml
index 9d2fdaf40..e88505434 100644
--- a/resize/resize.ml
+++ b/resize/resize.ml
@@ -277,24 +277,24 @@ read the man page virt-resize(1).
      * of the appliance.
      *)
     if !disks = [] && machine_readable () then (
-      printf "virt-resize\n";
-      printf "ntfsresize-force\n";
-      printf "32bitok\n";
-      printf "128-sector-alignment\n";
-      printf "alignment\n";
-      printf "align-first\n";
-      printf "infile-uri\n";
+      machine_readable_printf "virt-resize\n";
+      machine_readable_printf "ntfsresize-force\n";
+      machine_readable_printf "32bitok\n";
+      machine_readable_printf "128-sector-alignment\n";
+      machine_readable_printf "alignment\n";
+      machine_readable_printf "align-first\n";
+      machine_readable_printf "infile-uri\n";
       let g = open_guestfs () in
       g#add_drive "/dev/null";
       g#launch ();
       if g#feature_available [| "ntfsprogs"; "ntfs3g" |]
then
-        printf "ntfs\n";
+        machine_readable_printf "ntfs\n";
       if g#feature_available [| "btrfs" |] then
-        printf "btrfs\n";
+        machine_readable_printf "btrfs\n";
       if g#feature_available [| "xfs" |] then
-        printf "xfs\n";
+        machine_readable_printf "xfs\n";
       if g#feature_available [| "f2fs" |] then
-        printf "f2fs\n";
+        machine_readable_printf "f2fs\n";
       exit 0
     );
 
diff --git a/sparsify/cmdline.ml b/sparsify/cmdline.ml
index b0af053ac..4070d46bf 100644
--- a/sparsify/cmdline.ml
+++ b/sparsify/cmdline.ml
@@ -107,19 +107,19 @@ read the man page virt-sparsify(1).
    * about what this binary supports.
    *)
   if disks = [] && machine_readable () then (
-    printf "virt-sparsify\n";
-    printf "linux-swap\n";
-    printf "zero\n";
-    printf "check-tmpdir\n";
-    printf "in-place\n";
-    printf "tmp-option\n";
+    machine_readable_printf "virt-sparsify\n";
+    machine_readable_printf "linux-swap\n";
+    machine_readable_printf "zero\n";
+    machine_readable_printf "check-tmpdir\n";
+    machine_readable_printf "in-place\n";
+    machine_readable_printf "tmp-option\n";
     let g = open_guestfs () in
     g#add_drive "/dev/null";
     g#launch ();
     if g#feature_available [| "ntfsprogs"; "ntfs3g" |] then
-      printf "ntfs\n";
+      machine_readable_printf "ntfs\n";
     if g#feature_available [| "btrfs" |] then
-      printf "btrfs\n";
+      machine_readable_printf "btrfs\n";
     exit 0
   );
 
diff --git a/v2v/cmdline.ml b/v2v/cmdline.ml
index 10cbb90e6..babf1c002 100644
--- a/v2v/cmdline.ml
+++ b/v2v/cmdline.ml
@@ -334,20 +334,20 @@ read the man page virt-v2v(1).
    * about what this binary supports.
    *)
   if args = [] && machine_readable () then (
-    printf "virt-v2v\n";
-    printf "libguestfs-rewrite\n";
-    printf "vcenter-https\n";
-    printf "xen-ssh\n";
-    printf "vddk\n";
-    printf "colours-option\n";
-    printf "vdsm-compat-option\n";
-    printf "in-place\n";
-    printf "io/oo\n";
-    printf "mac-option\n";
-    List.iter (printf "input:%s\n") (Modules_list.input_modules ());
-    List.iter (printf "output:%s\n") (Modules_list.output_modules
());
-    List.iter (printf "convert:%s\n") (Modules_list.convert_modules
());
-    List.iter (printf "ovf:%s\n") Create_ovf.ovf_flavours;
+    machine_readable_printf "virt-v2v\n";
+    machine_readable_printf "libguestfs-rewrite\n";
+    machine_readable_printf "vcenter-https\n";
+    machine_readable_printf "xen-ssh\n";
+    machine_readable_printf "vddk\n";
+    machine_readable_printf "colours-option\n";
+    machine_readable_printf "vdsm-compat-option\n";
+    machine_readable_printf "in-place\n";
+    machine_readable_printf "io/oo\n";
+    machine_readable_printf "mac-option\n";
+    List.iter (machine_readable_printf "input:%s\n")
(Modules_list.input_modules ());
+    List.iter (machine_readable_printf "output:%s\n")
(Modules_list.output_modules ());
+    List.iter (machine_readable_printf "convert:%s\n")
(Modules_list.convert_modules ());
+    List.iter (machine_readable_printf "ovf:%s\n")
Create_ovf.ovf_flavours;
     exit 0
   );
 
-- 
2.17.1

On Tue, Aug 21, 2018 at 05:44:29PM +0200, Pino Toscano
wrote:
> Introduce a new type of option with an optional string argument.
> ---
>  common/mltools/getopt-c.c      | 20 +++++++++++++++++++-
>  common/mltools/getopt.ml       |  5 ++++-
>  common/mltools/getopt.mli      |  4 ++++
>  common/mltools/getopt_tests.ml | 18 +++++++++++++++++-
>  common/mltools/test-getopt.sh  | 11 +++++++++++
>  5 files changed, 55 insertions(+), 3 deletions(-)
I think this is the same as when it was last posted, so ACK.

Rich.
> diff --git a/common/mltools/getopt-c.c b/common/mltools/getopt-c.c
> index 7b7e39be2..5fa703428 100644
> --- a/common/mltools/getopt-c.c
> +++ b/common/mltools/getopt-c.c
> @@ -274,6 +274,10 @@ guestfs_int_mllib_getopt_parse (value argsv, value
specsv, value anon_funv, valu
>          has_arg = 1;
>          break;
>  
> +      case 8:  /* OptString of string * (string option -> unit) */
> +        has_arg = 2;
> +        break;
> +
>        default:
>          error (EXIT_FAILURE, 0,
>                 "internal error: unhandled Tag_val (actionv) =
%d",
> @@ -286,8 +290,11 @@ guestfs_int_mllib_getopt_parse (value argsv, value
specsv, value anon_funv, valu
>            caml_raise_out_of_memory ();
>          optstring = newstring;
>          optstring[optstring_len++] = key[0];
> -        if (has_arg)
> +        if (has_arg > 0) {
>            optstring[optstring_len++] = ':';
> +          if (has_arg > 1)
> +            optstring[optstring_len++] = ':';
> +        }
>        } else {
>          struct option *newopts = realloc (longopts, (longopts_len + 1 + 1)
* sizeof (*longopts));
>          if (newopts == NULL)
> @@ -393,6 +400,17 @@ guestfs_int_mllib_getopt_parse (value argsv, value
specsv, value anon_funv, valu
>        do_call1 (v, v2);
>        break;
>  
> +    case 8:  /* OptString of string * (string option -> unit) */
> +      v = Field (actionv, 1);
> +      if (optarg) {
> +        v2 = caml_alloc (1, 0);
> +        Store_field (v2, 0, caml_copy_string (optarg));
> +      } else {
> +        v2 = Val_none;
> +      }
> +      do_call1 (v, v2);
> +      break;
> +
>      default:
>        error (EXIT_FAILURE, 0,
>               "internal error: unhandled Tag_val (actionv) = %d",
> diff --git a/common/mltools/getopt.ml b/common/mltools/getopt.ml
> index 9d20855f7..da461457b 100644
> --- a/common/mltools/getopt.ml
> +++ b/common/mltools/getopt.ml
> @@ -31,6 +31,7 @@ type spec >    | Int of string * (int -> unit)
>    | Set_int of string * int ref
>    | Symbol of string * string list * (string -> unit)
> +  | OptString of string * (string option -> unit)
>  
>  module OptionName = struct
>    type option_name = S of char | L of string | M of string
> @@ -97,7 +98,8 @@ let show_help h () >          | Set_string (arg, _)
>          | Int (arg, _)
>          | Set_int (arg, _)
> -        | Symbol (arg, _, _) -> Some arg in
> +        | Symbol (arg, _, _)
> +        | OptString (arg, _) -> Some arg in
>        (match arg with
>        | None -> ()
>        | Some arg ->
> @@ -181,6 +183,7 @@ let create specs ?anon_fun usage_msg >      |
Set_string _ -> ()
>      | Int _ -> ()
>      | Set_int _ -> ()
> +    | OptString _ -> ()
>      | Symbol (_, elements, _) ->
>        List.iter (
>          fun e ->
> diff --git a/common/mltools/getopt.mli b/common/mltools/getopt.mli
> index 2cae19bb8..b4a4f261f 100644
> --- a/common/mltools/getopt.mli
> +++ b/common/mltools/getopt.mli
> @@ -44,6 +44,10 @@ type spec >          element in the tuple is the
documentation string of the
>          argument, the second is the list of allowed strings,
>          and the third is the function to call. *)
> +  | OptString of string * (string option -> unit)
> +    (** Option with an optional argument; the first element in the
> +        tuple is the documentation string of the argument, and the
> +        second is the function to call. *)
>  
>  module OptionName : sig
>    type option_name > diff --git a/common/mltools/getopt_tests.ml
b/common/mltools/getopt_tests.ml
> index 751bf1d5f..1617b3056 100644
> --- a/common/mltools/getopt_tests.ml
> +++ b/common/mltools/getopt_tests.ml
> @@ -40,6 +40,15 @@ let set_flag = ref false
>  let si = ref 42
>  let ss = ref "not set"
>  
> +type optstring_value > +  | Unset
> +  | NoValue
> +  | Value of string
> +let optstr = ref Unset
> +let set_optstr = function
> +  | None -> optstr := NoValue
> +  | Some s -> optstr := Value s
> +
>  let argspec = [
>    [ S 'a'; L"add" ],  Getopt.String ("string",
add_string), "Add string";
>    [ S 'c'; L"clear" ], Getopt.Clear clear_flag,
"Clear flag";
> @@ -47,10 +56,16 @@ let argspec = [
>    [ M"ii"; L"set-int" ], Getopt.Set_int
("int", si), "Set int";
>    [ M"is"; L"set-string"], Getopt.Set_string
("string", ss), "Set string";
>    [ S 't'; L"set" ], Getopt.Set set_flag, "Set
flag";
> +  [ S 'o'; L"optstr" ], Getopt.OptString
("string", set_optstr), "Set optional string";
>  ]
>  
>  let usage_msg = sprintf "%s: test the Getopt parser" prog
>  
> +let print_optstring_value = function
> +  | Unset -> "not set"
> +  | NoValue -> "<none>"
> +  | Value s -> s
> +
>  let opthandle = create_standard_options argspec ~anon_fun usage_msg
>  let () >    Getopt.parse opthandle;
> @@ -66,4 +81,5 @@ let () >    printf "clear_flag = %b\n"
!clear_flag;
>    printf "set_flag = %b\n" !set_flag;
>    printf "set_int = %d\n" !si;
> -  printf "set_string = %s\n" !ss
> +  printf "set_string = %s\n" !ss;
> +  printf "set_optstring = %s\n" (print_optstring_value !optstr)
> diff --git a/common/mltools/test-getopt.sh b/common/mltools/test-getopt.sh
> index 9db18fb44..58e2d0d59 100755
> --- a/common/mltools/test-getopt.sh
> +++ b/common/mltools/test-getopt.sh
> @@ -52,6 +52,7 @@ $t --help | grep -- '-i, --int <int>'
>  $t --help | grep -- '-ii, --set-int <int>'
>  $t --help | grep -- '-v, --verbose'
>  $t --help | grep -- '-x'
> +$t --help | grep -- '-o, --optstr <string>'
>  
>  # --version
>  $t --version | grep '^getopt_tests 1\.'
> @@ -60,6 +61,7 @@ $t --version | grep '^getopt_tests 1\.'
>  $t --short-options | grep '^-a'
>  $t --short-options | grep '^-c'
>  $t --short-options | grep '^-i'
> +$t --short-options | grep '^-o'
>  $t --short-options | grep '^-q'
>  $t --short-options | grep '^-ii'
>  $t --short-options | grep '^-is'
> @@ -78,6 +80,7 @@ $t --long-options | grep '^--colour'
>  $t --long-options | grep '^--colours'
>  $t --long-options | grep '^--debug-gc'
>  $t --long-options | grep '^--int'
> +$t --long-options | grep '^--optstr'
>  $t --long-options | grep '^--quiet'
>  $t --long-options | grep '^--set'
>  $t --long-options | grep '^--set-int'
> @@ -157,6 +160,14 @@ $t --set-string B | grep '^set_string = B'
>  expect_fail $t --is
>  expect_fail $t --set-string
>  
> +# -o/--optstr parameter.
> +$t | grep '^set_optstring = not set'
> +$t -o | grep '^set_optstring = <none>'
> +$t --optstr | grep '^set_optstring = <none>'
> +$t -o=A | grep '^set_optstring = A'
> +$t --optstr=A | grep '^set_optstring = A'
> +$t --optstr=A --optstr | grep '^set_optstring = <none>'
> +
>  # Anonymous parameters.
>  $t | grep '^anons = \[\]'
>  $t 1 | grep '^anons = \[1\]'
> -- 
> 2.17.1
> 
> _______________________________________________
> Libguestfs mailing list
> Libguestfs@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/

On Tue, Aug 21, 2018 at 05:44:30PM +0200, Pino Toscano
wrote:
> +let machine_readable_printf fs > +  let get_machine_readable_channel ()
> +    let open_machine_readable_channel () > +      match
!machine_readable_output with
> +      | NoOutput ->
> +        (* Trying to use machine_readable_printf when --machine-readable
was
> +         * not enabled, and thus machine_readable () returns false.
> +         *)
> +        failwith "internal error: machine_readable_printf used with
no --machine-readable"
I wonder if there's a way to avoid this error at compile time.

Replace the ‘machine_readable ()’ function that returns boolean with
one which returns an optional printf function.  Then caller code would
do:

  match machine_readable () with
  | None -> ()  (* ie. not --machine-readable *)
  | Some pr ->
      pr "stuff\n";
      exit 0

Of course the devil will be in the details as to whether this actually
works with our existing callers.
> +  fprintf (get_machine_readable_channel ()) fs
I'm surprised this works and you didn't need to use ksprintf.
>    (* No elements and machine-readable mode?  Print some facts. *)
>    if elements = [] && machine_readable () then (
> -    printf "virt-dib\n";
> +    machine_readable_printf "virt-dib\n";
>      let formats_list = Output_format.list_formats () in
> -    List.iter (printf "output:%s\n") formats_list;
> +    List.iter (machine_readable_printf "output:%s\n")
formats_list;
>      exit 0
>    );
So this caller would become:

  match machine_readable (), elements = [] with
  | None, _ -> ()
  | Some pr, [] -> 
     (* existing code, replacing printf with pr *)
  | Some _, _ ->
     (* this is a new case giving an error when the user
        uses --machine-readable + a list of elements, which I believe
        is not caught in the current code *)
     error (f_"--machine-readable cannot be used with elements on the
command line")

Rich.

-- 
Richard Jones, Virtualization Group, Red Hat http://people.redhat.com/~rjones
Read my programming and virtualization blog: http://rwmj.wordpress.com
Fedora Windows cross-compiler. Compile Windows programs, test, and
build Windows installers. Over 100 libraries supported.
http://fedoraproject.org/wiki/MinGW