mirrors/libguestfs
1
0
Fork 0
mirror of https://github.com/libguestfs/libguestfs.git synced 2026-03-22 07:03:38 +00:00
Code Issues Packages Projects Releases Wiki Activity

OCaml tools: add and use a Getopt module

Browse Source 
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.
Getopt now handles every part of the command line handling, including
the output of short & long options.

Do a single-step conversion of Common_utils and all the OCaml tools to
the syntax of Getopt.

Move a couple of utility functions from Common_utils to Getopt, since
they fit better there (and Common_utils cannot be used in Getopt, as
the former already uses the latter).

As side-change due to the conversion, extra arguments for sysprep
operation can have more keys for the same argument.
This commit is contained in:
Pino Toscano
2016-07-13 14:56:11 +02:00
parent cbf4bbf266
commit 0f7bf8f714
28 changed files with 937 additions and 383 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
builder/Makefile.am
View File

@@ -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 \

93
builder/cmdline.ml
View File

@@ -119,60 +119,52 @@ 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 =
List.map (fun (spec, _, _) -> spec) customize_argspec in
let argspec = argspec @ customize_argspec in
let argspec = set_standard_options argspec in
let args = ref [] in
let anon_fun s = push_front s args in
@@ -192,7 +184,8 @@ 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;
let opthandle = create_standard_options argspec ~anon_fun usage_msg in
Getopt.parse opthandle;
(* Dereference options. *)
let args = List.rev !args in

2
customize/Makefile.am
View File

@@ -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 \

35
customize/customize_main.ml
View File

@@ -71,33 +71,25 @@ 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
let customize_argspec =
List.map (fun (spec, _, _) -> spec) customize_argspec in
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 +102,8 @@ 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;
let opthandle = create_standard_options argspec usage_msg in
Getopt.parse opthandle;
if not !format_consumed then
error (f_"--format parameter must appear before -a parameter");

3
dib/Makefile.am
View File

@@ -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

75
dib/cmdline.ml
View File

@@ -151,51 +151,48 @@ read the man page virt-dib(1).
prepend (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";
[ "-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", Arg.Set is_ramdisk, " " ^ "Switch to a ramdisk build";
"--ramdisk-element", Arg.Set_string ramdisk_element, "name" ^ " " ^ s_"Main element for building ramdisks";
[ "--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", 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";
[ "--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", 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";
[ "-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", Arg.Int set_debug, "level" ^ " " ^ s_"Set debug level";
"-B", Arg.Set_string basepath, "path" ^ " " ^ s_"Base path of diskimage-builder library";
[ "--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;
let opthandle = create_standard_options argspec ~anon_fun:append_element usage_msg in
Getopt.parse opthandle;
let debug = !debug in
let basepath = !basepath in

104
generator/customize.ml
View File

@@ -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 () -> push_front %s ops),\n" discrim;
pr " \" \" ^ s_\"%s\"\n" shortdesc;
pr " [ \"--%s\" ],\n" name;
pr " Getopt.Unit (fun () -> push_front %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 -> push_front (%s s) ops),\n" discrim;
pr " s_\"%s\" ^ \" \" ^ s_\"%s\"\n" v shortdesc;
pr " [ \"--%s\" ],\n" name;
pr " Getopt.String (s_\"%s\", fun s -> push_front (%s s) ops),\n" v discrim;
pr " s_\"%s\"\n" shortdesc;
pr " ),\n";
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 " push_front (%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 " push_front (%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 " push_front (%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 " push_front (%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 " push_front (%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 " push_front (%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 " push_front (%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 " push_front (%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 ->

2
get-kernel/Makefile.am
View File

@@ -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)

28
get-kernel/get_kernel.ml
View File

@@ -50,24 +50,17 @@ 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 +69,8 @@ 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;
let opthandle = create_standard_options argspec usage_msg in
Getopt.parse opthandle;
(* Machine-readable mode? Print out some facts about what
* this binary supports.

10
mllib/Makefile.am
View File

@@ -31,6 +31,7 @@ SOURCES_MLI = \
curl.mli \
dev_t.mli \
fsync.mli \
getopt.mli \
JSON.mli \
mkdtemp.mli \
planner.mli \
@@ -44,6 +45,7 @@ SOURCES_ML = \
$(OCAML_BYTES_COMPAT_ML) \
libdir.ml \
common_gettext.ml \
getopt.ml \
dev_t.ml \
common_utils.ml \
fsync.ml \
@@ -61,6 +63,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 \
@@ -142,15 +145,18 @@ libdir.ml: Makefile
common_utils_tests_SOURCES = \
dev_t-c.c \
getopt-c.c \
dummy.c
common_utils_tests_CPPFLAGS = \
-I. \
-I$(top_builddir) \
-I$(shell $(OCAMLC) -where)
-I$(shell $(OCAMLC) -where) \
-I$(top_srcdir)/src
common_utils_tests_BOBJECTS = \
guestfs_config.cmo \
common_gettext.cmo \
dev_t.cmo \
getopt.cmo \
common_utils.cmo \
common_utils_tests.cmo
common_utils_tests_XOBJECTS = $(common_utils_tests_BOBJECTS:.cmo=.cmx)
@@ -178,7 +184,7 @@ endif
common_utils_tests_DEPENDENCIES = $(common_utils_tests_THEOBJECTS) $(top_srcdir)/ocaml-link.sh
common_utils_tests_LINK = \
$(top_srcdir)/ocaml-link.sh -- \
$(top_srcdir)/ocaml-link.sh -cclib '-lutils $(LIBXML2_LIBS) -lgnu' -- \
$(OCAMLFIND) $(BEST) $(OCAMLFLAGS) $(OCAMLPACKAGES) $(OCAMLPACKAGES_TESTS) $(OCAMLLINKFLAGS) \
$(common_utils_tests_THEOBJECTS) -o $@

65
mllib/common_utils.ml
View File

@@ -566,67 +566,20 @@ let human_size i =
)
)
(* Skip any leading '-' characters when comparing command line args. *)
let skip_dashes str =
let n = String.length str in
let rec loop i =
if i >= n then invalid_arg "skip_dashes"
else if String.unsafe_get str i = '-' then loop (i+1)
else i
in
let i = loop 0 in
if i = 0 then str
else String.sub str i (n-i)
let compare_command_line_args a b =
compare (String.lowercase (skip_dashes a)) (String.lowercase (skip_dashes b))
(* Implement `--short-options' and `--long-options'. *)
let long_options = ref ([] : (Arg.key * Arg.spec * Arg.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
) !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
) !long_options;
exit 0
let set_standard_options argspec =
let create_standard_options argspec ?anon_fun usage_msg =
(** Install an exit hook to check gc consistency for --debug-gc *)
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";
[ "-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 =
let cmp (arg1, _, _) (arg2, _, _) = compare_command_line_args arg1 arg2 in
List.sort cmp argspec in
let argspec = Arg.align argspec in
long_options := argspec;
argspec
Getopt.create argspec ?anon_fun usage_msg
(* Compare two version strings intelligently. *)
let rex_numbers = Str.regexp "^\\([0-9]+\\)\\(.*\\)$"

10
mllib/common_utils.mli
View File

@@ -254,17 +254,11 @@ val parse_resize : int64 -> string -> int64
val human_size : int64 -> string
(** Converts a size in bytes to a human-readable string. *)
val skip_dashes : string -> string
(** Skip any leading '-' characters when comparing command line args. *)
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 create_standard_options : Getopt.speclist -> ?anon_fun:Getopt.anon_fun -> Getopt.usage_msg -> Getopt.t
(** Adds the standard libguestfs command line options to the specified ones,
sorting them, and setting [long_options] to them.
Returns the resulting options. *)
Returns a new [Getopt.t] handle. *)
val compare_version : string -> string -> int
(** Compare two version strings. *)

316
mllib/getopt-c.c Normal file
View File

@@ -0,0 +1,316 @@
/* 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 <assert.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-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)
#ifdef HAVE_ATTRIBUTE_CLEANUP
#define CLEANUP_FREE_OPTION_LIST __attribute__((cleanup(cleanup_option_list)))
static void
cleanup_option_list (void *ptr)
{
struct option *opts = * (struct option **) ptr;
struct option *p = opts;
while (p->name != NULL) {
/* Cast the constness away, since we created the names on heap. */
free ((char *) p->name);
++p;
}
free (opts);
}
#else
#define CLEANUP_FREE_OPTION_LIST
#endif
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\n",
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);
CAMLlocal5 (specv, keysv, actionv, v, v2);
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_OPTION_LIST 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);
assert (len != 0);
for (j = 0; j < len; ++j) {
const char *key = String_val (Field (keysv, j));
size_t key_len = strlen (key);
int has_arg = 0;
/* We assume that the key is valid, with the checks done in the
* OCaml Getopt.parse_argv. */
++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 = strdup (key);
if (longopts[longopts_len].name == NULL)
caml_raise_out_of_memory ();
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:
/* specv_index set already -- nothing to do. */
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) */
v = Field (actionv, 0);
do_call1 (v, 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) */
v = Field (actionv, 1);
v2 = caml_copy_string (optarg);
do_call1 (v, v2);
break;
case 4: /* Set_string of string * string ref */
v = caml_copy_string (optarg);
caml_modify (&Field (Field (actionv, 1), 0), v);
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);
}
v = Field (actionv, 1);
do_call1 (v, 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) {
v2 = caml_copy_string (argv[optind++]);
do_call1 (v, v2);
}
}
CAMLreturn (Val_unit);
}

203
mllib/getopt.ml Normal file
View File

@@ -0,0 +1,203 @@
(* Command line handling 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
open Printf
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
type speclist = (keys * spec * doc) list
type t = {
mutable specs : speclist;
anon_fun : anon_fun option;
usage_msg : usage_msg;
}
external getopt_parse : string array -> (c_keys * spec * doc) array -> ?anon_fun:anon_fun -> usage_msg -> unit = "guestfs_int_mllib_getopt_parse"
let column_wrap = 38
let show_help h () =
let b = Buffer.create 1024 in
let spaces n =
String.make n ' ' in
let prologue = sprintf (f_"%s\nOptions:\n") h.usage_msg in
Buffer.add_string b prologue;
List.iter (
fun (keys, spec, doc) ->
let columns = ref 0 in
let add s =
Buffer.add_string b s;
columns := !columns + (String.length s)
in
add " ";
add (String.concat ", " keys);
let arg =
match spec with
| Unit _
| Set _
| Clear _ -> None
| String (arg, _)
| Set_string (arg, _)
| Int (arg, _)
| Set_int (arg, _) -> Some arg in
(match arg with
| None -> ()
| Some arg ->
add (sprintf " <%s>" arg)
);
if !columns >= column_wrap then (
Buffer.add_char b '\n';
Buffer.add_string b (spaces column_wrap);
) else (
Buffer.add_string b (spaces (column_wrap - !columns));
);
Buffer.add_string b doc;
Buffer.add_char b '\n';
) h.specs;
Buffer.output_buffer stdout b;
exit 0
let is_prefix str prefix =
let n = String.length prefix in
String.length str >= n && String.sub str 0 n = prefix
(* Implement `--short-options' and `--long-options'. *)
let display_short_options h () =
List.iter (
fun (args, _, _) ->
List.iter (
fun arg ->
if is_prefix arg "-" && not (is_prefix arg "--") then
printf "%s\n" arg
) args
) h.specs;
exit 0
let display_long_options h () =
List.iter (
fun (args, _, _) ->
List.iter (
fun arg ->
if is_prefix arg "--" && arg <> "--long-options" &&
arg <> "--short-options" then
printf "%s\n" arg
) args
) h.specs;
exit 0
(* Skip any leading '-' characters when comparing command line args. *)
let skip_dashes str =
let n = String.length str in
let rec loop i =
if i >= n then invalid_arg "skip_dashes"
else if String.unsafe_get str i = '-' then loop (i+1)
else i
in
let i = loop 0 in
if i = 0 then str
else String.sub str i (n-i)
let compare_command_line_args a b =
compare (String.lowercase (skip_dashes a)) (String.lowercase (skip_dashes b))
let create specs ?anon_fun usage_msg =
(* Sanity check the input *)
let validate_key key =
if String.length key == 0 || key == "-" || key == "--"
|| key.[0] != '-' then
invalid_arg (sprintf "invalid option key: '%s'" key)
in
List.iter (
fun (keys, spec, doc) ->
if keys == [] then
invalid_arg "empty keys for Getopt spec";
List.iter validate_key keys;
) specs;
let t =
{
specs = []; (* Set it later, with own options, and sorted. *)
anon_fun = anon_fun;
usage_msg = usage_msg;
} in
let specs = specs @ [
[ "--short-options" ], Unit (display_short_options t), s_"List short options (internal)";
[ "--long-options" ], Unit (display_long_options t), s_"List long options (internal)";
] in
(* Decide whether the help option can be added, and which switches use. *)
let has_dash_help = ref false in
let has_dash_dash_help = ref false in
List.iter (
fun (keys, _, _) ->
if not (!has_dash_help) then
has_dash_help := List.mem "-help" keys;
if not (!has_dash_dash_help) then
has_dash_dash_help := List.mem "--help" keys;
) specs;
let help_keys = [] @
(if !has_dash_help then [] else [ "-help" ]) @
(if !has_dash_dash_help then [] else [ "--help" ]) in
let specs = specs @
(if help_keys <> [] then [ help_keys, Unit (show_help t), s_"Display brief help"; ] else []) in
(* Sort the specs, and set them in the handle. *)
let specs = List.map (
fun (keys, action, doc) ->
List.hd (List.sort compare_command_line_args keys), (keys, action, doc)
) specs in
let specs =
let cmp (arg1, _) (arg2, _) = compare_command_line_args arg1 arg2 in
List.sort cmp specs in
let specs = List.map snd specs in
t.specs <- specs;
t
let parse_argv t argv =
let specs = List.map (
fun (keys, spec, doc) ->
Array.of_list keys, spec, doc
) t.specs in
let specs = Array.of_list specs in
getopt_parse argv specs ?anon_fun:t.anon_fun t.usage_msg
let parse t =
parse_argv t Sys.argv

87
mllib/getopt.mli Normal file
View File

@@ -0,0 +1,87 @@
(* Command line handling 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)
type speclist = (keys * spec * doc) list
val compare_command_line_args : string -> string -> int
(** Compare command line arguments for equality, ignoring any leading [-]s. *)
type t
(** The abstract data type. *)
val create : speclist -> ?anon_fun:anon_fun -> usage_msg -> t
(** [Getopt.create speclist ?anon_fun usage_msg] creates a new parses
for command line arguments.
[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.
*)
val parse_argv : t -> string array -> unit
(** [Getopt.parse handle args] parses the specified arguments.
[handle] is the [Getopt.t] type with the configuration of the
command line arguments.
[args] is the array with command line arguments, with the first
element representing the application name/path.
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 with a non-zero exit
value. *)
val parse : t -> unit
(** Call {!Getopt.parse_argv} on [Sys.argv]. *)

2
resize/Makefile.am
View File

@@ -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)

53
resize/resize.ml
View File

@@ -182,37 +182,29 @@ 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
let anon_fun s = push_front s disks in
let usage_msg =
@@ -223,7 +215,8 @@ 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;
let opthandle = create_standard_options argspec ~anon_fun usage_msg in
Getopt.parse opthandle;
if verbose () then (
printf "command line:";

9
sparsify/Makefile.am
View File

@@ -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)

26
sparsify/cmdline.ml
View File

@@ -63,21 +63,18 @@ 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
let anon_fun s = push_front s disks in
let usage_msg =
@@ -92,7 +89,8 @@ 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;
let opthandle = create_standard_options argspec ~anon_fun usage_msg in
Getopt.parse opthandle;
(* Dereference the rest of the args. *)
let check_tmpdir = !check_tmpdir in

2
sysprep/Makefile.am
View File

@@ -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 \

41
sysprep/main.ml
View File

@@ -117,31 +117,23 @@ 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 +146,8 @@ 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;
let opthandle = create_standard_options args usage_msg in
Getopt.parse opthandle;
if not !format_consumed then
error (f_"--format parameter must appear before -a parameter");

29
sysprep/sysprep_operation.ml
View File

@@ -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,30 +208,37 @@ 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 _ |
Getopt.Set_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
List.sort (fun (a, _) (b, _) -> Getopt.compare_command_line_args a b) args in
List.iter (
fun (arg_name, (op_name, heading, pod)) ->

6
sysprep/sysprep_operation.mli
View File

@@ -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.speclist
(** Get the list of extra arguments for the command line. *)
val dump_pod : unit -> unit

4
sysprep/sysprep_operation_script.ml
View File

@@ -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

4
sysprep/sysprep_operation_user_account.ml
View File

@@ -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.

5
v2v/Makefile.am
View File

@@ -97,6 +97,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 \
@@ -124,6 +125,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 \
@@ -177,6 +179,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
@@ -195,6 +198,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 \
@@ -409,6 +413,7 @@ v2v_unit_tests_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 \
stringMap.cmo \

92
v2v/cmdline.ml
View File

@@ -164,57 +164,48 @@ 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
let anon_fun s = push_front s args in
let usage_msg =
@@ -239,7 +230,8 @@ 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;
let opthandle = create_standard_options argspec ~anon_fun usage_msg in
Getopt.parse opthandle;
(* Dereference the arguments. *)
let args = List.rev !args in

12
v2v/copy_to_local.ml
View File

@@ -41,12 +41,11 @@ 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
let anon_fun s = push_front s args in
let usage_msg =
@@ -71,7 +70,8 @@ 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;
let opthandle = create_standard_options argspec ~anon_fun usage_msg in
Getopt.parse opthandle;
let args = !args in
let input_conn = !input_conn in