[PATCH 0/3] mllib: Various fixes and changes to Getopt module.
The second patch is obviously not complete yet - for discussion only. Rich.
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
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
--- 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
--- .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
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_utils
Theoretically 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. +$t
Just wondering whether GNU expect could be used here. Thanks, -- Pino Toscano
participants (2)
-
Pino Toscano -
Richard W.M. Jones