Pino Toscano
2016-Jun-24 15:42 UTC
[Libguestfs] [PATCH] RFC: OCaml tools: add and use a Getopt module
Add a new Getopt module to mllib, to parse command line arguments with
handlers close to the ones used with Arg, but using getopt(3) (actually
getopt_long_only) to do the real parsing. This allow us to provide
options for OCaml tools with a syntax similar to the C tools, and use
the additional features getopt offers and Arg does not.
Do a single-step conversion of Common_utils and all the OCaml tools to
the syntax of Getopt.
As side-change due to the conversion, extra arguments for sysprep
operation can have more keys for the same argument.
---
builder/Makefile.am | 2 +
builder/cmdline.ml | 91 ++++---
customize/Makefile.am | 2 +
customize/customize_main.ml | 33 +--
dib/Makefile.am | 3 +
dib/cmdline.ml | 80 +++---
generator/customize.ml | 104 ++++----
get-kernel/Makefile.am | 2 +
get-kernel/get_kernel.ml | 26 +-
mllib/Makefile.am | 3 +
mllib/common_utils.ml | 54 ++--
mllib/common_utils.mli | 2 +-
mllib/getopt-c.c | 398 ++++++++++++++++++++++++++++++
mllib/getopt.ml | 51 ++++
mllib/getopt.mli | 73 ++++++
resize/Makefile.am | 2 +
resize/resize.ml | 51 ++--
sparsify/Makefile.am | 9 +-
sparsify/cmdline.ml | 24 +-
sysprep/Makefile.am | 2 +
sysprep/main.ml | 39 ++-
sysprep/sysprep_operation.ml | 26 +-
sysprep/sysprep_operation.mli | 6 +-
sysprep/sysprep_operation_script.ml | 4 +-
sysprep/sysprep_operation_user_account.ml | 4 +-
v2v/Makefile.am | 4 +
v2v/cmdline.ml | 90 +++----
v2v/copy_to_local.ml | 10 +-
28 files changed, 858 insertions(+), 337 deletions(-)
create mode 100644 mllib/getopt-c.c
create mode 100644 mllib/getopt.ml
create mode 100644 mllib/getopt.mli
diff --git a/builder/Makefile.am b/builder/Makefile.am
index ad32940..8c3ba26 100644
--- a/builder/Makefile.am
+++ b/builder/Makefile.am
@@ -91,6 +91,7 @@ SOURCES_ML = \
SOURCES_C = \
../mllib/dev_t-c.c \
../mllib/fsync-c.c \
+ ../mllib/getopt-c.c \
../mllib/uri-c.c \
../mllib/mkdtemp-c.c \
../customize/perl_edit-c.c \
@@ -137,6 +138,7 @@ BOBJECTS = \
$(top_builddir)/mllib/guestfs_config.cmo \
$(top_builddir)/mllib/common_gettext.cmo \
$(top_builddir)/mllib/dev_t.cmo \
+ $(top_builddir)/mllib/getopt.cmo \
$(top_builddir)/mllib/common_utils.cmo \
$(top_builddir)/mllib/fsync.cmo \
$(top_builddir)/mllib/planner.cmo \
diff --git a/builder/cmdline.ml b/builder/cmdline.ml
index eee8367..7a59ac2 100644
--- a/builder/cmdline.ml
+++ b/builder/cmdline.ml
@@ -119,54 +119,47 @@ let parse_cmdline () let warn_if_partition = ref true
in
let argspec = [
- "--arch", Arg.Set_string arch, "arch" ^ "
" ^ s_"Set the output architecture";
- "--attach", Arg.String attach_disk, "iso" ^ "
" ^ s_"Attach data disk/ISO during install";
- "--attach-format", Arg.String set_attach_format,
- "format" ^ " "
^ s_"Set attach disk format";
- "--cache", Arg.String set_cache, "dir" ^ "
" ^ s_"Set template cache dir";
- "--no-cache", Arg.Unit no_cache, " " ^
s_"Disable template cache";
- "--cache-all-templates", Arg.Unit cache_all_mode,
- " " ^ s_"Download
all templates to the cache";
- "--check-signature", Arg.Set check_signature,
- " " ^ s_"Check
digital signatures";
- "--check-signatures", Arg.Set check_signature,
- " " ^ s_"Check
digital signatures";
- "--no-check-signature", Arg.Clear check_signature,
- " " ^ s_"Disable
digital signatures";
- "--no-check-signatures", Arg.Clear check_signature,
- " " ^ s_"Disable
digital signatures";
- "--curl", Arg.Set_string curl, "curl" ^ "
" ^ s_"Set curl binary/command";
- "--delete-cache", Arg.Unit delete_cache_mode,
- " " ^ s_"Delete the
template cache";
- "--no-delete-on-failure", Arg.Clear delete_on_failure,
- " " ^ s_"Don't
delete output file on failure";
- "--fingerprint", Arg.String add_fingerprint,
- "AAAA.." ^ " "
^ s_"Fingerprint of valid signing key";
- "--format", Arg.Set_string format, "raw|qcow2" ^
" " ^ s_"Output format (default: raw)";
- "--get-kernel", Arg.Unit get_kernel_mode,
- "image" ^ " " ^
s_"Get kernel from image";
- "--gpg", Arg.Set_string gpg, "gpg" ^ "
" ^ s_"Set GPG binary/command";
- "-l", Arg.Unit list_mode, " " ^
s_"List available templates";
- "--list", Arg.Unit list_mode, " " ^
s_"List available templates";
- "--long", Arg.Unit list_set_long, " " ^
s_"Shortcut for --list-format long";
- "--list-format", Arg.String list_set_format,
- "short|long|json" ^
" " ^ s_"Set the format for --list (default: short)";
- "--machine-readable", Arg.Set machine_readable, " " ^
s_"Make output machine readable";
- "-m", Arg.Int set_memsize, "mb" ^ "
" ^ s_"Set memory size";
- "--memsize", Arg.Int set_memsize, "mb" ^ "
" ^ s_"Set memory size";
- "--network", Arg.Set network, " " ^
s_"Enable appliance network (default)";
- "--no-network", Arg.Clear network, " " ^
s_"Disable appliance network";
- "--notes", Arg.Unit notes_mode, " " ^
s_"Display installation notes";
- "-o", Arg.Set_string output, "file" ^ "
" ^ s_"Set output filename";
- "--output", Arg.Set_string output, "file" ^ "
" ^ s_"Set output filename";
- "--print-cache", Arg.Unit print_cache_mode,
- " " ^ s_"Print info
about template cache";
- "--size", Arg.String set_size, "size" ^ "
" ^ s_"Set output disk size";
- "--smp", Arg.Int set_smp, "vcpus" ^
" " ^ s_"Set number of vCPUs";
- "--source", Arg.String add_source, "URL" ^ "
" ^ s_"Set source URL";
- "--no-sync", Arg.Clear sync, " " ^
s_"Do not fsync output file on exit";
- "--no-warn-if-partition", Arg.Clear warn_if_partition,
- " " ^ s_"Do not warn
if writing to a partition";
+ [ "--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),
+ 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,
+ s_"Download all templates to
the cache";
+ [ "--check-signature"; "--check-signatures" ],
Getopt.Set check_signature,
+ s_"Check digital
signatures";
+ [ "--no-check-signature"; "--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,
+ s_"Delete the template
cache";
+ [ "--no-delete-on-failure" ], Getopt.Clear delete_on_failure,
+ s_"Don't delete output
file on failure";
+ [ "--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,
+ 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),
+ 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,
+ 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,
+ s_"Do not warn if writing to a
partition";
] in
let customize_argspec, get_customize_ops = Customize_cmdline.argspec () in
let customize_argspec @@ -192,7 +185,7 @@ A short summary of the options is
given below. For detailed help please
read the man page virt-builder(1).
")
prog in
- Arg.parse argspec anon_fun usage_msg;
+ Getopt.parse argspec ~anon_fun usage_msg;
(* Dereference options. *)
let args = List.rev !args in
diff --git a/customize/Makefile.am b/customize/Makefile.am
index de3d7e0..f18e238 100644
--- a/customize/Makefile.am
+++ b/customize/Makefile.am
@@ -70,6 +70,7 @@ SOURCES_C = \
../fish/file-edit.c \
../fish/file-edit.h \
../mllib/dev_t-c.c \
+ ../mllib/getopt-c.c \
../mllib/uri-c.c \
crypt-c.c \
perl_edit-c.c
@@ -96,6 +97,7 @@ BOBJECTS = \
$(top_builddir)/mllib/guestfs_config.cmo \
$(top_builddir)/mllib/common_gettext.cmo \
$(top_builddir)/mllib/dev_t.cmo \
+ $(top_builddir)/mllib/getopt.cmo \
$(top_builddir)/mllib/common_utils.cmo \
$(top_builddir)/mllib/regedit.cmo \
$(top_builddir)/mllib/URI.cmo \
diff --git a/customize/customize_main.ml b/customize/customize_main.ml
index 5b7712e..bfec533 100644
--- a/customize/customize_main.ml
+++ b/customize/customize_main.ml
@@ -71,24 +71,18 @@ let main () in
let argspec = [
- "-a", Arg.String add_file, s_"file" ^
" " ^ s_"Add disk image file";
- "--add", Arg.String add_file, s_"file" ^
" " ^ s_"Add disk image file";
- "--attach", Arg.String attach_disk, "iso" ^ "
" ^ s_"Attach data disk/ISO during install";
- "--attach-format", Arg.String set_attach_format,
- "format" ^ " "
^ s_"Set attach disk format";
- "-c", Arg.Set_string libvirturi, s_"uri" ^
" " ^ s_"Set libvirt URI";
- "--connect", Arg.Set_string libvirturi, s_"uri" ^
" " ^ s_"Set libvirt URI";
- "-d", Arg.String set_domain, s_"domain" ^
" " ^ s_"Set libvirt guest name";
- "--domain", Arg.String set_domain, s_"domain" ^
" " ^ s_"Set libvirt guest name";
- "-n", Arg.Set dryrun, " " ^
s_"Perform a dry run";
- "--dryrun", Arg.Set dryrun, " " ^
s_"Perform a dry run";
- "--dry-run", Arg.Set dryrun, " " ^
s_"Perform a dry run";
- "--format", Arg.String set_format, s_"format" ^
" " ^ s_"Set format (default: auto)";
- "-m", Arg.Int set_memsize, "mb" ^ "
" ^ s_"Set memory size";
- "--memsize", Arg.Int set_memsize, "mb" ^ "
" ^ s_"Set memory size";
- "--network", Arg.Set network, " " ^
s_"Enable appliance network (default)";
- "--no-network", Arg.Clear network, " " ^
s_"Disable appliance network";
- "--smp", Arg.Int set_smp, "vcpus" ^
" " ^ s_"Set number of vCPUs";
+ [ "-a"; "--add" ], Getopt.String
(s_"file", add_file), s_"Add disk image file";
+ [ "--attach" ], Getopt.String ("iso", attach_disk),
s_"Attach data disk/ISO during install";
+ [ "--attach-format" ], Getopt.String ("format",
set_attach_format),
+ s_"Set attach disk
format";
+ [ "-c"; "--connect" ], Getopt.Set_string
(s_"uri", libvirturi), s_"Set libvirt URI";
+ [ "-d"; "--domain" ], Getopt.String
(s_"domain", set_domain), s_"Set libvirt guest name";
+ [ "-n"; "--dryrun"; "--dry-run" ],
Getopt.Set dryrun, s_"Perform a dry run";
+ [ "--format" ], Getopt.String (s_"format",
set_format), s_"Set format (default: auto)";
+ [ "-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";
+ [ "--smp" ], Getopt.Int ("vcpus", set_smp),
s_"Set number of vCPUs";
] in
let customize_argspec, get_customize_ops Customize_cmdline.argspec () in
@@ -97,7 +91,6 @@ let main () let argspec = argspec @ customize_argspec in
let argspec = set_standard_options argspec in
- let anon_fun _ = raise (Arg.Bad (s_"extra parameter on the command
line")) in
let usage_msg sprintf (f_"\
%s: customize a virtual machine
@@ -110,7 +103,7 @@ A short summary of the options is given below. For detailed
help please
read the man page virt-customize(1).
")
prog in
- Arg.parse argspec anon_fun usage_msg;
+ Getopt.parse argspec usage_msg;
if not !format_consumed then
error (f_"--format parameter must appear before -a parameter");
diff --git a/dib/Makefile.am b/dib/Makefile.am
index ae6e878..8f60314 100644
--- a/dib/Makefile.am
+++ b/dib/Makefile.am
@@ -34,6 +34,7 @@ SOURCES_ML = \
SOURCES_C = \
../mllib/dev_t-c.c \
+ ../mllib/getopt-c.c \
../mllib/mkdtemp-c.c
bin_PROGRAMS @@ -60,6 +61,7 @@ BOBJECTS = \
$(top_builddir)/mllib/guestfs_config.cmo \
$(top_builddir)/mllib/common_gettext.cmo \
$(top_builddir)/mllib/dev_t.cmo \
+ $(top_builddir)/mllib/getopt.cmo \
$(top_builddir)/mllib/common_utils.cmo \
$(top_builddir)/mllib/mkdtemp.cmo \
$(SOURCES_ML:.ml=.cmo)
@@ -81,6 +83,7 @@ endif
OCAMLCLIBS = \
-pthread -lpthread \
-lutils \
+ $(LIBXML2_LIBS) \
$(LIBINTL) \
-lgnu
diff --git a/dib/cmdline.ml b/dib/cmdline.ml
index 3a97366..a4a95ba 100644
--- a/dib/cmdline.ml
+++ b/dib/cmdline.ml
@@ -156,51 +156,49 @@ read the man page virt-dib(1).
extra_packages := List.rev (String.nsplit "," arg) @
!extra_packages in
let argspec = [
- "-p", Arg.String append_element_path, "path"
^ " " ^ s_"Add new a elements location";
- "--element-path", Arg.String append_element_path,
"path" ^ " " ^ s_"Add new a elements location";
- "--exclude-element", Arg.String append_excluded_element,
- "element" ^ " " ^ s_"Exclude the specified
element";
- "--exclude-script", Arg.String append_excluded_script,
- "script" ^ " " ^ s_"Exclude the specified
script";
- "--envvar", Arg.String append_envvar,
"envvar[=value]" ^ " " ^ s_"Carry/set this environment
variable";
- "--skip-base", Arg.Clear use_base, " " ^
s_"Skip the inclusion of the 'base' element";
- "--root-label", Arg.String set_root_label, "label" ^
" " ^ s_"Label for the root fs";
- "--install-type", Arg.Set_string install_type, "type" ^
" " ^ s_"Installation type";
- "--image-cache", Arg.String set_image_cache,
"directory" ^ " " ^ s_"Location for cached
images";
- "-u", Arg.Clear compressed, " " ^
"Do not compress the qcow2 image";
- "--qemu-img-options", Arg.String set_qemu_img_options,
- "option" ^ "
" ^ s_"Add qemu-img options";
- "--mkfs-options", Arg.String set_mkfs_options,
- "option" ^ "
" ^ s_"Add mkfs options";
- "--extra-packages", Arg.String append_extra_packages,
- "pkg,..." ^ " " ^ s_"Add extra packages to
install";
-
- "--ramdisk", Arg.Set is_ramdisk, " " ^
"Switch to a ramdisk build";
- "--ramdisk-element", Arg.Set_string ramdisk_element,
"name" ^ " " ^ s_"Main element for building
ramdisks";
-
- "--name", Arg.Set_string image_name, "name" ^
" " ^ s_"Name of the image";
- "--fs-type", Arg.Set_string fs_type, "fs" ^
" " ^ s_"Filesystem for the image";
- "--size", Arg.String set_size, "size" ^
" " ^ s_"Set output disk size";
- "--formats", Arg.String set_format,
"qcow2,tgz,..." ^ " " ^ s_"Output formats";
- "--arch", Arg.Set_string arch, "arch" ^
" " ^ s_"Output architecture";
- "--drive", Arg.String set_drive, "path" ^
" " ^ s_"Optional drive for caches";
-
- "-m", Arg.Int set_memsize, "mb" ^
" " ^ s_"Set memory size";
- "--memsize", Arg.Int set_memsize, "mb" ^
" " ^ s_"Set memory size";
- "--network", Arg.Set network, " " ^
s_"Enable appliance network (default)";
- "--no-network", Arg.Clear network, " " ^
s_"Disable appliance network";
- "--smp", Arg.Int set_smp, "vcpus" ^
" " ^ s_"Set number of vCPUs";
- "--no-delete-on-failure", Arg.Clear delete_on_failure,
- " " ^
s_"Don't delete output file on failure";
- "--machine-readable", Arg.Set machine_readable, " " ^
s_"Make output machine readable";
-
- "--debug", Arg.Int set_debug, "level" ^
" " ^ s_"Set debug level";
- "-B", Arg.Set_string basepath, "path" ^
" " ^ s_"Base path of diskimage-builder library";
+ [ "-p"; "--element-path" ], Getopt.String
("path", append_element_path), s_"Add new a elements
location";
+ [ "--exclude-element" ], Getopt.String ("element",
append_excluded_element),
+ s_"Exclude the specified element";
+ [ "--exclude-script" ], Getopt.String ("script",
append_excluded_script),
+ s_"Exclude the specified script";
+ [ "--envvar" ], Getopt.String ("envvar[=value]",
append_envvar), s_"Carry/set this environment variable";
+ [ "--skip-base" ], Getopt.Clear use_base, s_"Skip
the inclusion of the 'base' element";
+ [ "--root-label" ], Getopt.String ("label",
set_root_label), s_"Label for the root fs";
+ [ "--install-type" ], Getopt.Set_string ("type",
install_type), s_"Installation type";
+ [ "--image-cache" ], Getopt.String ("directory",
set_image_cache), s_"Location for cached images";
+ [ "-u" ], Getopt.Clear compressed, "Do not
compress the qcow2 image";
+ [ "--qemu-img-options" ], Getopt.String ("option",
set_qemu_img_options),
+ s_"Add qemu-img
options";
+ [ "--mkfs-options" ], Getopt.String ("option",
set_mkfs_options),
+ s_"Add mkfs options";
+ [ "--extra-packages" ], Getopt.String ("pkg,...",
append_extra_packages),
+ s_"Add extra packages to install";
+
+ [ "--ramdisk" ], Getopt.Set is_ramdisk, "Switch to
a ramdisk build";
+ [ "--ramdisk-element" ], Getopt.Set_string ("name",
ramdisk_element), s_"Main element for building ramdisks";
+
+ [ "--name" ], Getopt.Set_string ("name",
image_name), s_"Name of the image";
+ [ "--fs-type" ], Getopt.Set_string ("fs", fs_type),
s_"Filesystem for the image";
+ [ "--size" ], Getopt.String ("size", set_size),
s_"Set output disk size";
+ [ "--formats" ], Getopt.String ("qcow2,tgz,...",
set_format), s_"Output formats";
+ [ "--arch" ], Getopt.Set_string ("arch", arch),
s_"Output architecture";
+ [ "--drive" ], Getopt.String ("path", set_drive),
s_"Optional drive for caches";
+
+ [ "-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";
+ [ "--smp" ], Getopt.Int ("vcpus", set_smp),
s_"Set number of vCPUs";
+ [ "--no-delete-on-failure" ], Getopt.Clear delete_on_failure,
+ s_"Don't delete output
file on failure";
+ [ "--machine-readable" ], Getopt.Set machine_readable,
s_"Make output machine readable";
+
+ [ "--debug" ], Getopt.Int ("level", set_debug),
s_"Set debug level";
+ [ "-B" ], Getopt.Set_string ("path",
basepath), s_"Base path of diskimage-builder library";
] in
let argspec = set_standard_options argspec in
- Arg.parse argspec append_element usage_msg;
+ Getopt.parse argspec ~anon_fun:append_element usage_msg;
let debug = !debug in
let basepath = !basepath in
diff --git a/generator/customize.ml b/generator/customize.ml
index 5db76d5..6df37b0 100644
--- a/generator/customize.ml
+++ b/generator/customize.ml
@@ -568,7 +568,7 @@ let rec generate_customize_cmdline_mli () pr
"\n";
pr "\
-type argspec = Arg.key * Arg.spec * Arg.doc
+type argspec = Getopt.keys * Getopt.spec * Getopt.doc
val argspec : unit -> (argspec * string option * string) list * (unit ->
ops)
(** This returns a pair [(list, get_ops)].
@@ -598,7 +598,7 @@ open Customize_utils
pr "\n";
pr "\
-type argspec = Arg.key * Arg.spec * Arg.doc
+type argspec = Getopt.keys * Getopt.spec * Getopt.doc
let rec argspec () let ops = ref [] in
@@ -652,115 +652,123 @@ 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 " Arg.Unit (fun () -> ops := %s :: !ops),\n"
discrim;
- pr " \" \" ^ s_\"%s\"\n" shortdesc;
+ pr " [ \"--%s\" ],\n" name;
+ pr " Getopt.Unit (fun () -> ops := %s :: !ops),\n"
discrim;
+ pr " s_\"%s\"\n" shortdesc;
pr " ),\n";
pr " None, %S;\n" longdesc
| { op_type = String v; op_name = name; op_discrim = discrim;
op_shortdesc = shortdesc; op_pod_longdesc = longdesc } ->
pr " (\n";
- pr " \"--%s\",\n" name;
- pr " Arg.String (fun s -> ops := %s s :: !ops),\n"
discrim;
- pr " s_\"%s\" ^ \" \" ^
s_\"%s\"\n" v shortdesc;
+ pr " [ \"--%s\" ],\n" name;
+ pr " Getopt.String (s_\"%s\", fun s -> ops := %s s
:: !ops),\n" v discrim;
+ pr " s_\"%s\"\n" shortdesc;
pr " ),\n";
pr " Some %S, %S;\n" v longdesc
| { op_type = StringPair v; op_name = name; op_discrim = discrim;
op_shortdesc = shortdesc; op_pod_longdesc = longdesc } ->
pr " (\n";
- pr " \"--%s\",\n" name;
- pr " Arg.String (\n";
+ pr " [ \"--%s\" ],\n" name;
+ pr " Getopt.String (\n";
+ pr " s_\"%s\",\n" v;
pr " fun s ->\n";
pr " let p = split_string_pair \"%s\" s
in\n" name;
pr " ops := %s p :: !ops\n" discrim;
pr " ),\n";
- pr " s_\"%s\" ^ \" \" ^
s_\"%s\"\n" v shortdesc;
+ pr " s_\"%s\"\n" shortdesc;
pr " ),\n";
pr " Some %S, %S;\n" v longdesc
| { op_type = StringList v; op_name = name; op_discrim = discrim;
op_shortdesc = shortdesc; op_pod_longdesc = longdesc } ->
pr " (\n";
- pr " \"--%s\",\n" name;
- pr " Arg.String (\n";
+ pr " [ \"--%s\" ],\n" name;
+ pr " Getopt.String (\n";
+ pr " s_\"%s\",\n" v;
pr " fun s ->\n";
pr " let ss = split_string_list s in\n";
pr " ops := %s ss :: !ops\n" discrim;
pr " ),\n";
- pr " s_\"%s\" ^ \" \" ^
s_\"%s\"\n" v shortdesc;
+ pr " s_\"%s\"\n" shortdesc;
pr " ),\n";
pr " Some %S, %S;\n" v longdesc
| { op_type = TargetLinks v; op_name = name; op_discrim = discrim;
op_shortdesc = shortdesc; op_pod_longdesc = longdesc } ->
pr " (\n";
- pr " \"--%s\",\n" name;
- pr " Arg.String (\n";
+ pr " [ \"--%s\" ],\n" name;
+ pr " Getopt.String (\n";
+ pr " s_\"%s\",\n" v;
pr " fun s ->\n";
pr " let ss = split_links_list \"%s\" s
in\n" name;
pr " ops := %s ss :: !ops\n" discrim;
pr " ),\n";
- pr " s_\"%s\" ^ \" \" ^
s_\"%s\"\n" v shortdesc;
+ pr " s_\"%s\"\n" shortdesc;
pr " ),\n";
pr " Some %S, %S;\n" v longdesc
| { op_type = PasswordSelector v; op_name = name; op_discrim = discrim;
op_shortdesc = shortdesc; op_pod_longdesc = longdesc } ->
pr " (\n";
- pr " \"--%s\",\n" name;
- pr " Arg.String (\n";
+ pr " [ \"--%s\" ],\n" name;
+ pr " Getopt.String (\n";
+ pr " s_\"%s\",\n" v;
pr " fun s ->\n";
pr " let sel = Password.parse_selector s in\n";
pr " ops := %s sel :: !ops\n" discrim;
pr " ),\n";
- pr " s_\"%s\" ^ \" \" ^
s_\"%s\"\n" v shortdesc;
+ pr " s_\"%s\"\n" shortdesc;
pr " ),\n";
pr " Some %S, %S;\n" v longdesc
| { op_type = UserPasswordSelector v; op_name = name; op_discrim = discrim;
op_shortdesc = shortdesc; op_pod_longdesc = longdesc } ->
pr " (\n";
- pr " \"--%s\",\n" name;
- pr " Arg.String (\n";
+ pr " [ \"--%s\" ],\n" name;
+ pr " Getopt.String (\n";
+ pr " s_\"%s\",\n" v;
pr " fun s ->\n";
pr " let user, sel = split_string_pair \"%s\" s
in\n" name;
pr " let sel = Password.parse_selector sel in\n";
pr " ops := %s (user, sel) :: !ops\n" discrim;
pr " ),\n";
- pr " s_\"%s\" ^ \" \" ^
s_\"%s\"\n" v shortdesc;
+ pr " s_\"%s\"\n" shortdesc;
pr " ),\n";
pr " Some %S, %S;\n" v longdesc
| { op_type = SSHKeySelector v; op_name = name; op_discrim = discrim;
op_shortdesc = shortdesc; op_pod_longdesc = longdesc } ->
pr " (\n";
- pr " \"--%s\",\n" name;
- pr " Arg.String (\n";
+ pr " [ \"--%s\" ],\n" name;
+ pr " Getopt.String (\n";
+ pr " s_\"%s\",\n" v;
pr " fun s ->\n";
pr " let user, selstr = String.split \":\" s
in\n";
pr " let sel = Ssh_key.parse_selector selstr in\n";
pr " ops := %s (user, sel) :: !ops\n" discrim;
pr " ),\n";
- pr " s_\"%s\" ^ \" \" ^
s_\"%s\"\n" v shortdesc;
+ pr " s_\"%s\"\n" shortdesc;
pr " ),\n";
pr " Some %S, %S;\n" v longdesc
| { 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 " Arg.String (\n";
+ pr " [ \"--%s\" ],\n" name;
+ pr " Getopt.String (\n";
+ pr " s_\"%s\",\n" v;
pr " fun s ->\n";
pr " %s s;\n" fn;
pr " ops := %s s :: !ops\n" discrim;
pr " ),\n";
- pr " s_\"%s\" ^ \" \" ^
s_\"%s\"\n" v shortdesc;
+ pr " s_\"%s\"\n" shortdesc;
pr " ),\n";
pr " Some %S, %S;\n" v longdesc
| { op_type = SMPoolSelector v; op_name = name; op_discrim = discrim;
op_shortdesc = shortdesc; op_pod_longdesc = longdesc } ->
pr " (\n";
- pr " \"--%s\",\n" name;
- pr " Arg.String (\n";
+ pr " [ \"--%s\" ],\n" name;
+ pr " Getopt.String (\n";
+ pr " s_\"%s\",\n" v;
pr " fun s ->\n";
pr " let sel = Subscription_manager.parse_pool_selector s
in\n";
pr " ops := %s sel :: !ops\n" discrim;
pr " ),\n";
- pr " s_\"%s\" ^ \" \" ^
s_\"%s\"\n" v shortdesc;
+ pr " s_\"%s\"\n" shortdesc;
pr " ),\n";
pr " Some %S, %S;\n" v longdesc
) ops;
@@ -770,37 +778,39 @@ 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 " [ \"--%s\" ],\n" name;
if default (* is true *) then
- pr " Arg.Clear %s,\n" var
+ pr " Getopt.Clear %s,\n" var
else
- pr " Arg.Set %s,\n" var;
- pr " \" \" ^ s_\"%s\"\n" shortdesc;
+ pr " Getopt.Set %s,\n" var;
+ pr " s_\"%s\"\n" shortdesc;
pr " ),\n";
pr " None, %S;\n" longdesc
| { flag_type = FlagPasswordCrypto v; flag_ml_var = var;
flag_name = name; flag_shortdesc = shortdesc;
flag_pod_longdesc = longdesc } ->
pr " (\n";
- pr " \"--%s\",\n" name;
- pr " Arg.String (\n";
+ pr " [ \"--%s\" ],\n" name;
+ pr " Getopt.String (\n";
+ pr " s_\"%s\",\n" v;
pr " fun s ->\n";
pr " %s := Some (Password.password_crypto_of_string
s)\n" var;
pr " ),\n";
- pr " \"%s\" ^ \" \" ^
s_\"%s\"\n" v shortdesc;
+ pr " s_\"%s\"\n" shortdesc;
pr " ),\n";
pr " Some %S, %S;\n" v longdesc
| { flag_type = FlagSMCredentials v; flag_ml_var = var;
flag_name = name; flag_shortdesc = shortdesc;
flag_pod_longdesc = longdesc } ->
pr " (\n";
- pr " \"--%s\",\n" name;
- pr " Arg.String (\n";
+ pr " [ \"--%s\" ],\n" name;
+ pr " Getopt.String (\n";
+ pr " s_\"%s\",\n" v;
pr " fun s ->\n";
pr " %s := Some
(Subscription_manager.parse_credentials_selector s)\n"
var;
pr " ),\n";
- pr " \"%s\" ^ \" \" ^
s_\"%s\"\n" v shortdesc;
+ pr " s_\"%s\"\n" shortdesc;
pr " ),\n";
pr " Some %S, %S;\n" v longdesc
) flags;
@@ -844,13 +854,13 @@ pr " ] in
fun (cmd, arg) ->
try
let ((_, spec, _), _, _) = List.find (
- fun ((key, _, _), _, _) ->
- key = \"--\" ^ cmd
+ fun ((keys, _, _), _, _) ->
+ List.mem (\"--\" ^ cmd) keys
) argspec in
(match spec with
- | Arg.Unit fn -> fn ()
- | Arg.String fn -> fn arg
- | Arg.Set varref -> varref := true
+ | Getopt.Unit fn -> fn ()
+ | Getopt.String (_, fn) -> fn arg
+ | Getopt.Set varref -> varref := true
| _ -> error \"INTERNAL error: spec not handled for
%%s\" cmd
)
with Not_found ->
diff --git a/get-kernel/Makefile.am b/get-kernel/Makefile.am
index 6892fbb..c20de07 100644
--- a/get-kernel/Makefile.am
+++ b/get-kernel/Makefile.am
@@ -28,6 +28,7 @@ SOURCES_ML = \
SOURCES_C = \
../mllib/dev_t-c.c \
+ ../mllib/getopt-c.c \
../mllib/uri-c.c \
../fish/uri.c
@@ -59,6 +60,7 @@ BOBJECTS = \
$(top_builddir)/mllib/guestfs_config.cmo \
$(top_builddir)/mllib/common_gettext.cmo \
$(top_builddir)/mllib/dev_t.cmo \
+ $(top_builddir)/mllib/getopt.cmo \
$(top_builddir)/mllib/common_utils.cmo \
$(top_builddir)/mllib/URI.cmo \
$(SOURCES_ML:.ml=.cmo)
diff --git a/get-kernel/get_kernel.ml b/get-kernel/get_kernel.ml
index fed9faf..a9c1187 100644
--- a/get-kernel/get_kernel.ml
+++ b/get-kernel/get_kernel.ml
@@ -50,24 +50,18 @@ let parse_cmdline () error (f_"--prefix option
can only be given once");
prefix := Some p in
- let ditto = " -\"-" in
let argspec = [
- "-a", Arg.String set_file, s_"file" ^
" " ^ s_"Add disk image file";
- "--add", Arg.String set_file, s_"file" ^
" " ^ s_"Add disk image file";
- "-c", Arg.Set_string libvirturi, s_"uri" ^
" " ^ s_"Set libvirt URI";
- "--connect", Arg.Set_string libvirturi, s_"uri" ^
" " ^ s_"Set libvirt URI";
- "-d", Arg.String set_domain, s_"domain" ^
" " ^ s_"Set libvirt guest name";
- "--domain", Arg.String set_domain, s_"domain" ^
" " ^ s_"Set libvirt guest name";
- "--format", Arg.Set_string format, s_"format" ^
" " ^ s_"Format of input disk";
- "--machine-readable", Arg.Set machine_readable, " " ^
s_"Make output machine readable";
- "-o", Arg.Set_string output, s_"directory" ^
" " ^ s_"Output directory";
- "--output", Arg.Set_string output, ditto;
- "--unversioned-names", Arg.Set unversioned,
- " " ^ s_"Use
unversioned names for files";
- "--prefix", Arg.String set_prefix, "prefix" ^
" " ^ s_"Prefix for files";
+ [ "-a"; "--add" ], Getopt.String
(s_"file", set_file), s_"Add disk image file";
+ [ "-c"; "--connect" ], Getopt.Set_string
(s_"uri", libvirturi), s_"Set libvirt URI";
+ [ "-d"; "--domain" ], Getopt.String
(s_"domain", set_domain), s_"Set libvirt guest name";
+ [ "--format" ], Getopt.Set_string (s_"format",
format), s_"Format of input disk";
+ [ "--machine-readable" ], Getopt.Set machine_readable,
s_"Make output machine readable";
+ [ "-o"; "--output" ], Getopt.Set_string
(s_"directory", output), s_"Output directory";
+ [ "--unversioned-names" ], Getopt.Set unversioned,
+ s_"Use unversioned names for
files";
+ [ "--prefix" ], Getopt.String (s_"prefix",
set_prefix), s_"Prefix for files";
] in
let argspec = set_standard_options argspec in
- let anon_fun _ = raise (Arg.Bad (s_"extra parameter on the command
line")) in
let usage_msg sprintf (f_"\
%s: extract kernel and ramdisk from a guest
@@ -76,7 +70,7 @@ A short summary of the options is given below. For detailed
help please
read the man page virt-get-kernel(1).
")
prog in
- Arg.parse argspec anon_fun usage_msg;
+ Getopt.parse argspec usage_msg;
(* Machine-readable mode? Print out some facts about what
* this binary supports.
diff --git a/mllib/Makefile.am b/mllib/Makefile.am
index 10bbebf..b26ef72 100644
--- a/mllib/Makefile.am
+++ b/mllib/Makefile.am
@@ -30,6 +30,7 @@ SOURCES_MLI = \
common_utils.mli \
dev_t.mli \
fsync.mli \
+ getopt.mli \
JSON.mli \
mkdtemp.mli \
planner.mli \
@@ -43,6 +44,7 @@ SOURCES_ML = \
$(OCAML_BYTES_COMPAT_ML) \
libdir.ml \
common_gettext.ml \
+ getopt.ml \
dev_t.ml \
common_utils.ml \
fsync.ml \
@@ -59,6 +61,7 @@ SOURCES_C = \
../fish/uri.c \
dev_t-c.c \
fsync-c.c \
+ getopt-c.c \
mkdtemp-c.c \
progress-c.c \
statvfs-c.c \
diff --git a/mllib/common_utils.ml b/mllib/common_utils.ml
index a663027..1ea000f 100644
--- a/mllib/common_utils.ml
+++ b/mllib/common_utils.ml
@@ -562,20 +562,26 @@ let compare_command_line_args a b compare
(String.lowercase (skip_dashes a)) (String.lowercase (skip_dashes b))
(* Implement `--short-options' and `--long-options'. *)
-let long_options = ref ([] : (Arg.key * Arg.spec * Arg.doc) list)
+let long_options = ref ([] : (Getopt.keys * Getopt.spec * Getopt.doc) list)
let display_short_options () List.iter (
- fun (arg, _, _) ->
- if String.is_prefix arg "-" && not (String.is_prefix
arg "--") then
- printf "%s\n" arg
+ fun (args, _, _) ->
+ List.iter (
+ fun arg ->
+ if String.is_prefix arg "-" && not
(String.is_prefix arg "--") then
+ printf "%s\n" arg
+ ) args
) !long_options;
exit 0
let display_long_options () List.iter (
- fun (arg, _, _) ->
- if String.is_prefix arg "--" && arg <>
"--long-options" &&
- arg <> "--short-options" then
- printf "%s\n" arg
+ fun (args, _, _) ->
+ List.iter (
+ fun arg ->
+ if String.is_prefix arg "--" && arg <>
"--long-options" &&
+ arg <> "--short-options" then
+ printf "%s\n" arg
+ ) args
) !long_options;
exit 0
@@ -584,27 +590,23 @@ let set_standard_options argspec let set_debug_gc ()
at_exit (fun () -> Gc.compact()) in
let argspec = [
- "--short-options", Arg.Unit display_short_options, " "
^ s_"List short options (internal)";
- "--long-options", Arg.Unit display_long_options, " " ^
s_"List long options (internal)";
- "-V", Arg.Unit print_version_and_exit,
- " " ^ s_"Display
version and exit";
- "--version", Arg.Unit print_version_and_exit,
- " " ^ s_"Display
version and exit";
- "-v", Arg.Unit set_verbose, " " ^
s_"Enable libguestfs debugging messages";
- "--verbose", Arg.Unit set_verbose, " " ^
s_"Enable libguestfs debugging messages";
- "-x", Arg.Unit set_trace, " " ^
s_"Enable tracing of libguestfs calls";
- "--debug-gc", Arg.Unit set_debug_gc, " " ^
s_"Debug GC and memory allocations (internal)";
- "-q", Arg.Unit set_quiet, " " ^
s_"Don't print progress messages";
- "--quiet", Arg.Unit set_quiet, " " ^
s_"Don't print progress messages";
- "--color", Arg.Unit set_colours, " " ^
s_"Use ANSI colour sequences even if not tty";
- "--colors", Arg.Unit set_colours, " " ^
s_"Use ANSI colour sequences even if not tty";
- "--colour", Arg.Unit set_colours, " " ^
s_"Use ANSI colour sequences even if not tty";
- "--colours", Arg.Unit set_colours, " " ^
s_"Use ANSI colour sequences even if not tty";
+ [ "--short-options" ], Getopt.Unit display_short_options,
s_"List short options (internal)";
+ [ "--long-options" ], Getopt.Unit display_long_options,
s_"List long options (internal)";
+ [ "-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, s_"Debug GC
and memory allocations (internal)";
+ [ "-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";
] @ argspec in
+ let argspec = List.map (
+ fun (keys, action, doc) ->
+ List.hd (List.sort compare_command_line_args keys), (keys, action, doc)
+ ) argspec in
let argspec - let cmp (arg1, _, _) (arg2, _, _) =
compare_command_line_args arg1 arg2 in
+ let cmp (arg1, _) (arg2, _) = compare_command_line_args arg1 arg2 in
List.sort cmp argspec in
- let argspec = Arg.align argspec in
+ let argspec = List.map snd argspec in
long_options := argspec;
argspec
diff --git a/mllib/common_utils.mli b/mllib/common_utils.mli
index 5b0b9bb..bd0cbbf 100644
--- a/mllib/common_utils.mli
+++ b/mllib/common_utils.mli
@@ -222,7 +222,7 @@ val skip_dashes : string -> string
val compare_command_line_args : string -> string -> int
(** Compare command line arguments for equality, ignoring any leading [-]s. *)
-val set_standard_options : (Arg.key * Arg.spec * Arg.doc) list -> (Arg.key *
Arg.spec * Arg.doc) list
+val set_standard_options : (Getopt.keys * Getopt.spec * Getopt.doc) list ->
(Getopt.keys * Getopt.spec * Getopt.doc) list
(** Adds the standard libguestfs command line options to the specified ones,
sorting them, and setting [long_options] to them.
diff --git a/mllib/getopt-c.c b/mllib/getopt-c.c
new file mode 100644
index 0000000..d44448f
--- /dev/null
+++ b/mllib/getopt-c.c
@@ -0,0 +1,398 @@
+/* argument parsing using getopt(3)
+ * 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.
+ */
+
+#include <config.h>
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <stdint.h>
+#include <string.h>
+#include <unistd.h>
+#include <getopt.h>
+#include <stdbool.h>
+#include <libintl.h>
+#include <errno.h>
+#include <error.h>
+
+#include <caml/alloc.h>
+#include <caml/fail.h>
+#include <caml/memory.h>
+#include <caml/mlvalues.h>
+#include <caml/callback.h>
+#include <caml/printexc.h>
+
+#include <guestfs.h>
+#include "guestfs-internal-frontend.h"
+
+extern value guestfs_int_mllib_getopt_parse (value argsv, value specsv, value
anon_funv, value usage_msgv);
+
+#define Val_none Val_int(0)
+
+static void
+xwrite (int fd, const void *v_buf, size_t len)
+{
+ int r;
+ const char *buf = v_buf;
+
+ while (len > 0) {
+ r = write (fd, buf, len);
+ if (r == -1)
+ error (EXIT_FAILURE, errno, "write");
+ buf += r;
+ len -= r;
+ }
+}
+
+static void
+show_help (value specsv, value usage_msgv)
+{
+ CAMLparam2 (specsv, usage_msgv);
+ CAMLlocal4 (specv, keysv, actionv, docv);
+ FILE *f;
+ CLEANUP_FREE char *buf = NULL;
+ size_t buf_len = 0;
+ size_t i, specs_len;
+
+ f = open_memstream (&buf, &buf_len);
+ if (f == NULL)
+ error (EXIT_FAILURE, errno, "open_memstream");
+
+ fprintf (f, _("%s: %s\n"
+ "Options:\n"),
+ guestfs_int_program_name, String_val (usage_msgv));
+
+ specs_len = Wosize_val (specsv);
+
+ static const int column_wrap = 38;
+
+ for (i = 0; i < specs_len; ++i) {
+ size_t len, j;
+ const char *param = NULL;
+ int columns = 0;
+
+ specv = Field (specsv, i);
+ keysv = Field (specv, 0);
+ actionv = Field (specv, 1);
+ docv = Field (specv, 2);
+ len = Wosize_val (keysv);
+
+ if (len == 0)
+ continue;
+
+ switch (Tag_val (actionv)) {
+ case 0: /* Unit of (unit -> unit) */
+ case 1: /* Set of bool ref */
+ case 2: /* Clear of bool ref */
+ break;
+
+ case 3: /* String of string * (string -> unit) */
+ case 4: /* Set_string of string * string ref */
+ case 5: /* Int of string * (int -> unit) */
+ case 6: /* Set_int of string * int ref */
+ param = String_val (Field (actionv, 0));
+ break;
+
+ default:
+ error (EXIT_FAILURE, 0,
+ "internal error: unhandled Tag_val (actionv) = %d",
+ Tag_val (actionv));
+ }
+
+ columns += fprintf (f, " ");
+
+ for (j = 0; j < len; ++j) {
+ const char *key = String_val (Field (keysv, j));
+
+ if (j > 0)
+ columns += fprintf (f, ", ");
+ columns += fprintf (f, "%s", key);
+ }
+
+ if (param != NULL)
+ columns += fprintf (f, " <%s>", param);
+
+ if (columns >= column_wrap)
+ fprintf (f, "\n%*c", column_wrap, ' ');
+ else
+ fprintf (f, "%*c", column_wrap - columns, ' ');
+
+ fprintf (f, "%s\n", String_val (docv));
+ }
+
+ /* Close the FILE to update the buffer. */
+ fclose (f);
+ xwrite (STDOUT_FILENO, buf, buf_len);
+
+ exit (EXIT_SUCCESS);
+
+ CAMLreturn0;
+}
+
+static void __attribute__((noreturn))
+show_error (int status)
+{
+ fprintf (stderr, _("Try `%s --help' for more information.\n"),
+ guestfs_int_program_name);
+ exit (status);
+}
+
+static int
+find_spec (value specsv, int specs_len, char opt)
+{
+ CAMLparam1 (specsv);
+ CAMLlocal1 (keysv);
+ int i, ret;
+
+ for (i = 0; i < specs_len; ++i) {
+ int len, j;
+
+ keysv = Field (Field (specsv, i), 0);
+ len = Wosize_val (keysv);
+
+ for (j = 0; j < len; ++j) {
+ const char *key = String_val (Field (keysv, j));
+
+ if (key[0] == '-' && key[1] == opt) {
+ ret = i;
+ goto done;
+ }
+ }
+ }
+
+ ret = -1;
+
+ done:
+ CAMLreturnT (int, ret);
+}
+
+static void
+do_call1 (value funv, value paramv)
+{
+ CAMLparam2 (funv, paramv);
+ CAMLlocal1 (rv);
+
+ rv = caml_callback_exn (funv, paramv);
+
+ if (Is_exception_result (rv))
+ fprintf (stderr,
+ "libguestfs: uncaught OCaml exception in getopt callback:
%s",
+ caml_format_exception (Extract_exception (rv)));
+
+ CAMLreturn0;
+}
+
+value
+guestfs_int_mllib_getopt_parse (value argsv, value specsv, value anon_funv,
value usage_msgv)
+{
+ CAMLparam4 (argsv, specsv, anon_funv, usage_msgv);
+ CAMLlocal4 (specv, keysv, actionv, v);
+ size_t argc;
+ CLEANUP_FREE_STRING_LIST char **argv = NULL;
+ size_t specs_len, i;
+ CLEANUP_FREE char *optstring = NULL;
+ int optstring_len = 0;
+ CLEANUP_FREE struct option *longopts = NULL;
+ int longopts_len = 0;
+ int c;
+ int specv_index;
+
+ argc = Wosize_val (argsv);
+ argv = malloc (sizeof (char *) * (argc + 1));
+ if (argv == NULL)
+ caml_raise_out_of_memory ();
+ for (i = 0; i < argc; ++i) {
+ argv[i] = strdup (String_val (Field (argsv, i)));
+ if (argv[i] == NULL)
+ caml_raise_out_of_memory ();
+ }
+ argv[argc] = NULL;
+
+ specs_len = Wosize_val (specsv);
+
+ optstring = malloc (1);
+ if (optstring == NULL)
+ caml_raise_out_of_memory ();
+ longopts = malloc (sizeof (*longopts));
+ if (longopts == NULL)
+ caml_raise_out_of_memory ();
+
+ for (i = 0; i < specs_len; ++i) {
+ size_t len, j;
+
+ specv = Field (specsv, i);
+ keysv = Field (specv, 0);
+ actionv = Field (specv, 1);
+ len = Wosize_val (keysv);
+
+ if (len == 0)
+ caml_invalid_argument ("empty keys for Getopt spec");
+
+ for (j = 0; j < len; ++j) {
+ const char *key = String_val (Field (keysv, j));
+ size_t key_len = strlen (key);
+ int has_arg = 0;
+
+ if (key[0] != '-' || STREQ (key, "-") || STREQ (key,
"--")) {
+ char msg[1024];
+ snprintf (msg, sizeof msg, "invalid option key:
'%s'", key);
+ caml_invalid_argument (msg);
+ }
+
+ ++key;
+ if (key[0] == '-')
+ ++key;
+
+ switch (Tag_val (actionv)) {
+ case 0: /* Unit of (unit -> unit) */
+ case 1: /* Set of bool ref */
+ case 2: /* Clear of bool ref */
+ has_arg = 0;
+ break;
+
+ case 3: /* String of string * (string -> unit) */
+ case 4: /* Set_string of string * string ref */
+ case 5: /* Int of string * (int -> unit) */
+ case 6: /* Set_int of string * int ref */
+ has_arg = 1;
+ break;
+
+ default:
+ error (EXIT_FAILURE, 0,
+ "internal error: unhandled Tag_val (actionv) = %d",
+ Tag_val (actionv));
+ }
+
+ if (key_len == 2) { /* Single letter short option. */
+ char *newstring = realloc (optstring, optstring_len + 1 + has_arg + 1);
+ if (newstring == NULL)
+ caml_raise_out_of_memory ();
+ optstring = newstring;
+ optstring[optstring_len++] = key[0];
+ if (has_arg)
+ optstring[optstring_len++] = ':';
+ } else {
+ struct option *newopts = realloc (longopts, (longopts_len + 1 + 1) *
sizeof (*longopts));
+ if (newopts == NULL)
+ caml_raise_out_of_memory ();
+ longopts = newopts;
+ longopts[longopts_len].name = key;
+ longopts[longopts_len].has_arg = has_arg;
+ longopts[longopts_len].flag = &specv_index;
+ longopts[longopts_len].val = i;
+ ++longopts_len;
+ }
+ }
+ }
+
+ /* Zero entries at the end. */
+ optstring[optstring_len] = 0;
+ longopts[longopts_len].name = NULL;
+ longopts[longopts_len].has_arg = 0;
+ longopts[longopts_len].flag = NULL;
+ longopts[longopts_len].val = 0;
+
+ for (;;) {
+ int option_index = -1;
+ c = getopt_long_only (argc, argv, optstring, longopts, &option_index);
+ if (c == -1) break;
+
+ switch (c) {
+ case '?':
+ show_error (EXIT_FAILURE);
+ break;
+
+ case 0:
+ if (STREQ (longopts[option_index].name, "help")) {
+ show_help (specsv, usage_msgv);
+ }
+ /* specv_index set already -- nothing to do. */
+ break;
+
+ case 'h':
+ show_help (specsv, usage_msgv);
+ break;
+
+ default:
+ specv_index = find_spec (specsv, specs_len, c);
+ break;
+ }
+
+ specv = Field (specsv, specv_index);
+ actionv = Field (specv, 1);
+
+ switch (Tag_val (actionv)) {
+ int num;
+
+ case 0: /* Unit of (unit -> unit) */
+ do_call1 (Field (actionv, 0), Val_unit);
+ break;
+
+ case 1: /* Set of bool ref */
+ caml_modify (&Field (Field (actionv, 0), 0), Val_true);
+ break;
+
+ case 2: /* Clear of bool ref */
+ caml_modify (&Field (Field (actionv, 0), 0), Val_false);
+ break;
+
+ case 3: /* String of string * (string -> unit) */
+ do_call1 (Field (actionv, 1), caml_copy_string (optarg));
+ break;
+
+ case 4: /* Set_string of string * string ref */
+ caml_modify (&Field (Field (actionv, 1), 0), caml_copy_string
(optarg));
+ break;
+
+ case 5: /* Int of string * (int -> unit) */
+ if (sscanf (optarg, "%d", &num) != 1) {
+ fprintf (stderr, _("'%s' is not a numeric value.\n"),
+ guestfs_int_program_name);
+ show_error (EXIT_FAILURE);
+ }
+ do_call1 (Field (actionv, 1), Val_int (num));
+ break;
+
+ case 6: /* Set_int of string * int ref */
+ if (sscanf (optarg, "%d", &num) != 1) {
+ fprintf (stderr, _("'%s' is not a numeric value.\n"),
+ guestfs_int_program_name);
+ show_error (EXIT_FAILURE);
+ }
+ caml_modify (&Field (Field (actionv, 1), 0), Val_int (num));
+ break;
+
+ default:
+ error (EXIT_FAILURE, 0,
+ "internal error: unhandled Tag_val (actionv) = %d",
+ Tag_val (actionv));
+ }
+ }
+
+ if (optind < (int) argc) {
+ if (anon_funv == Val_none) {
+ fprintf (stderr, _("Extra parameter on the command line:
'%s'.\n"),
+ argv[optind]);
+ show_error (EXIT_FAILURE);
+ }
+ v = Field (anon_funv, 0);
+ while (optind < (int) argc)
+ do_call1 (v, caml_copy_string (argv[optind++]));
+ }
+
+ CAMLreturn (Val_unit);
+}
diff --git a/mllib/getopt.ml b/mllib/getopt.ml
new file mode 100644
index 0000000..f5cb11a
--- /dev/null
+++ b/mllib/getopt.ml
@@ -0,0 +1,51 @@
+(* Common utilities for OCaml tools in 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.
+ *)
+
+open Common_gettext.Gettext
+
+type spec + | Unit of (unit -> unit)
+ | Set of bool ref
+ | Clear of bool ref
+ | String of string * (string -> unit)
+ | Set_string of string * string ref
+ | Int of string * (int -> unit)
+ | Set_int of string * int ref
+
+type keys = string list
+type doc = string
+type usage_msg = string
+type anon_fun = (string -> unit)
+type c_keys = string array
+
+external getopt_parse : string array -> (c_keys * spec * doc) array ->
?anon_fun:anon_fun -> usage_msg -> unit =
"guestfs_int_mllib_getopt_parse"
+
+let parse_argv argv specs ?anon_fun usage_msg + let specs = specs @ [
+ (* Handled internally by getopt_parse. *)
+ [ "-h"; "-help"; "--help" ], Unit (fun ()
-> ()), s_"Display brief help";
+ ] in
+ let specs = List.map (
+ fun (keys, spec, doc) ->
+ (Array.of_list keys), spec, doc
+ ) specs in
+ let specs = Array.of_list specs in
+ getopt_parse argv specs ?anon_fun usage_msg
+
+let parse + parse_argv Sys.argv
diff --git a/mllib/getopt.mli b/mllib/getopt.mli
new file mode 100644
index 0000000..a100f1d
--- /dev/null
+++ b/mllib/getopt.mli
@@ -0,0 +1,73 @@
+(* Common utilities for OCaml tools in 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.
+ *)
+
+type spec + | Unit of (unit -> unit)
+ (* Simple option with no argument; call the function. *)
+ | Set of bool ref
+ (* Simple option with no argument; set the reference to true. *)
+ | Clear of bool ref
+ (* 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. *)
+ | 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. *)
+ | 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. *)
+ | 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. *)
+
+type keys = string list
+type doc = string
+type usage_msg = string
+type anon_fun = (string -> unit)
+
+val parse_argv : string array ->
+ (keys * spec * doc) list -> ?anon_fun:anon_fun -> usage_msg -> unit
+(** [Getopt.parse args speclist ?anon_fun usage_msg] parses the
+ specified arguments.
+
+ [args] is the array with command line arguments, with the first
+ element representing the application name/path.
+
+ [speclist] is a list of triples [(keys, spec, doc)]: [keys] is a
+ list of options, [spec] is the associated action, and [doc] is
+ the help text.
+
+ [anon_fun] is an optional function to handle non-option arguments;
+ not specifying one means that only options are allowed, and
+ non-options will cause an error.
+
+ [usage_msg] is the string which is printed before the list of
+ options as help text.
+
+ In case of errors, like non-integer value for [Int] or [Set_int],
+ an error message is printed, together with a pointer to use
+ [--help], and then the program exists. *)
+
+val parse :
+ (keys * spec * doc) list -> ?anon_fun:anon_fun -> usage_msg -> unit
+(** Call {!Getopt.parse_argv} on [Sys.argv]. *)
diff --git a/resize/Makefile.am b/resize/Makefile.am
index da5d42d..5fb311a 100644
--- a/resize/Makefile.am
+++ b/resize/Makefile.am
@@ -32,6 +32,7 @@ SOURCES_ML = \
SOURCES_C = \
../mllib/dev_t-c.c \
../mllib/fsync-c.c \
+ ../mllib/getopt-c.c \
../fish/progress.c \
../mllib/progress-c.c \
../fish/uri.c \
@@ -61,6 +62,7 @@ BOBJECTS = \
$(top_builddir)/mllib/guestfs_config.cmo \
$(top_builddir)/mllib/common_gettext.cmo \
$(top_builddir)/mllib/dev_t.cmo \
+ $(top_builddir)/mllib/getopt.cmo \
$(top_builddir)/mllib/common_utils.cmo \
$(SOURCES_ML:.ml=.cmo)
XOBJECTS = $(BOBJECTS:.cmo=.cmx)
diff --git a/resize/resize.ml b/resize/resize.ml
index 22386ce..e40ce60 100644
--- a/resize/resize.ml
+++ b/resize/resize.ml
@@ -182,35 +182,28 @@ let main () let sparse = ref true in
let unknown_fs_mode = ref "warn" in
- let ditto = " -\"-" in
let argspec = [
- "--align-first", Arg.Set_string align_first,
s_"never|always|auto" ^ " " ^ s_"Align first partition
(default: auto)";
- "--alignment", Arg.Set_int alignment, s_"sectors" ^
" " ^ s_"Set partition alignment (default: 128 sectors)";
- "--no-copy-boot-loader", Arg.Clear copy_boot_loader, "
" ^ s_"Don't copy boot loader";
- "-d", Arg.Unit set_verbose, " " ^
s_"Enable debugging messages";
- "--debug", Arg.Unit set_verbose, ditto;
- "--delete", Arg.String (add deletes), s_"part" ^
" " ^ s_"Delete partition";
- "--expand", Arg.String set_expand, s_"part" ^
" " ^ s_"Expand partition";
- "--no-expand-content", Arg.Clear expand_content, " "
^ s_"Don't expand content";
- "--no-extra-partition", Arg.Clear extra_partition, "
" ^ s_"Don't create extra partition";
- "--format", Arg.Set_string format, s_"format" ^
" " ^ s_"Format of input disk";
- "--ignore", Arg.String (add ignores), s_"part" ^
" " ^ s_"Ignore partition";
- "--lv-expand", Arg.String (add lv_expands), s_"lv" ^
" " ^ s_"Expand logical volume";
- "--LV-expand", Arg.String (add lv_expands), s_"lv" ^
ditto;
- "--lvexpand", Arg.String (add lv_expands), s_"lv" ^
ditto;
- "--LVexpand", Arg.String (add lv_expands), s_"lv" ^
ditto;
- "--machine-readable", Arg.Set machine_readable, " " ^
s_"Make output machine readable";
- "-n", Arg.Set dryrun, " " ^
s_"Don't perform changes";
- "--dry-run", Arg.Set dryrun, " " ^
s_"Don't perform changes";
- "--dryrun", Arg.Set dryrun, ditto;
- "--ntfsresize-force", Arg.Set ntfsresize_force, " " ^
s_"Force ntfsresize";
- "--output-format", Arg.Set_string output_format,
s_"format" ^ " " ^ s_"Format of output disk";
- "--resize", Arg.String (add resizes), s_"part=size"
^ " " ^ s_"Resize partition";
- "--resize-force", Arg.String (add resizes_force),
s_"part=size" ^ " " ^ s_"Forcefully resize
partition";
- "--shrink", Arg.String set_shrink, s_"part" ^
" " ^ s_"Shrink partition";
- "--no-sparse", Arg.Clear sparse, " " ^
s_"Turn off sparse copying";
- "--unknown-filesystems", Arg.Set_string unknown_fs_mode,
- s_"ignore|warn|error" ^
" " ^ s_"Behaviour on expand unknown filesystems (default:
warn)";
+ [ "--align-first" ], Getopt.Set_string
(s_"never|always|auto", align_first), s_"Align first partition
(default: auto)";
+ [ "--alignment" ], Getopt.Set_int (s_"sectors",
alignment), s_"Set partition alignment (default: 128 sectors)";
+ [ "--no-copy-boot-loader" ], Getopt.Clear copy_boot_loader,
s_"Don't copy boot loader";
+ [ "-d"; "--debug" ], Getopt.Unit set_verbose,
s_"Enable debugging messages";
+ [ "--delete" ], Getopt.String (s_"part", add
deletes), s_"Delete partition";
+ [ "--expand" ], Getopt.String (s_"part",
set_expand), s_"Expand partition";
+ [ "--no-expand-content" ], Getopt.Clear expand_content,
s_"Don't expand content";
+ [ "--no-extra-partition" ], Getopt.Clear extra_partition,
s_"Don't create extra partition";
+ [ "--format" ], Getopt.Set_string (s_"format",
format), s_"Format of input disk";
+ [ "--ignore" ], Getopt.String (s_"part", add
ignores), s_"Ignore partition";
+ [ "--lv-expand"; "--LV-expand";
"--lvexpand"; "--LVexpand" ], Getopt.String
(s_"lv", add lv_expands), s_"Expand logical volume";
+ [ "--machine-readable" ], Getopt.Set machine_readable,
s_"Make output machine readable";
+ [ "-n"; "--dry-run"; "--dryrun" ],
Getopt.Set dryrun, s_"Don't perform changes";
+ [ "--ntfsresize-force" ], Getopt.Set ntfsresize_force,
s_"Force ntfsresize";
+ [ "--output-format" ], Getopt.Set_string (s_"format",
output_format), s_"Format of output disk";
+ [ "--resize" ], Getopt.String (s_"part=size", add
resizes), s_"Resize partition";
+ [ "--resize-force" ], Getopt.String (s_"part=size",
add resizes_force), s_"Forcefully resize partition";
+ [ "--shrink" ], Getopt.String (s_"part",
set_shrink), s_"Shrink partition";
+ [ "--no-sparse" ], Getopt.Clear sparse, s_"Turn off
sparse copying";
+ [ "--unknown-filesystems" ], Getopt.Set_string
(s_"ignore|warn|error", unknown_fs_mode),
+ s_"Behaviour on expand
unknown filesystems (default: warn)";
] in
let argspec = set_standard_options argspec in
let disks = ref [] in
@@ -223,7 +216,7 @@ A short summary of the options is given below. For detailed
help please
read the man page virt-resize(1).
")
prog in
- Arg.parse argspec anon_fun usage_msg;
+ Getopt.parse argspec ~anon_fun usage_msg;
if verbose () then (
printf "command line:";
diff --git a/sparsify/Makefile.am b/sparsify/Makefile.am
index f9f0f8e..467790c 100644
--- a/sparsify/Makefile.am
+++ b/sparsify/Makefile.am
@@ -38,6 +38,7 @@ SOURCES_ML = \
SOURCES_C = \
../fish/progress.c \
../mllib/dev_t-c.c \
+ ../mllib/getopt-c.c \
../mllib/progress-c.c \
../mllib/statvfs-c.c
@@ -60,6 +61,7 @@ BOBJECTS = \
$(top_builddir)/mllib/guestfs_config.cmo \
$(top_builddir)/mllib/common_gettext.cmo \
$(top_builddir)/mllib/dev_t.cmo \
+ $(top_builddir)/mllib/getopt.cmo \
$(top_builddir)/mllib/common_utils.cmo \
$(top_builddir)/mllib/progress.cmo \
$(top_builddir)/mllib/StatVFS.cmo \
@@ -72,6 +74,7 @@ XOBJECTS = $(BOBJECTS:.cmo=.cmx)
OCAMLPACKAGES = \
-package str,unix \
-I $(top_builddir)/src/.libs \
+ -I $(top_builddir)/gnulib/lib/.libs \
-I $(top_builddir)/ocaml \
-I $(top_builddir)/mllib
if HAVE_OCAML_PKG_GETTEXT
@@ -79,7 +82,11 @@ OCAMLPACKAGES += -package gettext-stub
endif
OCAMLCLIBS = \
- $(LIBTINFO_LIBS)
+ -lutils \
+ $(LIBTINFO_LIBS) \
+ $(LIBXML2_LIBS) \
+ $(LIBINTL) \
+ -lgnu
OCAMLFLAGS = $(OCAML_FLAGS) $(OCAML_WARN_ERROR)
diff --git a/sparsify/cmdline.ml b/sparsify/cmdline.ml
index bd49e71..f43e648 100644
--- a/sparsify/cmdline.ml
+++ b/sparsify/cmdline.ml
@@ -63,19 +63,17 @@ let parse_cmdline () let tmp = ref "" in
let zeroes = ref [] in
- let ditto = " -\"-" in
let argspec = [
- "--check-tmpdir", Arg.String set_check_tmpdir,
"ignore|..." ^ " " ^ s_"Check there is enough space in
$TMPDIR";
- "--compress", Arg.Set compress, " " ^
s_"Compressed output format";
- "--convert", Arg.Set_string convert, s_"format" ^
" " ^ s_"Format of output disk (default: same as input)";
- "--format", Arg.Set_string format, s_"format" ^
" " ^ s_"Format of input disk";
- "--ignore", Arg.String (add ignores), s_"fs" ^ "
" ^ s_"Ignore filesystem";
- "--in-place", Arg.Set in_place, " " ^
s_"Modify the disk image in-place";
- "--inplace", Arg.Set in_place, ditto;
- "--machine-readable", Arg.Set machine_readable, " " ^
s_"Make output machine readable";
- "-o", Arg.Set_string option, s_"option" ^
" " ^ s_"Add qemu-img options";
- "--tmp", Arg.Set_string tmp,
s_"block|dir|prebuilt:file" ^ " " ^ s_"Set temporary
block device, directory or prebuilt file";
- "--zero", Arg.String (add zeroes), s_"fs" ^ "
" ^ s_"Zero filesystem";
+ [ "--check-tmpdir" ], Getopt.String ("ignore|...",
set_check_tmpdir), s_"Check there is enough space in $TMPDIR";
+ [ "--compress" ], Getopt.Set compress, s_"Compressed
output format";
+ [ "--convert" ], Getopt.Set_string (s_"format",
convert), s_"Format of output disk (default: same as input)";
+ [ "--format" ], Getopt.Set_string (s_"format",
format), s_"Format of input disk";
+ [ "--ignore" ], Getopt.String (s_"fs", add ignores),
s_"Ignore filesystem";
+ [ "--in-place"; "--inplace" ], Getopt.Set in_place,
s_"Modify the disk image in-place";
+ [ "--machine-readable" ], Getopt.Set machine_readable,
s_"Make output machine readable";
+ [ "-o" ], Getopt.Set_string (s_"option",
option), s_"Add qemu-img options";
+ [ "--tmp" ], Getopt.Set_string
(s_"block|dir|prebuilt:file", tmp), s_"Set temporary block
device, directory or prebuilt file";
+ [ "--zero" ], Getopt.String (s_"fs", add zeroes),
s_"Zero filesystem";
] in
let argspec = set_standard_options argspec in
let disks = ref [] in
@@ -92,7 +90,7 @@ A short summary of the options is given below. For detailed
help please
read the man page virt-sparsify(1).
")
prog in
- Arg.parse argspec anon_fun usage_msg;
+ Getopt.parse argspec ~anon_fun usage_msg;
(* Dereference the rest of the args. *)
let check_tmpdir = !check_tmpdir in
diff --git a/sysprep/Makefile.am b/sysprep/Makefile.am
index d4f1173..d69786e 100644
--- a/sysprep/Makefile.am
+++ b/sysprep/Makefile.am
@@ -81,6 +81,7 @@ SOURCES_ML = \
SOURCES_C = \
../mllib/dev_t-c.c \
+ ../mllib/getopt-c.c \
../mllib/uri-c.c \
../mllib/mkdtemp-c.c \
../customize/crypt-c.c \
@@ -109,6 +110,7 @@ BOBJECTS = \
$(top_builddir)/mllib/guestfs_config.cmo \
$(top_builddir)/mllib/common_gettext.cmo \
$(top_builddir)/mllib/dev_t.cmo \
+ $(top_builddir)/mllib/getopt.cmo \
$(top_builddir)/mllib/common_utils.cmo \
$(top_builddir)/mllib/URI.cmo \
$(top_builddir)/mllib/mkdtemp.cmo \
diff --git a/sysprep/main.ml b/sysprep/main.ml
index 35a259c..256ca4a 100644
--- a/sysprep/main.ml
+++ b/sysprep/main.ml
@@ -117,31 +117,24 @@ let main () in
let basic_args = [
- "-a", Arg.String add_file, s_"file" ^
" " ^ s_"Add disk image file";
- "--add", Arg.String add_file, s_"file" ^
" " ^ s_"Add disk image file";
- "-c", Arg.Set_string libvirturi, s_"uri" ^
" " ^ s_"Set libvirt URI";
- "--connect", Arg.Set_string libvirturi, s_"uri" ^
" " ^ s_"Set libvirt URI";
- "-d", Arg.String set_domain, s_"domain" ^
" " ^ s_"Set libvirt guest name";
- "--domain", Arg.String set_domain, s_"domain" ^
" " ^ s_"Set libvirt guest name";
- "-n", Arg.Set dryrun, " " ^
s_"Perform a dry run";
- "--dryrun", Arg.Set dryrun, " " ^
s_"Perform a dry run";
- "--dry-run", Arg.Set dryrun, " " ^
s_"Perform a dry run";
- "--dump-pod", Arg.Unit dump_pod, " " ^
s_"Dump POD (internal)";
- "--dump-pod-options", Arg.Unit dump_pod_options, " "
^ s_"Dump POD for options (internal)";
- "--enable", Arg.String set_enable,
s_"operations" ^ " " ^ s_"Enable specific
operations";
- "--format", Arg.String set_format, s_"format" ^
" " ^ s_"Set format (default: auto)";
- "--list-operations", Arg.Unit list_operations, " " ^
s_"List supported operations";
- "--mount-options", Arg.Set_string mount_opts,
s_"opts" ^ " " ^ s_"Set mount options (eg
/:noatime;/var:rw,noatime)";
- "--network", Arg.Set network, " " ^
s_"Enable appliance network";
- "--no-network", Arg.Clear network, " " ^
s_"Disable appliance network (default)";
- "--no-selinux-relabel", Arg.Unit (fun () -> ()),
- " " ^
s_"Compatibility option, does nothing";
- "--operation", Arg.String set_operations, " " ^
s_"Enable/disable specific operations";
- "--operations", Arg.String set_operations, " " ^
s_"Enable/disable specific operations";
+ [ "-a"; "--add" ], Getopt.String
(s_"file", add_file), s_"Add disk image file";
+ [ "-c"; "--connect" ], Getopt.Set_string
(s_"uri", libvirturi), s_"Set libvirt URI";
+ [ "-d"; "--domain" ], Getopt.String
(s_"domain", set_domain), s_"Set libvirt guest name";
+ [ "-n"; "--dryrun"; "--dry-run" ],
Getopt.Set dryrun, s_"Perform a dry run";
+ [ "--dump-pod" ], Getopt.Unit dump_pod, s_"Dump POD
(internal)";
+ [ "--dump-pod-options" ], Getopt.Unit dump_pod_options,
s_"Dump POD for options (internal)";
+ [ "--enable" ], Getopt.String (s_"operations",
set_enable), s_"Enable specific operations";
+ [ "--format" ], Getopt.String (s_"format",
set_format), s_"Set format (default: auto)";
+ [ "--list-operations" ], Getopt.Unit list_operations,
s_"List supported operations";
+ [ "--mount-options" ], Getopt.Set_string (s_"opts",
mount_opts), s_"Set mount options (eg /:noatime;/var:rw,noatime)";
+ [ "--network" ], Getopt.Set network, s_"Enable
appliance network";
+ [ "--no-network" ], Getopt.Clear network, s_"Disable
appliance network (default)";
+ [ "--no-selinux-relabel" ], Getopt.Unit (fun () -> ()),
+ s_"Compatibility option,
does nothing";
+ [ "--operation"; "--operations" ], Getopt.String
(s_"operations", set_operations), s_"Enable/disable specific
operations";
] in
let args = basic_args @ Sysprep_operation.extra_args () in
let argspec = set_standard_options args in
- let anon_fun _ = raise (Arg.Bad (s_"extra parameter on the command
line")) in
let usage_msg sprintf (f_"\
%s: reset or unconfigure a virtual machine so clones can be made
@@ -154,7 +147,7 @@ A short summary of the options is given below. For detailed
help please
read the man page virt-sysprep(1).
")
prog in
- Arg.parse argspec anon_fun usage_msg;
+ Getopt.parse argspec usage_msg;
if not !format_consumed then
error (f_"--format parameter must appear before -a parameter");
diff --git a/sysprep/sysprep_operation.ml b/sysprep/sysprep_operation.ml
index 057c8c5..8ffe2c7 100644
--- a/sysprep/sysprep_operation.ml
+++ b/sysprep/sysprep_operation.ml
@@ -49,7 +49,7 @@ type operation = {
perform_on_devices : device_side_effects callback option;
}
and extra_arg = {
- extra_argspec : Arg.key * Arg.spec * Arg.doc;
+ extra_argspec : Getopt.keys * Getopt.spec * Getopt.doc;
extra_pod_argval : string option;
extra_pod_description : string;
}
@@ -208,27 +208,33 @@ let dump_pod_options () let args = List.map (
function
| (op_name,
- { extra_argspec = (arg_name,
- (Arg.Unit _ | Arg.Bool _ | Arg.Set _ | Arg.Clear _),
+ { extra_argspec = (arg_names,
+ (Getopt.Unit _ | Getopt.Set _ | Getopt.Clear _),
_);
extra_pod_argval = None;
extra_pod_description = pod }) ->
- let heading = sprintf "B<%s>" arg_name in
- arg_name, (op_name, heading, pod)
+ List.map (
+ fun arg_name ->
+ let heading = sprintf "B<%s>" arg_name in
+ arg_name, (op_name, heading, pod)
+ ) arg_names
| (op_name,
- { extra_argspec = (arg_name,
- (Arg.String _ | Arg.Set_string _ | Arg.Int _ |
- Arg.Set_int _ | Arg.Float _ | Arg.Set_float _),
+ { extra_argspec = (arg_names,
+ (Getopt.String _ | Getopt.Set_string _ | Getopt.Int
_),
_);
extra_pod_argval = Some arg_val;
extra_pod_description = pod }) ->
- let heading = sprintf "B<%s> %s" arg_name arg_val in
- arg_name, (op_name, heading, pod)
+ List.map (
+ fun arg_name ->
+ let heading = sprintf "B<%s> %s" arg_name arg_val in
+ arg_name, (op_name, heading, pod)
+ ) arg_names
| _ ->
failwith "sysprep_operation.ml: argument type not implemented"
) args in
+ let args = List.flatten args in
let args List.sort (fun (a, _) (b, _) -> compare_command_line_args a
b) args in
diff --git a/sysprep/sysprep_operation.mli b/sysprep/sysprep_operation.mli
index f532a8c..48b65d7 100644
--- a/sysprep/sysprep_operation.mli
+++ b/sysprep/sysprep_operation.mli
@@ -106,8 +106,8 @@ type operation = {
}
and extra_arg = {
- extra_argspec : Arg.key * Arg.spec * Arg.doc;
- (** The argspec. See OCaml [Arg] module. *)
+ extra_argspec : Getopt.keys * Getopt.spec * Getopt.doc;
+ (** The argspec. See [Getopt] module in [mllib]. *)
extra_pod_argval : string option;
(** The argument value, used only in the virt-sysprep man page. *)
@@ -126,7 +126,7 @@ val bake : unit -> unit
(** 'Bake' is called after all modules have been registered. We
finalize the list of operations, sort it, and run some checks. *)
-val extra_args : unit -> (Arg.key * Arg.spec * Arg.doc) list
+val extra_args : unit -> (Getopt.keys * Getopt.spec * Getopt.doc) list
(** Get the list of extra arguments for the command line. *)
val dump_pod : unit -> unit
diff --git a/sysprep/sysprep_operation_script.ml
b/sysprep/sysprep_operation_script.ml
index 140225c..1725c8d 100644
--- a/sysprep/sysprep_operation_script.ml
+++ b/sysprep/sysprep_operation_script.ml
@@ -129,7 +129,7 @@ B<Note:> This is different from I<--firstboot>
scripts (which run
in the context of the guest when it is booting first time).
I<--script> scripts run on the host, not in the guest.");
extra_args = [
- { extra_argspec = "--scriptdir", Arg.String set_scriptdir,
s_"dir" ^ " " ^ s_"Mount point on host";
+ { extra_argspec = [ "--scriptdir" ], Getopt.String
(s_"dir", set_scriptdir), s_"Mount point on host";
extra_pod_argval = Some "SCRIPTDIR";
extra_pod_description = s_"\
The mount point (an empty directory on the host) used when
@@ -142,7 +142,7 @@ If I<--scriptdir> is not specified then a temporary
mountpoint
will be created."
};
- { extra_argspec = "--script", Arg.String add_script,
s_"script" ^ " " ^ s_"Script or program to run on
guest";
+ { extra_argspec = [ "--script" ], Getopt.String
(s_"script", add_script), s_"Script or program to run on
guest";
extra_pod_argval = Some "SCRIPT";
extra_pod_description = s_"\
Run the named C<SCRIPT> (a shell script or program) against the
diff --git a/sysprep/sysprep_operation_user_account.ml
b/sysprep/sysprep_operation_user_account.ml
index e71d5ea..cf7dc57 100644
--- a/sysprep/sysprep_operation_user_account.ml
+++ b/sysprep/sysprep_operation_user_account.ml
@@ -109,7 +109,7 @@ The \"root\" account is not removed.
See the I<--remove-user-accounts> parameter for a way to specify
how to remove only some users, or to not remove some others.");
extra_args = [
- { extra_argspec = "--remove-user-accounts", Arg.String
(add_users remove_users), s_"users" ^ " " ^ s_"Users to
remove";
+ { extra_argspec = [ "--remove-user-accounts" ], Getopt.String
(s_"users", add_users remove_users), s_"Users to remove";
extra_pod_argval = Some "USERS";
extra_pod_description = s_"\
The user accounts to be removed from the guest.
@@ -124,7 +124,7 @@ would only remove the user accounts C<bob> and
C<eve>.
This option can be specified multiple times."
};
- { extra_argspec = "--keep-user-accounts", Arg.String (add_users
keep_users), s_"users" ^ " " ^ s_"Users to keep";
+ { extra_argspec = [ "--keep-user-accounts" ], Getopt.String
(s_"users", add_users keep_users), s_"Users to keep";
extra_pod_argval = Some "USERS";
extra_pod_description = s_"\
The user accounts to be kept in the guest.
diff --git a/v2v/Makefile.am b/v2v/Makefile.am
index 05f4611..fcbf624 100644
--- a/v2v/Makefile.am
+++ b/v2v/Makefile.am
@@ -99,6 +99,7 @@ SOURCES_ML = \
SOURCES_C = \
../mllib/dev_t-c.c \
+ ../mllib/getopt-c.c \
../mllib/mkdtemp-c.c \
../mllib/statvfs-c.c \
domainxml-c.c \
@@ -126,6 +127,7 @@ BOBJECTS = \
$(top_builddir)/mllib/guestfs_config.cmo \
$(top_builddir)/mllib/common_gettext.cmo \
$(top_builddir)/mllib/dev_t.cmo \
+ $(top_builddir)/mllib/getopt.cmo \
$(top_builddir)/mllib/common_utils.cmo \
$(top_builddir)/mllib/regedit.cmo \
$(top_builddir)/mllib/mkdtemp.cmo \
@@ -178,6 +180,7 @@ virt_v2v_LINK = \
virt_v2v_copy_to_local_SOURCES = \
../mllib/dev_t-c.c \
../mllib/statvfs-c.c \
+ ../mllib/getopt-c.c \
domainxml-c.c \
utils-c.c \
xml-c.c
@@ -196,6 +199,7 @@ COPY_TO_LOCAL_BOBJECTS = \
$(top_builddir)/mllib/guestfs_config.cmo \
$(top_builddir)/mllib/common_gettext.cmo \
$(top_builddir)/mllib/dev_t.cmo \
+ $(top_builddir)/mllib/getopt.cmo \
$(top_builddir)/mllib/common_utils.cmo \
$(top_builddir)/mllib/JSON.cmo \
$(top_builddir)/mllib/StatVFS.cmo \
diff --git a/v2v/cmdline.ml b/v2v/cmdline.ml
index 1064987..ff0ab59 100644
--- a/v2v/cmdline.ml
+++ b/v2v/cmdline.ml
@@ -164,55 +164,47 @@ let parse_cmdline () and o_options String.concat
"|" (Modules_list.output_modules ()) in
- let ditto = " -\"-" in
let argspec = [
- "-b", Arg.String add_bridge, "in:out " ^
s_"Map bridge 'in' to 'out'";
- "--bridge", Arg.String add_bridge, "in:out " ^
ditto;
- "--compressed", Arg.Set compressed, " " ^
s_"Compress output file";
- "--dcpath", Arg.String (set_string_option_once
"--dcpath" dcpath),
- "path " ^
s_"Override dcPath (for vCenter)";
- "--dcPath", Arg.String (set_string_option_once
"--dcPath" dcpath),
- "path " ^ ditto;
- "--debug-overlay",Arg.Set debug_overlays,
- " " ^ s_"Save overlay files";
- "--debug-overlays",Arg.Set debug_overlays,
- ditto;
- "-i", Arg.String set_input_mode, i_options ^ " "
^ s_"Set input mode (default: libvirt)";
- "-ic", Arg.String (set_string_option_once "-ic"
input_conn),
- "uri " ^ s_"Libvirt
URI";
- "-if", Arg.String (set_string_option_once "-if"
input_format),
- "format " ^ s_"Input
format (for -i disk)";
- "--in-place", Arg.Set in_place, " " ^
s_"Only tune the guest in the input VM";
- "--machine-readable", Arg.Set machine_readable, " " ^
s_"Make output machine readable";
- "-n", Arg.String add_network, "in:out " ^
s_"Map network 'in' to 'out'";
- "--network", Arg.String add_network, "in:out " ^
ditto;
- "--no-copy", Arg.Clear do_copy, " " ^
s_"Just write the metadata";
- "--no-trim", Arg.String no_trim_warning,
- "-" ^ " " ^
s_"Ignored for backwards compatibility";
- "-o", Arg.String set_output_mode, o_options ^ "
" ^ s_"Set output mode (default: libvirt)";
- "-oa", Arg.String set_output_alloc,
- "sparse|preallocated " ^
s_"Set output allocation mode";
- "-oc", Arg.String (set_string_option_once "-oc"
output_conn),
- "uri " ^ s_"Libvirt
URI";
- "-of", Arg.String (set_string_option_once "-of"
output_format),
- "raw|qcow2 " ^
s_"Set output format";
- "-on", Arg.String (set_string_option_once "-on"
output_name),
- "name " ^ s_"Rename
guest when converting";
- "-os", Arg.String (set_string_option_once "-os"
output_storage),
- "storage " ^ s_"Set
output storage location";
- "--password-file", Arg.String (set_string_option_once
"--password-file" password_file),
- "file " ^ s_"Use
password from file";
- "--print-source", Arg.Set print_source, " " ^
s_"Print source and stop";
- "--qemu-boot", Arg.Set qemu_boot, " " ^
s_"Boot in qemu (-o qemu only)";
- "--root", Arg.String set_root_choice,"ask|... " ^
s_"How to choose root filesystem";
- "--vdsm-image-uuid", Arg.String add_vdsm_image_uuid, "uuid
" ^ s_"Output image UUID(s)";
- "--vdsm-vol-uuid", Arg.String add_vdsm_vol_uuid, "uuid
" ^ s_"Output vol UUID(s)";
- "--vdsm-vm-uuid", Arg.String (set_string_option_once
"--vdsm-vm-uuid" vdsm_vm_uuid),
- "uuid " ^ s_"Output
VM UUID";
- "--vdsm-ovf-output", Arg.String (set_string_option_once
"--vdsm-ovf-output" vdsm_ovf_output),
- " " ^ s_"Output OVF
file";
- "--vmtype", Arg.String vmtype_warning,
- "- " ^ s_"Ignored
for backwards compatibility";
+ [ "-b"; "--bridge" ], Getopt.String
("in:out", add_bridge), s_"Map bridge 'in' to
'out'";
+ [ "--compressed" ], Getopt.Set compressed, s_"Compress
output file";
+ [ "--dcpath"; "--dcPath" ], Getopt.String
("path", set_string_option_once "--dcpath" dcpath),
+ s_"Override dcPath (for
vCenter)";
+ [ "--debug-overlay"; "--debug-overlays" ], Getopt.Set
debug_overlays, s_"Save overlay files";
+ [ "-i" ], Getopt.String (i_options, set_input_mode),
s_"Set input mode (default: libvirt)";
+ [ "-ic" ], Getopt.String ("uri",
set_string_option_once "-ic" input_conn),
+ s_"Libvirt URI";
+ [ "-if" ], Getopt.String ("format",
set_string_option_once "-if" input_format),
+ s_"Input format (for -i
disk)";
+ [ "--in-place" ], Getopt.Set in_place, s_"Only tune
the guest in the input VM";
+ [ "--machine-readable" ], Getopt.Set machine_readable,
s_"Make output machine readable";
+ [ "-n"; "--network" ], Getopt.String
("in:out", add_network), s_"Map network 'in' to
'out'";
+ [ "--no-copy" ], Getopt.Clear do_copy, s_"Just write
the metadata";
+ [ "--no-trim" ], Getopt.String ("-", no_trim_warning),
+ s_"Ignored for backwards
compatibility";
+ [ "-o" ], Getopt.String (o_options, set_output_mode),
s_"Set output mode (default: libvirt)";
+ [ "-oa" ], Getopt.String ("sparse|preallocated",
set_output_alloc),
+ s_"Set output allocation
mode";
+ [ "-oc" ], Getopt.String ("uri",
set_string_option_once "-oc" output_conn),
+ s_"Libvirt URI";
+ [ "-of" ], Getopt.String ("raw|qcow2",
set_string_option_once "-of" output_format),
+ s_"Set output format";
+ [ "-on" ], Getopt.String ("name",
set_string_option_once "-on" output_name),
+ s_"Rename guest when
converting";
+ [ "-os" ], Getopt.String ("storage",
set_string_option_once "-os" output_storage),
+ s_"Set output storage
location";
+ [ "--password-file" ], Getopt.String ("file",
set_string_option_once "--password-file" password_file),
+ s_"Use password from
file";
+ [ "--print-source" ], Getopt.Set print_source, s_"Print
source and stop";
+ [ "--qemu-boot" ], Getopt.Set qemu_boot, s_"Boot in
qemu (-o qemu only)";
+ [ "--root" ], Getopt.String ("ask|... ",
set_root_choice), s_"How to choose root filesystem";
+ [ "--vdsm-image-uuid" ], Getopt.String ("uuid",
add_vdsm_image_uuid), s_"Output image UUID(s)";
+ [ "--vdsm-vol-uuid" ], Getopt.String ("uuid",
add_vdsm_vol_uuid), s_"Output vol UUID(s)";
+ [ "--vdsm-vm-uuid" ], Getopt.String ("uuid",
set_string_option_once "--vdsm-vm-uuid" vdsm_vm_uuid),
+ s_"Output VM UUID";
+ [ "--vdsm-ovf-output" ], Getopt.String ("-",
set_string_option_once "--vdsm-ovf-output" vdsm_ovf_output),
+ s_"Output OVF file";
+ [ "--vmtype" ], Getopt.String ("-", vmtype_warning),
+ s_"Ignored for backwards
compatibility";
] in
let argspec = set_standard_options argspec in
let args = ref [] in
@@ -239,7 +231,7 @@ A short summary of the options is given below. For detailed
help please
read the man page virt-v2v(1).
")
prog in
- Arg.parse argspec anon_fun usage_msg;
+ Getopt.parse argspec ~anon_fun usage_msg;
(* Dereference the arguments. *)
let args = List.rev !args in
diff --git a/v2v/copy_to_local.ml b/v2v/copy_to_local.ml
index 717ba50..b4245ae 100644
--- a/v2v/copy_to_local.ml
+++ b/v2v/copy_to_local.ml
@@ -41,10 +41,10 @@ let rec main ()
(* Handle the command line. *)
let argspec = [
- "-ic", Arg.String (set_string_option_once "-ic"
input_conn),
- "uri " ^ s_"Libvirt
URI";
- "--password-file", Arg.String (set_string_option_once
"--password-file" password_file),
- "file " ^ s_"Use
password from file";
+ [ "-ic" ], Getopt.String ("uri",
set_string_option_once "-ic" input_conn),
+ s_"Libvirt URI";
+ [ "--password-file" ], Getopt.String ("file",
set_string_option_once "--password-file" password_file),
+ s_"Use password from
file";
] in
let argspec = set_standard_options argspec in
let args = ref [] in
@@ -71,7 +71,7 @@ A short summary of the options is given below. For detailed
help please
read the man page virt-v2v-copy-to-local(1).
")
prog in
- Arg.parse argspec anon_fun usage_msg;
+ Getopt.parse argspec ~anon_fun usage_msg;
let args = !args in
let input_conn = !input_conn in
--
2.5.5
Richard W.M. Jones
2016-Jun-27 14:42 UTC
Re: [Libguestfs] [PATCH] RFC: OCaml tools: add and use a Getopt module
On Fri, Jun 24, 2016 at 05:42:37PM +0200, Pino Toscano wrote:> Add a new Getopt module to mllib, to parse command line arguments with > handlers close to the ones used with Arg, but using getopt(3) (actually > getopt_long_only) to do the real parsing. This allow us to provide > options for OCaml tools with a syntax similar to the C tools, and use > the additional features getopt offers and Arg does not. > > Do a single-step conversion of Common_utils and all the OCaml tools to > the syntax of Getopt. > > As side-change due to the conversion, extra arguments for sysprep > operation can have more keys for the same argument.In general terms, it's a very good change which really improves the tools. I have a few fairly minor issues below. ACK if you can clean all of those up.> builder/Makefile.am | 2 + > builder/cmdline.ml | 91 ++++--- > customize/Makefile.am | 2 + > customize/customize_main.ml | 33 +-- > dib/Makefile.am | 3 + > dib/cmdline.ml | 80 +++--- > generator/customize.ml | 104 ++++---- > get-kernel/Makefile.am | 2 + > get-kernel/get_kernel.ml | 26 +- > mllib/Makefile.am | 3 + > mllib/common_utils.ml | 54 ++-- > mllib/common_utils.mli | 2 +- > mllib/getopt-c.c | 398 ++++++++++++++++++++++++++++++ > mllib/getopt.ml | 51 ++++ > mllib/getopt.mli | 73 ++++++ > resize/Makefile.am | 2 + > resize/resize.ml | 51 ++-- > sparsify/Makefile.am | 9 +- > sparsify/cmdline.ml | 24 +- > sysprep/Makefile.am | 2 + > sysprep/main.ml | 39 ++- > sysprep/sysprep_operation.ml | 26 +- > sysprep/sysprep_operation.mli | 6 +- > sysprep/sysprep_operation_script.ml | 4 +- > sysprep/sysprep_operation_user_account.ml | 4 +- > v2v/Makefile.am | 4 + > v2v/cmdline.ml | 90 +++---- > v2v/copy_to_local.ml | 10 +- > 28 files changed, 858 insertions(+), 337 deletions(-) > create mode 100644 mllib/getopt-c.c > create mode 100644 mllib/getopt.ml > create mode 100644 mllib/getopt.mli > > diff --git a/builder/Makefile.am b/builder/Makefile.am > index ad32940..8c3ba26 100644 > --- a/builder/Makefile.am > +++ b/builder/Makefile.am > @@ -91,6 +91,7 @@ SOURCES_ML = \ > SOURCES_C = \ > ../mllib/dev_t-c.c \ > ../mllib/fsync-c.c \ > + ../mllib/getopt-c.c \ > ../mllib/uri-c.c \ > ../mllib/mkdtemp-c.c \ > ../customize/perl_edit-c.c \ > @@ -137,6 +138,7 @@ BOBJECTS = \ > $(top_builddir)/mllib/guestfs_config.cmo \ > $(top_builddir)/mllib/common_gettext.cmo \ > $(top_builddir)/mllib/dev_t.cmo \ > + $(top_builddir)/mllib/getopt.cmo \ > $(top_builddir)/mllib/common_utils.cmo \ > $(top_builddir)/mllib/fsync.cmo \ > $(top_builddir)/mllib/planner.cmo \ > diff --git a/builder/cmdline.ml b/builder/cmdline.ml > index eee8367..7a59ac2 100644 > --- a/builder/cmdline.ml > +++ b/builder/cmdline.ml > @@ -119,54 +119,47 @@ let parse_cmdline () > let warn_if_partition = ref true in > > let argspec = [ > - "--arch", Arg.Set_string arch, "arch" ^ " " ^ s_"Set the output architecture"; > - "--attach", Arg.String attach_disk, "iso" ^ " " ^ s_"Attach data disk/ISO during install"; > - "--attach-format", Arg.String set_attach_format, > - "format" ^ " " ^ s_"Set attach disk format"; > - "--cache", Arg.String set_cache, "dir" ^ " " ^ s_"Set template cache dir"; > - "--no-cache", Arg.Unit no_cache, " " ^ s_"Disable template cache"; > - "--cache-all-templates", Arg.Unit cache_all_mode, > - " " ^ s_"Download all templates to the cache"; > - "--check-signature", Arg.Set check_signature, > - " " ^ s_"Check digital signatures"; > - "--check-signatures", Arg.Set check_signature, > - " " ^ s_"Check digital signatures"; > - "--no-check-signature", Arg.Clear check_signature, > - " " ^ s_"Disable digital signatures"; > - "--no-check-signatures", Arg.Clear check_signature, > - " " ^ s_"Disable digital signatures"; > - "--curl", Arg.Set_string curl, "curl" ^ " " ^ s_"Set curl binary/command"; > - "--delete-cache", Arg.Unit delete_cache_mode, > - " " ^ s_"Delete the template cache"; > - "--no-delete-on-failure", Arg.Clear delete_on_failure, > - " " ^ s_"Don't delete output file on failure"; > - "--fingerprint", Arg.String add_fingerprint, > - "AAAA.." ^ " " ^ s_"Fingerprint of valid signing key"; > - "--format", Arg.Set_string format, "raw|qcow2" ^ " " ^ s_"Output format (default: raw)"; > - "--get-kernel", Arg.Unit get_kernel_mode, > - "image" ^ " " ^ s_"Get kernel from image"; > - "--gpg", Arg.Set_string gpg, "gpg" ^ " " ^ s_"Set GPG binary/command"; > - "-l", Arg.Unit list_mode, " " ^ s_"List available templates"; > - "--list", Arg.Unit list_mode, " " ^ s_"List available templates"; > - "--long", Arg.Unit list_set_long, " " ^ s_"Shortcut for --list-format long"; > - "--list-format", Arg.String list_set_format, > - "short|long|json" ^ " " ^ s_"Set the format for --list (default: short)"; > - "--machine-readable", Arg.Set machine_readable, " " ^ s_"Make output machine readable"; > - "-m", Arg.Int set_memsize, "mb" ^ " " ^ s_"Set memory size"; > - "--memsize", Arg.Int set_memsize, "mb" ^ " " ^ s_"Set memory size"; > - "--network", Arg.Set network, " " ^ s_"Enable appliance network (default)"; > - "--no-network", Arg.Clear network, " " ^ s_"Disable appliance network"; > - "--notes", Arg.Unit notes_mode, " " ^ s_"Display installation notes"; > - "-o", Arg.Set_string output, "file" ^ " " ^ s_"Set output filename"; > - "--output", Arg.Set_string output, "file" ^ " " ^ s_"Set output filename"; > - "--print-cache", Arg.Unit print_cache_mode, > - " " ^ s_"Print info about template cache"; > - "--size", Arg.String set_size, "size" ^ " " ^ s_"Set output disk size"; > - "--smp", Arg.Int set_smp, "vcpus" ^ " " ^ s_"Set number of vCPUs"; > - "--source", Arg.String add_source, "URL" ^ " " ^ s_"Set source URL"; > - "--no-sync", Arg.Clear sync, " " ^ s_"Do not fsync output file on exit"; > - "--no-warn-if-partition", Arg.Clear warn_if_partition, > - " " ^ s_"Do not warn if writing to a partition"; > + [ "--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), > + 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, > + s_"Download all templates to the cache"; > + [ "--check-signature"; "--check-signatures" ], Getopt.Set check_signature, > + s_"Check digital signatures"; > + [ "--no-check-signature"; "--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, > + s_"Delete the template cache"; > + [ "--no-delete-on-failure" ], Getopt.Clear delete_on_failure, > + s_"Don't delete output file on failure"; > + [ "--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, > + 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), > + 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, > + 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, > + s_"Do not warn if writing to a partition"; > ] in > let customize_argspec, get_customize_ops = Customize_cmdline.argspec () in > let customize_argspec > @@ -192,7 +185,7 @@ A short summary of the options is given below. For detailed help please > read the man page virt-builder(1). > ") > prog in > - Arg.parse argspec anon_fun usage_msg; > + Getopt.parse argspec ~anon_fun usage_msg; > > (* Dereference options. *) > let args = List.rev !args in > diff --git a/customize/Makefile.am b/customize/Makefile.am > index de3d7e0..f18e238 100644 > --- a/customize/Makefile.am > +++ b/customize/Makefile.am > @@ -70,6 +70,7 @@ SOURCES_C = \ > ../fish/file-edit.c \ > ../fish/file-edit.h \ > ../mllib/dev_t-c.c \ > + ../mllib/getopt-c.c \ > ../mllib/uri-c.c \ > crypt-c.c \ > perl_edit-c.c > @@ -96,6 +97,7 @@ BOBJECTS = \ > $(top_builddir)/mllib/guestfs_config.cmo \ > $(top_builddir)/mllib/common_gettext.cmo \ > $(top_builddir)/mllib/dev_t.cmo \ > + $(top_builddir)/mllib/getopt.cmo \ > $(top_builddir)/mllib/common_utils.cmo \ > $(top_builddir)/mllib/regedit.cmo \ > $(top_builddir)/mllib/URI.cmo \ > diff --git a/customize/customize_main.ml b/customize/customize_main.ml > index 5b7712e..bfec533 100644 > --- a/customize/customize_main.ml > +++ b/customize/customize_main.ml > @@ -71,24 +71,18 @@ let main () > in > > let argspec = [ > - "-a", Arg.String add_file, s_"file" ^ " " ^ s_"Add disk image file"; > - "--add", Arg.String add_file, s_"file" ^ " " ^ s_"Add disk image file"; > - "--attach", Arg.String attach_disk, "iso" ^ " " ^ s_"Attach data disk/ISO during install"; > - "--attach-format", Arg.String set_attach_format, > - "format" ^ " " ^ s_"Set attach disk format"; > - "-c", Arg.Set_string libvirturi, s_"uri" ^ " " ^ s_"Set libvirt URI"; > - "--connect", Arg.Set_string libvirturi, s_"uri" ^ " " ^ s_"Set libvirt URI"; > - "-d", Arg.String set_domain, s_"domain" ^ " " ^ s_"Set libvirt guest name"; > - "--domain", Arg.String set_domain, s_"domain" ^ " " ^ s_"Set libvirt guest name"; > - "-n", Arg.Set dryrun, " " ^ s_"Perform a dry run"; > - "--dryrun", Arg.Set dryrun, " " ^ s_"Perform a dry run"; > - "--dry-run", Arg.Set dryrun, " " ^ s_"Perform a dry run"; > - "--format", Arg.String set_format, s_"format" ^ " " ^ s_"Set format (default: auto)"; > - "-m", Arg.Int set_memsize, "mb" ^ " " ^ s_"Set memory size"; > - "--memsize", Arg.Int set_memsize, "mb" ^ " " ^ s_"Set memory size"; > - "--network", Arg.Set network, " " ^ s_"Enable appliance network (default)"; > - "--no-network", Arg.Clear network, " " ^ s_"Disable appliance network"; > - "--smp", Arg.Int set_smp, "vcpus" ^ " " ^ s_"Set number of vCPUs"; > + [ "-a"; "--add" ], Getopt.String (s_"file", add_file), s_"Add disk image file"; > + [ "--attach" ], Getopt.String ("iso", attach_disk), s_"Attach data disk/ISO during install"; > + [ "--attach-format" ], Getopt.String ("format", set_attach_format), > + s_"Set attach disk format"; > + [ "-c"; "--connect" ], Getopt.Set_string (s_"uri", libvirturi), s_"Set libvirt URI"; > + [ "-d"; "--domain" ], Getopt.String (s_"domain", set_domain), s_"Set libvirt guest name"; > + [ "-n"; "--dryrun"; "--dry-run" ], Getopt.Set dryrun, s_"Perform a dry run"; > + [ "--format" ], Getopt.String (s_"format", set_format), s_"Set format (default: auto)"; > + [ "-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"; > + [ "--smp" ], Getopt.Int ("vcpus", set_smp), s_"Set number of vCPUs"; > ] in > let customize_argspec, get_customize_ops > Customize_cmdline.argspec () in > @@ -97,7 +91,6 @@ let main () > let argspec = argspec @ customize_argspec in > let argspec = set_standard_options argspec in > > - let anon_fun _ = raise (Arg.Bad (s_"extra parameter on the command line")) in > let usage_msg > sprintf (f_"\ > %s: customize a virtual machine > @@ -110,7 +103,7 @@ A short summary of the options is given below. For detailed help please > read the man page virt-customize(1). > ") > prog in > - Arg.parse argspec anon_fun usage_msg; > + Getopt.parse argspec usage_msg; > > if not !format_consumed then > error (f_"--format parameter must appear before -a parameter"); > diff --git a/dib/Makefile.am b/dib/Makefile.am > index ae6e878..8f60314 100644 > --- a/dib/Makefile.am > +++ b/dib/Makefile.am > @@ -34,6 +34,7 @@ SOURCES_ML = \ > > SOURCES_C = \ > ../mllib/dev_t-c.c \ > + ../mllib/getopt-c.c \ > ../mllib/mkdtemp-c.c > > bin_PROGRAMS > @@ -60,6 +61,7 @@ BOBJECTS = \ > $(top_builddir)/mllib/guestfs_config.cmo \ > $(top_builddir)/mllib/common_gettext.cmo \ > $(top_builddir)/mllib/dev_t.cmo \ > + $(top_builddir)/mllib/getopt.cmo \ > $(top_builddir)/mllib/common_utils.cmo \ > $(top_builddir)/mllib/mkdtemp.cmo \ > $(SOURCES_ML:.ml=.cmo) > @@ -81,6 +83,7 @@ endif > OCAMLCLIBS = \ > -pthread -lpthread \ > -lutils \ > + $(LIBXML2_LIBS) \ > $(LIBINTL) \ > -lgnu > > diff --git a/dib/cmdline.ml b/dib/cmdline.ml > index 3a97366..a4a95ba 100644 > --- a/dib/cmdline.ml > +++ b/dib/cmdline.ml > @@ -156,51 +156,49 @@ read the man page virt-dib(1). > extra_packages := List.rev (String.nsplit "," arg) @ !extra_packages in > > let argspec = [ > - "-p", Arg.String append_element_path, "path" ^ " " ^ s_"Add new a elements location"; > - "--element-path", Arg.String append_element_path, "path" ^ " " ^ s_"Add new a elements location"; > - "--exclude-element", Arg.String append_excluded_element, > - "element" ^ " " ^ s_"Exclude the specified element"; > - "--exclude-script", Arg.String append_excluded_script, > - "script" ^ " " ^ s_"Exclude the specified script"; > - "--envvar", Arg.String append_envvar, "envvar[=value]" ^ " " ^ s_"Carry/set this environment variable"; > - "--skip-base", Arg.Clear use_base, " " ^ s_"Skip the inclusion of the 'base' element"; > - "--root-label", Arg.String set_root_label, "label" ^ " " ^ s_"Label for the root fs"; > - "--install-type", Arg.Set_string install_type, "type" ^ " " ^ s_"Installation type"; > - "--image-cache", Arg.String set_image_cache, "directory" ^ " " ^ s_"Location for cached images"; > - "-u", Arg.Clear compressed, " " ^ "Do not compress the qcow2 image"; > - "--qemu-img-options", Arg.String set_qemu_img_options, > - "option" ^ " " ^ s_"Add qemu-img options"; > - "--mkfs-options", Arg.String set_mkfs_options, > - "option" ^ " " ^ s_"Add mkfs options"; > - "--extra-packages", Arg.String append_extra_packages, > - "pkg,..." ^ " " ^ s_"Add extra packages to install"; > - > - "--ramdisk", Arg.Set is_ramdisk, " " ^ "Switch to a ramdisk build"; > - "--ramdisk-element", Arg.Set_string ramdisk_element, "name" ^ " " ^ s_"Main element for building ramdisks"; > - > - "--name", Arg.Set_string image_name, "name" ^ " " ^ s_"Name of the image"; > - "--fs-type", Arg.Set_string fs_type, "fs" ^ " " ^ s_"Filesystem for the image"; > - "--size", Arg.String set_size, "size" ^ " " ^ s_"Set output disk size"; > - "--formats", Arg.String set_format, "qcow2,tgz,..." ^ " " ^ s_"Output formats"; > - "--arch", Arg.Set_string arch, "arch" ^ " " ^ s_"Output architecture"; > - "--drive", Arg.String set_drive, "path" ^ " " ^ s_"Optional drive for caches"; > - > - "-m", Arg.Int set_memsize, "mb" ^ " " ^ s_"Set memory size"; > - "--memsize", Arg.Int set_memsize, "mb" ^ " " ^ s_"Set memory size"; > - "--network", Arg.Set network, " " ^ s_"Enable appliance network (default)"; > - "--no-network", Arg.Clear network, " " ^ s_"Disable appliance network"; > - "--smp", Arg.Int set_smp, "vcpus" ^ " " ^ s_"Set number of vCPUs"; > - "--no-delete-on-failure", Arg.Clear delete_on_failure, > - " " ^ s_"Don't delete output file on failure"; > - "--machine-readable", Arg.Set machine_readable, " " ^ s_"Make output machine readable"; > - > - "--debug", Arg.Int set_debug, "level" ^ " " ^ s_"Set debug level"; > - "-B", Arg.Set_string basepath, "path" ^ " " ^ s_"Base path of diskimage-builder library"; > + [ "-p"; "--element-path" ], Getopt.String ("path", append_element_path), s_"Add new a elements location"; > + [ "--exclude-element" ], Getopt.String ("element", append_excluded_element), > + s_"Exclude the specified element"; > + [ "--exclude-script" ], Getopt.String ("script", append_excluded_script), > + s_"Exclude the specified script"; > + [ "--envvar" ], Getopt.String ("envvar[=value]", append_envvar), s_"Carry/set this environment variable"; > + [ "--skip-base" ], Getopt.Clear use_base, s_"Skip the inclusion of the 'base' element"; > + [ "--root-label" ], Getopt.String ("label", set_root_label), s_"Label for the root fs"; > + [ "--install-type" ], Getopt.Set_string ("type", install_type), s_"Installation type"; > + [ "--image-cache" ], Getopt.String ("directory", set_image_cache), s_"Location for cached images"; > + [ "-u" ], Getopt.Clear compressed, "Do not compress the qcow2 image"; > + [ "--qemu-img-options" ], Getopt.String ("option", set_qemu_img_options), > + s_"Add qemu-img options"; > + [ "--mkfs-options" ], Getopt.String ("option", set_mkfs_options), > + s_"Add mkfs options"; > + [ "--extra-packages" ], Getopt.String ("pkg,...", append_extra_packages), > + s_"Add extra packages to install"; > + > + [ "--ramdisk" ], Getopt.Set is_ramdisk, "Switch to a ramdisk build"; > + [ "--ramdisk-element" ], Getopt.Set_string ("name", ramdisk_element), s_"Main element for building ramdisks"; > + > + [ "--name" ], Getopt.Set_string ("name", image_name), s_"Name of the image"; > + [ "--fs-type" ], Getopt.Set_string ("fs", fs_type), s_"Filesystem for the image"; > + [ "--size" ], Getopt.String ("size", set_size), s_"Set output disk size"; > + [ "--formats" ], Getopt.String ("qcow2,tgz,...", set_format), s_"Output formats"; > + [ "--arch" ], Getopt.Set_string ("arch", arch), s_"Output architecture"; > + [ "--drive" ], Getopt.String ("path", set_drive), s_"Optional drive for caches"; > + > + [ "-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"; > + [ "--smp" ], Getopt.Int ("vcpus", set_smp), s_"Set number of vCPUs"; > + [ "--no-delete-on-failure" ], Getopt.Clear delete_on_failure, > + s_"Don't delete output file on failure"; > + [ "--machine-readable" ], Getopt.Set machine_readable, s_"Make output machine readable"; > + > + [ "--debug" ], Getopt.Int ("level", set_debug), s_"Set debug level"; > + [ "-B" ], Getopt.Set_string ("path", basepath), s_"Base path of diskimage-builder library"; > ] in > > let argspec = set_standard_options argspec in > > - Arg.parse argspec append_element usage_msg; > + Getopt.parse argspec ~anon_fun:append_element usage_msg; > > let debug = !debug in > let basepath = !basepath in > diff --git a/generator/customize.ml b/generator/customize.ml > index 5db76d5..6df37b0 100644 > --- a/generator/customize.ml > +++ b/generator/customize.ml > @@ -568,7 +568,7 @@ let rec generate_customize_cmdline_mli () > pr "\n"; > > pr "\ > -type argspec = Arg.key * Arg.spec * Arg.doc > +type argspec = Getopt.keys * Getopt.spec * Getopt.doc > val argspec : unit -> (argspec * string option * string) list * (unit -> ops) > (** This returns a pair [(list, get_ops)]. > > @@ -598,7 +598,7 @@ open Customize_utils > pr "\n"; > > pr "\ > -type argspec = Arg.key * Arg.spec * Arg.doc > +type argspec = Getopt.keys * Getopt.spec * Getopt.doc > > let rec argspec () > let ops = ref [] in > @@ -652,115 +652,123 @@ 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 " Arg.Unit (fun () -> ops := %s :: !ops),\n" discrim; > - pr " \" \" ^ s_\"%s\"\n" shortdesc; > + pr " [ \"--%s\" ],\n" name; > + pr " Getopt.Unit (fun () -> ops := %s :: !ops),\n" discrim; > + pr " s_\"%s\"\n" shortdesc; > pr " ),\n"; > pr " None, %S;\n" longdesc > | { op_type = String v; op_name = name; op_discrim = discrim; > op_shortdesc = shortdesc; op_pod_longdesc = longdesc } -> > pr " (\n"; > - pr " \"--%s\",\n" name; > - pr " Arg.String (fun s -> ops := %s s :: !ops),\n" discrim; > - pr " s_\"%s\" ^ \" \" ^ s_\"%s\"\n" v shortdesc; > + pr " [ \"--%s\" ],\n" name; > + pr " Getopt.String (s_\"%s\", fun s -> ops := %s s :: !ops),\n" v discrim; > + pr " s_\"%s\"\n" shortdesc; > pr " ),\n"; > pr " Some %S, %S;\n" v longdesc > | { op_type = StringPair v; op_name = name; op_discrim = discrim; > op_shortdesc = shortdesc; op_pod_longdesc = longdesc } -> > pr " (\n"; > - pr " \"--%s\",\n" name; > - pr " Arg.String (\n"; > + pr " [ \"--%s\" ],\n" name; > + pr " Getopt.String (\n"; > + pr " s_\"%s\",\n" v; > pr " fun s ->\n"; > pr " let p = split_string_pair \"%s\" s in\n" name; > pr " ops := %s p :: !ops\n" discrim; > pr " ),\n"; > - pr " s_\"%s\" ^ \" \" ^ s_\"%s\"\n" v shortdesc; > + pr " s_\"%s\"\n" shortdesc; > pr " ),\n"; > pr " Some %S, %S;\n" v longdesc > | { op_type = StringList v; op_name = name; op_discrim = discrim; > op_shortdesc = shortdesc; op_pod_longdesc = longdesc } -> > pr " (\n"; > - pr " \"--%s\",\n" name; > - pr " Arg.String (\n"; > + pr " [ \"--%s\" ],\n" name; > + pr " Getopt.String (\n"; > + pr " s_\"%s\",\n" v; > pr " fun s ->\n"; > pr " let ss = split_string_list s in\n"; > pr " ops := %s ss :: !ops\n" discrim; > pr " ),\n"; > - pr " s_\"%s\" ^ \" \" ^ s_\"%s\"\n" v shortdesc; > + pr " s_\"%s\"\n" shortdesc; > pr " ),\n"; > pr " Some %S, %S;\n" v longdesc > | { op_type = TargetLinks v; op_name = name; op_discrim = discrim; > op_shortdesc = shortdesc; op_pod_longdesc = longdesc } -> > pr " (\n"; > - pr " \"--%s\",\n" name; > - pr " Arg.String (\n"; > + pr " [ \"--%s\" ],\n" name; > + pr " Getopt.String (\n"; > + pr " s_\"%s\",\n" v; > pr " fun s ->\n"; > pr " let ss = split_links_list \"%s\" s in\n" name; > pr " ops := %s ss :: !ops\n" discrim; > pr " ),\n"; > - pr " s_\"%s\" ^ \" \" ^ s_\"%s\"\n" v shortdesc; > + pr " s_\"%s\"\n" shortdesc; > pr " ),\n"; > pr " Some %S, %S;\n" v longdesc > | { op_type = PasswordSelector v; op_name = name; op_discrim = discrim; > op_shortdesc = shortdesc; op_pod_longdesc = longdesc } -> > pr " (\n"; > - pr " \"--%s\",\n" name; > - pr " Arg.String (\n"; > + pr " [ \"--%s\" ],\n" name; > + pr " Getopt.String (\n"; > + pr " s_\"%s\",\n" v; > pr " fun s ->\n"; > pr " let sel = Password.parse_selector s in\n"; > pr " ops := %s sel :: !ops\n" discrim; > pr " ),\n"; > - pr " s_\"%s\" ^ \" \" ^ s_\"%s\"\n" v shortdesc; > + pr " s_\"%s\"\n" shortdesc; > pr " ),\n"; > pr " Some %S, %S;\n" v longdesc > | { op_type = UserPasswordSelector v; op_name = name; op_discrim = discrim; > op_shortdesc = shortdesc; op_pod_longdesc = longdesc } -> > pr " (\n"; > - pr " \"--%s\",\n" name; > - pr " Arg.String (\n"; > + pr " [ \"--%s\" ],\n" name; > + pr " Getopt.String (\n"; > + pr " s_\"%s\",\n" v; > pr " fun s ->\n"; > pr " let user, sel = split_string_pair \"%s\" s in\n" name; > pr " let sel = Password.parse_selector sel in\n"; > pr " ops := %s (user, sel) :: !ops\n" discrim; > pr " ),\n"; > - pr " s_\"%s\" ^ \" \" ^ s_\"%s\"\n" v shortdesc; > + pr " s_\"%s\"\n" shortdesc; > pr " ),\n"; > pr " Some %S, %S;\n" v longdesc > | { op_type = SSHKeySelector v; op_name = name; op_discrim = discrim; > op_shortdesc = shortdesc; op_pod_longdesc = longdesc } -> > pr " (\n"; > - pr " \"--%s\",\n" name; > - pr " Arg.String (\n"; > + pr " [ \"--%s\" ],\n" name; > + pr " Getopt.String (\n"; > + pr " s_\"%s\",\n" v; > pr " fun s ->\n"; > pr " let user, selstr = String.split \":\" s in\n"; > pr " let sel = Ssh_key.parse_selector selstr in\n"; > pr " ops := %s (user, sel) :: !ops\n" discrim; > pr " ),\n"; > - pr " s_\"%s\" ^ \" \" ^ s_\"%s\"\n" v shortdesc; > + pr " s_\"%s\"\n" shortdesc; > pr " ),\n"; > pr " Some %S, %S;\n" v longdesc > | { 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 " Arg.String (\n"; > + pr " [ \"--%s\" ],\n" name; > + pr " Getopt.String (\n"; > + pr " s_\"%s\",\n" v; > pr " fun s ->\n"; > pr " %s s;\n" fn; > pr " ops := %s s :: !ops\n" discrim; > pr " ),\n"; > - pr " s_\"%s\" ^ \" \" ^ s_\"%s\"\n" v shortdesc; > + pr " s_\"%s\"\n" shortdesc; > pr " ),\n"; > pr " Some %S, %S;\n" v longdesc > | { op_type = SMPoolSelector v; op_name = name; op_discrim = discrim; > op_shortdesc = shortdesc; op_pod_longdesc = longdesc } -> > pr " (\n"; > - pr " \"--%s\",\n" name; > - pr " Arg.String (\n"; > + pr " [ \"--%s\" ],\n" name; > + pr " Getopt.String (\n"; > + pr " s_\"%s\",\n" v; > pr " fun s ->\n"; > pr " let sel = Subscription_manager.parse_pool_selector s in\n"; > pr " ops := %s sel :: !ops\n" discrim; > pr " ),\n"; > - pr " s_\"%s\" ^ \" \" ^ s_\"%s\"\n" v shortdesc; > + pr " s_\"%s\"\n" shortdesc; > pr " ),\n"; > pr " Some %S, %S;\n" v longdesc > ) ops; > @@ -770,37 +778,39 @@ 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 " [ \"--%s\" ],\n" name; > if default (* is true *) then > - pr " Arg.Clear %s,\n" var > + pr " Getopt.Clear %s,\n" var > else > - pr " Arg.Set %s,\n" var; > - pr " \" \" ^ s_\"%s\"\n" shortdesc; > + pr " Getopt.Set %s,\n" var; > + pr " s_\"%s\"\n" shortdesc; > pr " ),\n"; > pr " None, %S;\n" longdesc > | { flag_type = FlagPasswordCrypto v; flag_ml_var = var; > flag_name = name; flag_shortdesc = shortdesc; > flag_pod_longdesc = longdesc } -> > pr " (\n"; > - pr " \"--%s\",\n" name; > - pr " Arg.String (\n"; > + pr " [ \"--%s\" ],\n" name; > + pr " Getopt.String (\n"; > + pr " s_\"%s\",\n" v; > pr " fun s ->\n"; > pr " %s := Some (Password.password_crypto_of_string s)\n" var; > pr " ),\n"; > - pr " \"%s\" ^ \" \" ^ s_\"%s\"\n" v shortdesc; > + pr " s_\"%s\"\n" shortdesc; > pr " ),\n"; > pr " Some %S, %S;\n" v longdesc > | { flag_type = FlagSMCredentials v; flag_ml_var = var; > flag_name = name; flag_shortdesc = shortdesc; > flag_pod_longdesc = longdesc } -> > pr " (\n"; > - pr " \"--%s\",\n" name; > - pr " Arg.String (\n"; > + pr " [ \"--%s\" ],\n" name; > + pr " Getopt.String (\n"; > + pr " s_\"%s\",\n" v; > pr " fun s ->\n"; > pr " %s := Some (Subscription_manager.parse_credentials_selector s)\n" > var; > pr " ),\n"; > - pr " \"%s\" ^ \" \" ^ s_\"%s\"\n" v shortdesc; > + pr " s_\"%s\"\n" shortdesc; > pr " ),\n"; > pr " Some %S, %S;\n" v longdesc > ) flags; > @@ -844,13 +854,13 @@ pr " ] in > fun (cmd, arg) -> > try > let ((_, spec, _), _, _) = List.find ( > - fun ((key, _, _), _, _) -> > - key = \"--\" ^ cmd > + fun ((keys, _, _), _, _) -> > + List.mem (\"--\" ^ cmd) keys > ) argspec in > (match spec with > - | Arg.Unit fn -> fn () > - | Arg.String fn -> fn arg > - | Arg.Set varref -> varref := true > + | Getopt.Unit fn -> fn () > + | Getopt.String (_, fn) -> fn arg > + | Getopt.Set varref -> varref := true > | _ -> error \"INTERNAL error: spec not handled for %%s\" cmd > ) > with Not_found -> > diff --git a/get-kernel/Makefile.am b/get-kernel/Makefile.am > index 6892fbb..c20de07 100644 > --- a/get-kernel/Makefile.am > +++ b/get-kernel/Makefile.am > @@ -28,6 +28,7 @@ SOURCES_ML = \ > > SOURCES_C = \ > ../mllib/dev_t-c.c \ > + ../mllib/getopt-c.c \ > ../mllib/uri-c.c \ > ../fish/uri.c > > @@ -59,6 +60,7 @@ BOBJECTS = \ > $(top_builddir)/mllib/guestfs_config.cmo \ > $(top_builddir)/mllib/common_gettext.cmo \ > $(top_builddir)/mllib/dev_t.cmo \ > + $(top_builddir)/mllib/getopt.cmo \ > $(top_builddir)/mllib/common_utils.cmo \ > $(top_builddir)/mllib/URI.cmo \ > $(SOURCES_ML:.ml=.cmo) > diff --git a/get-kernel/get_kernel.ml b/get-kernel/get_kernel.ml > index fed9faf..a9c1187 100644 > --- a/get-kernel/get_kernel.ml > +++ b/get-kernel/get_kernel.ml > @@ -50,24 +50,18 @@ let parse_cmdline () > error (f_"--prefix option can only be given once"); > prefix := Some p in > > - let ditto = " -\"-" in > let argspec = [ > - "-a", Arg.String set_file, s_"file" ^ " " ^ s_"Add disk image file"; > - "--add", Arg.String set_file, s_"file" ^ " " ^ s_"Add disk image file"; > - "-c", Arg.Set_string libvirturi, s_"uri" ^ " " ^ s_"Set libvirt URI"; > - "--connect", Arg.Set_string libvirturi, s_"uri" ^ " " ^ s_"Set libvirt URI"; > - "-d", Arg.String set_domain, s_"domain" ^ " " ^ s_"Set libvirt guest name"; > - "--domain", Arg.String set_domain, s_"domain" ^ " " ^ s_"Set libvirt guest name"; > - "--format", Arg.Set_string format, s_"format" ^ " " ^ s_"Format of input disk"; > - "--machine-readable", Arg.Set machine_readable, " " ^ s_"Make output machine readable"; > - "-o", Arg.Set_string output, s_"directory" ^ " " ^ s_"Output directory"; > - "--output", Arg.Set_string output, ditto; > - "--unversioned-names", Arg.Set unversioned, > - " " ^ s_"Use unversioned names for files"; > - "--prefix", Arg.String set_prefix, "prefix" ^ " " ^ s_"Prefix for files"; > + [ "-a"; "--add" ], Getopt.String (s_"file", set_file), s_"Add disk image file"; > + [ "-c"; "--connect" ], Getopt.Set_string (s_"uri", libvirturi), s_"Set libvirt URI"; > + [ "-d"; "--domain" ], Getopt.String (s_"domain", set_domain), s_"Set libvirt guest name"; > + [ "--format" ], Getopt.Set_string (s_"format", format), s_"Format of input disk"; > + [ "--machine-readable" ], Getopt.Set machine_readable, s_"Make output machine readable"; > + [ "-o"; "--output" ], Getopt.Set_string (s_"directory", output), s_"Output directory"; > + [ "--unversioned-names" ], Getopt.Set unversioned, > + s_"Use unversioned names for files"; > + [ "--prefix" ], Getopt.String (s_"prefix", set_prefix), s_"Prefix for files"; > ] in > let argspec = set_standard_options argspec in > - let anon_fun _ = raise (Arg.Bad (s_"extra parameter on the command line")) in > let usage_msg > sprintf (f_"\ > %s: extract kernel and ramdisk from a guest > @@ -76,7 +70,7 @@ A short summary of the options is given below. For detailed help please > read the man page virt-get-kernel(1). > ") > prog in > - Arg.parse argspec anon_fun usage_msg; > + Getopt.parse argspec usage_msg; > > (* Machine-readable mode? Print out some facts about what > * this binary supports. > diff --git a/mllib/Makefile.am b/mllib/Makefile.am > index 10bbebf..b26ef72 100644 > --- a/mllib/Makefile.am > +++ b/mllib/Makefile.am > @@ -30,6 +30,7 @@ SOURCES_MLI = \ > common_utils.mli \ > dev_t.mli \ > fsync.mli \ > + getopt.mli \ > JSON.mli \ > mkdtemp.mli \ > planner.mli \ > @@ -43,6 +44,7 @@ SOURCES_ML = \ > $(OCAML_BYTES_COMPAT_ML) \ > libdir.ml \ > common_gettext.ml \ > + getopt.ml \ > dev_t.ml \ > common_utils.ml \ > fsync.ml \ > @@ -59,6 +61,7 @@ SOURCES_C = \ > ../fish/uri.c \ > dev_t-c.c \ > fsync-c.c \ > + getopt-c.c \ > mkdtemp-c.c \ > progress-c.c \ > statvfs-c.c \ > diff --git a/mllib/common_utils.ml b/mllib/common_utils.ml > index a663027..1ea000f 100644 > --- a/mllib/common_utils.ml > +++ b/mllib/common_utils.ml > @@ -562,20 +562,26 @@ let compare_command_line_args a b > compare (String.lowercase (skip_dashes a)) (String.lowercase (skip_dashes b)) > > (* Implement `--short-options' and `--long-options'. *) > -let long_options = ref ([] : (Arg.key * Arg.spec * Arg.doc) list) > +let long_options = ref ([] : (Getopt.keys * Getopt.spec * Getopt.doc) list) > let display_short_options () > List.iter ( > - fun (arg, _, _) -> > - if String.is_prefix arg "-" && not (String.is_prefix arg "--") then > - printf "%s\n" arg > + fun (args, _, _) -> > + List.iter ( > + fun arg -> > + if String.is_prefix arg "-" && not (String.is_prefix arg "--") then > + printf "%s\n" arg > + ) args > ) !long_options; > exit 0 > let display_long_options () > List.iter ( > - fun (arg, _, _) -> > - if String.is_prefix arg "--" && arg <> "--long-options" && > - arg <> "--short-options" then > - printf "%s\n" arg > + fun (args, _, _) -> > + List.iter ( > + fun arg -> > + if String.is_prefix arg "--" && arg <> "--long-options" && > + arg <> "--short-options" then > + printf "%s\n" arg > + ) args > ) !long_options; > exit 0 > > @@ -584,27 +590,23 @@ let set_standard_options argspec > let set_debug_gc () > at_exit (fun () -> Gc.compact()) in > let argspec = [ > - "--short-options", Arg.Unit display_short_options, " " ^ s_"List short options (internal)"; > - "--long-options", Arg.Unit display_long_options, " " ^ s_"List long options (internal)"; > - "-V", Arg.Unit print_version_and_exit, > - " " ^ s_"Display version and exit"; > - "--version", Arg.Unit print_version_and_exit, > - " " ^ s_"Display version and exit"; > - "-v", Arg.Unit set_verbose, " " ^ s_"Enable libguestfs debugging messages"; > - "--verbose", Arg.Unit set_verbose, " " ^ s_"Enable libguestfs debugging messages"; > - "-x", Arg.Unit set_trace, " " ^ s_"Enable tracing of libguestfs calls"; > - "--debug-gc", Arg.Unit set_debug_gc, " " ^ s_"Debug GC and memory allocations (internal)"; > - "-q", Arg.Unit set_quiet, " " ^ s_"Don't print progress messages"; > - "--quiet", Arg.Unit set_quiet, " " ^ s_"Don't print progress messages"; > - "--color", Arg.Unit set_colours, " " ^ s_"Use ANSI colour sequences even if not tty"; > - "--colors", Arg.Unit set_colours, " " ^ s_"Use ANSI colour sequences even if not tty"; > - "--colour", Arg.Unit set_colours, " " ^ s_"Use ANSI colour sequences even if not tty"; > - "--colours", Arg.Unit set_colours, " " ^ s_"Use ANSI colour sequences even if not tty"; > + [ "--short-options" ], Getopt.Unit display_short_options, s_"List short options (internal)"; > + [ "--long-options" ], Getopt.Unit display_long_options, s_"List long options (internal)"; > + [ "-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, s_"Debug GC and memory allocations (internal)"; > + [ "-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"; > ] @ argspec in > + let argspec = List.map ( > + fun (keys, action, doc) -> > + List.hd (List.sort compare_command_line_args keys), (keys, action, doc) > + ) argspec in > let argspec > - let cmp (arg1, _, _) (arg2, _, _) = compare_command_line_args arg1 arg2 in > + let cmp (arg1, _) (arg2, _) = compare_command_line_args arg1 arg2 in > List.sort cmp argspec in > - let argspec = Arg.align argspec in > + let argspec = List.map snd argspec in > long_options := argspec; > argspec > > diff --git a/mllib/common_utils.mli b/mllib/common_utils.mli > index 5b0b9bb..bd0cbbf 100644 > --- a/mllib/common_utils.mli > +++ b/mllib/common_utils.mli > @@ -222,7 +222,7 @@ val skip_dashes : string -> string > val compare_command_line_args : string -> string -> int > (** Compare command line arguments for equality, ignoring any leading [-]s. *) > > -val set_standard_options : (Arg.key * Arg.spec * Arg.doc) list -> (Arg.key * Arg.spec * Arg.doc) list > +val set_standard_options : (Getopt.keys * Getopt.spec * Getopt.doc) list -> (Getopt.keys * Getopt.spec * Getopt.doc) list > (** Adds the standard libguestfs command line options to the specified ones, > sorting them, and setting [long_options] to them. > > diff --git a/mllib/getopt-c.c b/mllib/getopt-c.c > new file mode 100644 > index 0000000..d44448f > --- /dev/null > +++ b/mllib/getopt-c.c > @@ -0,0 +1,398 @@> +value > +guestfs_int_mllib_getopt_parse (value argsv, value specsv, value anon_funv, value usage_msgv)I'm not convinced that this function is safe against OCaml GC compaction. In particular there are problems such as: ...> + for (j = 0; j < len; ++j) { > + const char *key = String_val (Field (keysv, j));key now points to a string on the OCaml heap, and then ...> + if (newopts == NULL) > + caml_raise_out_of_memory (); > + longopts = newopts; > + longopts[longopts_len].name = key;the same pointer is copied to longopts, but ...> + case 0: /* Unit of (unit -> unit) */ > + do_call1 (Field (actionv, 0), Val_unit);At this point you're calling an OCaml function which is likely to allocate, and could therefore call the GC, and could therefore compact the heap, which would move that string around, and make your pointer invalid. (You could try adding `Gc.compact ()' to one of these callback functions -- I'm fairly sure at least some of the time you could get a segfault, and if not, valgrind wouldn't be happy). That's one case I spotted, there may be others. The only safe way around this is to immediately copy the string onto the C heap. (Well, unless you can engineer some way where the GC is never called, but that seems unlikely). Note that as well as calling OCaml code, C functions such as copy_string can also invoke garbage collection.> diff --git a/mllib/getopt.ml b/mllib/getopt.ml > new file mode 100644 > index 0000000..f5cb11a > --- /dev/null > +++ b/mllib/getopt.ml > @@ -0,0 +1,51 @@ > +(* Common utilities for OCaml tools in 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. > + *) > + > +open Common_gettext.Gettext > + > +type spec > + | Unit of (unit -> unit) > + | Set of bool ref > + | Clear of bool ref > + | String of string * (string -> unit) > + | Set_string of string * string ref > + | Int of string * (int -> unit) > + | Set_int of string * int ref > + > +type keys = string list > +type doc = string > +type usage_msg = string > +type anon_fun = (string -> unit) > +type c_keys = string array > + > +external getopt_parse : string array -> (c_keys * spec * doc) array -> ?anon_fun:anon_fun -> usage_msg -> unit = "guestfs_int_mllib_getopt_parse" > + > +let parse_argv argv specs ?anon_fun usage_msgI feel this function could do some sanity checking on the inputs, especially the keys (but see my comment below). If the sanity check fails, it should either assert or failwith, but definitely not continue.> + let specs = specs @ [ > + (* Handled internally by getopt_parse. *) > + [ "-h"; "-help"; "--help" ], Unit (fun () -> ()), s_"Display brief help"; > + ] in > + let specs = List.map ( > + fun (keys, spec, doc) -> > + (Array.of_list keys), spec, docYou don't need parens here, since function application always binds tightest.> + ) specs in > + let specs = Array.of_list specs in > + getopt_parse argv specs ?anon_fun usage_msg > + > +let parse > + parse_argv Sys.argv > diff --git a/mllib/getopt.mli b/mllib/getopt.mli > new file mode 100644 > index 0000000..a100f1d > --- /dev/null > +++ b/mllib/getopt.mli > @@ -0,0 +1,73 @@ > +(* Common utilities for OCaml tools in 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. > + *) > + > +type spec > + | Unit of (unit -> unit) > + (* Simple option with no argument; call the function. *) > + | Set of bool ref > + (* Simple option with no argument; set the reference to true. *) > + | Clear of bool ref > + (* Simple option with no argument; set the reference to false. *)Does getopt_long create the '--no-X' options automatically?> + | 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. *) > + | 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. *) > + | 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. *) > + | 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. *) > + > +type keys = string listI had a vague idea that you might make this more type safe by changing this type to: type optstring = S of char (** short option *) | L of string (** --long *) and keys = optstring list It requires a bunch of extra changes through the code, but also avoids needing to write horrible unsafe code like: if String.is_prefix arg "-" && not (String.is_prefix arg "--") then You could also put optstring into a submodule so that just the L and S definitions can be imported into client modules without needing to import the whole of Getopt, so that makes the syntax quite brief: open Getopt.Optstring ... [ S'l'; L"list" ], Getopt.Unit list_mode, s_"List available templates"; or if you prefer: module O = Getopt.Optstring ... [ O.S'l'; O.L"list" ], Getopt.Unit list_mode, s_"List available templates"; For virt-v2v (see comments below) you might need another case (M?) for the single dash double letter options.> +type doc = string > +type usage_msg = string > +type anon_fun = (string -> unit) > + > +val parse_argv : string array -> > + (keys * spec * doc) list -> ?anon_fun:anon_fun -> usage_msg -> unit > +(** [Getopt.parse args speclist ?anon_fun usage_msg] parses the > + specified arguments. > + > + [args] is the array with command line arguments, with the first > + element representing the application name/path. > + > + [speclist] is a list of triples [(keys, spec, doc)]: [keys] is a > + list of options, [spec] is the associated action, and [doc] is > + the help text. > + > + [anon_fun] is an optional function to handle non-option arguments; > + not specifying one means that only options are allowed, and > + non-options will cause an error. > + > + [usage_msg] is the string which is printed before the list of > + options as help text. > + > + In case of errors, like non-integer value for [Int] or [Set_int], > + an error message is printed, together with a pointer to use > + [--help], and then the program exists. *) > + > +val parse : > + (keys * spec * doc) list -> ?anon_fun:anon_fun -> usage_msg -> unit > +(** Call {!Getopt.parse_argv} on [Sys.argv]. *) > diff --git a/resize/Makefile.am b/resize/Makefile.am > index da5d42d..5fb311a 100644 > --- a/resize/Makefile.am > +++ b/resize/Makefile.am > @@ -32,6 +32,7 @@ SOURCES_ML = \ > SOURCES_C = \ > ../mllib/dev_t-c.c \ > ../mllib/fsync-c.c \ > + ../mllib/getopt-c.c \ > ../fish/progress.c \ > ../mllib/progress-c.c \ > ../fish/uri.c \ > @@ -61,6 +62,7 @@ BOBJECTS = \ > $(top_builddir)/mllib/guestfs_config.cmo \ > $(top_builddir)/mllib/common_gettext.cmo \ > $(top_builddir)/mllib/dev_t.cmo \ > + $(top_builddir)/mllib/getopt.cmo \ > $(top_builddir)/mllib/common_utils.cmo \ > $(SOURCES_ML:.ml=.cmo) > XOBJECTS = $(BOBJECTS:.cmo=.cmx) > diff --git a/resize/resize.ml b/resize/resize.ml > index 22386ce..e40ce60 100644 > --- a/resize/resize.ml > +++ b/resize/resize.ml > @@ -182,35 +182,28 @@ let main () > let sparse = ref true in > let unknown_fs_mode = ref "warn" in > > - let ditto = " -\"-" in > let argspec = [ > - "--align-first", Arg.Set_string align_first, s_"never|always|auto" ^ " " ^ s_"Align first partition (default: auto)"; > - "--alignment", Arg.Set_int alignment, s_"sectors" ^ " " ^ s_"Set partition alignment (default: 128 sectors)"; > - "--no-copy-boot-loader", Arg.Clear copy_boot_loader, " " ^ s_"Don't copy boot loader"; > - "-d", Arg.Unit set_verbose, " " ^ s_"Enable debugging messages"; > - "--debug", Arg.Unit set_verbose, ditto; > - "--delete", Arg.String (add deletes), s_"part" ^ " " ^ s_"Delete partition"; > - "--expand", Arg.String set_expand, s_"part" ^ " " ^ s_"Expand partition"; > - "--no-expand-content", Arg.Clear expand_content, " " ^ s_"Don't expand content"; > - "--no-extra-partition", Arg.Clear extra_partition, " " ^ s_"Don't create extra partition"; > - "--format", Arg.Set_string format, s_"format" ^ " " ^ s_"Format of input disk"; > - "--ignore", Arg.String (add ignores), s_"part" ^ " " ^ s_"Ignore partition"; > - "--lv-expand", Arg.String (add lv_expands), s_"lv" ^ " " ^ s_"Expand logical volume"; > - "--LV-expand", Arg.String (add lv_expands), s_"lv" ^ ditto; > - "--lvexpand", Arg.String (add lv_expands), s_"lv" ^ ditto; > - "--LVexpand", Arg.String (add lv_expands), s_"lv" ^ ditto; > - "--machine-readable", Arg.Set machine_readable, " " ^ s_"Make output machine readable"; > - "-n", Arg.Set dryrun, " " ^ s_"Don't perform changes"; > - "--dry-run", Arg.Set dryrun, " " ^ s_"Don't perform changes"; > - "--dryrun", Arg.Set dryrun, ditto; > - "--ntfsresize-force", Arg.Set ntfsresize_force, " " ^ s_"Force ntfsresize"; > - "--output-format", Arg.Set_string output_format, s_"format" ^ " " ^ s_"Format of output disk"; > - "--resize", Arg.String (add resizes), s_"part=size" ^ " " ^ s_"Resize partition"; > - "--resize-force", Arg.String (add resizes_force), s_"part=size" ^ " " ^ s_"Forcefully resize partition"; > - "--shrink", Arg.String set_shrink, s_"part" ^ " " ^ s_"Shrink partition"; > - "--no-sparse", Arg.Clear sparse, " " ^ s_"Turn off sparse copying"; > - "--unknown-filesystems", Arg.Set_string unknown_fs_mode, > - s_"ignore|warn|error" ^ " " ^ s_"Behaviour on expand unknown filesystems (default: warn)"; > + [ "--align-first" ], Getopt.Set_string (s_"never|always|auto", align_first), s_"Align first partition (default: auto)"; > + [ "--alignment" ], Getopt.Set_int (s_"sectors", alignment), s_"Set partition alignment (default: 128 sectors)"; > + [ "--no-copy-boot-loader" ], Getopt.Clear copy_boot_loader, s_"Don't copy boot loader"; > + [ "-d"; "--debug" ], Getopt.Unit set_verbose, s_"Enable debugging messages"; > + [ "--delete" ], Getopt.String (s_"part", add deletes), s_"Delete partition"; > + [ "--expand" ], Getopt.String (s_"part", set_expand), s_"Expand partition"; > + [ "--no-expand-content" ], Getopt.Clear expand_content, s_"Don't expand content"; > + [ "--no-extra-partition" ], Getopt.Clear extra_partition, s_"Don't create extra partition"; > + [ "--format" ], Getopt.Set_string (s_"format", format), s_"Format of input disk"; > + [ "--ignore" ], Getopt.String (s_"part", add ignores), s_"Ignore partition"; > + [ "--lv-expand"; "--LV-expand"; "--lvexpand"; "--LVexpand" ], Getopt.String (s_"lv", add lv_expands), s_"Expand logical volume"; > + [ "--machine-readable" ], Getopt.Set machine_readable, s_"Make output machine readable"; > + [ "-n"; "--dry-run"; "--dryrun" ], Getopt.Set dryrun, s_"Don't perform changes"; > + [ "--ntfsresize-force" ], Getopt.Set ntfsresize_force, s_"Force ntfsresize"; > + [ "--output-format" ], Getopt.Set_string (s_"format", output_format), s_"Format of output disk"; > + [ "--resize" ], Getopt.String (s_"part=size", add resizes), s_"Resize partition"; > + [ "--resize-force" ], Getopt.String (s_"part=size", add resizes_force), s_"Forcefully resize partition"; > + [ "--shrink" ], Getopt.String (s_"part", set_shrink), s_"Shrink partition"; > + [ "--no-sparse" ], Getopt.Clear sparse, s_"Turn off sparse copying"; > + [ "--unknown-filesystems" ], Getopt.Set_string (s_"ignore|warn|error", unknown_fs_mode), > + s_"Behaviour on expand unknown filesystems (default: warn)"; > ] in > let argspec = set_standard_options argspec in > let disks = ref [] in > @@ -223,7 +216,7 @@ A short summary of the options is given below. For detailed help please > read the man page virt-resize(1). > ") > prog in > - Arg.parse argspec anon_fun usage_msg; > + Getopt.parse argspec ~anon_fun usage_msg; > > if verbose () then ( > printf "command line:"; > diff --git a/sparsify/Makefile.am b/sparsify/Makefile.am > index f9f0f8e..467790c 100644 > --- a/sparsify/Makefile.am > +++ b/sparsify/Makefile.am > @@ -38,6 +38,7 @@ SOURCES_ML = \ > SOURCES_C = \ > ../fish/progress.c \ > ../mllib/dev_t-c.c \ > + ../mllib/getopt-c.c \ > ../mllib/progress-c.c \ > ../mllib/statvfs-c.c > > @@ -60,6 +61,7 @@ BOBJECTS = \ > $(top_builddir)/mllib/guestfs_config.cmo \ > $(top_builddir)/mllib/common_gettext.cmo \ > $(top_builddir)/mllib/dev_t.cmo \ > + $(top_builddir)/mllib/getopt.cmo \ > $(top_builddir)/mllib/common_utils.cmo \ > $(top_builddir)/mllib/progress.cmo \ > $(top_builddir)/mllib/StatVFS.cmo \ > @@ -72,6 +74,7 @@ XOBJECTS = $(BOBJECTS:.cmo=.cmx) > OCAMLPACKAGES = \ > -package str,unix \ > -I $(top_builddir)/src/.libs \ > + -I $(top_builddir)/gnulib/lib/.libs \ > -I $(top_builddir)/ocaml \ > -I $(top_builddir)/mllib > if HAVE_OCAML_PKG_GETTEXT > @@ -79,7 +82,11 @@ OCAMLPACKAGES += -package gettext-stub > endif > > OCAMLCLIBS = \ > - $(LIBTINFO_LIBS) > + -lutils \ > + $(LIBTINFO_LIBS) \ > + $(LIBXML2_LIBS) \ > + $(LIBINTL) \ > + -lgnu > > OCAMLFLAGS = $(OCAML_FLAGS) $(OCAML_WARN_ERROR) > > diff --git a/sparsify/cmdline.ml b/sparsify/cmdline.ml > index bd49e71..f43e648 100644 > --- a/sparsify/cmdline.ml > +++ b/sparsify/cmdline.ml > @@ -63,19 +63,17 @@ let parse_cmdline () > let tmp = ref "" in > let zeroes = ref [] in > > - let ditto = " -\"-" in > let argspec = [ > - "--check-tmpdir", Arg.String set_check_tmpdir, "ignore|..." ^ " " ^ s_"Check there is enough space in $TMPDIR"; > - "--compress", Arg.Set compress, " " ^ s_"Compressed output format"; > - "--convert", Arg.Set_string convert, s_"format" ^ " " ^ s_"Format of output disk (default: same as input)"; > - "--format", Arg.Set_string format, s_"format" ^ " " ^ s_"Format of input disk"; > - "--ignore", Arg.String (add ignores), s_"fs" ^ " " ^ s_"Ignore filesystem"; > - "--in-place", Arg.Set in_place, " " ^ s_"Modify the disk image in-place"; > - "--inplace", Arg.Set in_place, ditto; > - "--machine-readable", Arg.Set machine_readable, " " ^ s_"Make output machine readable"; > - "-o", Arg.Set_string option, s_"option" ^ " " ^ s_"Add qemu-img options"; > - "--tmp", Arg.Set_string tmp, s_"block|dir|prebuilt:file" ^ " " ^ s_"Set temporary block device, directory or prebuilt file"; > - "--zero", Arg.String (add zeroes), s_"fs" ^ " " ^ s_"Zero filesystem"; > + [ "--check-tmpdir" ], Getopt.String ("ignore|...", set_check_tmpdir), s_"Check there is enough space in $TMPDIR"; > + [ "--compress" ], Getopt.Set compress, s_"Compressed output format"; > + [ "--convert" ], Getopt.Set_string (s_"format", convert), s_"Format of output disk (default: same as input)"; > + [ "--format" ], Getopt.Set_string (s_"format", format), s_"Format of input disk"; > + [ "--ignore" ], Getopt.String (s_"fs", add ignores), s_"Ignore filesystem"; > + [ "--in-place"; "--inplace" ], Getopt.Set in_place, s_"Modify the disk image in-place"; > + [ "--machine-readable" ], Getopt.Set machine_readable, s_"Make output machine readable"; > + [ "-o" ], Getopt.Set_string (s_"option", option), s_"Add qemu-img options"; > + [ "--tmp" ], Getopt.Set_string (s_"block|dir|prebuilt:file", tmp), s_"Set temporary block device, directory or prebuilt file"; > + [ "--zero" ], Getopt.String (s_"fs", add zeroes), s_"Zero filesystem"; > ] in > let argspec = set_standard_options argspec in > let disks = ref [] in > @@ -92,7 +90,7 @@ A short summary of the options is given below. For detailed help please > read the man page virt-sparsify(1). > ") > prog in > - Arg.parse argspec anon_fun usage_msg; > + Getopt.parse argspec ~anon_fun usage_msg; > > (* Dereference the rest of the args. *) > let check_tmpdir = !check_tmpdir in > diff --git a/sysprep/Makefile.am b/sysprep/Makefile.am > index d4f1173..d69786e 100644 > --- a/sysprep/Makefile.am > +++ b/sysprep/Makefile.am > @@ -81,6 +81,7 @@ SOURCES_ML = \ > > SOURCES_C = \ > ../mllib/dev_t-c.c \ > + ../mllib/getopt-c.c \ > ../mllib/uri-c.c \ > ../mllib/mkdtemp-c.c \ > ../customize/crypt-c.c \ > @@ -109,6 +110,7 @@ BOBJECTS = \ > $(top_builddir)/mllib/guestfs_config.cmo \ > $(top_builddir)/mllib/common_gettext.cmo \ > $(top_builddir)/mllib/dev_t.cmo \ > + $(top_builddir)/mllib/getopt.cmo \ > $(top_builddir)/mllib/common_utils.cmo \ > $(top_builddir)/mllib/URI.cmo \ > $(top_builddir)/mllib/mkdtemp.cmo \ > diff --git a/sysprep/main.ml b/sysprep/main.ml > index 35a259c..256ca4a 100644 > --- a/sysprep/main.ml > +++ b/sysprep/main.ml > @@ -117,31 +117,24 @@ let main () > in > > let basic_args = [ > - "-a", Arg.String add_file, s_"file" ^ " " ^ s_"Add disk image file"; > - "--add", Arg.String add_file, s_"file" ^ " " ^ s_"Add disk image file"; > - "-c", Arg.Set_string libvirturi, s_"uri" ^ " " ^ s_"Set libvirt URI"; > - "--connect", Arg.Set_string libvirturi, s_"uri" ^ " " ^ s_"Set libvirt URI"; > - "-d", Arg.String set_domain, s_"domain" ^ " " ^ s_"Set libvirt guest name"; > - "--domain", Arg.String set_domain, s_"domain" ^ " " ^ s_"Set libvirt guest name"; > - "-n", Arg.Set dryrun, " " ^ s_"Perform a dry run"; > - "--dryrun", Arg.Set dryrun, " " ^ s_"Perform a dry run"; > - "--dry-run", Arg.Set dryrun, " " ^ s_"Perform a dry run"; > - "--dump-pod", Arg.Unit dump_pod, " " ^ s_"Dump POD (internal)"; > - "--dump-pod-options", Arg.Unit dump_pod_options, " " ^ s_"Dump POD for options (internal)"; > - "--enable", Arg.String set_enable, s_"operations" ^ " " ^ s_"Enable specific operations"; > - "--format", Arg.String set_format, s_"format" ^ " " ^ s_"Set format (default: auto)"; > - "--list-operations", Arg.Unit list_operations, " " ^ s_"List supported operations"; > - "--mount-options", Arg.Set_string mount_opts, s_"opts" ^ " " ^ s_"Set mount options (eg /:noatime;/var:rw,noatime)"; > - "--network", Arg.Set network, " " ^ s_"Enable appliance network"; > - "--no-network", Arg.Clear network, " " ^ s_"Disable appliance network (default)"; > - "--no-selinux-relabel", Arg.Unit (fun () -> ()), > - " " ^ s_"Compatibility option, does nothing"; > - "--operation", Arg.String set_operations, " " ^ s_"Enable/disable specific operations"; > - "--operations", Arg.String set_operations, " " ^ s_"Enable/disable specific operations"; > + [ "-a"; "--add" ], Getopt.String (s_"file", add_file), s_"Add disk image file"; > + [ "-c"; "--connect" ], Getopt.Set_string (s_"uri", libvirturi), s_"Set libvirt URI"; > + [ "-d"; "--domain" ], Getopt.String (s_"domain", set_domain), s_"Set libvirt guest name"; > + [ "-n"; "--dryrun"; "--dry-run" ], Getopt.Set dryrun, s_"Perform a dry run"; > + [ "--dump-pod" ], Getopt.Unit dump_pod, s_"Dump POD (internal)"; > + [ "--dump-pod-options" ], Getopt.Unit dump_pod_options, s_"Dump POD for options (internal)"; > + [ "--enable" ], Getopt.String (s_"operations", set_enable), s_"Enable specific operations"; > + [ "--format" ], Getopt.String (s_"format", set_format), s_"Set format (default: auto)"; > + [ "--list-operations" ], Getopt.Unit list_operations, s_"List supported operations"; > + [ "--mount-options" ], Getopt.Set_string (s_"opts", mount_opts), s_"Set mount options (eg /:noatime;/var:rw,noatime)"; > + [ "--network" ], Getopt.Set network, s_"Enable appliance network"; > + [ "--no-network" ], Getopt.Clear network, s_"Disable appliance network (default)"; > + [ "--no-selinux-relabel" ], Getopt.Unit (fun () -> ()), > + s_"Compatibility option, does nothing"; > + [ "--operation"; "--operations" ], Getopt.String (s_"operations", set_operations), s_"Enable/disable specific operations"; > ] in > let args = basic_args @ Sysprep_operation.extra_args () in > let argspec = set_standard_options args in > - let anon_fun _ = raise (Arg.Bad (s_"extra parameter on the command line")) in > let usage_msg > sprintf (f_"\ > %s: reset or unconfigure a virtual machine so clones can be made > @@ -154,7 +147,7 @@ A short summary of the options is given below. For detailed help please > read the man page virt-sysprep(1). > ") > prog in > - Arg.parse argspec anon_fun usage_msg; > + Getopt.parse argspec usage_msg; > > if not !format_consumed then > error (f_"--format parameter must appear before -a parameter"); > diff --git a/sysprep/sysprep_operation.ml b/sysprep/sysprep_operation.ml > index 057c8c5..8ffe2c7 100644 > --- a/sysprep/sysprep_operation.ml > +++ b/sysprep/sysprep_operation.ml > @@ -49,7 +49,7 @@ type operation = { > perform_on_devices : device_side_effects callback option; > } > and extra_arg = { > - extra_argspec : Arg.key * Arg.spec * Arg.doc; > + extra_argspec : Getopt.keys * Getopt.spec * Getopt.doc; > extra_pod_argval : string option; > extra_pod_description : string; > } > @@ -208,27 +208,33 @@ let dump_pod_options () > let args = List.map ( > function > | (op_name, > - { extra_argspec = (arg_name, > - (Arg.Unit _ | Arg.Bool _ | Arg.Set _ | Arg.Clear _), > + { extra_argspec = (arg_names, > + (Getopt.Unit _ | Getopt.Set _ | Getopt.Clear _), > _); > extra_pod_argval = None; > extra_pod_description = pod }) -> > - let heading = sprintf "B<%s>" arg_name in > - arg_name, (op_name, heading, pod) > + List.map ( > + fun arg_name -> > + let heading = sprintf "B<%s>" arg_name in > + arg_name, (op_name, heading, pod) > + ) arg_names > > | (op_name, > - { extra_argspec = (arg_name, > - (Arg.String _ | Arg.Set_string _ | Arg.Int _ | > - Arg.Set_int _ | Arg.Float _ | Arg.Set_float _), > + { extra_argspec = (arg_names, > + (Getopt.String _ | Getopt.Set_string _ | Getopt.Int _), > _); > extra_pod_argval = Some arg_val; > extra_pod_description = pod }) -> > - let heading = sprintf "B<%s> %s" arg_name arg_val in > - arg_name, (op_name, heading, pod) > + List.map ( > + fun arg_name -> > + let heading = sprintf "B<%s> %s" arg_name arg_val in > + arg_name, (op_name, heading, pod) > + ) arg_names > > | _ -> > failwith "sysprep_operation.ml: argument type not implemented" > ) args in > + let args = List.flatten args in > > let args > List.sort (fun (a, _) (b, _) -> compare_command_line_args a b) args in > diff --git a/sysprep/sysprep_operation.mli b/sysprep/sysprep_operation.mli > index f532a8c..48b65d7 100644 > --- a/sysprep/sysprep_operation.mli > +++ b/sysprep/sysprep_operation.mli > @@ -106,8 +106,8 @@ type operation = { > } > > and extra_arg = { > - extra_argspec : Arg.key * Arg.spec * Arg.doc; > - (** The argspec. See OCaml [Arg] module. *) > + extra_argspec : Getopt.keys * Getopt.spec * Getopt.doc; > + (** The argspec. See [Getopt] module in [mllib]. *) > > extra_pod_argval : string option; > (** The argument value, used only in the virt-sysprep man page. *) > @@ -126,7 +126,7 @@ val bake : unit -> unit > (** 'Bake' is called after all modules have been registered. We > finalize the list of operations, sort it, and run some checks. *) > > -val extra_args : unit -> (Arg.key * Arg.spec * Arg.doc) list > +val extra_args : unit -> (Getopt.keys * Getopt.spec * Getopt.doc) list > (** Get the list of extra arguments for the command line. *) > > val dump_pod : unit -> unit > diff --git a/sysprep/sysprep_operation_script.ml b/sysprep/sysprep_operation_script.ml > index 140225c..1725c8d 100644 > --- a/sysprep/sysprep_operation_script.ml > +++ b/sysprep/sysprep_operation_script.ml > @@ -129,7 +129,7 @@ B<Note:> This is different from I<--firstboot> scripts (which run > in the context of the guest when it is booting first time). > I<--script> scripts run on the host, not in the guest."); > extra_args = [ > - { extra_argspec = "--scriptdir", Arg.String set_scriptdir, s_"dir" ^ " " ^ s_"Mount point on host"; > + { extra_argspec = [ "--scriptdir" ], Getopt.String (s_"dir", set_scriptdir), s_"Mount point on host"; > extra_pod_argval = Some "SCRIPTDIR"; > extra_pod_description = s_"\ > The mount point (an empty directory on the host) used when > @@ -142,7 +142,7 @@ If I<--scriptdir> is not specified then a temporary mountpoint > will be created." > }; > > - { extra_argspec = "--script", Arg.String add_script, s_"script" ^ " " ^ s_"Script or program to run on guest"; > + { extra_argspec = [ "--script" ], Getopt.String (s_"script", add_script), s_"Script or program to run on guest"; > extra_pod_argval = Some "SCRIPT"; > extra_pod_description = s_"\ > Run the named C<SCRIPT> (a shell script or program) against the > diff --git a/sysprep/sysprep_operation_user_account.ml b/sysprep/sysprep_operation_user_account.ml > index e71d5ea..cf7dc57 100644 > --- a/sysprep/sysprep_operation_user_account.ml > +++ b/sysprep/sysprep_operation_user_account.ml > @@ -109,7 +109,7 @@ The \"root\" account is not removed. > See the I<--remove-user-accounts> parameter for a way to specify > how to remove only some users, or to not remove some others."); > extra_args = [ > - { extra_argspec = "--remove-user-accounts", Arg.String (add_users remove_users), s_"users" ^ " " ^ s_"Users to remove"; > + { extra_argspec = [ "--remove-user-accounts" ], Getopt.String (s_"users", add_users remove_users), s_"Users to remove"; > extra_pod_argval = Some "USERS"; > extra_pod_description = s_"\ > The user accounts to be removed from the guest. > @@ -124,7 +124,7 @@ would only remove the user accounts C<bob> and C<eve>. > This option can be specified multiple times." > }; > > - { extra_argspec = "--keep-user-accounts", Arg.String (add_users keep_users), s_"users" ^ " " ^ s_"Users to keep"; > + { extra_argspec = [ "--keep-user-accounts" ], Getopt.String (s_"users", add_users keep_users), s_"Users to keep"; > extra_pod_argval = Some "USERS"; > extra_pod_description = s_"\ > The user accounts to be kept in the guest. > diff --git a/v2v/Makefile.am b/v2v/Makefile.am > index 05f4611..fcbf624 100644 > --- a/v2v/Makefile.am > +++ b/v2v/Makefile.am > @@ -99,6 +99,7 @@ SOURCES_ML = \ > > SOURCES_C = \ > ../mllib/dev_t-c.c \ > + ../mllib/getopt-c.c \ > ../mllib/mkdtemp-c.c \ > ../mllib/statvfs-c.c \ > domainxml-c.c \ > @@ -126,6 +127,7 @@ BOBJECTS = \ > $(top_builddir)/mllib/guestfs_config.cmo \ > $(top_builddir)/mllib/common_gettext.cmo \ > $(top_builddir)/mllib/dev_t.cmo \ > + $(top_builddir)/mllib/getopt.cmo \ > $(top_builddir)/mllib/common_utils.cmo \ > $(top_builddir)/mllib/regedit.cmo \ > $(top_builddir)/mllib/mkdtemp.cmo \ > @@ -178,6 +180,7 @@ virt_v2v_LINK = \ > virt_v2v_copy_to_local_SOURCES = \ > ../mllib/dev_t-c.c \ > ../mllib/statvfs-c.c \ > + ../mllib/getopt-c.c \ > domainxml-c.c \ > utils-c.c \ > xml-c.c > @@ -196,6 +199,7 @@ COPY_TO_LOCAL_BOBJECTS = \ > $(top_builddir)/mllib/guestfs_config.cmo \ > $(top_builddir)/mllib/common_gettext.cmo \ > $(top_builddir)/mllib/dev_t.cmo \ > + $(top_builddir)/mllib/getopt.cmo \ > $(top_builddir)/mllib/common_utils.cmo \ > $(top_builddir)/mllib/JSON.cmo \ > $(top_builddir)/mllib/StatVFS.cmo \ > diff --git a/v2v/cmdline.ml b/v2v/cmdline.ml > index 1064987..ff0ab59 100644 > --- a/v2v/cmdline.ml > +++ b/v2v/cmdline.ml > @@ -164,55 +164,47 @@ let parse_cmdline () > and o_options > String.concat "|" (Modules_list.output_modules ()) in > > - let ditto = " -\"-" in > let argspec = [ > - "-b", Arg.String add_bridge, "in:out " ^ s_"Map bridge 'in' to 'out'"; > - "--bridge", Arg.String add_bridge, "in:out " ^ ditto; > - "--compressed", Arg.Set compressed, " " ^ s_"Compress output file"; > - "--dcpath", Arg.String (set_string_option_once "--dcpath" dcpath), > - "path " ^ s_"Override dcPath (for vCenter)"; > - "--dcPath", Arg.String (set_string_option_once "--dcPath" dcpath), > - "path " ^ ditto; > - "--debug-overlay",Arg.Set debug_overlays, > - " " ^ s_"Save overlay files"; > - "--debug-overlays",Arg.Set debug_overlays, > - ditto; > - "-i", Arg.String set_input_mode, i_options ^ " " ^ s_"Set input mode (default: libvirt)"; > - "-ic", Arg.String (set_string_option_once "-ic" input_conn), > - "uri " ^ s_"Libvirt URI"; > - "-if", Arg.String (set_string_option_once "-if" input_format), > - "format " ^ s_"Input format (for -i disk)"; > - "--in-place", Arg.Set in_place, " " ^ s_"Only tune the guest in the input VM"; > - "--machine-readable", Arg.Set machine_readable, " " ^ s_"Make output machine readable"; > - "-n", Arg.String add_network, "in:out " ^ s_"Map network 'in' to 'out'"; > - "--network", Arg.String add_network, "in:out " ^ ditto; > - "--no-copy", Arg.Clear do_copy, " " ^ s_"Just write the metadata"; > - "--no-trim", Arg.String no_trim_warning, > - "-" ^ " " ^ s_"Ignored for backwards compatibility"; > - "-o", Arg.String set_output_mode, o_options ^ " " ^ s_"Set output mode (default: libvirt)"; > - "-oa", Arg.String set_output_alloc, > - "sparse|preallocated " ^ s_"Set output allocation mode"; > - "-oc", Arg.String (set_string_option_once "-oc" output_conn), > - "uri " ^ s_"Libvirt URI"; > - "-of", Arg.String (set_string_option_once "-of" output_format), > - "raw|qcow2 " ^ s_"Set output format"; > - "-on", Arg.String (set_string_option_once "-on" output_name), > - "name " ^ s_"Rename guest when converting"; > - "-os", Arg.String (set_string_option_once "-os" output_storage), > - "storage " ^ s_"Set output storage location"; > - "--password-file", Arg.String (set_string_option_once "--password-file" password_file), > - "file " ^ s_"Use password from file"; > - "--print-source", Arg.Set print_source, " " ^ s_"Print source and stop"; > - "--qemu-boot", Arg.Set qemu_boot, " " ^ s_"Boot in qemu (-o qemu only)"; > - "--root", Arg.String set_root_choice,"ask|... " ^ s_"How to choose root filesystem"; > - "--vdsm-image-uuid", Arg.String add_vdsm_image_uuid, "uuid " ^ s_"Output image UUID(s)"; > - "--vdsm-vol-uuid", Arg.String add_vdsm_vol_uuid, "uuid " ^ s_"Output vol UUID(s)"; > - "--vdsm-vm-uuid", Arg.String (set_string_option_once "--vdsm-vm-uuid" vdsm_vm_uuid), > - "uuid " ^ s_"Output VM UUID"; > - "--vdsm-ovf-output", Arg.String (set_string_option_once "--vdsm-ovf-output" vdsm_ovf_output), > - " " ^ s_"Output OVF file"; > - "--vmtype", Arg.String vmtype_warning, > - "- " ^ s_"Ignored for backwards compatibility"; > + [ "-b"; "--bridge" ], Getopt.String ("in:out", add_bridge), s_"Map bridge 'in' to 'out'"; > + [ "--compressed" ], Getopt.Set compressed, s_"Compress output file"; > + [ "--dcpath"; "--dcPath" ], Getopt.String ("path", set_string_option_once "--dcpath" dcpath), > + s_"Override dcPath (for vCenter)"; > + [ "--debug-overlay"; "--debug-overlays" ], Getopt.Set debug_overlays, s_"Save overlay files"; > + [ "-i" ], Getopt.String (i_options, set_input_mode), s_"Set input mode (default: libvirt)"; > + [ "-ic" ], Getopt.String ("uri", set_string_option_once "-ic" input_conn), > + s_"Libvirt URI"; > + [ "-if" ], Getopt.String ("format", set_string_option_once "-if" input_format), > + s_"Input format (for -i disk)";I'm interested to know if these awkward "single dash long options" actually work now? And the -o* ones below.> + [ "--in-place" ], Getopt.Set in_place, s_"Only tune the guest in the input VM"; > + [ "--machine-readable" ], Getopt.Set machine_readable, s_"Make output machine readable"; > + [ "-n"; "--network" ], Getopt.String ("in:out", add_network), s_"Map network 'in' to 'out'"; > + [ "--no-copy" ], Getopt.Clear do_copy, s_"Just write the metadata"; > + [ "--no-trim" ], Getopt.String ("-", no_trim_warning), > + s_"Ignored for backwards compatibility"; > + [ "-o" ], Getopt.String (o_options, set_output_mode), s_"Set output mode (default: libvirt)"; > + [ "-oa" ], Getopt.String ("sparse|preallocated", set_output_alloc), > + s_"Set output allocation mode"; > + [ "-oc" ], Getopt.String ("uri", set_string_option_once "-oc" output_conn), > + s_"Libvirt URI"; > + [ "-of" ], Getopt.String ("raw|qcow2", set_string_option_once "-of" output_format), > + s_"Set output format"; > + [ "-on" ], Getopt.String ("name", set_string_option_once "-on" output_name), > + s_"Rename guest when converting"; > + [ "-os" ], Getopt.String ("storage", set_string_option_once "-os" output_storage), > + s_"Set output storage location"; > + [ "--password-file" ], Getopt.String ("file", set_string_option_once "--password-file" password_file), > + s_"Use password from file"; > + [ "--print-source" ], Getopt.Set print_source, s_"Print source and stop"; > + [ "--qemu-boot" ], Getopt.Set qemu_boot, s_"Boot in qemu (-o qemu only)"; > + [ "--root" ], Getopt.String ("ask|... ", set_root_choice), s_"How to choose root filesystem"; > + [ "--vdsm-image-uuid" ], Getopt.String ("uuid", add_vdsm_image_uuid), s_"Output image UUID(s)"; > + [ "--vdsm-vol-uuid" ], Getopt.String ("uuid", add_vdsm_vol_uuid), s_"Output vol UUID(s)"; > + [ "--vdsm-vm-uuid" ], Getopt.String ("uuid", set_string_option_once "--vdsm-vm-uuid" vdsm_vm_uuid), > + s_"Output VM UUID"; > + [ "--vdsm-ovf-output" ], Getopt.String ("-", set_string_option_once "--vdsm-ovf-output" vdsm_ovf_output), > + s_"Output OVF file"; > + [ "--vmtype" ], Getopt.String ("-", vmtype_warning), > + s_"Ignored for backwards compatibility"; > ] in > let argspec = set_standard_options argspec in > let args = ref [] in > @@ -239,7 +231,7 @@ A short summary of the options is given below. For detailed help please > read the man page virt-v2v(1). > ") > prog in > - Arg.parse argspec anon_fun usage_msg; > + Getopt.parse argspec ~anon_fun usage_msg; > > (* Dereference the arguments. *) > let args = List.rev !args in > diff --git a/v2v/copy_to_local.ml b/v2v/copy_to_local.ml > index 717ba50..b4245ae 100644 > --- a/v2v/copy_to_local.ml > +++ b/v2v/copy_to_local.ml > @@ -41,10 +41,10 @@ let rec main () > > (* Handle the command line. *) > let argspec = [ > - "-ic", Arg.String (set_string_option_once "-ic" input_conn), > - "uri " ^ s_"Libvirt URI"; > - "--password-file", Arg.String (set_string_option_once "--password-file" password_file), > - "file " ^ s_"Use password from file"; > + [ "-ic" ], Getopt.String ("uri", set_string_option_once "-ic" input_conn), > + s_"Libvirt URI"; > + [ "--password-file" ], Getopt.String ("file", set_string_option_once "--password-file" password_file), > + s_"Use password from file"; > ] in > let argspec = set_standard_options argspec in > let args = ref [] in > @@ -71,7 +71,7 @@ A short summary of the options is given below. For detailed help please > read the man page virt-v2v-copy-to-local(1). > ") > prog in > - Arg.parse argspec anon_fun usage_msg; > + Getopt.parse argspec ~anon_fun usage_msg; > > let args = !args in > let input_conn = !input_conn inRich. -- 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/
Pino Toscano
2016-Jul-11 15:57 UTC
Re: [Libguestfs] [PATCH] RFC: OCaml tools: add and use a Getopt module
On Monday, 27 June 2016 15:42:46 CEST Richard W.M. Jones wrote:> On Fri, Jun 24, 2016 at 05:42:37PM +0200, Pino Toscano wrote: > > Add a new Getopt module to mllib, to parse command line arguments with > > handlers close to the ones used with Arg, but using getopt(3) (actually > > getopt_long_only) to do the real parsing. This allow us to provide > > options for OCaml tools with a syntax similar to the C tools, and use > > the additional features getopt offers and Arg does not. > > > > Do a single-step conversion of Common_utils and all the OCaml tools to > > the syntax of Getopt. > > > > As side-change due to the conversion, extra arguments for sysprep > > operation can have more keys for the same argument. > > In general terms, it's a very good change which really improves the > tools. > > I have a few fairly minor issues below. ACK if you can clean all of > those up.[...]> > diff --git a/mllib/getopt-c.c b/mllib/getopt-c.c > > new file mode 100644 > > index 0000000..d44448f > > --- /dev/null > > +++ b/mllib/getopt-c.c > > @@ -0,0 +1,398 @@ > > > +value > > +guestfs_int_mllib_getopt_parse (value argsv, value specsv, value anon_funv, value usage_msgv) > > I'm not convinced that this function is safe against OCaml GC compaction. > > In particular there are problems such as: > > ... > > + for (j = 0; j < len; ++j) { > > + const char *key = String_val (Field (keysv, j)); > > key now points to a string on the OCaml heap, and then ... > > > + if (newopts == NULL) > > + caml_raise_out_of_memory (); > > + longopts = newopts; > > + longopts[longopts_len].name = key; > > the same pointer is copied to longopts, but ... > > > + case 0: /* Unit of (unit -> unit) */ > > + do_call1 (Field (actionv, 0), Val_unit); > > At this point you're calling an OCaml function which is likely to > allocate, and could therefore call the GC, and could therefore compact > the heap, which would move that string around, and make your pointer > invalid. (You could try adding `Gc.compact ()' to one of these > callback functions -- I'm fairly sure at least some of the time you > could get a segfault, and if not, valgrind wouldn't be happy).I see, it fails that way indeed. Fixed it by: - copying long option strings on the heap (with the ugly cast in cleanup_option_list, but almost unavoidable) - making sure that operations that trigger allocations are executed one-by-one (i.e. caml_copy_string out of direct function parameters, etc)> > +external getopt_parse : string array -> (c_keys * spec * doc) array -> ?anon_fun:anon_fun -> usage_msg -> unit = "guestfs_int_mllib_getopt_parse" > > + > > +let parse_argv argv specs ?anon_fun usage_msg > > I feel this function could do some sanity checking on the inputs, > especially the keys (but see my comment below). If the sanity check > fails, it should either assert or failwith, but definitely not > continue.Moved the sanity checks in the OCaml part.> > + let specs = specs @ [ > > + (* Handled internally by getopt_parse. *) > > + [ "-h"; "-help"; "--help" ], Unit (fun () -> ()), s_"Display brief help"; > > + ] in > > + let specs = List.map ( > > + fun (keys, spec, doc) -> > > + (Array.of_list keys), spec, doc > > You don't need parens here, since function application always binds tightest.Removed, thanks (leftover of other code previously there).> > +type spec > > + | Unit of (unit -> unit) > > + (* Simple option with no argument; call the function. *) > > + | Set of bool ref > > + (* Simple option with no argument; set the reference to true. *) > > + | Clear of bool ref > > + (* Simple option with no argument; set the reference to false. *) > > Does getopt_long create the '--no-X' options automatically?No, it doesn't.> > + | 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. *) > > + | 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. *) > > + | 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. *) > > + | 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. *) > > + > > +type keys = string list > > I had a vague idea that you might make this more type safe by > changing this type to: > > type optstring = S of char (** short option *) | L of string (** --long *) > and keys = optstring list > > It requires a bunch of extra changes through the code, but also avoids > needing to write horrible unsafe code like: > > if String.is_prefix arg "-" && not (String.is_prefix arg "--") then > > You could also put optstring into a submodule so that just the L and S > definitions can be imported into client modules without needing to > import the whole of Getopt, so that makes the syntax quite brief: > > open Getopt.Optstring > ... > [ S'l'; L"list" ], Getopt.Unit list_mode, s_"List available templates"; > > or if you prefer: > > module O = Getopt.Optstring > ... > [ O.S'l'; O.L"list" ], Getopt.Unit list_mode, s_"List available templates";I thought about this, and at the moment it feels to me a bit too complicated. I might revise that in the future though.> > --- a/v2v/cmdline.ml > > +++ b/v2v/cmdline.ml > > @@ -164,55 +164,47 @@ let parse_cmdline () > > and o_options > > String.concat "|" (Modules_list.output_modules ()) in > > > > - let ditto = " -\"-" in > > let argspec = [ > > - "-b", Arg.String add_bridge, "in:out " ^ s_"Map bridge 'in' to 'out'"; > > - "--bridge", Arg.String add_bridge, "in:out " ^ ditto; > > - "--compressed", Arg.Set compressed, " " ^ s_"Compress output file"; > > - "--dcpath", Arg.String (set_string_option_once "--dcpath" dcpath), > > - "path " ^ s_"Override dcPath (for vCenter)"; > > - "--dcPath", Arg.String (set_string_option_once "--dcPath" dcpath), > > - "path " ^ ditto; > > - "--debug-overlay",Arg.Set debug_overlays, > > - " " ^ s_"Save overlay files"; > > - "--debug-overlays",Arg.Set debug_overlays, > > - ditto; > > - "-i", Arg.String set_input_mode, i_options ^ " " ^ s_"Set input mode (default: libvirt)"; > > - "-ic", Arg.String (set_string_option_once "-ic" input_conn), > > - "uri " ^ s_"Libvirt URI"; > > - "-if", Arg.String (set_string_option_once "-if" input_format), > > - "format " ^ s_"Input format (for -i disk)"; > > - "--in-place", Arg.Set in_place, " " ^ s_"Only tune the guest in the input VM"; > > - "--machine-readable", Arg.Set machine_readable, " " ^ s_"Make output machine readable"; > > - "-n", Arg.String add_network, "in:out " ^ s_"Map network 'in' to 'out'"; > > - "--network", Arg.String add_network, "in:out " ^ ditto; > > - "--no-copy", Arg.Clear do_copy, " " ^ s_"Just write the metadata"; > > - "--no-trim", Arg.String no_trim_warning, > > - "-" ^ " " ^ s_"Ignored for backwards compatibility"; > > - "-o", Arg.String set_output_mode, o_options ^ " " ^ s_"Set output mode (default: libvirt)"; > > - "-oa", Arg.String set_output_alloc, > > - "sparse|preallocated " ^ s_"Set output allocation mode"; > > - "-oc", Arg.String (set_string_option_once "-oc" output_conn), > > - "uri " ^ s_"Libvirt URI"; > > - "-of", Arg.String (set_string_option_once "-of" output_format), > > - "raw|qcow2 " ^ s_"Set output format"; > > - "-on", Arg.String (set_string_option_once "-on" output_name), > > - "name " ^ s_"Rename guest when converting"; > > - "-os", Arg.String (set_string_option_once "-os" output_storage), > > - "storage " ^ s_"Set output storage location"; > > - "--password-file", Arg.String (set_string_option_once "--password-file" password_file), > > - "file " ^ s_"Use password from file"; > > - "--print-source", Arg.Set print_source, " " ^ s_"Print source and stop"; > > - "--qemu-boot", Arg.Set qemu_boot, " " ^ s_"Boot in qemu (-o qemu only)"; > > - "--root", Arg.String set_root_choice,"ask|... " ^ s_"How to choose root filesystem"; > > - "--vdsm-image-uuid", Arg.String add_vdsm_image_uuid, "uuid " ^ s_"Output image UUID(s)"; > > - "--vdsm-vol-uuid", Arg.String add_vdsm_vol_uuid, "uuid " ^ s_"Output vol UUID(s)"; > > - "--vdsm-vm-uuid", Arg.String (set_string_option_once "--vdsm-vm-uuid" vdsm_vm_uuid), > > - "uuid " ^ s_"Output VM UUID"; > > - "--vdsm-ovf-output", Arg.String (set_string_option_once "--vdsm-ovf-output" vdsm_ovf_output), > > - " " ^ s_"Output OVF file"; > > - "--vmtype", Arg.String vmtype_warning, > > - "- " ^ s_"Ignored for backwards compatibility"; > > + [ "-b"; "--bridge" ], Getopt.String ("in:out", add_bridge), s_"Map bridge 'in' to 'out'"; > > + [ "--compressed" ], Getopt.Set compressed, s_"Compress output file"; > > + [ "--dcpath"; "--dcPath" ], Getopt.String ("path", set_string_option_once "--dcpath" dcpath), > > + s_"Override dcPath (for vCenter)"; > > + [ "--debug-overlay"; "--debug-overlays" ], Getopt.Set debug_overlays, s_"Save overlay files"; > > + [ "-i" ], Getopt.String (i_options, set_input_mode), s_"Set input mode (default: libvirt)"; > > + [ "-ic" ], Getopt.String ("uri", set_string_option_once "-ic" input_conn), > > + s_"Libvirt URI"; > > + [ "-if" ], Getopt.String ("format", set_string_option_once "-if" input_format), > > + s_"Input format (for -i disk)"; > > I'm interested to know if these awkward "single dash long options" > actually work now? And the -o* ones below.Thanks to getopt_long_only, they work (and thus the v2v test suite passes). Thanks for the thorough review, v2 coming in a moment. -- Pino Toscano
Seemingly Similar Threads
- [PATCH v3 1/2] OCaml tools: add and use a Getopt module
- [PATCH v2] OCaml tools: add and use a Getopt module
- Re: [PATCH] RFC: OCaml tools: add and use a Getopt module
- [PATCH v2 0/3] mllib: Various fixes and changes to Getopt module.
- [PATCH v3 0/3] mllib: Various fixes and changes to Getopt module.