Richard W.M. Jones
2016-Jul-15 21:37 UTC
[Libguestfs] [PATCH 0/3] mllib: Various fixes and changes to Getopt module.
The second patch is obviously not complete yet - for discussion only. Rich.
Richard W.M. Jones
2016-Jul-15 21:37 UTC
[Libguestfs] [PATCH 1/3] mllib: Fix parsing of integers on the command line and use correct int type.
Currently input such as "1ABC" or "1.1" is parsed (as 1).
If there is
trailing data on the command line, refuse to accept it.
In addition this parses the integer into a C 'long', which is as close
as we can get to the OCaml idea of a native int. This prevents the
gross rounding error from the earlier code if the integer parameter
was larger than 32 bits (on a 64 bit platform), but is still not
completely free of rounding problems because the OCaml type is 31 or
63 bits.
Probably we should have explicit 'int32' and 'int64' types in
the
OCaml code, instead of using (native) 'int'.
---
mllib/getopt-c.c | 9 ++++++---
1 file changed, 6 insertions(+), 3 deletions(-)
diff --git a/mllib/getopt-c.c b/mllib/getopt-c.c
index 1f129a7..afb8793 100644
--- a/mllib/getopt-c.c
+++ b/mllib/getopt-c.c
@@ -247,7 +247,8 @@ guestfs_int_mllib_getopt_parse (value argsv, value specsv,
value anon_funv, valu
actionv = Field (specv, 1);
switch (Tag_val (actionv)) {
- int num;
+ long num;
+ int nchars;
case 0: /* Unit of (unit -> unit) */
v = Field (actionv, 0);
@@ -274,7 +275,8 @@ guestfs_int_mllib_getopt_parse (value argsv, value specsv,
value anon_funv, valu
break;
case 5: /* Int of string * (int -> unit) */
- if (sscanf (optarg, "%d", &num) != 1) {
+ if (sscanf (optarg, "%ld%n", &num, &nchars) < 1
+ || optarg[nchars] != '\0') {
fprintf (stderr, _("'%s' is not a numeric value.\n"),
guestfs_int_program_name);
show_error (EXIT_FAILURE);
@@ -284,7 +286,8 @@ guestfs_int_mllib_getopt_parse (value argsv, value specsv,
value anon_funv, valu
break;
case 6: /* Set_int of string * int ref */
- if (sscanf (optarg, "%d", &num) != 1) {
+ if (sscanf (optarg, "%ld%n", &num, &nchars) < 1
+ || optarg[nchars] != '\0') {
fprintf (stderr, _("'%s' is not a numeric value.\n"),
guestfs_int_program_name);
show_error (EXIT_FAILURE);
--
2.7.4
Richard W.M. Jones
2016-Jul-15 21:37 UTC
[Libguestfs] [PATCH 2/3] mllib: Use L"..." and S '...' for long and short options.
---
builder/cmdline.ml | 61 +++++++++++++------------
generator/customize.ml | 29 ++++++------
mllib/common_utils.ml | 15 +++---
mllib/getopt.ml | 121 ++++++++++++++++++++++++-------------------------
mllib/getopt.mli | 39 +++++++++-------
5 files changed, 135 insertions(+), 130 deletions(-)
diff --git a/builder/cmdline.ml b/builder/cmdline.ml
index 846c2e3..49a57ee 100644
--- a/builder/cmdline.ml
+++ b/builder/cmdline.ml
@@ -20,6 +20,7 @@
open Common_gettext.Gettext
open Common_utils
+open Getopt.OptionName
open Customize_cmdline
@@ -119,46 +120,46 @@ let parse_cmdline () let warn_if_partition = ref true
in
let argspec = [
- [ "--arch" ], Getopt.Set_string ("arch", arch),
s_"Set the output architecture";
- [ "--attach" ], Getopt.String ("iso", attach_disk),
s_"Attach data disk/ISO during install";
- [ "--attach-format" ], Getopt.String ("format",
set_attach_format),
+ [ L"arch" ], Getopt.Set_string ("arch", arch),
s_"Set the output architecture";
+ [ L"attach" ], Getopt.String ("iso", attach_disk),
s_"Attach data disk/ISO during install";
+ [ L"attach-format" ], Getopt.String ("format",
set_attach_format),
s_"Set attach disk
format";
- [ "--cache" ], Getopt.String ("dir", set_cache),
s_"Set template cache dir";
- [ "--no-cache" ], Getopt.Unit no_cache, s_"Disable
template cache";
- [ "--cache-all-templates" ], Getopt.Unit cache_all_mode,
+ [ L"cache" ], Getopt.String ("dir", set_cache),
s_"Set template cache dir";
+ [ L"no-cache" ], Getopt.Unit no_cache, s_"Disable
template cache";
+ [ L"cache-all-templates" ], Getopt.Unit cache_all_mode,
s_"Download all templates to
the cache";
- [ "--check-signature"; "--check-signatures" ],
Getopt.Set check_signature,
+ [ L"check-signature"; L"check-signatures" ], Getopt.Set
check_signature,
s_"Check digital
signatures";
- [ "--no-check-signature"; "--no-check-signatures" ],
Getopt.Clear check_signature,
+ [ L"no-check-signature"; L"no-check-signatures" ],
Getopt.Clear check_signature,
s_"Disable digital
signatures";
- [ "--curl" ], Getopt.Set_string ("curl", curl),
s_"Set curl binary/command";
- [ "--delete-cache" ], Getopt.Unit delete_cache_mode,
+ [ L"curl" ], Getopt.Set_string ("curl", curl),
s_"Set curl binary/command";
+ [ L"delete-cache" ], Getopt.Unit delete_cache_mode,
s_"Delete the template
cache";
- [ "--no-delete-on-failure" ], Getopt.Clear delete_on_failure,
+ [ L"no-delete-on-failure" ], Getopt.Clear delete_on_failure,
s_"Don't delete output
file on failure";
- [ "--fingerprint" ], Getopt.String ("AAAA..",
add_fingerprint),
+ [ L"fingerprint" ], Getopt.String ("AAAA..",
add_fingerprint),
s_"Fingerprint of valid
signing key";
- [ "--format" ], Getopt.Set_string ("raw|qcow2",
format), s_"Output format (default: raw)";
- [ "--get-kernel" ], Getopt.Unit get_kernel_mode,
+ [ L"format" ], Getopt.Set_string ("raw|qcow2",
format), s_"Output format (default: raw)";
+ [ L"get-kernel" ], Getopt.Unit get_kernel_mode,
s_"Get kernel from
image";
- [ "--gpg" ], Getopt.Set_string ("gpg", gpg),
s_"Set GPG binary/command";
- [ "-l"; "--list" ], Getopt.Unit list_mode,
s_"List available templates";
- [ "--long" ], Getopt.Unit list_set_long, s_"Shortcut
for --list-format long";
- [ "--list-format" ], Getopt.String ("short|long|json",
list_set_format),
+ [ L"gpg" ], Getopt.Set_string ("gpg", gpg),
s_"Set GPG binary/command";
+ [ S 'l'; L"list" ], Getopt.Unit list_mode,
s_"List available templates";
+ [ L"long" ], Getopt.Unit list_set_long, s_"Shortcut
for --list-format long";
+ [ L"list-format" ], Getopt.String ("short|long|json",
list_set_format),
s_"Set the format for --list
(default: short)";
- [ "--machine-readable" ], Getopt.Set machine_readable,
s_"Make output machine readable";
- [ "-m"; "--memsize" ], Getopt.Int
("mb", set_memsize), s_"Set memory size";
- [ "--network" ], Getopt.Set network, s_"Enable
appliance network (default)";
- [ "--no-network" ], Getopt.Clear network, s_"Disable
appliance network";
- [ "--notes" ], Getopt.Unit notes_mode, s_"Display
installation notes";
- [ "-o"; "--output" ], Getopt.Set_string
("file", output), s_"Set output filename";
- [ "--print-cache" ], Getopt.Unit print_cache_mode,
+ [ L"machine-readable" ], Getopt.Set machine_readable,
s_"Make output machine readable";
+ [ S 'm'; L"memsize" ], Getopt.Int ("mb",
set_memsize), s_"Set memory size";
+ [ L"network" ], Getopt.Set network, s_"Enable
appliance network (default)";
+ [ L"no-network" ], Getopt.Clear network, s_"Disable
appliance network";
+ [ L"notes" ], Getopt.Unit notes_mode, s_"Display
installation notes";
+ [ S 'o'; L"output" ], Getopt.Set_string
("file", output), s_"Set output filename";
+ [ L"print-cache" ], Getopt.Unit print_cache_mode,
s_"Print info about template
cache";
- [ "--size" ], Getopt.String ("size", set_size),
s_"Set output disk size";
- [ "--smp" ], Getopt.Int ("vcpus", set_smp),
s_"Set number of vCPUs";
- [ "--source" ], Getopt.String ("URL", add_source),
s_"Set source URL";
- [ "--no-sync" ], Getopt.Clear sync, s_"Do not
fsync output file on exit";
- [ "--no-warn-if-partition" ], Getopt.Clear warn_if_partition,
+ [ L"size" ], Getopt.String ("size", set_size),
s_"Set output disk size";
+ [ L"smp" ], Getopt.Int ("vcpus", set_smp),
s_"Set number of vCPUs";
+ [ L"source" ], Getopt.String ("URL", add_source),
s_"Set source URL";
+ [ L"no-sync" ], Getopt.Clear sync, s_"Do not
fsync output file on exit";
+ [ L"no-warn-if-partition" ], Getopt.Clear warn_if_partition,
s_"Do not warn if writing to a
partition";
] in
let customize_argspec, get_customize_ops = Customize_cmdline.argspec () in
diff --git a/generator/customize.ml b/generator/customize.ml
index 0924732..259cd26 100644
--- a/generator/customize.ml
+++ b/generator/customize.ml
@@ -590,6 +590,7 @@ open Printf
open Common_utils
open Common_gettext.Gettext
+open Getopt.OptionName
open Customize_utils
@@ -652,7 +653,7 @@ let rec argspec () | { op_type = Unit; op_name = name;
op_discrim = discrim;
op_shortdesc = shortdesc; op_pod_longdesc = longdesc } ->
pr " (\n";
- pr " [ \"--%s\" ],\n" name;
+ pr " [ L\"%s\" ],\n" name;
pr " Getopt.Unit (fun () -> push_front %s ops),\n"
discrim;
pr " s_\"%s\"\n" shortdesc;
pr " ),\n";
@@ -660,7 +661,7 @@ let rec argspec () | { op_type = String v; op_name =
name; op_discrim = discrim;
op_shortdesc = shortdesc; op_pod_longdesc = longdesc } ->
pr " (\n";
- pr " [ \"--%s\" ],\n" name;
+ pr " [ L\"%s\" ],\n" name;
pr " Getopt.String (s_\"%s\", fun s -> push_front
(%s s) ops),\n" v discrim;
pr " s_\"%s\"\n" shortdesc;
pr " ),\n";
@@ -668,7 +669,7 @@ let rec argspec () | { op_type = StringPair v; op_name
= name; op_discrim = discrim;
op_shortdesc = shortdesc; op_pod_longdesc = longdesc } ->
pr " (\n";
- pr " [ \"--%s\" ],\n" name;
+ pr " [ L\"%s\" ],\n" name;
pr " Getopt.String (\n";
pr " s_\"%s\",\n" v;
pr " fun s ->\n";
@@ -681,7 +682,7 @@ let rec argspec () | { op_type = StringList v; op_name
= name; op_discrim = discrim;
op_shortdesc = shortdesc; op_pod_longdesc = longdesc } ->
pr " (\n";
- pr " [ \"--%s\" ],\n" name;
+ pr " [ L\"%s\" ],\n" name;
pr " Getopt.String (\n";
pr " s_\"%s\",\n" v;
pr " fun s ->\n";
@@ -694,7 +695,7 @@ let rec argspec () | { op_type = TargetLinks v; op_name
= name; op_discrim = discrim;
op_shortdesc = shortdesc; op_pod_longdesc = longdesc } ->
pr " (\n";
- pr " [ \"--%s\" ],\n" name;
+ pr " [ L\"%s\" ],\n" name;
pr " Getopt.String (\n";
pr " s_\"%s\",\n" v;
pr " fun s ->\n";
@@ -707,7 +708,7 @@ let rec argspec () | { op_type = PasswordSelector v;
op_name = name; op_discrim = discrim;
op_shortdesc = shortdesc; op_pod_longdesc = longdesc } ->
pr " (\n";
- pr " [ \"--%s\" ],\n" name;
+ pr " [ L\"%s\" ],\n" name;
pr " Getopt.String (\n";
pr " s_\"%s\",\n" v;
pr " fun s ->\n";
@@ -720,7 +721,7 @@ let rec argspec () | { op_type = UserPasswordSelector
v; op_name = name; op_discrim = discrim;
op_shortdesc = shortdesc; op_pod_longdesc = longdesc } ->
pr " (\n";
- pr " [ \"--%s\" ],\n" name;
+ pr " [ L\"%s\" ],\n" name;
pr " Getopt.String (\n";
pr " s_\"%s\",\n" v;
pr " fun s ->\n";
@@ -734,7 +735,7 @@ let rec argspec () | { op_type = SSHKeySelector v;
op_name = name; op_discrim = discrim;
op_shortdesc = shortdesc; op_pod_longdesc = longdesc } ->
pr " (\n";
- pr " [ \"--%s\" ],\n" name;
+ pr " [ L\"%s\" ],\n" name;
pr " Getopt.String (\n";
pr " s_\"%s\",\n" v;
pr " fun s ->\n";
@@ -748,7 +749,7 @@ let rec argspec () | { op_type = StringFn (v, fn);
op_name = name; op_discrim = discrim;
op_shortdesc = shortdesc; op_pod_longdesc = longdesc } ->
pr " (\n";
- pr " [ \"--%s\" ],\n" name;
+ pr " [ L\"%s\" ],\n" name;
pr " Getopt.String (\n";
pr " s_\"%s\",\n" v;
pr " fun s ->\n";
@@ -761,7 +762,7 @@ let rec argspec () | { op_type = SMPoolSelector v;
op_name = name; op_discrim = discrim;
op_shortdesc = shortdesc; op_pod_longdesc = longdesc } ->
pr " (\n";
- pr " [ \"--%s\" ],\n" name;
+ pr " [ L\"%s\" ],\n" name;
pr " Getopt.String (\n";
pr " s_\"%s\",\n" v;
pr " fun s ->\n";
@@ -778,7 +779,7 @@ let rec argspec () | { flag_type = FlagBool default;
flag_ml_var = var; flag_name = name;
flag_shortdesc = shortdesc; flag_pod_longdesc = longdesc } ->
pr " (\n";
- pr " [ \"--%s\" ],\n" name;
+ pr " [ L\"%s\" ],\n" name;
if default (* is true *) then
pr " Getopt.Clear %s,\n" var
else
@@ -790,7 +791,7 @@ let rec argspec () flag_name = name; flag_shortdesc
= shortdesc;
flag_pod_longdesc = longdesc } ->
pr " (\n";
- pr " [ \"--%s\" ],\n" name;
+ pr " [ L\"%s\" ],\n" name;
pr " Getopt.String (\n";
pr " s_\"%s\",\n" v;
pr " fun s ->\n";
@@ -803,7 +804,7 @@ let rec argspec () flag_name = name; flag_shortdesc
= shortdesc;
flag_pod_longdesc = longdesc } ->
pr " (\n";
- pr " [ \"--%s\" ],\n" name;
+ pr " [ L\"%s\" ],\n" name;
pr " Getopt.String (\n";
pr " s_\"%s\",\n" v;
pr " fun s ->\n";
@@ -855,7 +856,7 @@ pr " ] in
try
let ((_, spec, _), _, _) = List.find (
fun ((keys, _, _), _, _) ->
- List.mem (\"--\" ^ cmd) keys
+ List.mem (L cmd) keys
) argspec in
(match spec with
| Getopt.Unit fn -> fn ()
diff --git a/mllib/common_utils.ml b/mllib/common_utils.ml
index 3bbfa46..e7ee84a 100644
--- a/mllib/common_utils.ml
+++ b/mllib/common_utils.ml
@@ -19,6 +19,7 @@
open Printf
open Common_gettext.Gettext
+open Getopt.OptionName
module Char = struct
include Char
@@ -571,13 +572,13 @@ let create_standard_options argspec ?anon_fun usage_msg
let set_debug_gc () at_exit (fun () -> Gc.compact()) in
let argspec = [
- [ "-V"; "--version" ], Getopt.Unit
print_version_and_exit, s_"Display version and exit";
- [ "-v"; "--verbose" ], Getopt.Unit set_verbose,
s_"Enable libguestfs debugging messages";
- [ "-x" ], Getopt.Unit set_trace, s_"Enable
tracing of libguestfs calls";
- [ "--debug-gc" ], Getopt.Unit set_debug_gc,
Getopt.hidden_option_description;
- [ "-q"; "--quiet" ], Getopt.Unit set_quiet,
s_"Don't print progress messages";
- [ "--color"; "--colors";
- "--colour"; "--colours" ], Getopt.Unit set_colours,
s_"Use ANSI colour sequences even if not tty";
+ [ 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";
+ [ S 'x' ], Getopt.Unit set_trace, s_"Enable
tracing of libguestfs calls";
+ [ L"debug-gc" ], Getopt.Unit set_debug_gc,
Getopt.hidden_option_description;
+ [ S 'q'; L"quiet" ], Getopt.Unit set_quiet,
s_"Don't print progress messages";
+ [ L"color"; L"colors";
+ L"colour"; L"colours" ], Getopt.Unit set_colours,
s_"Use ANSI colour sequences even if not tty";
] @ argspec in
Getopt.create argspec ?anon_fun usage_msg
diff --git a/mllib/getopt.ml b/mllib/getopt.ml
index 550baa4..3bfcd21 100644
--- a/mllib/getopt.ml
+++ b/mllib/getopt.ml
@@ -29,7 +29,12 @@ type spec | Int of string * (int -> unit)
| Set_int of string * int ref
-type keys = string list
+module OptionName = struct
+ type option_name = S of char | L of string
+end
+open OptionName
+
+type keys = option_name list
type doc = string
type usage_msg = string
type anon_fun = (string -> unit)
@@ -49,6 +54,14 @@ external getopt_parse : string array -> (c_keys * spec *
doc) array -> ?anon_fun
let column_wrap = 38
+let string_of_option_name = function
+ | S c -> sprintf "-%c" c
+ | L s -> "--" ^ s
+
+let string_of_option_name_no_dashes = function
+ | S c -> String.make 1 c
+ | L s -> s
+
let show_help h () let b = Buffer.create 1024 in
@@ -58,10 +71,11 @@ let show_help h () let prologue = sprintf
(f_"%s\nOptions:\n") h.usage_msg in
Buffer.add_string b prologue;
- let specs = List.filter (
- fun (_, _, doc) ->
+ let specs + List.filter (
+ fun (_, _, doc) ->
doc <> hidden_option_description
- ) h.specs in
+ ) h.specs in
List.iter (
fun (keys, spec, doc) ->
@@ -72,7 +86,7 @@ let show_help h () in
add " ";
- add (String.concat ", " keys);
+ add (String.concat ", " (List.map string_of_option_name keys));
let arg match spec with
| Unit _
@@ -109,9 +123,9 @@ let display_short_options h () List.iter (
fun (args, _, _) ->
List.iter (
- fun arg ->
- if is_prefix arg "-" && not (is_prefix arg
"--") then
- printf "%s\n" arg
+ function
+ | S _ as arg -> print_endline (string_of_option_name arg)
+ | L _ -> ()
) args
) h.specs;
exit 0
@@ -119,73 +133,44 @@ let display_long_options h () List.iter (
fun (args, _, _) ->
List.iter (
- fun arg ->
- if is_prefix arg "--" && arg <>
"--long-options" &&
- arg <> "--short-options" then
- printf "%s\n" arg
+ function
+ | L "short-options" | L "long-options"
+ | S _ -> ()
+ | L _ as arg -> print_endline (string_of_option_name arg)
) args
) h.specs;
exit 0
-(* Skip any leading '-' characters when comparing command line args. *)
-let skip_dashes str - let n = String.length str in
- let rec loop i - if i >= n then invalid_arg "skip_dashes"
- else if String.unsafe_get str i = '-' then loop (i+1)
- else i
- in
- let i = loop 0 in
- if i = 0 then str
- else String.sub str i (n-i)
-
let compare_command_line_args a b - compare (String.lowercase (skip_dashes a))
(String.lowercase (skip_dashes b))
+ let a = String.lowercase (string_of_option_name_no_dashes a) in
+ let b = String.lowercase (string_of_option_name_no_dashes b) in
+ compare a b
let create specs ?anon_fun usage_msg (* Sanity check the input *)
- let validate_key key - if String.length key == 0 || key == "-"
|| key == "--"
- || key.[0] != '-' then
- invalid_arg (sprintf "invalid option key: '%s'" key)
+ let validate_key = function
+ | L"" -> invalid_arg "Getopt spec: invalid empty long
option"
+ | L"help" -> invalid_arg "Getopt spec: should not have
L\"help\""
+ | L"short-options" ->
+ invalid_arg "Getopt spec: should not have
L\"short-options\""
+ | L"long-options" ->
+ invalid_arg "Getopt spec: should not have
L\"long-options\""
+ | L s when s.[0] = '-' ->
+ invalid_arg (sprintf "Getopt spec: L%S should not begin with a
dash"
+ s)
+ | L s when String.contains s '_' ->
+ invalid_arg (sprintf "Getopt spec: L%S should not contain
'_'"
+ s)
+ | _ -> ()
in
-
List.iter (
fun (keys, spec, doc) ->
if keys == [] then
invalid_arg "empty keys for Getopt spec";
- List.iter validate_key keys;
+ List.iter validate_key keys
) specs;
- let t - {
- specs = []; (* Set it later, with own options, and sorted. *)
- anon_fun = anon_fun;
- usage_msg = usage_msg;
- } in
-
- let specs = specs @ [
- [ "--short-options" ], Unit (display_short_options t),
hidden_option_description;
- [ "--long-options" ], Unit (display_long_options t),
hidden_option_description;
- ] in
-
- (* Decide whether the help option can be added, and which switches use. *)
- let has_dash_help = ref false in
- let has_dash_dash_help = ref false in
- List.iter (
- fun (keys, _, _) ->
- if not (!has_dash_help) then
- has_dash_help := List.mem "-help" keys;
- if not (!has_dash_dash_help) then
- has_dash_dash_help := List.mem "--help" keys;
- ) specs;
- let help_keys = [] @
- (if !has_dash_help then [] else [ "-help" ]) @
- (if !has_dash_dash_help then [] else [ "--help" ]) in
- let specs = specs @
- (if help_keys <> [] then [ help_keys, Unit (show_help t),
s_"Display brief help"; ] else []) in
-
- (* Sort the specs, and set them in the handle. *)
+ (* Sort the specs. *)
let specs = List.map (
fun (keys, action, doc) ->
List.hd (List.sort compare_command_line_args keys), (keys, action, doc)
@@ -194,14 +179,26 @@ let create specs ?anon_fun usage_msg let cmp (arg1,
_) (arg2, _) = compare_command_line_args arg1 arg2 in
List.sort cmp specs in
let specs = List.map snd specs in
- t.specs <- specs;
+ let t = {
+ specs = specs;
+ anon_fun = anon_fun;
+ usage_msg = usage_msg;
+ } in
+ let added_options = [
+ [ L"short-options" ], Unit (display_short_options t),
+ hidden_option_description;
+ [ L"long-options" ], Unit (display_long_options t),
+ hidden_option_description;
+ [ L"help" ], Unit (show_help t), s_"Display brief
help";
+ ] in
+ t.specs <- added_options @ specs;
t
let parse_argv t argv let specs = List.map (
fun (keys, spec, doc) ->
- Array.of_list keys, spec, doc
+ Array.of_list (List.map string_of_option_name keys), spec, doc
) t.specs in
let specs = Array.of_list specs in
getopt_parse argv specs ?anon_fun:t.anon_fun t.usage_msg
diff --git a/mllib/getopt.mli b/mllib/getopt.mli
index 2a8bada..89d96ab 100644
--- a/mllib/getopt.mli
+++ b/mllib/getopt.mli
@@ -18,29 +18,34 @@
type spec | Unit of (unit -> unit)
- (* Simple option with no argument; call the function. *)
+ (** Simple option with no argument; call the function. *)
| Set of bool ref
- (* Simple option with no argument; set the reference to true. *)
+ (** Simple option with no argument; set the reference to true. *)
| Clear of bool ref
- (* Simple option with no argument; set the reference to false. *)
+ (** Simple option with no argument; set the reference to false. *)
| String of string * (string -> unit)
- (* Option requiring an argument; the first element in the tuple
- is the documentation string of the argument, and the second
- is the function to call. *)
+ (** Option requiring an argument; the first element in the tuple
+ is the documentation string of the argument, and the second
+ is the function to call. *)
| Set_string of string * string ref
- (* Option requiring an argument; the first element in the tuple
- is the documentation string of the argument, and the second
- is the reference to be set. *)
+ (** Option requiring an argument; the first element in the tuple
+ is the documentation string of the argument, and the second
+ is the reference to be set. *)
| Int of string * (int -> unit)
- (* Option requiring an integer value as argument; the first
- element in the tuple is the documentation string of the
- argument, and the second is the function to call. *)
+ (** Option requiring an integer value as argument; the first
+ element in the tuple is the documentation string of the
+ argument, and the second is the function to call. *)
| Set_int of string * int ref
- (* Option requiring an integer value as argument; the first
- element in the tuple is the documentation string of the
- argument, and the second is the reference to be set. *)
+ (** Option requiring an integer value as argument; the first
+ element in the tuple is the documentation string of the
+ argument, and the second is the reference to be set. *)
-type keys = string list
+module OptionName : sig
+ type option_name + | S of char (** short option like -a *)
+ | L of string (** long option like --add *)
+end
+type keys = OptionName.option_name list
type doc = string
type usage_msg = string
type anon_fun = (string -> unit)
@@ -49,7 +54,7 @@ type speclist = (keys * spec * doc) list
val hidden_option_description : string
-val compare_command_line_args : string -> string -> int
+val compare_command_line_args : OptionName.option_name ->
OptionName.option_name -> int
(** Compare command line arguments for equality, ignoring any leading [-]s. *)
type t
--
2.7.4
Richard W.M. Jones
2016-Jul-15 21:37 UTC
[Libguestfs] [PATCH 3/3] mllib: tests: Add tests of the new Getopt module.
---
.gitignore | 1 +
mllib/Makefile.am | 30 ++++++++-
mllib/getopt_tests.ml | 68 ++++++++++++++++++++
mllib/test-getopt.sh | 168 ++++++++++++++++++++++++++++++++++++++++++++++++++
4 files changed, 265 insertions(+), 2 deletions(-)
create mode 100644 mllib/getopt_tests.ml
create mode 100755 mllib/test-getopt.sh
diff --git a/.gitignore b/.gitignore
index 000e984..c1ae484 100644
--- a/.gitignore
+++ b/.gitignore
@@ -295,6 +295,7 @@ Makefile.in
/mllib/common_gettext.ml
/mllib/common_utils_tests
/mllib/dummy
+/mllib/getopt_tests
/mllib/guestfs_config.ml
/mllib/JSON_tests
/mllib/libdir.ml
diff --git a/mllib/Makefile.am b/mllib/Makefile.am
index 4f50c52..dc36f26 100644
--- a/mllib/Makefile.am
+++ b/mllib/Makefile.am
@@ -162,6 +162,15 @@ common_utils_tests_CPPFLAGS = \
common_utils_tests_BOBJECTS = common_utils_tests.cmo
common_utils_tests_XOBJECTS = $(common_utils_tests_BOBJECTS:.cmo=.cmx)
+getopt_tests_SOURCES = dummy.c
+getopt_tests_CPPFLAGS = \
+ -I. \
+ -I$(top_builddir) \
+ -I$(shell $(OCAMLC) -where) \
+ -I$(top_srcdir)/src
+getopt_tests_BOBJECTS = getopt_tests.cmo
+getopt_tests_XOBJECTS = $(getopt_tests_BOBJECTS:.cmo=.cmx)
+
JSON_tests_SOURCES = dummy.c
JSON_tests_BOBJECTS = JSON_tests.cmo
JSON_tests_XOBJECTS = $(JSON_tests_BOBJECTS:.cmo=.cmx)
@@ -171,16 +180,24 @@ if !HAVE_OCAMLOPT
common_utils_tests_THEOBJECTS = $(common_utils_tests_BOBJECTS)
common_utils_tests.cmo: OCAMLPACKAGES += $(OCAMLPACKAGES_TESTS)
+getopt_tests_THEOBJECTS = $(getopt_tests_BOBJECTS)
+getopt_tests.cmo: OCAMLPACKAGES += $(OCAMLPACKAGES_TESTS)
+
JSON_tests_THEOBJECTS = $(JSON_tests_BOBJECTS)
JSON_tests.cmo: OCAMLPACKAGES += $(OCAMLPACKAGES_TESTS)
+
BEST = c
OCAMLLINKFLAGS = mlguestfs.cma -custom
else
common_utils_tests_THEOBJECTS = $(common_utils_tests_XOBJECTS)
common_utils_tests.cmx: OCAMLPACKAGES += $(OCAMLPACKAGES_TESTS)
+getopt_tests_THEOBJECTS = $(getopt_tests_XOBJECTS)
+getopt_tests.cmx: OCAMLPACKAGES += $(OCAMLPACKAGES_TESTS)
+
JSON_tests_THEOBJECTS = $(JSON_tests_XOBJECTS)
JSON_tests.cmx: OCAMLPACKAGES += $(OCAMLPACKAGES_TESTS)
+
BEST = opt
OCAMLLINKFLAGS = mlguestfs.cmxa
endif
@@ -192,6 +209,13 @@ common_utils_tests_LINK = \
$(OCAMLPACKAGES) $(OCAMLPACKAGES_TESTS) \
$(common_utils_tests_THEOBJECTS) -o $@
+getopt_tests_DEPENDENCIES = $(getopt_tests_THEOBJECTS)
$(top_srcdir)/ocaml-link.sh
+getopt_tests_LINK = \
+ $(top_srcdir)/ocaml-link.sh -cclib '-lutils $(LIBXML2_LIBS) -lgnu' --
\
+ $(OCAMLFIND) $(BEST) $(OCAMLFLAGS) $(OCAMLLINKFLAGS) \
+ $(OCAMLPACKAGES) $(OCAMLPACKAGES_TESTS) \
+ $(getopt_tests_THEOBJECTS) -o $@
+
JSON_tests_DEPENDENCIES = $(JSON_tests_THEOBJECTS) $(top_srcdir)/ocaml-link.sh
JSON_tests_LINK = \
$(top_srcdir)/ocaml-link.sh -- \
@@ -201,8 +225,10 @@ JSON_tests_LINK = \
TESTS_ENVIRONMENT = $(top_builddir)/run --test
-TESTS -check_PROGRAMS +TESTS = \
+ test-getopt.sh
+check_PROGRAMS = \
+ getopt_tests
if HAVE_OCAML_PKG_OUNIT
check_PROGRAMS += common_utils_tests JSON_tests
diff --git a/mllib/getopt_tests.ml b/mllib/getopt_tests.ml
new file mode 100644
index 0000000..fb089ec
--- /dev/null
+++ b/mllib/getopt_tests.ml
@@ -0,0 +1,68 @@
+(* mllib
+ * Copyright (C) 2016 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 Getopt module. The tests are controlled by the
+ * test-getopt.sh script.
+ *)
+
+open Printf
+
+open Common_utils
+open Getopt.OptionName
+
+let adds = ref []
+let add_string = push_back adds
+
+let anons = ref []
+let anon_fun = push_back anons
+
+let ints = ref []
+let add_int = push_back ints
+
+let clear_flag = ref true
+let set_flag = ref false
+let si = ref 42
+let ss = ref "not set"
+
+let argspec = [
+ [ S 'a'; L"add" ], Getopt.String ("string",
add_string), "Add string";
+ [ S 'c'; L"clear" ], Getopt.Clear clear_flag, "Clear
flag";
+ [ S 'i'; L"int" ], Getopt.Int ("int", add_int),
"Add int";
+ [ L"si"; L"set-int" ], Getopt.Set_int ("int",
si), "Set int";
+ [ L"ss"; L"set-string"], Getopt.Set_string
("string", ss), "Set string";
+ [ S 't'; L"set" ], Getopt.Set set_flag, "Set
flag";
+]
+
+let usage_msg = sprintf "%s: test the Getopt parser" prog
+
+let opthandle = create_standard_options argspec ~anon_fun usage_msg
+let () + Getopt.parse opthandle;
+
+ (* Implicit settings. *)
+ printf "trace = %b\n" (trace ());
+ printf "verbose = %b\n" (verbose ());
+
+ (* Print the results. *)
+ printf "adds = [%s]\n" (String.concat ", " !adds);
+ printf "anons = [%s]\n" (String.concat ", " !anons);
+ printf "ints = [%s]\n" (String.concat ", " (List.map
string_of_int !ints));
+ 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
diff --git a/mllib/test-getopt.sh b/mllib/test-getopt.sh
new file mode 100755
index 0000000..1226554
--- /dev/null
+++ b/mllib/test-getopt.sh
@@ -0,0 +1,168 @@
+#!/bin/bash -
+# libguestfs
+# Copyright (C) 2016 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 Getopt module.
+# See also: getopt_tests.ml
+
+set -e
+set -x
+
+t=./getopt_tests
+
+expect_fail ()
+{
+ if "$@"; then
+ echo "$@" ": this command was expected to exit with an
error"
+ exit 1
+ fi
+}
+
+# Program works.
+$t
+
+# Flags added automatically by Common_utils.
+$t | grep '^trace = false'
+$t | grep '^verbose = false'
+
+$t -x | grep '^trace = true'
+$t --verbose | grep '^verbose = true'
+
+# --help
+$t --help | grep '^getopt_tests: test the Getopt parser'
+$t --help | grep '^Options:'
+$t --help | grep -- '-i, --int <int>'
+$t --help | grep -- '-v, --verbose'
+$t --help | grep -- '-x'
+
+# --version
+$t --version | grep '^getopt_tests 1\.'
+
+# --short-options
+$t --short-options | grep '^-a'
+$t --short-options | grep '^-c'
+$t --short-options | grep '^-i'
+$t --short-options | grep '^-q'
+$t --short-options | grep '^-t'
+$t --short-options | grep '^-V'
+$t --short-options | grep '^-v'
+$t --short-options | grep '^-x'
+
+# --long-options
+$t --long-options | grep '^--help'
+$t --long-options | grep '^--add'
+$t --long-options | grep '^--clear'
+$t --long-options | grep '^--color'
+$t --long-options | grep '^--colors'
+$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 '^--quiet'
+$t --long-options | grep '^--set'
+$t --long-options | grep '^--set-int'
+$t --long-options | grep '^--set-string'
+$t --long-options | grep '^--si'
+$t --long-options | grep '^--ss'
+$t --long-options | grep '^--version'
+$t --long-options | grep '^--verbose'
+
+# -a/--add parameter.
+$t | grep '^adds = \[\]'
+$t -a A | grep '^adds = \[A\]'
+$t -a A -a B | grep '^adds = \[A, B\]'
+$t --add A | grep '^adds = \[A\]'
+$t --add A -a B | grep '^adds = \[A, B\]'
+expect_fail $t -a
+expect_fail $t --add
+
+# -c/--clear parameter.
+$t | grep '^clear_flag = true'
+$t -c | grep '^clear_flag = false'
+$t --clear | grep '^clear_flag = false'
+
+# -i/--int parameter.
+$t | grep '^ints = \[\]'
+$t -i 1 | grep '^ints = \[1\]'
+$t -i 1 -i 2 | grep '^ints = \[1, 2\]'
+$t -i 1 --int 2 --int 3 | grep '^ints = \[1, 2, 3\]'
+expect_fail $t --int
+
+# Non-integer parameters.
+expect_fail $t --int --int
+expect_fail $t --int ""
+expect_fail $t --int ABC
+expect_fail $t --int 0.3
+expect_fail $t --int 0E
+expect_fail $t --int 0ABC
+
+# Negative and large integer parameters.
+$t -i -1 | grep '^ints = \[-1\]'
+$t -i -1073741824 | grep '^ints = \[-1073741824\]'
+$t -i 1073741823 | grep '^ints = \[1073741823\]'
+# These round incorrectly on 32 bit:
+#$t -i -2147483648 | grep '^ints = \[-2147483648\]'
+#$t -i 2147483647 | grep '^ints = \[2147483647\]'
+if [ `getconf LONG_BIT` = 64 ]; then
+ $t -i -2147483648 | grep '^ints = \[-2147483648\]'
+ $t -i 2147483647 | grep '^ints = \[2147483647\]'
+ $t -i -4611686018427387904 | grep '^ints =
\[-4611686018427387904\]'
+ $t -i 4611686018427387903 | grep '^ints = \[4611686018427387903\]'
+ # These round incorrectly on 64 bit:
+ #$t -i -9223372036854775808 | grep '^ints =
\[-9223372036854775808\]'
+ #$t -i 9223372036854775807 | grep '^ints =
\[9223372036854775807\]'
+fi
+
+# -t/--set parameter.
+$t | grep '^set_flag = false'
+$t -t | grep '^set_flag = true'
+$t --set | grep '^set_flag = true'
+
+# --si/--set-int parameter.
+$t | grep '^set_int = 42'
+$t --si 1 | grep '^set_int = 1'
+$t --set-int 2 | grep '^set_int = 2'
+expect_fail $t --si
+expect_fail $t --set-int
+expect_fail $t --set-int -i
+expect_fail $t --set-int ""
+expect_fail $t --set-int ABC
+expect_fail $t --set-int 0.3
+expect_fail $t --set-int 0E
+expect_fail $t --set-int 0ABC
+
+# --ss/--set-string parameter.
+$t | grep '^set_string = not set'
+$t --ss A | grep '^set_string = A'
+$t --set-string B | grep '^set_string = B'
+expect_fail $t --ss
+expect_fail $t --set-string
+
+# Anonymous parameters.
+$t | grep '^anons = \[\]'
+$t 1 | grep '^anons = \[1\]'
+$t 1 2 3 | grep '^anons = \[1, 2, 3\]'
+
+# Grouping single letter options.
+$t -cti1 | grep '^clear_flag = false'
+$t -cti1 | grep '^set_flag = true'
+$t -cti1 | grep '^ints = \[1\]'
+$t -i1 -i2 | grep '^ints = \[1, 2\]'
+
+# Short versions of long options (used by virt-v2v).
+$t -si 1 | grep '^set_int = 1'
+$t -ss A | grep '^set_string = A'
--
2.7.4
Pino Toscano
2016-Jul-18 08:13 UTC
Re: [Libguestfs] [PATCH 1/3] mllib: Fix parsing of integers on the command line and use correct int type.
On Friday, 15 July 2016 22:37:27 CEST Richard W.M. Jones wrote:> Currently input such as "1ABC" or "1.1" is parsed (as 1). If there is > trailing data on the command line, refuse to accept it. > > In addition this parses the integer into a C 'long', which is as close > as we can get to the OCaml idea of a native int. This prevents the > gross rounding error from the earlier code if the integer parameter > was larger than 32 bits (on a 64 bit platform), but is still not > completely free of rounding problems because the OCaml type is 31 or > 63 bits. > > Probably we should have explicit 'int32' and 'int64' types in the > OCaml code, instead of using (native) 'int'. > ---Ops, apologies, this should have been correct when sending the initial Getopt patch -- sending the fix I have locally here for few days. Thanks, -- Pino Toscano
Pino Toscano
2016-Jul-18 08:16 UTC
Re: [Libguestfs] [PATCH 3/3] mllib: tests: Add tests of the new Getopt module.
On Friday, 15 July 2016 22:37:29 CEST Richard W.M. Jones wrote:> ---Good idea, just a couple of notes.> +(* Test the Getopt module. The tests are controlled by the > + * test-getopt.sh script. > + *) > + > +open Printf > + > +open Common_utilsTheoretically Getopt is not tied to Common_utils, so it could be tested without it.> + > +t=./getopt_tests > + > +expect_fail () > +{ > + if "$@"; then > + echo "$@" ": this command was expected to exit with an error" > + exit 1 > + fi > +} > + > +# Program works. > +$tJust wondering whether GNU expect could be used here. Thanks, -- Pino Toscano