--- /dev/null
+config.cmi:
+config.cmo: config.cmi
+config.cmx: config.cmi
+destination_tab.cmi:
+destination_tab.cmo: destination_tab.cmi
+destination_tab.cmx: destination_tab.cmi
+logvols_tab.cmi:
+logvols_tab.cmo: logvols_tab.cmi
+logvols_tab.cmx: logvols_tab.cmi
+main.cmo: window.cmi slave.cmi
+main.cmx: window.cmx slave.cmx
+partitions_tab.cmi:
+partitions_tab.cmo: partitions_tab.cmi
+partitions_tab.cmx: partitions_tab.cmi
+slave.cmi: slave_types.cmi
+slave.cmo: utils.cmi slave_types.cmi slave.cmi
+slave.cmx: utils.cmx slave_types.cmx slave.cmi
+slave_types.cmi:
+slave_types.cmo: slave_types.cmi
+slave_types.cmx: slave_types.cmi
+source_tab.cmi:
+source_tab.cmo: utils.cmi slave_types.cmi slave.cmi source_tab.cmi
+source_tab.cmx: utils.cmx slave_types.cmx slave.cmx source_tab.cmi
+utils.cmi:
+utils.cmo: config.cmi utils.cmi
+utils.cmx: config.cmx utils.cmi
+window.cmi:
+window.cmo: source_tab.cmi partitions_tab.cmi logvols_tab.cmi destination_tab.cmi window.cmi
+window.cmx: source_tab.cmx partitions_tab.cmx logvols_tab.cmx destination_tab.cmx window.cmi
--- /dev/null
+*~
+*.cmi
+*.cmo
+*.cmx
+*.o
+Makefile
+Makefile.in
+aclocal.m4
+autom4te.cache
+compile
+config.h
+config.h.in
+config.log
+config.ml
+config.status
+configure
+doc/
+html/*.html
+install-sh
+missing
+pod2htm?.tmp
+stamp-h1
+virt-resize-ui-*.tar.gz
+virt-resize-ui
+virt-resize-ui.1
--- /dev/null
+# Virt resize UI.
+# Copyright (C) 2011 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.
+
+ACLOCAL_AMFLAGS = -I m4
+
+EXTRA_DIST = \
+ $(SOURCES) \
+ config.ml.in \
+ .gitignore \
+ virt-resize-ui.pod \
+ virt-resize-ui.1 \
+ html/pod.css
+
+CLEANFILES = *.cmi *.cmo *.cmx *.cmxa *.o virt-resize-ui *~
+
+# These are listed here in alphabetical order.
+SOURCES = \
+ config.mli \
+ destination_tab.mli \
+ destination_tab.ml \
+ logvols_tab.mli \
+ logvols_tab.ml \
+ main.ml \
+ partitions_tab.mli \
+ partitions_tab.ml \
+ slave.mli \
+ slave.ml \
+ slave_types.mli \
+ slave_types.ml \
+ source_tab.mli \
+ source_tab.ml \
+ utils.mli \
+ utils.ml \
+ window.ml \
+ window.mli
+
+BUILT_SOURCES = \
+ config.ml
+
+# Note this list must be in dependency order.
+OBJECTS = \
+ config.cmo \
+ utils.cmo \
+ slave_types.cmo \
+ slave.cmo \
+ source_tab.cmo \
+ destination_tab.cmo \
+ partitions_tab.cmo \
+ logvols_tab.cmo \
+ window.cmo \
+ main.cmo
+
+XOBJECTS = $(OBJECTS:.cmo=.cmx)
+
+bin_SCRIPTS = virt-resize-ui
+
+OCAMLPACKAGES = \
+ -package threads,libvirt,guestfs,lablgtk2,extlib
+OCAMLCFLAGS = \
+ -g \
+ -warn-error CDEFLMPSUVYZX \
+ -thread \
+ $(OCAMLPACKAGES) \
+ -predicates threads
+OCAMLOPTFLAGS = \
+ -ccopt -g \
+ $(OCAMLCFLAGS)
+OCAMLDOCFLAGS = \
+ $(OCAMLPACKAGES) \
+ -predicates threads \
+ -I +threads \
+ -sort -html
+
+if HAVE_OCAMLOPT
+virt-resize-ui: $(XOBJECTS)
+ $(OCAMLFIND) ocamlopt $(OCAMLOPTFLAGS) \
+ -predicates init,threads \
+ -linkpkg gtkThread.cmx \
+ $^ -o $@
+else
+virt-resize-ui: $(OBJECTS)
+ $(OCAMLFIND) ocamlc $(OCAMLCFLAGS) \
+ -predicates init,threads \
+ -linkpkg gtkThread.cmo \
+ $^ -o $@
+endif
+
+.mli.cmi:
+ $(OCAMLFIND) ocamlc $(OCAMLCFLAGS) -c $< -o $@
+.ml.cmo:
+ $(OCAMLFIND) ocamlc $(OCAMLCFLAGS) -c $< -o $@
+.ml.cmx:
+ $(OCAMLFIND) ocamlopt $(OCAMLCFLAGS) -c $< -o $@
+
+# Man page.
+man_MANS = virt-resize-ui.1
+
+if HAVE_PERLDOC
+
+virt-resize-ui.1: virt-resize-ui.pod
+ pod2man \
+ --section 1 \
+ -c "Virtualization Support" \
+ --release "$(PACKAGE_NAME)-$(PACKAGE_VERSION)" \
+ $< > $@
+
+noinst_DATA = \
+ html/virt-resize-ui.1.html
+
+html/virt-resize-ui.1.html: virt-resize-ui.pod
+ mkdir -p html
+ pod2html \
+ --css 'pod.css' \
+ --htmldir html \
+ --outfile html/virt-resize-ui.1.html \
+ virt-resize-ui.pod
+
+endif
+
+# Maintainer website update.
+HTMLFILES = \
+ html/virt-resize-ui.1.html
+
+WEBSITEDIR = $(HOME)/d/redhat/websites/libguestfs
+
+website: $(HTMLFILES)
+ cp $(HTMLFILES) $(WEBSITEDIR)
+
+CLEANFILES += $(HTMLFILES) pod2*.tmp
+
+# Convert internal documentation to HTML.
+docs:
+ rm -rf doc
+ mkdir -p doc
+ $(OCAMLFIND) ocamldoc -d doc $(OCAMLDOCFLAGS) $(SOURCES)
+
+# Dependencies.
+depend: .depend
+
+.depend: $(wildcard *.mli) $(wildcard *.ml)
+ $(OCAMLFIND) ocamldep $(OCAMLPACKAGES) $^ | \
+ $(SED) -e 's/ *$$//' | \
+ $(SED) -e :a -e '/ *\\$$/N; s/ *\\\n */ /; ta' | \
+ LANG=C sort > $@-t
+ mv $@-t $@
+
+include .depend
+
+.PHONY: depend docs
--- /dev/null
+(* Virt resize UI.
+ * Copyright (C) 2011 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.
+ *)
+
+let package = "@PACKAGE_NAME@"
+let version = "@PACKAGE_VERSION@"
--- /dev/null
+(* Virt resize UI.
+ * Copyright (C) 2011 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.
+ *)
+
+(** Configuration. *)
+
+val package : string
+ (** The package name. *)
+
+val version : string
+ (** The version number as a string. *)
--- /dev/null
+dnl Virt resize UI.
+dnl Copyright (C) 2011 Red Hat Inc.
+dnl
+dnl This program is free software; you can redistribute it and/or modify
+dnl it under the terms of the GNU General Public License as published by
+dnl the Free Software Foundation; either version 2 of the License, or
+dnl (at your option) any later version.
+dnl
+dnl This program is distributed in the hope that it will be useful,
+dnl but WITHOUT ANY WARRANTY; without even the implied warranty of
+dnl MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+dnl GNU General Public License for more details.
+dnl
+dnl You should have received a copy of the GNU General Public License along
+dnl with this program; if not, write to the Free Software Foundation, Inc.,
+dnl 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+AC_INIT([virt-resize-ui],[0.1.0])
+AM_INIT_AUTOMAKE([foreign])
+AC_CONFIG_MACRO_DIR([m4])
+
+dnl Check for C compiler.
+AC_PROG_CC_STDC
+AC_PROG_INSTALL
+AC_PROG_CPP
+AC_C_PROTOTYPES
+test "x$U" != "x" && AC_MSG_ERROR([Compiler not ANSI compliant])
+AM_PROG_CC_C_O
+AC_SYS_LARGEFILE
+
+AC_PROG_SED
+
+dnl Check for OCaml compiler.
+AC_PROG_OCAML
+if test "$OCAMLC" = "no"; then
+ AC_MSG_ERROR([You must install the OCaml compiler (ocamlc or ocamlopt)])
+fi
+
+dnl Choose native code if available, but allow the user to specify
+dnl bytecode only (useful for debugging).
+AC_ARG_WITH([native],
+ [AS_HELP_STRING([--without-native],
+ [disable native compilation (slow, but useful for debugging)])],
+ [],
+ [with_native=yes])
+AM_CONDITIONAL([HAVE_OCAMLOPT],
+ [test "x$with_native" != "xno" && test "x$OCAMLBEST" = "xopt"])
+
+dnl Check for OCaml findlib.
+AC_PROG_FINDLIB
+if test "$OCAMLFIND" = "no"; then
+ AC_MSG_ERROR([You must install OCaml findlib (ocamlfind)])
+fi
+
+dnl Check for all OCaml packages.
+AC_CHECK_OCAML_PKG([lablgtk2])
+if test "$OCAML_PKG_lablgtk2" = "no"; then
+ AC_MSG_ERROR([Please install OCaml module 'lablgtk2'.])
+fi
+
+AC_CHECK_OCAML_PKG([libvirt])
+if test "$OCAML_PKG_libvirt" = "no"; then
+ AC_MSG_ERROR([Please install OCaml module 'libvirt'.])
+fi
+
+AC_CHECK_OCAML_PKG([guestfs])
+if test "$OCAML_PKG_guestfs" = "no"; then
+ AC_MSG_ERROR([Please install OCaml module 'guestfs'.])
+fi
+
+AC_CHECK_OCAML_PKG([extlib])
+if test "$OCAML_PKG_extlib" = "no"; then
+ AC_MSG_ERROR([Please install OCaml module 'extlib'.])
+fi
+
+dnl Optional programs.
+AC_CHECK_PROG([PERLDOC],[perldoc],[perldoc],[no])
+if test "x$PERLDOC" = "xno" ; then
+ AC_MSG_WARN([perldoc not found - install perl to make man pages])
+fi
+AM_CONDITIONAL([HAVE_PERLDOC],[test "x$PERLDOC" != "xno"])
+
+AC_CONFIG_HEADERS([config.h])
+AC_CONFIG_FILES([Makefile config.ml])
+AC_OUTPUT
--- /dev/null
+(* Virt resize UI.
+ * Copyright (C) 2011 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.
+ *)
+
+class tab (vbox : GPack.box) =
+object
+ inherit GObj.widget (vbox#as_widget)
+end
+
+let tab () =
+ let vbox = GPack.vbox ~border_width:8 () in
+ new tab vbox
--- /dev/null
+(* Virt resize UI.
+ * Copyright (C) 2011 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.
+ *)
+
+(** The Destination_tab module handles the "Destionation" tab in the
+ main window. *)
+
+class tab : GPack.box ->
+object
+ inherit GObj.widget
+ val obj : Gtk.widget Gtk.obj
+end
+
+val tab : unit -> tab
--- /dev/null
+(* Virt resize UI.
+ * Copyright (C) 2011 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.
+ *)
+
+class tab (vbox : GPack.box) =
+object
+ inherit GObj.widget (vbox#as_widget)
+end
+
+let tab () =
+ let vbox = GPack.vbox ~border_width:8 () in
+ new tab vbox
--- /dev/null
+(* Virt resize UI.
+ * Copyright (C) 2011 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.
+ *)
+
+(** The Logvols_tab module handles the "Logical volumes" tab in the
+ main window. *)
+
+class tab : GPack.box ->
+object
+ inherit GObj.widget
+ val obj : Gtk.widget Gtk.obj
+end
+
+val tab : unit -> tab
--- /dev/null
+dnl autoconf macros for OCaml
+dnl
+dnl Copyright © 2009 Richard W.M. Jones
+dnl Copyright © 2009 Stefano Zacchiroli
+dnl Copyright © 2000-2005 Olivier Andrieu
+dnl Copyright © 2000-2005 Jean-Christophe Filliâtre
+dnl Copyright © 2000-2005 Georges Mariano
+dnl
+dnl For documentation, please read the ocaml.m4 man page.
+
+AC_DEFUN([AC_PROG_OCAML],
+[dnl
+ # checking for ocamlc
+ AC_CHECK_TOOL([OCAMLC],[ocamlc],[no])
+
+ if test "$OCAMLC" != "no"; then
+ OCAMLVERSION=`$OCAMLC -v | sed -n -e 's|.*version* *\(.*\)$|\1|p'`
+ AC_MSG_RESULT([OCaml version is $OCAMLVERSION])
+ OCAMLLIB=`$OCAMLC -where 2>/dev/null || $OCAMLC -v|tail -1|cut -d ' ' -f 4`
+ AC_MSG_RESULT([OCaml library path is $OCAMLLIB])
+
+ AC_SUBST([OCAMLVERSION])
+ AC_SUBST([OCAMLLIB])
+
+ # checking for ocamlopt
+ AC_CHECK_TOOL([OCAMLOPT],[ocamlopt],[no])
+ OCAMLBEST=byte
+ if test "$OCAMLOPT" = "no"; then
+ AC_MSG_WARN([Cannot find ocamlopt; bytecode compilation only.])
+ else
+ TMPVERSION=`$OCAMLOPT -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' `
+ if test "$TMPVERSION" != "$OCAMLVERSION" ; then
+ AC_MSG_RESULT([versions differs from ocamlc; ocamlopt discarded.])
+ OCAMLOPT=no
+ else
+ OCAMLBEST=opt
+ fi
+ fi
+
+ AC_SUBST([OCAMLBEST])
+
+ # checking for ocamlc.opt
+ AC_CHECK_TOOL([OCAMLCDOTOPT],[ocamlc.opt],[no])
+ if test "$OCAMLCDOTOPT" != "no"; then
+ TMPVERSION=`$OCAMLCDOTOPT -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' `
+ if test "$TMPVERSION" != "$OCAMLVERSION" ; then
+ AC_MSG_RESULT([versions differs from ocamlc; ocamlc.opt discarded.])
+ else
+ OCAMLC=$OCAMLCDOTOPT
+ fi
+ fi
+
+ # checking for ocamlopt.opt
+ if test "$OCAMLOPT" != "no" ; then
+ AC_CHECK_TOOL([OCAMLOPTDOTOPT],[ocamlopt.opt],[no])
+ if test "$OCAMLOPTDOTOPT" != "no"; then
+ TMPVERSION=`$OCAMLOPTDOTOPT -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' `
+ if test "$TMPVERSION" != "$OCAMLVERSION" ; then
+ AC_MSG_RESULT([version differs from ocamlc; ocamlopt.opt discarded.])
+ else
+ OCAMLOPT=$OCAMLOPTDOTOPT
+ fi
+ fi
+ fi
+
+ AC_SUBST([OCAMLOPT])
+ fi
+
+ AC_SUBST([OCAMLC])
+
+ # checking for ocamldep
+ AC_CHECK_TOOL([OCAMLDEP],[ocamldep],[no])
+
+ # checking for ocamlmktop
+ AC_CHECK_TOOL([OCAMLMKTOP],[ocamlmktop],[no])
+
+ # checking for ocamlmklib
+ AC_CHECK_TOOL([OCAMLMKLIB],[ocamlmklib],[no])
+
+ # checking for ocamldoc
+ AC_CHECK_TOOL([OCAMLDOC],[ocamldoc],[no])
+
+ # checking for ocamlbuild
+ AC_CHECK_TOOL([OCAMLBUILD],[ocamlbuild],[no])
+])
+
+
+AC_DEFUN([AC_PROG_OCAMLLEX],
+[dnl
+ # checking for ocamllex
+ AC_CHECK_TOOL([OCAMLLEX],[ocamllex],[no])
+ if test "$OCAMLLEX" != "no"; then
+ AC_CHECK_TOOL([OCAMLLEXDOTOPT],[ocamllex.opt],[no])
+ if test "$OCAMLLEXDOTOPT" != "no"; then
+ OCAMLLEX=$OCAMLLEXDOTOPT
+ fi
+ fi
+ AC_SUBST([OCAMLLEX])
+])
+
+AC_DEFUN([AC_PROG_OCAMLYACC],
+[dnl
+ AC_CHECK_TOOL([OCAMLYACC],[ocamlyacc],[no])
+ AC_SUBST([OCAMLYACC])
+])
+
+
+AC_DEFUN([AC_PROG_CAMLP4],
+[dnl
+ AC_REQUIRE([AC_PROG_OCAML])dnl
+
+ # checking for camlp4
+ AC_CHECK_TOOL([CAMLP4],[camlp4],[no])
+ if test "$CAMLP4" != "no"; then
+ TMPVERSION=`$CAMLP4 -v 2>&1| sed -n -e 's|.*version *\(.*\)$|\1|p'`
+ if test "$TMPVERSION" != "$OCAMLVERSION" ; then
+ AC_MSG_RESULT([versions differs from ocamlc])
+ CAMLP4=no
+ fi
+ fi
+ AC_SUBST([CAMLP4])
+
+ # checking for companion tools
+ AC_CHECK_TOOL([CAMLP4BOOT],[camlp4boot],[no])
+ AC_CHECK_TOOL([CAMLP4O],[camlp4o],[no])
+ AC_CHECK_TOOL([CAMLP4OF],[camlp4of],[no])
+ AC_CHECK_TOOL([CAMLP4OOF],[camlp4oof],[no])
+ AC_CHECK_TOOL([CAMLP4ORF],[camlp4orf],[no])
+ AC_CHECK_TOOL([CAMLP4PROF],[camlp4prof],[no])
+ AC_CHECK_TOOL([CAMLP4R],[camlp4r],[no])
+ AC_CHECK_TOOL([CAMLP4RF],[camlp4rf],[no])
+ AC_SUBST([CAMLP4BOOT])
+ AC_SUBST([CAMLP4O])
+ AC_SUBST([CAMLP4OF])
+ AC_SUBST([CAMLP4OOF])
+ AC_SUBST([CAMLP4ORF])
+ AC_SUBST([CAMLP4PROF])
+ AC_SUBST([CAMLP4R])
+ AC_SUBST([CAMLP4RF])
+])
+
+
+AC_DEFUN([AC_PROG_FINDLIB],
+[dnl
+ AC_REQUIRE([AC_PROG_OCAML])dnl
+
+ # checking for ocamlfind
+ AC_CHECK_TOOL([OCAMLFIND],[ocamlfind],[no])
+ AC_SUBST([OCAMLFIND])
+])
+
+
+dnl Thanks to Jim Meyering for working this next bit out for us.
+dnl XXX We should define AS_TR_SH if it's not defined already
+dnl (eg. for old autoconf).
+AC_DEFUN([AC_CHECK_OCAML_PKG],
+[dnl
+ AC_REQUIRE([AC_PROG_FINDLIB])dnl
+
+ AC_MSG_CHECKING([for OCaml findlib package $1])
+
+ unset found
+ unset pkg
+ found=no
+ for pkg in $1 $2 ; do
+ if $OCAMLFIND query $pkg >/dev/null 2>/dev/null; then
+ AC_MSG_RESULT([found])
+ AS_TR_SH([OCAML_PKG_$1])=$pkg
+ found=yes
+ break
+ fi
+ done
+ if test "$found" = "no" ; then
+ AC_MSG_RESULT([not found])
+ AS_TR_SH([OCAML_PKG_$1])=no
+ fi
+
+ AC_SUBST(AS_TR_SH([OCAML_PKG_$1]))
+])
+
+
+AC_DEFUN([AC_CHECK_OCAML_MODULE],
+[dnl
+ AC_MSG_CHECKING([for OCaml module $2])
+
+ cat > conftest.ml <<EOF
+open $3
+EOF
+ unset found
+ for $1 in $$1 $4 ; do
+ if $OCAMLC -c -I "$$1" conftest.ml >&5 2>&5 ; then
+ found=yes
+ break
+ fi
+ done
+
+ if test "$found" ; then
+ AC_MSG_RESULT([$$1])
+ else
+ AC_MSG_RESULT([not found])
+ $1=no
+ fi
+ AC_SUBST([$1])
+])
+
+
+dnl XXX Cross-compiling
+AC_DEFUN([AC_CHECK_OCAML_WORD_SIZE],
+[dnl
+ AC_MSG_CHECKING([for OCaml compiler word size])
+ cat > conftest.ml <<EOF
+ print_endline (string_of_int Sys.word_size)
+ EOF
+ OCAML_WORD_SIZE=`ocaml conftest.ml`
+ AC_MSG_RESULT([$OCAML_WORD_SIZE])
+ AC_SUBST([OCAML_WORD_SIZE])
+])
--- /dev/null
+(* Virt resize UI.
+ * Copyright (C) 2011 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.
+ *)
+
+let () =
+ ignore (new Window.window);
+ GtkThread.main ();
+ Slave.exit_thread ()
--- /dev/null
+(* Virt resize UI.
+ * Copyright (C) 2011 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.
+ *)
+
+class tab (vbox : GPack.box) =
+object
+ inherit GObj.widget (vbox#as_widget)
+end
+
+let tab () =
+ let vbox = GPack.vbox ~border_width:8 () in
+ new tab vbox
--- /dev/null
+(* Virt resize UI.
+ * Copyright (C) 2011 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.
+ *)
+
+(** The Partitions_tab module handles the "Resize partitions" tab in
+ the main window. *)
+
+class tab : GPack.box ->
+object
+ inherit GObj.widget
+ val obj : Gtk.widget Gtk.obj
+end
+
+val tab : unit -> tab
--- /dev/null
+(* Virt-resize UI.
+ * Copyright (C) 2011 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 Slave_types
+open Utils
+
+(*module C = Libvirt.Connect*)
+module Cond = Condition
+(*module D = Libvirt.Domain*)
+module G = Guestfs
+module M = Mutex
+module Q = Queue
+
+(* Callbacks. *)
+type 'a callback = 'a -> unit
+let no_callback _ = ()
+
+(* Hooks. *)
+let failure_hook = ref (fun _ -> ())
+let busy_hook = ref (fun _ -> ())
+let idle_hook = ref (fun _ -> ())
+let status_hook = ref (fun _ -> ())
+let progress_hook = ref (fun _ -> ())
+
+let set_failure_hook cb = failure_hook := cb
+let set_busy_hook cb = busy_hook := cb
+let set_idle_hook cb = idle_hook := cb
+let set_status_hook cb = status_hook := cb
+let set_progress_hook cb = progress_hook := cb
+
+(* Messages. *)
+type message =
+ | Exit_thread
+ | Open_images of (string * string option) list * inspection_data callback
+
+let rec string_of_message = function
+ | Exit_thread -> "Exit_thread"
+ | Open_images (images, _) ->
+ sprintf "Open_images %s" (string_of_images images)
+
+and string_of_images images =
+ "[" ^
+ String.concat "; "
+ (List.map (
+ function
+ | fn, None -> fn
+ | fn, Some format -> sprintf "%s (%s)" fn format
+ ) images) ^
+ "]"
+
+(* Execute a function, while holding a mutex. If the function
+ * fails, ensure we release the mutex before rethrowing the
+ * exception.
+ *)
+let with_lock m f =
+ M.lock m;
+ let r = try Left (f ()) with exn -> Right exn in
+ M.unlock m;
+ match r with
+ | Left r -> r
+ | Right exn -> raise exn
+
+(* The queue of commands, and a lock and condition to protect it. *)
+let q = Q.create ()
+let q_discard = ref false
+let q_lock = M.create ()
+let q_cond = Cond.create ()
+
+(* Send a command message to the slave thread. *)
+let send_message ?fail msg =
+ debug "sending message %s to slave thread ..." (string_of_message msg);
+ with_lock q_lock (
+ fun () ->
+ Q.push (fail, msg) q;
+ Cond.signal q_cond
+ )
+
+let discard_command_queue () =
+ with_lock q_lock (
+ fun () ->
+ Q.clear q;
+ (* Discard the currently running command too. *)
+ q_discard := true
+ )
+
+(*----------------------------------------------------------------------*)
+(* This is the slave thread. *)
+
+(* Run the callback unless someone set the q_discard flag while we
+ were running the command. This allows discard_command_queue () to
+ discard both the command queue and the running command (although
+ the running command is not interrupted). *)
+let callback_if_not_discarded (cb : 'a callback) (arg : 'a) =
+ let discard = with_lock q_lock (fun () -> !q_discard) in
+ if not discard then
+ GtkThread.async cb arg
+
+(* Set this to true to exit the thread. *)
+let quit = ref false
+
+(* Handles. These are not protected by locks because only the slave
+ * thread has access to them.
+ *)
+(*let conn = ref None*)
+let g = ref None
+
+(* Update the status bar. *)
+let status fs =
+ let f str = GtkThread.async !status_hook str in
+ ksprintf f fs
+
+let rec loop () =
+ debug "top of slave loop";
+
+ (* Get the next command. *)
+ let fail, cmd =
+ with_lock q_lock (
+ fun () ->
+ while Q.is_empty q do Cond.wait q_cond q_lock done;
+ q_discard := false;
+ Q.pop q
+ ) in
+
+ debug "slave processing command %s ..." (string_of_message cmd);
+
+ (try
+ GtkThread.async !busy_hook ();
+ execute_command cmd
+ with exn ->
+ (* If the user provided an override ?fail parameter to the
+ original call, call that, else call the global hook. *)
+ match fail with
+ | Some cb -> GtkThread.async cb exn
+ | None -> GtkThread.async !failure_hook exn
+ );
+
+ (* If there are no more commands in the queue, run the idle hook. *)
+ let empty = with_lock q_lock (fun () -> Q.is_empty q) in
+ if empty then GtkThread.async !idle_hook ();
+
+ if !quit then Thread.exit ();
+ loop ()
+
+and execute_command = function
+ | Exit_thread ->
+ quit := true;
+ close_all ()
+
+ | Open_images (images, cb) as cmd ->
+ status "Opening disk images ...";
+
+ open_disk_images images cb cmd
+
+(* Close all handles. *)
+and close_all () =
+(*
+ (match !conn with Some conn -> C.close conn | None -> ());
+ conn := None;
+*)
+ close_g ()
+
+and close_g () =
+ (match !g with Some g -> g#close () | None -> ());
+ g := None
+
+(* The common code for Open_domain and Open_images which opens the
+ * libguestfs handle, adds the disks, and launches the appliance.
+ *)
+and open_disk_images images cb cmd =
+ debug "opening disk image %s" (string_of_images images);
+
+ close_g ();
+ let g' = new G.guestfs () in
+ g := Some g';
+ let g = g' in
+
+ g#set_trace (trace ());
+
+ (* Attach progress bar callback. *)
+ ignore (
+ g#set_event_callback (
+ fun g event handle buf array ->
+ if event == G.EVENT_PROGRESS && Array.length array >= 4 then (
+ let proc_nr = array.(0)
+ and serial = array.(1)
+ and position = array.(2)
+ and total = array.(3) in
+ debug "progress callback proc_nr=%Ld serial=%Ld posn=%Ld total=%Ld"
+ proc_nr serial position total;
+ GtkThread.async !progress_hook (position, total)
+ )
+ ) [ G.EVENT_PROGRESS ]
+ );
+
+ List.iter (
+ function
+ | filename, None ->
+ g#add_drive_opts ~readonly:true filename
+ | filename, Some format ->
+ g#add_drive_opts ~readonly:true ~format filename
+ ) images;
+
+ g#launch ();
+
+ status "Listing filesystems ...";
+
+ (* Get list of filesystems. *)
+ let fses = g#list_filesystems () in
+
+ status "Looking for operating systems ...";
+
+ (* Perform inspection. This can fail, ignore errors. *)
+ let roots =
+ try Array.to_list (g#inspect_os ())
+ with
+ G.Error msg ->
+ debug "inspection failed (error ignored): %s" msg;
+ [] in
+
+ let oses = List.map (
+ fun root ->
+ let typ = g#inspect_get_type root in
+ let windows_current_control_set =
+ if typ <> "windows" then None
+ else (
+ try Some (g#inspect_get_windows_current_control_set root)
+ with G.Error _ -> None
+ ) in
+ let windows_systemroot =
+ if typ <> "windows" then None
+ else (
+ try Some (g#inspect_get_windows_systemroot root)
+ with G.Error _ -> None
+ ) in
+
+ {
+ insp_root = root;
+ insp_arch = g#inspect_get_arch root;
+ insp_distro = g#inspect_get_distro root;
+ insp_drive_mappings = g#inspect_get_drive_mappings root;
+ insp_filesystems = g#inspect_get_filesystems root;
+ insp_hostname = g#inspect_get_hostname root;
+ insp_major_version = g#inspect_get_major_version root;
+ insp_minor_version = g#inspect_get_minor_version root;
+ insp_mountpoints = g#inspect_get_mountpoints root;
+ insp_package_format = g#inspect_get_package_format root;
+ insp_package_management = g#inspect_get_package_management root;
+ insp_product_name = g#inspect_get_product_name root;
+ insp_product_variant = g#inspect_get_product_variant root;
+ insp_type = typ;
+ insp_windows_current_control_set = windows_current_control_set;
+ insp_windows_systemroot = windows_systemroot;
+ }
+ ) roots in
+
+ let data = {
+ insp_all_filesystems = fses;
+ insp_oses = oses;
+ } in
+
+ status "Finished opening disk";
+
+ callback_if_not_discarded cb data
+
+(*----------------------------------------------------------------------*)
+(* Start up one slave thread when the program starts. *)
+let slave_thread = Thread.create loop ()
+
+let exit_thread () =
+ discard_command_queue ();
+ send_message Exit_thread;
+ Thread.join slave_thread
--- /dev/null
+(* Virt-resize UI.
+ * Copyright (C) 2011 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.
+ *)
+
+(** The public interface to the slave thread. *)
+
+(** {2 Commands and callbacks}
+
+ Commands for libvirt and libguestfs are executed in a separate
+ slave thread. This file describes the interface with that thread
+ that the rest of the program sees.
+
+ Commands are intentionally as high level as possible. Often a
+ single command may perform many libvirt and libguestfs operations
+ before returing a result. This is to make use of the slave thread
+ as simple as possible.
+
+ Commands are executed in a "continuation-passing style" (CPS),
+ which means that you call a function to issue the command, passing
+ in a callback ("continuation"). The function returns immediately.
+ The callback may be called some time later once the issued command
+ completes successfully. Several commands can be queued up for
+ execution. Commands are executed and callbacks are performed in
+ sequence.
+
+ The callback returns the result of the command. The callback does
+ not get invoked if there was an error, or if the command was
+ cancelled before it runs (see {!discard_command_queue}). For some
+ commands the callback can be called multiple times (see
+ documentation below).
+*)
+
+type 'a callback = 'a -> unit
+(** A callback function in the main thread which is called when the
+ command finishes successfully.
+
+ This can also return some data (the ['a] parameter). A command
+ that returns a list of strings might have callback type [string
+ list callback], and a command that returns nothing would have
+ callback type [unit callback].
+
+ Note that errors are not returned this way. Each function can
+ optionally supply an extra callback to handle errors, or if
+ not supplied then it defaults to the failure hook set by
+ {!set_failure_hook}. *)
+
+val no_callback : 'a callback
+(** The main thread uses this as a callback if it doesn't care about
+ the return value from a command. *)
+
+type message =
+ (** {!b Do not use this directly}. Call {!Slave.exit_thread}
+ instead. *)
+ | Exit_thread
+
+ (** Open disk image(s). Return the guest inspection data. *)
+ | Open_images of (string * string option) list *
+ Slave_types.inspection_data callback
+
+val string_of_message : message -> string
+(** Useful debugging function to display a message. *)
+
+val send_message : ?fail:exn callback -> message -> unit
+(** Send a message to the slave thread.
+
+ Note as described above, this function returns immediately. A
+ callback (passed in the message) is called some time later if
+ the call succeeds, otherwise one of the failure methods
+ described above is used. *)
+
+val discard_command_queue : unit -> unit
+(** [discard_command_queue ()] discards any commands on the command
+ queue.
+
+ The currently running command cannot be discarded (because of
+ the design of libguestfs). Instead the callback is discarded,
+ so from the point of view of the main thread, the effect is
+ similar. *)
+
+val exit_thread : unit -> unit
+(** [exit_thread ()] causes the slave thread to exit, and returns
+ synchronously once the slave thread has exited. *)
+
+(** {2 Hooks}
+
+ Hooks are like callbacks, except they hook into special events
+ that happen in the slave thread, rather than just being a response
+ to commands.
+
+ The other difference is that hooks are global variables. You can
+ only set one hook of each type.
+
+ {!set_failure_hook} is used to catch errors in slave commands
+ and display those in the main thread.
+
+ {!set_busy_hook} and {!set_idle_hook} are used to implement a
+ "throbber".
+
+ {!set_progress_hook} is used to implement a progress bar. *)
+
+val set_failure_hook : exn callback -> unit
+(** Set the function in the main thread which is called if there is an
+ error in the slave thread. If this is not set then errors are
+ discarded. [exn] is the exception. *)
+
+val set_busy_hook : unit callback -> unit
+(** Set the function in the main thread which is called whenever
+ the slave thread starts working on a command. *)
+
+val set_idle_hook : unit callback -> unit
+(** Set the function in the main thread which is called whenever the
+ slave thread stops working on a command {i and} has no more
+ commands left in the queue to work on. *)
+
+val set_status_hook : string callback -> unit
+(** Set the function in the main thread which is called to
+ update the status bar. The slave thread updates the
+ status bar when an operation starts or stops, keeping the
+ user informed of what is happening. *)
+
+val set_progress_hook : (int64 * int64) callback -> unit
+(** Set the function in the main thread which is called whenever the
+ slave thread receives a progress notification message from
+ libguestfs. *)
--- /dev/null
+(* Virt-resize UI.
+ * Copyright (C) 2011 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 D = Libvirt.Domain
+module G = Guestfs
+
+(*
+type domain = {
+ dom_id : int;
+ dom_name : string;
+ dom_state : D.state;
+}
+*)
+
+type inspection_data = {
+ insp_all_filesystems : (string * string) list;
+ insp_oses : inspection_os list;
+}
+
+and inspection_os = {
+ insp_root : string;
+ insp_arch : string;
+ insp_distro : string;
+ insp_drive_mappings : (string * string) list;
+ insp_filesystems : string array;
+ insp_hostname : string;
+ insp_major_version : int;
+ insp_minor_version : int;
+ insp_mountpoints : (string * string) list;
+ insp_package_format : string;
+ insp_package_management : string;
+ insp_product_name : string;
+ insp_product_variant : string;
+ insp_type : string;
+ insp_windows_current_control_set : string option;
+ insp_windows_systemroot : string option;
+}
--- /dev/null
+(* Virt-resize UI.
+ * Copyright (C) 2011 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.
+ *)
+
+(** The types used by the slave thread. *)
+
+(*
+type domain = {
+ dom_id : int;
+ dom_name : string;
+ dom_state : Libvirt.Domain.state;
+}
+ (** List of domains as returned in the {!Slave.connect} callback. *)
+*)
+
+type inspection_data = {
+ insp_all_filesystems : (string * string) list;
+ (** see {!Guestfs.list_filesystems} *)
+ insp_oses : inspection_os list;
+ (** one entry per root (operating system), see {!Guestfs.inspect_os} *)
+}
+ (** The inspection data returned in the callback from
+ {!Slave.open_domain} and {!Slave.open_images}. *)
+
+and inspection_os = {
+ insp_root : string; (** see {!Guestfs.inspect_os} *)
+ insp_arch : string;
+ insp_distro : string;
+ insp_drive_mappings : (string * string) list;
+ insp_filesystems : string array;
+ insp_hostname : string;
+ insp_major_version : int;
+ insp_minor_version : int;
+ insp_mountpoints : (string * string) list;
+ insp_package_format : string;
+ insp_package_management : string;
+ insp_product_name : string;
+ insp_product_variant : string;
+ insp_type : string;
+ insp_windows_current_control_set : string option;
+ insp_windows_systemroot : string option;
+}
--- /dev/null
+(* Virt resize UI.
+ * Copyright (C) 2011 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 Slave_types
+open Utils
+
+type file_input = {
+ file_button : GButton.radio_button;
+ file_chooser : GFile.chooser_button;
+ file_format_raw : GButton.radio_button;
+ file_format_qcow2 : GButton.radio_button;
+ file_format_detect : GButton.radio_button;
+ file_open_button : GButton.button;
+}
+
+let file_input_set_sensitive t b =
+ t.file_chooser#misc#set_sensitive b;
+ t.file_format_raw#misc#set_sensitive b;
+ t.file_format_qcow2#misc#set_sensitive b;
+ t.file_format_detect#misc#set_sensitive b;
+ t.file_open_button#misc#set_sensitive b
+
+type libvirt_input = {
+ libvirt_button : GButton.radio_button;
+ libvirt_combo : GEdit.combo;
+}
+
+let libvirt_input_set_sensitive t b =
+ t.libvirt_combo#misc#set_sensitive b
+
+type inspection = {
+ inspection_label : GMisc.label;
+}
+
+class tab
+ (tbl : GPack.table) ready_signal not_ready_signal
+ file_input libvirt_input inspection =
+object (self)
+ inherit GObj.widget (tbl#as_widget)
+ inherit GUtil.ml_signals [ready_signal#disconnect;
+ not_ready_signal#disconnect]
+
+ (* Signals. *)
+ method ready : callback:(unit -> unit) -> GtkSignal.id =
+ ready_signal#connect ~after
+ method not_ready : callback:(unit -> unit) -> GtkSignal.id =
+ not_ready_signal#connect ~after
+
+ (* This method will be called back when disk image or guest is
+ opened. *)
+ method private opened inspection_data =
+ (* We expect that there are some filesystems in the image,
+ otherwise fail. *)
+ if inspection_data.insp_all_filesystems = [] then
+ inspection.inspection_label#set_text
+ "error: no filesystems were found in the selected disk image or guest"
+ else (
+ (match inspection_data.insp_oses with
+ | [] -> (* no OS, but there were filesystems *)
+ inspection.inspection_label#set_text
+ "warning: no operating systems were recognized in this disk image or guest"
+
+ | [ os ] ->
+ let label =
+ sprintf "%s %s %d.%d"
+ os.insp_type os.insp_distro
+ os.insp_major_version os.insp_minor_version in
+ let label =
+ if os.insp_product_name <> "" then
+ label ^ " (" ^ os.insp_product_name ^ ")"
+ else
+ label in
+ inspection.inspection_label#set_text label
+
+ | _ ->
+ inspection.inspection_label#set_text
+ "warning: resizing multi-boot virtual machines may not be successful"
+ );
+
+ (* Raise the ready signal. *)
+ ready_signal#call ()
+ )
+
+ initializer
+ (* Set the inputs to be sensitive according to the state of the
+ top level radio buttons. *)
+ let make_sensitive = function
+ | `FileInput ->
+ file_input_set_sensitive file_input true;
+ libvirt_input_set_sensitive libvirt_input false
+ | `LibvirtInput ->
+ file_input_set_sensitive file_input false;
+ libvirt_input_set_sensitive libvirt_input true
+ in
+
+ ignore (
+ file_input.file_button#connect#toggled ~callback:(
+ fun () ->
+ if file_input.file_button#active then
+ make_sensitive `FileInput
+ else
+ make_sensitive `LibvirtInput
+ )
+ );
+ ignore (
+ libvirt_input.libvirt_button#connect#toggled ~callback:(
+ fun () ->
+ if libvirt_input.libvirt_button#active then
+ make_sensitive `LibvirtInput
+ else
+ make_sensitive `FileInput
+ )
+ );
+
+ (* Default sensitivity. *)
+ make_sensitive `FileInput;
+
+ (* Wire up file dialog. *)
+ ignore (
+ file_input.file_open_button#connect#clicked ~callback:(
+ fun () ->
+ match file_input.file_chooser#filename with
+ | None -> () (* nothing selected yet *)
+ | Some filename -> (* filename selected *)
+ let format =
+ if file_input.file_format_raw#active then Some "raw"
+ else if file_input.file_format_qcow2#active then Some "qcow2"
+ else if file_input.file_format_detect#active then None
+ else assert false in (* shouldn't be possible??? *)
+ let msg = Slave.Open_images ([filename, format], self#opened) in
+ Slave.send_message msg
+ )
+ )
+
+end
+
+let tab () =
+ let tbl = GPack.table ~border_width:8 ~columns:2 ~rows:1 () in
+
+ (* Signals. *)
+ let ready_signal = new GUtil.signal () in
+ let not_ready_signal = new GUtil.signal () in
+
+ let file_input =
+ let button =
+ GButton.radio_button ~label:"File or device:"
+ ~packing:(tbl#attach ~top:0 ~left:0) () in
+ let chooser =
+ GFile.chooser_button ~action:`OPEN
+ ~packing:(tbl#attach ~top:0 ~left:1) () in
+ (* We have an "unnecessary" open button here for a couple of
+ reasons: Firstly because lablgtk2 doesn't bind the file-set
+ callback, so we can't tell when a file has been picked in the
+ file chooser. But secondly because it allows the user to pick
+ a file and the format before actually opening the file (which
+ could be an expensive operation). *)
+ let open_button =
+ GButton.button ~label:"Open"
+ ~packing:(tbl#attach ~top:0 ~left:2) () in
+ let raw = GButton.radio_button ~label:"raw"
+ ~packing:(tbl#attach ~top:1 ~left:1) () in
+ let group = raw#group in
+ let qcow2 = GButton.radio_button ~label:"qcow2" ~group
+ ~packing:(tbl#attach ~top:2 ~left:1) () in
+ let detect = GButton.radio_button ~label:"autodetect format"
+ ~group ~active:true
+ ~packing:(tbl#attach ~top:3 ~left:1) () in
+ { file_button = button; file_chooser = chooser;
+ file_format_raw = raw; file_format_qcow2 = qcow2;
+ file_format_detect = detect;
+ file_open_button = open_button } in
+
+ (* Add a dummy row as a spacer. *)
+ ignore (GMisc.label ~packing:(tbl#attach ~top:4 ~left:0) ());
+ tbl#set_row_spacing 4 16;
+
+ let libvirt_input =
+ let group = file_input.file_button#group in
+ let button =
+ GButton.radio_button ~label:"Guest:" ~group
+ ~packing:(tbl#attach ~top:5 ~left:0) () in
+ let combo =
+ GEdit.combo ~packing:(tbl#attach ~top:5 ~left:1) () in
+ { libvirt_button = button; libvirt_combo = combo } in
+
+ (* Add a dummy row as a spacer. *)
+ ignore (GMisc.label ~packing:(tbl#attach ~top:6 ~left:0) ());
+ tbl#set_row_spacing 6 16;
+
+ let inspection =
+ let label = GMisc.label ~packing:(tbl#attach ~top:7 ~left:0 ~right:2) () in
+ { inspection_label = label } in
+
+ (* Return the object. *)
+ new tab tbl ready_signal not_ready_signal
+ file_input libvirt_input inspection
--- /dev/null
+(* Virt resize UI.
+ * Copyright (C) 2011 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.
+ *)
+
+(** The Source_tab module handles the "Source" tab in the main window. *)
+
+type file_input
+type libvirt_input
+type inspection
+
+class tab : GPack.table -> unit GUtil.signal -> unit GUtil.signal ->
+ file_input -> libvirt_input -> inspection ->
+object ('a)
+ inherit GObj.widget
+
+ val obj : Gtk.widget Gtk.obj
+ method after : 'a
+ method disconnect : GtkSignal.id -> unit
+
+ (** Signal [not_ready] is raised when the source tab has missing
+ information. This is the initial state of the tab. *)
+ method not_ready : callback:(unit -> unit) -> GtkSignal.id
+
+ (** Signal [ready] is raised when the user has provided all the
+ information requested, and the source disk image or guest has
+ been opened successfully. *)
+ method ready : callback:(unit -> unit) -> GtkSignal.id
+end
+
+val tab : unit -> tab
--- /dev/null
+(* Virt-resize UI.
+ * Copyright (C) 2011 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 ExtString
+open ExtList
+
+open Printf
+
+let (+^) = Int64.add
+let (-^) = Int64.sub
+let ( *^ ) = Int64.mul
+let (/^) = Int64.div
+let (&^) = Int64.logand
+
+type ('a, 'b) either = Left of 'a | Right of 'b
+
+let verbose = ref false
+let set_verbose_flag () = verbose := true
+let verbose () = !verbose
+
+let debug fs =
+ let f str =
+ if verbose () then (
+ prerr_string Config.package;
+ prerr_string ": tid ";
+ prerr_string (string_of_int (Thread.id (Thread.self ())));
+ prerr_string ": ";
+ prerr_string str;
+ prerr_newline ()
+ )
+ in
+ ksprintf f fs
+
+let failwith fs =
+ let f str =
+ if verbose () then (prerr_string str; prerr_newline ());
+ raise (Failure str)
+ in
+ ksprintf f fs
+
+let trace = ref false
+let set_trace_flag () = trace := true
+let trace () = !trace
+
+let connect_uri = ref None
+let set_connect_uri conn = connect_uri := conn
+let connect_uri () = !connect_uri
+
+let utf8_copyright = "\194\169"
+let utf8_rarrow = "\xe2\x86\x92"
+
+let human_size i =
+ if i < 1024L then
+ sprintf "%Ld" i
+ else if i < 1024L *^ 1024L then
+ sprintf "%.1f KB" (Int64.to_float i /. 1024.)
+ else if i < 1024L *^ 1024L *^ 1024L then
+ sprintf "%.1f MB" (Int64.to_float i /. 1024. /. 1024.)
+ else if i < 1024L *^ 1024L *^ 1024L *^ 1024L then
+ sprintf "%.1f GB" (Int64.to_float i /. 1024. /. 1024. /. 1024.)
+ else
+ sprintf "%.1f TB" (Int64.to_float i /. 1024. /. 1024. /. 1024. /. 1024.)
+
+let human_size_1k i =
+ if i < 1024L then
+ sprintf "%Ld KB" i
+ else if i < 1024L *^ 1024L then
+ sprintf "%.1f MB" (Int64.to_float i /. 1024.)
+ else
+ sprintf "%.1f GB" (Int64.to_float i /. 1024. /. 1024.)
+
+let unique = let i = ref 0 in fun () -> incr i; !i
+
+let rec find_map f = function
+ | [] -> raise Not_found
+ | x :: xs ->
+ match f x with
+ | Some y -> y
+ | None -> find_map f xs
+
+(* g_markup_escape is not bound by lablgtk2, but we want to provide
+ * extra protection for \0 characters appearing in the string
+ * anyway.
+ *)
+let markup_escape name =
+ let f = function
+ | '&' -> "&" | '<' -> "<" | '>' -> ">"
+ | '\000' -> "\\0"
+ | c -> String.make 1 c
+ in
+ String.replace_chars f name
+
+let libguestfs_version_string () =
+ let g = new Guestfs.guestfs () in
+ let v = g#version () in
+ let s =
+ sprintf "%Ld.%Ld.%Ld%s"
+ v.Guestfs.major v.Guestfs.minor v.Guestfs.release v.Guestfs.extra in
+ g#close ();
+ s
+
+let libvirt_version_string () =
+ let v = fst (Libvirt.get_version ()) in
+ sprintf "%d.%d.%d" (v / 1_000_000) ((v / 1_000) mod 1_000) (v mod 1_000)
--- /dev/null
+(* Virt-resize UI.
+ * Copyright (C) 2011 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.
+ *)
+
+(** General-purpose utility code used everywhere. *)
+
+val (+^) : int64 -> int64 -> int64
+val (-^) : int64 -> int64 -> int64
+val ( *^ ) : int64 -> int64 -> int64
+val (/^) : int64 -> int64 -> int64
+val (&^) : int64 -> int64 -> int64
+ (** Int64 arithmetic operators. *)
+
+type ('a, 'b) either = Left of 'a | Right of 'b
+ (** A value which is either an ['a] or a ['b], just like Haskell's
+ "Either" type. *)
+
+val verbose : unit -> bool
+val set_verbose_flag : unit -> unit
+ (** If this contains [true] then {!debug} will send debugging
+ messages to stderr, else debugging messages are dropped.
+
+ This is set through the --verbose command line option. *)
+
+val debug : ('a, unit, string, unit) format4 -> 'a
+ (** A printf-like function for writing debugging messages. *)
+
+val failwith : ('a, unit, string, 'b) format4 -> 'a
+ (** Replacement for standard OCaml [failwith] function. This can
+ take a printf-like argument list, and also logs errors on stderr
+ when verbose is enabled. *)
+
+val trace : unit -> bool
+val set_trace_flag : unit -> unit
+ (** If this contains [true] then calls to libguestfs are traced.
+
+ This is set through the [-x] command line option. *)
+
+val connect_uri : unit -> string option
+val set_connect_uri : string option -> unit
+ (** The libvirt connection URI.
+
+ This is set through the [--connect] command line option. *)
+
+val utf8_copyright : string (** UTF-8 copyright symbol *)
+val utf8_rarrow : string (** UTF-8 RIGHTWARDS ARROW *)
+
+val human_size : int64 -> string
+ (** Convert a number of bytes into a human readable string. *)
+
+val human_size_1k : int64 -> string
+ (** Same as {!human_size} but the argument is 1KB blocks (used for
+ disk usage). *)
+
+val unique : unit -> int
+ (** Return a new integer each time called. *)
+
+val find_map : ('a -> 'b option) -> 'a list -> 'b
+ (** [find_map f xs] calls function [f] on each member of [xs] in order.
+ If [f] returns [Some b] then we stop and return [b]. If all calls
+ to [f] return [None] then this raises [Not_found]. *)
+
+val markup_escape : string -> string
+ (** Like g_markup_escape but with extra protection for strings
+ containing \0 characters. *)
+
+val libguestfs_version_string : unit -> string
+ (** Return the version of libguestfs as a string. *)
+
+val libvirt_version_string : unit -> string
+ (** Return the version of libvirt as a string. *)
--- /dev/null
+=encoding utf8
+
+=head1 NAME
+
+virt-resize-ui - Graphical interface for virt-resize
+
+=head1 SYNOPSIS
+
+ virt-resize-ui [--options]
+
+=head1 DESCRIPTION
+
+C<virt-resize-ui> is a graphical interface for the command line
+L<virt-resize(1)> program. It enables many of the features of
+C<virt-resize> through a guided, interactive interface.
+
+In most cases you can just run C<virt-resize-ui> and follow the
+questions.
+
+C<virt-resize-ui> does not I<need> to run as root, but it may have to
+access disk images that can only be read or created as root (for
+example to read virtual machines or do C<lvcreate>). If you only want
+to resize disk images stored as files in your home directory then root
+is not needed.
+
+=head1 OPTIONS
+
+=over 4
+
+=item B<-a>
+
+=item B<--add>
+
+Add I<file> which should be a disk image. You can supply multiple
+disk images by repeating this option.
+
+The format of the disk image is auto-detected. To override this and
+force a particular format use the I<--format=..> option.
+
+=item B<-c> URI
+
+=item B<--connect> URI
+
+If using libvirt, connect to the given I<URI>. If omitted, then we
+connect to the default libvirt hypervisor.
+
+If you specify guest block devices directly (I<-a>), then libvirt is
+not used at all.
+
+=item B<-d> guest
+
+=item B<--domain> guest
+
+Add all the disks from the named libvirt guest.
+
+=item B<--format raw>
+
+=item B<--format qcow2>
+
+=item B<--format "">
+
+The default for the I<-a> option is to auto-detect the format of the
+disk image. Using this forces the disk format for I<-a> options which
+follow on the command line. Using I<--format ""> (an empty string
+argument) switches back to auto-detection for subsequent I<-a>
+options.
+
+For example:
+
+ virt-resize-ui --format raw -a disk.img
+
+forces raw format (no auto-detection) for C<disk.img>.
+
+ virt-resize-ui --format raw -a disk.img --format "" -a another.img
+
+forces raw format (no auto-detection) for C<disk.img> and reverts to
+auto-detection for C<another.img>.
+
+If you have untrusted raw-format guest disk images, you should use
+this option to specify the disk format. This avoids a possible
+security problem with malicious guests (CVE-2010-3851).
+
+=item B<-v>
+
+=item B<--verbose>
+
+Enable verbose messages for debugging.
+
+=item B<-V>
+
+=item B<--version>
+
+Display version number and exit.
+
+=item B<-x>
+
+Enable tracing of libguestfs API calls.
+
+=back
+
+=head1 SEE ALSO
+
+L<virt-resize(1)>,
+L<guestfs(3)>,
+L<guestfish(1)>,
+L<virt-rescue(1)>,
+L<http://libguestfs.org/>.
+
+=head1 AUTHOR
+
+Richard W.M. Jones L<http://people.redhat.com/~rjones/>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2011 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., 675 Mass Ave, Cambridge, MA 02139, USA.
--- /dev/null
+(* Virt resize UI.
+ * Copyright (C) 2011 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+type file_menu = {
+ quit_item : GMenu.menu_item;
+}
+
+type help_menu = {
+ about_item : GMenu.menu_item;
+}
+
+type tabs = {
+ source_tab : Source_tab.tab;
+ destination_tab : Destination_tab.tab;
+ partitions_tab : Partitions_tab.tab;
+ logvols_tab : Logvols_tab.tab;
+}
+
+type buttons = {
+ prev_button : GButton.button;
+ next_button : GButton.button;
+ go_button : GButton.button;
+ exit_button : GButton.button;
+}
+
+class window =
+ let title = "Resize a virtual machine - virt-resize-ui" in
+object (self)
+ initializer
+ (* Window. *)
+ let window = GWindow.window ~width:700 ~height:700 ~title () in
+ let vbox = GPack.vbox ~packing:window#add () in
+
+ (* Menus. *)
+ let menubar = GMenu.menu_bar ~packing:vbox#pack () in
+ let factory = new GMenu.factory menubar in
+ let accel_group = factory#accel_group in
+
+ let file_menu =
+ let menu = factory#add_submenu "_File" in
+ let factory = new GMenu.factory menu ~accel_group in
+ let quit = factory#add_item "E_xit" ~key:GdkKeysyms._Q in
+ { quit_item = quit } in
+
+ let help_menu =
+ let menu = factory#add_submenu "_Help" in
+ let factory = new GMenu.factory menu ~accel_group in
+ let about = factory#add_item "About virt-resize-ui ..." in
+ { about_item = about } in
+
+ (* Tabbed notebook for main part of the display. *)
+ let tabs =
+ let nb = GPack.notebook ~packing:(vbox#pack ~expand:true ~fill:true) () in
+
+ let src = Source_tab.tab () in
+ let tab_label = (GMisc.label ~text:"Source" () :> GObj.widget) in
+ ignore (nb#append_page ~tab_label (src :> GObj.widget));
+
+ let dest = Destination_tab.tab () in
+ let tab_label = (GMisc.label ~text:"Destination" () :> GObj.widget) in
+ ignore (nb#append_page ~tab_label (dest :> GObj.widget));
+
+ let parts = Partitions_tab.tab () in
+ let tab_label =
+ (GMisc.label ~text:"Resize partitions" () :> GObj.widget) in
+ ignore (nb#append_page ~tab_label (parts :> GObj.widget));
+
+ let lvs = Logvols_tab.tab () in
+ let tab_label =
+ (GMisc.label ~text:"Expand logical volumes" () :> GObj.widget) in
+ ignore (nb#append_page ~tab_label (lvs :> GObj.widget));
+
+ { source_tab = src; destination_tab = dest;
+ partitions_tab = parts; logvols_tab = lvs } in
+
+ (* Buttons. *)
+ let buttons =
+ let bbox = GPack.button_box `HORIZONTAL ~packing:vbox#pack () in
+ bbox#set_border_width 8;
+
+ let ex = GButton.button ~stock:`QUIT ~packing:bbox#pack () in
+ ex#misc#set_sensitive true;
+ let prev = GButton.button ~stock:`GO_BACK ~packing:bbox#pack () in
+ prev#misc#set_sensitive false;
+ let next = GButton.button ~stock:`GO_FORWARD ~packing:bbox#pack () in
+ next#misc#set_sensitive true;
+ let go = GButton.button ~stock:`APPLY ~packing:bbox#pack () in
+ go#misc#set_sensitive false;
+ { prev_button = prev; next_button = next; go_button = go;
+ exit_button = ex } in
+
+ ignore help_menu;
+ ignore tabs;
+
+ (* Quit button. *)
+ let quit _ = GMain.quit (); false in
+ ignore (window#connect#destroy ~callback:GMain.quit);
+ ignore (window#event#connect#delete ~callback:quit);
+ ignore (file_menu.quit_item#connect#activate
+ ~callback:(fun () -> ignore (quit ()); ()));
+ ignore (buttons.exit_button#connect#clicked
+ ~callback:(fun () -> ignore (quit ()); ()));
+
+ (* Accel_group. *)
+ window#add_accel_group accel_group;
+
+ window#show ()
+end
--- /dev/null
+(* Virt resize UI.
+ * Copyright (C) 2011 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.
+ *)
+
+(** The Window module handles the main window and menus. *)
+
+class window :
+object
+ (* empty, for now *)
+end
git.annexia.org / virt-resize-ui.git / commitdiff