The ‘Progress’ module is a self-contained library with the only dependencies being: - the C ‘progress’ implementation Move it to a separate ‘common/mlprogress’ directory. This change is pure code refactoring. --- .gitignore | 1 + Makefile.am | 1 + common/mlprogress/Makefile.am | 111 ++++++++++++++++++++++++++++++ {mllib => common/mlprogress}/progress-c.c | 0 {mllib => common/mlprogress}/progress.ml | 0 {mllib => common/mlprogress}/progress.mli | 0 configure.ac | 1 + docs/C_SOURCE_FILES | 2 +- docs/guestfs-hacking.pod | 4 ++ mllib/Makefile.am | 7 +- resize/Makefile.am | 9 ++- sparsify/Makefile.am | 9 ++- 12 files changed, 136 insertions(+), 9 deletions(-) create mode 100644 common/mlprogress/Makefile.am rename {mllib => common/mlprogress}/progress-c.c (100%) rename {mllib => common/mlprogress}/progress.ml (100%) rename {mllib => common/mlprogress}/progress.mli (100%) diff --git a/.gitignore b/.gitignore index 2367cddcb..ea245c49d 100644 --- a/.gitignore +++ b/.gitignore @@ -124,6 +124,7 @@ Makefile.in /common/errnostring/errnostring-gperf.gperf /common/errnostring/errnostring.h /common/miniexpect/miniexpect.3 +/common/mlprogress/.depend /common/mlvisit/.depend /common/mlvisit/visit_tests /common/protocol/guestfs_protocol.c diff --git a/Makefile.am b/Makefile.am index 499a1d279..bd0fc94e7 100644 --- a/Makefile.am +++ b/Makefile.am @@ -154,6 +154,7 @@ SUBDIRS += csharp # shared code used by other OCaml tools, so these must come first. if HAVE_OCAML SUBDIRS += \ + common/mlprogress \ common/mlvisit \ mllib \ customize \ diff --git a/common/mlprogress/Makefile.am b/common/mlprogress/Makefile.am new file mode 100644 index 000000000..d4a229451 --- /dev/null +++ b/common/mlprogress/Makefile.am @@ -0,0 +1,111 @@ +# libguestfs OCaml tools common code +# Copyright (C) 2011-2017 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 $(top_srcdir)/subdir-rules.mk + +EXTRA_DIST = \ + $(SOURCES_MLI) \ + $(SOURCES_ML) \ + $(SOURCES_C) + +SOURCES_MLI = \ + progress.mli + +SOURCES_ML = \ + progress.ml + +SOURCES_C = \ + progress-c.c + +if HAVE_OCAML + +# We pretend that we're building a C library. automake handles the +# compilation of the C sources for us. At the end we take the C +# objects and OCaml objects and link them into the OCaml library. +# This C library is never used. + +noinst_LIBRARIES = libmlprogress.a + +if !HAVE_OCAMLOPT +MLPROGRESS_CMA = mlprogress.cma +else +MLPROGRESS_CMA = mlprogress.cmxa +endif + +noinst_DATA = $(MLPROGRESS_CMA) + +libmlprogress_a_SOURCES = $(SOURCES_C) +libmlprogress_a_CPPFLAGS = \ + -I. \ + -I$(top_builddir) \ + -I$(top_srcdir)/gnulib/lib -I$(top_builddir)/gnulib/lib \ + -I$(shell $(OCAMLC) -where) \ + -I$(top_srcdir)/common/utils \ + -I$(top_srcdir)/lib \ + -I$(top_srcdir)/common/progress +libmlprogress_a_CFLAGS = \ + $(WARN_CFLAGS) $(WERROR_CFLAGS) \ + $(LIBVIRT_CFLAGS) $(LIBXML2_CFLAGS) \ + -fPIC + +BOBJECTS = $(SOURCES_ML:.ml=.cmo) +XOBJECTS = $(BOBJECTS:.cmo=.cmx) + +# -I $(top_builddir)/lib/.libs is a hack which forces corresponding -L +# option to be passed to gcc, so we don't try linking against an +# installed copy of libguestfs. +OCAMLPACKAGES = \ + -package str,unix \ + -I $(top_builddir)/common/utils/.libs \ + -I $(top_builddir)/lib/.libs \ + -I $(top_builddir)/gnulib/lib/.libs \ + -I $(top_builddir)/ocaml \ + -I $(builddir) + +OCAMLFLAGS = $(OCAML_FLAGS) $(OCAML_WARN_ERROR) + +if !HAVE_OCAMLOPT +OBJECTS = $(BOBJECTS) +else +OBJECTS = $(XOBJECTS) +endif + +libmlprogress_a_DEPENDENCIES = $(OBJECTS) + +$(MLPROGRESS_CMA): $(OBJECTS) libmlprogress.a + $(OCAMLFIND) mklib $(OCAMLPACKAGES) \ + $(OBJECTS) $(libmlprogress_a_OBJECTS) \ + -cclib -lprogress \ + -o mlprogress + +# Dependencies. +depend: .depend + +.depend: $(wildcard $(abs_srcdir)/*.mli) $(wildcard $(abs_srcdir)/*.ml) + rm -f $@ $@-t + $(OCAMLFIND) ocamldep -I ../../ocaml -I $(abs_srcdir) $^ | \ + $(SED) 's/ *$$//' | \ + $(SED) -e :a -e '/ *\\$$/N; s/ *\\\n */ /; ta' | \ + $(SED) -e 's,$(abs_srcdir)/,$(builddir)/,g' | \ + sort > $@-t + mv $@-t $@ + +-include .depend + +endif + +.PHONY: depend docs diff --git a/mllib/progress-c.c b/common/mlprogress/progress-c.c similarity index 100% rename from mllib/progress-c.c rename to common/mlprogress/progress-c.c diff --git a/mllib/progress.ml b/common/mlprogress/progress.ml similarity index 100% rename from mllib/progress.ml rename to common/mlprogress/progress.ml diff --git a/mllib/progress.mli b/common/mlprogress/progress.mli similarity index 100% rename from mllib/progress.mli rename to common/mlprogress/progress.mli diff --git a/configure.ac b/configure.ac index 4fc226123..1abb72671 100644 --- a/configure.ac +++ b/configure.ac @@ -185,6 +185,7 @@ AC_CONFIG_FILES([Makefile common/errnostring/Makefile common/edit/Makefile common/miniexpect/Makefile + common/mlprogress/Makefile common/mlvisit/Makefile common/options/Makefile common/parallel/Makefile diff --git a/docs/C_SOURCE_FILES b/docs/C_SOURCE_FILES index 578126403..1e2a99e7e 100644 --- a/docs/C_SOURCE_FILES +++ b/docs/C_SOURCE_FILES @@ -15,6 +15,7 @@ common/edit/file-edit.c common/edit/file-edit.h common/miniexpect/miniexpect.c common/miniexpect/miniexpect.h +common/mlprogress/progress-c.c common/mlvisit/dummy.c common/mlvisit/visit-c.c common/options/config.c @@ -339,7 +340,6 @@ make-fs/make-fs.c mllib/common_utils-c.c mllib/dummy.c mllib/getopt-c.c -mllib/progress-c.c mllib/unix_utils-c.c mllib/uri-c.c mllib/xml-c.c diff --git a/docs/guestfs-hacking.pod b/docs/guestfs-hacking.pod index ac6d1ccbf..f9cb88f05 100644 --- a/docs/guestfs-hacking.pod +++ b/docs/guestfs-hacking.pod @@ -100,6 +100,10 @@ A copy of the miniexpect library from L<http://git.annexia.org/?p=miniexpect.git;a=summary>;. This is used in virt-p2v. +=item F<common/mlprogress> + +OCaml bindings for the progress bar functions (see F<common/progress>). + =item F<common/mlvisit> OCaml bindings for the visit functions (see F<common/visit>). diff --git a/mllib/Makefile.am b/mllib/Makefile.am index cb79f50f5..42f450323 100644 --- a/mllib/Makefile.am +++ b/mllib/Makefile.am @@ -36,7 +36,6 @@ SOURCES_MLI = \ getopt.mli \ JSON.mli \ planner.mli \ - progress.mli \ regedit.mli \ registry.mli \ stringMap.mli \ @@ -51,7 +50,6 @@ SOURCES_ML = \ getopt.ml \ unix_utils.ml \ common_utils.ml \ - progress.ml \ URI.ml \ planner.ml \ registry.ml \ @@ -66,10 +64,8 @@ SOURCES_C = \ ../common/options/decrypt.c \ ../common/options/keys.c \ ../common/options/uri.c \ - ../common/progress/progress.c \ common_utils-c.c \ getopt-c.c \ - progress-c.c \ unix_utils-c.c \ uri-c.c \ xml-c.c @@ -99,8 +95,7 @@ libmllib_a_CPPFLAGS = \ -I$(shell $(OCAMLC) -where) \ -I$(top_srcdir)/common/utils \ -I$(top_srcdir)/lib \ - -I$(top_srcdir)/common/options \ - -I$(top_srcdir)/common/progress + -I$(top_srcdir)/common/options libmllib_a_CFLAGS = \ $(WARN_CFLAGS) $(WERROR_CFLAGS) \ $(LIBVIRT_CFLAGS) $(LIBXML2_CFLAGS) \ diff --git a/resize/Makefile.am b/resize/Makefile.am index e097dd611..c35c3a78a 100644 --- a/resize/Makefile.am +++ b/resize/Makefile.am @@ -57,15 +57,18 @@ XOBJECTS = $(BOBJECTS:.cmo=.cmx) OCAMLPACKAGES = \ -package str,unix \ -I $(top_builddir)/common/utils/.libs \ + -I $(top_builddir)/common/progress/.libs \ -I $(top_builddir)/lib/.libs \ -I $(top_builddir)/gnulib/lib/.libs \ -I $(top_builddir)/ocaml \ + -I $(top_builddir)/common/mlprogress \ -I $(top_builddir)/mllib if HAVE_OCAML_PKG_GETTEXT OCAMLPACKAGES += -package gettext-stub endif OCAMLCLIBS = \ + -lprogress \ -lutils \ $(LIBTINFO_LIBS) \ $(LIBXML2_LIBS) \ @@ -80,7 +83,11 @@ else OBJECTS = $(XOBJECTS) endif -OCAMLLINKFLAGS = mlguestfs.$(MLARCHIVE) mllib.$(MLARCHIVE) $(LINK_CUSTOM_OCAMLC_ONLY) +OCAMLLINKFLAGS = \ + mlguestfs.$(MLARCHIVE) \ + mlprogress.$(MLARCHIVE) \ + mllib.$(MLARCHIVE) \ + $(LINK_CUSTOM_OCAMLC_ONLY) virt_resize_DEPENDENCIES = \ $(OBJECTS) \ diff --git a/sparsify/Makefile.am b/sparsify/Makefile.am index b7229ffdd..97236829e 100644 --- a/sparsify/Makefile.am +++ b/sparsify/Makefile.am @@ -62,15 +62,18 @@ XOBJECTS = $(BOBJECTS:.cmo=.cmx) OCAMLPACKAGES = \ -package str,unix \ -I $(top_builddir)/common/utils/.libs \ + -I $(top_builddir)/common/progress/.libs \ -I $(top_builddir)/lib/.libs \ -I $(top_builddir)/gnulib/lib/.libs \ -I $(top_builddir)/ocaml \ + -I $(top_builddir)/common/mlprogress \ -I $(top_builddir)/mllib if HAVE_OCAML_PKG_GETTEXT OCAMLPACKAGES += -package gettext-stub endif OCAMLCLIBS = \ + -lprogress \ -lutils \ $(LIBTINFO_LIBS) \ $(LIBXML2_LIBS) \ @@ -85,7 +88,11 @@ else OBJECTS = $(XOBJECTS) endif -OCAMLLINKFLAGS = mlguestfs.$(MLARCHIVE) mllib.$(MLARCHIVE) $(LINK_CUSTOM_OCAMLC_ONLY) +OCAMLLINKFLAGS = \ + mlguestfs.$(MLARCHIVE) \ + mlprogress.$(MLARCHIVE) \ + mllib.$(MLARCHIVE) \ + $(LINK_CUSTOM_OCAMLC_ONLY) virt_sparsify_DEPENDENCIES = \ $(OBJECTS) \ -- 2.13.0

The new module ‘Std_utils’ contains only functions which are pure OCaml and depend only on the OCaml stdlib. Therefore these functions may be used by the generator. The new module is moved to ‘common/mlstdutils’. This also removes the "<stdlib>" hack, and the code which copied the library around. Also ‘Guestfs_config’, ‘Libdir’ and ‘StringMap’ modules are moved since these are essentially the same. The bulk of this change is just updating files which use ‘open Common_utils’ to add ‘open Std_utils’ where necessary. --- .gitignore | 8 +- Makefile.am | 2 +- builder/Makefile.am | 12 +- builder/builder.ml | 1 + builder/cache.ml | 3 +- builder/cmdline.ml | 3 +- builder/downloader.ml | 3 +- builder/index.ml | 3 +- builder/index_parser.ml | 3 +- builder/ini_reader.ml | 1 + builder/languages.ml | 1 + builder/list_entries.ml | 3 +- builder/paths.ml | 1 + builder/sigchecker.ml | 3 +- builder/simplestreams_parser.ml | 3 +- builder/sources.ml | 3 +- builder/yajl.ml | 3 +- common/mlstdutils/Makefile.am | 151 +++++ common/mlstdutils/dummy.c | 2 + {mllib => common/mlstdutils}/guestfs_config.ml.in | 0 common/mlstdutils/std_utils.ml | 664 +++++++++++++++++++++ common/mlstdutils/std_utils.mli | 338 +++++++++++ common/mlstdutils/std_utils_tests.ml | 95 +++ {mllib => common/mlstdutils}/stringMap.ml | 0 {mllib => common/mlstdutils}/stringMap.mli | 0 configure.ac | 3 +- customize/Makefile.am | 8 +- customize/SELinux_relabel.ml | 3 +- customize/append_line.ml | 1 + customize/customize_main.ml | 3 +- customize/customize_run.ml | 3 +- customize/firstboot.ml | 1 + customize/hostname.ml | 1 + customize/password.ml | 3 +- customize/perl_edit.ml | 1 + customize/ssh_key.ml | 7 +- customize/subscription_manager.ml | 3 +- dib/Makefile.am | 10 +- dib/cmdline.ml | 3 +- dib/dib.ml | 3 +- dib/elements.ml | 3 +- dib/output_format.ml | 1 + dib/output_format_qcow2.ml | 1 + dib/utils.ml | 3 +- docs/C_SOURCE_FILES | 1 + docs/guestfs-hacking.pod | 4 + generator/GObject.ml | 2 +- generator/Makefile.am | 34 +- generator/OCaml.ml | 2 +- generator/UEFI.ml | 2 +- generator/XDR.ml | 2 +- generator/actions.ml | 2 +- generator/authors.ml | 2 +- generator/bindtests.ml | 2 +- generator/c.ml | 2 +- generator/checks.ml | 2 +- generator/csharp.ml | 2 +- generator/customize.ml | 3 +- generator/daemon.ml | 2 +- generator/docstrings.ml | 2 +- generator/erlang.ml | 2 +- generator/errnostring.ml | 2 +- generator/events.ml | 2 +- generator/fish.ml | 2 +- generator/golang.ml | 2 +- generator/haskell.ml | 2 +- generator/java.ml | 2 +- generator/lua.ml | 2 +- generator/main.ml | 2 +- generator/optgroups.ml | 2 +- generator/perl.ml | 2 +- generator/php.ml | 2 +- generator/pr.ml | 2 +- generator/python.ml | 2 +- generator/ruby.ml | 2 +- generator/structs.ml | 2 +- generator/tests_c_api.ml | 2 +- generator/utils.ml | 2 +- get-kernel/Makefile.am | 10 +- get-kernel/get_kernel.ml | 3 +- mllib/Makefile.am | 25 +- mllib/checksums.ml | 3 +- mllib/common_utils.ml | 676 +--------------------- mllib/common_utils.mli | 347 ----------- mllib/common_utils_tests.ml | 62 +- mllib/curl.ml | 1 + mllib/getopt_tests.ml | 1 + mllib/regedit.ml | 1 + mllib/registry.ml | 3 +- mllib/xpath_helpers.ml | 3 +- resize/Makefile.am | 5 +- resize/resize.ml | 1 + sparsify/Makefile.am | 5 +- sparsify/cmdline.ml | 3 +- sparsify/copying.ml | 1 + sparsify/in_place.ml | 1 + sparsify/utils.ml | 2 +- sysprep/Makefile.am | 5 +- sysprep/main.ml | 1 + sysprep/sysprep_operation.ml | 4 +- sysprep/sysprep_operation_backup_files.ml | 3 +- sysprep/sysprep_operation_cron_spool.ml | 6 +- sysprep/sysprep_operation_net_hostname.ml | 4 +- sysprep/sysprep_operation_net_hwaddr.ml | 4 +- sysprep/sysprep_operation_script.ml | 3 +- sysprep/sysprep_operation_user_account.ml | 1 + v2v/DOM.ml | 1 + v2v/Makefile.am | 6 +- v2v/changeuid.ml | 3 +- v2v/cmdline.ml | 3 +- v2v/convert_linux.ml | 3 +- v2v/convert_windows.ml | 3 +- v2v/copy_to_local.ml | 3 +- v2v/create_libvirt_xml.ml | 3 +- v2v/create_ovf.ml | 7 +- v2v/input_disk.ml | 3 +- v2v/input_libvirtxml.ml | 3 +- v2v/input_ova.ml | 3 +- v2v/input_vmx.ml | 3 +- v2v/inspect_source.ml | 1 + v2v/linux.ml | 3 +- v2v/linux_bootloaders.ml | 3 +- v2v/linux_kernels.ml | 3 +- v2v/modules_list.ml | 2 +- v2v/output_glance.ml | 3 +- v2v/output_libvirt.ml | 3 +- v2v/output_local.ml | 3 +- v2v/output_null.ml | 3 +- v2v/output_qemu.ml | 3 +- v2v/output_rhv.ml | 3 +- v2v/output_vdsm.ml | 3 +- v2v/parse_libvirt_xml.ml | 7 +- v2v/parse_ovf_from_ova.ml | 3 +- v2v/parse_vmx.ml | 1 + v2v/target_bus_assignment.ml | 1 + v2v/test-harness/Makefile.am | 3 +- v2v/test-harness/v2v_test_harness.ml | 1 + v2v/utils.ml | 3 +- v2v/v2v.ml | 3 +- v2v/v2v_unit_tests.ml | 8 +- v2v/vCenter.ml | 1 + v2v/windows_virtio.ml | 3 +- 142 files changed, 1526 insertions(+), 1238 deletions(-) create mode 100644 common/mlstdutils/Makefile.am create mode 100644 common/mlstdutils/dummy.c rename {mllib => common/mlstdutils}/guestfs_config.ml.in (100%) create mode 100644 common/mlstdutils/std_utils.ml create mode 100644 common/mlstdutils/std_utils.mli create mode 100644 common/mlstdutils/std_utils_tests.ml rename {mllib => common/mlstdutils}/stringMap.ml (100%) rename {mllib => common/mlstdutils}/stringMap.mli (100%) diff --git a/.gitignore b/.gitignore index a82a1f674..991b1ab94 100644 --- a/.gitignore +++ b/.gitignore @@ -125,6 +125,11 @@ Makefile.in /common/errnostring/errnostring.h /common/miniexpect/miniexpect.3 /common/mlprogress/.depend +/common/mlstdutils/.depend +/common/mlstdutils/guestfs_config.ml +/common/mlstdutils/libdir.ml +/common/mlstdutils/oUnit-* +/common/mlstdutils/std_utils_tests /common/mlvisit/.depend /common/mlvisit/visit_tests /common/mlxml/.depend @@ -276,7 +281,6 @@ Makefile.in /generator/common_utils.mli /generator/files-generated.txt /generator/generator -/generator/guestfs_config.ml /generator/.pod2text.data* /generator/stamp-generator /get-kernel/.depend @@ -366,9 +370,7 @@ Makefile.in /mllib/common_utils_tests /mllib/dummy /mllib/getopt_tests -/mllib/guestfs_config.ml /mllib/JSON_tests -/mllib/libdir.ml /mllib/oUnit-* /ocaml/bindtests.bc /ocaml/bindtests.opt diff --git a/Makefile.am b/Makefile.am index 48f538475..64ac23f2e 100644 --- a/Makefile.am +++ b/Makefile.am @@ -20,7 +20,7 @@ include $(top_srcdir)/common-rules.mk ACLOCAL_AMFLAGS = -I m4 # The generator - must be before anything else. -SUBDIRS = generator +SUBDIRS = common/mlstdutils generator # Must be the first tests that run. if ENABLE_APPLIANCE diff --git a/builder/Makefile.am b/builder/Makefile.am index d56b394b7..5f0606ca4 100644 --- a/builder/Makefile.am +++ b/builder/Makefile.am @@ -124,6 +124,7 @@ OCAMLPACKAGES = \ -I $(top_builddir)/lib/.libs \ -I $(top_builddir)/gnulib/lib/.libs \ -I $(top_builddir)/ocaml \ + -I $(top_builddir)/common/mlstdutils \ -I $(top_builddir)/mllib \ -I $(top_builddir)/customize OCAMLPACKAGES_TESTS = @@ -153,10 +154,16 @@ else OBJECTS = $(XOBJECTS) endif -OCAMLLINKFLAGS = mlguestfs.$(MLARCHIVE) mllib.$(MLARCHIVE) customize.$(MLARCHIVE) $(LINK_CUSTOM_OCAMLC_ONLY) +OCAMLLINKFLAGS = \ + mlstdutils.$(MLARCHIVE) \ + mlguestfs.$(MLARCHIVE) \ + mllib.$(MLARCHIVE) \ + customize.$(MLARCHIVE) \ + $(LINK_CUSTOM_OCAMLC_ONLY) virt_builder_DEPENDENCIES = \ $(OBJECTS) \ + ../common/mlstdutils/mlstdutils.$(MLARCHIVE) \ ../mllib/mllib.$(MLARCHIVE) \ ../customize/customize.$(MLARCHIVE) \ $(top_srcdir)/ocaml-link.sh @@ -228,6 +235,7 @@ endif yajl_tests_DEPENDENCIES = \ $(yajl_tests_THEOBJECTS) \ + ../common/mlstdutils/mlstdutils.$(MLARCHIVE) \ ../mllib/mllib.$(MLARCHIVE) \ ../customize/customize.$(MLARCHIVE) \ $(top_srcdir)/ocaml-link.sh @@ -299,7 +307,7 @@ depend: .depend .depend: $(wildcard $(abs_srcdir)/*.mli) $(wildcard $(abs_srcdir)/*.ml) rm -f $@ $@-t - $(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/mllib -I $(abs_top_builddir)/customize $^ | \ + $(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/mlstdutils -I $(abs_top_builddir)/mllib -I $(abs_top_builddir)/customize $^ | \ $(SED) 's/ *$$//' | \ $(SED) -e :a -e '/ *\\$$/N; s/ *\\\n */ /; ta' | \ $(SED) -e 's,$(abs_srcdir)/,$(builddir)/,g' | \ diff --git a/builder/builder.ml b/builder/builder.ml index b0a48ea89..0e02bab3b 100644 --- a/builder/builder.ml +++ b/builder/builder.ml @@ -20,6 +20,7 @@ open Common_gettext.Gettext module G = Guestfs +open Std_utils open Common_utils open Unix_utils open Password diff --git a/builder/cache.ml b/builder/cache.ml index 19fcd15e2..494796edb 100644 --- a/builder/cache.ml +++ b/builder/cache.ml @@ -16,8 +16,9 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Utils diff --git a/builder/cmdline.ml b/builder/cmdline.ml index f20c0936c..a1f901144 100644 --- a/builder/cmdline.ml +++ b/builder/cmdline.ml @@ -18,8 +18,9 @@ (* Command line argument parsing. *) -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Getopt.OptionName open Customize_cmdline diff --git a/builder/downloader.ml b/builder/downloader.ml index ef3cd67cb..d6b27c8c7 100644 --- a/builder/downloader.ml +++ b/builder/downloader.ml @@ -16,8 +16,9 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Utils diff --git a/builder/index.ml b/builder/index.ml index 8c59de651..54af6e719 100644 --- a/builder/index.ml +++ b/builder/index.ml @@ -16,8 +16,9 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Utils diff --git a/builder/index_parser.ml b/builder/index_parser.ml index 468805cf8..fb546831f 100644 --- a/builder/index_parser.ml +++ b/builder/index_parser.ml @@ -16,8 +16,9 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Utils diff --git a/builder/ini_reader.ml b/builder/ini_reader.ml index 0470d173d..2d8ff7e59 100644 --- a/builder/ini_reader.ml +++ b/builder/ini_reader.ml @@ -16,6 +16,7 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) +open Std_utils open Common_utils type sections = section list diff --git a/builder/languages.ml b/builder/languages.ml index 66f49cb06..d94f97c5c 100644 --- a/builder/languages.ml +++ b/builder/languages.ml @@ -16,6 +16,7 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) +open Std_utils open Common_utils let split_locale loc = diff --git a/builder/list_entries.ml b/builder/list_entries.ml index 2a1aef4c8..ea607107c 100644 --- a/builder/list_entries.ml +++ b/builder/list_entries.ml @@ -16,8 +16,9 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Printf diff --git a/builder/paths.ml b/builder/paths.ml index cbd9d4bd0..e0fb9a024 100644 --- a/builder/paths.ml +++ b/builder/paths.ml @@ -16,6 +16,7 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) +open Std_utils open Common_utils let xdg_cache_home = diff --git a/builder/sigchecker.ml b/builder/sigchecker.ml index 6c1e691ee..f72c21ab0 100644 --- a/builder/sigchecker.ml +++ b/builder/sigchecker.ml @@ -16,9 +16,10 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -open Common_gettext.Gettext +open Std_utils open Common_utils open Unix_utils +open Common_gettext.Gettext open Utils diff --git a/builder/simplestreams_parser.ml b/builder/simplestreams_parser.ml index 8844d476b..c550675ba 100644 --- a/builder/simplestreams_parser.ml +++ b/builder/simplestreams_parser.ml @@ -16,8 +16,9 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Yajl open Utils diff --git a/builder/sources.ml b/builder/sources.ml index 290151c3a..4c9ea0fff 100644 --- a/builder/sources.ml +++ b/builder/sources.ml @@ -16,8 +16,9 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Printf open Unix diff --git a/builder/yajl.ml b/builder/yajl.ml index d933b5246..5ae1c5d9b 100644 --- a/builder/yajl.ml +++ b/builder/yajl.ml @@ -16,8 +16,9 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext type yajl_val = | Yajl_null diff --git a/common/mlstdutils/Makefile.am b/common/mlstdutils/Makefile.am new file mode 100644 index 000000000..9e0b34d42 --- /dev/null +++ b/common/mlstdutils/Makefile.am @@ -0,0 +1,151 @@ +# libguestfs OCaml tools common code +# Copyright (C) 2011-2017 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 $(top_srcdir)/subdir-rules.mk + +EXTRA_DIST = \ + $(SOURCES_MLI) \ + $(SOURCES_ML) \ + std_utils_tests.ml + +SOURCES_MLI = \ + std_utils.mli \ + stringMap.mli + +SOURCES_ML = \ + guestfs_config.ml \ + $(OCAML_BYTES_COMPAT_ML) \ + libdir.ml \ + stringMap.ml \ + std_utils.ml + +if HAVE_OCAML + +# We pretend that we're building a C library. automake handles the +# compilation of the C sources for us. At the end we take the C +# objects and OCaml objects and link them into the OCaml library. +# This C library is never used. + +noinst_LIBRARIES = libmlstdutils.a + +if !HAVE_OCAMLOPT +MLSTDUTILS_CMA = mlstdutils.cma +else +MLSTDUTILS_CMA = mlstdutils.cmxa +endif + +noinst_DATA = $(MLSTDUTILS_CMA) + +libmlstdutils_a_SOURCES = dummy.c +libmlstdutils_a_CPPFLAGS = \ + -I. \ + -I$(top_builddir) +libmlstdutils_a_CFLAGS = \ + $(WARN_CFLAGS) $(WERROR_CFLAGS) \ + -fPIC + +BOBJECTS = $(SOURCES_ML:.ml=.cmo) +XOBJECTS = $(BOBJECTS:.cmo=.cmx) + +OCAMLPACKAGES = \ + -package str,unix \ + -I $(builddir) +OCAMLPACKAGES_TESTS = $(MLSTDUTILS_CMA) +if HAVE_OCAML_PKG_OUNIT +OCAMLPACKAGES_TESTS += -package oUnit +endif + +OCAMLFLAGS = $(OCAML_FLAGS) $(OCAML_WARN_ERROR) + +if !HAVE_OCAMLOPT +OBJECTS = $(BOBJECTS) +else +OBJECTS = $(XOBJECTS) +endif + +libmlstdutils_a_DEPENDENCIES = $(OBJECTS) + +$(MLSTDUTILS_CMA): $(OBJECTS) + $(OCAMLFIND) mklib $(OCAMLPACKAGES) $(OBJECTS) -o mlstdutils + +# This OCaml module has to be generated by make (configure will put +# unexpanded prefix macro in). + +libdir.ml: Makefile + echo 'let libdir = "$(libdir)"' > $@-t + mv $@-t $@ + +# Tests. + +std_utils_tests_SOURCES = dummy.c +std_utils_tests_CPPFLAGS = \ + -I. \ + -I$(top_builddir) +std_utils_tests_BOBJECTS = std_utils_tests.cmo +std_utils_tests_XOBJECTS = $(std_utils_tests_BOBJECTS:.cmo=.cmx) + +# Can't call the following as <test>_OBJECTS because automake gets confused. +if !HAVE_OCAMLOPT +std_utils_tests_THEOBJECTS = $(std_utils_tests_BOBJECTS) +std_utils_tests.cmo: OCAMLPACKAGES += $(OCAMLPACKAGES_TESTS) +else +std_utils_tests_THEOBJECTS = $(std_utils_tests_XOBJECTS) +std_utils_tests.cmx: OCAMLPACKAGES += $(OCAMLPACKAGES_TESTS) +endif + +OCAMLLINKFLAGS = $(LINK_CUSTOM_OCAMLC_ONLY) + +std_utils_tests_DEPENDENCIES = \ + $(std_utils_tests_THEOBJECTS) \ + $(MLSTDUTILS_CMA) \ + $(top_srcdir)/ocaml-link.sh +std_utils_tests_LINK = \ + $(top_srcdir)/ocaml-link.sh -- \ + $(OCAMLFIND) $(BEST) $(OCAMLFLAGS) $(OCAMLLINKFLAGS) \ + $(OCAMLPACKAGES) $(OCAMLPACKAGES_TESTS) \ + $(std_utils_tests_THEOBJECTS) -o $@ + +TESTS_ENVIRONMENT = $(top_builddir)/run --test + +TESTS = +check_PROGRAMS = + +if HAVE_OCAML_PKG_OUNIT +check_PROGRAMS += std_utils_tests +TESTS += std_utils_tests +endif + +check-valgrind: + $(MAKE) VG="@VG@" check + +# Dependencies. +depend: .depend + +.depend: $(wildcard $(abs_srcdir)/*.mli) $(wildcard $(abs_srcdir)/*.ml) + rm -f $@ $@-t + $(OCAMLFIND) ocamldep -I $(abs_srcdir) $^ | \ + $(SED) 's/ *$$//' | \ + $(SED) -e :a -e '/ *\\$$/N; s/ *\\\n */ /; ta' | \ + $(SED) -e 's,$(abs_srcdir)/,$(builddir)/,g' | \ + sort > $@-t + mv $@-t $@ + +-include .depend + +endif + +.PHONY: depend docs diff --git a/common/mlstdutils/dummy.c b/common/mlstdutils/dummy.c new file mode 100644 index 000000000..ebab6198c --- /dev/null +++ b/common/mlstdutils/dummy.c @@ -0,0 +1,2 @@ +/* Dummy source, to be used for OCaml-based tools with no C sources. */ +enum { foo = 1 }; diff --git a/mllib/guestfs_config.ml.in b/common/mlstdutils/guestfs_config.ml.in similarity index 100% rename from mllib/guestfs_config.ml.in rename to common/mlstdutils/guestfs_config.ml.in diff --git a/common/mlstdutils/std_utils.ml b/common/mlstdutils/std_utils.ml new file mode 100644 index 000000000..7b8d65f66 --- /dev/null +++ b/common/mlstdutils/std_utils.ml @@ -0,0 +1,664 @@ +(* Common utilities for OCaml tools in libguestfs. + * Copyright (C) 2010-2017 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 Printf + +module Char = struct + include Char + + let lowercase_ascii c = + if (c >= 'A' && c <= 'Z') + then unsafe_chr (code c + 32) + else c + + let uppercase_ascii c = + if (c >= 'a' && c <= 'z') + then unsafe_chr (code c - 32) + else c + + let isspace c = + c = ' ' + (* || c = '\f' *) || c = '\n' || c = '\r' || c = '\t' (* || c = '\v' *) + + let isdigit = function + | '0'..'9' -> true + | _ -> false + + let isxdigit = function + | '0'..'9' -> true + | 'a'..'f' -> true + | 'A'..'F' -> true + | _ -> false + + let isalpha = function + | 'a'..'z' -> true + | 'A'..'Z' -> true + | _ -> false + + let isalnum = function + | '0'..'9' -> true + | 'a'..'z' -> true + | 'A'..'Z' -> true + | _ -> false + + let hexdigit = function + | '0' -> 0 + | '1' -> 1 + | '2' -> 2 + | '3' -> 3 + | '4' -> 4 + | '5' -> 5 + | '6' -> 6 + | '7' -> 7 + | '8' -> 8 + | '9' -> 9 + | 'a' | 'A' -> 10 + | 'b' | 'B' -> 11 + | 'c' | 'C' -> 12 + | 'd' | 'D' -> 13 + | 'e' | 'E' -> 14 + | 'f' | 'F' -> 15 + | _ -> -1 +end + +module String = struct + include String + + let map f s = + let len = String.length s in + let b = Bytes.create len in + for i = 0 to len-1 do + Bytes.unsafe_set b i (f (unsafe_get s i)) + done; + Bytes.to_string b + + let lowercase_ascii s = map Char.lowercase_ascii s + let uppercase_ascii s = map Char.uppercase_ascii s + + let capitalize_ascii s = + let b = Bytes.of_string s in + Bytes.unsafe_set b 0 (Char.uppercase_ascii (Bytes.unsafe_get b 0)); + Bytes.to_string b + + let is_prefix str prefix = + let n = length prefix in + length str >= n && sub str 0 n = prefix + + let is_suffix str suffix = + let sufflen = length suffix + and len = length str in + len >= sufflen && sub str (len - sufflen) sufflen = suffix + + let rec find s sub = + let len = length s in + let sublen = length sub in + let rec loop i = + if i <= len-sublen then ( + let rec loop2 j = + if j < sublen then ( + if s.[i+j] = sub.[j] then loop2 (j+1) + else -1 + ) else + i (* found *) + in + let r = loop2 0 in + if r = -1 then loop (i+1) else r + ) else + -1 (* not found *) + in + loop 0 + + let rec replace s s1 s2 = + let len = length s in + let sublen = length s1 in + let i = find s s1 in + if i = -1 then s + else ( + let s' = sub s 0 i in + let s'' = sub s (i+sublen) (len-i-sublen) in + s' ^ s2 ^ replace s'' s1 s2 + ) + + let replace_char s c1 c2 = + let b2 = Bytes.of_string s in + let r = ref false in + for i = 0 to Bytes.length b2 - 1 do + if Bytes.unsafe_get b2 i = c1 then ( + Bytes.unsafe_set b2 i c2; + r := true + ) + done; + if not !r then s else Bytes.to_string b2 + + let rec nsplit sep str = + let len = length str in + let seplen = length sep in + let i = find str sep in + if i = -1 then [str] + else ( + let s' = sub str 0 i in + let s'' = sub str (i+seplen) (len-i-seplen) in + s' :: nsplit sep s'' + ) + + let split sep str = + let len = length sep in + let seplen = length str in + let i = find str sep in + if i = -1 then str, "" + else ( + sub str 0 i, sub str (i + len) (seplen - i - len) + ) + + let rec lines_split str = + let buf = Buffer.create 16 in + let len = length str in + let rec loop start len = + try + let i = index_from str start '\n' in + if i > 0 && str.[i-1] = '\\' then ( + Buffer.add_substring buf str start (i-start-1); + Buffer.add_char buf '\n'; + loop (i+1) len + ) else ( + Buffer.add_substring buf str start (i-start); + i+1 + ) + with Not_found -> + if len > 0 && str.[len-1] = '\\' then ( + Buffer.add_substring buf str start (len-start-1); + Buffer.add_char buf '\n' + ) else + Buffer.add_substring buf str start (len-start); + len+1 + in + let endi = loop 0 len in + let line = Buffer.contents buf in + if endi > len then + [line] + else + line :: lines_split (sub str endi (len-endi)) + + let random8 = + let chars = "abcdefghijklmnopqrstuvwxyz0123456789" in + fun () -> + concat "" ( + List.map ( + fun _ -> + let c = Random.int 36 in + let c = chars.[c] in + make 1 c + ) [1;2;3;4;5;6;7;8] + ) + + let triml ?(test = Char.isspace) str = + let i = ref 0 in + let n = ref (String.length str) in + while !n > 0 && test str.[!i]; do + decr n; + incr i + done; + if !i = 0 then str + else String.sub str !i !n + + let trimr ?(test = Char.isspace) str = + let n = ref (String.length str) in + while !n > 0 && test str.[!n-1]; do + decr n + done; + if !n = String.length str then str + else String.sub str 0 !n + + let trim ?(test = Char.isspace) str = + trimr ~test (triml ~test str) + + let count_chars c str = + let count = ref 0 in + for i = 0 to String.length str - 1 do + if c = String.unsafe_get str i then incr count + done; + !count + + let explode str = + let r = ref [] in + for i = 0 to String.length str - 1 do + let c = String.unsafe_get str i in + r := c :: !r; + done; + List.rev !r + + let map_chars f str = + List.map f (explode str) + + let spaces n = String.make n ' ' +end + +let (//) = Filename.concat +let quote = Filename.quote + +let subdirectory parent path = + if path = parent then + "" + else if String.is_prefix path (parent // "") then ( + let len = String.length parent in + String.sub path (len+1) (String.length path - len-1) + ) else + invalid_arg (sprintf "%S is not a path prefix of %S" parent path) + +let ( +^ ) = Int64.add +let ( -^ ) = Int64.sub +let ( *^ ) = Int64.mul +let ( /^ ) = Int64.div +let ( &^ ) = Int64.logand +let ( ~^ ) = Int64.lognot + +external identity : 'a -> 'a = "%identity" + +let roundup64 i a = let a = a -^ 1L in (i +^ a) &^ (~^ a) +let div_roundup64 i a = (i +^ a -^ 1L) /^ a + +let int_of_le32 str = + assert (String.length str = 4); + let c0 = Char.code (String.unsafe_get str 0) in + let c1 = Char.code (String.unsafe_get str 1) in + let c2 = Char.code (String.unsafe_get str 2) in + let c3 = Char.code (String.unsafe_get str 3) in + Int64.of_int c0 +^ + (Int64.shift_left (Int64.of_int c1) 8) +^ + (Int64.shift_left (Int64.of_int c2) 16) +^ + (Int64.shift_left (Int64.of_int c3) 24) + +let le32_of_int i = + let c0 = i &^ 0xffL in + let c1 = Int64.shift_right (i &^ 0xff00L) 8 in + let c2 = Int64.shift_right (i &^ 0xff0000L) 16 in + let c3 = Int64.shift_right (i &^ 0xff000000L) 24 in + let b = Bytes.create 4 in + Bytes.unsafe_set b 0 (Char.unsafe_chr (Int64.to_int c0)); + Bytes.unsafe_set b 1 (Char.unsafe_chr (Int64.to_int c1)); + Bytes.unsafe_set b 2 (Char.unsafe_chr (Int64.to_int c2)); + Bytes.unsafe_set b 3 (Char.unsafe_chr (Int64.to_int c3)); + Bytes.to_string b + +type wrap_break_t = WrapEOS | WrapSpace | WrapNL + +let rec wrap ?(chan = stdout) ?(indent = 0) str = + let len = String.length str in + _wrap chan indent 0 0 len str + +and _wrap chan indent column i len str = + if i < len then ( + let (j, break) = _wrap_find_next_break i len str in + let next_column = + if column + (j-i) >= 76 then ( + output_char chan '\n'; + output_spaces chan indent; + indent + (j-i) + 1 + ) + else column + (j-i) + 1 in + output chan (Bytes.of_string str) i (j-i); + match break with + | WrapEOS -> () + | WrapSpace -> + output_char chan ' '; + _wrap chan indent next_column (j+1) len str + | WrapNL -> + output_char chan '\n'; + output_spaces chan indent; + _wrap chan indent indent (j+1) len str + ) + +and _wrap_find_next_break i len str = + if i >= len then (len, WrapEOS) + else if String.unsafe_get str i = ' ' then (i, WrapSpace) + else if String.unsafe_get str i = '\n' then (i, WrapNL) + else _wrap_find_next_break (i+1) len str + +and output_spaces chan n = for i = 0 to n-1 do output_char chan ' ' done + +let (|>) x f = f x + +(* Drop elements from a list while a predicate is true. *) +let rec dropwhile f = function + | [] -> [] + | x :: xs when f x -> dropwhile f xs + | xs -> xs + +(* Take elements from a list while a predicate is true. *) +let rec takewhile f = function + | x :: xs when f x -> x :: takewhile f xs + | _ -> [] + +let rec filter_map f = function + | [] -> [] + | x :: xs -> + match f x with + | Some y -> y :: filter_map f xs + | None -> filter_map f xs + +let rec find_map f = function + | [] -> raise Not_found + | x :: xs -> + match f x with + | Some y -> y + | None -> find_map f xs + +let iteri f xs = + let rec loop i = function + | [] -> () + | x :: xs -> f i x; loop (i+1) xs + in + loop 0 xs + +let rec mapi i f = + function + | [] -> [] + | a::l -> + let r = f i a in + r :: mapi (i + 1) f l +let mapi f l = mapi 0 f l + +let rec combine3 xs ys zs = + match xs, ys, zs with + | [], [], [] -> [] + | x::xs, y::ys, z::zs -> (x, y, z) :: combine3 xs ys zs + | _ -> invalid_arg "combine3" + +let rec assoc ?(cmp = compare) ~default x = function + | [] -> default + | (y, y') :: _ when cmp x y = 0 -> y' + | _ :: ys -> assoc ~cmp ~default x ys + +let uniq ?(cmp = Pervasives.compare) xs = + let rec loop acc = function + | [] -> acc + | [x] -> x :: acc + | x :: (y :: _ as xs) when cmp x y = 0 -> + loop acc xs + | x :: (y :: _ as xs) -> + loop (x :: acc) xs + in + List.rev (loop [] xs) + +let sort_uniq ?(cmp = Pervasives.compare) xs = + let xs = List.sort cmp xs in + let xs = uniq ~cmp xs in + xs + +let remove_duplicates xs = + let h = Hashtbl.create (List.length xs) in + let rec loop = function + | [] -> [] + | x :: xs when Hashtbl.mem h x -> xs + | x :: xs -> Hashtbl.add h x true; x :: loop xs + in + loop xs + +let push_back xsp x = xsp := !xsp @ [x] +let push_front x xsp = xsp := x :: !xsp +let pop_back xsp = + let x, xs = + match List.rev !xsp with + | x :: xs -> x, xs + | [] -> failwith "pop" in + xsp := List.rev xs; + x +let pop_front xsp = + let x, xs = + match !xsp with + | x :: xs -> x, xs + | [] -> failwith "shift" in + xsp := xs; + x + +let append xsp xs = xsp := !xsp @ xs +let prepend xs xsp = xsp := xs @ !xsp + +let unique = let i = ref 0 in fun () -> incr i; !i + +let may f = function + | None -> () + | Some x -> f x + +type ('a, 'b) maybe = Either of 'a | Or of 'b + +let protect ~f ~finally = + let r = + try Either (f ()) + with exn -> Or exn in + finally (); + match r with Either ret -> ret | Or exn -> raise exn + +let failwithf fs = ksprintf failwith fs + +exception Executable_not_found of string (* executable *) + +let which executable = + let paths = + try String.nsplit ":" (Sys.getenv "PATH") + with Not_found -> [] in + let paths = filter_map ( + fun p -> + let path = p // executable in + try Unix.access path [Unix.X_OK]; Some path + with Unix.Unix_error _ -> None + ) paths in + match paths with + | [] -> raise (Executable_not_found executable) + | x :: _ -> x + +(* Program name. *) +let prog = Filename.basename Sys.executable_name + +(* Stores the colours (--colours), quiet (--quiet), trace (-x) and + * verbose (-v) flags in a global variable. + *) +let colours = ref false +let set_colours () = colours := true +let colours () = !colours + +let quiet = ref false +let set_quiet () = quiet := true +let quiet () = !quiet + +let trace = ref false +let set_trace () = trace := true +let trace () = !trace + +let verbose = ref false +let set_verbose () = verbose := true +let verbose () = !verbose + +let read_whole_file path = + let buf = Buffer.create 16384 in + let chan = open_in path in + let maxlen = 16384 in + let b = Bytes.create maxlen in + let rec loop () = + let r = input chan b 0 maxlen in + if r > 0 then ( + Buffer.add_substring buf (Bytes.to_string b) 0 r; + loop () + ) + in + loop (); + close_in chan; + Buffer.contents buf + +(* Compare two version strings intelligently. *) +let rex_numbers = Str.regexp "^\\([0-9]+\\)\\(.*\\)$" +let rex_letters = Str.regexp_case_fold "^\\([a-z]+\\)\\(.*\\)$" + +let compare_version v1 v2 = + let rec split_version = function + | "" -> [] + | str -> + let first, rest = + if Str.string_match rex_numbers str 0 then ( + let n = Str.matched_group 1 str in + let rest = Str.matched_group 2 str in + let n = + try `Number (int_of_string n) + with Failure _ -> `String n in + n, rest + ) + else if Str.string_match rex_letters str 0 then + `String (Str.matched_group 1 str), Str.matched_group 2 str + else ( + let len = String.length str in + `Char str.[0], String.sub str 1 (len-1) + ) in + first :: split_version rest + in + compare (split_version v1) (split_version v2) + +(* Annoying LVM2 returns a differing UUID strings for different + * function calls (sometimes containing or not containing '-' + * characters), so we have to normalize each string before + * comparison. c.f. 'compare_pvuuids' in virt-filesystem. + *) +let compare_lvm2_uuids uuid1 uuid2 = + let n1 = String.length uuid1 and n2 = String.length uuid2 in + let rec loop i1 i2 = + if i1 = n1 && i2 = n2 then 0 (* matching *) + else if i1 >= n1 then 1 (* different lengths *) + else if i2 >= n2 then -1 + else if uuid1.[i1] = '-' then loop (i1+1) i2 (* ignore '-' characters *) + else if uuid2.[i2] = '-' then loop i1 (i2+1) + else ( + let c = compare uuid1.[i1] uuid2.[i2] in + if c <> 0 then c (* not matching *) + else loop (i1+1) (i2+1) + ) + in + loop 0 0 + +let stringify_args args = + let rec quote_args = function + | [] -> "" + | x :: xs -> " " ^ Filename.quote x ^ quote_args xs + in + match args with + | [] -> "" + | app :: xs -> app ^ quote_args xs + +(* Unlink a temporary file on exit. *) +let unlink_on_exit = + let files = ref [] in + let registered_handlers = ref false in + + let rec unlink_files () = + List.iter ( + fun file -> try Unix.unlink file with _ -> () + ) !files + and register_handlers () = + (* Unlink on exit. *) + at_exit unlink_files + in + + fun file -> + files := file :: !files; + if not !registered_handlers then ( + register_handlers (); + registered_handlers := true + ) + +let is_block_device file = + try (Unix.stat file).Unix.st_kind = Unix.S_BLK + with Unix.Unix_error _ -> false + +let is_char_device file = + try (Unix.stat file).Unix.st_kind = Unix.S_CHR + with Unix.Unix_error _ -> false + +(* Annoyingly Sys.is_directory throws an exception on failure + * (RHBZ#1022431). + *) +let is_directory path = + try Sys.is_directory path + with Sys_error _ -> false + +let absolute_path path = + if not (Filename.is_relative path) then path + else Sys.getcwd () // path + +let qemu_input_filename filename = + (* If the filename is something like "file:foo" then qemu-img will + * try to interpret that as "foo" in the file:/// protocol. To + * avoid that, if the path is relative prefix it with "./" since + * qemu-img won't try to interpret such a path. + *) + if String.length filename > 0 && filename.[0] <> '/' then + "./" ^ filename + else + filename + +let rec mkdir_p path permissions = + try Unix.mkdir path permissions + with + | Unix.Unix_error (Unix.EEXIST, _, _) -> () + | Unix.Unix_error (Unix.ENOENT, _, _) -> + (* A component in the path does not exist, so first try + * creating the parent directory, and then again the requested + * directory. *) + mkdir_p (Filename.dirname path) permissions; + Unix.mkdir path permissions + +let normalize_arch = function + | "i486" | "i586" | "i686" -> "i386" + | "amd64" -> "x86_64" + | "powerpc" -> "ppc" + | "powerpc64" -> "ppc64" + | "powerpc64le" -> "ppc64le" + | arch -> arch + +(* Are guest arch and host_cpu compatible, in terms of being able + * to run commands in the libguestfs appliance? + *) +let guest_arch_compatible guest_arch = + let own = normalize_arch Guestfs_config.host_cpu in + let guest_arch = normalize_arch guest_arch in + match own, guest_arch with + | x, y when x = y -> true + | "x86_64", "i386" -> true + | _ -> false + +(* Is the guest OS "Unix-like"? *) +let unix_like = function + | "hurd" + | "linux" + | "minix" -> true + | typ when String.is_suffix typ "bsd" -> true + | _ -> false + +(** Return the last part of a string, after the specified separator. *) +let last_part_of str sep = + try + let i = String.rindex str sep in + Some (String.sub str (i+1) (String.length str - (i+1))) + with Not_found -> None + +let read_first_line_from_file filename = + let chan = open_in filename in + let line = input_line chan in + close_in chan; + line + +let is_regular_file path = (* NB: follows symlinks. *) + try (Unix.stat path).Unix.st_kind = Unix.S_REG + with Unix.Unix_error _ -> false diff --git a/common/mlstdutils/std_utils.mli b/common/mlstdutils/std_utils.mli new file mode 100644 index 000000000..820673764 --- /dev/null +++ b/common/mlstdutils/std_utils.mli @@ -0,0 +1,338 @@ +(* Common utilities for OCaml tools in libguestfs. + * Copyright (C) 2010-2017 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. + *) + +module Char : sig + type t = char + val chr : int -> char + val code : char -> int + val compare: t -> t -> int + val escaped : char -> string + val unsafe_chr : int -> char + + val lowercase_ascii : char -> char + val uppercase_ascii : char -> char + + val isspace : char -> bool + (** Return true if char is a whitespace character. *) + val isdigit : char -> bool + (** Return true if the character is a digit [[0-9]]. *) + val isxdigit : char -> bool + (** Return true if the character is a hex digit [[0-9a-fA-F]]. *) + val isalpha : char -> bool + (** Return true if the character is a US ASCII 7 bit alphabetic. *) + val isalnum : char -> bool + (** Return true if the character is a US ASCII 7 bit alphanumeric. *) + + val hexdigit : char -> int + (** Return the value of a hex digit. If the char is not in + the set [[0-9a-fA-F]] then this returns [-1]. *) +end +(** Override the Char module from stdlib. *) + +module String : sig + type t = string + val compare: t -> t -> int + val concat : string -> string list -> string + val contains : string -> char -> bool + val contains_from : string -> int -> char -> bool + val copy : string -> string + val escaped : string -> string + val get : string -> int -> char + val index : string -> char -> int + val index_from : string -> int -> char -> int + val iter : (char -> unit) -> string -> unit + val length : string -> int + val make : int -> char -> string + val rcontains_from : string -> int -> char -> bool + val rindex : string -> char -> int + val rindex_from : string -> int -> char -> int + val sub : string -> int -> int -> string + val unsafe_get : string -> int -> char + + val map : (char -> char) -> string -> string + + val lowercase_ascii : string -> string + val uppercase_ascii : string -> string + val capitalize_ascii : string -> string + + val is_prefix : string -> string -> bool + (** [is_prefix str prefix] returns true if [prefix] is a prefix of [str]. *) + val is_suffix : string -> string -> bool + (** [is_suffix str suffix] returns true if [suffix] is a suffix of [str]. *) + val find : string -> string -> int + (** [find str sub] searches for [sub] as a substring of [str]. If + found it returns the index. If not found, it returns [-1]. *) + val replace : string -> string -> string -> string + (** [replace str s1 s2] replaces all instances of [s1] appearing in + [str] with [s2]. *) + val replace_char : string -> char -> char -> string + (** Replace character in string. *) + val nsplit : string -> string -> string list + (** [nsplit sep str] splits [str] into multiple strings at each + separator [sep]. *) + val split : string -> string -> string * string + (** [split sep str] splits [str] at the first occurrence of the + separator [sep], returning the part before and the part after. + If separator is not found, return the whole string and an + empty string. *) + val lines_split : string -> string list + (** [lines_split str] splits [str] into lines, keeping continuation + characters (i.e. [\] at the end of lines) into account. *) + val random8 : unit -> string + (** Return a string of 8 random printable characters. *) + val triml : ?test:(char -> bool) -> string -> string + (** Trim left. *) + val trimr : ?test:(char -> bool) -> string -> string + (** Trim right. *) + val trim : ?test:(char -> bool) -> string -> string + (** Trim left and right. *) + val count_chars : char -> string -> int + (** Count number of times the character occurs in string. *) + val explode : string -> char list + (** Explode a string into a list of characters. *) + val map_chars : (char -> 'a) -> string -> 'a list + (** Explode string, then map function over the characters. *) + val spaces : int -> string + (** [spaces n] creates a string of n spaces. *) +end +(** Override the String module from stdlib. *) + +val ( // ) : string -> string -> string +(** Concatenate directory and filename. *) + +val quote : string -> string +(** Shell-safe quoting of a string (alias for {!Filename.quote}). *) + +val subdirectory : string -> string -> string +(** [subdirectory parent path] returns subdirectory part of [path] relative + to the [parent]. If [path] and [parent] point to the same directory empty + string is returned. + + Note: path normalization on arguments is {b not} performed! + + If [parent] is not a path prefix of [path] the function raises + [Invalid_argument]. *) + +val ( +^ ) : int64 -> int64 -> int64 +val ( -^ ) : int64 -> int64 -> int64 +val ( *^ ) : int64 -> int64 -> int64 +val ( /^ ) : int64 -> int64 -> int64 +val ( &^ ) : int64 -> int64 -> int64 +val ( ~^ ) : int64 -> int64 +(** Various int64 operators. *) + +external identity : 'a -> 'a = "%identity" + +val roundup64 : int64 -> int64 -> int64 +(** [roundup64 i a] returns [i] rounded up to the next multiple of [a]. *) +val div_roundup64 : int64 -> int64 -> int64 +(** [div_roundup64 i a] returns [i] rounded up to the next multiple of [a], + with the result divided by [a]. *) +val int_of_le32 : string -> int64 +(** Unpack a 4 byte string as a little endian 32 bit integer. *) +val le32_of_int : int64 -> string +(** Pack a 32 bit integer a 4 byte string stored little endian. *) + +val wrap : ?chan:out_channel -> ?indent:int -> string -> unit +(** Wrap text. *) + +val output_spaces : out_channel -> int -> unit +(** Write [n] spaces to [out_channel]. *) + +val (|>) : 'a -> ('a -> 'b) -> 'b +(** Added in OCaml 4.01, we can remove our definition when we + can assume this minimum version of OCaml. *) + +val dropwhile : ('a -> bool) -> 'a list -> 'a list +(** [dropwhile f xs] drops leading elements from [xs] until + [f] returns false. *) +val takewhile : ('a -> bool) -> 'a list -> 'a list +(** [takewhile f xs] takes leading elements from [xs] until + [f] returns false. + + For any list [xs] and function [f], + [xs = takewhile f xs @ dropwhile f xs] *) +val filter_map : ('a -> 'b option) -> 'a list -> 'b list +(** [filter_map f xs] applies [f] to each element of [xs]. If + [f x] returns [Some y] then [y] is added to the returned list. *) +val find_map : ('a -> 'b option) -> 'a list -> 'b +(** [find_map f xs] applies [f] to each element of [xs] until + [f x] returns [Some y]. It returns [y]. If we exhaust the + list then this raises [Not_found]. *) +val iteri : (int -> 'a -> 'b) -> 'a list -> unit +(** [iteri f xs] calls [f i x] for each element, with [i] counting from [0]. *) +val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list +(** [mapi f xs] calls [f i x] for each element, with [i] counting from [0], + forming the return values from [f] into another list. *) + +val combine3 : 'a list -> 'b list -> 'c list -> ('a * 'b * 'c) list +(** Like {!List.combine} but for triples. All lists must be the same length. *) + +val assoc : ?cmp:('a -> 'a -> int) -> default:'b -> 'a -> ('a * 'b) list -> 'b +(** Like {!List.assoc} but with a user-defined comparison function, and + instead of raising [Not_found], it returns the [~default] value. *) + +val uniq : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list +(** Uniquify a list (the list must be sorted first). *) + +val sort_uniq : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list +(** Sort and uniquify a list. *) + +val remove_duplicates : 'a list -> 'a list +(** Remove duplicates from an unsorted list; useful when the order + of the elements matter. + + Please use [sort_uniq] when the order does not matter. *) + +val push_back : 'a list ref -> 'a -> unit +val push_front : 'a -> 'a list ref -> unit +val pop_back : 'a list ref -> 'a +val pop_front : 'a list ref -> 'a +(** Imperative list manipulation functions, similar to C++ STL + functions with the same names. (Although the names are similar, + the computational complexity of the functions is quite different.) + + These operate on list references, and each function modifies the + list reference that is passed to it. + + [push_back xsp x] appends the element [x] to the end of the list + [xsp]. This function is not tail-recursive. + + [push_front x xsp] prepends the element [x] to the head of the + list [xsp]. (The arguments are reversed compared to the same Perl + function, but OCaml is type safe so that's OK.) + + [pop_back xsp] removes the last element of the list [xsp] and + returns it. The list is modified to become the list minus the + final element. If a zero-length list is passed in, this raises + [Failure "pop_back"]. This function is not tail-recursive. + + [pop_front xsp] removes the head element of the list [xsp] and + returns it. The list is modified to become the tail of the list. + If a zero-length list is passed in, this raises [Failure + "pop_front"]. *) + +val append : 'a list ref -> 'a list -> unit +val prepend : 'a list -> 'a list ref -> unit +(** More imperative list manipulation functions. + + [append] is like {!push_back} above, except it appends a list to + the list reference. This function is not tail-recursive. + + [prepend] is like {!push_front} above, except it prepends a list + to the list reference. *) + +val unique : unit -> int +(** Returns a unique number each time called. *) + +val may : ('a -> unit) -> 'a option -> unit +(** [may f (Some x)] runs [f x]. [may f None] does nothing. *) + +type ('a, 'b) maybe = Either of 'a | Or of 'b +(** Like the Haskell [Either] type. *) + +val protect : f:(unit -> 'a) -> finally:(unit -> unit) -> 'a +(** Execute [~f] and afterwards execute [~finally]. + + If [~f] throws an exception then [~finally] is run and the + original exception from [~f] is re-raised. + + If [~finally] throws an exception, then the original exception + is lost. (NB: Janestreet core {!Exn.protectx}, on which this + function is modelled, doesn't throw away the exception in this + case, but requires a lot more work by the caller. Perhaps we + will change this in future.) *) + +val failwithf : ('a, unit, string, 'b) format4 -> 'a +(** Like [failwith] but supports printf-like arguments. *) + +exception Executable_not_found of string (* executable *) +(** Exception thrown by [which] when the specified executable is not found + in [$PATH]. *) + +val which : string -> string +(** Return the full path of the specified executable from [$PATH]. + + Throw [Executable_not_found] if not available. *) + +val prog : string +(** The program name (derived from {!Sys.executable_name}). *) + +val set_colours : unit -> unit +val colours : unit -> bool +val set_quiet : unit -> unit +val quiet : unit -> bool +val set_trace : unit -> unit +val trace : unit -> bool +val set_verbose : unit -> unit +val verbose : unit -> bool +(** Stores the colours ([--colours]), quiet ([--quiet]), trace ([-x]) + and verbose ([-v]) flags in global variables. *) + +val read_whole_file : string -> string +(** Read in the whole file as a string. *) + +val compare_version : string -> string -> int +(** Compare two version strings. *) + +val compare_lvm2_uuids : string -> string -> int +(** Compare two LVM2 UUIDs, ignoring '-' characters. *) + +val stringify_args : string list -> string +(** Create a "pretty-print" representation of a program invocation + (i.e. executable and its arguments). *) + +val unlink_on_exit : string -> unit +(** Unlink a temporary file on exit. *) + +val is_block_device : string -> bool +val is_char_device : string -> bool +val is_directory : string -> bool +(** These don't throw exceptions, unlike the [Sys] functions. *) + +val absolute_path : string -> string +(** Convert any path to an absolute path. *) + +val qemu_input_filename : string -> string +(** Sanitizes a filename for passing it safely to qemu/qemu-img. *) + +val mkdir_p : string -> int -> unit +(** Creates a directory, and its parents if missing. *) + +val normalize_arch : string -> string +(** Normalize the architecture name, i.e. maps it into a defined + identifier for it -- e.g. i386, i486, i586, and i686 are + normalized as i386. *) + +val guest_arch_compatible : string -> bool +(** Are guest arch and host_cpu compatible, in terms of being able + to run commands in the libguestfs appliance? *) + +val unix_like : string -> bool +(** Is the guest OS "Unix-like"? Call this with the result of + {!Guestfs.inspect_get_type}. *) + +val last_part_of : string -> char -> string option +(** Return the last part of a string, after the specified separator. *) + +val read_first_line_from_file : string -> string +(** Read only the first line (i.e. until the first newline character) + of a file. *) + +val is_regular_file : string -> bool +(** Checks whether the file is a regular file. *) diff --git a/common/mlstdutils/std_utils_tests.ml b/common/mlstdutils/std_utils_tests.ml new file mode 100644 index 000000000..94fc52d63 --- /dev/null +++ b/common/mlstdutils/std_utils_tests.ml @@ -0,0 +1,95 @@ +(* Common utilities for OCaml tools in libguestfs. + * Copyright (C) 2011-2017 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. + *) + +(* This file tests the Common_utils module. *) + +open OUnit2 +open Std_utils + +(* Utils. *) +let assert_equal_string = assert_equal ~printer:(fun x -> x) +let assert_equal_int = assert_equal ~printer:(fun x -> string_of_int x) +let assert_equal_int64 = assert_equal ~printer:(fun x -> Int64.to_string x) +let assert_equal_stringlist = assert_equal ~printer:(fun x -> "(" ^ (String.escaped (String.concat "," x)) ^ ")") + +let test_subdirectory ctx = + assert_equal_string "" (subdirectory "/foo" "/foo"); + assert_equal_string "" (subdirectory "/foo" "/foo/"); + assert_equal_string "bar" (subdirectory "/foo" "/foo/bar"); + assert_equal_string "bar/baz" (subdirectory "/foo" "/foo/bar/baz") + +(* Test Common_utils.int_of_le32 and Common_utils.le32_of_int. *) +let test_le32 ctx = + assert_equal_int64 0x20406080L (int_of_le32 "\x80\x60\x40\x20"); + assert_equal_string "\x80\x60\x40\x20" (le32_of_int 0x20406080L) + +(* Test Common_utils.String.is_prefix. *) +let test_string_is_prefix ctx = + assert_bool "String.is_prefix,," (String.is_prefix "" ""); + assert_bool "String.is_prefix,foo," (String.is_prefix "foo" ""); + assert_bool "String.is_prefix,foo,foo" (String.is_prefix "foo" "foo"); + assert_bool "String.is_prefix,foo123,foo" (String.is_prefix "foo123" "foo"); + assert_bool "not (String.is_prefix,,foo" (not (String.is_prefix "" "foo")) + +(* Test Common_utils.String.is_suffix. *) +let test_string_is_suffix ctx = + assert_bool "String.is_suffix,," (String.is_suffix "" ""); + assert_bool "String.is_suffix,foo," (String.is_suffix "foo" ""); + assert_bool "String.is_suffix,foo,foo" (String.is_suffix "foo" "foo"); + assert_bool "String.is_suffix,123foo,foo" (String.is_suffix "123foo" "foo"); + assert_bool "not String.is_suffix,,foo" (not (String.is_suffix "" "foo")) + +(* Test Common_utils.String.find. *) +let test_string_find ctx = + assert_equal_int 0 (String.find "" ""); + assert_equal_int 0 (String.find "foo" ""); + assert_equal_int 1 (String.find "foo" "o"); + assert_equal_int 3 (String.find "foobar" "bar"); + assert_equal_int (-1) (String.find "" "baz"); + assert_equal_int (-1) (String.find "foobar" "baz") + +(* Test Common_utils.String.lines_split. *) +let test_string_lines_split ctx = + assert_equal_stringlist [""] (String.lines_split ""); + assert_equal_stringlist ["A"] (String.lines_split "A"); + assert_equal_stringlist ["A"; ""] (String.lines_split "A\n"); + assert_equal_stringlist ["A"; "B"] (String.lines_split "A\nB"); + assert_equal_stringlist ["A"; "B"; "C"] (String.lines_split "A\nB\nC"); + assert_equal_stringlist ["A"; "B"; "C"; "D"] (String.lines_split "A\nB\nC\nD"); + assert_equal_stringlist ["A\n"] (String.lines_split "A\\"); + assert_equal_stringlist ["A\nB"] (String.lines_split "A\\\nB"); + assert_equal_stringlist ["A"; "B\nC"] (String.lines_split "A\nB\\\nC"); + assert_equal_stringlist ["A"; "B\nC"; "D"] (String.lines_split "A\nB\\\nC\nD"); + assert_equal_stringlist ["A"; "B\nC\nD"] (String.lines_split "A\nB\\\nC\\\nD"); + assert_equal_stringlist ["A\nB"; ""] (String.lines_split "A\\\nB\n"); + assert_equal_stringlist ["A\nB\n"] (String.lines_split "A\\\nB\\\n") + +(* Suites declaration. *) +let suite = + "mllib Common_utils" >::: + [ + "subdirectory" >:: test_subdirectory; + "numeric.le32" >:: test_le32; + "strings.is_prefix" >:: test_string_is_prefix; + "strings.is_suffix" >:: test_string_is_suffix; + "strings.find" >:: test_string_find; + "strings.lines_split" >:: test_string_lines_split; + ] + +let () = + run_test_tt_main suite diff --git a/mllib/stringMap.ml b/common/mlstdutils/stringMap.ml similarity index 100% rename from mllib/stringMap.ml rename to common/mlstdutils/stringMap.ml diff --git a/mllib/stringMap.mli b/common/mlstdutils/stringMap.mli similarity index 100% rename from mllib/stringMap.mli rename to common/mlstdutils/stringMap.mli diff --git a/configure.ac b/configure.ac index 7d0f0a1dd..eba149241 100644 --- a/configure.ac +++ b/configure.ac @@ -186,6 +186,8 @@ AC_CONFIG_FILES([Makefile common/edit/Makefile common/miniexpect/Makefile common/mlprogress/Makefile + common/mlstdutils/Makefile + common/mlstdutils/guestfs_config.ml common/mlvisit/Makefile common/mlxml/Makefile common/options/Makefile @@ -230,7 +232,6 @@ AC_CONFIG_FILES([Makefile lua/examples/Makefile make-fs/Makefile mllib/Makefile - mllib/guestfs_config.ml ocaml/META ocaml/Makefile ocaml/examples/Makefile diff --git a/customize/Makefile.am b/customize/Makefile.am index 07398b2e8..674134b70 100644 --- a/customize/Makefile.am +++ b/customize/Makefile.am @@ -123,6 +123,7 @@ OCAMLPACKAGES = \ -I $(top_builddir)/lib/.libs \ -I $(top_builddir)/gnulib/lib/.libs \ -I $(top_builddir)/ocaml \ + -I $(top_builddir)/common/mlstdutils \ -I $(top_builddir)/mllib \ -I $(builddir) if HAVE_OCAML_PKG_GETTEXT @@ -149,7 +150,12 @@ else CUSTOMIZE_THEOBJECTS = $(CUSTOMIZE_XOBJECTS) endif -OCAMLLINKFLAGS = mlguestfs.$(MLARCHIVE) mllib.$(MLARCHIVE) customize.$(MLARCHIVE) $(LINK_CUSTOM_OCAMLC_ONLY) +OCAMLLINKFLAGS = \ + mlstdutils.$(MLARCHIVE) \ + mlguestfs.$(MLARCHIVE) \ + mllib.$(MLARCHIVE) \ + customize.$(MLARCHIVE) \ + $(LINK_CUSTOM_OCAMLC_ONLY) OCAMLCLIBS = \ -lutils \ diff --git a/customize/SELinux_relabel.ml b/customize/SELinux_relabel.ml index 11999299b..ab373b33a 100644 --- a/customize/SELinux_relabel.ml +++ b/customize/SELinux_relabel.ml @@ -16,8 +16,9 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Printf diff --git a/customize/append_line.ml b/customize/append_line.ml index e967b4201..405080617 100644 --- a/customize/append_line.ml +++ b/customize/append_line.ml @@ -16,6 +16,7 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) +open Std_utils open Common_utils open Common_gettext.Gettext diff --git a/customize/customize_main.ml b/customize/customize_main.ml index 5b4641237..55ec3cb78 100644 --- a/customize/customize_main.ml +++ b/customize/customize_main.ml @@ -16,8 +16,9 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Getopt.OptionName open Customize_cmdline diff --git a/customize/customize_run.ml b/customize/customize_run.ml index f71ae3535..5564684b4 100644 --- a/customize/customize_run.ml +++ b/customize/customize_run.ml @@ -19,8 +19,9 @@ open Unix open Printf -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Customize_cmdline open Password diff --git a/customize/firstboot.ml b/customize/firstboot.ml index 9208daa0a..41aa52dac 100644 --- a/customize/firstboot.ml +++ b/customize/firstboot.ml @@ -18,6 +18,7 @@ open Printf +open Std_utils open Common_utils open Common_gettext.Gettext diff --git a/customize/hostname.ml b/customize/hostname.ml index 23c149402..b49db8714 100644 --- a/customize/hostname.ml +++ b/customize/hostname.ml @@ -16,6 +16,7 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) +open Std_utils open Common_utils open Printf diff --git a/customize/password.ml b/customize/password.ml index 4ab5a14d1..d26b94865 100644 --- a/customize/password.ml +++ b/customize/password.ml @@ -16,8 +16,9 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Printf diff --git a/customize/perl_edit.ml b/customize/perl_edit.ml index 5cd250b49..bb44ea062 100644 --- a/customize/perl_edit.ml +++ b/customize/perl_edit.ml @@ -16,6 +16,7 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) +open Std_utils open Common_utils external c_edit_file : verbose:bool -> Guestfs.t -> int64 -> string -> string -> unit diff --git a/customize/ssh_key.ml b/customize/ssh_key.ml index 4302a8e92..185536d1d 100644 --- a/customize/ssh_key.ml +++ b/customize/ssh_key.ml @@ -16,13 +16,14 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -open Common_gettext.Gettext -open Common_utils - open Printf open Sys open Unix +open Std_utils +open Common_utils +open Common_gettext.Gettext + module G = Guestfs type ssh_key_selector = diff --git a/customize/subscription_manager.ml b/customize/subscription_manager.ml index a23efe546..56ba28ab9 100644 --- a/customize/subscription_manager.ml +++ b/customize/subscription_manager.ml @@ -16,8 +16,9 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext type sm_credentials = { sm_username : string; diff --git a/dib/Makefile.am b/dib/Makefile.am index 6780ee249..b10fa94c9 100644 --- a/dib/Makefile.am +++ b/dib/Makefile.am @@ -79,6 +79,7 @@ OCAMLPACKAGES = \ -I $(top_builddir)/lib/.libs \ -I $(top_builddir)/gnulib/lib/.libs \ -I $(top_builddir)/ocaml \ + -I $(top_builddir)/common/mlstdutils \ -I $(top_builddir)/mllib if HAVE_OCAML_PKG_GETTEXT OCAMLPACKAGES += -package gettext-stub @@ -99,10 +100,15 @@ else OBJECTS = $(XOBJECTS) endif -OCAMLLINKFLAGS = mlguestfs.$(MLARCHIVE) mllib.$(MLARCHIVE) $(LINK_CUSTOM_OCAMLC_ONLY) +OCAMLLINKFLAGS = \ + mlstdutils.$(MLARCHIVE) \ + mlguestfs.$(MLARCHIVE) \ + mllib.$(MLARCHIVE) \ + $(LINK_CUSTOM_OCAMLC_ONLY) virt_dib_DEPENDENCIES = \ $(OBJECTS) \ + ../common/mlstdutils/mlstdutils.$(MLARCHIVE) \ ../mllib/mllib.$(MLARCHIVE) \ $(top_srcdir)/ocaml-link.sh virt_dib_LINK = \ @@ -138,7 +144,7 @@ depend: .depend .depend: $(wildcard $(abs_srcdir)/*.mli) $(wildcard $(abs_srcdir)/*.ml) rm -f $@ $@-t - $(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/mllib $^ | \ + $(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/common/mlstdutils -I $(abs_top_builddir)/mllib $^ | \ $(SED) 's/ *$$//' | \ $(SED) -e :a -e '/ *\\$$/N; s/ *\\\n */ /; ta' | \ $(SED) -e 's,$(abs_srcdir)/,$(builddir)/,g' | \ diff --git a/dib/cmdline.ml b/dib/cmdline.ml index 67194704e..549f01546 100644 --- a/dib/cmdline.ml +++ b/dib/cmdline.ml @@ -18,8 +18,9 @@ (* Command line argument parsing. *) -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Getopt.OptionName open Utils diff --git a/dib/dib.ml b/dib/dib.ml index 8d078aabb..78b109da8 100644 --- a/dib/dib.ml +++ b/dib/dib.ml @@ -16,9 +16,10 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -open Common_gettext.Gettext +open Std_utils open Common_utils open Unix_utils +open Common_gettext.Gettext open Cmdline open Utils diff --git a/dib/elements.ml b/dib/elements.ml index 4c2875ae1..d237eeb7f 100644 --- a/dib/elements.ml +++ b/dib/elements.ml @@ -18,8 +18,9 @@ (* Parsing and handling of elements. *) -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Utils diff --git a/dib/output_format.ml b/dib/output_format.ml index 851cefc43..6499ee259 100644 --- a/dib/output_format.ml +++ b/dib/output_format.ml @@ -16,6 +16,7 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) +open Std_utils open Common_utils open Common_gettext.Gettext open Getopt.OptionName diff --git a/dib/output_format_qcow2.ml b/dib/output_format_qcow2.ml index afb564ce7..a32b2a4f9 100644 --- a/dib/output_format_qcow2.ml +++ b/dib/output_format_qcow2.ml @@ -16,6 +16,7 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) +open Std_utils open Common_utils open Common_gettext.Gettext open Getopt.OptionName diff --git a/dib/utils.ml b/dib/utils.ml index afa2ec944..8b6bb1576 100644 --- a/dib/utils.ml +++ b/dib/utils.ml @@ -16,8 +16,9 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Printf diff --git a/docs/C_SOURCE_FILES b/docs/C_SOURCE_FILES index f6ac73047..71c17603f 100644 --- a/docs/C_SOURCE_FILES +++ b/docs/C_SOURCE_FILES @@ -16,6 +16,7 @@ common/edit/file-edit.h common/miniexpect/miniexpect.c common/miniexpect/miniexpect.h common/mlprogress/progress-c.c +common/mlstdutils/dummy.c common/mlvisit/dummy.c common/mlvisit/visit-c.c common/mlxml/xml-c.c diff --git a/docs/guestfs-hacking.pod b/docs/guestfs-hacking.pod index 1ff496381..beb44d2dc 100644 --- a/docs/guestfs-hacking.pod +++ b/docs/guestfs-hacking.pod @@ -100,6 +100,10 @@ A copy of the miniexpect library from L<http://git.annexia.org/?p=miniexpect.git;a=summary>;. This is used in virt-p2v. +=item F<common/mlstdutils> + +A library of pure OCaml utility functions used in many places. + =item F<common/mlprogress> OCaml bindings for the progress bar functions (see F<common/progress>). diff --git a/generator/GObject.ml b/generator/GObject.ml index bb95b170c..8fa17c219 100644 --- a/generator/GObject.ml +++ b/generator/GObject.ml @@ -22,7 +22,7 @@ open Printf -open Common_utils +open Std_utils open Actions open Docstrings open Events diff --git a/generator/Makefile.am b/generator/Makefile.am index 81b49cab1..401029d34 100644 --- a/generator/Makefile.am +++ b/generator/Makefile.am @@ -53,8 +53,6 @@ sources = \ c.mli \ checks.ml \ checks.mli \ - common_utils.ml \ - common_utils.mli \ csharp.ml \ csharp.mli \ customize.ml \ @@ -77,7 +75,6 @@ sources = \ GObject.mli \ golang.ml \ golang.mli \ - guestfs_config.ml \ haskell.ml \ haskell.mli \ java.ml \ @@ -118,8 +115,8 @@ sources = \ # In build dependency order. objects = \ $(OCAML_GENERATOR_BYTES_COMPAT_CMO) \ - guestfs_config.cmo \ - common_utils.cmo \ + ../common/mlstdutils/guestfs_config.cmo \ + ../common/mlstdutils/std_utils.cmo \ types.cmo \ utils.cmo \ proc_nr.cmo \ @@ -170,7 +167,12 @@ objects = \ EXTRA_DIST = $(sources) files-generated.txt -OCAMLPACKAGES = -package unix,str -I $(srcdir) -I . +OCAMLPACKAGES = \ + -package unix,str \ + -I $(srcdir) \ + -I . \ + -I $(top_srcdir)/common/mlstdutils \ + -I $(top_builddir)/common/mlstdutils OCAMLFLAGS = $(OCAML_FLAGS) $(OCAML_WARN_ERROR) noinst_PROGRAM = generator @@ -183,9 +185,9 @@ generator: $(objects) # Dependencies. depend: .depend -.depend: $(wildcard $(abs_srcdir)/*.mli) $(wildcard $(abs_srcdir)/*.ml) common_utils.ml common_utils.mli guestfs_config.ml +.depend: $(wildcard $(abs_srcdir)/*.mli) $(wildcard $(abs_srcdir)/*.ml) $(wildcard $(abs_srcdir)/common/mlstdutils/*.mli) $(wildcard $(abs_srcdir)/common/mlstdutils/*.ml) rm -f $@ $@-t - $(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) $^ | \ + $(OCAMLFIND) ocamldep -I ../common/mlstdutils -I $(abs_srcdir) $^ | \ $(SED) 's/ *$$//' | \ $(SED) -e :a -e '/ *\\$$/N; s/ *\\\n */ /; ta' | \ $(SED) -e 's,$(abs_srcdir)/,$(builddir)/,g' | \ @@ -224,22 +226,6 @@ stamp-generator: generator cd $(top_srcdir) && $(abs_builddir)/generator touch $@ -# We share common_utils.ml{,i} with the mllib directory. However we -# have to remove functions which depend on any modules which are not -# part of the OCaml stdlib. -common_utils.ml: $(top_srcdir)/mllib/common_utils.ml - rm -f $@ $@-t - echo '(* This file is generated from mllib/common_utils.ml *)' > $@-t - sed -n '/^(\*<stdlib>\*)$$/,/^(\*<\/stdlib>\*)$$/p' $< >> $@-t - mv $@-t $@ -common_utils.mli: $(top_srcdir)/mllib/common_utils.mli - rm -f $@ $@-t - echo '(* This file is generated from mllib/common_utils.mli *)' > $@-t - sed -n '/^(\*<stdlib>\*)$$/,/^(\*<\/stdlib>\*)$$/p' $< >> $@-t - mv $@-t $@ -guestfs_config.ml: ../mllib/guestfs_config.ml - cp $< $@ - CLEANFILES += $(noinst_DATA) $(noinst_PROGRAM) DISTCLEANFILES += .pod2text.data.version.2 diff --git a/generator/OCaml.ml b/generator/OCaml.ml index 955da6f09..f6a4292b9 100644 --- a/generator/OCaml.ml +++ b/generator/OCaml.ml @@ -20,7 +20,7 @@ open Printf -open Common_utils +open Std_utils open Types open Utils open Pr diff --git a/generator/UEFI.ml b/generator/UEFI.ml index 95797aad9..5c5e02bab 100644 --- a/generator/UEFI.ml +++ b/generator/UEFI.ml @@ -18,7 +18,7 @@ (* Please read generator/README first. *) -open Common_utils +open Std_utils open Utils open Pr open Docstrings diff --git a/generator/XDR.ml b/generator/XDR.ml index 2d799929b..4b0a552d1 100644 --- a/generator/XDR.ml +++ b/generator/XDR.ml @@ -20,7 +20,7 @@ open Printf -open Common_utils +open Std_utils open Types open Utils open Pr diff --git a/generator/actions.ml b/generator/actions.ml index 2722f3dcd..a9b3b5906 100644 --- a/generator/actions.ml +++ b/generator/actions.ml @@ -18,7 +18,7 @@ (* Please read generator/README first. *) -open Common_utils +open Std_utils open Types open Utils diff --git a/generator/authors.ml b/generator/authors.ml index d4547bdb1..ca5242983 100644 --- a/generator/authors.ml +++ b/generator/authors.ml @@ -18,7 +18,7 @@ (* Please read generator/README first. *) -open Common_utils +open Std_utils open Utils open Pr open Docstrings diff --git a/generator/bindtests.ml b/generator/bindtests.ml index c3caebfce..d225146c0 100644 --- a/generator/bindtests.ml +++ b/generator/bindtests.ml @@ -20,7 +20,7 @@ open Printf -open Common_utils +open Std_utils open Types open Utils open Pr diff --git a/generator/c.ml b/generator/c.ml index 1f099a221..27bf1ebf9 100644 --- a/generator/c.ml +++ b/generator/c.ml @@ -20,7 +20,7 @@ open Printf -open Common_utils +open Std_utils open Types open Utils open Pr diff --git a/generator/checks.ml b/generator/checks.ml index 881069489..be7b272a3 100644 --- a/generator/checks.ml +++ b/generator/checks.ml @@ -18,7 +18,7 @@ (* Please read generator/README first. *) -open Common_utils +open Std_utils open Types open Utils open Actions diff --git a/generator/csharp.ml b/generator/csharp.ml index 6a280011a..0eab21f0d 100644 --- a/generator/csharp.ml +++ b/generator/csharp.ml @@ -20,7 +20,7 @@ open Printf -open Common_utils +open Std_utils open Types open Utils open Pr diff --git a/generator/customize.ml b/generator/customize.ml index b158eb5d9..381ed0627 100644 --- a/generator/customize.ml +++ b/generator/customize.ml @@ -20,7 +20,7 @@ open Printf -open Common_utils +open Std_utils open Docstrings open Pr @@ -623,6 +623,7 @@ and generate_customize_cmdline_ml () = open Printf +open Std_utils open Common_utils open Common_gettext.Gettext open Getopt.OptionName diff --git a/generator/daemon.ml b/generator/daemon.ml index 84686973c..0300dc54b 100644 --- a/generator/daemon.ml +++ b/generator/daemon.ml @@ -20,7 +20,7 @@ open Printf -open Common_utils +open Std_utils open Types open Utils open Pr diff --git a/generator/docstrings.ml b/generator/docstrings.ml index 2ce595dae..696f1c52a 100644 --- a/generator/docstrings.ml +++ b/generator/docstrings.ml @@ -21,7 +21,7 @@ open Unix open Printf -open Common_utils +open Std_utils open Types open Utils open Pr diff --git a/generator/erlang.ml b/generator/erlang.ml index 602380966..03cca3368 100644 --- a/generator/erlang.ml +++ b/generator/erlang.ml @@ -20,7 +20,7 @@ open Printf -open Common_utils +open Std_utils open Types open Utils open Pr diff --git a/generator/errnostring.ml b/generator/errnostring.ml index b3d718815..e5f4c69f8 100644 --- a/generator/errnostring.ml +++ b/generator/errnostring.ml @@ -20,7 +20,7 @@ open Printf -open Common_utils +open Std_utils open Types open Utils open Pr diff --git a/generator/events.ml b/generator/events.ml index 7188e1203..f3b682a5a 100644 --- a/generator/events.ml +++ b/generator/events.ml @@ -18,7 +18,7 @@ (* Please read generator/README first. *) -open Common_utils +open Std_utils open Utils (* NB: DO NOT REORDER THESE, as doing so will change the ABI. Only diff --git a/generator/fish.ml b/generator/fish.ml index 45289132f..3d99c9081 100644 --- a/generator/fish.ml +++ b/generator/fish.ml @@ -20,7 +20,7 @@ open Printf -open Common_utils +open Std_utils open Types open Utils open Pr diff --git a/generator/golang.ml b/generator/golang.ml index f32ccf2c1..67f360839 100644 --- a/generator/golang.ml +++ b/generator/golang.ml @@ -20,7 +20,7 @@ open Printf -open Common_utils +open Std_utils open Types open Utils open Pr diff --git a/generator/haskell.ml b/generator/haskell.ml index 592d817fa..ec3f311df 100644 --- a/generator/haskell.ml +++ b/generator/haskell.ml @@ -20,7 +20,7 @@ open Printf -open Common_utils +open Std_utils open Types open Utils open Pr diff --git a/generator/java.ml b/generator/java.ml index c44e669a0..7c3212a49 100644 --- a/generator/java.ml +++ b/generator/java.ml @@ -20,7 +20,7 @@ open Printf -open Common_utils +open Std_utils open Types open Utils open Pr diff --git a/generator/lua.ml b/generator/lua.ml index c4ab4cc47..b40c51753 100644 --- a/generator/lua.ml +++ b/generator/lua.ml @@ -20,7 +20,7 @@ open Printf -open Common_utils +open Std_utils open Types open Utils open Pr diff --git a/generator/main.ml b/generator/main.ml index d4316c085..0e1c01f74 100644 --- a/generator/main.ml +++ b/generator/main.ml @@ -21,7 +21,7 @@ open Unix open Printf -open Common_utils +open Std_utils open Pr open Actions open Structs diff --git a/generator/optgroups.ml b/generator/optgroups.ml index e9a37e19c..4b9b66f77 100644 --- a/generator/optgroups.ml +++ b/generator/optgroups.ml @@ -18,7 +18,7 @@ (* Please read generator/README first. *) -open Common_utils +open Std_utils open Types open Utils open Actions diff --git a/generator/perl.ml b/generator/perl.ml index bf2dc4a81..8e3dad75e 100644 --- a/generator/perl.ml +++ b/generator/perl.ml @@ -20,7 +20,7 @@ open Printf -open Common_utils +open Std_utils open Types open Utils open Pr diff --git a/generator/php.ml b/generator/php.ml index 48cd89fdc..0721e431a 100644 --- a/generator/php.ml +++ b/generator/php.ml @@ -20,7 +20,7 @@ open Printf -open Common_utils +open Std_utils open Types open Utils open Pr diff --git a/generator/pr.ml b/generator/pr.ml index e8b32b67d..0c56f3e67 100644 --- a/generator/pr.ml +++ b/generator/pr.ml @@ -21,7 +21,7 @@ open Unix open Printf -open Common_utils +open Std_utils open Utils (* Output channel, 'pr' prints to this. *) diff --git a/generator/python.ml b/generator/python.ml index 4cae24757..c6c237241 100644 --- a/generator/python.ml +++ b/generator/python.ml @@ -20,7 +20,7 @@ open Printf -open Common_utils +open Std_utils open Types open Utils open Pr diff --git a/generator/ruby.ml b/generator/ruby.ml index 4d2ebbf0d..825cab32a 100644 --- a/generator/ruby.ml +++ b/generator/ruby.ml @@ -20,7 +20,7 @@ open Printf -open Common_utils +open Std_utils open Types open Utils open Pr diff --git a/generator/structs.ml b/generator/structs.ml index 834fa9c54..57975b564 100644 --- a/generator/structs.ml +++ b/generator/structs.ml @@ -18,7 +18,7 @@ (* Please read generator/README first. *) -open Common_utils +open Std_utils open Types open Utils diff --git a/generator/tests_c_api.ml b/generator/tests_c_api.ml index f9f14f6dc..a680521f4 100644 --- a/generator/tests_c_api.ml +++ b/generator/tests_c_api.ml @@ -20,7 +20,7 @@ open Printf -open Common_utils +open Std_utils open Types open Utils open Pr diff --git a/generator/utils.ml b/generator/utils.ml index a745a02b7..b818a0b3c 100644 --- a/generator/utils.ml +++ b/generator/utils.ml @@ -23,7 +23,7 @@ * makes this a bit harder than it should be. *) -open Common_utils +open Std_utils open Unix open Printf diff --git a/get-kernel/Makefile.am b/get-kernel/Makefile.am index bda3a8db1..c6454d7a4 100644 --- a/get-kernel/Makefile.am +++ b/get-kernel/Makefile.am @@ -63,6 +63,7 @@ OCAMLPACKAGES = \ -I $(top_builddir)/lib/.libs \ -I $(top_builddir)/gnulib/lib/.libs \ -I $(top_builddir)/ocaml \ + -I $(top_builddir)/common/mlstdutils \ -I $(top_builddir)/mllib if HAVE_OCAML_PKG_GETTEXT OCAMLPACKAGES += -package gettext-stub @@ -83,10 +84,15 @@ else OBJECTS = $(XOBJECTS) endif -OCAMLLINKFLAGS = mlguestfs.$(MLARCHIVE) mllib.$(MLARCHIVE) $(LINK_CUSTOM_OCAMLC_ONLY) +OCAMLLINKFLAGS = \ + mlstdutils.$(MLARCHIVE) \ + mlguestfs.$(MLARCHIVE) \ + mllib.$(MLARCHIVE) \ + $(LINK_CUSTOM_OCAMLC_ONLY) virt_get_kernel_DEPENDENCIES = \ $(OBJECTS) \ + ../common/mlstdutils/mlstdutils.$(MLARCHIVE) \ ../mllib/mllib.$(MLARCHIVE) \ $(top_srcdir)/ocaml-link.sh virt_get_kernel_LINK = \ @@ -121,7 +127,7 @@ depend: .depend .depend: $(wildcard $(abs_srcdir)/*.mli) $(wildcard $(abs_srcdir)/*.ml) rm -f $@ $@-t - $(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/mllib $^ | \ + $(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/common/mlstdutils -I $(abs_top_builddir)/mllib $^ | \ $(SED) 's/ *$$//' | \ $(SED) -e :a -e '/ *\\$$/N; s/ *\\\n */ /; ta' | \ $(SED) -e 's,$(abs_srcdir)/,$(builddir)/,g' | \ diff --git a/get-kernel/get_kernel.ml b/get-kernel/get_kernel.ml index e45838811..1c9ece44b 100644 --- a/get-kernel/get_kernel.ml +++ b/get-kernel/get_kernel.ml @@ -16,8 +16,9 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Getopt.OptionName module G = Guestfs diff --git a/mllib/Makefile.am b/mllib/Makefile.am index c84f5f36d..5f6f7fa85 100644 --- a/mllib/Makefile.am +++ b/mllib/Makefile.am @@ -19,7 +19,7 @@ include $(top_srcdir)/subdir-rules.mk EXTRA_DIST = \ $(SOURCES_MLI) \ - $(filter-out guestfs_config.ml libdir.ml,$(SOURCES_ML)) \ + $(SOURCES_ML) \ $(SOURCES_C) \ common_utils_tests.ml \ getopt_tests.ml \ @@ -36,15 +36,11 @@ SOURCES_MLI = \ planner.mli \ regedit.mli \ registry.mli \ - stringMap.mli \ URI.mli \ xpath_helpers.mli SOURCES_ML = \ - guestfs_config.ml \ $(OCAML_BYTES_COMPAT_ML) \ - libdir.ml \ - stringMap.ml \ common_gettext.ml \ getopt.ml \ unix_utils.ml \ @@ -93,7 +89,8 @@ libmllib_a_CPPFLAGS = \ -I$(top_srcdir)/common/utils \ -I$(top_srcdir)/lib \ -I$(top_srcdir)/common/options \ - -I$(top_srcdir)/common/mlxml + -I$(top_srcdir)/common/mlxml \ + -I$(top_srcdir)/common/mlstdutils libmllib_a_CFLAGS = \ $(WARN_CFLAGS) $(WERROR_CFLAGS) \ $(LIBVIRT_CFLAGS) $(LIBXML2_CFLAGS) \ @@ -112,6 +109,7 @@ OCAMLPACKAGES = \ -I $(top_builddir)/gnulib/lib/.libs \ -I $(top_builddir)/ocaml \ -I $(top_builddir)/common/mlxml \ + -I $(top_builddir)/common/mlstdutils \ -I $(builddir) OCAMLPACKAGES_TESTS = $(MLLIB_CMA) if HAVE_OCAML_PKG_GETTEXT @@ -144,13 +142,6 @@ $(MLLIB_CMA): $(OBJECTS) libmllib.a $(OCAMLFIND) mklib $(OCAMLPACKAGES) \ $(OBJECTS) $(libmllib_a_OBJECTS) -o mllib -# This OCaml module has to be generated by make (configure will put -# unexpanded prefix macro in). - -libdir.ml: Makefile - echo 'let libdir = "$(libdir)"' > $@-t - mv $@-t $@ - # Tests. common_utils_tests_SOURCES = dummy.c @@ -196,10 +187,14 @@ JSON_tests_THEOBJECTS = $(JSON_tests_XOBJECTS) JSON_tests.cmx: OCAMLPACKAGES += $(OCAMLPACKAGES_TESTS) endif -OCAMLLINKFLAGS = mlguestfs.$(MLARCHIVE) $(LINK_CUSTOM_OCAMLC_ONLY) +OCAMLLINKFLAGS = \ + mlstdutils.$(MLARCHIVE) \ + mlguestfs.$(MLARCHIVE) \ + $(LINK_CUSTOM_OCAMLC_ONLY) common_utils_tests_DEPENDENCIES = \ $(common_utils_tests_THEOBJECTS) \ + ../common/mlstdutils/mlstdutils.$(MLARCHIVE) \ $(MLLIB_CMA) \ $(top_srcdir)/ocaml-link.sh common_utils_tests_LINK = \ @@ -210,6 +205,7 @@ common_utils_tests_LINK = \ getopt_tests_DEPENDENCIES = \ $(getopt_tests_THEOBJECTS) \ + ../common/mlstdutils/mlstdutils.$(MLARCHIVE) \ $(MLLIB_CMA) \ $(top_srcdir)/ocaml-link.sh getopt_tests_LINK = \ @@ -220,6 +216,7 @@ getopt_tests_LINK = \ JSON_tests_DEPENDENCIES = \ $(JSON_tests_THEOBJECTS) \ + ../common/mlstdutils/mlstdutils.$(MLARCHIVE) \ $(MLLIB_CMA) \ $(top_srcdir)/ocaml-link.sh JSON_tests_LINK = \ diff --git a/mllib/checksums.ml b/mllib/checksums.ml index 61deac2d1..f4c414f57 100644 --- a/mllib/checksums.ml +++ b/mllib/checksums.ml @@ -16,8 +16,9 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Printf diff --git a/mllib/common_utils.ml b/mllib/common_utils.ml index 6a9b08973..1220de7a0 100644 --- a/mllib/common_utils.ml +++ b/mllib/common_utils.ml @@ -16,14 +16,9 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -(* The parts between <stdlib>..</stdlib> are copied into the - * generator/common_utils.ml file. These parts must ONLY use - * functions from the OCaml stdlib. - *) -(*<stdlib>*) open Printf -(*</stdlib>*) +open Std_utils open Common_gettext.Gettext open Getopt.OptionName @@ -31,474 +26,6 @@ external c_inspect_decrypt : Guestfs.t -> int64 -> unit = "guestfs_int_mllib_ins external c_set_echo_keys : unit -> unit = "guestfs_int_mllib_set_echo_keys" "noalloc" external c_set_keys_from_stdin : unit -> unit = "guestfs_int_mllib_set_keys_from_stdin" "noalloc" -(*<stdlib>*) - -module Char = struct - include Char - - let lowercase_ascii c = - if (c >= 'A' && c <= 'Z') - then unsafe_chr (code c + 32) - else c - - let uppercase_ascii c = - if (c >= 'a' && c <= 'z') - then unsafe_chr (code c - 32) - else c - - let isspace c = - c = ' ' - (* || c = '\f' *) || c = '\n' || c = '\r' || c = '\t' (* || c = '\v' *) - - let isdigit = function - | '0'..'9' -> true - | _ -> false - - let isxdigit = function - | '0'..'9' -> true - | 'a'..'f' -> true - | 'A'..'F' -> true - | _ -> false - - let isalpha = function - | 'a'..'z' -> true - | 'A'..'Z' -> true - | _ -> false - - let isalnum = function - | '0'..'9' -> true - | 'a'..'z' -> true - | 'A'..'Z' -> true - | _ -> false - - let hexdigit = function - | '0' -> 0 - | '1' -> 1 - | '2' -> 2 - | '3' -> 3 - | '4' -> 4 - | '5' -> 5 - | '6' -> 6 - | '7' -> 7 - | '8' -> 8 - | '9' -> 9 - | 'a' | 'A' -> 10 - | 'b' | 'B' -> 11 - | 'c' | 'C' -> 12 - | 'd' | 'D' -> 13 - | 'e' | 'E' -> 14 - | 'f' | 'F' -> 15 - | _ -> -1 -end - -module String = struct - include String - - let map f s = - let len = String.length s in - let b = Bytes.create len in - for i = 0 to len-1 do - Bytes.unsafe_set b i (f (unsafe_get s i)) - done; - Bytes.to_string b - - let lowercase_ascii s = map Char.lowercase_ascii s - let uppercase_ascii s = map Char.uppercase_ascii s - - let capitalize_ascii s = - let b = Bytes.of_string s in - Bytes.unsafe_set b 0 (Char.uppercase_ascii (Bytes.unsafe_get b 0)); - Bytes.to_string b - - let is_prefix str prefix = - let n = length prefix in - length str >= n && sub str 0 n = prefix - - let is_suffix str suffix = - let sufflen = length suffix - and len = length str in - len >= sufflen && sub str (len - sufflen) sufflen = suffix - - let rec find s sub = - let len = length s in - let sublen = length sub in - let rec loop i = - if i <= len-sublen then ( - let rec loop2 j = - if j < sublen then ( - if s.[i+j] = sub.[j] then loop2 (j+1) - else -1 - ) else - i (* found *) - in - let r = loop2 0 in - if r = -1 then loop (i+1) else r - ) else - -1 (* not found *) - in - loop 0 - - let rec replace s s1 s2 = - let len = length s in - let sublen = length s1 in - let i = find s s1 in - if i = -1 then s - else ( - let s' = sub s 0 i in - let s'' = sub s (i+sublen) (len-i-sublen) in - s' ^ s2 ^ replace s'' s1 s2 - ) - - let replace_char s c1 c2 = - let b2 = Bytes.of_string s in - let r = ref false in - for i = 0 to Bytes.length b2 - 1 do - if Bytes.unsafe_get b2 i = c1 then ( - Bytes.unsafe_set b2 i c2; - r := true - ) - done; - if not !r then s else Bytes.to_string b2 - - let rec nsplit sep str = - let len = length str in - let seplen = length sep in - let i = find str sep in - if i = -1 then [str] - else ( - let s' = sub str 0 i in - let s'' = sub str (i+seplen) (len-i-seplen) in - s' :: nsplit sep s'' - ) - - let split sep str = - let len = length sep in - let seplen = length str in - let i = find str sep in - if i = -1 then str, "" - else ( - sub str 0 i, sub str (i + len) (seplen - i - len) - ) - - let rec lines_split str = - let buf = Buffer.create 16 in - let len = length str in - let rec loop start len = - try - let i = index_from str start '\n' in - if i > 0 && str.[i-1] = '\\' then ( - Buffer.add_substring buf str start (i-start-1); - Buffer.add_char buf '\n'; - loop (i+1) len - ) else ( - Buffer.add_substring buf str start (i-start); - i+1 - ) - with Not_found -> - if len > 0 && str.[len-1] = '\\' then ( - Buffer.add_substring buf str start (len-start-1); - Buffer.add_char buf '\n' - ) else - Buffer.add_substring buf str start (len-start); - len+1 - in - let endi = loop 0 len in - let line = Buffer.contents buf in - if endi > len then - [line] - else - line :: lines_split (sub str endi (len-endi)) - - let random8 = - let chars = "abcdefghijklmnopqrstuvwxyz0123456789" in - fun () -> - concat "" ( - List.map ( - fun _ -> - let c = Random.int 36 in - let c = chars.[c] in - make 1 c - ) [1;2;3;4;5;6;7;8] - ) - - let triml ?(test = Char.isspace) str = - let i = ref 0 in - let n = ref (String.length str) in - while !n > 0 && test str.[!i]; do - decr n; - incr i - done; - if !i = 0 then str - else String.sub str !i !n - - let trimr ?(test = Char.isspace) str = - let n = ref (String.length str) in - while !n > 0 && test str.[!n-1]; do - decr n - done; - if !n = String.length str then str - else String.sub str 0 !n - - let trim ?(test = Char.isspace) str = - trimr ~test (triml ~test str) - - let count_chars c str = - let count = ref 0 in - for i = 0 to String.length str - 1 do - if c = String.unsafe_get str i then incr count - done; - !count - - let explode str = - let r = ref [] in - for i = 0 to String.length str - 1 do - let c = String.unsafe_get str i in - r := c :: !r; - done; - List.rev !r - - let map_chars f str = - List.map f (explode str) - - let spaces n = String.make n ' ' -end - -let (//) = Filename.concat -let quote = Filename.quote - -let subdirectory parent path = - if path = parent then - "" - else if String.is_prefix path (parent // "") then ( - let len = String.length parent in - String.sub path (len+1) (String.length path - len-1) - ) else - invalid_arg (sprintf "%S is not a path prefix of %S" parent path) - -let ( +^ ) = Int64.add -let ( -^ ) = Int64.sub -let ( *^ ) = Int64.mul -let ( /^ ) = Int64.div -let ( &^ ) = Int64.logand -let ( ~^ ) = Int64.lognot - -external identity : 'a -> 'a = "%identity" - -let roundup64 i a = let a = a -^ 1L in (i +^ a) &^ (~^ a) -let div_roundup64 i a = (i +^ a -^ 1L) /^ a - -let int_of_le32 str = - assert (String.length str = 4); - let c0 = Char.code (String.unsafe_get str 0) in - let c1 = Char.code (String.unsafe_get str 1) in - let c2 = Char.code (String.unsafe_get str 2) in - let c3 = Char.code (String.unsafe_get str 3) in - Int64.of_int c0 +^ - (Int64.shift_left (Int64.of_int c1) 8) +^ - (Int64.shift_left (Int64.of_int c2) 16) +^ - (Int64.shift_left (Int64.of_int c3) 24) - -let le32_of_int i = - let c0 = i &^ 0xffL in - let c1 = Int64.shift_right (i &^ 0xff00L) 8 in - let c2 = Int64.shift_right (i &^ 0xff0000L) 16 in - let c3 = Int64.shift_right (i &^ 0xff000000L) 24 in - let b = Bytes.create 4 in - Bytes.unsafe_set b 0 (Char.unsafe_chr (Int64.to_int c0)); - Bytes.unsafe_set b 1 (Char.unsafe_chr (Int64.to_int c1)); - Bytes.unsafe_set b 2 (Char.unsafe_chr (Int64.to_int c2)); - Bytes.unsafe_set b 3 (Char.unsafe_chr (Int64.to_int c3)); - Bytes.to_string b - -type wrap_break_t = WrapEOS | WrapSpace | WrapNL - -let rec wrap ?(chan = stdout) ?(indent = 0) str = - let len = String.length str in - _wrap chan indent 0 0 len str - -and _wrap chan indent column i len str = - if i < len then ( - let (j, break) = _wrap_find_next_break i len str in - let next_column = - if column + (j-i) >= 76 then ( - output_char chan '\n'; - output_spaces chan indent; - indent + (j-i) + 1 - ) - else column + (j-i) + 1 in - output chan (Bytes.of_string str) i (j-i); - match break with - | WrapEOS -> () - | WrapSpace -> - output_char chan ' '; - _wrap chan indent next_column (j+1) len str - | WrapNL -> - output_char chan '\n'; - output_spaces chan indent; - _wrap chan indent indent (j+1) len str - ) - -and _wrap_find_next_break i len str = - if i >= len then (len, WrapEOS) - else if String.unsafe_get str i = ' ' then (i, WrapSpace) - else if String.unsafe_get str i = '\n' then (i, WrapNL) - else _wrap_find_next_break (i+1) len str - -and output_spaces chan n = for i = 0 to n-1 do output_char chan ' ' done - -let (|>) x f = f x - -(* Drop elements from a list while a predicate is true. *) -let rec dropwhile f = function - | [] -> [] - | x :: xs when f x -> dropwhile f xs - | xs -> xs - -(* Take elements from a list while a predicate is true. *) -let rec takewhile f = function - | x :: xs when f x -> x :: takewhile f xs - | _ -> [] - -let rec filter_map f = function - | [] -> [] - | x :: xs -> - match f x with - | Some y -> y :: filter_map f xs - | None -> filter_map f xs - -let rec find_map f = function - | [] -> raise Not_found - | x :: xs -> - match f x with - | Some y -> y - | None -> find_map f xs - -let iteri f xs = - let rec loop i = function - | [] -> () - | x :: xs -> f i x; loop (i+1) xs - in - loop 0 xs - -let rec mapi i f = - function - | [] -> [] - | a::l -> - let r = f i a in - r :: mapi (i + 1) f l -let mapi f l = mapi 0 f l - -let rec combine3 xs ys zs = - match xs, ys, zs with - | [], [], [] -> [] - | x::xs, y::ys, z::zs -> (x, y, z) :: combine3 xs ys zs - | _ -> invalid_arg "combine3" - -let rec assoc ?(cmp = compare) ~default x = function - | [] -> default - | (y, y') :: _ when cmp x y = 0 -> y' - | _ :: ys -> assoc ~cmp ~default x ys - -let uniq ?(cmp = Pervasives.compare) xs = - let rec loop acc = function - | [] -> acc - | [x] -> x :: acc - | x :: (y :: _ as xs) when cmp x y = 0 -> - loop acc xs - | x :: (y :: _ as xs) -> - loop (x :: acc) xs - in - List.rev (loop [] xs) - -let sort_uniq ?(cmp = Pervasives.compare) xs = - let xs = List.sort cmp xs in - let xs = uniq ~cmp xs in - xs - -let remove_duplicates xs = - let h = Hashtbl.create (List.length xs) in - let rec loop = function - | [] -> [] - | x :: xs when Hashtbl.mem h x -> xs - | x :: xs -> Hashtbl.add h x true; x :: loop xs - in - loop xs - -let push_back xsp x = xsp := !xsp @ [x] -let push_front x xsp = xsp := x :: !xsp -let pop_back xsp = - let x, xs = - match List.rev !xsp with - | x :: xs -> x, xs - | [] -> failwith "pop" in - xsp := List.rev xs; - x -let pop_front xsp = - let x, xs = - match !xsp with - | x :: xs -> x, xs - | [] -> failwith "shift" in - xsp := xs; - x - -let append xsp xs = xsp := !xsp @ xs -let prepend xs xsp = xsp := xs @ !xsp - -let unique = let i = ref 0 in fun () -> incr i; !i - -let may f = function - | None -> () - | Some x -> f x - -type ('a, 'b) maybe = Either of 'a | Or of 'b - -let protect ~f ~finally = - let r = - try Either (f ()) - with exn -> Or exn in - finally (); - match r with Either ret -> ret | Or exn -> raise exn - -let failwithf fs = ksprintf failwith fs - -exception Executable_not_found of string (* executable *) - -let which executable = - let paths = - try String.nsplit ":" (Sys.getenv "PATH") - with Not_found -> [] in - let paths = filter_map ( - fun p -> - let path = p // executable in - try Unix.access path [Unix.X_OK]; Some path - with Unix.Unix_error _ -> None - ) paths in - match paths with - | [] -> raise (Executable_not_found executable) - | x :: _ -> x - -(* Program name. *) -let prog = Filename.basename Sys.executable_name - -(* Stores the colours (--colours), quiet (--quiet), trace (-x) and - * verbose (-v) flags in a global variable. - *) -let colours = ref false -let set_colours () = colours := true -let colours () = !colours - -let quiet = ref false -let set_quiet () = quiet := true -let quiet () = !quiet - -let trace = ref false -let set_trace () = trace := true -let trace () = !trace - -let verbose = ref false -let set_verbose () = verbose := true -let verbose () = !verbose - (* ANSI terminal colours. *) let istty chan = Unix.isatty (Unix.descr_of_out_channel chan) @@ -514,8 +41,6 @@ let ansi_magenta ?(chan = stdout) () = let ansi_restore ?(chan = stdout) () = if colours () || istty chan then output_string chan "\x1b[0m" -(*</stdlib>*) - (* Timestamped progress messages, used for ordinary messages when not * --quiet. *) @@ -630,26 +155,6 @@ let virt_tools_data_dir = ) in fun () -> Lazy.force dir -(*<stdlib>*) - -let read_whole_file path = - let buf = Buffer.create 16384 in - let chan = open_in path in - let maxlen = 16384 in - let b = Bytes.create maxlen in - let rec loop () = - let r = input chan b 0 maxlen in - if r > 0 then ( - Buffer.add_substring buf (Bytes.to_string b) 0 r; - loop () - ) - in - loop (); - close_in chan; - Buffer.contents buf - -(*</stdlib>*) - (* Parse a size field, eg. "10G". *) let parse_size = let const_re = Str.regexp "^\\([.0-9]+\\)\\([bKMG]\\)$" in @@ -764,67 +269,6 @@ let create_standard_options argspec ?anon_fun ?(key_opts = false) usage_msg = else []) in Getopt.create argspec ?anon_fun usage_msg -(*<stdlib>*) - -(* Compare two version strings intelligently. *) -let rex_numbers = Str.regexp "^\\([0-9]+\\)\\(.*\\)$" -let rex_letters = Str.regexp_case_fold "^\\([a-z]+\\)\\(.*\\)$" - -let compare_version v1 v2 = - let rec split_version = function - | "" -> [] - | str -> - let first, rest = - if Str.string_match rex_numbers str 0 then ( - let n = Str.matched_group 1 str in - let rest = Str.matched_group 2 str in - let n = - try `Number (int_of_string n) - with Failure _ -> `String n in - n, rest - ) - else if Str.string_match rex_letters str 0 then - `String (Str.matched_group 1 str), Str.matched_group 2 str - else ( - let len = String.length str in - `Char str.[0], String.sub str 1 (len-1) - ) in - first :: split_version rest - in - compare (split_version v1) (split_version v2) - -(* Annoying LVM2 returns a differing UUID strings for different - * function calls (sometimes containing or not containing '-' - * characters), so we have to normalize each string before - * comparison. c.f. 'compare_pvuuids' in virt-filesystem. - *) -let compare_lvm2_uuids uuid1 uuid2 = - let n1 = String.length uuid1 and n2 = String.length uuid2 in - let rec loop i1 i2 = - if i1 = n1 && i2 = n2 then 0 (* matching *) - else if i1 >= n1 then 1 (* different lengths *) - else if i2 >= n2 then -1 - else if uuid1.[i1] = '-' then loop (i1+1) i2 (* ignore '-' characters *) - else if uuid2.[i2] = '-' then loop i1 (i2+1) - else ( - let c = compare uuid1.[i1] uuid2.[i2] in - if c <> 0 then c (* not matching *) - else loop (i1+1) (i2+1) - ) - in - loop 0 0 - -let stringify_args args = - let rec quote_args = function - | [] -> "" - | x :: xs -> " " ^ Filename.quote x ^ quote_args xs - in - match args with - | [] -> "" - | app :: xs -> app ^ quote_args xs - -(*</stdlib>*) - (* Run an external command, slurp up the output as a list of lines. *) let external_command ?(echo_cmd = true) cmd = if echo_cmd then @@ -889,31 +333,6 @@ let uuidgen () = if len < 10 then assert false; (* sanity check on uuidgen *) uuid -(*<stdlib>*) - -(* Unlink a temporary file on exit. *) -let unlink_on_exit = - let files = ref [] in - let registered_handlers = ref false in - - let rec unlink_files () = - List.iter ( - fun file -> try Unix.unlink file with _ -> () - ) !files - and register_handlers () = - (* Unlink on exit. *) - at_exit unlink_files - in - - fun file -> - files := file :: !files; - if not !registered_handlers then ( - register_handlers (); - registered_handlers := true - ) - -(*</stdlib>*) - (* Remove a temporary directory on exit. *) let rmdir_on_exit = let dirs = ref [] in @@ -1050,18 +469,6 @@ let detect_file_type filename = close_in chan; ret -(*<stdlib>*) - -let is_block_device file = - try (Unix.stat file).Unix.st_kind = Unix.S_BLK - with Unix.Unix_error _ -> false - -let is_char_device file = - try (Unix.stat file).Unix.st_kind = Unix.S_CHR - with Unix.Unix_error _ -> false - -(*</stdlib>*) - let is_partition dev = try if not (is_block_device dev) then false @@ -1075,87 +482,6 @@ let is_partition dev = ) with Unix.Unix_error _ -> false -(*<stdlib>*) - -(* Annoyingly Sys.is_directory throws an exception on failure - * (RHBZ#1022431). - *) -let is_directory path = - try Sys.is_directory path - with Sys_error _ -> false - -let absolute_path path = - if not (Filename.is_relative path) then path - else Sys.getcwd () // path - -let qemu_input_filename filename = - (* If the filename is something like "file:foo" then qemu-img will - * try to interpret that as "foo" in the file:/// protocol. To - * avoid that, if the path is relative prefix it with "./" since - * qemu-img won't try to interpret such a path. - *) - if String.length filename > 0 && filename.[0] <> '/' then - "./" ^ filename - else - filename - -let rec mkdir_p path permissions = - try Unix.mkdir path permissions - with - | Unix.Unix_error (Unix.EEXIST, _, _) -> () - | Unix.Unix_error (Unix.ENOENT, _, _) -> - (* A component in the path does not exist, so first try - * creating the parent directory, and then again the requested - * directory. *) - mkdir_p (Filename.dirname path) permissions; - Unix.mkdir path permissions - -let normalize_arch = function - | "i486" | "i586" | "i686" -> "i386" - | "amd64" -> "x86_64" - | "powerpc" -> "ppc" - | "powerpc64" -> "ppc64" - | "powerpc64le" -> "ppc64le" - | arch -> arch - -(* Are guest arch and host_cpu compatible, in terms of being able - * to run commands in the libguestfs appliance? - *) -let guest_arch_compatible guest_arch = - let own = normalize_arch Guestfs_config.host_cpu in - let guest_arch = normalize_arch guest_arch in - match own, guest_arch with - | x, y when x = y -> true - | "x86_64", "i386" -> true - | _ -> false - -(* Is the guest OS "Unix-like"? *) -let unix_like = function - | "hurd" - | "linux" - | "minix" -> true - | typ when String.is_suffix typ "bsd" -> true - | _ -> false - -(** Return the last part of a string, after the specified separator. *) -let last_part_of str sep = - try - let i = String.rindex str sep in - Some (String.sub str (i+1) (String.length str - (i+1))) - with Not_found -> None - -let read_first_line_from_file filename = - let chan = open_in filename in - let line = input_line chan in - close_in chan; - line - -let is_regular_file path = (* NB: follows symlinks. *) - try (Unix.stat path).Unix.st_kind = Unix.S_REG - with Unix.Unix_error _ -> false - -(*</stdlib>*) - let inspect_mount_root g ?mount_opts_fn root = let mps = g#inspect_get_mountpoints root in let cmp (a,_) (b,_) = diff --git a/mllib/common_utils.mli b/mllib/common_utils.mli index c088f8497..b72f7ee62 100644 --- a/mllib/common_utils.mli +++ b/mllib/common_utils.mli @@ -16,280 +16,6 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -(* The parts between <stdlib>..</stdlib> are copied into the - * generator/common_utils.ml file. These parts must ONLY use - * functions from the OCaml stdlib. - *) -(*<stdlib>*) - -module Char : sig - type t = char - val chr : int -> char - val code : char -> int - val compare: t -> t -> int - val escaped : char -> string - val unsafe_chr : int -> char - - val lowercase_ascii : char -> char - val uppercase_ascii : char -> char - - val isspace : char -> bool - (** Return true if char is a whitespace character. *) - val isdigit : char -> bool - (** Return true if the character is a digit [[0-9]]. *) - val isxdigit : char -> bool - (** Return true if the character is a hex digit [[0-9a-fA-F]]. *) - val isalpha : char -> bool - (** Return true if the character is a US ASCII 7 bit alphabetic. *) - val isalnum : char -> bool - (** Return true if the character is a US ASCII 7 bit alphanumeric. *) - - val hexdigit : char -> int - (** Return the value of a hex digit. If the char is not in - the set [[0-9a-fA-F]] then this returns [-1]. *) -end -(** Override the Char module from stdlib. *) - -module String : sig - type t = string - val compare: t -> t -> int - val concat : string -> string list -> string - val contains : string -> char -> bool - val contains_from : string -> int -> char -> bool - val copy : string -> string - val escaped : string -> string - val get : string -> int -> char - val index : string -> char -> int - val index_from : string -> int -> char -> int - val iter : (char -> unit) -> string -> unit - val length : string -> int - val make : int -> char -> string - val rcontains_from : string -> int -> char -> bool - val rindex : string -> char -> int - val rindex_from : string -> int -> char -> int - val sub : string -> int -> int -> string - val unsafe_get : string -> int -> char - - val map : (char -> char) -> string -> string - - val lowercase_ascii : string -> string - val uppercase_ascii : string -> string - val capitalize_ascii : string -> string - - val is_prefix : string -> string -> bool - (** [is_prefix str prefix] returns true if [prefix] is a prefix of [str]. *) - val is_suffix : string -> string -> bool - (** [is_suffix str suffix] returns true if [suffix] is a suffix of [str]. *) - val find : string -> string -> int - (** [find str sub] searches for [sub] as a substring of [str]. If - found it returns the index. If not found, it returns [-1]. *) - val replace : string -> string -> string -> string - (** [replace str s1 s2] replaces all instances of [s1] appearing in - [str] with [s2]. *) - val replace_char : string -> char -> char -> string - (** Replace character in string. *) - val nsplit : string -> string -> string list - (** [nsplit sep str] splits [str] into multiple strings at each - separator [sep]. *) - val split : string -> string -> string * string - (** [split sep str] splits [str] at the first occurrence of the - separator [sep], returning the part before and the part after. - If separator is not found, return the whole string and an - empty string. *) - val lines_split : string -> string list - (** [lines_split str] splits [str] into lines, keeping continuation - characters (i.e. [\] at the end of lines) into account. *) - val random8 : unit -> string - (** Return a string of 8 random printable characters. *) - val triml : ?test:(char -> bool) -> string -> string - (** Trim left. *) - val trimr : ?test:(char -> bool) -> string -> string - (** Trim right. *) - val trim : ?test:(char -> bool) -> string -> string - (** Trim left and right. *) - val count_chars : char -> string -> int - (** Count number of times the character occurs in string. *) - val explode : string -> char list - (** Explode a string into a list of characters. *) - val map_chars : (char -> 'a) -> string -> 'a list - (** Explode string, then map function over the characters. *) - val spaces : int -> string - (** [spaces n] creates a string of n spaces. *) -end -(** Override the String module from stdlib. *) - -val ( // ) : string -> string -> string -(** Concatenate directory and filename. *) - -val quote : string -> string -(** Shell-safe quoting of a string (alias for {!Filename.quote}). *) - -val subdirectory : string -> string -> string -(** [subdirectory parent path] returns subdirectory part of [path] relative - to the [parent]. If [path] and [parent] point to the same directory empty - string is returned. - - Note: path normalization on arguments is {b not} performed! - - If [parent] is not a path prefix of [path] the function raises - [Invalid_argument]. *) - -val ( +^ ) : int64 -> int64 -> int64 -val ( -^ ) : int64 -> int64 -> int64 -val ( *^ ) : int64 -> int64 -> int64 -val ( /^ ) : int64 -> int64 -> int64 -val ( &^ ) : int64 -> int64 -> int64 -val ( ~^ ) : int64 -> int64 -(** Various int64 operators. *) - -external identity : 'a -> 'a = "%identity" - -val roundup64 : int64 -> int64 -> int64 -(** [roundup64 i a] returns [i] rounded up to the next multiple of [a]. *) -val div_roundup64 : int64 -> int64 -> int64 -(** [div_roundup64 i a] returns [i] rounded up to the next multiple of [a], - with the result divided by [a]. *) -val int_of_le32 : string -> int64 -(** Unpack a 4 byte string as a little endian 32 bit integer. *) -val le32_of_int : int64 -> string -(** Pack a 32 bit integer a 4 byte string stored little endian. *) - -val wrap : ?chan:out_channel -> ?indent:int -> string -> unit -(** Wrap text. *) - -val output_spaces : out_channel -> int -> unit -(** Write [n] spaces to [out_channel]. *) - -val (|>) : 'a -> ('a -> 'b) -> 'b -(** Added in OCaml 4.01, we can remove our definition when we - can assume this minimum version of OCaml. *) - -val dropwhile : ('a -> bool) -> 'a list -> 'a list -(** [dropwhile f xs] drops leading elements from [xs] until - [f] returns false. *) -val takewhile : ('a -> bool) -> 'a list -> 'a list -(** [takewhile f xs] takes leading elements from [xs] until - [f] returns false. - - For any list [xs] and function [f], - [xs = takewhile f xs @ dropwhile f xs] *) -val filter_map : ('a -> 'b option) -> 'a list -> 'b list -(** [filter_map f xs] applies [f] to each element of [xs]. If - [f x] returns [Some y] then [y] is added to the returned list. *) -val find_map : ('a -> 'b option) -> 'a list -> 'b -(** [find_map f xs] applies [f] to each element of [xs] until - [f x] returns [Some y]. It returns [y]. If we exhaust the - list then this raises [Not_found]. *) -val iteri : (int -> 'a -> 'b) -> 'a list -> unit -(** [iteri f xs] calls [f i x] for each element, with [i] counting from [0]. *) -val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list -(** [mapi f xs] calls [f i x] for each element, with [i] counting from [0], - forming the return values from [f] into another list. *) - -val combine3 : 'a list -> 'b list -> 'c list -> ('a * 'b * 'c) list -(** Like {!List.combine} but for triples. All lists must be the same length. *) - -val assoc : ?cmp:('a -> 'a -> int) -> default:'b -> 'a -> ('a * 'b) list -> 'b -(** Like {!List.assoc} but with a user-defined comparison function, and - instead of raising [Not_found], it returns the [~default] value. *) - -val uniq : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list -(** Uniquify a list (the list must be sorted first). *) - -val sort_uniq : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list -(** Sort and uniquify a list. *) - -val remove_duplicates : 'a list -> 'a list -(** Remove duplicates from an unsorted list; useful when the order - of the elements matter. - - Please use [sort_uniq] when the order does not matter. *) - -val push_back : 'a list ref -> 'a -> unit -val push_front : 'a -> 'a list ref -> unit -val pop_back : 'a list ref -> 'a -val pop_front : 'a list ref -> 'a -(** Imperative list manipulation functions, similar to C++ STL - functions with the same names. (Although the names are similar, - the computational complexity of the functions is quite different.) - - These operate on list references, and each function modifies the - list reference that is passed to it. - - [push_back xsp x] appends the element [x] to the end of the list - [xsp]. This function is not tail-recursive. - - [push_front x xsp] prepends the element [x] to the head of the - list [xsp]. (The arguments are reversed compared to the same Perl - function, but OCaml is type safe so that's OK.) - - [pop_back xsp] removes the last element of the list [xsp] and - returns it. The list is modified to become the list minus the - final element. If a zero-length list is passed in, this raises - [Failure "pop_back"]. This function is not tail-recursive. - - [pop_front xsp] removes the head element of the list [xsp] and - returns it. The list is modified to become the tail of the list. - If a zero-length list is passed in, this raises [Failure - "pop_front"]. *) - -val append : 'a list ref -> 'a list -> unit -val prepend : 'a list -> 'a list ref -> unit -(** More imperative list manipulation functions. - - [append] is like {!push_back} above, except it appends a list to - the list reference. This function is not tail-recursive. - - [prepend] is like {!push_front} above, except it prepends a list - to the list reference. *) - -val unique : unit -> int -(** Returns a unique number each time called. *) - -val may : ('a -> unit) -> 'a option -> unit -(** [may f (Some x)] runs [f x]. [may f None] does nothing. *) - -type ('a, 'b) maybe = Either of 'a | Or of 'b -(** Like the Haskell [Either] type. *) - -val protect : f:(unit -> 'a) -> finally:(unit -> unit) -> 'a -(** Execute [~f] and afterwards execute [~finally]. - - If [~f] throws an exception then [~finally] is run and the - original exception from [~f] is re-raised. - - If [~finally] throws an exception, then the original exception - is lost. (NB: Janestreet core {!Exn.protectx}, on which this - function is modelled, doesn't throw away the exception in this - case, but requires a lot more work by the caller. Perhaps we - will change this in future.) *) - -val failwithf : ('a, unit, string, 'b) format4 -> 'a -(** Like [failwith] but supports printf-like arguments. *) - -exception Executable_not_found of string (* executable *) -(** Exception thrown by [which] when the specified executable is not found - in [$PATH]. *) - -val which : string -> string -(** Return the full path of the specified executable from [$PATH]. - - Throw [Executable_not_found] if not available. *) - -val prog : string -(** The program name (derived from {!Sys.executable_name}). *) - -val set_quiet : unit -> unit -val quiet : unit -> bool -val set_trace : unit -> unit -val trace : unit -> bool -val set_verbose : unit -> unit -val verbose : unit -> bool -(** Stores the quiet ([--quiet]), trace ([-x]) and verbose ([-v]) flags - in global variables. *) - -(*</stdlib>*) - val message : ('a, unit, string, unit) format4 -> 'a (** Timestamped progress messages. Used for ordinary messages when not [--quiet]. *) @@ -328,13 +54,6 @@ val virt_tools_data_dir : unit -> string the environment variable is not set, a default value is calculated based on configure settings. *) -(*<stdlib>*) - -val read_whole_file : string -> string -(** Read in the whole file as a string. *) - -(*</stdlib>*) - val parse_size : string -> int64 (** Parse a size field, eg. [10G] *) @@ -354,20 +73,6 @@ val create_standard_options : Getopt.speclist -> ?anon_fun:Getopt.anon_fun -> ?k Returns a new [Getopt.t] handle. *) -(*<stdlib>*) - -val compare_version : string -> string -> int -(** Compare two version strings. *) - -val compare_lvm2_uuids : string -> string -> int -(** Compare two LVM2 UUIDs, ignoring '-' characters. *) - -val stringify_args : string list -> string -(** Create a "pretty-print" representation of a program invocation - (i.e. executable and its arguments). *) - -(*</stdlib>*) - val external_command : ?echo_cmd:bool -> string -> string list (** Run an external command, slurp up the output as a list of lines. @@ -389,13 +94,6 @@ val shell_command : ?echo_cmd:bool -> string -> int val uuidgen : unit -> string (** Run uuidgen to return a random UUID. *) -(*<stdlib>*) - -val unlink_on_exit : string -> unit -(** Unlink a temporary file on exit. *) - -(*</stdlib>*) - val rmdir_on_exit : string -> unit (** Remove a temporary directory on exit (using [rm -rf]). *) @@ -431,55 +129,10 @@ val debug_augeas_errors : Guestfs.guestfs -> unit val detect_file_type : string -> [`GZip | `Tar | `XZ | `Zip | `Unknown] (** Detect type of a file (for a very limited range of file types). *) -(*<stdlib>*) - -val is_block_device : string -> bool -val is_char_device : string -> bool -val is_directory : string -> bool -(** These don't throw exceptions, unlike the [Sys] functions. *) - -(*</stdlib>*) - val is_partition : string -> bool (** Return true if the host device [dev] is a partition. If it's anything else, or missing, returns false. *) -(*<stdlib>*) - -val absolute_path : string -> string -(** Convert any path to an absolute path. *) - -val qemu_input_filename : string -> string -(** Sanitizes a filename for passing it safely to qemu/qemu-img. *) - -val mkdir_p : string -> int -> unit -(** Creates a directory, and its parents if missing. *) - -val normalize_arch : string -> string -(** Normalize the architecture name, i.e. maps it into a defined - identifier for it -- e.g. i386, i486, i586, and i686 are - normalized as i386. *) - -val guest_arch_compatible : string -> bool -(** Are guest arch and host_cpu compatible, in terms of being able - to run commands in the libguestfs appliance? *) - -val unix_like : string -> bool -(** Is the guest OS "Unix-like"? Call this with the result of - {!Guestfs.inspect_get_type}. *) - -val last_part_of : string -> char -> string option -(** Return the last part of a string, after the specified separator. *) - -val read_first_line_from_file : string -> string -(** Read only the first line (i.e. until the first newline character) - of a file. *) - -val is_regular_file : string -> bool -(** Checks whether the file is a regular file. *) - -(*</stdlib>*) - val inspect_mount_root : Guestfs.guestfs -> ?mount_opts_fn:(string -> string) -> string -> unit (** Mounts all the mount points of the specified root, just like [guestfish -i] does. diff --git a/mllib/common_utils_tests.ml b/mllib/common_utils_tests.ml index aacc01e04..def5ea932 100644 --- a/mllib/common_utils_tests.ml +++ b/mllib/common_utils_tests.ml @@ -19,24 +19,13 @@ (* This file tests the Common_utils module. *) open OUnit2 + +open Std_utils open Common_utils (* Utils. *) let assert_equal_string = assert_equal ~printer:(fun x -> x) -let assert_equal_int = assert_equal ~printer:(fun x -> string_of_int x) let assert_equal_int64 = assert_equal ~printer:(fun x -> Int64.to_string x) -let assert_equal_stringlist = assert_equal ~printer:(fun x -> "(" ^ (String.escaped (String.concat "," x)) ^ ")") - -let test_subdirectory ctx = - assert_equal_string "" (subdirectory "/foo" "/foo"); - assert_equal_string "" (subdirectory "/foo" "/foo/"); - assert_equal_string "bar" (subdirectory "/foo" "/foo/bar"); - assert_equal_string "bar/baz" (subdirectory "/foo" "/foo/bar/baz") - -(* Test Common_utils.int_of_le32 and Common_utils.le32_of_int. *) -let test_le32 ctx = - assert_equal_int64 0x20406080L (int_of_le32 "\x80\x60\x40\x20"); - assert_equal_string "\x80\x60\x40\x20" (le32_of_int 0x20406080L) (* Test Common_utils.parse_size. *) let test_parse_resize ctx = @@ -90,59 +79,12 @@ let test_human_size ctx = assert_equal_string "3.4G" (human_size 3650722201_L); assert_equal_string "-3.4G" (human_size (-3650722201_L)) -(* Test Common_utils.String.is_prefix. *) -let test_string_is_prefix ctx = - assert_bool "String.is_prefix,," (String.is_prefix "" ""); - assert_bool "String.is_prefix,foo," (String.is_prefix "foo" ""); - assert_bool "String.is_prefix,foo,foo" (String.is_prefix "foo" "foo"); - assert_bool "String.is_prefix,foo123,foo" (String.is_prefix "foo123" "foo"); - assert_bool "not (String.is_prefix,,foo" (not (String.is_prefix "" "foo")) - -(* Test Common_utils.String.is_suffix. *) -let test_string_is_suffix ctx = - assert_bool "String.is_suffix,," (String.is_suffix "" ""); - assert_bool "String.is_suffix,foo," (String.is_suffix "foo" ""); - assert_bool "String.is_suffix,foo,foo" (String.is_suffix "foo" "foo"); - assert_bool "String.is_suffix,123foo,foo" (String.is_suffix "123foo" "foo"); - assert_bool "not String.is_suffix,,foo" (not (String.is_suffix "" "foo")) - -(* Test Common_utils.String.find. *) -let test_string_find ctx = - assert_equal_int 0 (String.find "" ""); - assert_equal_int 0 (String.find "foo" ""); - assert_equal_int 1 (String.find "foo" "o"); - assert_equal_int 3 (String.find "foobar" "bar"); - assert_equal_int (-1) (String.find "" "baz"); - assert_equal_int (-1) (String.find "foobar" "baz") - -(* Test Common_utils.String.lines_split. *) -let test_string_lines_split ctx = - assert_equal_stringlist [""] (String.lines_split ""); - assert_equal_stringlist ["A"] (String.lines_split "A"); - assert_equal_stringlist ["A"; ""] (String.lines_split "A\n"); - assert_equal_stringlist ["A"; "B"] (String.lines_split "A\nB"); - assert_equal_stringlist ["A"; "B"; "C"] (String.lines_split "A\nB\nC"); - assert_equal_stringlist ["A"; "B"; "C"; "D"] (String.lines_split "A\nB\nC\nD"); - assert_equal_stringlist ["A\n"] (String.lines_split "A\\"); - assert_equal_stringlist ["A\nB"] (String.lines_split "A\\\nB"); - assert_equal_stringlist ["A"; "B\nC"] (String.lines_split "A\nB\\\nC"); - assert_equal_stringlist ["A"; "B\nC"; "D"] (String.lines_split "A\nB\\\nC\nD"); - assert_equal_stringlist ["A"; "B\nC\nD"] (String.lines_split "A\nB\\\nC\\\nD"); - assert_equal_stringlist ["A\nB"; ""] (String.lines_split "A\\\nB\n"); - assert_equal_stringlist ["A\nB\n"] (String.lines_split "A\\\nB\\\n") - (* Suites declaration. *) let suite = "mllib Common_utils" >::: [ - "subdirectory" >:: test_subdirectory; - "numeric.le32" >:: test_le32; "sizes.parse_resize" >:: test_parse_resize; "sizes.human_size" >:: test_human_size; - "strings.is_prefix" >:: test_string_is_prefix; - "strings.is_suffix" >:: test_string_is_suffix; - "strings.find" >:: test_string_find; - "strings.lines_split" >:: test_string_lines_split; ] let () = diff --git a/mllib/curl.ml b/mllib/curl.ml index ed0b8960a..ccf98acef 100644 --- a/mllib/curl.ml +++ b/mllib/curl.ml @@ -18,6 +18,7 @@ open Printf +open Std_utils open Common_utils type t = { diff --git a/mllib/getopt_tests.ml b/mllib/getopt_tests.ml index 9d432e922..22e4282fa 100644 --- a/mllib/getopt_tests.ml +++ b/mllib/getopt_tests.ml @@ -22,6 +22,7 @@ open Printf +open Std_utils open Common_utils open Getopt.OptionName diff --git a/mllib/regedit.ml b/mllib/regedit.ml index dd03f5a23..e07700bb1 100644 --- a/mllib/regedit.ml +++ b/mllib/regedit.ml @@ -16,6 +16,7 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) +open Std_utils open Common_utils open Common_gettext.Gettext diff --git a/mllib/registry.ml b/mllib/registry.ml index 767092c6d..8d62e3bb5 100644 --- a/mllib/registry.ml +++ b/mllib/registry.ml @@ -18,8 +18,9 @@ open Printf -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext type node = int64 type value = int64 diff --git a/mllib/xpath_helpers.ml b/mllib/xpath_helpers.ml index d651fab23..e6185bf3d 100644 --- a/mllib/xpath_helpers.ml +++ b/mllib/xpath_helpers.ml @@ -18,8 +18,9 @@ open Printf -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext (* Parse an xpath expression and return a string/int. Returns * [Some v], or [None] if the expression doesn't match. diff --git a/resize/Makefile.am b/resize/Makefile.am index c35c3a78a..3707d73b4 100644 --- a/resize/Makefile.am +++ b/resize/Makefile.am @@ -61,6 +61,7 @@ OCAMLPACKAGES = \ -I $(top_builddir)/lib/.libs \ -I $(top_builddir)/gnulib/lib/.libs \ -I $(top_builddir)/ocaml \ + -I $(top_builddir)/common/mlstdutils \ -I $(top_builddir)/common/mlprogress \ -I $(top_builddir)/mllib if HAVE_OCAML_PKG_GETTEXT @@ -84,6 +85,7 @@ OBJECTS = $(XOBJECTS) endif OCAMLLINKFLAGS = \ + mlstdutils.$(MLARCHIVE) \ mlguestfs.$(MLARCHIVE) \ mlprogress.$(MLARCHIVE) \ mllib.$(MLARCHIVE) \ @@ -91,6 +93,7 @@ OCAMLLINKFLAGS = \ virt_resize_DEPENDENCIES = \ $(OBJECTS) \ + ../common/mlstdutils/mlstdutils.$(MLARCHIVE) \ ../mllib/mllib.$(MLARCHIVE) \ $(top_srcdir)/ocaml-link.sh virt_resize_LINK = \ @@ -135,7 +138,7 @@ depend: .depend .depend: $(wildcard $(abs_srcdir)/*.mli) $(wildcard $(abs_srcdir)/*.ml) rm -f $@ $@-t - $(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/mllib $^ | \ + $(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/mlstdutils -I $(abs_top_builddir)/mllib $^ | \ $(SED) 's/ *$$//' | \ $(SED) -e :a -e '/ *\\$$/N; s/ *\\\n */ /; ta' | \ $(SED) -e 's,$(abs_srcdir)/,$(builddir)/,g' | \ diff --git a/resize/resize.ml b/resize/resize.ml index f9b612e28..66ef9e11d 100644 --- a/resize/resize.ml +++ b/resize/resize.ml @@ -18,6 +18,7 @@ open Printf +open Std_utils open Common_utils open Common_gettext.Gettext open Unix_utils diff --git a/sparsify/Makefile.am b/sparsify/Makefile.am index 97236829e..a1395ccbd 100644 --- a/sparsify/Makefile.am +++ b/sparsify/Makefile.am @@ -66,6 +66,7 @@ OCAMLPACKAGES = \ -I $(top_builddir)/lib/.libs \ -I $(top_builddir)/gnulib/lib/.libs \ -I $(top_builddir)/ocaml \ + -I $(top_builddir)/common/mlstdutils \ -I $(top_builddir)/common/mlprogress \ -I $(top_builddir)/mllib if HAVE_OCAML_PKG_GETTEXT @@ -89,6 +90,7 @@ OBJECTS = $(XOBJECTS) endif OCAMLLINKFLAGS = \ + mlstdutils.$(MLARCHIVE) \ mlguestfs.$(MLARCHIVE) \ mlprogress.$(MLARCHIVE) \ mllib.$(MLARCHIVE) \ @@ -96,6 +98,7 @@ OCAMLLINKFLAGS = \ virt_sparsify_DEPENDENCIES = \ $(OBJECTS) \ + ../common/mlstdutils/mlstdutils.$(MLARCHIVE) \ ../mllib/mllib.$(MLARCHIVE) \ $(top_srcdir)/ocaml-link.sh virt_sparsify_LINK = \ @@ -142,7 +145,7 @@ depend: .depend .depend: $(wildcard $(abs_srcdir)/*.mli) $(wildcard $(abs_srcdir)/*.ml) rm -f $@ $@-t - $(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/mllib $^ | \ + $(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/common/mlstdutils -I $(abs_top_builddir)/mllib $^ | \ $(SED) 's/ *$$//' | \ $(SED) -e :a -e '/ *\\$$/N; s/ *\\\n */ /; ta' | \ $(SED) -e 's,$(abs_srcdir)/,$(builddir)/,g' | \ diff --git a/sparsify/cmdline.ml b/sparsify/cmdline.ml index 4629aa7a4..6e0594f12 100644 --- a/sparsify/cmdline.ml +++ b/sparsify/cmdline.ml @@ -20,8 +20,9 @@ open Printf -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Getopt.OptionName open Utils diff --git a/sparsify/copying.ml b/sparsify/copying.ml index 9042bd53d..02a53b9b4 100644 --- a/sparsify/copying.ml +++ b/sparsify/copying.ml @@ -23,6 +23,7 @@ open Unix open Printf +open Std_utils open Common_utils open Common_gettext.Gettext open Unix_utils diff --git a/sparsify/in_place.ml b/sparsify/in_place.ml index 88f30c0b3..1f3da2c70 100644 --- a/sparsify/in_place.ml +++ b/sparsify/in_place.ml @@ -21,6 +21,7 @@ open Unix open Printf +open Std_utils open Common_utils open Common_gettext.Gettext diff --git a/sparsify/utils.ml b/sparsify/utils.ml index 3bb64b737..27723c3a2 100644 --- a/sparsify/utils.ml +++ b/sparsify/utils.ml @@ -20,7 +20,7 @@ open Printf -open Common_utils +open Std_utils module G = Guestfs diff --git a/sysprep/Makefile.am b/sysprep/Makefile.am index 68cb1814a..c2adb1a6e 100644 --- a/sysprep/Makefile.am +++ b/sysprep/Makefile.am @@ -112,6 +112,7 @@ OCAMLPACKAGES = \ -I $(top_builddir)/gnulib/lib/.libs \ -I $(top_builddir)/ocaml \ -I $(top_builddir)/common/visit/.libs \ + -I $(top_builddir)/common/mlstdutils \ -I $(top_builddir)/common/mlvisit \ -I $(top_builddir)/mllib \ -I $(top_builddir)/customize @@ -137,6 +138,7 @@ OBJECTS = $(XOBJECTS) endif OCAMLLINKFLAGS = \ + mlstdutils.$(MLARCHIVE) \ mlguestfs.$(MLARCHIVE) \ mllib.$(MLARCHIVE) \ mlvisit.$(MLARCHIVE) \ @@ -145,6 +147,7 @@ OCAMLLINKFLAGS = \ virt_sysprep_DEPENDENCIES = \ $(OBJECTS) \ + ../common/mlstdutils/mlstdutils.$(MLARCHIVE) \ ../mllib/mllib.$(MLARCHIVE) \ ../customize/customize.$(MLARCHIVE) \ $(top_srcdir)/ocaml-link.sh @@ -213,7 +216,7 @@ depend: .depend .depend: $(wildcard $(abs_srcdir)/*.mli) $(wildcard $(abs_srcdir)/*.ml) rm -f $@ $@-t - $(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/mllib -I $(abs_top_builddir)/customize $^ | \ + $(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/mlstdutils -I $(abs_top_builddir)/mllib -I $(abs_top_builddir)/customize $^ | \ $(SED) 's/ *$$//' | \ $(SED) -e :a -e '/ *\\$$/N; s/ *\\\n */ /; ta' | \ $(SED) -e 's,$(abs_srcdir)/,$(builddir)/,g' | \ diff --git a/sysprep/main.ml b/sysprep/main.ml index 82164c62f..ab631c479 100644 --- a/sysprep/main.ml +++ b/sysprep/main.ml @@ -19,6 +19,7 @@ open Unix open Printf +open Std_utils open Common_utils open Common_gettext.Gettext open Getopt.OptionName diff --git a/sysprep/sysprep_operation.ml b/sysprep/sysprep_operation.ml index b2286f642..17d298fc1 100644 --- a/sysprep/sysprep_operation.ml +++ b/sysprep/sysprep_operation.ml @@ -16,10 +16,10 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -open Common_utils - open Printf +open Std_utils +open Common_utils open Common_gettext.Gettext open Getopt.OptionName diff --git a/sysprep/sysprep_operation_backup_files.ml b/sysprep/sysprep_operation_backup_files.ml index 6b1a100e6..64df8d758 100644 --- a/sysprep/sysprep_operation_backup_files.ml +++ b/sysprep/sysprep_operation_backup_files.ml @@ -18,8 +18,9 @@ open Printf -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Visit open Unix_utils.Fnmatch open Sysprep_operation diff --git a/sysprep/sysprep_operation_cron_spool.ml b/sysprep/sysprep_operation_cron_spool.ml index 063f75a83..f48a5201a 100644 --- a/sysprep/sysprep_operation_cron_spool.ml +++ b/sysprep/sysprep_operation_cron_spool.ml @@ -16,9 +16,11 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -open Sysprep_operation -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext + +open Sysprep_operation module G = Guestfs diff --git a/sysprep/sysprep_operation_net_hostname.ml b/sysprep/sysprep_operation_net_hostname.ml index 7284d630f..b455e5c93 100644 --- a/sysprep/sysprep_operation_net_hostname.ml +++ b/sysprep/sysprep_operation_net_hostname.ml @@ -16,10 +16,12 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) +open Std_utils open Common_utils -open Sysprep_operation open Common_gettext.Gettext +open Sysprep_operation + module G = Guestfs let net_hostname_perform (g : Guestfs.guestfs) root side_effects = diff --git a/sysprep/sysprep_operation_net_hwaddr.ml b/sysprep/sysprep_operation_net_hwaddr.ml index 439da6d81..21cae1be4 100644 --- a/sysprep/sysprep_operation_net_hwaddr.ml +++ b/sysprep/sysprep_operation_net_hwaddr.ml @@ -16,10 +16,12 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) +open Std_utils open Common_utils -open Sysprep_operation open Common_gettext.Gettext +open Sysprep_operation + module G = Guestfs let net_hwaddr_perform (g : Guestfs.guestfs) root side_effects = diff --git a/sysprep/sysprep_operation_script.ml b/sysprep/sysprep_operation_script.ml index aa656727e..cf911043a 100644 --- a/sysprep/sysprep_operation_script.ml +++ b/sysprep/sysprep_operation_script.ml @@ -19,9 +19,10 @@ open Printf open Unix -open Common_gettext.Gettext +open Std_utils open Common_utils open Unix_utils +open Common_gettext.Gettext open Getopt.OptionName open Sysprep_operation diff --git a/sysprep/sysprep_operation_user_account.ml b/sysprep/sysprep_operation_user_account.ml index 6f44b9dfd..2a633f5d8 100644 --- a/sysprep/sysprep_operation_user_account.ml +++ b/sysprep/sysprep_operation_user_account.ml @@ -19,6 +19,7 @@ open Printf +open Std_utils open Common_utils open Common_gettext.Gettext open Getopt.OptionName diff --git a/v2v/DOM.ml b/v2v/DOM.ml index 29ce64fa6..9986fc912 100644 --- a/v2v/DOM.ml +++ b/v2v/DOM.ml @@ -18,6 +18,7 @@ (* Poor man's XML DOM, mutable for ease of modification. *) +open Std_utils open Common_utils open Printf diff --git a/v2v/Makefile.am b/v2v/Makefile.am index 2de99ceb9..8a831a700 100644 --- a/v2v/Makefile.am +++ b/v2v/Makefile.am @@ -146,6 +146,7 @@ OCAMLPACKAGES = \ -I $(top_builddir)/lib/.libs \ -I $(top_builddir)/gnulib/lib/.libs \ -I $(top_builddir)/ocaml \ + -I $(top_builddir)/common/mlstdutils \ -I $(top_builddir)/common/mlxml \ -I $(top_builddir)/mllib \ -I $(top_builddir)/customize @@ -170,6 +171,7 @@ OBJECTS = $(XOBJECTS) endif OCAMLLINKFLAGS = \ + mlstdutils.$(MLARCHIVE) \ mlguestfs.$(MLARCHIVE) \ mlxml.$(MLARCHIVE) \ mllib.$(MLARCHIVE) \ @@ -210,6 +212,7 @@ endif virt_v2v_copy_to_local_DEPENDENCIES = \ $(COPY_TO_LOCAL_OBJECTS) \ + ../common/mlstdutils/mlstdutils.$(MLARCHIVE) \ ../common/mlxml/mlxml.$(MLARCHIVE) \ ../mllib/mllib.$(MLARCHIVE) \ $(top_srcdir)/ocaml-link.sh @@ -495,6 +498,7 @@ endif v2v_unit_tests_DEPENDENCIES = \ $(v2v_unit_tests_THEOBJECTS) \ + ../common/mlstdutils/mlstdutils.$(MLARCHIVE) \ ../common/mlxml/mlxml.$(MLARCHIVE) \ ../mllib/mllib.$(MLARCHIVE) \ $(top_srcdir)/ocaml-link.sh @@ -510,7 +514,7 @@ depend: .depend .depend: $(wildcard $(abs_srcdir)/*.mli) $(wildcard $(abs_srcdir)/*.ml) rm -f $@ $@-t - $(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/common/mlxml -I $(abs_top_builddir)/mllib -I $(abs_top_builddir)/customize $^ | \ + $(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/common/mlstdutils -I $(abs_top_builddir)/common/mlxml -I $(abs_top_builddir)/mllib -I $(abs_top_builddir)/customize $^ | \ $(SED) 's/ *$$//' | \ $(SED) -e :a -e '/ *\\$$/N; s/ *\\\n */ /; ta' | \ $(SED) -e 's,$(abs_srcdir)/,$(builddir)/,g' | \ diff --git a/v2v/changeuid.ml b/v2v/changeuid.ml index dbb05bc94..639fcfe12 100644 --- a/v2v/changeuid.ml +++ b/v2v/changeuid.ml @@ -21,9 +21,10 @@ open Unix open Printf +open Std_utils open Common_utils -open Common_gettext.Gettext open Unix_utils +open Common_gettext.Gettext open Utils diff --git a/v2v/cmdline.ml b/v2v/cmdline.ml index 70301ab40..a19510b3f 100644 --- a/v2v/cmdline.ml +++ b/v2v/cmdline.ml @@ -20,8 +20,9 @@ open Printf -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Getopt.OptionName open Types diff --git a/v2v/convert_linux.ml b/v2v/convert_linux.ml index 42a19947b..ffb43564f 100644 --- a/v2v/convert_linux.ml +++ b/v2v/convert_linux.ml @@ -28,8 +28,9 @@ open Printf -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Utils open Types diff --git a/v2v/convert_windows.ml b/v2v/convert_windows.ml index dfb90d079..2c8708878 100644 --- a/v2v/convert_windows.ml +++ b/v2v/convert_windows.ml @@ -18,8 +18,9 @@ open Printf -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Utils open Types diff --git a/v2v/copy_to_local.ml b/v2v/copy_to_local.ml index 88fd9abde..0a2b7ed75 100644 --- a/v2v/copy_to_local.ml +++ b/v2v/copy_to_local.ml @@ -20,8 +20,9 @@ open Printf -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Getopt.OptionName open Utils diff --git a/v2v/create_libvirt_xml.ml b/v2v/create_libvirt_xml.ml index 246cacd21..3f22f3764 100644 --- a/v2v/create_libvirt_xml.ml +++ b/v2v/create_libvirt_xml.ml @@ -18,8 +18,9 @@ open Printf -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Types open Utils diff --git a/v2v/create_ovf.ml b/v2v/create_ovf.ml index 6c7aba6d7..fd7ec5fe8 100644 --- a/v2v/create_ovf.ml +++ b/v2v/create_ovf.ml @@ -18,12 +18,13 @@ (* Create OVF and related files for RHV. *) -open Common_gettext.Gettext -open Common_utils - open Unix open Printf +open Std_utils +open Common_utils +open Common_gettext.Gettext + open Types open Utils open DOM diff --git a/v2v/input_disk.ml b/v2v/input_disk.ml index d28f45ece..a92f3a602 100644 --- a/v2v/input_disk.ml +++ b/v2v/input_disk.ml @@ -18,8 +18,9 @@ open Printf -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Types open Utils diff --git a/v2v/input_libvirtxml.ml b/v2v/input_libvirtxml.ml index d829ee523..570541d7d 100644 --- a/v2v/input_libvirtxml.ml +++ b/v2v/input_libvirtxml.ml @@ -18,8 +18,9 @@ open Printf -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Types open Parse_libvirt_xml diff --git a/v2v/input_ova.ml b/v2v/input_ova.ml index b509326dd..e8be68ed7 100644 --- a/v2v/input_ova.ml +++ b/v2v/input_ova.ml @@ -18,9 +18,10 @@ open Printf -open Common_gettext.Gettext +open Std_utils open Common_utils open Unix_utils +open Common_gettext.Gettext open Types open Utils diff --git a/v2v/input_vmx.ml b/v2v/input_vmx.ml index c48a0155a..bb1650ae9 100644 --- a/v2v/input_vmx.ml +++ b/v2v/input_vmx.ml @@ -19,8 +19,9 @@ open Printf open Scanf -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Types open Utils diff --git a/v2v/inspect_source.ml b/v2v/inspect_source.ml index 7476c3d85..e5d1fd3aa 100644 --- a/v2v/inspect_source.ml +++ b/v2v/inspect_source.ml @@ -18,6 +18,7 @@ open Printf +open Std_utils open Common_utils open Common_gettext.Gettext diff --git a/v2v/linux.ml b/v2v/linux.ml index 5f40c4196..799654511 100644 --- a/v2v/linux.ml +++ b/v2v/linux.ml @@ -18,8 +18,9 @@ open Printf -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Types open Utils diff --git a/v2v/linux_bootloaders.ml b/v2v/linux_bootloaders.ml index 33a6dc4e9..b5ad25508 100644 --- a/v2v/linux_bootloaders.ml +++ b/v2v/linux_bootloaders.ml @@ -18,8 +18,9 @@ open Printf -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Types open Utils diff --git a/v2v/linux_kernels.ml b/v2v/linux_kernels.ml index e8c3a93c6..6e1ca4bf1 100644 --- a/v2v/linux_kernels.ml +++ b/v2v/linux_kernels.ml @@ -20,8 +20,9 @@ open Printf -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Types diff --git a/v2v/modules_list.ml b/v2v/modules_list.ml index 3ee0bd7dc..e3c6d5934 100644 --- a/v2v/modules_list.ml +++ b/v2v/modules_list.ml @@ -16,7 +16,7 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -open Common_utils +open Std_utils let input_modules = ref [] and output_modules = ref [] diff --git a/v2v/output_glance.ml b/v2v/output_glance.ml index 3feb2e493..e26bc0732 100644 --- a/v2v/output_glance.ml +++ b/v2v/output_glance.ml @@ -18,9 +18,10 @@ open Printf -open Common_gettext.Gettext +open Std_utils open Common_utils open Unix_utils +open Common_gettext.Gettext open Types open Utils diff --git a/v2v/output_libvirt.ml b/v2v/output_libvirt.ml index b3e695387..61e1efddb 100644 --- a/v2v/output_libvirt.ml +++ b/v2v/output_libvirt.ml @@ -18,8 +18,9 @@ open Printf -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Types open Utils diff --git a/v2v/output_local.ml b/v2v/output_local.ml index 9c105ef8d..3553150ff 100644 --- a/v2v/output_local.ml +++ b/v2v/output_local.ml @@ -18,8 +18,9 @@ open Printf -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Types open Utils diff --git a/v2v/output_null.ml b/v2v/output_null.ml index b0e99b4de..9b31c2d00 100644 --- a/v2v/output_null.ml +++ b/v2v/output_null.ml @@ -18,9 +18,10 @@ open Printf -open Common_gettext.Gettext +open Std_utils open Common_utils open Unix_utils +open Common_gettext.Gettext open Types open Utils diff --git a/v2v/output_qemu.ml b/v2v/output_qemu.ml index 031279cb3..00814e8f0 100644 --- a/v2v/output_qemu.ml +++ b/v2v/output_qemu.ml @@ -18,8 +18,9 @@ open Printf -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Types open Utils diff --git a/v2v/output_rhv.ml b/v2v/output_rhv.ml index 82e745a94..0c02df612 100644 --- a/v2v/output_rhv.ml +++ b/v2v/output_rhv.ml @@ -16,9 +16,10 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -open Common_gettext.Gettext +open Std_utils open Common_utils open Unix_utils +open Common_gettext.Gettext open Unix open Printf diff --git a/v2v/output_vdsm.ml b/v2v/output_vdsm.ml index d8cd20156..361a8e555 100644 --- a/v2v/output_vdsm.ml +++ b/v2v/output_vdsm.ml @@ -16,8 +16,9 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Unix open Printf diff --git a/v2v/parse_libvirt_xml.ml b/v2v/parse_libvirt_xml.ml index 4ac9b51a5..56f9ea297 100644 --- a/v2v/parse_libvirt_xml.ml +++ b/v2v/parse_libvirt_xml.ml @@ -18,12 +18,13 @@ open Printf -open Common_gettext.Gettext +open Std_utils open Common_utils - -open Types +open Common_gettext.Gettext open Xpath_helpers +open Types + type parsed_disk = { p_source_disk : source_disk; p_source : parsed_source; diff --git a/v2v/parse_ovf_from_ova.ml b/v2v/parse_ovf_from_ova.ml index 2a3752776..6dc032407 100644 --- a/v2v/parse_ovf_from_ova.ml +++ b/v2v/parse_ovf_from_ova.ml @@ -18,9 +18,10 @@ (* Parse OVF from an externally produced OVA file. *) -open Common_gettext.Gettext +open Std_utils open Common_utils open Unix_utils +open Common_gettext.Gettext open Types open Utils diff --git a/v2v/parse_vmx.ml b/v2v/parse_vmx.ml index 33ec17d3d..770dc29d3 100644 --- a/v2v/parse_vmx.ml +++ b/v2v/parse_vmx.ml @@ -18,6 +18,7 @@ open Printf +open Std_utils open Common_utils open Common_gettext.Gettext diff --git a/v2v/target_bus_assignment.ml b/v2v/target_bus_assignment.ml index a9010c245..de6b0148d 100644 --- a/v2v/target_bus_assignment.ml +++ b/v2v/target_bus_assignment.ml @@ -16,6 +16,7 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) +open Std_utils open Common_utils open Common_gettext.Gettext diff --git a/v2v/test-harness/Makefile.am b/v2v/test-harness/Makefile.am index 9a548022a..bcfcdf21d 100644 --- a/v2v/test-harness/Makefile.am +++ b/v2v/test-harness/Makefile.am @@ -42,6 +42,7 @@ OCAMLPACKAGES = \ -I $(top_builddir)/lib/.libs \ -I $(top_builddir)/gnulib/lib/.libs \ -I $(top_builddir)/ocaml \ + -I $(top_builddir)/common/mlstdutils \ -I $(top_builddir)/common/mlxml \ -I $(top_builddir)/mllib \ -I $(top_builddir)/v2v @@ -129,7 +130,7 @@ depend: .depend .depend: $(wildcard $(abs_srcdir)/*.mli) $(wildcard $(abs_srcdir)/*.ml) rm -f $@ $@-t - $(OCAMLFIND) ocamldep -I ../../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/common/mlxml -I $(abs_top_builddir)/mllib -I $(abs_top_builddir)/customize -I $(abs_top_builddir)/v2v $^ | \ + $(OCAMLFIND) ocamldep -I ../../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/common/mlstdutils -I $(abs_top_builddir)/common/mlxml -I $(abs_top_builddir)/mllib -I $(abs_top_builddir)/customize -I $(abs_top_builddir)/v2v $^ | \ $(SED) 's/ *$$//' | \ $(SED) -e :a -e '/ *\\$$/N; s/ *\\\n */ /; ta' | \ $(SED) -e 's,$(abs_srcdir)/,$(builddir)/,g' | \ diff --git a/v2v/test-harness/v2v_test_harness.ml b/v2v/test-harness/v2v_test_harness.ml index 3c29a9430..ba8c5eeab 100644 --- a/v2v/test-harness/v2v_test_harness.ml +++ b/v2v/test-harness/v2v_test_harness.ml @@ -23,6 +23,7 @@ module D = Libvirt.Domain open Unix open Printf +open Std_utils open Common_utils type test_plan = { diff --git a/v2v/utils.ml b/v2v/utils.ml index e0275db53..0dab5816e 100644 --- a/v2v/utils.ml +++ b/v2v/utils.ml @@ -20,8 +20,9 @@ open Printf -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext external drive_name : int -> string = "v2v_utils_drive_name" external drive_index : string -> int = "v2v_utils_drive_index" diff --git a/v2v/v2v.ml b/v2v/v2v.ml index 59f5ef17e..f1ce9335a 100644 --- a/v2v/v2v.ml +++ b/v2v/v2v.ml @@ -19,9 +19,10 @@ open Unix open Printf -open Common_gettext.Gettext +open Std_utils open Common_utils open Unix_utils +open Common_gettext.Gettext open Types open Utils diff --git a/v2v/v2v_unit_tests.ml b/v2v/v2v_unit_tests.ml index 7f98e09d3..be0bf0172 100644 --- a/v2v/v2v_unit_tests.ml +++ b/v2v/v2v_unit_tests.ml @@ -18,13 +18,15 @@ (* This file tests individual virt-v2v functions. *) -open OUnit2 -open Types - open Printf +open OUnit2 + +open Std_utils open Common_utils +open Types + let inspect_defaults = { i_type = ""; i_distro = ""; i_arch = ""; i_major_version = 0; i_minor_version = 0; diff --git a/v2v/vCenter.ml b/v2v/vCenter.ml index 468261d3d..d84bf8b58 100644 --- a/v2v/vCenter.ml +++ b/v2v/vCenter.ml @@ -18,6 +18,7 @@ open Printf +open Std_utils open Common_utils open Common_gettext.Gettext diff --git a/v2v/windows_virtio.ml b/v2v/windows_virtio.ml index 9891a770c..76af7ab2f 100644 --- a/v2v/windows_virtio.ml +++ b/v2v/windows_virtio.ml @@ -18,8 +18,9 @@ open Printf -open Common_gettext.Gettext +open Std_utils open Common_utils +open Common_gettext.Gettext open Regedit -- 2.13.0

This is present in the daemon, but the function could be used throughout the code. --- common/cleanups/cleanups.h | 4 ++++ common/cleanups/stdlib-cleanups.c | 9 +++++++++ 2 files changed, 13 insertions(+) diff --git a/common/cleanups/cleanups.h b/common/cleanups/cleanups.h index 211bce98a..70021e94e 100644 --- a/common/cleanups/cleanups.h +++ b/common/cleanups/cleanups.h @@ -26,6 +26,8 @@ __attribute__((cleanup(guestfs_int_cleanup_hash_free))) #define CLEANUP_UNLINK_FREE \ __attribute__((cleanup(guestfs_int_cleanup_unlink_free))) +#define CLEANUP_CLOSE \ + __attribute__((cleanup(guestfs_int_cleanup_close))) #define CLEANUP_FCLOSE \ __attribute__((cleanup(guestfs_int_cleanup_fclose))) #define CLEANUP_PCLOSE \ @@ -48,6 +50,7 @@ #define CLEANUP_FREE #define CLEANUP_HASH_FREE #define CLEANUP_UNLINK_FREE +#define CLEANUP_CLOSE #define CLEANUP_FCLOSE #define CLEANUP_PCLOSE #define CLEANUP_XMLFREE @@ -65,6 +68,7 @@ extern void guestfs_int_cleanup_free (void *ptr); extern void guestfs_int_cleanup_hash_free (void *ptr); extern void guestfs_int_cleanup_unlink_free (char **ptr); +extern void guestfs_int_cleanup_close (void *ptr); extern void guestfs_int_cleanup_fclose (void *ptr); extern void guestfs_int_cleanup_pclose (void *ptr); extern void guestfs_int_cleanup_xmlFree (void *ptr); diff --git a/common/cleanups/stdlib-cleanups.c b/common/cleanups/stdlib-cleanups.c index 0512a86a2..e77708db4 100644 --- a/common/cleanups/stdlib-cleanups.c +++ b/common/cleanups/stdlib-cleanups.c @@ -83,6 +83,15 @@ guestfs_int_cleanup_unlink_free (char **ptr) } void +guestfs_int_cleanup_close (void *ptr) +{ + const int fd = * (int *) ptr; + + if (fd >= 0) + close (fd); +} + +void guestfs_int_cleanup_fclose (void *ptr) { FILE *f = * (FILE **) ptr; -- 2.13.0

This was only used inside the library, so move it there. --- .gitignore | 2 +- common/utils/Makefile.am | 4 +--- common/utils/guestfs-internal-frontend.h | 12 ------------ docs/C_SOURCE_FILES | 2 +- generator/UEFI.ml | 3 ++- generator/main.ml | 2 +- lib/Makefile.am | 3 ++- lib/appliance-uefi.c | 2 +- lib/guestfs-internal.h | 12 ++++++++++++ 9 files changed, 21 insertions(+), 21 deletions(-) diff --git a/.gitignore b/.gitignore index 97fe2f050..e0dbe280c 100644 --- a/.gitignore +++ b/.gitignore @@ -141,7 +141,6 @@ Makefile.in /common/utils/structs-cleanup.c /common/utils/structs-print.c /common/utils/structs-print.h -/common/utils/uefi.c /compile /config.cache /config.guess @@ -341,6 +340,7 @@ Makefile.in /lib/structs-copy.c /lib/structs-free.c /lib/unit-tests +/lib/uefi.c /libguestfs.spec /libguestfs-*.tar.gz /libtool diff --git a/common/utils/Makefile.am b/common/utils/Makefile.am index 485909bbe..47a4186d7 100644 --- a/common/utils/Makefile.am +++ b/common/utils/Makefile.am @@ -21,8 +21,7 @@ generator_built = \ guestfs-internal-frontend-cleanups.h \ structs-cleanup.c \ structs-print.c \ - structs-print.h \ - uefi.c + structs-print.h BUILT_SOURCES = \ $(generator_built) @@ -39,7 +38,6 @@ libutils_la_SOURCES = \ structs-cleanup.c \ structs-print.c \ structs-print.h \ - uefi.c \ utils.c libutils_la_CPPFLAGS = \ -DGUESTFS_WARN_DEPRECATED=1 \ diff --git a/common/utils/guestfs-internal-frontend.h b/common/utils/guestfs-internal-frontend.h index a7aecee76..366444b31 100644 --- a/common/utils/guestfs-internal-frontend.h +++ b/common/utils/guestfs-internal-frontend.h @@ -71,18 +71,6 @@ extern void guestfs_int_fadvise_noreuse (int fd); extern char *guestfs_int_shell_unquote (const char *str); extern void guestfs_int_cleanup_free_string_list (char ***ptr); -/* uefi.c */ -struct uefi_firmware { - const char *code; /* code file (NULL = end of list) */ - const char *code_debug; /* code file with debugging msgs (may be NULL)*/ - const char *vars; /* vars template file */ - int flags; /* various flags, see below */ -#define UEFI_FLAG_SECURE_BOOT_REQUIRED 1 /* secure boot (see RHBZ#1367615) */ -}; -extern struct uefi_firmware guestfs_int_uefi_i386_firmware[]; -extern struct uefi_firmware guestfs_int_uefi_x86_64_firmware[]; -extern struct uefi_firmware guestfs_int_uefi_aarch64_firmware[]; - /* These are in a separate header so the header can be generated. * Don't include the following file directly: */ diff --git a/docs/C_SOURCE_FILES b/docs/C_SOURCE_FILES index ceed9581d..0ba99e259 100644 --- a/docs/C_SOURCE_FILES +++ b/docs/C_SOURCE_FILES @@ -51,7 +51,6 @@ common/utils/guestfs-internal-frontend.h common/utils/structs-cleanup.c common/utils/structs-print.c common/utils/structs-print.h -common/utils/uefi.c common/utils/utils.c common/visit/visit.c common/visit/visit.h @@ -333,6 +332,7 @@ lib/structs-copy.c lib/structs-free.c lib/tmpdirs.c lib/tsk.c +lib/uefi.c lib/umask.c lib/unit-tests.c lib/version.c diff --git a/generator/UEFI.ml b/generator/UEFI.ml index 5c5e02bab..17418f473 100644 --- a/generator/UEFI.ml +++ b/generator/UEFI.ml @@ -86,7 +86,8 @@ let generate_uefi_c () = pr "\n"; pr "#include <stdio.h>\n"; pr "\n"; - pr "#include \"guestfs-internal-frontend.h\"\n"; + pr "#include \"guestfs.h\"\n"; + pr "#include \"guestfs-internal.h\"\n"; List.iter ( fun arch -> diff --git a/generator/main.ml b/generator/main.ml index 0e1c01f74..8ff698130 100644 --- a/generator/main.ml +++ b/generator/main.ml @@ -94,7 +94,7 @@ Run it from the top source directory using the command C.generate_client_structs_print_c; output_to "common/utils/structs-print.h" C.generate_client_structs_print_h; - output_to "common/utils/uefi.c" + output_to "lib/uefi.c" UEFI.generate_uefi_c; output_to "lib/guestfs.h" C.generate_guestfs_h; diff --git a/lib/Makefile.am b/lib/Makefile.am index 90c657514..12fdbcd6c 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -124,10 +124,11 @@ libguestfs_la_SOURCES = \ structs-free.c \ tmpdirs.c \ tsk.c \ + uefi.c \ umask.c \ + version.c \ wait.c \ whole-file.c \ - version.c \ yara.c \ libguestfs.syms diff --git a/lib/appliance-uefi.c b/lib/appliance-uefi.c index 1612c5db5..986989e67 100644 --- a/lib/appliance-uefi.c +++ b/lib/appliance-uefi.c @@ -19,7 +19,7 @@ /** * Find the UEFI firmware needed to boot the appliance. * - * See also F<common/utils/uefi.c> (autogenerated file) containing the + * See also F<lib/uefi.c> (autogenerated file) containing the * firmware file locations. */ diff --git a/lib/guestfs-internal.h b/lib/guestfs-internal.h index bc289cabc..d218f22b4 100644 --- a/lib/guestfs-internal.h +++ b/lib/guestfs-internal.h @@ -996,4 +996,16 @@ extern bool guestfs_int_version_cmp_ge (const struct version *a, const struct ve #define version_init_null(v) guestfs_int_version_from_values (v, 0, 0, 0) #define version_is_null(v) ((v)->v_major == 0 && (v)->v_minor == 0 && (v)->v_micro == 0) +/* uefi.c */ +struct uefi_firmware { + const char *code; /* code file (NULL = end of list) */ + const char *code_debug; /* code file with debugging msgs (may be NULL)*/ + const char *vars; /* vars template file */ + int flags; /* various flags, see below */ +#define UEFI_FLAG_SECURE_BOOT_REQUIRED 1 /* secure boot (see RHBZ#1367615) */ +}; +extern struct uefi_firmware guestfs_int_uefi_i386_firmware[]; +extern struct uefi_firmware guestfs_int_uefi_x86_64_firmware[]; +extern struct uefi_firmware guestfs_int_uefi_aarch64_firmware[]; + #endif /* GUESTFS_INTERNAL_H_ */ -- 2.13.0

Create a module ‘C_utils’ containing functions like ‘drive_name’ and ‘shell_unquote’ which come from the C utilities. The new directory ‘common/mlutils’ also contains the ‘Unix_utils’ wrappers around POSIX functions missing from the OCaml stdlib. --- .gitignore | 3 + Makefile.am | 24 ++--- builder/Makefile.am | 6 +- common/mlutils/Makefile.am | 156 ++++++++++++++++++++++++++++ v2v/utils-c.c => common/mlutils/c_utils-c.c | 6 +- common/mlutils/c_utils.ml | 26 +++++ common/mlutils/c_utils.mli | 30 ++++++ common/mlutils/c_utils_unit_tests.ml | 81 +++++++++++++++ common/mlutils/dummy.c | 2 + {mllib => common/mlutils}/unix_utils-c.c | 0 {mllib => common/mlutils}/unix_utils.ml | 0 {mllib => common/mlutils}/unix_utils.mli | 0 configure.ac | 1 + customize/Makefile.am | 5 +- dib/Makefile.am | 6 +- docs/C_SOURCE_FILES | 5 +- docs/guestfs-hacking.pod | 5 + get-kernel/Makefile.am | 5 +- mllib/Makefile.am | 8 +- resize/Makefile.am | 6 +- sparsify/Makefile.am | 6 +- sysprep/Makefile.am | 5 +- v2v/Makefile.am | 12 ++- v2v/convert_linux.ml | 3 +- v2v/create_libvirt_xml.ml | 1 + v2v/parse_libvirt_xml.ml | 3 +- v2v/utils.ml | 5 - v2v/utils.mli | 11 -- v2v/v2v.ml | 1 + v2v/v2v_unit_tests.ml | 46 -------- 30 files changed, 371 insertions(+), 97 deletions(-) create mode 100644 common/mlutils/Makefile.am rename v2v/utils-c.c => common/mlutils/c_utils-c.c (93%) create mode 100644 common/mlutils/c_utils.ml create mode 100644 common/mlutils/c_utils.mli create mode 100644 common/mlutils/c_utils_unit_tests.ml create mode 100644 common/mlutils/dummy.c rename {mllib => common/mlutils}/unix_utils-c.c (100%) rename {mllib => common/mlutils}/unix_utils.ml (100%) rename {mllib => common/mlutils}/unix_utils.mli (100%) diff --git a/.gitignore b/.gitignore index 934d9f291..b20b5f5b8 100644 --- a/.gitignore +++ b/.gitignore @@ -130,6 +130,9 @@ Makefile.in /common/mlstdutils/libdir.ml /common/mlstdutils/oUnit-* /common/mlstdutils/std_utils_tests +/common/mlutils/.depend +/common/mlutils/c_utils_unit_tests +/common/mlutils/oUnit-* /common/mlvisit/.depend /common/mlvisit/visit_tests /common/mlxml/.depend diff --git a/Makefile.am b/Makefile.am index b3eb35349..509bcae83 100644 --- a/Makefile.am +++ b/Makefile.am @@ -156,18 +156,18 @@ SUBDIRS += csharp # OCaml tools. Note 'common/ml*', 'mllib' and 'customize' contain # shared code used by other OCaml tools, so these must come first. if HAVE_OCAML -SUBDIRS += \ - common/mlprogress \ - common/mlvisit \ - common/mlxml \ - mllib \ - customize \ - builder builder/templates \ - get-kernel \ - resize \ - sparsify \ - sysprep \ - v2v +SUBDIRS += common/mlutils +SUBDIRS += common/mlprogress +SUBDIRS += common/mlvisit +SUBDIRS += common/mlxml +SUBDIRS += mllib +SUBDIRS += customize +SUBDIRS += builder builder/templates +SUBDIRS += get-kernel +SUBDIRS += resize +SUBDIRS += sparsify +SUBDIRS += sysprep +SUBDIRS += v2v if HAVE_OCAML_PKG_LIBVIRT SUBDIRS += v2v/test-harness endif diff --git a/builder/Makefile.am b/builder/Makefile.am index cfe302f9d..355cfd0d1 100644 --- a/builder/Makefile.am +++ b/builder/Makefile.am @@ -127,6 +127,7 @@ OCAMLPACKAGES = \ -I $(top_builddir)/gnulib/lib/.libs \ -I $(top_builddir)/ocaml \ -I $(top_builddir)/common/mlstdutils \ + -I $(top_builddir)/common/mlutils \ -I $(top_builddir)/mllib \ -I $(top_builddir)/customize OCAMLPACKAGES_TESTS = @@ -160,6 +161,7 @@ endif OCAMLLINKFLAGS = \ mlstdutils.$(MLARCHIVE) \ mlguestfs.$(MLARCHIVE) \ + mlcutils.$(MLARCHIVE) \ mllib.$(MLARCHIVE) \ customize.$(MLARCHIVE) \ $(LINK_CUSTOM_OCAMLC_ONLY) @@ -167,6 +169,7 @@ OCAMLLINKFLAGS = \ virt_builder_DEPENDENCIES = \ $(OBJECTS) \ ../common/mlstdutils/mlstdutils.$(MLARCHIVE) \ + ../common/mlutils/mlcutils.$(MLARCHIVE) \ ../mllib/mllib.$(MLARCHIVE) \ ../customize/customize.$(MLARCHIVE) \ $(top_srcdir)/ocaml-link.sh @@ -239,6 +242,7 @@ endif yajl_tests_DEPENDENCIES = \ $(yajl_tests_THEOBJECTS) \ ../common/mlstdutils/mlstdutils.$(MLARCHIVE) \ + ../common/mlutils/mlcutils.$(MLARCHIVE) \ ../mllib/mllib.$(MLARCHIVE) \ ../customize/customize.$(MLARCHIVE) \ $(top_srcdir)/ocaml-link.sh @@ -310,7 +314,7 @@ depend: .depend .depend: $(wildcard $(abs_srcdir)/*.mli) $(wildcard $(abs_srcdir)/*.ml) rm -f $@ $@-t - $(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/mlstdutils -I $(abs_top_builddir)/mllib -I $(abs_top_builddir)/customize $^ | \ + $(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/mlstdutils -I $(abs_top_builddir)/mlutils -I $(abs_top_builddir)/mllib -I $(abs_top_builddir)/customize $^ | \ $(SED) 's/ *$$//' | \ $(SED) -e :a -e '/ *\\$$/N; s/ *\\\n */ /; ta' | \ $(SED) -e 's,$(abs_srcdir)/,$(builddir)/,g' | \ diff --git a/common/mlutils/Makefile.am b/common/mlutils/Makefile.am new file mode 100644 index 000000000..d2cc9c36f --- /dev/null +++ b/common/mlutils/Makefile.am @@ -0,0 +1,156 @@ +# libguestfs OCaml tools common code +# Copyright (C) 2011-2017 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 $(top_srcdir)/subdir-rules.mk + +EXTRA_DIST = \ + $(SOURCES_MLI) \ + $(SOURCES_ML) \ + $(SOURCES_C) + +SOURCES_MLI = \ + c_utils.mli \ + unix_utils.mli + +SOURCES_ML = \ + c_utils.ml \ + unix_utils.ml + +SOURCES_C = \ + c_utils-c.c \ + unix_utils-c.c + +if HAVE_OCAML + +# We pretend that we're building a C library. automake handles the +# compilation of the C sources for us. At the end we take the C +# objects and OCaml objects and link them into the OCaml library. +# This C library is never used. + +noinst_LIBRARIES = libmlcutils.a + +if !HAVE_OCAMLOPT +MLCUTILS_CMA = mlcutils.cma +else +MLCUTILS_CMA = mlcutils.cmxa +endif + +noinst_DATA = $(MLCUTILS_CMA) + +# lib/guestfs-internal-all.h header is used here. It probably +# shouldn't be located under lib. XXX +libmlcutils_a_SOURCES = $(SOURCES_C) +libmlcutils_a_CPPFLAGS = \ + -I. \ + -I$(top_builddir) \ + -I$(top_srcdir)/gnulib/lib -I$(top_builddir)/gnulib/lib \ + -I$(top_srcdir)/common/cleanups -I$(top_builddir)/common/cleanups \ + -I$(top_srcdir)/common/utils -I$(top_builddir)/common/utils \ + -I$(top_srcdir)/lib -I$(top_builddir)/lib \ + -I$(shell $(OCAMLC) -where) +libmlcutils_a_CFLAGS = \ + $(WARN_CFLAGS) $(WERROR_CFLAGS) \ + -fPIC + +BOBJECTS = $(SOURCES_ML:.ml=.cmo) +XOBJECTS = $(BOBJECTS:.cmo=.cmx) + +OCAMLPACKAGES = \ + -package str,unix \ + -I $(top_builddir)/gnulib/lib/.libs \ + -I $(top_builddir)/common/utils/.libs \ + -I $(top_builddir)/common/cleanups/.libs \ + -I $(top_builddir)/common/mlstdutils \ + -I $(builddir) + +OCAMLFLAGS = $(OCAML_FLAGS) $(OCAML_WARN_ERROR) + +if !HAVE_OCAMLOPT +OBJECTS = $(BOBJECTS) +else +OBJECTS = $(XOBJECTS) +endif + +libmlcutils_a_DEPENDENCIES = $(OBJECTS) + +$(MLCUTILS_CMA): $(OBJECTS) libmlcutils.a + $(OCAMLFIND) mklib $(OCAMLPACKAGES) \ + $(OBJECTS) $(libmlcutils_a_OBJECTS) \ + -cclib -lutils -cclib -lcleanups \ + -o mlcutils + +# Tests. + +TESTS = +check_PROGRAMS = + +if HAVE_OCAML_PKG_OUNIT +TESTS += c_utils_unit_tests +check_PROGRAMS += c_utils_unit_tests +endif + +c_utils_unit_tests_BOBJECTS = \ + c_utils_unit_tests.cmo +c_utils_unit_tests_XOBJECTS = $(c_utils_unit_tests_BOBJECTS:.cmo=.cmx) + +c_utils_unit_tests_SOURCES = dummy.c +c_utils_unit_tests_CPPFLAGS = $(libmlcutils_a_CPPFLAGS) +c_utils_unit_tests_CFLAGS = $(libmlcutils_a_CFLAGS) + +if !HAVE_OCAMLOPT +# Can't call this c_utils_unit_tests_OBJECTS because automake gets confused. +c_utils_unit_tests_THEOBJECTS = $(c_utils_unit_tests_BOBJECTS) +c_utils_unit_tests.cmo: OCAMLPACKAGES += -package oUnit +else +c_utils_unit_tests_THEOBJECTS = $(c_utils_unit_tests_XOBJECTS) +c_utils_unit_tests.cmx: OCAMLPACKAGES += -package oUnit +endif + +OCAMLLINKFLAGS = \ + mlstdutils.$(MLARCHIVE) \ + mlcutils.$(MLARCHIVE) \ + $(LINK_CUSTOM_OCAMLC_ONLY) + +c_utils_unit_tests_DEPENDENCIES = \ + $(c_utils_unit_tests_THEOBJECTS) \ + ../mlstdutils/mlstdutils.$(MLARCHIVE) \ + mlcutils.$(MLARCHIVE) \ + $(top_srcdir)/ocaml-link.sh +c_utils_unit_tests_LINK = \ + $(top_srcdir)/ocaml-link.sh -cclib '-lutils -lcleanups -lgnu' -- \ + $(OCAMLFIND) $(BEST) $(OCAMLFLAGS) \ + $(OCAMLPACKAGES) -package oUnit \ + $(OCAMLLINKFLAGS) \ + $(c_utils_unit_tests_THEOBJECTS) -o $@ + +# Dependencies. +depend: .depend + +.depend: $(wildcard $(abs_srcdir)/*.mli) $(wildcard $(abs_srcdir)/*.ml) + rm -f $@ $@-t + $(OCAMLFIND) ocamldep -I $(abs_srcdir) $^ | \ + $(SED) 's/ *$$//' | \ + $(SED) -e :a -e '/ *\\$$/N; s/ *\\\n */ /; ta' | \ + $(SED) -e 's,$(abs_srcdir)/,$(builddir)/,g' | \ + sort > $@-t + mv $@-t $@ + +-include .depend + +endif + +.PHONY: depend docs diff --git a/v2v/utils-c.c b/common/mlutils/c_utils-c.c similarity index 93% rename from v2v/utils-c.c rename to common/mlutils/c_utils-c.c index 69b070fc2..32edbd4a7 100644 --- a/v2v/utils-c.c +++ b/common/mlutils/c_utils-c.c @@ -41,7 +41,7 @@ extern void unix_error (int errcode, char * cmdname, value arg) Noreturn; #pragma GCC diagnostic ignored "-Wmissing-prototypes" value -v2v_utils_drive_name (value indexv) +guestfs_int_mlutils_drive_name (value indexv) { CAMLparam1 (indexv); CAMLlocal1 (namev); @@ -54,7 +54,7 @@ v2v_utils_drive_name (value indexv) } value -v2v_utils_drive_index (value strv) +guestfs_int_mlutils_drive_index (value strv) { CAMLparam1 (strv); ssize_t r; @@ -67,7 +67,7 @@ v2v_utils_drive_index (value strv) } value -v2v_utils_shell_unquote (value strv) +guestfs_int_mlutils_shell_unquote (value strv) { CAMLparam1 (strv); CAMLlocal1 (retv); diff --git a/common/mlutils/c_utils.ml b/common/mlutils/c_utils.ml new file mode 100644 index 000000000..e4263962d --- /dev/null +++ b/common/mlutils/c_utils.ml @@ -0,0 +1,26 @@ +(* virt-v2v + * Copyright (C) 2009-2017 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. + *) + +(* OCaml bindings for C utility functions in [common/utils]. *) + +open Printf + +external drive_name : int -> string = "guestfs_int_mlutils_drive_name" +external drive_index : string -> int = "guestfs_int_mlutils_drive_index" + +external shell_unquote : string -> string = "guestfs_int_mlutils_shell_unquote" diff --git a/common/mlutils/c_utils.mli b/common/mlutils/c_utils.mli new file mode 100644 index 000000000..7824f9658 --- /dev/null +++ b/common/mlutils/c_utils.mli @@ -0,0 +1,30 @@ +(* virt-v2v + * Copyright (C) 2009-2017 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. + *) + +(** OCaml bindings for C utility functions in [common/utils]. *) + +val drive_name : int -> string +val drive_index : string -> int + +val shell_unquote : string -> string +(** If the string looks like a shell quoted string, then attempt to + unquote it. + + This is just intended to deal with quoting in configuration files + (like ones under /etc/sysconfig), and it doesn't deal with some + situations such as $variable interpolation. *) diff --git a/common/mlutils/c_utils_unit_tests.ml b/common/mlutils/c_utils_unit_tests.ml new file mode 100644 index 000000000..8840d6620 --- /dev/null +++ b/common/mlutils/c_utils_unit_tests.ml @@ -0,0 +1,81 @@ +(* virt-v2v + * Copyright (C) 2011-2017 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. + *) + +(* This file tests individual OCaml bindings for C utility functions. *) + +open Printf + +open OUnit2 + +open Std_utils +open C_utils + +let test_drive_name ctx = + let printer = identity in + assert_equal ~printer "a" (drive_name 0); + assert_equal ~printer "z" (drive_name 25); + assert_equal ~printer "aa" (drive_name 26); + assert_equal ~printer "ab" (drive_name 27); + assert_equal ~printer "az" (drive_name 51); + assert_equal ~printer "ba" (drive_name 52); + assert_equal ~printer "zz" (drive_name 701); + assert_equal ~printer "aaa" (drive_name 702); + assert_equal ~printer "zzz" (drive_name 18277) + +let test_drive_index ctx = + let printer = string_of_int in + assert_equal ~printer 0 (drive_index "a"); + assert_equal ~printer 25 (drive_index "z"); + assert_equal ~printer 26 (drive_index "aa"); + assert_equal ~printer 27 (drive_index "ab"); + assert_equal ~printer 51 (drive_index "az"); + assert_equal ~printer 52 (drive_index "ba"); + assert_equal ~printer 701 (drive_index "zz"); + assert_equal ~printer 702 (drive_index "aaa"); + assert_equal ~printer 18277 (drive_index "zzz"); + let exn = Invalid_argument "drive_index: invalid parameter" in + assert_raises exn (fun () -> drive_index ""); + assert_raises exn (fun () -> drive_index "abc123"); + assert_raises exn (fun () -> drive_index "123"); + assert_raises exn (fun () -> drive_index "Z"); + assert_raises exn (fun () -> drive_index "aB") + +let test_shell_unquote ctx = + let printer = identity in + assert_equal ~printer "a" (shell_unquote "a"); + assert_equal ~printer "b" (shell_unquote "'b'"); + assert_equal ~printer "c" (shell_unquote "\"c\""); + assert_equal ~printer "dd" (shell_unquote "\"dd\""); + assert_equal ~printer "e\\e" (shell_unquote "\"e\\\\e\""); + assert_equal ~printer "f\\" (shell_unquote "\"f\\\\\""); + assert_equal ~printer "\\g" (shell_unquote "\"\\\\g\""); + assert_equal ~printer "h\\-h" (shell_unquote "\"h\\-h\""); + assert_equal ~printer "i`" (shell_unquote "\"i\\`\""); + assert_equal ~printer "j\"" (shell_unquote "\"j\\\"\"") + +(* Suites declaration. *) +let suite = + "C_utils" >::: + [ + "C_utils.drive_name" >:: test_drive_name; + "C_utils.drive_index" >:: test_drive_index; + "C_utils.shell_unquote" >:: test_shell_unquote; + ] + +let () = + run_test_tt_main suite diff --git a/common/mlutils/dummy.c b/common/mlutils/dummy.c new file mode 100644 index 000000000..ebab6198c --- /dev/null +++ b/common/mlutils/dummy.c @@ -0,0 +1,2 @@ +/* Dummy source, to be used for OCaml-based tools with no C sources. */ +enum { foo = 1 }; diff --git a/mllib/unix_utils-c.c b/common/mlutils/unix_utils-c.c similarity index 100% rename from mllib/unix_utils-c.c rename to common/mlutils/unix_utils-c.c diff --git a/mllib/unix_utils.ml b/common/mlutils/unix_utils.ml similarity index 100% rename from mllib/unix_utils.ml rename to common/mlutils/unix_utils.ml diff --git a/mllib/unix_utils.mli b/common/mlutils/unix_utils.mli similarity index 100% rename from mllib/unix_utils.mli rename to common/mlutils/unix_utils.mli diff --git a/configure.ac b/configure.ac index 9b7f61a2e..000c09868 100644 --- a/configure.ac +++ b/configure.ac @@ -189,6 +189,7 @@ AC_CONFIG_FILES([Makefile common/mlprogress/Makefile common/mlstdutils/Makefile common/mlstdutils/guestfs_config.ml + common/mlutils/Makefile common/mlvisit/Makefile common/mlxml/Makefile common/options/Makefile diff --git a/customize/Makefile.am b/customize/Makefile.am index 815513b25..b845e512f 100644 --- a/customize/Makefile.am +++ b/customize/Makefile.am @@ -126,6 +126,7 @@ OCAMLPACKAGES = \ -I $(top_builddir)/gnulib/lib/.libs \ -I $(top_builddir)/ocaml \ -I $(top_builddir)/common/mlstdutils \ + -I $(top_builddir)/common/mlutils \ -I $(top_builddir)/mllib \ -I $(builddir) if HAVE_OCAML_PKG_GETTEXT @@ -155,6 +156,7 @@ endif OCAMLLINKFLAGS = \ mlstdutils.$(MLARCHIVE) \ mlguestfs.$(MLARCHIVE) \ + mlcutils.$(MLARCHIVE) \ mllib.$(MLARCHIVE) \ customize.$(MLARCHIVE) \ $(LINK_CUSTOM_OCAMLC_ONLY) @@ -175,6 +177,7 @@ virt_customize_DEPENDENCIES = \ $(top_srcdir)/ocaml-link.sh \ $(CUSTOMIZE_THEOBJECTS) \ $(CUSTOMIZE_CMA) \ + ../common/mlutils/mlcutils.$(MLARCHIVE) \ ../mllib/mllib.$(MLARCHIVE) virt_customize_LINK = \ $(top_srcdir)/ocaml-link.sh -cclib '$(OCAMLCLIBS)' -- \ @@ -307,7 +310,7 @@ depend: .depend .depend: $(wildcard $(abs_srcdir)/*.mli) $(wildcard $(abs_srcdir)/*.ml) rm -f $@ $@-t - $(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/mllib $^ | \ + $(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/common/mlutils -I $(abs_top_builddir)/mllib $^ | \ $(SED) 's/ *$$//' | \ $(SED) -e :a -e '/ *\\$$/N; s/ *\\\n */ /; ta' | \ $(SED) -e 's,$(abs_srcdir)/,$(builddir)/,g' | \ diff --git a/dib/Makefile.am b/dib/Makefile.am index b10fa94c9..877225a85 100644 --- a/dib/Makefile.am +++ b/dib/Makefile.am @@ -75,11 +75,13 @@ XOBJECTS = $(BOBJECTS:.cmo=.cmx) # installed copy of libguestfs. OCAMLPACKAGES = \ -package str,unix \ + -I $(top_builddir)/common/cleanups/.libs \ -I $(top_builddir)/common/utils/.libs \ -I $(top_builddir)/lib/.libs \ -I $(top_builddir)/gnulib/lib/.libs \ -I $(top_builddir)/ocaml \ -I $(top_builddir)/common/mlstdutils \ + -I $(top_builddir)/common/mlutils \ -I $(top_builddir)/mllib if HAVE_OCAML_PKG_GETTEXT OCAMLPACKAGES += -package gettext-stub @@ -103,12 +105,14 @@ endif OCAMLLINKFLAGS = \ mlstdutils.$(MLARCHIVE) \ mlguestfs.$(MLARCHIVE) \ + mlcutils.$(MLARCHIVE) \ mllib.$(MLARCHIVE) \ $(LINK_CUSTOM_OCAMLC_ONLY) virt_dib_DEPENDENCIES = \ $(OBJECTS) \ ../common/mlstdutils/mlstdutils.$(MLARCHIVE) \ + ../common/mlutils/mlcutils.$(MLARCHIVE) \ ../mllib/mllib.$(MLARCHIVE) \ $(top_srcdir)/ocaml-link.sh virt_dib_LINK = \ @@ -144,7 +148,7 @@ depend: .depend .depend: $(wildcard $(abs_srcdir)/*.mli) $(wildcard $(abs_srcdir)/*.ml) rm -f $@ $@-t - $(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/common/mlstdutils -I $(abs_top_builddir)/mllib $^ | \ + $(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/common/mlstdutils -I $(abs_top_builddir)/common/mlutils -I $(abs_top_builddir)/mllib $^ | \ $(SED) 's/ *$$//' | \ $(SED) -e :a -e '/ *\\$$/N; s/ *\\\n */ /; ta' | \ $(SED) -e 's,$(abs_srcdir)/,$(builddir)/,g' | \ diff --git a/docs/C_SOURCE_FILES b/docs/C_SOURCE_FILES index fce01da3e..e856ffda0 100644 --- a/docs/C_SOURCE_FILES +++ b/docs/C_SOURCE_FILES @@ -21,6 +21,9 @@ common/miniexpect/miniexpect.c common/miniexpect/miniexpect.h common/mlprogress/progress-c.c common/mlstdutils/dummy.c +common/mlutils/c_utils-c.c +common/mlutils/dummy.c +common/mlutils/unix_utils-c.c common/mlvisit/dummy.c common/mlvisit/visit-c.c common/mlxml/xml-c.c @@ -344,7 +347,6 @@ make-fs/make-fs.c mllib/common_utils-c.c mllib/dummy.c mllib/getopt-c.c -mllib/unix_utils-c.c mllib/uri-c.c ocaml/guestfs-c-actions.c ocaml/guestfs-c-errnos.c @@ -410,4 +412,3 @@ utils/qemu-speed-test/qemu-speed-test.c v2v/libvirt_utils-c.c v2v/qemuopts-c.c v2v/test-harness/dummy.c -v2v/utils-c.c diff --git a/docs/guestfs-hacking.pod b/docs/guestfs-hacking.pod index 6ee4c236b..bd3d92233 100644 --- a/docs/guestfs-hacking.pod +++ b/docs/guestfs-hacking.pod @@ -113,6 +113,11 @@ A library of pure OCaml utility functions used in many places. OCaml bindings for the progress bar functions (see F<common/progress>). +=item F<common/mlutils> + +OCaml bindings for C functions in C<common/utils>, and some POSIX +bindings which are missing from the OCaml stdlib. + =item F<common/mlvisit> OCaml bindings for the visit functions (see F<common/visit>). diff --git a/get-kernel/Makefile.am b/get-kernel/Makefile.am index 16cf90eb9..1ca8be92c 100644 --- a/get-kernel/Makefile.am +++ b/get-kernel/Makefile.am @@ -66,6 +66,7 @@ OCAMLPACKAGES = \ -I $(top_builddir)/gnulib/lib/.libs \ -I $(top_builddir)/ocaml \ -I $(top_builddir)/common/mlstdutils \ + -I $(top_builddir)/common/mlutils \ -I $(top_builddir)/mllib if HAVE_OCAML_PKG_GETTEXT OCAMLPACKAGES += -package gettext-stub @@ -90,12 +91,14 @@ endif OCAMLLINKFLAGS = \ mlstdutils.$(MLARCHIVE) \ mlguestfs.$(MLARCHIVE) \ + mlcutils.$(MLARCHIVE) \ mllib.$(MLARCHIVE) \ $(LINK_CUSTOM_OCAMLC_ONLY) virt_get_kernel_DEPENDENCIES = \ $(OBJECTS) \ ../common/mlstdutils/mlstdutils.$(MLARCHIVE) \ + ../common/mlutils/mlcutils.$(MLARCHIVE) \ ../mllib/mllib.$(MLARCHIVE) \ $(top_srcdir)/ocaml-link.sh virt_get_kernel_LINK = \ @@ -130,7 +133,7 @@ depend: .depend .depend: $(wildcard $(abs_srcdir)/*.mli) $(wildcard $(abs_srcdir)/*.ml) rm -f $@ $@-t - $(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/common/mlstdutils -I $(abs_top_builddir)/mllib $^ | \ + $(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/common/mlstdutils -I $(abs_top_builddir)/common/mlutils -I $(abs_top_builddir)/mllib $^ | \ $(SED) 's/ *$$//' | \ $(SED) -e :a -e '/ *\\$$/N; s/ *\\\n */ /; ta' | \ $(SED) -e 's,$(abs_srcdir)/,$(builddir)/,g' | \ diff --git a/mllib/Makefile.am b/mllib/Makefile.am index ee251e99d..51d71465b 100644 --- a/mllib/Makefile.am +++ b/mllib/Makefile.am @@ -28,7 +28,6 @@ EXTRA_DIST = \ SOURCES_MLI = \ checksums.mli \ - unix_utils.mli \ common_utils.mli \ curl.mli \ getopt.mli \ @@ -43,7 +42,6 @@ SOURCES_ML = \ $(OCAML_BYTES_COMPAT_ML) \ common_gettext.ml \ getopt.ml \ - unix_utils.ml \ common_utils.ml \ URI.ml \ planner.ml \ @@ -60,7 +58,6 @@ SOURCES_C = \ ../common/options/uri.c \ common_utils-c.c \ getopt-c.c \ - unix_utils-c.c \ uri-c.c if HAVE_OCAML @@ -91,7 +88,8 @@ libmllib_a_CPPFLAGS = \ -I$(top_srcdir)/lib \ -I$(top_srcdir)/common/options \ -I$(top_srcdir)/common/mlxml \ - -I$(top_srcdir)/common/mlstdutils + -I$(top_srcdir)/common/mlstdutils \ + -I$(top_srcdir)/common/mlutils libmllib_a_CFLAGS = \ $(WARN_CFLAGS) $(WERROR_CFLAGS) \ $(LIBVIRT_CFLAGS) $(LIBXML2_CFLAGS) \ @@ -112,6 +110,7 @@ OCAMLPACKAGES = \ -I $(top_builddir)/ocaml \ -I $(top_builddir)/common/mlxml \ -I $(top_builddir)/common/mlstdutils \ + -I $(top_builddir)/common/mlutils \ -I $(builddir) OCAMLPACKAGES_TESTS = $(MLLIB_CMA) if HAVE_OCAML_PKG_GETTEXT @@ -192,6 +191,7 @@ endif OCAMLLINKFLAGS = \ mlstdutils.$(MLARCHIVE) \ + mlcutils.$(MLARCHIVE) \ mlguestfs.$(MLARCHIVE) \ $(LINK_CUSTOM_OCAMLC_ONLY) diff --git a/resize/Makefile.am b/resize/Makefile.am index 3707d73b4..454ea4660 100644 --- a/resize/Makefile.am +++ b/resize/Makefile.am @@ -56,6 +56,7 @@ XOBJECTS = $(BOBJECTS:.cmo=.cmx) # installed copy of libguestfs. OCAMLPACKAGES = \ -package str,unix \ + -I $(top_builddir)/common/cleanups/.libs \ -I $(top_builddir)/common/utils/.libs \ -I $(top_builddir)/common/progress/.libs \ -I $(top_builddir)/lib/.libs \ @@ -63,6 +64,7 @@ OCAMLPACKAGES = \ -I $(top_builddir)/ocaml \ -I $(top_builddir)/common/mlstdutils \ -I $(top_builddir)/common/mlprogress \ + -I $(top_builddir)/common/mlutils \ -I $(top_builddir)/mllib if HAVE_OCAML_PKG_GETTEXT OCAMLPACKAGES += -package gettext-stub @@ -88,12 +90,14 @@ OCAMLLINKFLAGS = \ mlstdutils.$(MLARCHIVE) \ mlguestfs.$(MLARCHIVE) \ mlprogress.$(MLARCHIVE) \ + mlcutils.$(MLARCHIVE) \ mllib.$(MLARCHIVE) \ $(LINK_CUSTOM_OCAMLC_ONLY) virt_resize_DEPENDENCIES = \ $(OBJECTS) \ ../common/mlstdutils/mlstdutils.$(MLARCHIVE) \ + ../common/mlutils/mlcutils.$(MLARCHIVE) \ ../mllib/mllib.$(MLARCHIVE) \ $(top_srcdir)/ocaml-link.sh virt_resize_LINK = \ @@ -138,7 +142,7 @@ depend: .depend .depend: $(wildcard $(abs_srcdir)/*.mli) $(wildcard $(abs_srcdir)/*.ml) rm -f $@ $@-t - $(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/mlstdutils -I $(abs_top_builddir)/mllib $^ | \ + $(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/common/mlstdutils -I $(abs_top_builddir)/common/mlutils -I $(abs_top_builddir)/mllib $^ | \ $(SED) 's/ *$$//' | \ $(SED) -e :a -e '/ *\\$$/N; s/ *\\\n */ /; ta' | \ $(SED) -e 's,$(abs_srcdir)/,$(builddir)/,g' | \ diff --git a/sparsify/Makefile.am b/sparsify/Makefile.am index a1395ccbd..8cd33d2be 100644 --- a/sparsify/Makefile.am +++ b/sparsify/Makefile.am @@ -61,6 +61,7 @@ XOBJECTS = $(BOBJECTS:.cmo=.cmx) # installed copy of libguestfs. OCAMLPACKAGES = \ -package str,unix \ + -I $(top_builddir)/common/cleanups/.libs \ -I $(top_builddir)/common/utils/.libs \ -I $(top_builddir)/common/progress/.libs \ -I $(top_builddir)/lib/.libs \ @@ -68,6 +69,7 @@ OCAMLPACKAGES = \ -I $(top_builddir)/ocaml \ -I $(top_builddir)/common/mlstdutils \ -I $(top_builddir)/common/mlprogress \ + -I $(top_builddir)/common/mlutils \ -I $(top_builddir)/mllib if HAVE_OCAML_PKG_GETTEXT OCAMLPACKAGES += -package gettext-stub @@ -93,12 +95,14 @@ OCAMLLINKFLAGS = \ mlstdutils.$(MLARCHIVE) \ mlguestfs.$(MLARCHIVE) \ mlprogress.$(MLARCHIVE) \ + mlcutils.$(MLARCHIVE) \ mllib.$(MLARCHIVE) \ $(LINK_CUSTOM_OCAMLC_ONLY) virt_sparsify_DEPENDENCIES = \ $(OBJECTS) \ ../common/mlstdutils/mlstdutils.$(MLARCHIVE) \ + ../common/mlutils/mlcutils.$(MLARCHIVE) \ ../mllib/mllib.$(MLARCHIVE) \ $(top_srcdir)/ocaml-link.sh virt_sparsify_LINK = \ @@ -145,7 +149,7 @@ depend: .depend .depend: $(wildcard $(abs_srcdir)/*.mli) $(wildcard $(abs_srcdir)/*.ml) rm -f $@ $@-t - $(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/common/mlstdutils -I $(abs_top_builddir)/mllib $^ | \ + $(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/common/mlstdutils -I $(abs_top_builddir)/common/mlutils -I $(abs_top_builddir)/mllib $^ | \ $(SED) 's/ *$$//' | \ $(SED) -e :a -e '/ *\\$$/N; s/ *\\\n */ /; ta' | \ $(SED) -e 's,$(abs_srcdir)/,$(builddir)/,g' | \ diff --git a/sysprep/Makefile.am b/sysprep/Makefile.am index 8c94473da..19a8b8803 100644 --- a/sysprep/Makefile.am +++ b/sysprep/Makefile.am @@ -116,6 +116,7 @@ OCAMLPACKAGES = \ -I $(top_builddir)/ocaml \ -I $(top_builddir)/common/visit/.libs \ -I $(top_builddir)/common/mlstdutils \ + -I $(top_builddir)/common/mlutils \ -I $(top_builddir)/common/mlvisit \ -I $(top_builddir)/mllib \ -I $(top_builddir)/customize @@ -145,6 +146,7 @@ endif OCAMLLINKFLAGS = \ mlstdutils.$(MLARCHIVE) \ mlguestfs.$(MLARCHIVE) \ + mlcutils.$(MLARCHIVE) \ mllib.$(MLARCHIVE) \ mlvisit.$(MLARCHIVE) \ customize.$(MLARCHIVE) \ @@ -153,6 +155,7 @@ OCAMLLINKFLAGS = \ virt_sysprep_DEPENDENCIES = \ $(OBJECTS) \ ../common/mlstdutils/mlstdutils.$(MLARCHIVE) \ + ../common/mlutils/mlcutils.$(MLARCHIVE) \ ../mllib/mllib.$(MLARCHIVE) \ ../customize/customize.$(MLARCHIVE) \ $(top_srcdir)/ocaml-link.sh @@ -221,7 +224,7 @@ depend: .depend .depend: $(wildcard $(abs_srcdir)/*.mli) $(wildcard $(abs_srcdir)/*.ml) rm -f $@ $@-t - $(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/mlstdutils -I $(abs_top_builddir)/mllib -I $(abs_top_builddir)/customize $^ | \ + $(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/common/mlstdutils -I $(abs_top_builddir)/common/mlutils -I $(abs_top_builddir)/mllib -I $(abs_top_builddir)/customize $^ | \ $(SED) 's/ *$$//' | \ $(SED) -e :a -e '/ *\\$$/N; s/ *\\\n */ /; ta' | \ $(SED) -e 's,$(abs_srcdir)/,$(builddir)/,g' | \ diff --git a/v2v/Makefile.am b/v2v/Makefile.am index 41ff9af0b..4c4e3e210 100644 --- a/v2v/Makefile.am +++ b/v2v/Makefile.am @@ -111,8 +111,7 @@ SOURCES_ML = \ SOURCES_C = \ libvirt_utils-c.c \ - qemuopts-c.c \ - utils-c.c + qemuopts-c.c if HAVE_OCAML @@ -149,6 +148,7 @@ OCAMLPACKAGES = \ -I $(top_builddir)/gnulib/lib/.libs \ -I $(top_builddir)/ocaml \ -I $(top_builddir)/common/mlstdutils \ + -I $(top_builddir)/common/mlutils \ -I $(top_builddir)/common/mlxml \ -I $(top_builddir)/mllib \ -I $(top_builddir)/customize @@ -177,6 +177,7 @@ OCAMLLINKFLAGS = \ mlstdutils.$(MLARCHIVE) \ mlguestfs.$(MLARCHIVE) \ mlxml.$(MLARCHIVE) \ + mlcutils.$(MLARCHIVE) \ mllib.$(MLARCHIVE) \ $(LINK_CUSTOM_OCAMLC_ONLY) @@ -187,8 +188,7 @@ virt_v2v_LINK = \ $(OBJECTS) -o $@ virt_v2v_copy_to_local_SOURCES = \ - libvirt_utils-c.c \ - utils-c.c + libvirt_utils-c.c virt_v2v_copy_to_local_CPPFLAGS = \ -I. \ -I$(top_builddir) \ @@ -218,6 +218,7 @@ virt_v2v_copy_to_local_DEPENDENCIES = \ $(COPY_TO_LOCAL_OBJECTS) \ ../common/mlstdutils/mlstdutils.$(MLARCHIVE) \ ../common/mlxml/mlxml.$(MLARCHIVE) \ + ../common/mlutils/mlcutils.$(MLARCHIVE) \ ../mllib/mllib.$(MLARCHIVE) \ $(top_srcdir)/ocaml-link.sh virt_v2v_copy_to_local_LINK = \ @@ -504,6 +505,7 @@ v2v_unit_tests_DEPENDENCIES = \ $(v2v_unit_tests_THEOBJECTS) \ ../common/mlstdutils/mlstdutils.$(MLARCHIVE) \ ../common/mlxml/mlxml.$(MLARCHIVE) \ + ../common/mlutils/mlcutils.$(MLARCHIVE) \ ../mllib/mllib.$(MLARCHIVE) \ $(top_srcdir)/ocaml-link.sh v2v_unit_tests_LINK = \ @@ -518,7 +520,7 @@ depend: .depend .depend: $(wildcard $(abs_srcdir)/*.mli) $(wildcard $(abs_srcdir)/*.ml) rm -f $@ $@-t - $(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/common/mlstdutils -I $(abs_top_builddir)/common/mlxml -I $(abs_top_builddir)/mllib -I $(abs_top_builddir)/customize $^ | \ + $(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/common/mlstdutils -I $(abs_top_builddir)/common/mlutils -I $(abs_top_builddir)/common/mlxml -I $(abs_top_builddir)/mllib -I $(abs_top_builddir)/customize $^ | \ $(SED) 's/ *$$//' | \ $(SED) -e :a -e '/ *\\$$/N; s/ *\\\n */ /; ta' | \ $(SED) -e 's,$(abs_srcdir)/,$(builddir)/,g' | \ diff --git a/v2v/convert_linux.ml b/v2v/convert_linux.ml index ffb43564f..c34bf3e91 100644 --- a/v2v/convert_linux.ml +++ b/v2v/convert_linux.ml @@ -28,6 +28,7 @@ open Printf +open C_utils open Std_utils open Common_utils open Common_gettext.Gettext @@ -186,7 +187,7 @@ let rec convert (g : G.guestfs) inspect source output rcaps = fun line -> if Str.string_match rex line 0 then ( let path = Str.matched_group 1 line in - let path = Utils.shell_unquote path in + let path = shell_unquote path in if String.length path >= 1 && path.[0] = '/' then ( let vboxuninstall = path ^ "/uninstall.sh" in Some vboxuninstall diff --git a/v2v/create_libvirt_xml.ml b/v2v/create_libvirt_xml.ml index 3f22f3764..f5dca2d57 100644 --- a/v2v/create_libvirt_xml.ml +++ b/v2v/create_libvirt_xml.ml @@ -19,6 +19,7 @@ open Printf open Std_utils +open C_utils open Common_utils open Common_gettext.Gettext diff --git a/v2v/parse_libvirt_xml.ml b/v2v/parse_libvirt_xml.ml index 56f9ea297..285cf2f44 100644 --- a/v2v/parse_libvirt_xml.ml +++ b/v2v/parse_libvirt_xml.ml @@ -18,6 +18,7 @@ open Printf +open C_utils open Std_utils open Common_utils open Common_gettext.Gettext @@ -39,7 +40,7 @@ and parsed_source = *) let get_drive_slot str offset = let name = String.sub str offset (String.length str - offset) in - try Some (Utils.drive_index name) + try Some (drive_index name) with Invalid_argument _ -> warning (f_"could not parse device name ‘%s’ from the source libvirt XML") str; None diff --git a/v2v/utils.ml b/v2v/utils.ml index 0dab5816e..0c6a1f444 100644 --- a/v2v/utils.ml +++ b/v2v/utils.ml @@ -24,11 +24,6 @@ open Std_utils open Common_utils open Common_gettext.Gettext -external drive_name : int -> string = "v2v_utils_drive_name" -external drive_index : string -> int = "v2v_utils_drive_index" - -external shell_unquote : string -> string = "v2v_utils_shell_unquote" - (* Map guest architecture found by inspection to the architecture * that KVM must emulate. Note for x86 we assume a 64 bit hypervisor. *) diff --git a/v2v/utils.mli b/v2v/utils.mli index 4906f0023..f267717d4 100644 --- a/v2v/utils.mli +++ b/v2v/utils.mli @@ -18,17 +18,6 @@ (** Utilities used in virt-v2v only. *) -val drive_name : int -> string -val drive_index : string -> int - -val shell_unquote : string -> string -(** If the string looks like a shell quoted string, then attempt to - unquote it. - - This is just intended to deal with quoting in configuration files - (like ones under /etc/sysconfig), and it doesn't deal with some - situations such as $variable interpolation. *) - val kvm_arch : string -> string (** Map guest architecture found by inspection to the architecture that KVM must emulate. Note for x86 we assume a 64 bit hypervisor. *) diff --git a/v2v/v2v.ml b/v2v/v2v.ml index f1ce9335a..00fbff2bc 100644 --- a/v2v/v2v.ml +++ b/v2v/v2v.ml @@ -19,6 +19,7 @@ open Unix open Printf +open C_utils open Std_utils open Common_utils open Unix_utils diff --git a/v2v/v2v_unit_tests.ml b/v2v/v2v_unit_tests.ml index be0bf0172..76f04f6fe 100644 --- a/v2v/v2v_unit_tests.ml +++ b/v2v/v2v_unit_tests.ml @@ -110,36 +110,6 @@ let test_get_ostype ctx = i_product_variant = "Server"; i_arch = "x86_64" }) -let test_drive_name ctx = - let printer = identity in - assert_equal ~printer "a" (Utils.drive_name 0); - assert_equal ~printer "z" (Utils.drive_name 25); - assert_equal ~printer "aa" (Utils.drive_name 26); - assert_equal ~printer "ab" (Utils.drive_name 27); - assert_equal ~printer "az" (Utils.drive_name 51); - assert_equal ~printer "ba" (Utils.drive_name 52); - assert_equal ~printer "zz" (Utils.drive_name 701); - assert_equal ~printer "aaa" (Utils.drive_name 702); - assert_equal ~printer "zzz" (Utils.drive_name 18277) - -let test_drive_index ctx = - let printer = string_of_int in - assert_equal ~printer 0 (Utils.drive_index "a"); - assert_equal ~printer 25 (Utils.drive_index "z"); - assert_equal ~printer 26 (Utils.drive_index "aa"); - assert_equal ~printer 27 (Utils.drive_index "ab"); - assert_equal ~printer 51 (Utils.drive_index "az"); - assert_equal ~printer 52 (Utils.drive_index "ba"); - assert_equal ~printer 701 (Utils.drive_index "zz"); - assert_equal ~printer 702 (Utils.drive_index "aaa"); - assert_equal ~printer 18277 (Utils.drive_index "zzz"); - let exn = Invalid_argument "drive_index: invalid parameter" in - assert_raises exn (fun () -> Utils.drive_index ""); - assert_raises exn (fun () -> Utils.drive_index "abc123"); - assert_raises exn (fun () -> Utils.drive_index "123"); - assert_raises exn (fun () -> Utils.drive_index "Z"); - assert_raises exn (fun () -> Utils.drive_index "aB") - let test_virtio_iso_path_matches_guest_os ctx = (* Windows OSes fake inspection data. *) let make_win name major minor variant arch = { @@ -779,19 +749,6 @@ let test_virtio_iso_path_matches_guest_os ctx = ) all_windows ) paths -let test_shell_unquote ctx = - let printer = identity in - assert_equal ~printer "a" (Utils.shell_unquote "a"); - assert_equal ~printer "b" (Utils.shell_unquote "'b'"); - assert_equal ~printer "c" (Utils.shell_unquote "\"c\""); - assert_equal ~printer "dd" (Utils.shell_unquote "\"dd\""); - assert_equal ~printer "e\\e" (Utils.shell_unquote "\"e\\\\e\""); - assert_equal ~printer "f\\" (Utils.shell_unquote "\"f\\\\\""); - assert_equal ~printer "\\g" (Utils.shell_unquote "\"\\\\g\""); - assert_equal ~printer "h\\-h" (Utils.shell_unquote "\"h\\-h\""); - assert_equal ~printer "i`" (Utils.shell_unquote "\"i\\`\""); - assert_equal ~printer "j\"" (Utils.shell_unquote "\"j\\\"\"") - let test_qemu_img_supports ctx = (* No assertion here, we don't know if qemu-img supports the * feature, so just run the code and make sure it doesn't crash. @@ -945,11 +902,8 @@ let suite = "virt-v2v" >::: [ "Create_ovf.get_ostype" >:: test_get_ostype; - "Utils.drive_name" >:: test_drive_name; - "Utils.drive_index" >:: test_drive_index; "Windows_virtio.virtio_iso_path_matches_guest_os" >:: test_virtio_iso_path_matches_guest_os; - "Utils.shell_unquote" >:: test_shell_unquote; "Utils.qemu_img_supports" >:: test_qemu_img_supports; "Parse_vmx.parse_string" >::test_vmx_parse_string; ] -- 2.13.0

After the previous refactoring, we are able to link the daemon to common/utils, and also remove some of the "duplicate" functions that the daemon carried ("duplicate" in quotes because they were often not exact duplicates). It also allows us in future (but not in this commit) to move utility functions from the daemon into libutils. --- daemon/Makefile.am | 6 ++++- daemon/augeas.c | 2 +- daemon/btrfs.c | 18 +++++++-------- daemon/cleanups.c | 6 ----- daemon/daemon.h | 14 +----------- daemon/debug.c | 4 ++-- daemon/echo-daemon.c | 2 +- daemon/guestfsd.c | 64 ---------------------------------------------------- daemon/ldm.c | 2 +- daemon/lvm.c | 4 ++-- daemon/md.c | 8 ++++--- daemon/stat.c | 2 +- generator/daemon.ml | 8 +++---- 13 files changed, 32 insertions(+), 108 deletions(-) diff --git a/daemon/Makefile.am b/daemon/Makefile.am index 9695500bf..84d9d279e 100644 --- a/daemon/Makefile.am +++ b/daemon/Makefile.am @@ -50,6 +50,7 @@ guestfsd_SOURCES = \ ../common/errnostring/errnostring.h \ ../common/protocol/guestfs_protocol.h \ ../common/cleanups/cleanups.h \ + ../common/utils/utils.h \ 9p.c \ acl.c \ actions.h \ @@ -179,6 +180,7 @@ guestfsd_LDADD = \ ../common/errnostring/liberrnostring.la \ ../common/protocol/libprotocol.la \ ../common/cleanups/libcleanups.la \ + ../common/utils/libutils.la \ $(ACL_LIBS) \ $(CAP_LIBS) \ $(YAJL_LIBS) \ @@ -209,7 +211,9 @@ guestfsd_CPPFLAGS = \ -I$(top_srcdir)/common/protocol \ -I$(top_builddir)/common/protocol \ -I$(top_srcdir)/common/cleanups \ - -I$(top_builddir)/common/cleanups + -I$(top_builddir)/common/cleanups \ + -I$(top_srcdir)/common/utils \ + -I$(top_builddir)/common/utils guestfsd_CFLAGS = \ $(WARN_CFLAGS) $(WERROR_CFLAGS) \ $(RPC_CFLAGS) \ diff --git a/daemon/augeas.c b/daemon/augeas.c index 5adc959a5..bd54c4849 100644 --- a/daemon/augeas.c +++ b/daemon/augeas.c @@ -436,7 +436,7 @@ do_aug_ls (const char *path) if (matches == NULL) return NULL; /* do_aug_match has already sent the error */ - sort_strings (matches, count_strings ((void *) matches)); + sort_strings (matches, guestfs_int_count_strings ((void *) matches)); return matches; /* Caller frees. */ } diff --git a/daemon/btrfs.c b/daemon/btrfs.c index ae2310b53..5f1e5d1d0 100644 --- a/daemon/btrfs.c +++ b/daemon/btrfs.c @@ -152,7 +152,7 @@ do_mkfs_btrfs (char *const *devices, int leafsize, const char *label, const char *metadata, int nodesize, int sectorsize) { - const size_t nr_devices = count_strings (devices); + const size_t nr_devices = guestfs_int_count_strings (devices); const size_t MAX_ARGS = nr_devices + 64; const char *argv[MAX_ARGS]; size_t i = 0, j; @@ -500,7 +500,7 @@ do_btrfs_subvolume_list (const mountable_t *fs) guestfs_int_btrfssubvolume_list *ret = NULL; - const size_t nr_subvolumes = count_strings (lines); + const size_t nr_subvolumes = guestfs_int_count_strings (lines); ret = malloc (sizeof *ret); if (!ret) { @@ -733,7 +733,7 @@ int do_btrfs_device_add (char *const *devices, const char *fs) { static int btrfs_device_add_needs_force = -1; - const size_t nr_devices = count_strings (devices); + const size_t nr_devices = guestfs_int_count_strings (devices); const size_t MAX_ARGS = nr_devices + 8; const char *argv[MAX_ARGS]; size_t i = 0, j; @@ -781,7 +781,7 @@ do_btrfs_device_add (char *const *devices, const char *fs) int do_btrfs_device_delete (char *const *devices, const char *fs) { - const size_t nr_devices = count_strings (devices); + const size_t nr_devices = guestfs_int_count_strings (devices); if (nr_devices == 0) return 0; @@ -1391,7 +1391,7 @@ do_btrfs_qgroup_show (const char *path) * 0/5 9249849344 9249849344 * */ - const size_t nr_qgroups = count_strings (lines) - 2; + const size_t nr_qgroups = guestfs_int_count_strings (lines) - 2; guestfs_int_btrfsqgroup_list *ret = NULL; ret = malloc (sizeof *ret); if (!ret) { @@ -1821,7 +1821,7 @@ do_btrfs_balance_status (const char *path) if (!lines) return NULL; - nlines = count_strings (lines); + nlines = guestfs_int_count_strings (lines); ret = calloc (1, sizeof *ret); if (ret == NULL) { @@ -1938,7 +1938,7 @@ do_btrfs_scrub_status (const char *path) if (!lines) return NULL; - if (count_strings (lines) < 2) { + if (guestfs_int_count_strings (lines) < 2) { reply_with_error ("truncated output from 'btrfs scrub status -R' command"); return NULL; } @@ -2124,7 +2124,7 @@ int do_btrfs_image (char *const *sources, const char *image, int compresslevel) { - const size_t nr_sources = count_strings (sources); + const size_t nr_sources = guestfs_int_count_strings (sources); const size_t MAX_ARGS = 64 + nr_sources; const char *argv[MAX_ARGS]; size_t i = 0, j; @@ -2229,7 +2229,7 @@ do_btrfs_filesystem_show (const char *device) if (!lines) return NULL; - if (count_strings (lines) < 3) { + if (guestfs_int_count_strings (lines) < 3) { reply_with_error ("truncated output from 'btrfs filesystem show' command"); return NULL; } diff --git a/daemon/cleanups.c b/daemon/cleanups.c index c73b9e492..b4767178a 100644 --- a/daemon/cleanups.c +++ b/daemon/cleanups.c @@ -36,12 +36,6 @@ cleanup_aug_close (void *ptr) } void -cleanup_free_string_list (void *ptr) -{ - free_strings (* (char ***) ptr); -} - -void cleanup_free_stringsbuf (void *ptr) { free_stringsbuf ((struct stringsbuf *) ptr); diff --git a/daemon/daemon.h b/daemon/daemon.h index 746af22b9..2d296a6c2 100644 --- a/daemon/daemon.h +++ b/daemon/daemon.h @@ -31,6 +31,7 @@ #include "guestfs_protocol.h" #include "cleanups.h" +#include "utils.h" #include "guestfs-internal-all.h" @@ -83,17 +84,13 @@ extern char *mountable_to_string (const mountable_t *mountable); * Don't call them directly. */ extern void cleanup_aug_close (void *ptr); -extern void cleanup_free_string_list (void *ptr); extern void cleanup_free_stringsbuf (void *ptr); #ifdef HAVE_ATTRIBUTE_CLEANUP #define CLEANUP_AUG_CLOSE __attribute__((cleanup(cleanup_aug_close))) -#define CLEANUP_FREE_STRING_LIST \ - __attribute__((cleanup(cleanup_free_string_list))) #define CLEANUP_FREE_STRINGSBUF __attribute__((cleanup(cleanup_free_stringsbuf))) #else #define CLEANUP_AUG_CLOSE -#define CLEANUP_FREE_STRING_LIST #define CLEANUP_FREE_STRINGSBUF #endif @@ -130,21 +127,12 @@ extern int end_stringsbuf (struct stringsbuf *sb); extern char **take_stringsbuf (struct stringsbuf *sb); extern void free_stringsbuf (struct stringsbuf *sb); -extern size_t count_strings (char *const *argv); extern void sort_strings (char **argv, size_t len); -extern void free_strings (char **argv); extern void free_stringslen (char **argv, size_t len); extern void sort_device_names (char **argv, size_t len); extern int compare_device_names (const char *a, const char *b); -/* Concatenate strings, optionally with a separator string between - * each. On error, these return NULL but do NOT call reply_with_* nor - * free anything. - */ -extern char *concat_strings (char *const *argv); -extern char *join_strings (const char *separator, char *const *argv); - extern struct stringsbuf split_lines_sb (char *str); extern char **split_lines (char *str); diff --git a/daemon/debug.c b/daemon/debug.c index b18d87c26..e2d43a7ca 100644 --- a/daemon/debug.c +++ b/daemon/debug.c @@ -444,7 +444,7 @@ debug_ldd (const char *subcmd, size_t argc, char *const *const argv) static char * debug_ls (const char *subcmd, size_t argc, char *const *const argv) { - const size_t len = count_strings (argv); + const size_t len = guestfs_int_count_strings (argv); CLEANUP_FREE const char **cargv = NULL; size_t i; int r; @@ -477,7 +477,7 @@ debug_ls (const char *subcmd, size_t argc, char *const *const argv) static char * debug_ll (const char *subcmd, size_t argc, char *const *const argv) { - const size_t len = count_strings (argv); + const size_t len = guestfs_int_count_strings (argv); CLEANUP_FREE const char **cargv = NULL; size_t i; int r; diff --git a/daemon/echo-daemon.c b/daemon/echo-daemon.c index d566a9bb2..15429f072 100644 --- a/daemon/echo-daemon.c +++ b/daemon/echo-daemon.c @@ -28,7 +28,7 @@ do_echo_daemon (char *const *argv) { char *out; - out = join_strings (" ", argv); + out = guestfs_int_join_strings (" ", argv); if (out == NULL) { reply_with_perror ("malloc"); return NULL; diff --git a/daemon/guestfsd.c b/daemon/guestfsd.c index db2bb702f..b3f40628b 100644 --- a/daemon/guestfsd.c +++ b/daemon/guestfsd.c @@ -583,16 +583,6 @@ take_stringsbuf (struct stringsbuf *sb) return ret; } -size_t -count_strings (char *const *argv) -{ - size_t argc; - - for (argc = 0; argv[argc] != NULL; ++argc) - ; - return argc; -} - /** * Returns true if C<v> is a power of 2. * @@ -620,19 +610,6 @@ sort_strings (char **argv, size_t len) } void -free_strings (char **argv) -{ - size_t argc; - - if (!argv) - return; - - for (argc = 0; argv[argc] != NULL; ++argc) - free (argv[argc]); - free (argv); -} - -void free_stringslen (char **argv, size_t len) { size_t i; @@ -720,47 +697,6 @@ sort_device_names (char **argv, size_t len) qsort (argv, len, sizeof (char *), compare_device_names_vp); } -char * -concat_strings (char *const *argv) -{ - return join_strings ("", argv); -} - -char * -join_strings (const char *separator, char *const *argv) -{ - size_t i, len, seplen, rlen; - char *r; - - seplen = strlen (separator); - - len = 0; - for (i = 0; argv[i] != NULL; ++i) { - if (i > 0) - len += seplen; - len += strlen (argv[i]); - } - len++; /* for final \0 */ - - r = malloc (len); - if (r == NULL) - return NULL; - - rlen = 0; - for (i = 0; argv[i] != NULL; ++i) { - if (i > 0) { - memcpy (&r[rlen], separator, seplen); - rlen += seplen; - } - len = strlen (argv[i]); - memcpy (&r[rlen], argv[i], len); - rlen += len; - } - r[rlen] = '\0'; - - return r; -} - /** * Split an output string into a NULL-terminated list of lines, * wrapped into a stringsbuf. diff --git a/daemon/ldm.c b/daemon/ldm.c index 7753b0d82..75418e8d3 100644 --- a/daemon/ldm.c +++ b/daemon/ldm.c @@ -320,7 +320,7 @@ do_ldmtool_scan_devices (char * const * devices) int r; CLEANUP_FREE char *out = NULL, *err = NULL; - nr_devices = count_strings (devices); + nr_devices = guestfs_int_count_strings (devices); argv = malloc ((3 + nr_devices) * sizeof (char *)); if (argv == NULL) { reply_with_perror ("malloc"); diff --git a/daemon/lvm.c b/daemon/lvm.c index 6c57046ff..5d12b009f 100644 --- a/daemon/lvm.c +++ b/daemon/lvm.c @@ -337,7 +337,7 @@ do_vgcreate (const char *volgroup, char *const *physvols) CLEANUP_FREE char *err = NULL; CLEANUP_FREE const char **argv = NULL; - argc = count_strings (physvols) + 3; + argc = guestfs_int_count_strings (physvols) + 3; argv = malloc (sizeof (char *) * (argc + 1)); if (argv == NULL) { reply_with_perror ("malloc"); @@ -643,7 +643,7 @@ do_vg_activate (int activate, char *const *volgroups) CLEANUP_FREE char *err = NULL; CLEANUP_FREE const char **argv = NULL; - argc = count_strings (volgroups) + 4; + argc = guestfs_int_count_strings (volgroups) + 4; argv = malloc (sizeof (char *) * (argc+1)); if (argv == NULL) { reply_with_perror ("malloc"); diff --git a/daemon/md.c b/daemon/md.c index 3f31529e2..64d98fae5 100644 --- a/daemon/md.c +++ b/daemon/md.c @@ -97,7 +97,8 @@ do_md_create (const char *name, char *const *devices, } } else - nrdevices = count_strings (devices) + count_bits (umissingbitmap); + nrdevices = + guestfs_int_count_strings (devices) + count_bits (umissingbitmap); if (optargs_bitmask & GUESTFS_MD_CREATE_LEVEL_BITMASK) { if (STRNEQ (level, "linear") && STRNEQ (level, "raid0") && @@ -124,10 +125,11 @@ do_md_create (const char *name, char *const *devices, } /* Check invariant. */ - if (count_strings (devices) + count_bits (umissingbitmap) != + if (guestfs_int_count_strings (devices) + count_bits (umissingbitmap) != (size_t) (nrdevices + spare)) { reply_with_error ("devices (%zu) + bits set in missingbitmap (%zu) is not equal to nrdevices (%d) + spare (%d)", - count_strings (devices), count_bits (umissingbitmap), + guestfs_int_count_strings (devices), + count_bits (umissingbitmap), nrdevices, spare); return -1; } diff --git a/daemon/stat.c b/daemon/stat.c index 73f19226b..a1cd49245 100644 --- a/daemon/stat.c +++ b/daemon/stat.c @@ -127,7 +127,7 @@ do_internal_lstatnslist (const char *path, char *const *names) guestfs_int_statns_list *ret; size_t i, nr_names; - nr_names = count_strings (names); + nr_names = guestfs_int_count_strings (names); ret = malloc (sizeof *ret); if (!ret) { diff --git a/generator/daemon.ml b/generator/daemon.ml index 0300dc54b..2ae462864 100644 --- a/generator/daemon.ml +++ b/generator/daemon.ml @@ -397,7 +397,7 @@ let generate_daemon_stubs actions () = | RStringList (RPlainString, n) | RHashtable (RPlainString, RPlainString, n) -> pr " struct guestfs_%s_ret ret;\n" name; - pr " ret.%s.%s_len = count_strings (r);\n" n n; + pr " ret.%s.%s_len = guestfs_int_count_strings (r);\n" n n; pr " ret.%s.%s_val = r;\n" n n; pr " reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name @@ -413,7 +413,7 @@ let generate_daemon_stubs actions () = pr " free (r[i]);\n"; pr " r[i] = rr;\n"; pr " }\n"; - pr " ret.%s.%s_len = count_strings (r);\n" n n; + pr " ret.%s.%s_len = guestfs_int_count_strings (r);\n" n n; pr " ret.%s.%s_val = r;\n" n n; pr " reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name @@ -428,7 +428,7 @@ let generate_daemon_stubs actions () = pr " free (r[i]);\n"; pr " r[i] = rr;\n"; pr " }\n"; - pr " ret.%s.%s_len = count_strings (r);\n" n n; + pr " ret.%s.%s_len = guestfs_int_count_strings (r);\n" n n; pr " ret.%s.%s_val = r;\n" n n; pr " reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name @@ -443,7 +443,7 @@ let generate_daemon_stubs actions () = pr " free (r[i+1]);\n"; pr " r[i+1] = rr;\n"; pr " }\n"; - pr " ret.%s.%s_len = count_strings (r);\n" n n; + pr " ret.%s.%s_len = guestfs_int_count_strings (r);\n" n n; pr " ret.%s.%s_val = r;\n" n n; pr " reply ((xdrproc_t) &xdr_guestfs_%s_ret, (char *) &ret);\n" name -- 2.13.0

‘file’ is a small, self-contained API which runs a single command, so it's a good test case for reimplementing APIs. --- daemon/Makefile.am | 2 ++ daemon/file.c | 80 ----------------------------------------------- daemon/file.ml | 60 +++++++++++++++++++++++++++++++++++ daemon/file.mli | 19 +++++++++++ generator/actions_core.ml | 1 + 5 files changed, 82 insertions(+), 80 deletions(-) create mode 100644 daemon/file.ml create mode 100644 daemon/file.mli diff --git a/daemon/Makefile.am b/daemon/Makefile.am index 3fb70fe52..f354a0d6f 100644 --- a/daemon/Makefile.am +++ b/daemon/Makefile.am @@ -259,6 +259,7 @@ guestfsd_CFLAGS = \ SOURCES_MLI = \ chroot.mli \ sysroot.mli \ + file.mli \ utils.mli SOURCES_ML = \ @@ -266,6 +267,7 @@ SOURCES_ML = \ utils.ml \ sysroot.ml \ chroot.ml \ + file.ml \ callbacks.ml \ daemon.ml diff --git a/daemon/file.c b/daemon/file.c index 84874dc6f..ee79eb507 100644 --- a/daemon/file.c +++ b/daemon/file.c @@ -30,7 +30,6 @@ #include "actions.h" #include "optgroups.h" -GUESTFSD_EXT_CMD(str_file, file); GUESTFSD_EXT_CMD(str_zcat, zcat); GUESTFSD_EXT_CMD(str_bzcat, bzcat); @@ -449,85 +448,6 @@ do_pwrite_device (const char *device, const char *content, size_t size, return pwrite_fd (fd, content, size, offset, device, 1); } -/* This runs the 'file' command. */ -char * -do_file (const char *path) -{ - CLEANUP_FREE char *buf = NULL; - const char *display_path = path; - const int is_dev = STRPREFIX (path, "/dev/"); - struct stat statbuf; - - if (!is_dev) { - buf = sysroot_path (path); - if (!buf) { - reply_with_perror ("malloc"); - return NULL; - } - path = buf; - - /* For non-dev, check this is a regular file, else just return the - * file type as a string (RHBZ#582484). - */ - if (lstat (path, &statbuf) == -1) { - reply_with_perror ("lstat: %s", display_path); - return NULL; - } - - if (! S_ISREG (statbuf.st_mode)) { - char *ret; - - if (S_ISDIR (statbuf.st_mode)) - ret = strdup ("directory"); - else if (S_ISCHR (statbuf.st_mode)) - ret = strdup ("character device"); - else if (S_ISBLK (statbuf.st_mode)) - ret = strdup ("block device"); - else if (S_ISFIFO (statbuf.st_mode)) - ret = strdup ("FIFO"); - else if (S_ISLNK (statbuf.st_mode)) - ret = strdup ("symbolic link"); - else if (S_ISSOCK (statbuf.st_mode)) - ret = strdup ("socket"); - else - ret = strdup ("unknown, not regular file"); - - if (ret == NULL) - reply_with_perror ("strdup"); - return ret; - } - } - - /* Which flags to use? For /dev paths, follow links because - * /dev/VG/LV is a symbolic link. - */ - const char *flags = is_dev ? "-zbsL" : "-zb"; - - char *out; - CLEANUP_FREE char *err = NULL; - int r = command (&out, &err, str_file, flags, path, NULL); - - if (r == -1) { - free (out); - reply_with_error ("%s: %s", display_path, err); - return NULL; - } - - /* We need to remove the trailing \n from output of file(1). */ - size_t len = strlen (out); - if (len > 0 && out[len-1] == '\n') - out[--len] = '\0'; - - /* Some upstream versions of file add a space at the end of the - * output. This is fixed in the Fedora version, but we might as - * well fix it here too. (RHBZ#928995). - */ - if (len > 0 && out[len-1] == ' ') - out[--len] = '\0'; - - return out; /* caller frees */ -} - /* zcat | file */ char * do_zfile (const char *method, const char *path) diff --git a/daemon/file.ml b/daemon/file.ml new file mode 100644 index 000000000..557de764b --- /dev/null +++ b/daemon/file.ml @@ -0,0 +1,60 @@ +(* guestfs-inspection + * Copyright (C) 2009-2017 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 Unix +open Printf + +open Std_utils + +open Utils + +(* This runs the [file] command. *) +let file path = + let is_dev = String.is_prefix path "/dev/" in + + (* For non-dev, check this is a regular file, else just return the + * file type as a string (RHBZ#582484). + *) + if not is_dev then ( + let sysroot = Sysroot.sysroot () in + let chroot = Chroot.create sysroot ~name:(sprintf "file: %s" path) in + + let statbuf = Chroot.f chroot lstat path in + match statbuf.st_kind with + | S_DIR -> "directory" + | S_CHR -> "character device" + | S_BLK -> "block device" + | S_FIFO -> "FIFO" + | S_LNK -> "symbolic link" + | S_SOCK -> "socket" + | S_REG -> + (* Regular file, so now run [file] on it. *) + let out = command "file" ["-zb"; sysroot // path] in + + (* We need to remove the trailing \n from output of file(1). + * + * Some upstream versions of file add a space at the end of the + * output. This is fixed in the Fedora version, but we might as + * well fix it here too. (RHBZ#928995). + *) + String.trimr out + ) + else (* it's a device *) ( + let out = command "file" ["-zbsL"; path] in + String.trimr out + ) diff --git a/daemon/file.mli b/daemon/file.mli new file mode 100644 index 000000000..bd49bad0b --- /dev/null +++ b/daemon/file.mli @@ -0,0 +1,19 @@ +(* guestfs-inspection + * Copyright (C) 2009-2017 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. + *) + +val file : string -> string diff --git a/generator/actions_core.ml b/generator/actions_core.ml index 0e667eff1..26ed1274e 100644 --- a/generator/actions_core.ml +++ b/generator/actions_core.ml @@ -2321,6 +2321,7 @@ and physical volumes." }; { defaults with name = "file"; added = (1, 9, 1); style = RString (RPlainString, "description"), [String (Dev_or_Path, "path")], []; + impl = OCaml "File.file"; tests = [ InitISOFS, Always, TestResultString ( [["file"; "/empty"]], "empty"), []; -- 2.13.0

The reimplemented APIs are: * list_devices * list_partitions * part_to_dev * part_to_partnum * is_whole_device --- daemon/Makefile.am | 2 + daemon/daemon.h | 3 - daemon/devsparts.c | 257 ---------------------------------------------- daemon/devsparts.ml | 109 ++++++++++++++++++++ daemon/devsparts.mli | 25 +++++ daemon/guestfsd.c | 75 -------------- daemon/utils.ml | 84 +++++++++++++++ daemon/utils.mli | 15 +++ generator/actions_core.ml | 5 + generator/daemon.ml | 32 +++++- 10 files changed, 268 insertions(+), 339 deletions(-) create mode 100644 daemon/devsparts.ml create mode 100644 daemon/devsparts.mli diff --git a/daemon/Makefile.am b/daemon/Makefile.am index fc99c500f..e616de73b 100644 --- a/daemon/Makefile.am +++ b/daemon/Makefile.am @@ -260,6 +260,7 @@ SOURCES_MLI = \ blkid.mli \ chroot.mli \ sysroot.mli \ + devsparts.mli \ file.mli \ mountable.mli \ utils.mli @@ -271,6 +272,7 @@ SOURCES_ML = \ mountable.ml \ chroot.ml \ blkid.ml \ + devsparts.ml \ file.ml \ callbacks.ml \ daemon.ml diff --git a/daemon/daemon.h b/daemon/daemon.h index 2d296a6c2..684f9b096 100644 --- a/daemon/daemon.h +++ b/daemon/daemon.h @@ -130,9 +130,6 @@ extern void free_stringsbuf (struct stringsbuf *sb); extern void sort_strings (char **argv, size_t len); extern void free_stringslen (char **argv, size_t len); -extern void sort_device_names (char **argv, size_t len); -extern int compare_device_names (const char *a, const char *b); - extern struct stringsbuf split_lines_sb (char *str); extern char **split_lines (char *str); diff --git a/daemon/devsparts.c b/daemon/devsparts.c index 82467b92f..1aacb8e16 100644 --- a/daemon/devsparts.c +++ b/daemon/devsparts.c @@ -33,263 +33,6 @@ #include "daemon.h" #include "actions.h" -typedef int (*block_dev_func_t) (const char *dev, struct stringsbuf *r); - -/* Execute a given function for each discovered block device */ -static char ** -foreach_block_device (block_dev_func_t func, bool return_md) -{ - CLEANUP_FREE_STRINGSBUF DECLARE_STRINGSBUF (r); - DIR *dir; - int err = 0; - struct dirent *d; - int fd; - - dir = opendir ("/sys/block"); - if (!dir) { - reply_with_perror ("opendir: /sys/block"); - return NULL; - } - - for (;;) { - errno = 0; - d = readdir (dir); - if (!d) break; - - if (STREQLEN (d->d_name, "sd", 2) || - STREQLEN (d->d_name, "hd", 2) || - STREQLEN (d->d_name, "ubd", 3) || - STREQLEN (d->d_name, "vd", 2) || - STREQLEN (d->d_name, "sr", 2) || - (return_md && - STREQLEN (d->d_name, "md", 2) && c_isdigit (d->d_name[2]))) { - CLEANUP_FREE char *dev_path = NULL; - if (asprintf (&dev_path, "/dev/%s", d->d_name) == -1) { - reply_with_perror ("asprintf"); - closedir (dir); - return NULL; - } - - /* Ignore the root device. */ - if (is_root_device (dev_path)) - continue; - - /* RHBZ#514505: Some versions of qemu <= 0.10 add a - * CD-ROM device even though we didn't request it. Try to - * detect this by seeing if the device contains media. - */ - fd = open (dev_path, O_RDONLY|O_CLOEXEC); - if (fd == -1) { - perror (dev_path); - continue; - } - close (fd); - - /* Call the map function for this device */ - if ((*func)(d->d_name, &r) != 0) { - err = 1; - break; - } - } - } - - /* Check readdir didn't fail */ - if (errno != 0) { - reply_with_perror ("readdir: /sys/block"); - closedir (dir); - return NULL; - } - - /* Close the directory handle */ - if (closedir (dir) == -1) { - reply_with_perror ("closedir: /sys/block"); - return NULL; - } - - if (err) - return NULL; - - /* Sort the devices. */ - if (r.size > 0) - sort_device_names (r.argv, r.size); - - /* NULL terminate the list */ - if (end_stringsbuf (&r) == -1) { - return NULL; - } - - return take_stringsbuf (&r); -} - -/* Add a device to the list of devices */ -static int -add_device (const char *device, struct stringsbuf *r) -{ - char *dev_path; - - if (asprintf (&dev_path, "/dev/%s", device) == -1) { - reply_with_perror ("asprintf"); - return -1; - } - - if (add_string_nodup (r, dev_path) == -1) - return -1; - - return 0; -} - -char ** -do_list_devices (void) -{ - /* For backwards compatibility, don't return MD devices in the list - * returned by guestfs_list_devices. This is because most API users - * expect that this list is effectively the same as the list of - * devices added by guestfs_add_drive. - * - * Also, MD devices are special devices - unlike the devices exposed - * by QEMU, and there is a special API for them, - * guestfs_list_md_devices. - */ - return foreach_block_device (add_device, false); -} - -static int -add_partitions (const char *device, struct stringsbuf *r) -{ - CLEANUP_FREE char *devdir = NULL; - - /* Open the device's directory under /sys/block */ - if (asprintf (&devdir, "/sys/block/%s", device) == -1) { - reply_with_perror ("asprintf"); - return -1; - } - - DIR *dir = opendir (devdir); - if (!dir) { - reply_with_perror ("opendir: %s", devdir); - return -1; - } - - /* Look in /sys/block/<device>/ for entries starting with <device> - * e.g. /sys/block/sda/sda1 - */ - errno = 0; - struct dirent *d; - while ((d = readdir (dir)) != NULL) { - if (STREQLEN (d->d_name, device, strlen (device))) { - CLEANUP_FREE char *part = NULL; - if (asprintf (&part, "/dev/%s", d->d_name) == -1) { - perror ("asprintf"); - closedir (dir); - return -1; - } - - if (add_string (r, part) == -1) { - closedir (dir); - return -1; - } - } - } - - /* Check if readdir failed */ - if (0 != errno) { - reply_with_perror ("readdir: %s", devdir); - closedir (dir); - return -1; - } - - /* Close the directory handle */ - if (closedir (dir) == -1) { - reply_with_perror ("closedir: /sys/block/%s", device); - return -1; - } - - return 0; -} - -char ** -do_list_partitions (void) -{ - return foreach_block_device (add_partitions, true); -} - -char * -do_part_to_dev (const char *part) -{ - int err = 1; - size_t n = strlen (part); - - while (n >= 1 && c_isdigit (part[n-1])) { - err = 0; - n--; - } - - if (err) { - reply_with_error ("device name is not a partition"); - return NULL; - } - - /* Deal with <device>p<N> partition names such as /dev/md0p1. */ - if (part[n-1] == 'p') - n--; - - char *r = strndup (part, n); - if (r == NULL) { - reply_with_perror ("strdup"); - return NULL; - } - - return r; -} - -int -do_part_to_partnum (const char *part) -{ - int err = 1; - size_t n = strlen (part); - - while (n >= 1 && c_isdigit (part[n-1])) { - err = 0; - n--; - } - - if (err) { - reply_with_error ("device name is not a partition"); - return -1; - } - - int r; - if (sscanf (&part[n], "%d", &r) != 1) { - reply_with_error ("could not parse number"); - return -1; - } - - return r; -} - -int -do_is_whole_device (const char *device) -{ - /* A 'whole' block device will have a symlink to the device in its - * /sys/block directory */ - CLEANUP_FREE char *devpath = NULL; - if (asprintf (&devpath, "/sys/block/%s/device", - device + strlen ("/dev/")) == -1) { - reply_with_perror ("asprintf"); - return -1; - } - - struct stat statbuf; - if (stat (devpath, &statbuf) == -1) { - if (errno == ENOENT || errno == ENOTDIR) return 0; - - reply_with_perror ("stat"); - return -1; - } - - return 1; -} - int do_device_index (const char *device) { diff --git a/daemon/devsparts.ml b/daemon/devsparts.ml new file mode 100644 index 000000000..e97ff1267 --- /dev/null +++ b/daemon/devsparts.ml @@ -0,0 +1,109 @@ +(* guestfs-inspection + * Copyright (C) 2009-2017 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 Printf +open Unix + +open Std_utils + +open Utils + +let map_block_devices ~return_md f = + let devs = Sys.readdir "/sys/block" in + let devs = Array.to_list devs in + let devs = List.filter ( + fun dev -> + String.is_prefix dev "sd" || + String.is_prefix dev "hd" || + String.is_prefix dev "ubd" || + String.is_prefix dev "vd" || + String.is_prefix dev "sr" || + (return_md && String.is_prefix dev "md" && + String.length dev >= 3 && Char.isdigit dev.[2]) + ) devs in + + (* Ignore the root device. *) + let devs = + List.filter (fun dev -> not (is_root_device ("/dev/" ^ dev))) devs in + + (* RHBZ#514505: Some versions of qemu <= 0.10 add a + * CD-ROM device even though we didn't request it. Try to + * detect this by seeing if the device contains media. + *) + let devs = + List.filter ( + fun dev -> + try close (openfile ("/dev/" ^ dev) [O_RDONLY; O_CLOEXEC] 0); true + with _ -> false + ) devs in + + (* Call the map function for the devices left in the list. *) + List.map f devs + +let list_devices () = + (* For backwards compatibility, don't return MD devices in the list + * returned by guestfs_list_devices. This is because most API users + * expect that this list is effectively the same as the list of + * devices added by guestfs_add_drive. + * + * Also, MD devices are special devices - unlike the devices exposed + * by QEMU, and there is a special API for them, + * guestfs_list_md_devices. + *) + let devices = + map_block_devices ~return_md:false (fun dev -> "/dev/" ^ dev) in + sort_device_names devices + +let rec list_partitions () = + let partitions = map_block_devices ~return_md:true add_partitions in + let partitions = List.flatten partitions in + sort_device_names partitions + +and add_partitions dev = + (* Open the device's directory under /sys/block *) + let parts = Sys.readdir ("/sys/block/" ^ dev) in + let parts = Array.to_list parts in + + (* Look in /sys/block/<device>/ for entries starting with + * <device>, eg. /sys/block/sda/sda1. + *) + let parts = List.filter (fun part -> String.is_prefix part dev) parts in + List.map (fun part -> "/dev/" ^ part) parts + +let part_to_dev part = + let dev, part = split_device_partition part in + if part = 0 then + failwithf "device name is not a partition"; + "/dev/" ^ dev + +let part_to_partnum part = + let _, part = split_device_partition part in + if part = 0 then + failwithf "device name is not a partition"; + part + +let is_whole_device device = + (* A 'whole' block device will have a symlink to the device in its + * /sys/block directory + *) + assert (String.is_prefix device "/dev/"); + let device = String.sub device 5 (String.length device - 5) in + let devpath = sprintf "/sys/block/%s/device" device in + + try ignore (stat devpath); true + with Unix_error ((ENOENT|ENOTDIR), _, _) -> false diff --git a/daemon/devsparts.mli b/daemon/devsparts.mli new file mode 100644 index 000000000..4dfaa86e6 --- /dev/null +++ b/daemon/devsparts.mli @@ -0,0 +1,25 @@ +(* guestfs-inspection + * Copyright (C) 2009-2017 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. + *) + +val list_devices : unit -> string list +val list_partitions : unit -> string list + +val part_to_dev : string -> string +val part_to_partnum : string -> int + +val is_whole_device : string -> bool diff --git a/daemon/guestfsd.c b/daemon/guestfsd.c index 05337b31c..9704094a6 100644 --- a/daemon/guestfsd.c +++ b/daemon/guestfsd.c @@ -630,81 +630,6 @@ free_stringslen (char **argv, size_t len) } /** - * Compare device names (including partition numbers if present). - * - * L<https://rwmj.wordpress.com/2011/01/09/how-are-linux-drives-named-bey... - */ -int -compare_device_names (const char *a, const char *b) -{ - size_t alen, blen; - int r; - int a_partnum, b_partnum; - - /* Skip /dev/ prefix if present. */ - if (STRPREFIX (a, "/dev/")) - a += 5; - if (STRPREFIX (b, "/dev/")) - b += 5; - - /* Skip sd/hd/ubd/vd. */ - alen = strcspn (a, "d"); - blen = strcspn (b, "d"); - assert (alen > 0 && alen <= 2); - assert (blen > 0 && blen <= 2); - a += alen + 1; - b += blen + 1; - - /* Get device name part, that is, just 'a', 'ab' etc. */ - alen = strcspn (a, "0123456789"); - blen = strcspn (b, "0123456789"); - - /* If device name part is longer, it is always greater, eg. - * "/dev/sdz" < "/dev/sdaa". - */ - if (alen != blen) - return alen - blen; - - /* Device name parts are the same length, so do a regular compare. */ - r = strncmp (a, b, alen); - if (r != 0) - return r; - - /* Compare partitions numbers. */ - a += alen; - b += alen; - - /* If no partition numbers, bail -- the devices are the same. This - * can happen in one peculiar case: where you have a mix of devices - * with different interfaces (eg. /dev/sda and /dev/vda). - * (RHBZ#858128). - */ - if (!*a && !*b) - return 0; - - r = sscanf (a, "%d", &a_partnum); - assert (r == 1); - r = sscanf (b, "%d", &b_partnum); - assert (r == 1); - - return a_partnum - b_partnum; -} - -static int -compare_device_names_vp (const void *vp1, const void *vp2) -{ - char * const *p1 = (char * const *) vp1; - char * const *p2 = (char * const *) vp2; - return compare_device_names (*p1, *p2); -} - -void -sort_device_names (char **argv, size_t len) -{ - qsort (argv, len, sizeof (char *), compare_device_names_vp); -} - -/** * Split an output string into a NULL-terminated list of lines, * wrapped into a stringsbuf. * diff --git a/daemon/utils.ml b/daemon/utils.ml index 7630a5534..48f6b9c5c 100644 --- a/daemon/utils.ml +++ b/daemon/utils.ml @@ -129,6 +129,90 @@ let is_root_device device = device func arg (error_message err); false +(* XXX This function is copied from C, but is misconceived. It + * cannot by design work for devices like /dev/md0. It would be + * better if it checked for the existence of devices and partitions + * in /sys/block so we know what the kernel thinks is a device or + * partition. The same applies to APIs such as part_to_partnum + * and part_to_dev which rely on this function. + *) +let split_device_partition dev = + (* Skip /dev/ prefix if present. *) + let dev = + if String.is_prefix dev "/dev/" then + String.sub dev 5 (String.length dev - 5) + else dev in + + (* Find the partition number (if present). *) + let dev, part = + let n = String.length dev in + let i = ref n in + while !i >= 1 && Char.isdigit dev.[!i-1] do + decr i + done; + let i = !i in + if i = n then + dev, 0 (* no partition number, whole device *) + else + String.sub dev 0 i, int_of_string (String.sub dev i (n-i)) in + + (* Deal with device names like /dev/md0p1. *) + (* XXX This function is buggy (as was the old C function) when + * presented with a whole device like /dev/md0. + *) + let dev = + let n = String.length dev in + if n < 2 || dev.[n-1] <> 'p' || not (Char.isdigit dev.[n-2]) then + dev + else ( + let i = ref (n-1) in + while !i >= 0 && Char.isdigit dev.[!i] do + decr i; + done; + let i = !i in + String.sub dev 0 i + ) in + + dev, part + +let rec sort_device_names devs = + List.sort compare_device_names devs + +and compare_device_names a b = + (* This takes the device name like "/dev/sda1" and returns ("sda", 1). *) + let dev_a, part_a = split_device_partition a + and dev_b, part_b = split_device_partition b in + + (* Skip "sd|hd|ubd..." so that /dev/sda and /dev/vda sort together. + * (This is what the old C function did, but it's not clear if it + * is still relevant. XXX) + *) + let skip_prefix dev = + let n = String.length dev in + if n >= 2 && dev.[1] = 'd' then + String.sub dev 2 (String.length dev - 2) + else if n >= 3 && dev.[2] = 'd' then + String.sub dev 3 (String.length dev - 3) + else + dev in + let dev_a = skip_prefix dev_a + and dev_b = skip_prefix dev_b in + + (* If device name part is longer, it is always greater, eg. + * "/dev/sdz" < "/dev/sdaa". + *) + let r = compare (String.length dev_a) (String.length dev_b) in + if r <> 0 then r + else ( + (* Device name parts are the same length, so do a regular compare. *) + let r = compare dev_a dev_b in + if r <> 0 then r + else ( + (* Device names are identical, so compare partition numbers. *) + compare part_a part_b + ) + ) + let proc_unmangle_path path = let n = String.length path in let b = Buffer.create n in diff --git a/daemon/utils.mli b/daemon/utils.mli index 57f703c6c..a1f956be3 100644 --- a/daemon/utils.mli +++ b/daemon/utils.mli @@ -41,6 +41,21 @@ val is_root_device_stat : Unix.stats -> bool (** As for {!is_root_device} but operates on a statbuf instead of a device name. *) +val split_device_partition : string -> string * int +(** Split a device name like [/dev/sda1] into a device name and + partition number, eg. ["sda", 1]. + + The [/dev/] prefix is skipped and removed, if present. + + If the partition number is not present (a whole device), 0 is returned. + + This function splits [/dev/md0p1] to ["md0", 1]. *) + +val sort_device_names : string list -> string list +(** Sort device names correctly so that /dev/sdaa appears after /dev/sdz. + This also deals with partition numbers, and works whether or not + [/dev/] is present. *) + val proc_unmangle_path : string -> string (** Reverse kernel path escaping done in fs/seq_file.c:mangle_path. This is inconsistently used for /proc fields. *) diff --git a/generator/actions_core.ml b/generator/actions_core.ml index a6eb2c273..94391288f 100644 --- a/generator/actions_core.ml +++ b/generator/actions_core.ml @@ -1817,6 +1817,7 @@ is I<not> intended that you try to parse the output string." }; { defaults with name = "list_devices"; added = (0, 0, 4); style = RStringList (RDevice, "devices"), [], []; + impl = OCaml "Devsparts.list_devices"; tests = [ InitEmpty, Always, TestResult ( [["list_devices"]], @@ -1833,6 +1834,7 @@ See also C<guestfs_list_filesystems>." }; { defaults with name = "list_partitions"; added = (0, 0, 4); style = RStringList (RDevice, "partitions"), [], []; + impl = OCaml "Devsparts.list_partitions"; tests = [ InitBasicFS, Always, TestResult ( [["list_partitions"]], @@ -6086,6 +6088,7 @@ See also C<guestfs_stat>." }; { defaults with name = "part_to_dev"; added = (1, 5, 15); style = RString (RDevice, "device"), [String (Device, "partition")], []; + impl = OCaml "Devsparts.part_to_dev"; tests = [ InitPartition, Always, TestResultDevice ( [["part_to_dev"; "/dev/sda1"]], "/dev/sda"), []; @@ -6533,6 +6536,7 @@ as in C<guestfs_compress_out>." }; { defaults with name = "part_to_partnum"; added = (1, 13, 25); style = RInt "partnum", [String (Device, "partition")], []; + impl = OCaml "Devsparts.part_to_partnum"; tests = [ InitPartition, Always, TestResult ( [["part_to_partnum"; "/dev/sda1"]], "ret == 1"), []; @@ -8480,6 +8484,7 @@ you are better to use C<guestfs_mv> instead." }; { defaults with name = "is_whole_device"; added = (1, 21, 9); style = RBool "flag", [String (Device, "device")], []; + impl = OCaml "Devsparts.is_whole_device"; tests = [ InitEmpty, Always, TestResultTrue ( [["is_whole_device"; "/dev/sda"]]), []; diff --git a/generator/daemon.ml b/generator/daemon.ml index 121634806..3ffe91537 100644 --- a/generator/daemon.ml +++ b/generator/daemon.ml @@ -553,6 +553,26 @@ copy_mountable (const mountable_t *mountable) CAMLreturn (r); } +/* Implement RStringList. */ +static char ** +return_string_list (value retv) +{ + CLEANUP_FREE_STRINGSBUF DECLARE_STRINGSBUF (ret); + value v; + + while (retv != Val_int (0)) { + v = Field (retv, 0); + if (add_string (&ret, String_val (v)) == -1) + return NULL; + retv = Field (retv, 1); + } + + if (end_stringsbuf (&ret) == -1) + return NULL; + + return take_stringsbuf (&ret); /* caller frees */ +} + "; List.iter ( @@ -669,12 +689,14 @@ copy_mountable (const mountable_t *mountable) (match ret with | RErr -> assert false - | RInt _ -> assert false + | RInt _ -> + pr " CAMLreturnT (int, Int_val (retv));\n" | RInt64 _ -> assert false - | RBool _ -> assert false + | RBool _ -> + pr " CAMLreturnT (int, Bool_val (retv));\n" | RConstString _ -> assert false | RConstOptString _ -> assert false - | RString (RPlainString, _) -> + | RString ((RPlainString|RDevice), _) -> pr " char *ret = strdup (String_val (retv));\n"; pr " if (ret == NULL) {\n"; pr " reply_with_perror (\"strdup\");\n"; @@ -682,7 +704,9 @@ copy_mountable (const mountable_t *mountable) pr " }\n"; pr " CAMLreturnT (char *, ret); /* caller frees */\n" | RString _ -> assert false - | RStringList _ -> assert false + | RStringList _ -> + pr " char **ret = return_string_list (retv);\n"; + pr " CAMLreturnT (char **, ret); /* caller frees */\n" | RStruct _ -> assert false | RStructList _ -> assert false | RHashtable _ -> assert false -- 2.13.0

This also demonstrates usage of optional arguments. --- daemon/Makefile.am | 2 ++ daemon/is.c | 41 ----------------------------------------- daemon/is.ml | 44 ++++++++++++++++++++++++++++++++++++++++++++ daemon/is.mli | 21 +++++++++++++++++++++ generator/actions_core.ml | 3 +++ generator/daemon.ml | 7 ++++--- 6 files changed, 74 insertions(+), 44 deletions(-) create mode 100644 daemon/is.ml create mode 100644 daemon/is.mli diff --git a/daemon/Makefile.am b/daemon/Makefile.am index 9311d0ba0..a77298502 100644 --- a/daemon/Makefile.am +++ b/daemon/Makefile.am @@ -263,6 +263,7 @@ SOURCES_MLI = \ sysroot.mli \ devsparts.mli \ file.mli \ + is.mli \ mountable.mli \ utils.mli @@ -275,6 +276,7 @@ SOURCES_ML = \ blkid.ml \ devsparts.ml \ file.ml \ + is.ml \ callbacks.ml \ daemon.ml diff --git a/daemon/is.c b/daemon/is.c index 4d5e911c2..a91dab32b 100644 --- a/daemon/is.c +++ b/daemon/is.c @@ -39,36 +39,6 @@ do_exists (const char *path) /* Takes optional arguments, consult optargs_bitmask. */ int -do_is_file (const char *path, int followsymlinks) -{ - mode_t mode; - int r; - - if (!(optargs_bitmask & GUESTFS_IS_FILE_FOLLOWSYMLINKS_BITMASK)) - followsymlinks = 0; - - r = get_mode (path, &mode, followsymlinks); - if (r <= 0) return r; - return S_ISREG (mode); -} - -/* Takes optional arguments, consult optargs_bitmask. */ -int -do_is_dir (const char *path, int followsymlinks) -{ - mode_t mode; - int r; - - if (!(optargs_bitmask & GUESTFS_IS_DIR_FOLLOWSYMLINKS_BITMASK)) - followsymlinks = 0; - - r = get_mode (path, &mode, followsymlinks); - if (r <= 0) return r; - return S_ISDIR (mode); -} - -/* Takes optional arguments, consult optargs_bitmask. */ -int do_is_chardev (const char *path, int followsymlinks) { mode_t mode; @@ -112,17 +82,6 @@ do_is_fifo (const char *path, int followsymlinks) return S_ISFIFO (mode); } -int -do_is_symlink (const char *path) -{ - mode_t mode; - int r; - - r = get_mode (path, &mode, 0); - if (r <= 0) return r; - return S_ISLNK (mode); -} - /* Takes optional arguments, consult optargs_bitmask. */ int do_is_socket (const char *path, int followsymlinks) diff --git a/daemon/is.ml b/daemon/is.ml new file mode 100644 index 000000000..b99215737 --- /dev/null +++ b/daemon/is.ml @@ -0,0 +1,44 @@ +(* guestfs-inspection + * Copyright (C) 2009-2017 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 Printf +open Unix + +let rec is_file ?(followsymlinks = false) path = + let sysroot = Sysroot.sysroot () in + let chroot = Chroot.create sysroot ~name:(sprintf "is_file: %s" path) in + Chroot.f chroot get_kind (path, followsymlinks) = Some S_REG + +and is_dir ?(followsymlinks = false) path = + let sysroot = Sysroot.sysroot () in + let chroot = Chroot.create sysroot ~name:(sprintf "is_dir: %s" path) in + Chroot.f chroot get_kind (path, followsymlinks) = Some S_DIR + +and is_symlink path = + let sysroot = Sysroot.sysroot () in + let chroot = Chroot.create sysroot ~name:(sprintf "is_symlink: %s" path) in + Chroot.f chroot get_kind (path, false) = Some S_LNK + +and get_kind (path, followsymlinks) = + let statfun = if followsymlinks then stat else lstat in + try + let statbuf = statfun path in + Some statbuf.st_kind + with + Unix_error ((ENOENT|ENOTDIR), _, _) -> + None (* File doesn't exist => return None *) diff --git a/daemon/is.mli b/daemon/is.mli new file mode 100644 index 000000000..20622c39f --- /dev/null +++ b/daemon/is.mli @@ -0,0 +1,21 @@ +(* guestfs-inspection + * Copyright (C) 2009-2017 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. + *) + +val is_file : ?followsymlinks:bool -> string -> bool +val is_dir : ?followsymlinks:bool -> string -> bool +val is_symlink : string -> bool diff --git a/generator/actions_core.ml b/generator/actions_core.ml index 94391288f..421f3ac6b 100644 --- a/generator/actions_core.ml +++ b/generator/actions_core.ml @@ -2114,6 +2114,7 @@ See also C<guestfs_is_file>, C<guestfs_is_dir>, C<guestfs_stat>." }; { defaults with name = "is_file"; added = (0, 0, 8); style = RBool "fileflag", [String (Pathname, "path")], [OBool "followsymlinks"]; + impl = OCaml "Is.is_file"; once_had_no_optargs = true; tests = [ InitISOFS, Always, TestResultTrue ( @@ -2138,6 +2139,7 @@ See also C<guestfs_stat>." }; { defaults with name = "is_dir"; added = (0, 0, 8); style = RBool "dirflag", [String (Pathname, "path")], [OBool "followsymlinks"]; + impl = OCaml "Is.is_dir"; once_had_no_optargs = true; tests = [ InitISOFS, Always, TestResultFalse ( @@ -6052,6 +6054,7 @@ See also C<guestfs_stat>." }; { defaults with name = "is_symlink"; added = (1, 5, 10); style = RBool "flag", [String (Pathname, "path")], []; + impl = OCaml "Is.is_symlink"; tests = [ InitISOFS, Always, TestResultFalse ( [["is_symlink"; "/directory"]]), []; diff --git a/generator/daemon.ml b/generator/daemon.ml index 3ffe91537..ef6086bfe 100644 --- a/generator/daemon.ml +++ b/generator/daemon.ml @@ -577,6 +577,7 @@ return_string_list (value retv) List.iter ( fun ({ name = name; style = ret, args, optargs } as f) -> + let uc_name = String.uppercase_ascii name in let ocaml_function = match f.impl with | OCaml f -> f @@ -625,8 +626,8 @@ return_string_list (value retv) let uc_n = String.uppercase_ascii n in (* optargs are all passed as [None|Some _] *) - pr " if ((optargs_bitmask & %s_%s_BITMASK) == 0)\n" - f.c_optarg_prefix uc_n; + pr " if ((optargs_bitmask & GUESTFS_%s_%s_BITMASK) == 0)\n" + uc_name uc_n; pr " args[%d] = Val_int (0); /* None */\n" !i; pr " else {\n"; pr " v = "; @@ -651,7 +652,7 @@ return_string_list (value retv) | Bool n -> pr "Val_bool (%s)" n | Int n -> pr "Val_int (%s)" n | Int64 n -> pr "caml_copy_int64 (%s)" n - | String ((PlainString|Device|Dev_or_Path), n) -> + | String ((PlainString|Device|Pathname|Dev_or_Path), n) -> pr "caml_copy_string (%s)" n | String (Mountable, n) -> pr "copy_mountable (%s)" n -- 2.13.0

Some of the oldest and most core APIs, reimplemented. This also moves the strange ‘mount_vfs_nochroot’ function into btrfs.c. --- daemon/Makefile.am | 2 + daemon/btrfs.c | 43 ++++++++++++++++++++ daemon/daemon.h | 6 --- daemon/mount.c | 99 ----------------------------------------------- daemon/mount.ml | 62 +++++++++++++++++++++++++++++ daemon/mount.mli | 22 +++++++++++ generator/actions_core.ml | 4 ++ generator/daemon.ml | 3 +- 8 files changed, 135 insertions(+), 106 deletions(-) create mode 100644 daemon/mount.ml create mode 100644 daemon/mount.mli diff --git a/daemon/Makefile.am b/daemon/Makefile.am index 63c01ef94..6b50e905d 100644 --- a/daemon/Makefile.am +++ b/daemon/Makefile.am @@ -265,6 +265,7 @@ SOURCES_MLI = \ file.mli \ is.mli \ link.mli \ + mount.mli \ mountable.mli \ utils.mli @@ -279,6 +280,7 @@ SOURCES_ML = \ file.ml \ is.ml \ link.ml \ + mount.ml \ callbacks.ml \ daemon.ml diff --git a/daemon/btrfs.c b/daemon/btrfs.c index 5f1e5d1d0..4f52b71e8 100644 --- a/daemon/btrfs.c +++ b/daemon/btrfs.c @@ -37,6 +37,7 @@ GUESTFSD_EXT_CMD(str_btrfs, btrfs); GUESTFSD_EXT_CMD(str_btrfstune, btrfstune); GUESTFSD_EXT_CMD(str_btrfsck, btrfsck); GUESTFSD_EXT_CMD(str_mkfs_btrfs, mkfs.btrfs); +GUESTFSD_EXT_CMD(str_mount, mount); GUESTFSD_EXT_CMD(str_umount, umount); GUESTFSD_EXT_CMD(str_btrfsimage, btrfs-image); @@ -387,6 +388,48 @@ do_btrfs_subvolume_create (const char *dest, const char *qgroupid) return 0; } +static int +mount_vfs_nochroot (const char *options, const char *vfstype, + const mountable_t *mountable, + const char *mp, const char *user_mp) +{ + CLEANUP_FREE char *options_plus = NULL; + const char *device = mountable->device; + if (mountable->type == MOUNTABLE_BTRFSVOL) { + if (options && strlen (options) > 0) { + if (asprintf (&options_plus, "subvol=%s,%s", + mountable->volume, options) == -1) { + reply_with_perror ("asprintf"); + return -1; + } + } + else { + if (asprintf (&options_plus, "subvol=%s", mountable->volume) == -1) { + reply_with_perror ("asprintf"); + return -1; + } + } + } + + CLEANUP_FREE char *error = NULL; + int r; + if (vfstype) + r = command (NULL, &error, + str_mount, "-o", options_plus ? options_plus : options, + "-t", vfstype, device, mp, NULL); + else + r = command (NULL, &error, + str_mount, "-o", options_plus ? options_plus : options, + device, mp, NULL); + if (r == -1) { + reply_with_error ("%s on %s (options: '%s'): %s", + device, user_mp, options, error); + return -1; + } + + return 0; +} + static char * mount (const mountable_t *fs) { diff --git a/daemon/daemon.h b/daemon/daemon.h index 684f9b096..9f4a7f8a6 100644 --- a/daemon/daemon.h +++ b/daemon/daemon.h @@ -94,12 +94,6 @@ extern void cleanup_free_stringsbuf (void *ptr); #define CLEANUP_FREE_STRINGSBUF #endif -/*-- in mount.c --*/ - -extern int mount_vfs_nochroot (const char *options, const char *vfstype, - const mountable_t *mountable, - const char *mp, const char *user_mp); - /* Growable strings buffer. */ struct stringsbuf { char **argv; diff --git a/daemon/mount.c b/daemon/mount.c index 0ad9626a7..962b86079 100644 --- a/daemon/mount.c +++ b/daemon/mount.c @@ -111,105 +111,6 @@ is_device_mounted (const char *device) return 0; } -/* The "simple mount" call offers no complex options, you can just - * mount a device on a mountpoint. The variations like mount_ro, - * mount_options and mount_vfs let you set progressively more things. - * - * It's tempting to try a direct mount(2) syscall, but that doesn't - * do any autodetection, so we are better off calling out to - * /bin/mount. - */ - -int -do_mount_vfs (const char *options, const char *vfstype, - const mountable_t *mountable, const char *mountpoint) -{ - CLEANUP_FREE char *mp = NULL; - struct stat statbuf; - - ABS_PATH (mountpoint, 0, return -1); - - mp = sysroot_path (mountpoint); - if (!mp) { - reply_with_perror ("malloc"); - return -1; - } - - /* Check the mountpoint exists and is a directory. */ - if (stat (mp, &statbuf) == -1) { - reply_with_perror ("mount: %s", mountpoint); - return -1; - } - if (!S_ISDIR (statbuf.st_mode)) { - reply_with_perror ("mount: %s: mount point is not a directory", mountpoint); - return -1; - } - - return mount_vfs_nochroot (options, vfstype, mountable, mp, mountpoint); -} - -int -mount_vfs_nochroot (const char *options, const char *vfstype, - const mountable_t *mountable, - const char *mp, const char *user_mp) -{ - CLEANUP_FREE char *options_plus = NULL; - const char *device = mountable->device; - if (mountable->type == MOUNTABLE_BTRFSVOL) { - if (options && strlen (options) > 0) { - if (asprintf (&options_plus, "subvol=%s,%s", - mountable->volume, options) == -1) { - reply_with_perror ("asprintf"); - return -1; - } - } - - else { - if (asprintf (&options_plus, "subvol=%s", mountable->volume) == -1) { - reply_with_perror ("asprintf"); - return -1; - } - } - } - - CLEANUP_FREE char *error = NULL; - int r; - if (vfstype) - r = command (NULL, &error, - str_mount, "-o", options_plus ? options_plus : options, - "-t", vfstype, device, mp, NULL); - else - r = command (NULL, &error, - str_mount, "-o", options_plus ? options_plus : options, - device, mp, NULL); - if (r == -1) { - reply_with_error ("%s on %s (options: '%s'): %s", - device, user_mp, options, error); - return -1; - } - - return 0; -} - -int -do_mount (const mountable_t *mountable, const char *mountpoint) -{ - return do_mount_vfs ("", NULL, mountable, mountpoint); -} - -int -do_mount_ro (const mountable_t *mountable, const char *mountpoint) -{ - return do_mount_vfs ("ro", NULL, mountable, mountpoint); -} - -int -do_mount_options (const char *options, const mountable_t *mountable, - const char *mountpoint) -{ - return do_mount_vfs (options, NULL, mountable, mountpoint); -} - /* Takes optional arguments, consult optargs_bitmask. */ int do_umount (const char *pathordevice, diff --git a/daemon/mount.ml b/daemon/mount.ml new file mode 100644 index 000000000..4bb74fb82 --- /dev/null +++ b/daemon/mount.ml @@ -0,0 +1,62 @@ +(* guestfs-inspection + * Copyright (C) 2009-2017 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 Std_utils + +open Mountable +open Utils + +let mount_vfs options vfs mountable mountpoint = + let mp = Sysroot.sysroot () // mountpoint in + + (* Check the mountpoint exists and is a directory. *) + if not (is_directory mp) then + failwithf "mount: %s: mount point is not a directory" mountpoint; + + let args = ref [] in + + (* -o options *) + (match options, mountable.m_type with + | (None | Some ""), (MountableDevice | MountablePath) -> () + | Some options, (MountableDevice | MountablePath) -> + push_back args "-o"; + push_back args options + | (None | Some ""), MountableBtrfsVol subvol -> + push_back args "-o"; + push_back args ("subvol=" ^ subvol) + | Some options, MountableBtrfsVol subvol -> + push_back args "-o"; + push_back args ("subvol=" ^ subvol ^ "," ^ options) + ); + + (* -t vfs *) + (match vfs with + | None | Some "" -> () + | Some t -> + push_back args "-t"; + push_back args t + ); + + push_back args mountable.m_device; + push_back args mp; + + ignore (command "mount" !args) + +let mount = mount_vfs None None +let mount_ro = mount_vfs (Some "ro") None +let mount_options options = mount_vfs (Some options) None diff --git a/daemon/mount.mli b/daemon/mount.mli new file mode 100644 index 000000000..e43d97c42 --- /dev/null +++ b/daemon/mount.mli @@ -0,0 +1,22 @@ +(* guestfs-inspection + * Copyright (C) 2009-2017 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. + *) + +val mount : Mountable.t -> string -> unit +val mount_ro : Mountable.t -> string -> unit +val mount_options : string -> Mountable.t -> string -> unit +val mount_vfs : string option -> string option -> Mountable.t -> string -> unit diff --git a/generator/actions_core.ml b/generator/actions_core.ml index 7d6755fdc..f33bc5320 100644 --- a/generator/actions_core.ml +++ b/generator/actions_core.ml @@ -1739,6 +1739,7 @@ let daemon_functions = [ { defaults with name = "mount"; added = (0, 0, 3); style = RErr, [String (Mountable, "mountable"); String (PlainString, "mountpoint")], []; + impl = OCaml "Mount.mount"; tests = [ InitEmpty, Always, TestResultString ( [["part_disk"; "/dev/sda"; "mbr"]; @@ -2922,6 +2923,7 @@ If set to true, POSIX ACLs are saved in the output tar. { defaults with name = "mount_ro"; added = (1, 0, 10); style = RErr, [String (Mountable, "mountable"); String (PlainString, "mountpoint")], []; + impl = OCaml "Mount.mount_ro"; tests = [ InitBasicFS, Always, TestLastFail ( [["umount"; "/"; "false"; "false"]; @@ -2941,6 +2943,7 @@ mounts the filesystem with the read-only (I<-o ro>) flag." }; { defaults with name = "mount_options"; added = (1, 0, 10); style = RErr, [String (PlainString, "options"); String (Mountable, "mountable"); String (PlainString, "mountpoint")], []; + impl = OCaml "Mount.mount_options"; shortdesc = "mount a guest disk with mount options"; longdesc = "\ This is the same as the C<guestfs_mount> command, but it @@ -2954,6 +2957,7 @@ the filesystem uses)." }; { defaults with name = "mount_vfs"; added = (1, 0, 10); style = RErr, [String (PlainString, "options"); String (PlainString, "vfstype"); String (Mountable, "mountable"); String (PlainString, "mountpoint")], []; + impl = OCaml "Mount.mount_vfs"; shortdesc = "mount a guest disk with mount options and vfstype"; longdesc = "\ This is the same as the C<guestfs_mount> command, but it diff --git a/generator/daemon.ml b/generator/daemon.ml index ef6086bfe..fd01e5d8a 100644 --- a/generator/daemon.ml +++ b/generator/daemon.ml @@ -689,7 +689,8 @@ return_string_list (value retv) pr "\n"; (match ret with - | RErr -> assert false + | RErr -> + pr " CAMLreturnT (int, 0);\n" | RInt _ -> pr " CAMLreturnT (int, Int_val (retv));\n" | RInt64 _ -> assert false -- 2.13.0

--- daemon/Makefile.am | 2 + daemon/realpath.c | 187 ---------------------------------------------- daemon/realpath.ml | 83 ++++++++++++++++++++ daemon/realpath.mli | 19 +++++ generator/actions_core.ml | 1 + 5 files changed, 105 insertions(+), 187 deletions(-) create mode 100644 daemon/realpath.ml create mode 100644 daemon/realpath.mli diff --git a/daemon/Makefile.am b/daemon/Makefile.am index 33d2a472e..fa1bb731e 100644 --- a/daemon/Makefile.am +++ b/daemon/Makefile.am @@ -268,6 +268,7 @@ SOURCES_MLI = \ mount.mli \ mountable.mli \ parted.mli \ + realpath.mli \ utils.mli SOURCES_ML = \ @@ -283,6 +284,7 @@ SOURCES_ML = \ link.ml \ mount.ml \ parted.ml \ + realpath.ml \ callbacks.ml \ daemon.ml diff --git a/daemon/realpath.c b/daemon/realpath.c index 24ab133e2..f9d22d28d 100644 --- a/daemon/realpath.c +++ b/daemon/realpath.c @@ -48,190 +48,3 @@ do_realpath (const char *path) return ret; /* caller frees */ } - -static int find_path_element (int fd_cwd, int is_end, const char *name, char **name_ret); - -char * -do_case_sensitive_path (const char *path) -{ - size_t next; - int fd_cwd, fd2, err, is_end; - char *ret; - - ret = strdup ("/"); - if (ret == NULL) { - reply_with_perror ("strdup"); - return NULL; - } - next = 1; /* next position in 'ret' buffer */ - - /* 'fd_cwd' here is a surrogate for the current working directory, so - * that we don't have to actually call chdir(2). - */ - fd_cwd = open (sysroot, O_RDONLY|O_DIRECTORY|O_CLOEXEC); - if (fd_cwd == -1) { - reply_with_perror ("%s", sysroot); - goto error; - } - - /* First character is a '/'. Take each subsequent path element - * and follow it. - */ - while (*path) { - char *t; - size_t i, len; - CLEANUP_FREE char *name_in = NULL, *name_out = NULL; - - i = strcspn (path, "/"); - if (i == 0) { - path++; - continue; - } - - if ((i == 1 && path[0] == '.') || - (i == 2 && path[0] == '.' && path[1] == '.')) { - reply_with_error ("path contained . or .. elements"); - goto error; - } - - name_in = strndup (path, i); - if (name_in == NULL) { - reply_with_perror ("strdup"); - goto error; - } - - /* Skip to next element in path (for the next loop iteration). */ - path += i; - is_end = *path == 0; - - /* Read the current directory looking (case insensitively) for - * this element of the path. This replaces 'name' with the - * correct case version. - */ - if (find_path_element (fd_cwd, is_end, name_in, &name_out) == -1) - goto error; - len = strlen (name_out); - - /* Add the real name of this path element to the return value. */ - if (next > 1) - ret[next++] = '/'; - - t = realloc (ret, next+len+1); - if (t == NULL) { - reply_with_perror ("realloc"); - goto error; - } - ret = t; - - strcpy (&ret[next], name_out); - next += len; - - /* Is it a directory? Try going into it. */ - fd2 = openat (fd_cwd, name_out, O_RDONLY|O_DIRECTORY|O_CLOEXEC); - err = errno; - close (fd_cwd); - fd_cwd = fd2; - errno = err; - if (fd_cwd == -1) { - /* Some errors are OK provided we've reached the end of the path. */ - if (is_end && (errno == ENOTDIR || errno == ENOENT)) - break; - - reply_with_perror ("openat: %s", name_out); - goto error; - } - } - - if (fd_cwd >= 0) - close (fd_cwd); - - return ret; /* caller frees */ - - error: - if (fd_cwd >= 0) - close (fd_cwd); - free (ret); - - return NULL; -} - -/* 'fd_cwd' is a file descriptor pointing to an open directory. - * 'name' is the path element to search for. 'is_end' is a flag - * indicating if this is the last path element. - * - * We search the directory looking for a path element that case - * insensitively matches 'name', returning the actual name in '*name_ret'. - * - * If this is successful, return 0. If it fails, reply with an error - * and return -1. - */ -static int -find_path_element (int fd_cwd, int is_end, const char *name, char **name_ret) -{ - int fd2; - DIR *dir; - struct dirent *d; - - fd2 = dup_cloexec (fd_cwd); /* because closedir will close it */ - if (fd2 == -1) { - reply_with_perror ("dup"); - return -1; - } - dir = fdopendir (fd2); - if (dir == NULL) { - reply_with_perror ("opendir"); - close (fd2); - return -1; - } - - for (;;) { - errno = 0; - d = readdir (dir); - if (d == NULL) - break; - if (STRCASEEQ (d->d_name, name)) - break; - } - - if (d == NULL && errno != 0) { - reply_with_perror ("readdir"); - closedir (dir); - return -1; - } - - if (d == NULL && is_end) { - /* Last path element: return it as-is, assuming that the user will - * create a new file or directory (RHBZ#840115). - */ - closedir (dir); - *name_ret = strdup (name); - if (*name_ret == NULL) { - reply_with_perror ("strdup"); - return -1; - } - return 0; - } - - if (d == NULL) { - reply_with_error ("%s: no file or directory found with this name", name); - closedir (dir); - return -1; - } - - *name_ret = strdup (d->d_name); - if (*name_ret == NULL) { - reply_with_perror ("strdup"); - closedir (dir); - return -1; - } - - /* NB: closedir frees the structure associated with 'd', so we must - * do this last. - */ - if (closedir (dir) == -1) { - reply_with_perror ("closedir"); - return -1; - } - - return 0; -} diff --git a/daemon/realpath.ml b/daemon/realpath.ml new file mode 100644 index 000000000..918481015 --- /dev/null +++ b/daemon/realpath.ml @@ -0,0 +1,83 @@ +(* guestfs-inspection + * Copyright (C) 2009-2017 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 Printf + +open Std_utils + +(* The infamous case_sensitive_path function, which works around + * the bug in ntfs-3g that all paths are case sensitive even though + * the underlying filesystem is case insensitive. + *) +let rec case_sensitive_path path = + let elems = String.nsplit "/" path in + + (* The caller ensures that the first element of [path] is [/], + * and therefore the first element of the split list must be + * empty. + *) + assert (List.length elems > 0); + assert (List.hd elems = ""); + let elems = List.tl elems in + + let sysroot = Sysroot.sysroot () in + let chroot = Chroot.create sysroot + ~name:(sprintf "case_sensitive_path: %s" path) in + + (* Now we iterate down the tree starting at the sysroot. *) + let elems = + Chroot.f chroot ( + fun () -> + let rec loop = function + | [] -> [] + | [ "."|".." ] -> + failwithf "path contains \"//\" or \".\" or \"..\" elements" + | "" :: elems -> + (* For compatibility with C implementation, we ignore + * "//" in the middle of the path. + *) + loop elems + | [ file ] -> + (* If it's the final element, it's allowed to be missing. *) + (match find_path_element file with + | None -> [ file ] (* return the original *) + | Some file -> [ file ] + ); + | elem :: elems -> + (match find_path_element elem with + | None -> + failwithf "%s: not found" elem + | Some elem -> + (* This will fail intentionally if not a directory. *) + Unix.chdir elem; + elem :: loop elems + ) + in + loop elems + ) () in + + (* Reconstruct the case sensitive path. *) + "/" ^ String.concat "/" elems + +and find_path_element name = + let dir = Sys.readdir "." in + let dir = Array.to_list dir in + let lc_name = String.lowercase_ascii name in + let cmp n = String.lowercase_ascii n = lc_name in + try Some (List.find cmp dir) + with Not_found -> None diff --git a/daemon/realpath.mli b/daemon/realpath.mli new file mode 100644 index 000000000..371e619fc --- /dev/null +++ b/daemon/realpath.mli @@ -0,0 +1,19 @@ +(* guestfs-inspection + * Copyright (C) 2009-2017 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. + *) + +val case_sensitive_path : string -> string diff --git a/generator/actions_core.ml b/generator/actions_core.ml index 4bf0c7b70..54d0a6ca8 100644 --- a/generator/actions_core.ml +++ b/generator/actions_core.ml @@ -4797,6 +4797,7 @@ The result list is not sorted. { defaults with name = "case_sensitive_path"; added = (1, 0, 75); style = RString (RPlainString, "rpath"), [String (Pathname, "path")], []; + impl = OCaml "Realpath.case_sensitive_path"; tests = [ InitISOFS, Always, TestResultString ( [["case_sensitive_path"; "/DIRECTORY"]], "/directory"), []; -- 2.13.0

--- daemon/Makefile.am | 2 ++ daemon/ldm.c | 82 ----------------------------------------------- daemon/ldm.ml | 52 ++++++++++++++++++++++++++++++ daemon/ldm.mli | 20 ++++++++++++ generator/actions_core.ml | 2 ++ 5 files changed, 76 insertions(+), 82 deletions(-) create mode 100644 daemon/ldm.ml create mode 100644 daemon/ldm.mli diff --git a/daemon/Makefile.am b/daemon/Makefile.am index e956745a2..652349cf0 100644 --- a/daemon/Makefile.am +++ b/daemon/Makefile.am @@ -265,6 +265,7 @@ SOURCES_MLI = \ file.mli \ filearch.mli \ is.mli \ + ldm.mli \ link.mli \ mount.mli \ mountable.mli \ @@ -283,6 +284,7 @@ SOURCES_ML = \ file.ml \ filearch.ml \ is.ml \ + ldm.ml \ link.ml \ mount.ml \ parted.ml \ diff --git a/daemon/ldm.c b/daemon/ldm.c index 75418e8d3..5106e65f9 100644 --- a/daemon/ldm.c +++ b/daemon/ldm.c @@ -23,7 +23,6 @@ #include <unistd.h> #include <sys/types.h> #include <sys/stat.h> -#include <glob.h> #include <string.h> #include <yajl/yajl_tree.h> @@ -47,87 +46,6 @@ optgroup_ldm_available (void) return prog_exists (str_ldmtool); } -static int -glob_errfunc (const char *epath, int eerrno) -{ - fprintf (stderr, "glob: failure reading %s: %s\n", epath, strerror (eerrno)); - return 1; -} - -static char ** -get_devices (const char *pattern) -{ - CLEANUP_FREE_STRINGSBUF DECLARE_STRINGSBUF (ret); - glob_t devs; - int err; - size_t i; - - memset (&devs, 0, sizeof devs); - - err = glob (pattern, GLOB_ERR, glob_errfunc, &devs); - if (err == GLOB_NOSPACE) { - reply_with_error ("glob: returned GLOB_NOSPACE: " - "rerun with LIBGUESTFS_DEBUG=1"); - goto error; - } else if (err == GLOB_ABORTED) { - reply_with_error ("glob: returned GLOB_ABORTED: " - "rerun with LIBGUESTFS_DEBUG=1"); - goto error; - } - - for (i = 0; i < devs.gl_pathc; ++i) { - if (add_string (&ret, devs.gl_pathv[i]) == -1) - goto error; - } - - if (end_stringsbuf (&ret) == -1) goto error; - - globfree (&devs); - return take_stringsbuf (&ret); - - error: - globfree (&devs); - - return NULL; -} - -/* All device mapper devices called /dev/mapper/ldm_vol_*. XXX We - * could tighten this up in future if ldmtool had a way to read these - * names back after they have been created. - */ -char ** -do_list_ldm_volumes (void) -{ - struct stat buf; - - /* If /dev/mapper doesn't exist at all, don't give an error. */ - if (stat ("/dev/mapper", &buf) == -1) { - if (errno == ENOENT) - return empty_list (); - reply_with_perror ("/dev/mapper"); - return NULL; - } - - return get_devices ("/dev/mapper/ldm_vol_*"); -} - -/* Same as above but /dev/mapper/ldm_part_*. See comment above. */ -char ** -do_list_ldm_partitions (void) -{ - struct stat buf; - - /* If /dev/mapper doesn't exist at all, don't give an error. */ - if (stat ("/dev/mapper", &buf) == -1) { - if (errno == ENOENT) - return empty_list (); - reply_with_perror ("/dev/mapper"); - return NULL; - } - - return get_devices ("/dev/mapper/ldm_part_*"); -} - int do_ldmtool_create_all (void) { diff --git a/daemon/ldm.ml b/daemon/ldm.ml new file mode 100644 index 000000000..dc7b36f9c --- /dev/null +++ b/daemon/ldm.ml @@ -0,0 +1,52 @@ +(* guestfs-inspection + * Copyright (C) 2009-2017 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 Std_utils + +open Utils + +(* All device mapper devices are called /dev/mapper/ldm_vol_*. XXX We + * could tighten this up in future if ldmtool had a way to read these + * names back after they have been created. + *) +let list_ldm_volumes () = + (* If /dev/mapper doesn't exist at all, don't give an error. *) + if not (is_directory "/dev/mapper") then + [] + else ( + let dir = Sys.readdir "/dev/mapper" in + let dir = Array.to_list dir in + let dir = + List.filter (fun d -> String.is_prefix d "ldm_vol_") dir in + let dir = List.map ((^) "/dev/mapper/") dir in + List.sort compare dir + ) + +(* Same as above but /dev/mapper/ldm_part_*. *) +let list_ldm_partitions () = + (* If /dev/mapper doesn't exist at all, don't give an error. *) + if not (is_directory "/dev/mapper") then + [] + else ( + let dir = Sys.readdir "/dev/mapper" in + let dir = Array.to_list dir in + let dir = + List.filter (fun d -> String.is_prefix d "ldm_part_") dir in + let dir = List.map ((^) "/dev/mapper/") dir in + List.sort compare dir + ) diff --git a/daemon/ldm.mli b/daemon/ldm.mli new file mode 100644 index 000000000..789abb0b3 --- /dev/null +++ b/daemon/ldm.mli @@ -0,0 +1,20 @@ +(* guestfs-inspection + * Copyright (C) 2009-2017 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. + *) + +val list_ldm_volumes : unit -> string list +val list_ldm_partitions : unit -> string list diff --git a/generator/actions_core.ml b/generator/actions_core.ml index bfd96589e..331a5feb1 100644 --- a/generator/actions_core.ml +++ b/generator/actions_core.ml @@ -8114,6 +8114,7 @@ The capabilities set C<cap> should be passed in text form { defaults with name = "list_ldm_volumes"; added = (1, 20, 0); style = RStringList (RDevice, "devices"), [], []; + impl = OCaml "Ldm.list_ldm_volumes"; optional = Some "ldm"; shortdesc = "list all Windows dynamic disk volumes"; longdesc = "\ @@ -8124,6 +8125,7 @@ device names." }; { defaults with name = "list_ldm_partitions"; added = (1, 20, 0); style = RStringList (RDevice, "devices"), [], []; + impl = OCaml "Ldm.list_ldm_partitions"; optional = Some "ldm"; shortdesc = "list all Windows dynamic disk partitions"; longdesc = "\ -- 2.13.0

--- daemon/Makefile.am | 2 + daemon/md.c | 125 ++++++++++++---------------------------------- daemon/md.ml | 48 ++++++++++++++++++ daemon/md.mli | 19 +++++++ generator/actions_core.ml | 1 + 5 files changed, 101 insertions(+), 94 deletions(-) create mode 100644 daemon/md.ml create mode 100644 daemon/md.mli diff --git a/daemon/Makefile.am b/daemon/Makefile.am index 74b154862..ab622ae5d 100644 --- a/daemon/Makefile.am +++ b/daemon/Makefile.am @@ -268,6 +268,7 @@ SOURCES_MLI = \ ldm.mli \ link.mli \ lvm.mli \ + md.mli \ mount.mli \ mountable.mli \ parted.mli \ @@ -288,6 +289,7 @@ SOURCES_ML = \ ldm.ml \ link.ml \ lvm.ml \ + md.ml \ mount.ml \ parted.ml \ realpath.ml \ diff --git a/daemon/md.c b/daemon/md.c index 64d98fae5..5c9ecd136 100644 --- a/daemon/md.c +++ b/daemon/md.c @@ -24,7 +24,6 @@ #include <inttypes.h> #include <unistd.h> #include <fcntl.h> -#include <glob.h> #ifdef HAVE_LINUX_RAID_MD_U_H #include <sys/ioctl.h> @@ -32,6 +31,8 @@ #include <linux/raid/md_u.h> #endif /* HAVE_LINUX_RAID_MD_U_H */ +#include <caml/mlvalues.h> + #include "daemon.h" #include "actions.h" #include "optgroups.h" @@ -45,6 +46,35 @@ optgroup_mdadm_available (void) return prog_exists (str_mdadm); } +/* Check if 'dev' is a real RAID device, because in the case where md + * is linked directly into the kernel (not a module), /dev/md0 is + * sometimes created. This is called from OCaml function + * Md.list_md_devices. + */ +extern value guestfs_int_daemon_is_raid_device (value devicev); + +/* NB: This is a "noalloc" call. */ +value +guestfs_int_daemon_is_raid_device (value devv) +{ + const char *dev = String_val (devv); + int ret = 1; + +#if defined(HAVE_LINUX_RAID_MD_U_H) && defined(GET_ARRAY_INFO) + int fd; + mdu_array_info_t array; + + fd = open (dev, O_RDONLY); + if (fd >= 0) { + if (ioctl (fd, GET_ARRAY_INFO, &array) == -1 && errno == ENODEV) + ret = 0; + close (fd); + } +#endif + + return Val_bool (ret); +} + static size_t count_bits (uint64_t bitmap) { @@ -188,99 +218,6 @@ do_md_create (const char *name, char *const *devices, #pragma GCC diagnostic pop #endif -static int -glob_errfunc (const char *epath, int eerrno) -{ - fprintf (stderr, "glob: failure reading %s: %s\n", epath, strerror (eerrno)); - return 1; -} - -/* Check if 'dev' is a real RAID device, because in the case where md - * is linked directly into the kernel (not a module), /dev/md0 is - * sometimes created. - */ -static int -is_raid_device (const char *dev) -{ - int ret = 1; - -#if defined(HAVE_LINUX_RAID_MD_U_H) && defined(GET_ARRAY_INFO) - int fd; - mdu_array_info_t array; - - fd = open (dev, O_RDONLY); - if (fd >= 0) { - if (ioctl (fd, GET_ARRAY_INFO, &array) == -1 && errno == ENODEV) - ret = 0; - close (fd); - } -#endif - - return ret; -} - -char ** -do_list_md_devices (void) -{ - CLEANUP_FREE_STRINGSBUF DECLARE_STRINGSBUF (ret); - glob_t mds; - - memset (&mds, 0, sizeof mds); - -#define PREFIX "/sys/block/md" -#define SUFFIX "/md" - - /* Look for directories under /sys/block matching md[0-9]* - * As an additional check, we also make sure they have a md subdirectory. - */ - const int err = glob (PREFIX "[0-9]*" SUFFIX, GLOB_ERR, glob_errfunc, &mds); - if (err == GLOB_NOSPACE) { - reply_with_error ("glob: returned GLOB_NOSPACE: " - "rerun with LIBGUESTFS_DEBUG=1"); - goto error; - } else if (err == GLOB_ABORTED) { - reply_with_error ("glob: returned GLOB_ABORTED: " - "rerun with LIBGUESTFS_DEBUG=1"); - goto error; - } - - for (size_t i = 0; i < mds.gl_pathc; i++) { - size_t len; - char *dev, *n; - - len = strlen (mds.gl_pathv[i]) - strlen (PREFIX) - strlen (SUFFIX); - -#define DEV "/dev/md" - dev = malloc (strlen (DEV) + len + 1); - if (NULL == dev) { - reply_with_perror ("malloc"); - goto error; - } - - n = dev; - n = mempcpy (n, DEV, strlen (DEV)); - n = mempcpy (n, &mds.gl_pathv[i][strlen (PREFIX)], len); - *n = '\0'; - - if (!is_raid_device (dev)) { - free (dev); - continue; - } - - if (add_string_nodup (&ret, dev) == -1) goto error; - } - - if (end_stringsbuf (&ret) == -1) goto error; - globfree (&mds); - - return take_stringsbuf (&ret); - - error: - globfree (&mds); - - return NULL; -} - char ** do_md_detail (const char *md) { diff --git a/daemon/md.ml b/daemon/md.ml new file mode 100644 index 000000000..caf87cf8f --- /dev/null +++ b/daemon/md.ml @@ -0,0 +1,48 @@ +(* guestfs-inspection + * Copyright (C) 2009-2017 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 Printf + +open Std_utils + +open Utils + +external is_raid_device : string -> bool = + "guestfs_int_daemon_is_raid_device" "noalloc" + +let re_md = Str.regexp "^md[0-9]+$" + +let list_md_devices () = + (* Look for directories under /sys/block matching md[0-9]+ + * As an additional check, we also make sure they have a md subdirectory. + *) + let devs = Sys.readdir "/sys/block" in + let devs = Array.to_list devs in + let devs = List.filter (fun d -> Str.string_match re_md d 0) devs in + let devs = List.filter ( + fun d -> is_directory (sprintf "/sys/block/%s/md" d) + ) devs in + + (* Construct the equivalent /dev/md[0-9]+ device names. *) + let devs = List.map ((^) "/dev/") devs in + + (* Check they are really RAID devices. *) + let devs = List.filter is_raid_device devs in + + (* Return the list sorted. *) + sort_device_names devs diff --git a/daemon/md.mli b/daemon/md.mli new file mode 100644 index 000000000..56b6ea65e --- /dev/null +++ b/daemon/md.mli @@ -0,0 +1,19 @@ +(* guestfs-inspection + * Copyright (C) 2009-2017 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. + *) + +val list_md_devices : unit -> string list diff --git a/generator/actions_core.ml b/generator/actions_core.ml index f6f006eee..140ba6c1b 100644 --- a/generator/actions_core.ml +++ b/generator/actions_core.ml @@ -6632,6 +6632,7 @@ If not set, this defaults to C<raid1>. { defaults with name = "list_md_devices"; added = (1, 15, 4); style = RStringList (RDevice, "devices"), [], []; + impl = OCaml "Md.list_md_devices"; shortdesc = "list Linux md (RAID) devices"; longdesc = "\ List all Linux md devices." }; -- 2.13.0

--- .gitignore | 1 + daemon/Makefile.am | 1 + generator/OCaml.ml | 8 ++++ generator/OCaml.mli | 1 + generator/daemon.ml | 116 +++++++++++++++++++++++++++++++++++++++++++++++++++- generator/main.ml | 2 + 6 files changed, 127 insertions(+), 2 deletions(-) diff --git a/.gitignore b/.gitignore index 6fceba555..bca927afc 100644 --- a/.gitignore +++ b/.gitignore @@ -183,6 +183,7 @@ Makefile.in /daemon/stamp-guestfsd.pod /daemon/structs-cleanups.c /daemon/structs-cleanups.h +/daemon/structs.ml /daemon/stubs-?.c /daemon/stubs.h /daemon/types.ml diff --git a/daemon/Makefile.am b/daemon/Makefile.am index ab622ae5d..8b3f83029 100644 --- a/daemon/Makefile.am +++ b/daemon/Makefile.am @@ -278,6 +278,7 @@ SOURCES_MLI = \ SOURCES_ML = \ types.ml \ utils.ml \ + structs.ml \ sysroot.ml \ mountable.ml \ chroot.ml \ diff --git a/generator/OCaml.ml b/generator/OCaml.ml index d3929475a..d05bb495b 100644 --- a/generator/OCaml.ml +++ b/generator/OCaml.ml @@ -888,3 +888,11 @@ and generate_ocaml_function_type ?(extra_unit = false) (ret, args, optargs) = | RStructList (_, typ) -> pr "%s array" typ | RHashtable _ -> pr "(string * string) list" ) + +(* Structure definitions (again). These are used in the daemon, + * but it's convenient to generate them here. + *) +and generate_ocaml_daemon_structs () = + generate_header OCamlStyle GPLv2plus; + + generate_ocaml_structure_decls () diff --git a/generator/OCaml.mli b/generator/OCaml.mli index 4e79a5b5a..a36fbe02f 100644 --- a/generator/OCaml.mli +++ b/generator/OCaml.mli @@ -20,3 +20,4 @@ val generate_ocaml_c : unit -> unit val generate_ocaml_c_errnos : unit -> unit val generate_ocaml_ml : unit -> unit val generate_ocaml_mli : unit -> unit +val generate_ocaml_daemon_structs : unit -> unit diff --git a/generator/daemon.ml b/generator/daemon.ml index 1d7461f8c..8cac5ccb1 100644 --- a/generator/daemon.ml +++ b/generator/daemon.ml @@ -575,6 +575,110 @@ return_string_list (value retv) "; + (* Implement code for returning structs and struct lists. *) + let emit_return_struct typ = + let struc = Structs.lookup_struct typ in + pr "/* Implement RStruct (%S, _). */\n" typ; + pr "static guestfs_int_%s *\n" typ; + pr "return_%s (value retv)\n" typ; + pr "{\n"; + pr " guestfs_int_%s *ret;\n" typ; + pr " value v;\n"; + pr "\n"; + pr " ret = malloc (sizeof (*ret));\n"; + pr " if (ret == NULL) {\n"; + pr " reply_with_perror (\"malloc\");\n"; + pr " return NULL;\n"; + pr " }\n"; + pr "\n"; + iteri ( + fun i -> + pr " v = Field (retv, %d);\n" i; + function + | n, (FString|FUUID) -> + pr " ret->%s = strdup (String_val (v));\n" n; + pr " if (ret->%s == NULL) return NULL;\n" n + | n, FBuffer -> + pr " ret->%s_len = caml_string_length (v);\n" n; + pr " ret->%s = strdup (String_val (v));\n" n; + pr " if (ret->%s == NULL) return NULL;\n" n + | n, (FBytes|FInt64|FUInt64) -> + pr " ret->%s = Int64_val (v);\n" n + | n, (FInt32|FUInt32) -> + pr " ret->%s = Int32_val (v);\n" n + | n, FOptPercent -> + pr " if (v == Val_int (0)) /* None */\n"; + pr " ret->%s = -1;\n" n; + pr " else {\n"; + pr " v = Field (v, 0);\n"; + pr " ret->%s = Double_val (v);\n" n; + pr " }\n" + | n, FChar -> + pr " ret->%s = Int_val (v);\n" n + ) struc.s_cols; + pr "\n"; + pr " return ret;\n"; + pr "}\n"; + pr "\n" + + and emit_return_struct_list typ = + pr "/* Implement RStructList (%S, _). */\n" typ; + pr "static guestfs_int_%s_list *\n" typ; + pr "return_%s_list (value retv)\n" typ; + pr "{\n"; + pr " guestfs_int_%s_list *ret;\n" typ; + pr " guestfs_int_%s *r;\n" typ; + pr " size_t i, len;\n"; + pr " value v, rv;\n"; + pr "\n"; + pr " /* Count the number of elements in the list. */\n"; + pr " rv = retv;\n"; + pr " len = 0;\n"; + pr " while (rv != Val_int (0)) {\n"; + pr " len++;\n"; + pr " rv = Field (rv, 1);\n"; + pr " }\n"; + pr "\n"; + pr " ret = malloc (sizeof *ret);\n"; + pr " if (ret == NULL) {\n"; + pr " reply_with_perror (\"malloc\");\n"; + pr " return NULL;\n"; + pr " }\n"; + pr " ret->guestfs_int_%s_list_len = len;\n" typ; + pr " ret->guestfs_int_%s_list_val =\n" typ; + pr " calloc (len, sizeof (guestfs_int_%s));\n" typ; + pr " if (ret->guestfs_int_%s_list_val == NULL) {\n" typ; + pr " reply_with_perror (\"calloc\");\n"; + pr " free (ret);\n"; + pr " return NULL;\n"; + pr " }\n"; + pr "\n"; + pr " rv = retv;\n"; + pr " for (i = 0; i < len; ++i) {\n"; + pr " v = Field (rv, 0);\n"; + pr " r = return_%s (v);\n" typ; + pr " if (r == NULL)\n"; + pr " return NULL; /* XXX leaks memory along this error path */\n"; + pr " memcpy (&ret->guestfs_int_%s_list_val[i], r, sizeof (*r));\n" typ; + pr " free (r);\n"; + pr " rv = Field (rv, 1);\n"; + pr " }\n"; + pr "\n"; + pr " return ret;\n"; + pr "}\n"; + pr "\n"; + in + + List.iter ( + function + | typ, RStructOnly -> + emit_return_struct typ + | typ, (RStructListOnly | RStructAndList) -> + emit_return_struct typ; + emit_return_struct_list typ + ) (rstructs_used_by (actions |> impl_ocaml_functions)); + + (* Implement the wrapper functions. *) List.iter ( fun ({ name = name; style = ret, args, optargs } as f) -> let uc_name = String.uppercase_ascii name in @@ -709,8 +813,16 @@ return_string_list (value retv) | RStringList _ -> pr " char **ret = return_string_list (retv);\n"; pr " CAMLreturnT (char **, ret); /* caller frees */\n" - | RStruct _ -> assert false - | RStructList _ -> assert false + | RStruct (_, typ) -> + pr " guestfs_int_%s *ret =\n" typ; + pr " return_%s (retv);\n" typ; + pr " /* caller frees */\n"; + pr " CAMLreturnT (guestfs_int_%s *, ret);\n" typ + | RStructList (_, typ) -> + pr " guestfs_int_%s_list *ret =\n" typ; + pr " return_%s_list (retv);\n" typ; + pr " /* caller frees */\n"; + pr " CAMLreturnT (guestfs_int_%s_list *, ret);\n" typ | RHashtable _ -> assert false | RBufferOut _ -> assert false ); diff --git a/generator/main.ml b/generator/main.ml index a6c805e2e..72f704b8e 100644 --- a/generator/main.ml +++ b/generator/main.ml @@ -191,6 +191,8 @@ Run it from the top source directory using the command OCaml.generate_ocaml_c; output_to "ocaml/guestfs-c-errnos.c" OCaml.generate_ocaml_c_errnos; + output_to "daemon/structs.ml" + OCaml.generate_ocaml_daemon_structs; output_to "ocaml/bindtests.ml" Bindtests.generate_ocaml_bindtests; -- 2.13.0

Move the list_filesystems API into the daemon, reimplementing it in OCaml. Since this API makes many other API calls, it runs a lot faster in the daemon. --- daemon/Makefile.am | 2 + daemon/ldm.ml | 3 + daemon/ldm.mli | 2 + daemon/listfs.ml | 156 +++++++++++++++++++++++++++++ daemon/listfs.mli | 19 ++++ daemon/lvm.ml | 3 + daemon/lvm.mli | 2 + docs/C_SOURCE_FILES | 1 - generator/actions_core.ml | 75 +++++++------- generator/daemon.ml | 59 ++++++++++- generator/proc_nr.ml | 1 + lib/MAX_PROC_NR | 2 +- lib/Makefile.am | 1 - lib/listfs.c | 246 ---------------------------------------------- 14 files changed, 285 insertions(+), 287 deletions(-) create mode 100644 daemon/listfs.ml create mode 100644 daemon/listfs.mli delete mode 100644 lib/listfs.c diff --git a/daemon/Makefile.am b/daemon/Makefile.am index 2c16bcf7d..eb25c0110 100644 --- a/daemon/Makefile.am +++ b/daemon/Makefile.am @@ -268,6 +268,7 @@ SOURCES_MLI = \ is.mli \ ldm.mli \ link.mli \ + listfs.mli \ lvm.mli \ md.mli \ mount.mli \ @@ -295,6 +296,7 @@ SOURCES_ML = \ md.ml \ mount.ml \ parted.ml \ + listfs.ml \ realpath.ml \ callbacks.ml \ daemon.ml diff --git a/daemon/ldm.ml b/daemon/ldm.ml index dc7b36f9c..19cd03e83 100644 --- a/daemon/ldm.ml +++ b/daemon/ldm.ml @@ -20,6 +20,9 @@ open Std_utils open Utils +external available : unit -> bool = + "guestfs_int_daemon_optgroup_lvm2_available" "noalloc" + (* All device mapper devices are called /dev/mapper/ldm_vol_*. XXX We * could tighten this up in future if ldmtool had a way to read these * names back after they have been created. diff --git a/daemon/ldm.mli b/daemon/ldm.mli index 789abb0b3..e6edfabd8 100644 --- a/daemon/ldm.mli +++ b/daemon/ldm.mli @@ -16,5 +16,7 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) +val available : unit -> bool + val list_ldm_volumes : unit -> string list val list_ldm_partitions : unit -> string list diff --git a/daemon/listfs.ml b/daemon/listfs.ml new file mode 100644 index 000000000..df5404f81 --- /dev/null +++ b/daemon/listfs.ml @@ -0,0 +1,156 @@ +(* guestfs-inspection + * Copyright (C) 2009-2017 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 Printf + +open Std_utils + +let rec list_filesystems () = + let has_lvm2 = Lvm.available () in + let has_ldm = Ldm.available () in + + let devices = Devsparts.list_devices () in + let partitions = Devsparts.list_partitions () in + let mds = Md.list_md_devices () in + + (* Look to see if any devices directly contain filesystems + * (RHBZ#590167). However vfs-type will fail to tell us anything + * useful about devices which just contain partitions, so we also + * get the list of partitions and exclude the corresponding devices + * by using part-to-dev. + *) + let devices = List.fold_left ( + fun devices part -> + let d = Devsparts.part_to_dev part in + List.filter ((<>) d) devices + ) devices partitions in + + (* Use vfs-type to check for filesystems on devices. *) + let ret = filter_map check_with_vfs_type devices in + + (* Use vfs-type to check for filesystems on partitions, but + * ignore MBR partition type 42 used by LDM. + *) + let ret = + ret @ + filter_map ( + fun part -> + if not has_ldm || not (is_mbr_partition_type_42 part) then + check_with_vfs_type part + else + None (* ignore type 42 *) + ) partitions in + + (* Use vfs-type to check for filesystems on md devices. *) + let ret = ret @ filter_map check_with_vfs_type mds in + + (* LVM. *) + let ret = + if has_lvm2 then ( + let lvs = Lvm.lvs () in + (* Use vfs-type to check for filesystems on LVs. *) + ret @ filter_map check_with_vfs_type lvs + ) + else ret in + + (* LDM. *) + let ret = + if has_ldm then ( + let ldmvols = Ldm.list_ldm_volumes () in + let ldmparts = Ldm.list_ldm_partitions () in + (* Use vfs-type to check for filesystems on Windows dynamic disks. *) + ret @ + filter_map check_with_vfs_type ldmvols @ + filter_map check_with_vfs_type ldmparts + ) + else ret in + + List.flatten ret + +(* Use vfs-type to check for a filesystem of some sort of [device]. + * Returns [Some [device, vfs_type; ...]] if found (there may be + * multiple devices found in the case of btrfs), else [None] if nothing + * is found. + *) +and check_with_vfs_type device = + let mountable = Mountable.of_device device in + let vfs_type = + try Blkid.vfs_type mountable + with exn -> + if verbose () then + eprintf "check_with_vfs_type: %s: %s\n" + device (Printexc.to_string exn); + "" in + + if vfs_type = "" then + Some [mountable, "unknown"] + + (* Ignore all "*_member" strings. In libblkid these are returned + * for things which are members of some RAID or LVM set, most + * importantly "LVM2_member" which is a PV. + *) + else if String.is_suffix vfs_type "_member" then + None + + (* Ignore LUKS-encrypted partitions. These are also containers, as above. *) + else if vfs_type = "crypto_LUKS" then + None + + (* A single btrfs device can turn into many volumes. *) + else if vfs_type = "btrfs" then ( + let vols = Btrfs.btrfs_subvolume_list mountable in + + (* Filter out the default subvolume. You can access that by + * simply mounting the whole device, so we will add the whole + * device at the beginning of the returned list instead. + *) + let default_volume = Btrfs.btrfs_subvolume_get_default mountable in + let vols = + List.filter ( + fun { Btrfs.btrfssubvolume_id = id } -> id <> default_volume + ) vols in + + Some ( + (mountable, vfs_type) (* whole device = default volume *) + :: List.map ( + fun { Btrfs.btrfssubvolume_path = path } -> + let mountable = Mountable.of_btrfsvol device path in + (mountable, "btrfs") + ) vols + ) + ) + + else + Some [mountable, vfs_type] + +(* We should ignore partitions that have MBR type byte 0x42, because + * these are members of a Windows dynamic disk group. Trying to read + * them will cause errors (RHBZ#887520). Assuming that libguestfs was + * compiled with ldm support, we'll get the filesystems on these later. + *) +and is_mbr_partition_type_42 partition = + try + let partnum = Devsparts.part_to_partnum partition in + let device = Devsparts.part_to_dev partition in + let mbr_id = Parted.part_get_mbr_id device partnum in + mbr_id = 0x42 + with exn -> + if verbose () then + eprintf "is_mbr_partition_type_42: %s: %s\n" + partition (Printexc.to_string exn); + false diff --git a/daemon/listfs.mli b/daemon/listfs.mli new file mode 100644 index 000000000..69958da77 --- /dev/null +++ b/daemon/listfs.mli @@ -0,0 +1,19 @@ +(* guestfs-inspection + * Copyright (C) 2009-2017 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. + *) + +val list_filesystems : unit -> (Mountable.t * string) list diff --git a/daemon/lvm.ml b/daemon/lvm.ml index 55421b628..14f0a8578 100644 --- a/daemon/lvm.ml +++ b/daemon/lvm.ml @@ -22,6 +22,9 @@ open Std_utils open Utils +external available : unit -> bool = + "guestfs_int_daemon_optgroup_lvm2_available" "noalloc" + let lvs_has_S_opt = lazy ( let out = command "lvm" ["lvs"; "--help"] in String.find out "-S" >= 0 diff --git a/daemon/lvm.mli b/daemon/lvm.mli index f254728cb..1cf61ecfb 100644 --- a/daemon/lvm.mli +++ b/daemon/lvm.mli @@ -16,4 +16,6 @@ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) +val available : unit -> bool + val lvs : unit -> string list diff --git a/docs/C_SOURCE_FILES b/docs/C_SOURCE_FILES index c5abf867e..24bd78fdd 100644 --- a/docs/C_SOURCE_FILES +++ b/docs/C_SOURCE_FILES @@ -322,7 +322,6 @@ lib/launch.c lib/libvirt-auth.c lib/libvirt-domain.c lib/libvirt-is-version.c -lib/listfs.c lib/lpj.c lib/match.c lib/mountable.c diff --git a/generator/actions_core.ml b/generator/actions_core.ml index bd3c21d3b..d5946b3f5 100644 --- a/generator/actions_core.ml +++ b/generator/actions_core.ml @@ -209,43 +209,6 @@ If the mountable does not represent a btrfs subvolume, then this function fails and the C<errno> is set to C<EINVAL>." }; { defaults with - name = "list_filesystems"; added = (1, 5, 15); - style = RHashtable (RMountable, RPlainString, "fses"), [], []; - shortdesc = "list filesystems"; - longdesc = "\ -This inspection command looks for filesystems on partitions, -block devices and logical volumes, returning a list of C<mountables> -containing filesystems and their type. - -The return value is a hash, where the keys are the devices -containing filesystems, and the values are the filesystem types. -For example: - - \"/dev/sda1\" => \"ntfs\" - \"/dev/sda2\" => \"ext2\" - \"/dev/vg_guest/lv_root\" => \"ext4\" - \"/dev/vg_guest/lv_swap\" => \"swap\" - -The key is not necessarily a block device. It may also be an opaque -‘mountable’ string which can be passed to C<guestfs_mount>. - -The value can have the special value \"unknown\", meaning the -content of the device is undetermined or empty. -\"swap\" means a Linux swap partition. - -This command runs other libguestfs commands, which might include -C<guestfs_mount> and C<guestfs_umount>, and therefore you should -use this soon after launch and only when nothing is mounted. - -Not all of the filesystems returned will be mountable. In -particular, swap partitions are returned in the list. Also -this command does not check that each filesystem -found is valid and mountable, and some filesystems might -be mountable but require special options. Filesystems may -not all belong to a single logical operating system -(use C<guestfs_inspect_os> to look for OSes)." }; - - { defaults with name = "add_drive"; added = (0, 0, 3); style = RErr, [String (PlainString, "filename")], [OBool "readonly"; OString "format"; OString "iface"; OString "name"; OString "label"; OString "protocol"; OStringList "server"; OString "username"; OString "secret"; OString "cachemode"; OString "discard"; OBool "copyonread"]; once_had_no_optargs = true; @@ -9635,4 +9598,42 @@ initrd or kernel module(s) instead. =back" }; + { defaults with + name = "list_filesystems"; added = (1, 5, 15); + style = RHashtable (RMountable, RPlainString, "fses"), [], []; + impl = OCaml "Listfs.list_filesystems"; + shortdesc = "list filesystems"; + longdesc = "\ +This inspection command looks for filesystems on partitions, +block devices and logical volumes, returning a list of C<mountables> +containing filesystems and their type. + +The return value is a hash, where the keys are the devices +containing filesystems, and the values are the filesystem types. +For example: + + \"/dev/sda1\" => \"ntfs\" + \"/dev/sda2\" => \"ext2\" + \"/dev/vg_guest/lv_root\" => \"ext4\" + \"/dev/vg_guest/lv_swap\" => \"swap\" + +The key is not necessarily a block device. It may also be an opaque +‘mountable’ string which can be passed to C<guestfs_mount>. + +The value can have the special value \"unknown\", meaning the +content of the device is undetermined or empty. +\"swap\" means a Linux swap partition. + +This command runs other libguestfs commands, which might include +C<guestfs_mount> and C<guestfs_umount>, and therefore you should +use this soon after launch and only when nothing is mounted. + +Not all of the filesystems returned will be mountable. In +particular, swap partitions are returned in the list. Also +this command does not check that each filesystem +found is valid and mountable, and some filesystems might +be mountable but require special options. Filesystems may +not all belong to a single logical operating system +(use C<guestfs_inspect_os> to look for OSes)." }; + ] diff --git a/generator/daemon.ml b/generator/daemon.ml index 83994e9d3..66b625388 100644 --- a/generator/daemon.ml +++ b/generator/daemon.ml @@ -573,6 +573,58 @@ return_string_list (value retv) return take_stringsbuf (&ret); /* caller frees */ } +/* Implement RString (RMountable, _). */ +static char * +return_string_mountable (value retv) +{ + value typev = Field (retv, 0); + value devicev = Field (retv, 1); + value subvolv; + char *ret; + + if (Is_long (typev)) { /* MountableDevice or MountablePath */ + ret = strdup (String_val (devicev)); + if (ret == NULL) + reply_with_perror (\"strdup\"); + return ret; + } + else { /* MountableBtrfsVol of subvol */ + subvolv = Field (typev, 0); + if (asprintf (&ret, \"btrfsvol:%%s/%%s\", + String_val (devicev), String_val (subvolv)) == -1) + reply_with_perror (\"asprintf\"); + return ret; + } +} + +/* Implement RHashtable (RMountable, RPlainString, _). */ +static char ** +return_hashtable_mountable_string (value retv) +{ + CLEANUP_FREE_STRINGSBUF DECLARE_STRINGSBUF (ret); + value v, mv, sv; + char *m; + + while (retv != Val_int (0)) { + v = Field (retv, 0); /* (Mountable.t, string) */ + mv = Field (v, 0); /* Mountable.t */ + m = return_string_mountable (mv); + if (m == NULL) + return NULL; + if (add_string_nodup (&ret, m) == -1) + return NULL; + sv = Field (v, 1); /* string */ + if (add_string (&ret, String_val (sv)) == -1) + return NULL; + retv = Field (retv, 1); + } + + if (end_stringsbuf (&ret) == -1) + return NULL; + + return take_stringsbuf (&ret); /* caller frees */ +} + "; (* Implement code for returning structs and struct lists. *) @@ -810,7 +862,9 @@ return_string_list (value retv) pr " CAMLreturnT (char *, NULL);\n"; pr " }\n"; pr " CAMLreturnT (char *, ret); /* caller frees */\n" - | RString _ -> assert false + | RString (RMountable, _) -> + pr " char *ret = return_string_mountable (retv);\n"; + pr " CAMLreturnT (char *, ret); /* caller frees */\n" | RStringList _ -> pr " char **ret = return_string_list (retv);\n"; pr " CAMLreturnT (char **, ret); /* caller frees */\n" @@ -824,6 +878,9 @@ return_string_list (value retv) pr " return_%s_list (retv);\n" typ; pr " /* caller frees */\n"; pr " CAMLreturnT (guestfs_int_%s_list *, ret);\n" typ + | RHashtable (RMountable, RPlainString, _) -> + pr " char **ret = return_hashtable_mountable_string (retv);\n"; + pr " CAMLreturnT (char **, ret); /* caller frees */\n" | RHashtable _ -> assert false | RBufferOut _ -> assert false ); diff --git a/generator/proc_nr.ml b/generator/proc_nr.ml index 1b0feae87..dec02f5fa 100644 --- a/generator/proc_nr.ml +++ b/generator/proc_nr.ml @@ -483,6 +483,7 @@ let proc_nr = [ 473, "yara_destroy"; 474, "internal_yara_scan"; 475, "file_architecture"; +476, "list_filesystems"; ] (* End of list. If adding a new entry, add it at the end of the list diff --git a/lib/MAX_PROC_NR b/lib/MAX_PROC_NR index 7573eff88..b86395733 100644 --- a/lib/MAX_PROC_NR +++ b/lib/MAX_PROC_NR @@ -1 +1 @@ -475 +476 diff --git a/lib/Makefile.am b/lib/Makefile.am index c7a9880eb..f12cd055e 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -108,7 +108,6 @@ libguestfs_la_SOURCES = \ launch-unix.c \ libvirt-auth.c \ libvirt-domain.c \ - listfs.c \ lpj.c \ match.c \ mountable.c \ diff --git a/lib/listfs.c b/lib/listfs.c deleted file mode 100644 index 60aff3305..000000000 --- a/lib/listfs.c +++ /dev/null @@ -1,246 +0,0 @@ -/* libguestfs - * Copyright (C) 2010 Red Hat Inc. - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2 of the License, or (at your option) any later version. - * - * This library 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 - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; 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 <string.h> - -#include "guestfs.h" -#include "guestfs-internal.h" -#include "guestfs-internal-actions.h" -#include "structs-cleanups.h" - -/* List filesystems. - * - * The current implementation just uses guestfs_vfs_type and doesn't - * try mounting anything, but we reserve the right in future to try - * mounting filesystems. - */ - -static void remove_from_list (char **list, const char *item); -static int check_with_vfs_type (guestfs_h *g, const char *dev, struct stringsbuf *sb); -static int is_mbr_partition_type_42 (guestfs_h *g, const char *partition); - -char ** -guestfs_impl_list_filesystems (guestfs_h *g) -{ - size_t i; - DECLARE_STRINGSBUF (ret); - - const char *lvm2[] = { "lvm2", NULL }; - const int has_lvm2 = guestfs_feature_available (g, (char **) lvm2); - const char *ldm[] = { "ldm", NULL }; - const int has_ldm = guestfs_feature_available (g, (char **) ldm); - - CLEANUP_FREE_STRING_LIST char **devices = NULL; - CLEANUP_FREE_STRING_LIST char **partitions = NULL; - CLEANUP_FREE_STRING_LIST char **mds = NULL; - CLEANUP_FREE_STRING_LIST char **lvs = NULL; - CLEANUP_FREE_STRING_LIST char **ldmvols = NULL; - CLEANUP_FREE_STRING_LIST char **ldmparts = NULL; - - /* Look to see if any devices directly contain filesystems - * (RHBZ#590167). However vfs-type will fail to tell us anything - * useful about devices which just contain partitions, so we also - * get the list of partitions and exclude the corresponding devices - * by using part-to-dev. - */ - devices = guestfs_list_devices (g); - if (devices == NULL) goto error; - partitions = guestfs_list_partitions (g); - if (partitions == NULL) goto error; - mds = guestfs_list_md_devices (g); - if (mds == NULL) goto error; - - for (i = 0; partitions[i] != NULL; ++i) { - CLEANUP_FREE char *dev = guestfs_part_to_dev (g, partitions[i]); - if (dev) - remove_from_list (devices, dev); - } - - /* Use vfs-type to check for filesystems on devices. */ - for (i = 0; devices[i] != NULL; ++i) - if (check_with_vfs_type (g, devices[i], &ret) == -1) - goto error; - - /* Use vfs-type to check for filesystems on partitions. */ - for (i = 0; partitions[i] != NULL; ++i) { - if (has_ldm == 0 || ! is_mbr_partition_type_42 (g, partitions[i])) { - if (check_with_vfs_type (g, partitions[i], &ret) == -1) - goto error; - } - } - - /* Use vfs-type to check for filesystems on md devices. */ - for (i = 0; mds[i] != NULL; ++i) - if (check_with_vfs_type (g, mds[i], &ret) == -1) - goto error; - - if (has_lvm2 > 0) { - /* Use vfs-type to check for filesystems on LVs. */ - lvs = guestfs_lvs (g); - if (lvs == NULL) goto error; - - for (i = 0; lvs[i] != NULL; ++i) - if (check_with_vfs_type (g, lvs[i], &ret) == -1) - goto error; - } - - if (has_ldm > 0) { - /* Use vfs-type to check for filesystems on Windows dynamic disks. */ - ldmvols = guestfs_list_ldm_volumes (g); - if (ldmvols == NULL) goto error; - - for (i = 0; ldmvols[i] != NULL; ++i) - if (check_with_vfs_type (g, ldmvols[i], &ret) == -1) - goto error; - - ldmparts = guestfs_list_ldm_partitions (g); - if (ldmparts == NULL) goto error; - - for (i = 0; ldmparts[i] != NULL; ++i) - if (check_with_vfs_type (g, ldmparts[i], &ret) == -1) - goto error; - } - - /* Finish off the list and return it. */ - guestfs_int_end_stringsbuf (g, &ret); - return ret.argv; - - error: - guestfs_int_free_stringsbuf (&ret); - return NULL; -} - -/* If 'item' occurs in 'list', remove and free it. */ -static void -remove_from_list (char **list, const char *item) -{ - size_t i; - - for (i = 0; list[i] != NULL; ++i) - if (STREQ (list[i], item)) { - free (list[i]); - for (; list[i+1] != NULL; ++i) - list[i] = list[i+1]; - list[i] = NULL; - return; - } -} - -/* Use vfs-type to look for a filesystem of some sort on 'dev'. - * Apart from some types which we ignore, add the result to the - * 'ret' string list. - */ -static int -check_with_vfs_type (guestfs_h *g, const char *device, struct stringsbuf *sb) -{ - const char *v; - CLEANUP_FREE char *vfs_type = NULL; - - guestfs_push_error_handler (g, NULL, NULL); - vfs_type = guestfs_vfs_type (g, device); - guestfs_pop_error_handler (g); - - if (!vfs_type) - v = "unknown"; - else if (STREQ (vfs_type, "")) - v = "unknown"; - else if (STREQ (vfs_type, "btrfs")) { - CLEANUP_FREE_BTRFSSUBVOLUME_LIST struct guestfs_btrfssubvolume_list *vols = - guestfs_btrfs_subvolume_list (g, device); - - if (vols == NULL) - return -1; - - const int64_t default_volume = - guestfs_btrfs_subvolume_get_default (g, device); - - for (size_t i = 0; i < vols->len; i++) { - struct guestfs_btrfssubvolume *this = &vols->val[i]; - - /* Ignore the default subvolume. We get it by simply mounting - * the whole device of this btrfs filesystem. - */ - if (this->btrfssubvolume_id == (uint64_t) default_volume) - continue; - - guestfs_int_add_sprintf (g, sb, - "btrfsvol:%s/%s", - device, this->btrfssubvolume_path); - guestfs_int_add_string (g, sb, "btrfs"); - } - - v = vfs_type; - } - else { - /* Ignore all "*_member" strings. In libblkid these are returned - * for things which are members of some RAID or LVM set, most - * importantly "LVM2_member" which is a PV. - */ - const size_t n = strlen (vfs_type); - if (n >= 7 && STREQ (&vfs_type[n-7], "_member")) - return 0; - - /* Ignore LUKS-encrypted partitions. These are also containers. */ - if (STREQ (vfs_type, "crypto_LUKS")) - return 0; - - v = vfs_type; - } - - guestfs_int_add_string (g, sb, device); - guestfs_int_add_string (g, sb, v); - - return 0; -} - -/* We should ignore partitions that have MBR type byte 0x42, because - * these are members of a Windows dynamic disk group. Trying to read - * them will cause errors (RHBZ#887520). Assuming that libguestfs was - * compiled with ldm support, we'll get the filesystems on these later. - */ -static int -is_mbr_partition_type_42 (guestfs_h *g, const char *partition) -{ - CLEANUP_FREE char *device = NULL; - int partnum; - int mbr_id; - int ret = 0; - - guestfs_push_error_handler (g, NULL, NULL); - - partnum = guestfs_part_to_partnum (g, partition); - if (partnum == -1) - goto out; - - device = guestfs_part_to_dev (g, partition); - if (device == NULL) - goto out; - - mbr_id = guestfs_part_get_mbr_id (g, device, partnum); - - ret = mbr_id == 0x42; - - out: - guestfs_pop_error_handler (g); - - return ret; -} -- 2.13.0

--- daemon/Makefile.am | 3 +- daemon/findfs.c | 94 ----------------------------------------------- daemon/findfs.ml | 56 ++++++++++++++++++++++++++++ daemon/findfs.mli | 20 ++++++++++ daemon/lvm.c | 31 ++++++++++++++++ daemon/lvm.ml | 3 ++ daemon/lvm.mli | 8 ++++ docs/C_SOURCE_FILES | 1 - generator/actions_core.ml | 2 + 9 files changed, 122 insertions(+), 96 deletions(-) delete mode 100644 daemon/findfs.c create mode 100644 daemon/findfs.ml create mode 100644 daemon/findfs.mli diff --git a/daemon/Makefile.am b/daemon/Makefile.am index eb25c0110..7dec1855b 100644 --- a/daemon/Makefile.am +++ b/daemon/Makefile.am @@ -108,7 +108,6 @@ guestfsd_SOURCES = \ ext2.c \ fallocate.c \ file.c \ - findfs.c \ fill.c \ find.c \ format.c \ @@ -265,6 +264,7 @@ SOURCES_MLI = \ devsparts.mli \ file.mli \ filearch.mli \ + findfs.mli \ is.mli \ ldm.mli \ link.mli \ @@ -293,6 +293,7 @@ SOURCES_ML = \ ldm.ml \ link.ml \ lvm.ml \ + findfs.ml \ md.ml \ mount.ml \ parted.ml \ diff --git a/daemon/findfs.c b/daemon/findfs.c deleted file mode 100644 index f44137038..000000000 --- a/daemon/findfs.c +++ /dev/null @@ -1,94 +0,0 @@ -/* libguestfs - the guestfsd daemon - * Copyright (C) 2010 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 <string.h> -#include <unistd.h> - -#include "daemon.h" -#include "actions.h" - -GUESTFSD_EXT_CMD(str_findfs, findfs); - -static char * -findfs (const char *tag, const char *label_or_uuid) -{ - char *out; - CLEANUP_FREE char *err = NULL; - CLEANUP_FREE char *arg = NULL; - int r; - size_t len; - - /* Kill the cache file, forcing blkid to reread values from the - * original filesystems. In blkid there is a '-p' option which is - * supposed to do this, but (a) it doesn't work and (b) that option - * is not supported in RHEL 5. - */ - unlink ("/etc/blkid/blkid.tab"); - unlink ("/run/blkid/blkid.tab"); - - if (asprintf (&arg, "%s=%s", tag, label_or_uuid) == -1) { - reply_with_perror ("asprintf"); - return NULL; - } - - r = command (&out, &err, str_findfs, arg, NULL); - if (r == -1) { - reply_with_error ("%s", err); - free (out); - return NULL; - } - - /* Trim trailing \n if present. */ - len = strlen (out); - if (len > 0 && out[len-1] == '\n') - out[len-1] = '\0'; - - if (STRPREFIX (out, "/dev/mapper/") || STRPREFIX (out, "/dev/dm-")) { - char *canonical; - r = lv_canonical (out, &canonical); - if (r == -1) { - free (out); - return NULL; - } - if (r == 1) { - free (out); - out = canonical; - } - /* Ignore the case where r == 0. /dev/mapper does not correspond - * to an LV, so the best we can do is just return it as-is. - */ - } - - return out; /* caller frees */ -} - -char * -do_findfs_uuid (const char *uuid) -{ - return findfs ("UUID", uuid); -} - -char * -do_findfs_label (const char *label) -{ - return findfs ("LABEL", label); -} diff --git a/daemon/findfs.ml b/daemon/findfs.ml new file mode 100644 index 000000000..8acb72928 --- /dev/null +++ b/daemon/findfs.ml @@ -0,0 +1,56 @@ +(* guestfs-inspection + * Copyright (C) 2009-2017 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 Printf +open Unix + +open Std_utils + +open Utils + +let rec findfs_uuid uuid = + findfs "UUID" uuid +and findfs_label label = + findfs "LABEL"label + +and findfs tag str = + (* Kill the cache file, forcing blkid to reread values from the + * original filesystems. In blkid there is a '-p' option which is + * supposed to do this, but (a) it doesn't work and (b) that option + * is not supported in RHEL 5. + *) + (try unlink "/etc/blkid/blkid.tab" with Unix_error _ -> ()); + (try unlink "/run/blkid/blkid.tab" with Unix_error _ -> ()); + + let out = command "findfs" [ sprintf "%s=%s" tag str ] in + + (* Trim trailing \n if present. *) + let out = String.trim out in + + if String.is_prefix out "/dev/mapper/" || + String.is_prefix out "/dev/dm-" then ( + match Lvm.lv_canonical out with + | None -> + (* Ignore the case where 'out' doesn't appear to be an LV. + * The best we can do is return the original as-is. + *) + out + | Some out -> out + ) + else + out diff --git a/daemon/findfs.mli b/daemon/findfs.mli new file mode 100644 index 000000000..acef0395c --- /dev/null +++ b/daemon/findfs.mli @@ -0,0 +1,20 @@ +(* guestfs-inspection + * Copyright (C) 2009-2017 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. + *) + +val findfs_uuid : string -> string +val findfs_label : string -> string diff --git a/daemon/lvm.c b/daemon/lvm.c index 072bf53b4..268d87416 100644 --- a/daemon/lvm.c +++ b/daemon/lvm.c @@ -27,6 +27,11 @@ #include <sys/stat.h> #include <dirent.h> +#include <caml/alloc.h> +#include <caml/fail.h> +#include <caml/memory.h> +#include <caml/mlvalues.h> + #include "daemon.h" #include "c-ctype.h" #include "actions.h" @@ -969,3 +974,29 @@ do_vgchange_uuid_all (void) return 0; } + +/* Allow lv_canonical to be called from OCaml functions in the daemon. */ +extern value guestfs_int_daemon_lv_canonical (value devicev); + +value +guestfs_int_daemon_lv_canonical (value devicev) +{ + CAMLparam1 (devicev); + CAMLlocal2 (rv, v); + int r; + CLEANUP_FREE char *rdevice = NULL; + + r = lv_canonical (String_val (devicev), &rdevice); + if (r == -1) + caml_failwith ("lv_canonical"); + + if (r == 0) /* Return None. */ + rv = Val_int (0); + else { /* Return Some rdevice. */ + v = caml_copy_string (rdevice); + rv = caml_alloc (1, 0); + caml_modify (&Field (rv, 0), v); + } + + CAMLreturn (rv); +} diff --git a/daemon/lvm.ml b/daemon/lvm.ml index 14f0a8578..8647f3246 100644 --- a/daemon/lvm.ml +++ b/daemon/lvm.ml @@ -25,6 +25,9 @@ open Utils external available : unit -> bool = "guestfs_int_daemon_optgroup_lvm2_available" "noalloc" +external lv_canonical : string -> string option = + "guestfs_int_daemon_lv_canonical" + let lvs_has_S_opt = lazy ( let out = command "lvm" ["lvs"; "--help"] in String.find out "-S" >= 0 diff --git a/daemon/lvm.mli b/daemon/lvm.mli index 1cf61ecfb..f01f1f80c 100644 --- a/daemon/lvm.mli +++ b/daemon/lvm.mli @@ -19,3 +19,11 @@ val available : unit -> bool val lvs : unit -> string list + +val lv_canonical : string -> string option +(** This is a binding for the C lv_canonical function used in a + few cases. On error this raises an exception. There are + two possible non-error cases: + + Some lv = conversion was successful, returning the canonical LV + None = input path was not an LV, it could not be made canonical *) diff --git a/docs/C_SOURCE_FILES b/docs/C_SOURCE_FILES index 24bd78fdd..7a3907ce2 100644 --- a/docs/C_SOURCE_FILES +++ b/docs/C_SOURCE_FILES @@ -102,7 +102,6 @@ daemon/fallocate.c daemon/file.c daemon/fill.c daemon/find.c -daemon/findfs.c daemon/format.c daemon/fs-min-size.c daemon/fsck.c diff --git a/generator/actions_core.ml b/generator/actions_core.ml index b1e2559e0..0a967f76d 100644 --- a/generator/actions_core.ml +++ b/generator/actions_core.ml @@ -5746,6 +5746,7 @@ returns true iff this is the case." }; { defaults with name = "findfs_uuid"; added = (1, 5, 3); style = RString (RDevice, "device"), [String (PlainString, "uuid")], []; + impl = OCaml "Findfs.findfs_uuid"; shortdesc = "find a filesystem by UUID"; longdesc = "\ This command searches the filesystems and returns the one @@ -5757,6 +5758,7 @@ To find the UUID of a filesystem, use C<guestfs_vfs_uuid>." }; { defaults with name = "findfs_label"; added = (1, 5, 3); style = RString (RDevice, "device"), [String (PlainString, "label")], []; + impl = OCaml "Findfs.findfs_label"; shortdesc = "find a filesystem by label"; longdesc = "\ This command searches the filesystems and returns the one -- 2.13.0