[Libguestfs] [PATCH v3 1/2] OCaml tools: add and use a Getopt module

Add a new Getopt module to mllib, to parse command line arguments with handlers close to the ones used with Arg, but using getopt(3) (actually getopt_long_only) to do the real parsing. This allow us to provide options for OCaml tools with a syntax similar to the C tools, and use the additional features getopt offers and Arg does not. 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. --- builder/Makefile.am | 2 + builder/cmdline.ml | 93 ++++----- customize/Makefile.am | 2 + customize/customize_main.ml | 35 ++-- dib/Makefile.am | 3 + dib/cmdline.ml | 83 ++++---- generator/customize.ml | 104 +++++----- get-kernel/Makefile.am | 2 + get-kernel/get_kernel.ml | 28 ++- mllib/Makefile.am | 10 +- mllib/common_utils.ml | 65 +----- mllib/common_utils.mli | 10 +- mllib/getopt-c.c | 316 ++++++++++++++++++++++++++++++ mllib/getopt.ml | 203 +++++++++++++++++++ mllib/getopt.mli | 87 ++++++++ resize/Makefile.am | 2 + resize/resize.ml | 53 +++-- sparsify/Makefile.am | 9 +- sparsify/cmdline.ml | 26 ++- sysprep/Makefile.am | 2 + sysprep/main.ml | 41 ++-- sysprep/sysprep_operation.ml | 29 +-- sysprep/sysprep_operation.mli | 6 +- sysprep/sysprep_operation_script.ml | 4 +- sysprep/sysprep_operation_user_account.ml | 4 +- v2v/Makefile.am | 5 + v2v/cmdline.ml | 92 ++++----- v2v/copy_to_local.ml | 12 +- 28 files changed, 941 insertions(+), 387 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 5c41cfa..a4691d7 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 6085b45..846c2e3 100644 --- a/builder/cmdline.ml +++ b/builder/cmdline.ml @@ -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 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 3681b32..2d2c3e9 100644 --- a/customize/customize_main.ml +++ b/customize/customize_main.ml @@ -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"); 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 ec4ebba..0ec1616 100644 --- a/dib/cmdline.ml +++ b/dib/cmdline.ml @@ -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"; - - "--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; + let opthandle = create_standard_options argspec ~anon_fun:append_element usage_msg in + Getopt.parse opthandle; let debug = !debug in let basepath = !basepath in diff --git a/generator/customize.ml b/generator/customize.ml index 8caf2b5..0924732 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 () -> 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 -> 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..b841c5f 100644 --- a/get-kernel/get_kernel.ml +++ b/get-kernel/get_kernel.ml @@ -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. diff --git a/mllib/Makefile.am b/mllib/Makefile.am index e728d54..041d09a 100644 --- a/mllib/Makefile.am +++ b/mllib/Makefile.am @@ -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 $@ diff --git a/mllib/common_utils.ml b/mllib/common_utils.ml index 69118da..2379e61 100644 --- a/mllib/common_utils.ml +++ b/mllib/common_utils.ml @@ -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]+\\)\\(.*\\)$" diff --git a/mllib/common_utils.mli b/mllib/common_utils.mli index 9b1086c..b45cdbd 100644 --- a/mllib/common_utils.mli +++ b/mllib/common_utils.mli @@ -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. *) diff --git a/mllib/getopt-c.c b/mllib/getopt-c.c new file mode 100644 index 0000000..1f129a7 --- /dev/null +++ b/mllib/getopt-c.c @@ -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); +} diff --git a/mllib/getopt.ml b/mllib/getopt.ml new file mode 100644 index 0000000..90f4c44 --- /dev/null +++ b/mllib/getopt.ml @@ -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 diff --git a/mllib/getopt.mli b/mllib/getopt.mli new file mode 100644 index 0000000..9d9737e --- /dev/null +++ b/mllib/getopt.mli @@ -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]. *) 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 f92f1b7..185f5a0 100644 --- a/resize/resize.ml +++ b/resize/resize.ml @@ -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:"; 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 0c12f8e..3593e26 100644 --- a/sparsify/cmdline.ml +++ b/sparsify/cmdline.ml @@ -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 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 7922b43..3259d0d 100644 --- a/sysprep/main.ml +++ b/sysprep/main.ml @@ -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"); diff --git a/sysprep/sysprep_operation.ml b/sysprep/sysprep_operation.ml index 73020d5..b4d650f 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,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)) -> diff --git a/sysprep/sysprep_operation.mli b/sysprep/sysprep_operation.mli index f532a8c..7291dd6 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.speclist (** 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 4b3748c..cc0ec9b 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 fedc84d..bca5ba3 100644 --- a/v2v/Makefile.am +++ b/v2v/Makefile.am @@ -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 \ diff --git a/v2v/cmdline.ml b/v2v/cmdline.ml index 1a729ca..e704bd4 100644 --- a/v2v/cmdline.ml +++ b/v2v/cmdline.ml @@ -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 diff --git a/v2v/copy_to_local.ml b/v2v/copy_to_local.ml index 1811dca..fe34413 100644 --- a/v2v/copy_to_local.ml +++ b/v2v/copy_to_local.ml @@ -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 -- 2.7.4