4:37 p.m.
---
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