[PATCH] RFC: OCaml tools: add and use a Getopt module
by Pino Toscano
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
8 years, 4 months
- 2
- 2
[PATCHv2 0/3] fix btrfs subvolume procession in tools
by Maxim Perevedentsev
sparsify case: modified guestfs_is_lv
mllib: fixed is_btrfs_subvolume
Maxim Perevedentsev (3):
mllib: add checking for btrfs subvolume
lvm: modify guestfs_is_lv to take mountable
sysprep: fix btrfs subvolume processing in fs-uuids
daemon/lvm.c | 6 ++++--
generator/actions.ml | 6 +++---
mllib/common_utils.ml | 7 +++++++
mllib/common_utils.mli | 3 +++
sysprep/sysprep_operation_fs_uuids.ml | 16 +++++++++-------
5 files changed, 26 insertions(+), 12 deletions(-)
--
1.8.3.1
8 years, 4 months
- 2
- 4
[PATCH 0/3] fix btrfs subvolume procession in tools
by Maxim Perevedentsev
This patcheset fixes errors in virt-sysprep and virt-sparsify.
Here we have a common functionality: is_btrfs_subvolume.
Doesn't it make sense to turn it into guestfs API?
Also I found an issue. In 'virt-sysprep fs-uuids',
the uuids for ALL filesystems are regenerated
as many times as many roots are in guest.
Is it done intentionally?
Maxim Perevedentsev (3):
mllib: add checking for btrfs subvolume
sparsify: fix btrfs subvolume processing in is_read_only_lv
sysprep: fix btrfs subvolume processing in fs-uuids
mllib/common_utils.ml | 10 ++++++++++
mllib/common_utils.mli | 3 +++
sparsify/utils.ml | 3 ++-
sysprep/sysprep_operation_fs_uuids.ml | 16 +++++++++-------
4 files changed, 24 insertions(+), 8 deletions(-)
--
1.8.3.1
8 years, 4 months
- 3
- 10
[PATCH] filesystem_walk: more information into tsk_dirent
by Matteo Cafasso
Access, modification, last status change and creation time in
Unix format as for statns.
Number of links pointing to a given entry.
If the entry is a symbolic link, report the its target path.
A new flag (DIRENT_COMPRESSED 0x04) indicating whether the file is
compressed using native filesystem compression support.
Signed-off-by: Matteo Cafasso <noxdafox(a)gmail.com>
---
daemon/tsk.c | 44 ++++++++++++++++++++++++++++++++-------
generator/actions.ml | 39 ++++++++++++++++++++++++++++++++--
generator/structs.ml | 20 +++++++++---------
tests/tsk/test-filesystem-walk.sh | 44 +++++++++++++++++++--------------------
4 files changed, 106 insertions(+), 41 deletions(-)
diff --git a/daemon/tsk.c b/daemon/tsk.c
index 446213e..2d0ea83 100644
--- a/daemon/tsk.c
+++ b/daemon/tsk.c
@@ -38,13 +38,15 @@
enum tsk_dirent_flags {
DIRENT_UNALLOC = 0x00,
DIRENT_ALLOC = 0x01,
- DIRENT_REALLOC = 0x02
+ DIRENT_REALLOC = 0x02,
+ DIRENT_COMPRESSED = 0x04
};
static int open_filesystem (const char *, TSK_IMG_INFO **, TSK_FS_INFO **);
static TSK_WALK_RET_ENUM fswalk_callback (TSK_FS_FILE *, const char *, void *);
static char file_type (TSK_FS_FILE *);
static int file_flags (TSK_FS_FILE *fsfile);
+static void file_metadata (TSK_FS_META *, guestfs_int_tsk_dirent *);
static int send_dirent_info (guestfs_int_tsk_dirent *);
static void reply_with_tsk_error (const char *);
@@ -122,15 +124,15 @@ fswalk_callback (TSK_FS_FILE *fsfile, const char *path, void *data)
return TSK_WALK_ERROR;
}
+ /* Set dirent fields */
+ memset (&dirent, 0, sizeof dirent);
+
dirent.tsk_inode = fsfile->name->meta_addr;
dirent.tsk_type = file_type (fsfile);
- dirent.tsk_size = (fsfile->meta != NULL) ? fsfile->meta->size : -1;
dirent.tsk_name = fname;
dirent.tsk_flags = file_flags (fsfile);
- dirent.tsk_spare1 = dirent.tsk_spare2 = dirent.tsk_spare3 =
- dirent.tsk_spare4 = dirent.tsk_spare5 = dirent.tsk_spare6 =
- dirent.tsk_spare7 = dirent.tsk_spare8 = dirent.tsk_spare9 =
- dirent.tsk_spare10 = dirent.tsk_spare11 = 0;
+
+ file_metadata (fsfile->meta, &dirent);
ret = send_dirent_info (&dirent);
ret = (ret == 0) ? TSK_WALK_CONT : TSK_WALK_ERROR;
@@ -175,7 +177,7 @@ file_type (TSK_FS_FILE *fsfile)
return 'u';
}
-/* Inspect fsfile to retrieve the file allocation state. */
+/* Inspect fsfile to retrieve file flags. */
static int
file_flags (TSK_FS_FILE *fsfile)
{
@@ -188,9 +190,37 @@ file_flags (TSK_FS_FILE *fsfile)
else
flags |= DIRENT_ALLOC;
+ if (fsfile->meta && fsfile->meta->flags & TSK_FS_META_FLAG_COMP)
+ flags |= DIRENT_COMPRESSED;
+
return flags;
}
+/* Inspect fsfile to retrieve file metadata. */
+static void
+file_metadata (TSK_FS_META *fsmeta, guestfs_int_tsk_dirent *dirent)
+{
+ if (fsmeta != NULL) {
+ dirent->tsk_size = fsmeta->size;
+ dirent->tsk_nlink = fsmeta->nlink;
+ dirent->tsk_atime_sec = fsmeta->atime;
+ dirent->tsk_atime_nsec = fsmeta->atime_nano;
+ dirent->tsk_mtime_sec = fsmeta->mtime;
+ dirent->tsk_mtime_nsec = fsmeta->mtime_nano;
+ dirent->tsk_ctime_sec = fsmeta->ctime;
+ dirent->tsk_ctime_nsec = fsmeta->ctime_nano;
+ dirent->tsk_crtime_sec = fsmeta->crtime;
+ dirent->tsk_crtime_nsec = fsmeta->crtime_nano;
+ /* tsk_link never changes */
+ dirent->tsk_link = (fsmeta->link != NULL) ? fsmeta->link : (char *) "";
+ }
+ else {
+ dirent->tsk_size = -1;
+ /* tsk_link never changes */
+ dirent->tsk_link = (char *) "";
+ }
+}
+
/* Serialise dirent into XDR stream and send it to the appliance.
* Return 0 on success, -1 on error.
*/
diff --git a/generator/actions.ml b/generator/actions.ml
index e0931b8..78d0a73 100644
--- a/generator/actions.ml
+++ b/generator/actions.ml
@@ -3612,11 +3612,46 @@ from the metadata structure.
The bit is set to C<1> when the file name is in an unallocated state
and the metadata structure is in an allocated one.
This generally implies the metadata has been reallocated to a new file.
-Therefore, information such as file type and file size
-might not correspond with the ones of the original deleted entry.
+Therefore, information such as file type, file size, timestamps,
+number of links and symlink target might not correspond
+with the ones of the original deleted entry.
+
+=item 0x0004
+
+The bit is set to C<1> when the file is compressed using filesystem
+native compression support (NTFS). The API is not able to detect
+application level compression.
=back
+=item 'tsk_atime_sec'
+
+=item 'tsk_atime_nsec'
+
+=item 'tsk_mtime_sec'
+
+=item 'tsk_mtime_nsec'
+
+=item 'tsk_ctime_sec'
+
+=item 'tsk_ctime_nsec'
+
+=item 'tsk_crtime_sec'
+
+=item 'tsk_crtime_nsec'
+
+Respectively, access, modification, last status change and creation
+time in Unix format in seconds and nanoseconds.
+
+=item 'tsk_nlink'
+
+Number of file names pointing to this entry.
+
+=item 'tsk_link'
+
+If the entry is a symbolic link, this field will contain the path
+to the target file.
+
=back
The C<tsk_type> field will contain one of the following characters:
diff --git a/generator/structs.ml b/generator/structs.ml
index eb8931f..029bc3a 100644
--- a/generator/structs.ml
+++ b/generator/structs.ml
@@ -454,17 +454,17 @@ let structs = [
"tsk_size", FInt64;
"tsk_name", FString;
"tsk_flags", FUInt32;
+ "tsk_atime_sec", FInt64;
+ "tsk_atime_nsec", FInt64;
+ "tsk_mtime_sec", FInt64;
+ "tsk_mtime_nsec", FInt64;
+ "tsk_ctime_sec", FInt64;
+ "tsk_ctime_nsec", FInt64;
+ "tsk_crtime_sec", FInt64;
+ "tsk_crtime_nsec", FInt64;
+ "tsk_nlink", FInt64;
+ "tsk_link", FString;
"tsk_spare1", FInt64;
- "tsk_spare2", FInt64;
- "tsk_spare3", FInt64;
- "tsk_spare4", FInt64;
- "tsk_spare5", FInt64;
- "tsk_spare6", FInt64;
- "tsk_spare7", FInt64;
- "tsk_spare8", FInt64;
- "tsk_spare9", FInt64;
- "tsk_spare10", FInt64;
- "tsk_spare11", FInt64;
];
s_camel_name = "TSKDirent" };
diff --git a/tests/tsk/test-filesystem-walk.sh b/tests/tsk/test-filesystem-walk.sh
index 6ee3f71..f0c2d3d 100755
--- a/tests/tsk/test-filesystem-walk.sh
+++ b/tests/tsk/test-filesystem-walk.sh
@@ -51,17 +51,17 @@ tsk_type: r
tsk_size: .*
tsk_name: \$MFT
tsk_flags: 1
-tsk_spare1: 0
-tsk_spare2: 0
-tsk_spare3: 0
-tsk_spare4: 0
-tsk_spare5: 0
-tsk_spare6: 0
-tsk_spare7: 0
-tsk_spare8: 0
-tsk_spare9: 0
-tsk_spare10: 0
-tsk_spare11: 0 }'
+tsk_atime_sec: .*
+tsk_atime_nsec: .*
+tsk_mtime_sec: .*
+tsk_mtime_nsec: .*
+tsk_ctime_sec: .*
+tsk_ctime_nsec: .*
+tsk_crtime_sec: .*
+tsk_crtime_nsec: .*
+tsk_nlink: 1
+tsk_link:
+tsk_spare1: 0 }'
if [ $? != 0 ]; then
echo "$0: \$MFT not found in files list."
echo "File list:"
@@ -75,17 +75,17 @@ tsk_type: [ru]
tsk_size: .*
tsk_name: test.txt
tsk_flags: 0
-tsk_spare1: 0
-tsk_spare2: 0
-tsk_spare3: 0
-tsk_spare4: 0
-tsk_spare5: 0
-tsk_spare6: 0
-tsk_spare7: 0
-tsk_spare8: 0
-tsk_spare9: 0
-tsk_spare10: 0
-tsk_spare11: 0 }'
+tsk_atime_sec: .*
+tsk_atime_nsec: .*
+tsk_mtime_sec: .*
+tsk_mtime_nsec: .*
+tsk_ctime_sec: .*
+tsk_ctime_nsec: .*
+tsk_crtime_sec: .*
+tsk_crtime_nsec: .*
+tsk_nlink: .*
+tsk_link:
+tsk_spare1: 0 }'
if [ $? != 0 ]; then
echo "$0: /test.txt not found in files list."
echo "File list:"
--
2.8.1
8 years, 4 months
- 2
- 1
[PATCH v3 0/8] v2v: Move Curl wrapper to mllib and more.
by Richard W.M. Jones
v2 -> v3:
- Changes to the Curl API suggested by Pino.
8 years, 4 months
- 2
- 16
[PATCH v2 0/8] v2v: Move Curl wrapper to mllib and use it for virt-builder (and more).
by Richard W.M. Jones
v1 -> v2:
- Fixed the bug with precedence of if / @.
- Add some imperative list operators inspired by Perl, and use those
for constructing the Curl arguments, and more.
Rich.
8 years, 4 months
- 2
- 9
[PATCH 1/2] daemon: free the string on stringsbuf add failure
by Pino Toscano
If add_string_nodup fails free the passed string instead of leaking it,
as that string would have been owned by the stringbuf.
Adapt few places to this behaviour.
---
daemon/btrfs.c | 4 +---
daemon/devsparts.c | 8 ++++----
daemon/guestfsd.c | 1 +
3 files changed, 6 insertions(+), 7 deletions(-)
diff --git a/daemon/btrfs.c b/daemon/btrfs.c
index 9b52aa8..d70565a 100644
--- a/daemon/btrfs.c
+++ b/daemon/btrfs.c
@@ -1123,10 +1123,8 @@ do_btrfs_subvolume_show (const char *subvolume)
}
if (ss) {
- if (add_string_nodup (&ret, ss) == -1) {
- free (ss);
+ if (add_string_nodup (&ret, ss) == -1)
return NULL;
- }
} else {
if (add_string (&ret, "") == -1)
return NULL;
diff --git a/daemon/devsparts.c b/daemon/devsparts.c
index 7c690f8..41c728c 100644
--- a/daemon/devsparts.c
+++ b/daemon/devsparts.c
@@ -311,7 +311,6 @@ do_list_disk_labels (void)
{
DIR *dir = NULL;
struct dirent *d;
- char *rawdev = NULL;
DECLARE_STRINGSBUF (ret);
dir = opendir (GUESTFSDIR);
@@ -330,6 +329,7 @@ do_list_disk_labels (void)
errno = 0;
while ((d = readdir (dir)) != NULL) {
CLEANUP_FREE char *path = NULL;
+ char *rawdev;
if (d->d_name[0] == '.')
continue;
@@ -347,12 +347,13 @@ do_list_disk_labels (void)
goto error;
}
- if (add_string (&ret, d->d_name) == -1)
+ if (add_string (&ret, d->d_name) == -1) {
+ free (rawdev);
goto error;
+ }
if (add_string_nodup (&ret, rawdev) == -1)
goto error;
- rawdev = NULL; /* buffer now owned by the stringsbuf */
}
/* Check readdir didn't fail */
@@ -380,6 +381,5 @@ do_list_disk_labels (void)
error:
if (dir)
closedir (dir);
- free (rawdev);
return NULL;
}
diff --git a/daemon/guestfsd.c b/daemon/guestfsd.c
index 8b9acc7..af151bd 100644
--- a/daemon/guestfsd.c
+++ b/daemon/guestfsd.c
@@ -512,6 +512,7 @@ add_string_nodup (struct stringsbuf *sb, char *str)
reply_with_perror ("realloc");
free_stringslen (sb->argv, sb->size);
sb->argv = NULL;
+ free (str);
return -1;
}
sb->argv = new_argv;
--
2.5.5
8 years, 4 months
- 2
- 2
[PATCH] filesystem_walk: more information into tsk_dirent
by Matteo Cafasso
Access, modification, last status change and creation time in
Unix format as for statns.
Number of links pointing to a given entry.
If the entry is a symbolic link, report the its target path.
A new flag (DIRENT_COMPRESSED 0x04) indicating whether the file is
compressed using native filesystem compression support.
Signed-off-by: Matteo Cafasso <noxdafox(a)gmail.com>
---
daemon/tsk.c | 59 ++++++++++++++++++++++++++++++++++-----
generator/actions.ml | 39 ++++++++++++++++++++++++--
generator/structs.ml | 20 ++++++-------
tests/tsk/test-filesystem-walk.sh | 44 ++++++++++++++---------------
4 files changed, 121 insertions(+), 41 deletions(-)
diff --git a/daemon/tsk.c b/daemon/tsk.c
index 446213e..b0fb3a7 100644
--- a/daemon/tsk.c
+++ b/daemon/tsk.c
@@ -38,13 +38,15 @@
enum tsk_dirent_flags {
DIRENT_UNALLOC = 0x00,
DIRENT_ALLOC = 0x01,
- DIRENT_REALLOC = 0x02
+ DIRENT_REALLOC = 0x02,
+ DIRENT_COMPRESSED = 0x04
};
static int open_filesystem (const char *, TSK_IMG_INFO **, TSK_FS_INFO **);
static TSK_WALK_RET_ENUM fswalk_callback (TSK_FS_FILE *, const char *, void *);
static char file_type (TSK_FS_FILE *);
static int file_flags (TSK_FS_FILE *fsfile);
+static int file_metadata (TSK_FS_META *, guestfs_int_tsk_dirent *);
static int send_dirent_info (guestfs_int_tsk_dirent *);
static void reply_with_tsk_error (const char *);
@@ -122,19 +124,24 @@ fswalk_callback (TSK_FS_FILE *fsfile, const char *path, void *data)
return TSK_WALK_ERROR;
}
+ /* Set dirent fields */
+ memset (&dirent, 0, sizeof dirent);
+
dirent.tsk_inode = fsfile->name->meta_addr;
dirent.tsk_type = file_type (fsfile);
- dirent.tsk_size = (fsfile->meta != NULL) ? fsfile->meta->size : -1;
dirent.tsk_name = fname;
dirent.tsk_flags = file_flags (fsfile);
- dirent.tsk_spare1 = dirent.tsk_spare2 = dirent.tsk_spare3 =
- dirent.tsk_spare4 = dirent.tsk_spare5 = dirent.tsk_spare6 =
- dirent.tsk_spare7 = dirent.tsk_spare8 = dirent.tsk_spare9 =
- dirent.tsk_spare10 = dirent.tsk_spare11 = 0;
+
+ ret = file_metadata (fsfile->meta, &dirent);
+ if (ret < 0)
+ return TSK_WALK_ERROR;
ret = send_dirent_info (&dirent);
ret = (ret == 0) ? TSK_WALK_CONT : TSK_WALK_ERROR;
+ if (strlen(dirent.tsk_link) == 0)
+ free (dirent.tsk_link);
+
return ret;
}
@@ -175,7 +182,7 @@ file_type (TSK_FS_FILE *fsfile)
return 'u';
}
-/* Inspect fsfile to retrieve the file allocation state. */
+/* Inspect fsfile to retrieve file flags. */
static int
file_flags (TSK_FS_FILE *fsfile)
{
@@ -188,9 +195,47 @@ file_flags (TSK_FS_FILE *fsfile)
else
flags |= DIRENT_ALLOC;
+ if (fsfile->meta && fsfile->meta->flags & TSK_FS_META_FLAG_COMP)
+ flags |= DIRENT_COMPRESSED;
+
return flags;
}
+/* Inspect fsfile to retrieve file metadata. */
+static int
+file_metadata (TSK_FS_META *fsmeta, guestfs_int_tsk_dirent *dirent)
+{
+ if (fsmeta != NULL) {
+ dirent->tsk_size = fsmeta->size;
+ dirent->tsk_nlink = fsmeta->nlink;
+ dirent->tsk_atime_sec = fsmeta->atime;
+ dirent->tsk_atime_nsec = fsmeta->atime_nano;
+ dirent->tsk_mtime_sec = fsmeta->mtime;
+ dirent->tsk_mtime_nsec = fsmeta->mtime_nano;
+ dirent->tsk_ctime_sec = fsmeta->ctime;
+ dirent->tsk_ctime_nsec = fsmeta->ctime_nano;
+ dirent->tsk_crtime_sec = fsmeta->crtime;
+ dirent->tsk_crtime_nsec = fsmeta->crtime_nano;
+
+ dirent->tsk_link = (fsmeta->link != NULL) ? fsmeta->link : strdup ("");
+ if (dirent->tsk_link == NULL) {
+ perror ("strdup");
+ return -1;
+ }
+ }
+ else {
+ dirent->tsk_size = -1;
+
+ dirent->tsk_link = strdup ("");
+ if (dirent->tsk_link == NULL) {
+ perror ("strdup");
+ return -1;
+ }
+ }
+
+ return 0;
+}
+
/* Serialise dirent into XDR stream and send it to the appliance.
* Return 0 on success, -1 on error.
*/
diff --git a/generator/actions.ml b/generator/actions.ml
index e0931b8..78d0a73 100644
--- a/generator/actions.ml
+++ b/generator/actions.ml
@@ -3612,11 +3612,46 @@ from the metadata structure.
The bit is set to C<1> when the file name is in an unallocated state
and the metadata structure is in an allocated one.
This generally implies the metadata has been reallocated to a new file.
-Therefore, information such as file type and file size
-might not correspond with the ones of the original deleted entry.
+Therefore, information such as file type, file size, timestamps,
+number of links and symlink target might not correspond
+with the ones of the original deleted entry.
+
+=item 0x0004
+
+The bit is set to C<1> when the file is compressed using filesystem
+native compression support (NTFS). The API is not able to detect
+application level compression.
=back
+=item 'tsk_atime_sec'
+
+=item 'tsk_atime_nsec'
+
+=item 'tsk_mtime_sec'
+
+=item 'tsk_mtime_nsec'
+
+=item 'tsk_ctime_sec'
+
+=item 'tsk_ctime_nsec'
+
+=item 'tsk_crtime_sec'
+
+=item 'tsk_crtime_nsec'
+
+Respectively, access, modification, last status change and creation
+time in Unix format in seconds and nanoseconds.
+
+=item 'tsk_nlink'
+
+Number of file names pointing to this entry.
+
+=item 'tsk_link'
+
+If the entry is a symbolic link, this field will contain the path
+to the target file.
+
=back
The C<tsk_type> field will contain one of the following characters:
diff --git a/generator/structs.ml b/generator/structs.ml
index eb8931f..029bc3a 100644
--- a/generator/structs.ml
+++ b/generator/structs.ml
@@ -454,17 +454,17 @@ let structs = [
"tsk_size", FInt64;
"tsk_name", FString;
"tsk_flags", FUInt32;
+ "tsk_atime_sec", FInt64;
+ "tsk_atime_nsec", FInt64;
+ "tsk_mtime_sec", FInt64;
+ "tsk_mtime_nsec", FInt64;
+ "tsk_ctime_sec", FInt64;
+ "tsk_ctime_nsec", FInt64;
+ "tsk_crtime_sec", FInt64;
+ "tsk_crtime_nsec", FInt64;
+ "tsk_nlink", FInt64;
+ "tsk_link", FString;
"tsk_spare1", FInt64;
- "tsk_spare2", FInt64;
- "tsk_spare3", FInt64;
- "tsk_spare4", FInt64;
- "tsk_spare5", FInt64;
- "tsk_spare6", FInt64;
- "tsk_spare7", FInt64;
- "tsk_spare8", FInt64;
- "tsk_spare9", FInt64;
- "tsk_spare10", FInt64;
- "tsk_spare11", FInt64;
];
s_camel_name = "TSKDirent" };
diff --git a/tests/tsk/test-filesystem-walk.sh b/tests/tsk/test-filesystem-walk.sh
index 6ee3f71..f0c2d3d 100755
--- a/tests/tsk/test-filesystem-walk.sh
+++ b/tests/tsk/test-filesystem-walk.sh
@@ -51,17 +51,17 @@ tsk_type: r
tsk_size: .*
tsk_name: \$MFT
tsk_flags: 1
-tsk_spare1: 0
-tsk_spare2: 0
-tsk_spare3: 0
-tsk_spare4: 0
-tsk_spare5: 0
-tsk_spare6: 0
-tsk_spare7: 0
-tsk_spare8: 0
-tsk_spare9: 0
-tsk_spare10: 0
-tsk_spare11: 0 }'
+tsk_atime_sec: .*
+tsk_atime_nsec: .*
+tsk_mtime_sec: .*
+tsk_mtime_nsec: .*
+tsk_ctime_sec: .*
+tsk_ctime_nsec: .*
+tsk_crtime_sec: .*
+tsk_crtime_nsec: .*
+tsk_nlink: 1
+tsk_link:
+tsk_spare1: 0 }'
if [ $? != 0 ]; then
echo "$0: \$MFT not found in files list."
echo "File list:"
@@ -75,17 +75,17 @@ tsk_type: [ru]
tsk_size: .*
tsk_name: test.txt
tsk_flags: 0
-tsk_spare1: 0
-tsk_spare2: 0
-tsk_spare3: 0
-tsk_spare4: 0
-tsk_spare5: 0
-tsk_spare6: 0
-tsk_spare7: 0
-tsk_spare8: 0
-tsk_spare9: 0
-tsk_spare10: 0
-tsk_spare11: 0 }'
+tsk_atime_sec: .*
+tsk_atime_nsec: .*
+tsk_mtime_sec: .*
+tsk_mtime_nsec: .*
+tsk_ctime_sec: .*
+tsk_ctime_nsec: .*
+tsk_crtime_sec: .*
+tsk_crtime_nsec: .*
+tsk_nlink: .*
+tsk_link:
+tsk_spare1: 0 }'
if [ $? != 0 ]; then
echo "$0: /test.txt not found in files list."
echo "File list:"
--
2.8.1
8 years, 4 months
- 2
- 1
list-filesystems and btrfs snapshots
by Maxim Perevedentsev
Hello everyone!
I have an issue with OpenSUSE-42.1 (I guess this is the only distro with
btrfs snapshots by default).
As we remember, list_filesystems returns btrfs snapshots along with devices.
><fs> list-filesystems
/dev/sda1: swap
btrfsvol:/dev/sda2/@: btrfs
btrfsvol:/dev/sda2/@/.snapshots: btrfs
btrfsvol:/dev/sda2/@/.snapshots/1/snapshot: btrfs
btrfsvol:/dev/sda2/@/.snapshots/2/snapshot: btrfs
...
btrfsvol:/dev/sda2/@/.snapshots/16/snapshot: btrfs
/dev/sda2: btrfs
The btrfs snapshots are not block devices, so an error is thrown by
RESOLVE_DEVICE macro in stubs.c. That means we will get an error
trying to call blockdev - oriented functions at these devices.
=========================
After grepping "list_filesystems" issues were found in:
- virt-sparsify (in-place and copying): is_lv
- virt-filesystems: blockdev_getsize64
- virt-cat (inspect_os) treats this as multiboot system and refuses to
proceed
- virt-rescue --suggest suggests all snapshots (maybe this is correct)
- virt-sysprep --operation fs-uuids goes into infinite loop
[ 144.2] Performing "fs-uuids" ...
virt-sysprep: warning: cannot set random UUID on filesystem
btrfsvol:/dev/sda2/@/.snapshots/16/snapshot type btrfs: set_uuid:
set_uuid_stub: btrfsvol:/dev/sda2/@/.snapshots/16/snapshot: expecting a
device name
...
virt-sysprep: warning: cannot set random UUID on filesystem
btrfsvol:/dev/sda2/@/.snapshots/1/snapshot type btrfs: set_uuid:
set_uuid_stub: btrfsvol:/dev/sda2/@/.snapshots/1/snapshot: expecting a
device name
virt-sysprep: warning: cannot set random UUID on filesystem
btrfsvol:/dev/sda2/@/.snapshots type btrfs: set_uuid: set_uuid_stub:
btrfsvol:/dev/sda2/@/.snapshots: expecting a device name
virt-sysprep: warning: cannot set random UUID on filesystem
btrfsvol:/dev/sda2/@ type btrfs: set_uuid: set_uuid_stub:
btrfsvol:/dev/sda2/@: expecting a device name
[ 154.4] Performing "fs-uuids" ...
=========================
I'd like to ask for your comments on fixing this.
Should we
1. add a new command (guestfs_list_filesystems_devices) to return only
device-like filesystems?
2. add something like guestfs_is_device which handles subvolumes on host
side?
NB: guestfs_is_blockdev also fails on stub
3. allow guestfs_is_(blockdev|chardev|...) to check subvolumes on host
side? (maybe together with 2?)
4. anything else?
Thank you!
--
Your sincerely,
Maxim Perevedentsev
8 years, 4 months
- 3
- 4
[PATCH 0/3] Move Curl wrapper to mllib and use it for virt-builder.
by Richard W.M. Jones
Move the Curl wrapper module from virt-v2v to mllib. Use the module
when virt-builder issues curl calls.
Rich.
8 years, 4 months
- 1
- 4