>From 4e9f48f22ace1380684a6a124178be89ca86a664 Mon Sep 17 00:00:00 2001
From: Maros Zatko <mzatko@redhat.com>
Date: Mon, 8 Aug 2016 11:54:56 +0200
Subject: [PATCH] rescue: rewrite in OCaml

---
 Makefile.am            |   3 +-
 docs/C_SOURCE_FILES    |   2 +-
 rescue/Makefile.am     | 147 +++++++++-----
 rescue/dummy.c         |   2 +
 rescue/rescue.c        | 527 -------------------------------------------------
 rescue/rescue.ml       | 226 +++++++++++++++++++++
 rescue/virt-rescue.pod |  17 ++
 7 files changed, 344 insertions(+), 580 deletions(-)
 create mode 100644 rescue/dummy.c
 delete mode 100644 rescue/rescue.c
 create mode 100644 rescue/rescue.ml

diff --git a/Makefile.am b/Makefile.am
index 4b5babb..d39884c 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -94,7 +94,7 @@ SUBDIRS += test-tool
 SUBDIRS += fish
 
 # virt-tools in C.
-SUBDIRS += align cat diff df edit format inspector make-fs rescue
+SUBDIRS += align cat diff df edit format inspector make-fs
 if HAVE_P2V
 SUBDIRS += p2v
 endif
@@ -150,6 +150,7 @@ SUBDIRS += \
 	dib \
 	get-kernel \
 	resize \
+	rescue \
 	sparsify \
 	sysprep \
 	v2v
diff --git a/docs/C_SOURCE_FILES b/docs/C_SOURCE_FILES
index 3db4db3..4d961bf 100644
--- a/docs/C_SOURCE_FILES
+++ b/docs/C_SOURCE_FILES
@@ -205,7 +205,7 @@ p2v/whole-file.c
 php/extension/guestfs_php.c
 python/guestfs-py-byhand.c
 python/guestfs-py.c
-rescue/rescue.c
+rescue/dummy.c
 resize/dummy.c
 ruby/ext/guestfs/_guestfs.c
 sparsify/dummy.c
diff --git a/rescue/Makefile.am b/rescue/Makefile.am
index 1568730..e377cbf 100644
--- a/rescue/Makefile.am
+++ b/rescue/Makefile.am
@@ -1,5 +1,5 @@
-# libguestfs virt-rescue
-# Copyright (C) 2010-2016 Red Hat Inc.
+# libguestfs virt-rescue tool
+# Copyright (C) 2015 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
@@ -18,55 +18,92 @@
 include $(top_srcdir)/subdir-rules.mk
 
 EXTRA_DIST = \
-	test-virt-rescue.pl \
+	$(SOURCES_MLI) $(SOURCES_ML) $(SOURCES_C) \
 	test-virt-rescue-docs.sh \
-	test-virt-rescue-suggest.sh \
-	virt-rescue.pod
+        virt-rescue.pod
 
-CLEANFILES = \
-	stamp-virt-rescue.pod \
-	virt-rescue.1
+CLEANFILES = *~ *.annot *.cmi *.cmo *.cmx *.cmxa *.o virt-rescue
 
-bin_PROGRAMS = virt-rescue
+SOURCES_MLI = \
+	rescue.mli
 
-SHARED_SOURCE_FILES = \
-	../fish/config.c \
-	../fish/domain.c \
-	../fish/inspect.c \
-	../fish/keys.c \
-	../fish/options.h \
-	../fish/options.c \
-	../fish/uri.h \
-	../fish/uri.c
+SOURCES_ML = \
+	rescue.ml
 
-virt_rescue_SOURCES = \
-	$(SHARED_SOURCE_FILES) \
-	rescue.c
+SOURCES_C = \
+	dummy.c
 
-virt_rescue_CPPFLAGS = \
-	-DCOMPILING_VIRT_RESCUE=1 \
-	-DGUESTFS_WARN_DEPRECATED=1 \
-	-DLOCALEBASEDIR=\""$(datadir)/locale"\" \
-	-I$(top_srcdir)/src -I$(top_builddir)/src \
-	-I$(top_srcdir)/fish \
-	-I$(srcdir)/../gnulib/lib -I../gnulib/lib
+bin_PROGRAMS =
 
+if HAVE_OCAML
+
+bin_PROGRAMS += virt-rescue
+
+virt_rescue_SOURCES = $(SOURCES_C)
+virt_rescue_CPPFLAGS = \
+	-I. \
+	-I$(top_builddir) \
+	-I$(top_srcdir)/gnulib/lib -I$(top_builddir)/gnulib/lib \
+	-I$(shell $(OCAMLC) -where) \
+	-I$(top_srcdir)/gnulib/lib \
+	-I$(top_srcdir)/src
 virt_rescue_CFLAGS = \
-	$(WARN_CFLAGS) $(WERROR_CFLAGS) \
-	$(LIBCONFIG_CFLAGS) \
-	$(LIBXML2_CFLAGS)
-
-virt_rescue_LDADD = \
-	$(LIBCONFIG_LIBS) \
-	$(top_builddir)/src/libutils.la \
-	$(top_builddir)/src/libguestfs.la \
+	-pthread \
+	$(WARN_CFLAGS) $(WERROR_CFLAGS)
+
+BOBJECTS = \
+	$(SOURCES_ML:.ml=.cmo)
+XOBJECTS = $(BOBJECTS:.cmo=.cmx)
+
+# -I $(top_builddir)/src/.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)/src/.libs \
+	-I $(top_builddir)/gnulib/lib/.libs \
+	-I $(top_builddir)/ocaml \
+	-I $(top_builddir)/mllib
+if HAVE_OCAML_PKG_GETTEXT
+OCAMLPACKAGES += -package gettext-stub
+endif
+
+OCAMLCLIBS = \
+	-pthread -lpthread \
+	-lutils \
 	$(LIBXML2_LIBS) \
-	$(LIBVIRT_LIBS) \
-	$(LTLIBINTL) \
-	../gnulib/lib/libgnu.la
+	$(LIBINTL) \
+	-lgnu
+
+OCAMLFLAGS = $(OCAML_FLAGS) $(OCAML_WARN_ERROR)
+
+if !HAVE_OCAMLOPT
+OBJECTS = $(BOBJECTS)
+else
+OBJECTS = $(XOBJECTS)
+endif
+
+OCAMLLINKFLAGS = mlguestfs.$(MLARCHIVE) mllib.$(MLARCHIVE) $(LINK_CUSTOM_OCAMLC_ONLY)
+
+virt_rescue_DEPENDENCIES = \
+	$(OBJECTS) \
+	../mllib/mllib.$(MLARCHIVE) \
+	$(top_srcdir)/ocaml-link.sh
+virt_rescue_LINK = \
+	$(top_srcdir)/ocaml-link.sh -cclib '$(OCAMLCLIBS)' -- \
+	  $(OCAMLFIND) $(BEST) $(OCAMLFLAGS) $(OCAMLPACKAGES) $(OCAMLLINKFLAGS) \
+	  $(OBJECTS) -o $@
+
+# Tests.
+
+TESTS_ENVIRONMENT = $(top_builddir)/run --test
+
+TESTS = test-virt-rescue-docs.sh
 
 # Manual pages and HTML files for the website.
+
 man_MANS = virt-rescue.1
+
 noinst_DATA = $(top_builddir)/website/virt-rescue.1.html
 
 virt-rescue.1 $(top_builddir)/website/virt-rescue.1.html: stamp-virt-rescue.pod
@@ -76,22 +113,30 @@ stamp-virt-rescue.pod: virt-rescue.pod
 	  --man virt-rescue.1 \
 	  --html $(top_builddir)/website/virt-rescue.1.html \
 	  --license GPLv2+ \
-	  --warning ro-option \
+	  --warning safe \
 	  $<
 	touch $@
 
-# Tests.
+CLEANFILES += \
+	stamp-virt-rescue.pod \
+	virt-rescue.1
 
-TESTS_ENVIRONMENT = $(top_builddir)/run --test
+# Dependencies.
+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 $^ | \
+	  $(SED) 's/ *$$//' | \
+	  $(SED) -e :a -e '/ *\\$$/N; s/ *\\\n */ /; ta' | \
+	  $(SED) -e 's,$(abs_srcdir)/,$(builddir)/,g' | \
+	  sort > $@-t
+	mv $@-t $@
+
+-include .depend
 
-TESTS = \
-	test-virt-rescue-docs.sh
+endif
 
-if ENABLE_APPLIANCE
-TESTS += \
-	test-virt-rescue.pl \
-	test-virt-rescue-suggest.sh
-endif ENABLE_APPLIANCE
+DISTCLEANFILES = .depend
 
-check-valgrind:
-	$(MAKE) TESTS="test-virt-rescue-suggest.sh" VG="$(top_builddir)/run @VG@" check
+.PHONY: depend docs
diff --git a/rescue/dummy.c b/rescue/dummy.c
new file mode 100644
index 0000000..ebab619
--- /dev/null
+++ b/rescue/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/rescue/rescue.c b/rescue/rescue.c
deleted file mode 100644
index 37b82f6..0000000
--- a/rescue/rescue.c
+++ /dev/null
@@ -1,527 +0,0 @@
-/* virt-rescue
- * Copyright (C) 2010-2012 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 <inttypes.h>
-#include <unistd.h>
-#include <getopt.h>
-#include <errno.h>
-#include <error.h>
-#include <locale.h>
-#include <assert.h>
-#include <libintl.h>
-
-#include "ignore-value.h"
-#include "xvasprintf.h"
-
-#include "guestfs.h"
-#include "options.h"
-
-static void add_scratch_disks (int n, struct drv **drvs);
-static void do_suggestion (struct drv *drvs);
-
-/* Currently open libguestfs handle. */
-guestfs_h *g;
-
-int read_only = 0;
-int live = 0;
-int verbose = 0;
-int keys_from_stdin = 0;
-int echo_keys = 0;
-const char *libvirt_uri = NULL;
-int inspector = 0;
-
-static void __attribute__((noreturn))
-usage (int status)
-{
-  if (status != EXIT_SUCCESS)
-    fprintf (stderr, _("Try `%s --help' for more information.\n"),
-             guestfs_int_program_name);
-  else {
-    printf (_("%s: Run a rescue shell on a virtual machine\n"
-              "Copyright (C) 2009-2016 Red Hat Inc.\n"
-              "Usage:\n"
-              "  %s [--options] -d domname\n"
-              "  %s [--options] -a disk.img [-a disk.img ...]\n"
-              "Options:\n"
-              "  -a|--add image       Add image\n"
-              "  --append kernelopts  Append kernel options\n"
-              "  -c|--connect uri     Specify libvirt URI for -d option\n"
-              "  -d|--domain guest    Add disks from libvirt guest\n"
-              "  --format[=raw|..]    Force disk format for -a option\n"
-              "  --help               Display brief help\n"
-              "  -m|--memsize MB      Set memory size in megabytes\n"
-              "  --network            Enable network\n"
-              "  -r|--ro              Access read-only\n"
-              "  --scratch[=N]        Add scratch disk(s)\n"
-              "  --selinux            For backwards compat only, does nothing\n"
-              "  --smp N              Enable SMP with N >= 2 virtual CPUs\n"
-              "  --suggest            Suggest mount commands for this guest\n"
-              "  -v|--verbose         Verbose messages\n"
-              "  -V|--version         Display version and exit\n"
-              "  -w|--rw              Mount read-write\n"
-              "  -x                   Trace libguestfs API calls\n"
-              "For more information, see the manpage %s(1).\n"),
-            guestfs_int_program_name, guestfs_int_program_name,
-            guestfs_int_program_name, guestfs_int_program_name);
-  }
-  exit (status);
-}
-
-int
-main (int argc, char *argv[])
-{
-  setlocale (LC_ALL, "");
-  bindtextdomain (PACKAGE, LOCALEBASEDIR);
-  textdomain (PACKAGE);
-
-  parse_config ();
-
-  enum { HELP_OPTION = CHAR_MAX + 1 };
-
-  static const char options[] = "a:c:d:m:rvVwx";
-  static const struct option long_options[] = {
-    { "add", 1, 0, 'a' },
-    { "append", 1, 0, 0 },
-    { "connect", 1, 0, 'c' },
-    { "domain", 1, 0, 'd' },
-    { "format", 2, 0, 0 },
-    { "help", 0, 0, HELP_OPTION },
-    { "long-options", 0, 0, 0 },
-    { "memsize", 1, 0, 'm' },
-    { "network", 0, 0, 0 },
-    { "ro", 0, 0, 'r' },
-    { "rw", 0, 0, 'w' },
-    { "scratch", 2, 0, 0 },
-    { "selinux", 0, 0, 0 },
-    { "short-options", 0, 0, 0 },
-    { "smp", 1, 0, 0 },
-    { "suggest", 0, 0, 0 },
-    { "verbose", 0, 0, 'v' },
-    { "version", 0, 0, 'V' },
-    { 0, 0, 0, 0 }
-  };
-  struct drv *drvs = NULL;
-  struct drv *drv;
-  const char *format = NULL;
-  bool format_consumed = true;
-  int c;
-  int option_index;
-  int network = 0;
-  const char *append = NULL;
-  int memsize = 0;
-  int smp = 0;
-  int suggest = 0;
-
-  g = guestfs_create ();
-  if (g == NULL)
-    error (EXIT_FAILURE, errno, "guestfs_create");
-
-  for (;;) {
-    c = getopt_long (argc, argv, options, long_options, &option_index);
-    if (c == -1) break;
-
-    switch (c) {
-    case 0:			/* options which are long only */
-      if (STREQ (long_options[option_index].name, "long-options"))
-        display_long_options (long_options);
-      else if (STREQ (long_options[option_index].name, "short-options"))
-        display_short_options (options);
-      else if (STREQ (long_options[option_index].name, "selinux")) {
-        /* nothing */
-      } else if (STREQ (long_options[option_index].name, "append")) {
-        append = optarg;
-      } else if (STREQ (long_options[option_index].name, "network")) {
-        network = 1;
-      } else if (STREQ (long_options[option_index].name, "format")) {
-        OPTION_format;
-      } else if (STREQ (long_options[option_index].name, "smp")) {
-        if (sscanf (optarg, "%d", &smp) != 1)
-          error (EXIT_FAILURE, 0,
-                 _("could not parse --smp parameter '%s'"), optarg);
-        if (smp < 1)
-          error (EXIT_FAILURE, 0,
-                 _("--smp parameter '%s' should be >= 1"), optarg);
-      } else if (STREQ (long_options[option_index].name, "suggest")) {
-        suggest = 1;
-      } else if (STREQ (long_options[option_index].name, "scratch")) {
-        if (!optarg || STREQ (optarg, ""))
-          add_scratch_disks (1, &drvs);
-        else {
-          int n;
-          if (sscanf (optarg, "%d", &n) != 1)
-            error (EXIT_FAILURE, 0,
-                   _("could not parse --scratch parameter '%s'"), optarg);
-          if (n < 1)
-            error (EXIT_FAILURE, 0,
-                   _("--scratch parameter '%s' should be >= 1"), optarg);
-          add_scratch_disks (n, &drvs);
-        }
-      } else
-        error (EXIT_FAILURE, 0,
-               _("unknown long option: %s (%d)"),
-               long_options[option_index].name, option_index);
-      break;
-
-    case 'a':
-      OPTION_a;
-      break;
-
-    case 'c':
-      OPTION_c;
-      break;
-
-    case 'd':
-      OPTION_d;
-      break;
-
-    case 'm':
-      if (sscanf (optarg, "%d", &memsize) != 1)
-        error (EXIT_FAILURE, 0,
-               _("could not parse memory size '%s'"), optarg);
-      break;
-
-    case 'r':
-      OPTION_r;
-      break;
-
-    case 'v':
-      OPTION_v;
-      break;
-
-    case 'V':
-      OPTION_V;
-      break;
-
-    case 'w':
-      OPTION_w;
-      break;
-
-    case 'x':
-      OPTION_x;
-      break;
-
-    case HELP_OPTION:
-      usage (EXIT_SUCCESS);
-
-    default:
-      usage (EXIT_FAILURE);
-    }
-  }
-
-  /* Old-style syntax?  There were no -a or -d options in the old
-   * virt-rescue which is how we detect this.
-   */
-  if (drvs == NULL) {
-    while (optind < argc) {
-      if (strchr (argv[optind], '/') ||
-          access (argv[optind], F_OK) == 0) { /* simulate -a option */
-        drv = calloc (1, sizeof (struct drv));
-        if (!drv)
-          error (EXIT_FAILURE, errno, "calloc");
-        drv->type = drv_a;
-        drv->a.filename = strdup (argv[optind]);
-        if (!drv->a.filename)
-          error (EXIT_FAILURE, errno, "strdup");
-        drv->next = drvs;
-        drvs = drv;
-      } else {                  /* simulate -d option */
-        drv = calloc (1, sizeof (struct drv));
-        if (!drv)
-          error (EXIT_FAILURE, errno, "calloc");
-        drv->type = drv_d;
-        drv->d.guest = argv[optind];
-        drv->next = drvs;
-        drvs = drv;
-      }
-
-      optind++;
-    }
-  }
-
-  /* --suggest flag */
-  if (suggest) {
-    do_suggestion (drvs);
-    exit (EXIT_SUCCESS);
-  }
-
-  /* These are really constants, but they have to be variables for the
-   * options parsing code.  Assert here that they have known-good
-   * values.
-   */
-  assert (inspector == 0);
-  assert (keys_from_stdin == 0);
-  assert (echo_keys == 0);
-  assert (live == 0);
-
-  /* Must be no extra arguments on the command line. */
-  if (optind != argc) {
-    fprintf (stderr, _("%s: error: extra argument '%s' on command line.\n"
-             "Make sure to specify the argument for --format or --scratch "
-             "like '--format=%s'.\n"),
-             guestfs_int_program_name, argv[optind], argv[optind]);
-    usage (EXIT_FAILURE);
-  }
-
-  CHECK_OPTION_format_consumed;
-
-  /* User must have specified some drives. */
-  if (drvs == NULL) {
-    fprintf (stderr, _("%s: error: you must specify at least one -a or -d option.\n"),
-             guestfs_int_program_name);
-    usage (EXIT_FAILURE);
-  }
-
-  /* Setting "direct mode" is required for the rescue appliance. */
-  if (guestfs_set_direct (g, 1) == -1)
-    exit (EXIT_FAILURE);
-
-  {
-    /* The libvirt backend doesn't support direct mode.  As a temporary
-     * workaround, force the appliance backend, but warn about it.
-     */
-    CLEANUP_FREE char *backend = guestfs_get_backend (g);
-    if (backend) {
-      if (STREQ (backend, "libvirt") ||
-          STRPREFIX (backend, "libvirt:")) {
-        fprintf (stderr, _("%s: warning: virt-rescue doesn't work with the libvirt backend\n"
-                           "at the moment.  As a workaround, forcing backend = 'direct'.\n"),
-                 guestfs_int_program_name);
-        if (guestfs_set_backend (g, "direct") == -1)
-          exit (EXIT_FAILURE);
-      }
-    }
-  }
-
-  /* Set other features. */
-  if (memsize > 0)
-    if (guestfs_set_memsize (g, memsize) == -1)
-      exit (EXIT_FAILURE);
-  if (network)
-    if (guestfs_set_network (g, 1) == -1)
-      exit (EXIT_FAILURE);
-  if (smp >= 1)
-    if (guestfs_set_smp (g, smp) == -1)
-      exit (EXIT_FAILURE);
-
-  {
-    /* Kernel command line must include guestfs_rescue=1 (see
-     * appliance/init) as well as other options.
-     */
-    CLEANUP_FREE char *append_full = xasprintf ("guestfs_rescue=1%s%s",
-                                                append ? " " : "",
-                                                append ? append : "");
-    if (guestfs_set_append (g, append_full) == -1)
-      exit (EXIT_FAILURE);
-  }
-
-  /* Add drives. */
-  add_drives (drvs, 'a');
-
-  /* Free up data structures, no longer needed after this point. */
-  free_drives (drvs);
-
-  /* Run the appliance.  This won't return until the user quits the
-   * appliance.
-   */
-  if (!verbose)
-    guestfs_set_error_handler (g, NULL, NULL);
-
-  /* We expect launch to fail, so ignore the return value, and don't
-   * bother with explicit guestfs_shutdown either.
-   */
-  ignore_value (guestfs_launch (g));
-
-  guestfs_close (g);
-
-  exit (EXIT_SUCCESS);
-}
-
-static void suggest_filesystems (void);
-
-static int
-compare_keys_len (const void *p1, const void *p2)
-{
-  const char *key1 = * (char * const *) p1;
-  const char *key2 = * (char * const *) p2;
-  return strlen (key1) - strlen (key2);
-}
-
-/* virt-rescue --suggest flag does a kind of inspection on the
- * drives and suggests mount commands that you should use.
- */
-static void
-do_suggestion (struct drv *drvs)
-{
-  CLEANUP_FREE_STRING_LIST char **roots = NULL;
-  size_t i;
-
-  /* For inspection, force add_drives to add the drives read-only. */
-  read_only = 1;
-
-  /* Add drives. */
-  add_drives (drvs, 'a');
-
-  /* Free up data structures, no longer needed after this point. */
-  free_drives (drvs);
-
-  printf (_("Inspecting the virtual machine or disk image ...\n\n"));
-  fflush (stdout);
-
-  if (guestfs_launch (g) == -1)
-    exit (EXIT_FAILURE);
-
-  /* Don't use inspect_mount, since for virt-rescue we should allow
-   * arbitrary disks and disks with more than one OS on them.  Let's
-   * do this using the basic API instead.
-   */
-  roots = guestfs_inspect_os (g);
-  if (roots == NULL)
-    exit (EXIT_FAILURE);
-
-  if (roots[0] == NULL) {
-    suggest_filesystems ();
-    return;
-  }
-
-  printf (_("This disk contains one or more operating systems.  You can use these mount\n"
-            "commands in virt-rescue (at the ><rescue> prompt) to mount the filesystems.\n\n"));
-
-  for (i = 0; roots[i] != NULL; ++i) {
-    CLEANUP_FREE_STRING_LIST char **mps = NULL;
-    CLEANUP_FREE char *type = NULL, *distro = NULL, *product_name = NULL;
-    int major, minor;
-    size_t j;
-
-    type = guestfs_inspect_get_type (g, roots[i]);
-    distro = guestfs_inspect_get_distro (g, roots[i]);
-    product_name = guestfs_inspect_get_product_name (g, roots[i]);
-    major = guestfs_inspect_get_major_version (g, roots[i]);
-    minor = guestfs_inspect_get_minor_version (g, roots[i]);
-
-    printf (_("# %s is the root of a %s operating system\n"
-              "# type: %s, distro: %s, version: %d.%d\n"
-              "# %s\n\n"),
-            roots[i], type ? : "unknown",
-            type ? : "unknown", distro ? : "unknown", major, minor,
-            product_name ? : "");
-
-    mps = guestfs_inspect_get_mountpoints (g, roots[i]);
-    if (mps == NULL)
-      exit (EXIT_FAILURE);
-
-    /* Sort by key length, shortest key first, so that we end up
-     * mounting the filesystems in the correct order.
-     */
-    qsort (mps, guestfs_int_count_strings (mps) / 2, 2 * sizeof (char *),
-           compare_keys_len);
-
-    for (j = 0; mps[j] != NULL; j += 2)
-      printf ("mount %s /sysroot%s\n", mps[j+1], mps[j]);
-
-    /* If it's Linux, print the bind-mounts and a chroot command. */
-    if (type && STREQ (type, "linux")) {
-      printf ("mount --rbind /dev /sysroot/dev\n");
-      printf ("mount --rbind /proc /sysroot/proc\n");
-      printf ("mount --rbind /sys /sysroot/sys\n");
-      printf ("\n");
-      printf ("cd /sysroot\n");
-      printf ("chroot /sysroot\n");
-    }
-
-    printf ("\n");
-  }
-}
-
-/* Inspection failed, so it doesn't contain any OS that we recognise.
- * However there might still be filesystems so print some suggestions
- * for those.
- */
-static void
-suggest_filesystems (void)
-{
-  size_t i, count;
-
-  CLEANUP_FREE_STRING_LIST char **fses = guestfs_list_filesystems (g);
-  if (fses == NULL)
-    exit (EXIT_FAILURE);
-
-  /* Count how many are not swap or unknown.  Possibly we should try
-   * mounting to see which are mountable, but that has a high
-   * probability of breaking.
-   */
-#define TEST_MOUNTABLE(fs) STRNEQ ((fs), "swap") && STRNEQ ((fs), "unknown")
-  count = 0;
-  for (i = 0; fses[i] != NULL; i += 2) {
-    if (TEST_MOUNTABLE (fses[i+1]))
-      count++;
-  }
-
-  if (count == 0) {
-    printf (_("This disk contains no mountable filesystems that we recognize.\n\n"
-              "However you can still use virt-rescue on the disk image, to try to mount\n"
-              "filesystems that are not recognized by libguestfs, or to create partitions,\n"
-              "logical volumes and filesystems on a blank disk.\n"));
-    return;
-  }
-
-  printf (_("This disk contains one or more filesystems, but we don't recognize any\n"
-            "operating system.  You can use these mount commands in virt-rescue (at the\n"
-            "><rescue> prompt) to mount these filesystems.\n\n"));
-
-  for (i = 0; fses[i] != NULL; i += 2) {
-    printf (_("# %s has type '%s'\n"), fses[i], fses[i+1]);
-
-    if (TEST_MOUNTABLE (fses[i+1]))
-      printf ("mount %s /sysroot\n", fses[i]);
-
-    printf ("\n");
-  }
-#undef TEST_MOUNTABLE
-}
-
-static void add_scratch_disk (struct drv **drvs);
-
-static void
-add_scratch_disks (int n, struct drv **drvs)
-{
-  while (n > 0) {
-    add_scratch_disk (drvs);
-    n--;
-  }
-}
-
-static void
-add_scratch_disk (struct drv **drvs)
-{
-  struct drv *drv;
-
-  /* Add the scratch disk to the drives list. */
-  drv = calloc (1, sizeof (struct drv));
-  if (!drv)
-    error (EXIT_FAILURE, errno, "calloc");
-  drv->type = drv_scratch;
-  drv->nr_drives = -1;
-  drv->scratch.size = INT64_C (10737418240);
-  drv->next = *drvs;
-  *drvs = drv;
-}
diff --git a/rescue/rescue.ml b/rescue/rescue.ml
new file mode 100644
index 0000000..053627b
--- /dev/null
+++ b/rescue/rescue.ml
@@ -0,0 +1,226 @@
+(* virt-rescue
+ * Copyright (C) 2009-2016 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+open Common_utils
+open Common_gettext.Gettext
+open Getopt.OptionName
+
+open Unix
+open Printf
+
+module G = Guestfs
+
+let () = Random.self_init ()
+
+let parse_args () =
+  let images = ref [] in
+  let append = ref "" in
+  let libvirturi = ref "" in
+  let domain = ref "" in
+  let format = ref "" in
+  let memsize = ref 0 in
+  let network = ref false in
+  let readonly = ref false in
+  let readwrite = ref false in
+  let scratch = ref 0 in
+  let selinux = ref false in
+  let smp = ref 1 in
+  let suggest = ref false in
+
+  let argspec = [
+    [S 'a'; L"add"], Getopt.String (s_"image ", (fun s -> push_front s images)), s_"Add image";
+    [L"append"], Getopt.Set_string (s_"kernelopts", append), s_"Append kernel options";
+    [S 'c'; L"connect"], Getopt.Set_string (s_"uri", libvirturi), s_"Specify libvirt URI for -d option";
+    [S 'd'; L"domain"], Getopt.Set_string (s_"domain", domain), s_"Add disks from libvirt guest";
+    [L"format"], Getopt.Set_string (s_"format", format), s_"Force disk format for -a option";
+    [S 'm'; L"memsize"], Getopt.Set_int (s_"MB", memsize), s_"Set memory size in megabytes";
+    [L"network"], Getopt.Set network, s_"Enable network";
+    [S 'r'; L"ro"], Getopt.Set readonly, s_"Access read-only";
+    [L"scratch"], Getopt.Set_int (s_"N", scratch), s_"Add scratch disks(s)";
+    [L"selinux"], Getopt.Set selinux, s_"For backwards compat only, does nothing";
+    [L"smp"], Getopt.Set_int (s_"N", smp), s_"Set SMP CPU count";
+    [L"suggest"], Getopt.Set suggest, s_"Suggest mount commands for this guest";
+    [S 'w'; L"rw"], Getopt.Set readwrite, s_"Mount read-write"
+  ] in
+  let anon_fun x = () in
+  let usage_msg =
+    sprintf (f_"\
+%s: Run a rescue shell on a virtual machine
+Copyright (C) 2009-2016 Red Hat Inc.
+Usage:\n") prog in
+  let opthandle = create_standard_options argspec ~anon_fun usage_msg in
+  Getopt.parse opthandle;
+
+  (* Dereference args *)
+  let images = !images in
+  let append = !append in
+  let libvirturi = match !libvirturi with "" -> None | s -> Some s in
+  let domain = !domain in
+  let format = match !format with "" -> None | str -> Some str in
+  let memsize = !memsize in
+  let network = !network in
+  let readonly = !readonly in
+  let readwrite = !readwrite in
+  let scratch = !scratch in
+  let selinux = !selinux in
+  let smp = !smp in
+  let suggest = !suggest in
+
+  if domain = "" && images = [] then
+    failwith "you must specify at least one -a or -d option.";
+
+  if readwrite && readonly then
+    failwith "cannot mix --ro and --rw options";
+
+  images, append, libvirturi, domain, format, memsize, network, readonly,
+    scratch, selinux, smp, suggest
+
+let perform_rescue images append libvirturi domain format memsize network readonly scratch
+      selinux smp suggest =
+  let g = open_guestfs () in
+    if not (domain = "") then (
+      print_string ("domain: " ^ domain);
+      ignore (g#add_domain ~readonly ?libvirturi domain)
+    ) else (
+      List.iter (g#add_drive ?format ~readonly) images
+    );
+
+    g#set_direct true;
+
+    if selinux then
+      g#set_selinux selinux;
+    if smp > 1 then
+      g#set_smp smp;
+    if network then
+      g#set_network network;
+    if memsize > 0 then
+      g#set_memsize memsize;
+
+    for i = 0 to scratch do
+      g#add_drive_scratch 10737418240_L;
+    done;
+
+    (* Set backend to direct *)
+    if (String.is_prefix (g#get_backend ()) "libvirt") then (
+      g#set_backend "direct";
+
+      if not (String.is_prefix (g#get_backend ()) "direct") then (
+        let s = sprintf "Could not set direct backend. Got %s instead" (g#get_backend ()) in
+        failwith s;
+      );
+    );
+
+    g#set_append (Some append);
+
+    (* We expect launch to fail so let's ignore error *)
+    try
+      g#launch ();
+    with (Guestfs.Error s) -> ();
+
+    g#shutdown ();
+    g#close ()
+
+let is_mountable (fs,_) = (not (fs = "swap")) && (not (fs = "unknown"))
+
+let suggestion_for_fs (p, t) =
+  printf "# %s has type '%s'\n" p t;
+  if is_mountable (p, t) then
+    printf "mount %s /sysroot\n" p;
+  print_newline ()
+
+let inspection_for_fs g p =
+  let os_type = g#inspect_get_type p in
+  let distro = g#inspect_get_distro p in
+  let product_name = g#inspect_get_product_name p in
+  let major = g#inspect_get_major_version p in
+  let minor = g#inspect_get_minor_version p in
+  let os_type = match os_type with
+    "" -> "unknown"
+  |  _ -> os_type in
+  let distro = match distro with
+    "" -> "unknown"
+  |  _ -> distro in
+
+  printf ("# %s is the root of a %s operating system\n
+# type: %s, distro: %s, version: %d.%d\n
+# %s\n\n") p os_type os_type distro major minor product_name;
+
+  let mps = g#inspect_get_mountpoints p in
+  if mps = [] then failwith "empty mountpoints"
+  else (
+    let mps = List.sort (fun (a,b) (c,d) -> compare (compare a c) (compare b d)) mps in
+    List.iter (fun (m, p) -> printf "mount %s /sysroot%s\n" p m) mps;
+  );
+
+  if os_type = "linux" then (
+      printf ("mount --rbind /dev /sysroot/dev\n");
+      printf ("mount --rbind /proc /sysroot/proc\n");
+      printf ("mount --rbind /sys /sysroot/sys\n");
+      printf ("\n");
+      printf ("cd /sysroot\n");
+      printf ("chroot /sysroot\n");
+  )
+
+let perform_suggestion images libvirturi domain format scratch =
+  let g = open_guestfs () in
+    if not (domain = "") then (
+      ignore (g#add_domain ~readonly:true domain ?libvirturi)
+    ) else (
+      List.iter (g#add_drive ?format ~readonly:true) images
+    );
+
+    for i = 0 to scratch do
+      g#add_drive_scratch 10737418240_L;
+    done;
+
+    g#launch ();
+
+    let rootfs = g#inspect_os () in
+    if Array.length rootfs = 0 then
+      failwith "No root fs found";
+    if rootfs.(0) = "" then (
+      let fses = g#list_filesystems () in
+      let fs_count = List.fold_left (fun x y -> x + if y then 1 else 0) 0 (List.map is_mountable fses) in
+      if fs_count = 0 then (
+        print_string ("This disk contains no mountable filesystems that we recognize.\n\n"
+              ^ "However you can still use virt-rescue on the disk image, to try to mount\n"
+              ^ "filesystems that are not recognized by libguestfs, or to create partitions,\n"
+              ^ "logical volumes and filesystems on a blank disk.\n");
+      ) else (
+        print_string ("This disk contains one or more filesystems, but we don't recognize any\n"
+            ^ "operating system.  You can use these mount commands in virt-rescue (at the\n"
+            ^ "><rescue> prompt) to mount these filesystems.\n\n");
+        List.iter suggestion_for_fs fses;
+      )
+    ) else (
+      print_string ("This disk contains one or more operating systems.  You can use these mount\n"
+        ^ "commands in virt-rescue (at the ><rescue> prompt) to mount the filesystems.\n\n");
+      Array.iter (inspection_for_fs g) rootfs
+    )
+
+let main () =
+  let images, append, libvirturi, domain, format, memsize, network, readonly, scratch,
+      selinux, smp, suggest = parse_args () in
+
+  if suggest then
+    perform_suggestion images libvirturi domain format scratch
+  else (
+    perform_rescue images append libvirturi domain format memsize network readonly scratch selinux smp suggest;
+  )
+
+let () = run_main_and_handle_errors main
diff --git a/rescue/virt-rescue.pod b/rescue/virt-rescue.pod
index f2cfef0..be6e33c 100644
--- a/rescue/virt-rescue.pod
+++ b/rescue/virt-rescue.pod
@@ -129,6 +129,15 @@ Add a remote disk.  See L<guestfish(1)/ADDING REMOTE STORAGE>.
 
 Pass additional options to the rescue kernel.
 
+=item B<--colors>
+
+=item B<--colours>
+
+Use ANSI colour sequences to colourize messages.  This is the default
+when the output is a tty.  If the output of the program is redirected
+to a file, ANSI colour sequences are disabled unless you use this
+option.
+
 =item B<-c> URI
 
 =item B<--connect> URI
@@ -224,6 +233,14 @@ second terminal, then paste the commands into another virt-rescue.
 This option implies I<--ro> and is safe to use even if the guest is up
 or if another virt-rescue is running.
 
+=item B<-q>
+
+=item B<--quiet>
+
+Don't print log messages.
+
+To enable detailed logging of individual file operations, use I<-x>.
+
 =item B<-v>
 
 =item B<--verbose>
-- 
2.5.5

