diff options
54 files changed, 1 insertions, 13728 deletions
@@ -6,31 +6,11 @@ config.sub configure.ac COPYING COPYING.LIB -examples/.depend -examples/list_domains.ml -examples/node_info.ml -examples/Makefile.in .hgignore install-sh -libvirt/.depend -libvirt/generator.pl -libvirt/libvirt_c.c -libvirt/libvirt_c_epilogue.c -libvirt/libvirt_c_oneoffs.c -libvirt/libvirt_c_prologue.c -libvirt/libvirt.ml -libvirt/libvirt.mli -libvirt/libvirt_version.ml.in -libvirt/libvirt_version.mli -libvirt/Makefile.in -libvirt/README Makefile.in Make.rules.in MANIFEST -META.in -mlvirsh/.depend -mlvirsh/Makefile.in -mlvirsh/mlvirsh.ml po/ja.po po/LINGUAS po/Makefile.in @@ -38,47 +18,7 @@ po/pl.po po/POTFILES po/virt-top.pot README -TODO.libvirt TODO.virt-top -virt-ctrl/.depend -virt-ctrl/Makefile.in -virt-ctrl/mingw-gcc-wrapper.ml -virt-ctrl/rebuild-icons.sh -virt-ctrl/vc_connection_dlg.ml -virt-ctrl/vc_connection_dlg.mli -virt-ctrl/vc_connections.ml -virt-ctrl/vc_connections.mli -virt-ctrl/vc_dbus.ml -virt-ctrl/vc_dbus.mli -virt-ctrl/vc_domain_ops.ml -virt-ctrl/vc_domain_ops.mli -virt-ctrl/vc_helpers.ml -virt-ctrl/vc_helpers.mli -virt-ctrl/vc_icons.ml -virt-ctrl/vc_mainwindow.ml -virt-ctrl/vc_mainwindow.mli -virt-ctrl/virt_ctrl.ml -virt-df/.depend -virt-df/Makefile.in -virt-df/README -virt-df/virt-df.1 -virt-df/virt-df.pod -virt-df/virt-df.txt -virt-df/virt_df.ml -virt-df/virt_df.mli -virt-df/virt_df_ext2.ml -virt-df/virt_df_ext2.mli -virt-df/virt_df_linux_swap.ml -virt-df/virt_df_linux_swap.mli -virt-df/virt_df_lvm2_lexer.mll -virt-df/virt_df_lvm2_metadata.ml -virt-df/virt_df_lvm2_metadata.mli -virt-df/virt_df_lvm2.ml -virt-df/virt_df_lvm2.mli -virt-df/virt_df_lvm2_parser.mly -virt-df/virt_df_main.ml -virt-df/virt_df_mbr.ml -virt-df/virt_df_mbr.mli virt-top/.depend virt-top/Makefile.in virt-top/README @@ -95,4 +35,4 @@ virt-top/virt_top_utils.ml virt-top/virt_top_utils.mli virt-top/virt_top_xml.ml wininstaller.nsis.in -winlicense.rtf
\ No newline at end of file +winlicense.rtf diff --git a/examples/Makefile.in b/examples/Makefile.in deleted file mode 100644 index 75a98eb..0000000 --- a/examples/Makefile.in +++ /dev/null @@ -1,90 +0,0 @@ -# ocaml-libvirt -# Copyright (C) 2007 Red Hat Inc., Richard W.M. Jones -# -# This library is free software; you can redistribute it and/or -# modify it under the terms of the GNU Lesser General Public -# License as published by the Free Software Foundation; either -# version 2 of the License, or (at your option) any later version. -# -# This library is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# Lesser General Public License for more details. -# -# You should have received a copy of the GNU Lesser General Public -# License along with this library; if not, write to the Free Software -# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -OCAMLFIND = @OCAMLFIND@ - -ifneq ($(OCAMLFIND),) -OCAMLCPACKAGES := -package unix -I ../libvirt -OCAMLCFLAGS := -g -OCAMLCLIBS := -linkpkg -OCAMLOPTPACKAGES := $(OCAMLCPACKAGES) -OCAMLOPTFLAGS := -OCAMLOPTLIBS := $(OCAMLCLIBS) -else -OCAMLCINCS := -I ../libvirt -OCAMLCFLAGS := -g -OCAMLCLIBS := unix.cma -OCAMLOPTINCS := $(OCAMLCINCS) -OCAMLOPTFLAGS := -OCAMLOPTLIBS := unix.cmxa -endif - -export LIBRARY_PATH=../libvirt -export LD_LIBRARY_PATH=../libvirt - -BYTE_TARGETS := list_domains node_info -OPT_TARGETS := list_domains.opt node_info.opt - -all: $(BYTE_TARGETS) - -opt: $(OPT_TARGETS) - -ifneq ($(OCAMLFIND),) -list_domains: list_domains.cmo - $(OCAMLFIND) ocamlc \ - $(OCAMLCPACKAGES) $(OCAMLCFLAGS) $(OCAMLCLIBS) \ - ../libvirt/mllibvirt.cma -o $@ $< - -list_domains.opt: list_domains.cmx - $(OCAMLFIND) ocamlopt \ - $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \ - ../libvirt/mllibvirt.cmxa -o $@ $< - -node_info: node_info.cmo - $(OCAMLFIND) ocamlc \ - $(OCAMLCPACKAGES) $(OCAMLCFLAGS) $(OCAMLCLIBS) \ - ../libvirt/mllibvirt.cma -o $@ $< - -node_info.opt: node_info.cmx - $(OCAMLFIND) ocamlopt \ - $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \ - ../libvirt/mllibvirt.cmxa -o $@ $< -else -list_domains: list_domains.cmo - $(OCAMLC) \ - $(OCAMLCINCS) $(OCAMLCFLAGS) $(OCAMLCLIBS) \ - ../libvirt/mllibvirt.cma -o $@ $< - -list_domains.opt: list_domains.cmx - $(OCAMLOPT) \ - $(OCAMLOPTINCS) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \ - ../libvirt/mllibvirt.cmxa -o $@ $< - -node_info: node_info.cmo - $(OCAMLC) \ - $(OCAMLCINCS) $(OCAMLCFLAGS) $(OCAMLCLIBS) \ - ../libvirt/mllibvirt.cma -o $@ $< - -node_info.opt: node_info.cmx - $(OCAMLOPT) \ - $(OCAMLOPTINCS) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \ - ../libvirt/mllibvirt.cmxa -o $@ $< -endif - -install: - -include ../Make.rules diff --git a/examples/list_domains.ml b/examples/list_domains.ml deleted file mode 100644 index c97432c..0000000 --- a/examples/list_domains.ml +++ /dev/null @@ -1,46 +0,0 @@ -(* Simple demo program showing how to list out domains. - Usage: list_domains [URI] - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - *) - -open Printf - -module C = Libvirt.Connect -module D = Libvirt.Domain -module N = Libvirt.Network - -let () = - try - let name = - if Array.length Sys.argv >= 2 then - Some (Sys.argv.(1)) - else - None in - let conn = C.connect_readonly ?name () in - - (* List running domains. *) - let n = C.num_of_domains conn in - let ids = C.list_domains conn n in - let domains = Array.map (D.lookup_by_id conn) ids in - Array.iter ( - fun dom -> - printf "%8d %s\n%!" (D.get_id dom) (D.get_name dom) - ) domains; - - (* List inactive domains. *) - let n = C.num_of_defined_domains conn in - let names = C.list_defined_domains conn n in - Array.iter ( - fun name -> - printf "inactive %s\n%!" name - ) names; - with - Libvirt.Virterror err -> - eprintf "error: %s\n" (Libvirt.Virterror.to_string err) - -let () = - (* Run the garbage collector which is a good way to check for - * memory corruption errors and reference counting issues in libvirt. - *) - Gc.compact () diff --git a/examples/node_info.ml b/examples/node_info.ml deleted file mode 100644 index c52615e..0000000 --- a/examples/node_info.ml +++ /dev/null @@ -1,48 +0,0 @@ -(* Simple demo program showing node info. - Usage: node_info [URI] - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - *) - -open Printf - -module C = Libvirt.Connect - -let () = - try - let name = - if Array.length Sys.argv >= 2 then - Some (Sys.argv.(1)) - else - None in - let conn = C.connect_readonly ?name () in - - (* Get node_info, hostname, etc. *) - let node_info = C.get_node_info conn in - - printf "model = %s\n" node_info.C.model; - printf "memory = %Ld K\n" node_info.C.memory; - printf "cpus = %d\n" node_info.C.cpus; - printf "mhz = %d\n" node_info.C.mhz; - printf "nodes = %d\n" node_info.C.nodes; - printf "sockets = %d\n" node_info.C.sockets; - printf "cores = %d\n" node_info.C.cores; - printf "threads = %d\n%!" node_info.C.threads; - - let hostname = C.get_hostname conn in - - printf "hostname = %s\n%!" hostname; - - let uri = C.get_uri conn in - - printf "uri = %s\n%!" uri - - with - Libvirt.Virterror err -> - eprintf "error: %s\n" (Libvirt.Virterror.to_string err) - -let () = - (* Run the garbage collector which is a good way to check for - * memory corruption errors and reference counting issues in libvirt. - *) - Gc.compact () diff --git a/libvirt/Makefile.in b/libvirt/Makefile.in deleted file mode 100644 index 66ffc75..0000000 --- a/libvirt/Makefile.in +++ /dev/null @@ -1,126 +0,0 @@ -# ocaml-libvirt -# Copyright (C) 2007 Red Hat Inc., Richard W.M. Jones -# -# This library is free software; you can redistribute it and/or -# modify it under the terms of the GNU Lesser General Public -# License as published by the Free Software Foundation; either -# version 2 of the License, or (at your option) any later version. -# -# This library is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# Lesser General Public License for more details. -# -# You should have received a copy of the GNU Lesser General Public -# License along with this library; if not, write to the Free Software -# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -WIN32 = @WIN32@ - -CFLAGS = @CFLAGS@ \ - -I.. \ - -I"$(shell ocamlc -where)" \ - @DEBUG@ @WARNINGS@ @CFLAGS_FPIC@ -LDFLAGS = @LDFLAGS@ -# -L"$(shell ocamlc -where)" - -OCAMLC = @OCAMLC@ -OCAMLOPT = @OCAMLOPT@ -OCAMLFIND = @OCAMLFIND@ -OCAMLMKLIB = @OCAMLMKLIB@ - -ifneq ($(OCAMLFIND),) -OCAMLCPACKAGES := -package unix -OCAMLCFLAGS := -g -OCAMLCLIBS := -linkpkg -else -OCAMLCINCS := -OCAMLCFLAGS := -g -OCAMLCLIBS := unix.cma -endif - -OCAMLOPTFLAGS := -ifneq ($(OCAMLFIND),) -OCAMLOPTPACKAGES := $(OCAMLCPACKAGES) -OCAMLOPTLIBS := $(OCAMLCLIBS) -else -OCAMLOPTINCS := $(OCAMLCINCS) -OCAMLOPTLIBS := unix.cmxa -endif - -export LIBRARY_PATH=. -export LD_LIBRARY_PATH=. - -BYTE_TARGETS := mllibvirt.cma -OPT_TARGETS := mllibvirt.cmxa - -all: $(BYTE_TARGETS) - -opt: $(OPT_TARGETS) - -COBJS := libvirt.cmo libvirt_version.cmo -OPTOBJS := libvirt.cmx libvirt_version.cmx - -ifneq ($(OCAMLMKLIB),) -# Good, we can just use ocamlmklib -mllibvirt.cma: libvirt_c.o $(COBJS) - $(OCAMLMKLIB) -o mllibvirt $^ $(LDFLAGS) -lvirt - -mllibvirt.cmxa: libvirt_c.o $(OPTOBJS) - $(OCAMLMKLIB) -o mllibvirt $^ $(LDFLAGS) -lvirt - -else -ifeq ($(WIN32),yes) -# Ugh, MinGW doesn't have ocamlmklib. This technique is copied from the -# example in OCaml distribution, otherlibs/win32unix/Makefile.nt - -mllibvirt.cma: dllmllibvirt.dll libmllibvirt.a $(COBJS) - $(OCAMLC) -a -linkall -o $@ $(COBJS) \ - -dllib -lmllibvirt -cclib -lmllibvirt -cclib "$(LDFLAGS) -lvirt" - -mllibvirt.cmxa: libmllibvirt.a $(OPTOBJS) - $(OCAMLOPT) -a -linkall -o $@ $(OPTOBJS) \ - -cclib -lmllibvirt -cclib "$(LDFLAGS) -lvirt" - -dllmllibvirt.dll: libvirt_c.o - $(CC) -shared -o $@ $^ \ - $(LDFLAGS) "$(shell ocamlc -where)"/ocamlrun.a -lvirt - -libmllibvirt.a: libvirt_c.o - ar rc $@ $^ - ranlib $@ - -else -# Don't know how to build a library on this platform. -$(BYTE_TARGETS) $(OPT_TARGETS): - echo "Error: ocamlmklib missing, and no known way to build libraries on this platform" - exit 1 -endif -endif - -# Automatically generate the C code from a Perl script 'generator.pl'. -libvirt_c.c: generator.pl - perl -w $< - -# Status of automatically generated bindings. -autostatus: libvirt_c.c - @echo -n "Functions which have manual bindings: " - @grep ^ocaml_libvirt_ libvirt_c_oneoffs.c | wc -l - @echo -n "Functions which have automatic bindings: " - @grep ^ocaml_libvirt_ libvirt_c.c | wc -l - @echo -n "LOC in manual bindings: " - @wc -l < libvirt_c_oneoffs.c - @echo -n "LOC in automatic bindings: " - @wc -l < libvirt_c.c - -libvirt.cmo: libvirt.cmi -libvirt.cmi: libvirt.mli - -libvirt_version.cmo: libvirt_version.cmi -libvirt_version.cmi: libvirt_version.mli - -install: - ocamlfind install libvirt \ - ../META *.so *.a *.cmx *.cma *.cmxa *.cmi *.mli - -include ../Make.rules diff --git a/libvirt/README b/libvirt/README deleted file mode 100644 index be8300d..0000000 --- a/libvirt/README +++ /dev/null @@ -1,49 +0,0 @@ -README -====== - -The public interface is described in 'libvirt.mli'. You may prefer to -do 'make doc' at the top level source directory and then read the HTML -documentation starting at html/index.html. - -'libvirt.ml' describes how OCaml functions map to C functions. - -'libvirt_c*.c' are the C functions which map OCaml objects to C -objects and vice versa (see next section). - -Generated code --------------- - -The C bindings in 'libvirt_c.c' are now generated automatically by a -Perl script called 'generator.pl'. You do not normally need to run -this script, but you may need to if you want to extend libvirt -coverage. - -The majority of the functions are now generated automatically, but -there are a few one-off bindings (eg. one-of-a-type functions, -functions with particularly complex mappings). Our eventual aim to is -autogenerate as much as possible. Use 'make autostatus' in this -directory to find out how we're doing. - -The generated 'libvirt_c.c' #includes some other C files in this -directory: - - #include "libvirt_c_prologue.c" - - A prologue that prototypes some static functions which are defined - in the epilogue (see below), and provides some general macros. - - #include "libvirt_c_oneoffs.c" - - One-off bindings: Bindings which are too specialised or one-of-a-kind - to be worth generating automatically. - - [Followed by generated bindings, then ...] - - #include "libvirt_c_epilogue.c" - - An epilogue which defines some standard static functions (eg.) for - wrapping and unwrapping libvirt objects. - -The key to understanding the generator is to look at the generated -code (libvirt_c.c) first, and go from there back to parts of the -generator script. diff --git a/libvirt/generator.pl b/libvirt/generator.pl deleted file mode 100755 index 4fbace6..0000000 --- a/libvirt/generator.pl +++ /dev/null @@ -1,1018 +0,0 @@ -#!/usr/bin/perl -w -# -# OCaml bindings for libvirt. -# (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc. -# http://libvirt.org/ -# -# This library is free software; you can redistribute it and/or -# modify it under the terms of the GNU Lesser General Public -# License as published by the Free Software Foundation; either -# version 2 of the License, or (at your option) any later version. -# -# This library is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -# Lesser General Public License for more details. -# -# You should have received a copy of the GNU Lesser General Public -# License along with this library; if not, write to the Free Software -# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -# This generates libvirt_c.c (the core of the bindings). You don't -# need to run this program unless you are extending the bindings -# themselves (eg. because libvirt has been extended). -# -# Please read libvirt/README. - -use strict; - -#---------------------------------------------------------------------- - -# The functions in the libvirt API that we can generate. - -# The 'sig' (signature) doesn't have a meaning or any internal structure. -# It is interpreted by the generation functions below to indicate what -# "class" the function falls into, and to generate the right class of -# binding. -# -# Any function added since libvirt 0.2.1 must be marked weak. - -my @functions = ( - { name => "virConnectClose", sig => "conn : free" }, - { name => "virConnectGetHostname", sig => "conn : string", weak => 1 }, - { name => "virConnectGetURI", sig => "conn : string", weak => 1 }, - { name => "virConnectGetType", sig => "conn : static string" }, - { name => "virConnectNumOfDomains", sig => "conn : int" }, - { name => "virConnectListDomains", sig => "conn, int : int array" }, - { name => "virConnectNumOfDefinedDomains", sig => "conn : int" }, - { name => "virConnectListDefinedDomains", - sig => "conn, int : string array" }, - { name => "virConnectNumOfNetworks", sig => "conn : int" }, - { name => "virConnectListNetworks", sig => "conn, int : string array" }, - { name => "virConnectNumOfDefinedNetworks", sig => "conn : int" }, - { name => "virConnectListDefinedNetworks", - sig => "conn, int : string array" }, - { name => "virConnectNumOfStoragePools", sig => "conn : int", weak => 1 }, - { name => "virConnectListStoragePools", - sig => "conn, int : string array", weak => 1 }, - { name => "virConnectNumOfDefinedStoragePools", - sig => "conn : int", weak => 1 }, - { name => "virConnectListDefinedStoragePools", - sig => "conn, int : string array", weak => 1 }, - { name => "virConnectGetCapabilities", sig => "conn : string" }, - - { name => "virDomainCreateLinux", sig => "conn, string, 0U : dom" }, - { name => "virDomainCreateLinuxJob", - sig => "conn, string, 0U : job", weak => 1 }, - { name => "virDomainFree", sig => "dom : free" }, - { name => "virDomainDestroy", sig => "dom : free" }, - { name => "virDomainLookupByName", sig => "conn, string : dom" }, - { name => "virDomainLookupByID", sig => "conn, int : dom" }, - { name => "virDomainLookupByUUID", sig => "conn, uuid : dom" }, - { name => "virDomainLookupByUUIDString", sig => "conn, string : dom" }, - { name => "virDomainGetName", sig => "dom : static string" }, - { name => "virDomainGetOSType", sig => "dom : string" }, - { name => "virDomainGetXMLDesc", sig => "dom, 0 : string" }, - { name => "virDomainGetUUID", sig => "dom : uuid" }, - { name => "virDomainGetUUIDString", sig => "dom : uuid string" }, - { name => "virDomainGetMaxVcpus", sig => "dom : int" }, - { name => "virDomainSave", sig => "dom, string : unit" }, - { name => "virDomainSaveJob", - sig => "dom, string : job from dom", weak => 1 }, - { name => "virDomainRestore", sig => "conn, string : unit" }, - { name => "virDomainRestoreJob", - sig => "conn, string : job", weak => 1 }, - { name => "virDomainCoreDump", sig => "dom, string, 0 : unit" }, - { name => "virDomainCoreDumpJob", - sig => "dom, string, 0 : job from dom", weak => 1 }, - { name => "virDomainSuspend", sig => "dom : unit" }, - { name => "virDomainResume", sig => "dom : unit" }, - { name => "virDomainShutdown", sig => "dom : unit" }, - { name => "virDomainReboot", sig => "dom, 0 : unit" }, - { name => "virDomainDefineXML", sig => "conn, string : dom" }, - { name => "virDomainUndefine", sig => "dom : unit" }, - { name => "virDomainCreate", sig => "dom : unit" }, - { name => "virDomainCreateJob", - sig => "dom, 0U : job from dom", weak => 1 }, - { name => "virDomainAttachDevice", sig => "dom, string : unit" }, - { name => "virDomainDetachDevice", sig => "dom, string : unit" }, - { name => "virDomainGetAutostart", sig => "dom : bool" }, - { name => "virDomainSetAutostart", sig => "dom, bool : unit" }, - - { name => "virNetworkFree", sig => "net : free" }, - { name => "virNetworkDestroy", sig => "net : free" }, - { name => "virNetworkLookupByName", sig => "conn, string : net" }, - { name => "virNetworkLookupByUUID", sig => "conn, uuid : net" }, - { name => "virNetworkLookupByUUIDString", sig => "conn, string : net" }, - { name => "virNetworkGetName", sig => "net : static string" }, - { name => "virNetworkGetXMLDesc", sig => "net, 0 : string" }, - { name => "virNetworkGetBridgeName", sig => "net : string" }, - { name => "virNetworkGetUUID", sig => "net : uuid" }, - { name => "virNetworkGetUUIDString", sig => "net : uuid string" }, - { name => "virNetworkUndefine", sig => "net : unit" }, - { name => "virNetworkCreateXML", sig => "conn, string : net" }, - { name => "virNetworkCreateXMLJob", - sig => "conn, string : job", weak => 1 }, - { name => "virNetworkDefineXML", sig => "conn, string : net" }, - { name => "virNetworkCreate", sig => "net : unit" }, - { name => "virNetworkCreateJob", - sig => "net : job from net", weak => 1 }, - { name => "virNetworkGetAutostart", sig => "net : bool" }, - { name => "virNetworkSetAutostart", sig => "net, bool : unit" }, - - { name => "virStoragePoolFree", sig => "pool : free", weak => 1 }, - { name => "virStoragePoolDestroy", sig => "pool : free", weak => 1 }, - { name => "virStoragePoolLookupByName", - sig => "conn, string : pool", weak => 1 }, - { name => "virStoragePoolLookupByUUID", - sig => "conn, uuid : pool", weak => 1 }, - { name => "virStoragePoolLookupByUUIDString", - sig => "conn, string : pool", weak => 1 }, - { name => "virStoragePoolGetName", - sig => "pool : static string", weak => 1 }, - { name => "virStoragePoolGetXMLDesc", - sig => "pool, 0U : string", weak => 1 }, - { name => "virStoragePoolGetUUID", - sig => "pool : uuid", weak => 1 }, - { name => "virStoragePoolGetUUIDString", - sig => "pool : uuid string", weak => 1 }, - { name => "virStoragePoolCreateXML", - sig => "conn, string, 0U : pool", weak => 1 }, - { name => "virStoragePoolDefineXML", - sig => "conn, string, 0U : pool", weak => 1 }, - { name => "virStoragePoolBuild", - sig => "pool, uint : unit", weak => 1 }, - { name => "virStoragePoolUndefine", - sig => "pool : unit", weak => 1 }, - { name => "virStoragePoolCreate", - sig => "pool, 0U : unit", weak => 1 }, - { name => "virStoragePoolDelete", - sig => "pool, uint : unit", weak => 1 }, - { name => "virStoragePoolRefresh", - sig => "pool, 0U : unit", weak => 1 }, - { name => "virStoragePoolGetAutostart", - sig => "pool : bool", weak => 1 }, - { name => "virStoragePoolSetAutostart", - sig => "pool, bool : unit", weak => 1 }, - { name => "virStoragePoolNumOfVolumes", - sig => "pool : int", weak => 1 }, - { name => "virStoragePoolListVolumes", - sig => "pool, int : string array", weak => 1 }, - - { name => "virStorageVolFree", sig => "vol : free", weak => 1 }, - { name => "virStorageVolDelete", - sig => "vol, uint : unit", weak => 1 }, - { name => "virStorageVolLookupByName", - sig => "pool, string : vol from pool", weak => 1 }, - { name => "virStorageVolLookupByKey", - sig => "conn, string : vol", weak => 1 }, - { name => "virStorageVolLookupByPath", - sig => "conn, string : vol", weak => 1 }, - { name => "virStorageVolCreateXML", - sig => "pool, string, 0U : vol from pool", weak => 1 }, - { name => "virStorageVolGetXMLDesc", - sig => "vol, 0U : string", weak => 1 }, - { name => "virStorageVolGetPath", - sig => "vol : string", weak => 1 }, - { name => "virStorageVolGetKey", - sig => "vol : static string", weak => 1 }, - { name => "virStorageVolGetName", - sig => "vol : static string", weak => 1 }, - { name => "virStoragePoolLookupByVolume", - sig => "vol : pool from vol", weak => 1 }, - - { name => "virJobFree", - sig => "job : free", weak => 1 }, - { name => "virJobCancel", - sig => "job : unit", weak => 1 }, - { name => "virJobGetNetwork", - sig => "job : net from job", weak => 1 }, - { name => "virJobGetDomain", - sig => "job : dom from job", weak => 1 }, - - ); - -# Functions we haven't implemented anywhere yet but which are mentioned -# in 'libvirt.ml'. -# -# We create stubs for these, but eventually they need to either be -# moved ^^^ so they are auto-generated, or implementations of them -# written in 'libvirt_c_oneoffs.c'. - -my @unimplemented = ( - ); - -#---------------------------------------------------------------------- - -# Open the output file. - -my $filename = "libvirt_c.c"; -open F, ">$filename" or die "$filename: $!"; - -# Write the prologue. - -print F <<'END'; -/* !!! WARNING WARNING WARNING WARNING WARNING WARNING WARNING !!! - * - * THIS FILE IS AUTOMATICALLY GENERATED BY 'generator.pl'. - * - * Any changes you make to this file may be overwritten. - */ - -/* OCaml bindings for libvirt. - * (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc. - * http://libvirt.org/ - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2 of the License, or (at your option) any later version. - * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - */ - -#include "config.h" - -#include <stdio.h> -#include <stdlib.h> -#include <string.h> - -#include <libvirt/libvirt.h> -#include <libvirt/virterror.h> - -#include <caml/config.h> -#include <caml/alloc.h> -#include <caml/callback.h> -#include <caml/custom.h> -#include <caml/fail.h> -#include <caml/memory.h> -#include <caml/misc.h> -#include <caml/mlvalues.h> -#include <caml/signals.h> - -#include "libvirt_c_prologue.c" - -#include "libvirt_c_oneoffs.c" - -END - -#---------------------------------------------------------------------- - -sub camel_case_to_underscores -{ - my $name = shift; - - $name =~ s/([A-Z][a-z]+|XML|URI|OS|UUID)/$1,/g; - my @subs = split (/,/, $name); - @subs = map { lc($_) } @subs; - join "_", @subs -} - -# Helper functions dealing with signatures. - -sub short_name_to_c_type -{ - local $_ = shift; - - if ($_ eq "conn") { "virConnectPtr" } - elsif ($_ eq "dom") { "virDomainPtr" } - elsif ($_ eq "net") { "virNetworkPtr" } - elsif ($_ eq "pool") { "virStoragePoolPtr" } - elsif ($_ eq "vol") { "virStorageVolPtr" } - elsif ($_ eq "job") { "virJobPtr" } - else { - die "unknown short name $_" - } -} - -# Generate a C signature for the original function. Used when building -# weak bindings. - -sub gen_c_signature -{ - my $sig = shift; - my $c_name = shift; - - if ($sig =~ /^(\w+) : string$/) { - my $c_type = short_name_to_c_type ($1); - "char *$c_name ($c_type $1)" - } elsif ($sig =~ /^(\w+) : static string$/) { - my $c_type = short_name_to_c_type ($1); - "const char *$c_name ($c_type $1)" - } elsif ($sig =~ /^(\w+) : int$/) { - my $c_type = short_name_to_c_type ($1); - "int $c_name ($c_type $1)" - } elsif ($sig =~ /^(\w+) : uuid$/) { - my $c_type = short_name_to_c_type ($1); - "int $c_name ($c_type $1, unsigned char *)" - } elsif ($sig =~ /^(\w+) : uuid string$/) { - my $c_type = short_name_to_c_type ($1); - "int $c_name ($c_type $1, char *)" - } elsif ($sig =~ /^(\w+) : bool$/) { - my $c_type = short_name_to_c_type ($1); - "int $c_name ($c_type $1, int *r)" - } elsif ($sig =~ /^(\w+), bool : unit$/) { - my $c_type = short_name_to_c_type ($1); - "int $c_name ($c_type $1, int b)" - } elsif ($sig eq "conn, int : int array") { - "int $c_name (virConnectPtr conn, int *ids, int maxids)" - } elsif ($sig =~ /^(\w+), int : string array$/) { - my $c_type = short_name_to_c_type ($1); - "int $c_name ($c_type $1, char **const names, int maxnames)" - } elsif ($sig =~ /^(\w+), 0(U?) : string$/) { - my $c_type = short_name_to_c_type ($1); - my $unsigned = $2 eq "U" ? "unsigned " : ""; - "char *$c_name ($c_type $1, $unsigned int flags)" - } elsif ($sig =~ /^(\w+), 0(U?) : unit$/) { - my $c_type = short_name_to_c_type ($1); - my $unsigned = $2 eq "U" ? "unsigned " : ""; - "int $c_name ($c_type $1, $unsigned int flags)" - } elsif ($sig =~ /^(\w+) : unit$/) { - my $c_type = short_name_to_c_type ($1); - "int $c_name ($c_type $1)" - } elsif ($sig =~ /^(\w+) : free$/) { - my $c_type = short_name_to_c_type ($1); - "int $c_name ($c_type $1)" - } elsif ($sig =~ /^(\w+), string : unit$/) { - my $c_type = short_name_to_c_type ($1); - "int $c_name ($c_type $1, const char *str)" - } elsif ($sig =~ /^(\w+), string, 0(U?) : unit$/) { - my $c_type = short_name_to_c_type ($1); - my $unsigned = $2 eq "U" ? "unsigned " : ""; - "int $c_name ($c_type $1, const char *str, ${unsigned}int flags)" - } elsif ($sig =~ /^(\w+), string : (\w+)$/) { - my $c_type = short_name_to_c_type ($1); - my $c_ret_type = short_name_to_c_type ($2); - "$c_ret_type $c_name ($c_type $1, const char *str)" - } elsif ($sig =~ /^(\w+), string, 0(U?) : (\w+)$/) { - my $c_type = short_name_to_c_type ($1); - my $unsigned = $2 eq "U" ? "unsigned " : ""; - my $c_ret_type = short_name_to_c_type ($3); - "$c_ret_type $c_name ($c_type $1, const char *str, ${unsigned}int flags)" - } elsif ($sig =~ /^(\w+), (u?)int : unit$/) { - my $c_type = short_name_to_c_type ($1); - my $unsigned = $2 eq "u" ? "unsigned " : ""; - "int $c_name ($c_type $1, ${unsigned}int i)" - } elsif ($sig =~ /^(\w+), (u?)int : (\w+)$/) { - my $c_type = short_name_to_c_type ($1); - my $unsigned = $2 eq "u" ? "unsigned " : ""; - my $c_ret_type = short_name_to_c_type ($3); - "$c_ret_type $c_name ($c_type $1, ${unsigned}int i)" - } elsif ($sig =~ /^(\w+), uuid : (\w+)$/) { - my $c_type = short_name_to_c_type ($1); - my $c_ret_type = short_name_to_c_type ($2); - "$c_ret_type $c_name ($c_type $1, const unsigned char *str)" - } elsif ($sig =~ /^(\w+), 0(U?) : (\w+)$/) { - my $c_type = short_name_to_c_type ($1); - my $unsigned = $2 eq "U" ? "unsigned " : ""; - my $c_ret_type = short_name_to_c_type ($3); - "$c_ret_type $c_name ($c_type $1, $unsigned int flags)" - } elsif ($sig =~ /^(\w+) : (\w+)$/) { - my $c_type = short_name_to_c_type ($1); - my $c_ret_type = short_name_to_c_type ($2); - "$c_ret_type $c_name ($c_type $1)" - } elsif ($sig =~ /^(\w+), string : (\w+) from \w+$/) { - my $c_type = short_name_to_c_type ($1); - my $c_ret_type = short_name_to_c_type ($2); - "$c_ret_type $c_name ($c_type $1, const char *str)" - } elsif ($sig =~ /^(\w+), string, 0(U?) : (\w+) from \w+$/) { - my $c_type = short_name_to_c_type ($1); - my $unsigned = $2 eq "U" ? "unsigned " : ""; - my $c_ret_type = short_name_to_c_type ($3); - "$c_ret_type $c_name ($c_type $1, const char *str, $unsigned int flags)" - } elsif ($sig =~ /^(\w+), 0(U?) : (\w+) from \w+$/) { - my $c_type = short_name_to_c_type ($1); - my $unsigned = $2 eq "U" ? "unsigned " : ""; - my $c_ret_type = short_name_to_c_type ($3); - "$c_ret_type $c_name ($c_type $1, $unsigned int flags)" - } elsif ($sig =~ /^(\w+) : (\w+) from \w+$/) { - my $c_type = short_name_to_c_type ($1); - my $c_ret_type = short_name_to_c_type ($2); - "$c_ret_type $c_name ($c_type $1)" - } else { - die "unknown signature $sig" - } -} - -# OCaml argument names. - -sub gen_arg_names -{ - my $sig = shift; - - if ($sig =~ /^(\w+) : string$/) { - ( "$1v" ) - } elsif ($sig =~ /^(\w+) : static string$/) { - ( "$1v" ) - } elsif ($sig =~ /^(\w+) : int$/) { - ( "$1v" ) - } elsif ($sig =~ /^(\w+) : uuid$/) { - ( "$1v" ) - } elsif ($sig =~ /^(\w+) : uuid string$/) { - ( "$1v" ) - } elsif ($sig =~ /^(\w+) : bool$/) { - ( "$1v" ) - } elsif ($sig =~ /^(\w+), bool : unit$/) { - ( "$1v", "bv" ) - } elsif ($sig eq "conn, int : int array") { - ( "connv", "iv" ) - } elsif ($sig =~ /^(\w+), int : string array$/) { - ( "$1v", "iv" ) - } elsif ($sig =~ /^(\w+), 0U? : string$/) { - ( "$1v" ) - } elsif ($sig =~ /^(\w+), 0U? : unit$/) { - ( "$1v" ) - } elsif ($sig =~ /^(\w+) : unit$/) { - ( "$1v" ) - } elsif ($sig =~ /^(\w+) : free$/) { - ( "$1v" ) - } elsif ($sig =~ /^(\w+), string : unit$/) { - ( "$1v", "strv" ) - } elsif ($sig =~ /^(\w+), string, 0U? : unit$/) { - ( "$1v", "strv" ) - } elsif ($sig =~ /^(\w+), string : (\w+)$/) { - ( "$1v", "strv" ) - } elsif ($sig =~ /^(\w+), string, 0U? : (\w+)$/) { - ( "$1v", "strv" ) - } elsif ($sig =~ /^(\w+), u?int : (\w+)$/) { - ( "$1v", "iv" ) - } elsif ($sig =~ /^(\w+), uuid : (\w+)$/) { - ( "$1v", "uuidv" ) - } elsif ($sig =~ /^(\w+), 0U? : (\w+)$/) { - ( "$1v" ) - } elsif ($sig =~ /^(\w+) : (\w+)$/) { - ( "$1v" ) - } elsif ($sig =~ /^(\w+), string : (\w+) from \w+$/) { - ( "$1v", "strv" ) - } elsif ($sig =~ /^(\w+), string, 0U? : (\w+) from \w+$/) { - ( "$1v", "strv" ) - } elsif ($sig =~ /^(\w+), 0U? : (\w+) from \w+$/) { - ( "$1v" ) - } elsif ($sig =~ /^(\w+) : (\w+) from \w+$/) { - ( "$1v" ) - } else { - die "unknown signature $sig" - } -} - -# Unpack the first (object) argument. - -sub gen_unpack_args -{ - local $_ = shift; - - if ($_ eq "conn") { - "virConnectPtr conn = Connect_val (connv);" - } elsif ($_ eq "dom") { - "virDomainPtr dom = Domain_val (domv);\n". - " virConnectPtr conn = Connect_domv (domv);" - } elsif ($_ eq "net") { - "virNetworkPtr net = Network_val (netv);\n". - " virConnectPtr conn = Connect_netv (netv);" - } elsif ($_ eq "pool") { - "virStoragePoolPtr pool = Pool_val (poolv);\n". - " virConnectPtr conn = Connect_polv (poolv);" - } elsif ($_ eq "vol") { - "virStorageVolPtr vol = Volume_val (volv);\n". - " virConnectPtr conn = Connect_volv (volv);" - } elsif ($_ eq "job") { - "virJobPtr job = Job_val (jobv);\n". - " virConnectPtr conn = Connect_jobv (jobv);" - } else { - die "unknown short name $_" - } -} - -# Pack the result if it's an object. - -sub gen_pack_result -{ - local $_ = shift; - - if ($_ eq "dom") { "rv = Val_domain (r, connv);" } - elsif ($_ eq "net") { "rv = Val_network (r, connv);" } - elsif ($_ eq "pool") { "rv = Val_pool (r, connv);" } - elsif ($_ eq "vol") { "rv = Val_volume (r, connv);" } - elsif ($_ eq "job") { "rv = Val_job (r, connv);" } - else { - die "unknown short name $_" - } -} - -sub gen_free_arg -{ - local $_ = shift; - - if ($_ eq "conn") { "Connect_val (connv) = NULL;" } - elsif ($_ eq "dom") { "Domain_val (domv) = NULL;" } - elsif ($_ eq "net") { "Network_val (netv) = NULL;" } - elsif ($_ eq "pool") { "Pool_val (poolv) = NULL;" } - elsif ($_ eq "vol") { "Volume_val (volv) = NULL;" } - elsif ($_ eq "job") { "Job_val (jobv) = NULL;" } - else { - die "unknown short name $_" - } -} - -# Generate the C body for each signature (class of function). - -sub gen_c_code -{ - my $sig = shift; - my $c_name = shift; - - if ($sig =~ /^(\w+) : string$/) { - "\ - CAMLlocal1 (rv); - " . gen_unpack_args ($1) . " - char *r; - - NONBLOCKING (r = $c_name ($1)); - CHECK_ERROR (!r, conn, \"$c_name\"); - - rv = caml_copy_string (r); - free (r); - CAMLreturn (rv); -" - } elsif ($sig =~ /^(\w+) : static string$/) { - "\ - CAMLlocal1 (rv); - " . gen_unpack_args ($1) . " - const char *r; - - NONBLOCKING (r = $c_name ($1)); - CHECK_ERROR (!r, conn, \"$c_name\"); - - rv = caml_copy_string (r); - CAMLreturn (rv); -" - } elsif ($sig =~ /^(\w+) : int$/) { - "\ - " . gen_unpack_args ($1) . " - int r; - - NONBLOCKING (r = $c_name ($1)); - CHECK_ERROR (r == -1, conn, \"$c_name\"); - - CAMLreturn (Val_int (r)); -" - } elsif ($sig =~ /^(\w+) : uuid$/) { - "\ - CAMLlocal1 (rv); - " . gen_unpack_args ($1) . " - unsigned char uuid[VIR_UUID_BUFLEN]; - int r; - - NONBLOCKING (r = $c_name ($1, uuid)); - CHECK_ERROR (r == -1, conn, \"$c_name\"); - - /* UUIDs are byte arrays with a fixed length. */ - rv = caml_alloc_string (VIR_UUID_BUFLEN); - memcpy (String_val (rv), uuid, VIR_UUID_BUFLEN); - CAMLreturn (rv); -" - } elsif ($sig =~ /^(\w+) : uuid string$/) { - "\ - CAMLlocal1 (rv); - " . gen_unpack_args ($1) . " - char uuid[VIR_UUID_STRING_BUFLEN]; - int r; - - NONBLOCKING (r = $c_name ($1, uuid)); - CHECK_ERROR (r == -1, conn, \"$c_name\"); - - rv = caml_copy_string (uuid); - CAMLreturn (rv); -" - } elsif ($sig =~ /^(\w+) : bool$/) { - "\ - " . gen_unpack_args ($1) . " - int r, b; - - NONBLOCKING (r = $c_name ($1, &b)); - CHECK_ERROR (r == -1, conn, \"$c_name\"); - - CAMLreturn (b ? Val_true : Val_false); -" - } elsif ($sig =~ /^(\w+), bool : unit$/) { - "\ - " . gen_unpack_args ($1) . " - int r, b; - - b = bv == Val_true ? 1 : 0; - - NONBLOCKING (r = $c_name ($1, b)); - CHECK_ERROR (r == -1, conn, \"$c_name\"); - - CAMLreturn (Val_unit); -" - } elsif ($sig eq "conn, int : int array") { - "\ - CAMLlocal1 (rv); - virConnectPtr conn = Connect_val (connv); - int i = Int_val (iv); - int ids[i], r; - - NONBLOCKING (r = $c_name (conn, ids, i)); - CHECK_ERROR (r == -1, conn, \"$c_name\"); - - rv = caml_alloc (r, 0); - for (i = 0; i < r; ++i) - Store_field (rv, i, Val_int (ids[i])); - - CAMLreturn (rv); -" - } elsif ($sig =~ /^(\w+), int : string array$/) { - "\ - CAMLlocal2 (rv, strv); - " . gen_unpack_args ($1) . " - int i = Int_val (iv); - char *names[i]; - int r; - - NONBLOCKING (r = $c_name ($1, names, i)); - CHECK_ERROR (r == -1, conn, \"$c_name\"); - - rv = caml_alloc (r, 0); - for (i = 0; i < r; ++i) { - strv = caml_copy_string (names[i]); - Store_field (rv, i, strv); - free (names[i]); - } - - CAMLreturn (rv); -" - } elsif ($sig =~ /^(\w+), 0U? : string$/) { - "\ - CAMLlocal1 (rv); - " . gen_unpack_args ($1) . " - char *r; - - NONBLOCKING (r = $c_name ($1, 0)); - CHECK_ERROR (!r, conn, \"$c_name\"); - - rv = caml_copy_string (r); - free (r); - CAMLreturn (rv); -" - } elsif ($sig =~ /^(\w+), 0U? : unit$/) { - "\ - " . gen_unpack_args ($1) . " - int r; - - NONBLOCKING (r = $c_name ($1, 0)); - CHECK_ERROR (r == -1, conn, \"$c_name\"); - - CAMLreturn (Val_unit); -" - } elsif ($sig =~ /^(\w+) : unit$/) { - "\ - " . gen_unpack_args ($1) . " - int r; - - NONBLOCKING (r = $c_name ($1)); - CHECK_ERROR (r == -1, conn, \"$c_name\"); - - CAMLreturn (Val_unit); -" - } elsif ($sig =~ /^(\w+) : free$/) { - "\ - " . gen_unpack_args ($1) . " - int r; - - NONBLOCKING (r = $c_name ($1)); - CHECK_ERROR (r == -1, conn, \"$c_name\"); - - /* So that we don't double-free in the finalizer: */ - " . gen_free_arg ($1) . " - - CAMLreturn (Val_unit); -" - } elsif ($sig =~ /^(\w+), string : unit$/) { - "\ - " . gen_unpack_args ($1) . " - char *str = String_val (strv); - int r; - - NONBLOCKING (r = $c_name ($1, str)); - CHECK_ERROR (r == -1, conn, \"$c_name\"); - - CAMLreturn (Val_unit); -" - } elsif ($sig =~ /^(\w+), string, 0U? : unit$/) { - "\ - CAMLlocal1 (rv); - " . gen_unpack_args ($1) . " - char *str = String_val (strv); - int r; - - NONBLOCKING (r = $c_name ($1, str, 0)); - CHECK_ERROR (!r, conn, \"$c_name\"); - - CAMLreturn (Val_unit); -" - } elsif ($sig =~ /^(\w+), string : (\w+)$/) { - my $c_ret_type = short_name_to_c_type ($2); - "\ - CAMLlocal1 (rv); - " . gen_unpack_args ($1) . " - char *str = String_val (strv); - $c_ret_type r; - - NONBLOCKING (r = $c_name ($1, str)); - CHECK_ERROR (!r, conn, \"$c_name\"); - - " . gen_pack_result ($2) . " - - CAMLreturn (rv); -" - } elsif ($sig =~ /^(\w+), string, 0U? : (\w+)$/) { - my $c_ret_type = short_name_to_c_type ($2); - "\ - CAMLlocal1 (rv); - " . gen_unpack_args ($1) . " - char *str = String_val (strv); - $c_ret_type r; - - NONBLOCKING (r = $c_name ($1, str, 0)); - CHECK_ERROR (!r, conn, \"$c_name\"); - - " . gen_pack_result ($2) . " - - CAMLreturn (rv); -" - } elsif ($sig =~ /^(\w+), (u?)int : unit$/) { - my $unsigned = $2 eq "u" ? "unsigned " : ""; - "\ - " . gen_unpack_args ($1) . " - ${unsigned}int i = Int_val (iv); - int r; - - NONBLOCKING (r = $c_name ($1, i)); - CHECK_ERROR (!r, conn, \"$c_name\"); - - CAMLreturn (Val_unit); -" - } elsif ($sig =~ /^(\w+), (u?)int : (\w+)$/) { - my $c_ret_type = short_name_to_c_type ($3); - my $unsigned = $2 eq "u" ? "unsigned " : ""; - "\ - CAMLlocal1 (rv); - " . gen_unpack_args ($1) . " - ${unsigned}int i = Int_val (iv); - $c_ret_type r; - - NONBLOCKING (r = $c_name ($1, i)); - CHECK_ERROR (!r, conn, \"$c_name\"); - - " . gen_pack_result ($3) . " - - CAMLreturn (rv); -" - } elsif ($sig =~ /^(\w+), uuid : (\w+)$/) { - my $c_ret_type = short_name_to_c_type ($2); - "\ - CAMLlocal1 (rv); - " . gen_unpack_args ($1) . " - unsigned char *uuid = (unsigned char *) String_val (uuidv); - $c_ret_type r; - - NONBLOCKING (r = $c_name ($1, uuid)); - CHECK_ERROR (!r, conn, \"$c_name\"); - - " . gen_pack_result ($2) . " - - CAMLreturn (rv); -" - } elsif ($sig =~ /^(\w+), 0U? : (\w+)$/) { - my $c_ret_type = short_name_to_c_type ($2); - "\ - CAMLlocal1 (rv); - " . gen_unpack_args ($1) . " - $c_ret_type r; - - NONBLOCKING (r = $c_name ($1, 0)); - CHECK_ERROR (!r, conn, \"$c_name\"); - - " . gen_pack_result ($2) . " - - CAMLreturn (rv); -" - } elsif ($sig =~ /^(\w+) : (\w+)$/) { - my $c_ret_type = short_name_to_c_type ($2); - "\ - CAMLlocal1 (rv); - " . gen_unpack_args ($1) . " - $c_ret_type r; - - NONBLOCKING (r = $c_name ($1)); - CHECK_ERROR (!r, conn, \"$c_name\"); - - " . gen_pack_result ($2) . " - - CAMLreturn (rv); -" - } elsif ($sig =~ /^(\w+), string : (\w+) from (\w+)$/) { - my $c_ret_type = short_name_to_c_type ($2); - "\ - CAMLlocal2 (rv, connv); - " . gen_unpack_args ($1) . " - char *str = String_val (strv); - $c_ret_type r; - - NONBLOCKING (r = $c_name ($1, str)); - CHECK_ERROR (!r, conn, \"$c_name\"); - - connv = Field ($3v, 1); - " . gen_pack_result ($2) . " - - CAMLreturn (rv); -" - } elsif ($sig =~ /^(\w+), string, 0U? : (\w+) from (\w+)$/) { - my $c_ret_type = short_name_to_c_type ($2); - "\ - CAMLlocal2 (rv, connv); - " . gen_unpack_args ($1) . " - char *str = String_val (strv); - $c_ret_type r; - - NONBLOCKING (r = $c_name ($1, str, 0)); - CHECK_ERROR (!r, conn, \"$c_name\"); - - connv = Field ($3v, 1); - " . gen_pack_result ($2) . " - - CAMLreturn (rv); -" - } elsif ($sig =~ /^(\w+), 0U? : (\w+) from (\w+)$/) { - my $c_ret_type = short_name_to_c_type ($2); - "\ - CAMLlocal2 (rv, connv); - " . gen_unpack_args ($1) . " - $c_ret_type r; - - NONBLOCKING (r = $c_name ($1, 0)); - CHECK_ERROR (!r, conn, \"$c_name\"); - - connv = Field ($3v, 1); - " . gen_pack_result ($2) . " - - CAMLreturn (rv); -" - } elsif ($sig =~ /^(\w+) : (\w+) from (\w+)$/) { - my $c_ret_type = short_name_to_c_type ($2); - "\ - CAMLlocal2 (rv, connv); - " . gen_unpack_args ($1) . " - $c_ret_type r; - - NONBLOCKING (r = $c_name ($1)); - CHECK_ERROR (!r, conn, \"$c_name\"); - - connv = Field ($3v, 1); - " . gen_pack_result ($2) . " - - CAMLreturn (rv); -" - } else { - die "unknown signature $sig" - } -} - -# Generate each function. - -foreach my $function (@functions) { - my $c_name = $function->{name}; - my $is_weak = $function->{weak}; - my $sig = $function->{sig}; - - #print "generating $c_name with sig \"$sig\" ...\n"; - - #my $is_pool_func = $c_name =~ /^virStoragePool/; - #my $is_vol_func = $c_name =~ /^virStorageVol/; - - # Generate an equivalent C-external name for the function, unless - # one is defined already. - my $c_external_name; - if (exists ($function->{c_external_name})) { - $c_external_name = $function->{c_external_name}; - } elsif ($c_name =~ /^vir/) { - $c_external_name = substr $c_name, 3; - $c_external_name = camel_case_to_underscores ($c_external_name); - $c_external_name = "ocaml_libvirt_" . $c_external_name; - } else { - die "cannot convert c_name $c_name to c_external_name" - } - - print F <<END; -/* Automatically generated binding for $c_name. - * In generator.pl this function has signature "$sig". - */ - -END - - # Generate a full function prototype if the function is weak. - my $have_name = "HAVE_" . uc ($c_name); - if ($is_weak) { - my $c_sig = gen_c_signature ($sig, $c_name); - print F <<END; -#ifdef HAVE_WEAK_SYMBOLS -#ifdef $have_name -extern $c_sig __attribute__((weak)); -#endif -#endif - -END - } - - my @arg_names = gen_arg_names ($sig); - my $nr_arg_names = scalar @arg_names; - my $arg_names = join ", ", @arg_names; - my $arg_names_as_values = join (", ", map { "value $_" } @arg_names); - - # Generate the start of the function, arguments. - print F <<END; -CAMLprim value -$c_external_name ($arg_names_as_values) -{ - CAMLparam$nr_arg_names ($arg_names); -END - - # If weak, check the function exists at compile time or runtime. - if ($is_weak) { - print F <<END; -#ifndef $have_name - /* Symbol $c_name not found at compile time. */ - not_supported ("$c_name"); - CAMLnoreturn; -#else - /* Check that the symbol $c_name - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK ($c_name); -END - } - - # Generate the internals of the function. - print F (gen_c_code ($sig, $c_name)); - - # Finish off weak #ifdef. - if ($is_weak) { - print F <<END; -#endif -END - } - - # Finish off the function. - print F <<END; -} - -END -} - -#---------------------------------------------------------------------- - -# Unimplemented functions. - -if (@unimplemented) { - printf "$0: warning: %d unimplemented functions\n", scalar (@unimplemented); - - print F <<'END'; -/* The following functions are unimplemented and always fail. - * See generator.pl '@unimplemented' - */ - -END - - foreach my $c_external_name (@unimplemented) { - print F <<END; -CAMLprim value -$c_external_name () -{ - failwith ("$c_external_name is unimplemented"); -} - -END - } # end foreach -} # end if @unimplemented - -#---------------------------------------------------------------------- - -# Write the epilogue. - -print F <<'END'; -#include "libvirt_c_epilogue.c" - -/* EOF */ -END - -close F; -print "$0: written $filename\n" - diff --git a/libvirt/libvirt.ml b/libvirt/libvirt.ml deleted file mode 100644 index aefc6c4..0000000 --- a/libvirt/libvirt.ml +++ /dev/null @@ -1,522 +0,0 @@ -(* OCaml bindings for libvirt. - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA -*) - -type uuid = string - -type xml = string - -type filename = string - -external get_version : ?driver:string -> unit -> int * int = "ocaml_libvirt_get_version" - -let uuid_length = 16 -let uuid_string_length = 36 - -(* http://caml.inria.fr/pub/ml-archives/caml-list/2004/07/80683af867cce6bf8fff273973f70c95.en.html *) -type rw = [`R|`W] -type ro = [`R] - -type ('a, 'b) job_t - -module Connect = -struct - type 'rw t - - type node_info = { - model : string; - memory : int64; - cpus : int; - mhz : int; - nodes : int; - sockets : int; - cores : int; - threads : int; - } - - external connect : ?name:string -> unit -> rw t = "ocaml_libvirt_connect_open" - external connect_readonly : ?name:string -> unit -> ro t = "ocaml_libvirt_connect_open_readonly" - external close : [>`R] t -> unit = "ocaml_libvirt_connect_close" - external get_type : [>`R] t -> string = "ocaml_libvirt_connect_get_type" - external get_version : [>`R] t -> int = "ocaml_libvirt_connect_get_version" - external get_hostname : [>`R] t -> string = "ocaml_libvirt_connect_get_hostname" - external get_uri : [>`R] t -> string = "ocaml_libvirt_connect_get_uri" - external get_max_vcpus : [>`R] t -> ?type_:string -> unit -> int = "ocaml_libvirt_connect_get_max_vcpus" - external list_domains : [>`R] t -> int -> int array = "ocaml_libvirt_connect_list_domains" - external num_of_domains : [>`R] t -> int = "ocaml_libvirt_connect_num_of_domains" - external get_capabilities : [>`R] t -> xml = "ocaml_libvirt_connect_get_capabilities" - external num_of_defined_domains : [>`R] t -> int = "ocaml_libvirt_connect_num_of_defined_domains" - external list_defined_domains : [>`R] t -> int -> string array = "ocaml_libvirt_connect_list_defined_domains" - external num_of_networks : [>`R] t -> int = "ocaml_libvirt_connect_num_of_networks" - external list_networks : [>`R] t -> int -> string array = "ocaml_libvirt_connect_list_networks" - external num_of_defined_networks : [>`R] t -> int = "ocaml_libvirt_connect_num_of_defined_networks" - external list_defined_networks : [>`R] t -> int -> string array = "ocaml_libvirt_connect_list_defined_networks" - external num_of_pools : [>`R] t -> int = "ocaml_libvirt_connect_num_of_storage_pools" - external list_pools : [>`R] t -> int -> string array = "ocaml_libvirt_connect_list_storage_pools" - external num_of_defined_pools : [>`R] t -> int = "ocaml_libvirt_connect_num_of_defined_storage_pools" - external list_defined_pools : [>`R] t -> int -> string array = "ocaml_libvirt_connect_list_defined_storage_pools" - - external get_node_info : [>`R] t -> node_info = "ocaml_libvirt_connect_get_node_info" - external node_get_free_memory : [> `R] t -> int64 = "ocaml_libvirt_connect_node_get_free_memory" - external node_get_cells_free_memory : [> `R] t -> int -> int -> int64 array = "ocaml_libvirt_connect_node_get_cells_free_memory" - - (* See VIR_NODEINFO_MAXCPUS macro defined in <libvirt.h>. *) - let maxcpus_of_node_info { nodes = nodes; sockets = sockets; - cores = cores; threads = threads } = - nodes * sockets * cores * threads - - (* See VIR_CPU_MAPLEN macro defined in <libvirt.h>. *) - let cpumaplen nr_cpus = - (nr_cpus + 7) / 8 - - (* See VIR_USE_CPU, VIR_UNUSE_CPU, VIR_CPU_USABLE macros defined in <libvirt.h>. *) - let use_cpu cpumap cpu = - cpumap.[cpu/8] <- - Char.chr (Char.code cpumap.[cpu/8] lor (1 lsl (cpu mod 8))) - let unuse_cpu cpumap cpu = - cpumap.[cpu/8] <- - Char.chr (Char.code cpumap.[cpu/8] land (lnot (1 lsl (cpu mod 8)))) - let cpu_usable cpumaps maplen vcpu cpu = - Char.code cpumaps.[vcpu*maplen + cpu/8] land (1 lsl (cpu mod 8)) <> 0 - - external const : [>`R] t -> ro t = "%identity" -end - -module Domain = -struct - type 'rw t - - type state = - | InfoNoState | InfoRunning | InfoBlocked | InfoPaused - | InfoShutdown | InfoShutoff | InfoCrashed - - type info = { - state : state; - max_mem : int64; - memory : int64; - nr_virt_cpu : int; - cpu_time : int64; - } - - type vcpu_state = VcpuOffline | VcpuRunning | VcpuBlocked - - type vcpu_info = { - number : int; - vcpu_state : vcpu_state; - vcpu_time : int64; - cpu : int; - } - - type sched_param = string * sched_param_value - and sched_param_value = - | SchedFieldInt32 of int32 | SchedFieldUInt32 of int32 - | SchedFieldInt64 of int64 | SchedFieldUInt64 of int64 - | SchedFieldFloat of float | SchedFieldBool of bool - - type migrate_flag = Live - - type block_stats = { - rd_req : int64; - rd_bytes : int64; - wr_req : int64; - wr_bytes : int64; - errs : int64; - } - - type interface_stats = { - rx_bytes : int64; - rx_packets : int64; - rx_errs : int64; - rx_drop : int64; - tx_bytes : int64; - tx_packets : int64; - tx_errs : int64; - tx_drop : int64; - } - - external create_linux : [>`W] Connect.t -> xml -> rw t = "ocaml_libvirt_domain_create_linux" - external create_linux_job : [>`W] Connect.t -> xml -> ([`Domain], rw) job_t = "ocaml_libvirt_domain_create_linux_job" - external lookup_by_id : 'a Connect.t -> int -> 'a t = "ocaml_libvirt_domain_lookup_by_id" - external lookup_by_uuid : 'a Connect.t -> uuid -> 'a t = "ocaml_libvirt_domain_lookup_by_uuid" - external lookup_by_uuid_string : 'a Connect.t -> string -> 'a t = "ocaml_libvirt_domain_lookup_by_uuid_string" - external lookup_by_name : 'a Connect.t -> string -> 'a t = "ocaml_libvirt_domain_lookup_by_name" - external destroy : [>`W] t -> unit = "ocaml_libvirt_domain_destroy" - external free : [>`R] t -> unit = "ocaml_libvirt_domain_free" - external suspend : [>`W] t -> unit = "ocaml_libvirt_domain_suspend" - external resume : [>`W] t -> unit = "ocaml_libvirt_domain_resume" - external save : [>`W] t -> filename -> unit = "ocaml_libvirt_domain_save" - external save_job : [>`W] t -> filename -> ([`Domain_nocreate], rw) job_t = "ocaml_libvirt_domain_save_job" - external restore : [>`W] Connect.t -> filename -> unit = "ocaml_libvirt_domain_restore" - external restore_job : [>`W] Connect.t -> filename -> ([`Domain_nocreate], rw) job_t = "ocaml_libvirt_domain_restore_job" - external core_dump : [>`W] t -> filename -> unit = "ocaml_libvirt_domain_core_dump" - external core_dump_job : [>`W] t -> filename -> ([`Domain_nocreate], rw) job_t = "ocaml_libvirt_domain_core_dump_job" - external shutdown : [>`W] t -> unit = "ocaml_libvirt_domain_shutdown" - external reboot : [>`W] t -> unit = "ocaml_libvirt_domain_reboot" - external get_name : [>`R] t -> string = "ocaml_libvirt_domain_get_name" - external get_uuid : [>`R] t -> uuid = "ocaml_libvirt_domain_get_uuid" - external get_uuid_string : [>`R] t -> string = "ocaml_libvirt_domain_get_uuid_string" - external get_id : [>`R] t -> int = "ocaml_libvirt_domain_get_id" - external get_os_type : [>`R] t -> string = "ocaml_libvirt_domain_get_os_type" - external get_max_memory : [>`R] t -> int64 = "ocaml_libvirt_domain_get_max_memory" - external set_max_memory : [>`W] t -> int64 -> unit = "ocaml_libvirt_domain_set_max_memory" - external set_memory : [>`W] t -> int64 -> unit = "ocaml_libvirt_domain_set_memory" - external get_info : [>`R] t -> info = "ocaml_libvirt_domain_get_info" - external get_xml_desc : [>`R] t -> xml = "ocaml_libvirt_domain_get_xml_desc" - external get_scheduler_type : [>`R] t -> string * int = "ocaml_libvirt_domain_get_scheduler_type" - external get_scheduler_parameters : [>`R] t -> int -> sched_param array = "ocaml_libvirt_domain_get_scheduler_parameters" - external set_scheduler_parameters : [>`W] t -> sched_param array -> unit = "ocaml_libvirt_domain_set_scheduler_parameters" - external define_xml : [>`W] Connect.t -> xml -> rw t = "ocaml_libvirt_domain_define_xml" - external undefine : [>`W] t -> unit = "ocaml_libvirt_domain_undefine" - external create : [>`W] t -> unit = "ocaml_libvirt_domain_create" - external create_job : [>`W] t -> ([`Domain_nocreate], rw) job_t = "ocaml_libvirt_domain_create_job" - external get_autostart : [>`R] t -> bool = "ocaml_libvirt_domain_get_autostart" - external set_autostart : [>`W] t -> bool -> unit = "ocaml_libvirt_domain_set_autostart" - external set_vcpus : [>`W] t -> int -> unit = "ocaml_libvirt_domain_set_vcpus" - external pin_vcpu : [>`W] t -> int -> string -> unit = "ocaml_libvirt_domain_pin_vcpu" - external get_vcpus : [>`R] t -> int -> int -> int * vcpu_info array * string = "ocaml_libvirt_domain_get_vcpus" - external get_max_vcpus : [>`R] t -> int = "ocaml_libvirt_domain_get_max_vcpus" - external attach_device : [>`W] t -> xml -> unit = "ocaml_libvirt_domain_attach_device" - external detach_device : [>`W] t -> xml -> unit = "ocaml_libvirt_domain_detach_device" - external migrate : [>`W] t -> [>`W] Connect.t -> migrate_flag list -> ?dname:string -> ?uri:string -> ?bandwidth:int -> unit -> rw t = "ocaml_libvirt_domain_migrate_bytecode" "ocaml_libvirt_domain_migrate_native" - external block_stats : [>`R] t -> string -> block_stats = "ocaml_libvirt_domain_block_stats" - external interface_stats : [>`R] t -> string -> interface_stats = "ocaml_libvirt_domain_interface_stats" - - external const : [>`R] t -> ro t = "%identity" -end - -module Network = -struct - type 'rw t - - external lookup_by_name : 'a Connect.t -> string -> 'a t = "ocaml_libvirt_network_lookup_by_name" - external lookup_by_uuid : 'a Connect.t -> uuid -> 'a t = "ocaml_libvirt_network_lookup_by_uuid" - external lookup_by_uuid_string : 'a Connect.t -> string -> 'a t = "ocaml_libvirt_network_lookup_by_uuid_string" - external create_xml : [>`W] Connect.t -> xml -> rw t = "ocaml_libvirt_network_create_xml" - external create_xml_job : [>`W] Connect.t -> xml -> ([`Network], rw) job_t = "ocaml_libvirt_network_create_xml_job" - external define_xml : [>`W] Connect.t -> xml -> rw t = "ocaml_libvirt_network_define_xml" - external undefine : [>`W] t -> unit = "ocaml_libvirt_network_undefine" - external create : [>`W] t -> unit = "ocaml_libvirt_network_create" - external create_job : [>`W] t -> ([`Network_nocreate], rw) job_t = "ocaml_libvirt_network_create_job" - external destroy : [>`W] t -> unit = "ocaml_libvirt_network_destroy" - external free : [>`R] t -> unit = "ocaml_libvirt_network_free" - external get_name : [>`R] t -> string = "ocaml_libvirt_network_get_name" - external get_uuid : [>`R] t -> uuid = "ocaml_libvirt_network_get_uuid" - external get_uuid_string : [>`R] t -> string = "ocaml_libvirt_network_get_uuid_string" - external get_xml_desc : [>`R] t -> xml = "ocaml_libvirt_network_get_xml_desc" - external get_bridge_name : [>`R] t -> string = "ocaml_libvirt_network_get_bridge_name" - external get_autostart : [>`R] t -> bool = "ocaml_libvirt_network_get_autostart" - external set_autostart : [>`W] t -> bool -> unit = "ocaml_libvirt_network_set_autostart" - - external const : [>`R] t -> ro t = "%identity" -end - -module Pool = -struct - type 'rw t - type pool_state = Inactive | Building | Running | Degraded - type pool_build_flags = New | Repair | Resize - type pool_delete_flags = Normal | Zeroed - type pool_info = { - state : pool_state; - capacity : int64; - allocation : int64; - available : int64; - } - - external lookup_by_name : 'a Connect.t -> string -> 'a t = "ocaml_libvirt_storage_pool_lookup_by_name" - external lookup_by_uuid : 'a Connect.t -> uuid -> 'a t = "ocaml_libvirt_storage_pool_lookup_by_uuid" - external lookup_by_uuid_string : 'a Connect.t -> string -> 'a t = "ocaml_libvirt_storage_pool_lookup_by_uuid_string" - external create_xml : [>`W] Connect.t -> xml -> rw t = "ocaml_libvirt_storage_pool_create_xml" - external define_xml : [>`W] Connect.t -> xml -> rw t = "ocaml_libvirt_storage_pool_define_xml" - external build : [>`W] t -> pool_build_flags -> unit = "ocaml_libvirt_storage_pool_build" - external undefine : [>`W] t -> unit = "ocaml_libvirt_storage_pool_undefine" - external create : [>`W] t -> unit = "ocaml_libvirt_storage_pool_create" - external destroy : [>`W] t -> unit = "ocaml_libvirt_storage_pool_destroy" - external delete : [>`W] t -> unit = "ocaml_libvirt_storage_pool_delete" - external free : [>`R] t -> unit = "ocaml_libvirt_storage_pool_free" - external refresh : [`R] t -> unit = "ocaml_libvirt_storage_pool_refresh" - external get_name : [`R] t -> string = "ocaml_libvirt_storage_pool_get_name" - external get_uuid : [`R] t -> uuid = "ocaml_libvirt_storage_pool_get_uuid" - external get_uuid_string : [`R] t -> string = "ocaml_libvirt_storage_pool_get_uuid_string" - external get_info : [`R] t -> pool_info = "ocaml_libvirt_storage_pool_get_info" - external get_xml_desc : [`R] t -> xml = "ocaml_libvirt_storage_pool_get_xml_desc" - external get_autostart : [`R] t -> bool = "ocaml_libvirt_storage_pool_get_autostart" - external set_autostart : [`W] t -> bool -> unit = "ocaml_libvirt_storage_pool_set_autostart" - external num_of_volumes : [`R] t -> int = "ocaml_libvirt_storage_pool_num_of_volumes" - external list_volumes : [`R] t -> int -> string array = "ocaml_libvirt_storage_pool_list_volumes" - external const : [>`R] t -> ro t = "%identity" -end - -module Volume = -struct - type 'rw t - type vol_type = File | Block - type vol_delete_flags = Normal | Zeroed - type vol_info = { - typ : vol_type; - capacity : int64; - allocation : int64; - } - - external lookup_by_name : 'a Pool.t -> string -> 'a t = "ocaml_libvirt_storage_vol_lookup_by_name" - external lookup_by_key : 'a Connect.t -> string -> 'a t = "ocaml_libvirt_storage_vol_lookup_by_key" - external lookup_by_path : 'a Connect.t -> string -> 'a t = "ocaml_libvirt_storage_vol_lookup_by_path" - external pool_of_volume : 'a t -> 'a Pool.t = "ocaml_libvirt_storage_pool_lookup_by_volume" - external get_name : [`R] t -> string = "ocaml_libvirt_storage_vol_get_name" - external get_key : [`R] t -> string = "ocaml_libvirt_storage_vol_get_key" - external get_path : [`R] t -> string = "ocaml_libvirt_storage_vol_get_path" - external get_info : [`R] t -> vol_info = "ocaml_libvirt_storage_vol_get_info" - external get_xml_desc : [`R] t -> xml = "ocaml_libvirt_storage_vol_get_xml_desc" - external create_xml : [`W] Pool.t -> xml -> unit = "ocaml_libvirt_storage_vol_create_xml" - external delete : [`W] t -> unit = "ocaml_libvirt_storage_vol_delete" - external free : [>`R] t -> unit = "ocaml_libvirt_storage_vol_free" - external const : [>`R] t -> ro t = "%identity" -end - -module Job = -struct - type ('jobclass, 'rw) t = ('jobclass, 'rw) job_t - type job_type = Bounded | Unbounded - type job_state = Running | Complete | Failed | Cancelled - type job_info = { - typ : job_type; - state : job_state; - running_time : int; - remaining_time : int; - percent_complete : int - } - external get_info : ('a,'b) t -> job_info = "ocaml_libvirt_job_get_info" - external get_domain : ([`Domain], 'a) t -> 'a Domain.t = "ocaml_libvirt_job_get_domain" - external get_network : ([`Network], 'a) t -> 'a Network.t = "ocaml_libvirt_job_get_network" - external cancel : ('a,'b) t -> unit = "ocaml_libvirt_job_cancel" - external free : ('a, [>`R]) t -> unit = "ocaml_libvirt_job_free" - external const : ('a, [>`R]) t -> ('a, ro) t = "%identity" -end - -module Virterror = -struct - type code = - | VIR_ERR_OK - | VIR_ERR_INTERNAL_ERROR - | VIR_ERR_NO_MEMORY - | VIR_ERR_NO_SUPPORT - | VIR_ERR_UNKNOWN_HOST - | VIR_ERR_NO_CONNECT - | VIR_ERR_INVALID_CONN - | VIR_ERR_INVALID_DOMAIN - | VIR_ERR_INVALID_ARG - | VIR_ERR_OPERATION_FAILED - | VIR_ERR_GET_FAILED - | VIR_ERR_POST_FAILED - | VIR_ERR_HTTP_ERROR - | VIR_ERR_SEXPR_SERIAL - | VIR_ERR_NO_XEN - | VIR_ERR_XEN_CALL - | VIR_ERR_OS_TYPE - | VIR_ERR_NO_KERNEL - | VIR_ERR_NO_ROOT - | VIR_ERR_NO_SOURCE - | VIR_ERR_NO_TARGET - | VIR_ERR_NO_NAME - | VIR_ERR_NO_OS - | VIR_ERR_NO_DEVICE - | VIR_ERR_NO_XENSTORE - | VIR_ERR_DRIVER_FULL - | VIR_ERR_CALL_FAILED - | VIR_ERR_XML_ERROR - | VIR_ERR_DOM_EXIST - | VIR_ERR_OPERATION_DENIED - | VIR_ERR_OPEN_FAILED - | VIR_ERR_READ_FAILED - | VIR_ERR_PARSE_FAILED - | VIR_ERR_CONF_SYNTAX - | VIR_ERR_WRITE_FAILED - | VIR_ERR_XML_DETAIL - | VIR_ERR_INVALID_NETWORK - | VIR_ERR_NETWORK_EXIST - | VIR_ERR_SYSTEM_ERROR - | VIR_ERR_RPC - | VIR_ERR_GNUTLS_ERROR - | VIR_WAR_NO_NETWORK - | VIR_ERR_NO_DOMAIN - | VIR_ERR_NO_NETWORK - | VIR_ERR_INVALID_MAC - | VIR_ERR_AUTH_FAILED - | VIR_ERR_INVALID_STORAGE_POOL - | VIR_ERR_INVALID_STORAGE_VOL - | VIR_WAR_NO_STORAGE - | VIR_ERR_NO_STORAGE_POOL - | VIR_ERR_NO_STORAGE_VOL - | VIR_ERR_UNKNOWN of int - - let string_of_code = function - | VIR_ERR_OK -> "VIR_ERR_OK" - | VIR_ERR_INTERNAL_ERROR -> "VIR_ERR_INTERNAL_ERROR" - | VIR_ERR_NO_MEMORY -> "VIR_ERR_NO_MEMORY" - | VIR_ERR_NO_SUPPORT -> "VIR_ERR_NO_SUPPORT" - | VIR_ERR_UNKNOWN_HOST -> "VIR_ERR_UNKNOWN_HOST" - | VIR_ERR_NO_CONNECT -> "VIR_ERR_NO_CONNECT" - | VIR_ERR_INVALID_CONN -> "VIR_ERR_INVALID_CONN" - | VIR_ERR_INVALID_DOMAIN -> "VIR_ERR_INVALID_DOMAIN" - | VIR_ERR_INVALID_ARG -> "VIR_ERR_INVALID_ARG" - | VIR_ERR_OPERATION_FAILED -> "VIR_ERR_OPERATION_FAILED" - | VIR_ERR_GET_FAILED -> "VIR_ERR_GET_FAILED" - | VIR_ERR_POST_FAILED -> "VIR_ERR_POST_FAILED" - | VIR_ERR_HTTP_ERROR -> "VIR_ERR_HTTP_ERROR" - | VIR_ERR_SEXPR_SERIAL -> "VIR_ERR_SEXPR_SERIAL" - | VIR_ERR_NO_XEN -> "VIR_ERR_NO_XEN" - | VIR_ERR_XEN_CALL -> "VIR_ERR_XEN_CALL" - | VIR_ERR_OS_TYPE -> "VIR_ERR_OS_TYPE" - | VIR_ERR_NO_KERNEL -> "VIR_ERR_NO_KERNEL" - | VIR_ERR_NO_ROOT -> "VIR_ERR_NO_ROOT" - | VIR_ERR_NO_SOURCE -> "VIR_ERR_NO_SOURCE" - | VIR_ERR_NO_TARGET -> "VIR_ERR_NO_TARGET" - | VIR_ERR_NO_NAME -> "VIR_ERR_NO_NAME" - | VIR_ERR_NO_OS -> "VIR_ERR_NO_OS" - | VIR_ERR_NO_DEVICE -> "VIR_ERR_NO_DEVICE" - | VIR_ERR_NO_XENSTORE -> "VIR_ERR_NO_XENSTORE" - | VIR_ERR_DRIVER_FULL -> "VIR_ERR_DRIVER_FULL" - | VIR_ERR_CALL_FAILED -> "VIR_ERR_CALL_FAILED" - | VIR_ERR_XML_ERROR -> "VIR_ERR_XML_ERROR" - | VIR_ERR_DOM_EXIST -> "VIR_ERR_DOM_EXIST" - | VIR_ERR_OPERATION_DENIED -> "VIR_ERR_OPERATION_DENIED" - | VIR_ERR_OPEN_FAILED -> "VIR_ERR_OPEN_FAILED" - | VIR_ERR_READ_FAILED -> "VIR_ERR_READ_FAILED" - | VIR_ERR_PARSE_FAILED -> "VIR_ERR_PARSE_FAILED" - | VIR_ERR_CONF_SYNTAX -> "VIR_ERR_CONF_SYNTAX" - | VIR_ERR_WRITE_FAILED -> "VIR_ERR_WRITE_FAILED" - | VIR_ERR_XML_DETAIL -> "VIR_ERR_XML_DETAIL" - | VIR_ERR_INVALID_NETWORK -> "VIR_ERR_INVALID_NETWORK" - | VIR_ERR_NETWORK_EXIST -> "VIR_ERR_NETWORK_EXIST" - | VIR_ERR_SYSTEM_ERROR -> "VIR_ERR_SYSTEM_ERROR" - | VIR_ERR_RPC -> "VIR_ERR_RPC" - | VIR_ERR_GNUTLS_ERROR -> "VIR_ERR_GNUTLS_ERROR" - | VIR_WAR_NO_NETWORK -> "VIR_WAR_NO_NETWORK" - | VIR_ERR_NO_DOMAIN -> "VIR_ERR_NO_DOMAIN" - | VIR_ERR_NO_NETWORK -> "VIR_ERR_NO_NETWORK" - | VIR_ERR_INVALID_MAC -> "VIR_ERR_INVALID_MAC" - | VIR_ERR_AUTH_FAILED -> "VIR_ERR_AUTH_FAILED" - | VIR_ERR_INVALID_STORAGE_POOL -> "VIR_ERR_INVALID_STORAGE_POOL" - | VIR_ERR_INVALID_STORAGE_VOL -> "VIR_ERR_INVALID_STORAGE_VOL" - | VIR_WAR_NO_STORAGE -> "VIR_WAR_NO_STORAGE" - | VIR_ERR_NO_STORAGE_POOL -> "VIR_ERR_NO_STORAGE_POOL" - | VIR_ERR_NO_STORAGE_VOL -> "VIR_ERR_NO_STORAGE_VOL" - | VIR_ERR_UNKNOWN i -> "VIR_ERR_" ^ string_of_int i - - type domain = - | VIR_FROM_NONE - | VIR_FROM_XEN - | VIR_FROM_XEND - | VIR_FROM_XENSTORE - | VIR_FROM_SEXPR - | VIR_FROM_XML - | VIR_FROM_DOM - | VIR_FROM_RPC - | VIR_FROM_PROXY - | VIR_FROM_CONF - | VIR_FROM_QEMU - | VIR_FROM_NET - | VIR_FROM_TEST - | VIR_FROM_REMOTE - | VIR_FROM_OPENVZ - | VIR_FROM_XENXM - | VIR_FROM_STATS_LINUX - | VIR_FROM_STORAGE - | VIR_FROM_UNKNOWN of int - - let string_of_domain = function - | VIR_FROM_NONE -> "VIR_FROM_NONE" - | VIR_FROM_XEN -> "VIR_FROM_XEN" - | VIR_FROM_XEND -> "VIR_FROM_XEND" - | VIR_FROM_XENSTORE -> "VIR_FROM_XENSTORE" - | VIR_FROM_SEXPR -> "VIR_FROM_SEXPR" - | VIR_FROM_XML -> "VIR_FROM_XML" - | VIR_FROM_DOM -> "VIR_FROM_DOM" - | VIR_FROM_RPC -> "VIR_FROM_RPC" - | VIR_FROM_PROXY -> "VIR_FROM_PROXY" - | VIR_FROM_CONF -> "VIR_FROM_CONF" - | VIR_FROM_QEMU -> "VIR_FROM_QEMU" - | VIR_FROM_NET -> "VIR_FROM_NET" - | VIR_FROM_TEST -> "VIR_FROM_TEST" - | VIR_FROM_REMOTE -> "VIR_FROM_REMOTE" - | VIR_FROM_OPENVZ -> "VIR_FROM_OPENVZ" - | VIR_FROM_XENXM -> "VIR_FROM_XENXM" - | VIR_FROM_STATS_LINUX -> "VIR_FROM_STATS_LINUX" - | VIR_FROM_STORAGE -> "VIR_FROM_STORAGE" - | VIR_FROM_UNKNOWN i -> "VIR_FROM_" ^ string_of_int i - - type level = - | VIR_ERR_NONE - | VIR_ERR_WARNING - | VIR_ERR_ERROR - | VIR_ERR_UNKNOWN_LEVEL of int - - let string_of_level = function - | VIR_ERR_NONE -> "VIR_ERR_NONE" - | VIR_ERR_WARNING -> "VIR_ERR_WARNING" - | VIR_ERR_ERROR -> "VIR_ERR_ERROR" - | VIR_ERR_UNKNOWN_LEVEL i -> "VIR_ERR_LEVEL_" ^ string_of_int i - - type t = { - code : code; - domain : domain; - message : string option; - level : level; - conn : ro Connect.t option; - dom : ro Domain.t option; - str1 : string option; - str2 : string option; - str3 : string option; - int1 : int32; - int2 : int32; - net : ro Network.t option; - } - - let to_string { code = code; domain = domain; message = message } = - let buf = Buffer.create 128 in - Buffer.add_string buf "libvirt: "; - Buffer.add_string buf (string_of_code code); - Buffer.add_string buf ": "; - Buffer.add_string buf (string_of_domain domain); - Buffer.add_string buf ": "; - (match message with Some msg -> Buffer.add_string buf msg | None -> ()); - Buffer.contents buf - - external get_last_error : unit -> t option = "ocaml_libvirt_virterror_get_last_error" - external get_last_conn_error : [>`R] Connect.t -> t option = "ocaml_libvirt_virterror_get_last_conn_error" - external reset_last_error : unit -> unit = "ocaml_libvirt_virterror_reset_last_error" - external reset_last_conn_error : [>`R] Connect.t -> unit = "ocaml_libvirt_virterror_reset_last_conn_error" - - let no_error () = - { code = VIR_ERR_OK; domain = VIR_FROM_NONE; message = None; - level = VIR_ERR_NONE; conn = None; dom = None; - str1 = None; str2 = None; str3 = None; - int1 = 0_l; int2 = 0_l; net = None } -end - -exception Virterror of Virterror.t -exception Not_supported of string - -(* Initialization. *) -external c_init : unit -> unit = "ocaml_libvirt_init" -let () = - Callback.register_exception - "ocaml_libvirt_virterror" (Virterror (Virterror.no_error ())); - Callback.register_exception - "ocaml_libvirt_not_supported" (Not_supported ""); - c_init () diff --git a/libvirt/libvirt.mli b/libvirt/libvirt.mli deleted file mode 100644 index af372af..0000000 --- a/libvirt/libvirt.mli +++ /dev/null @@ -1,994 +0,0 @@ -(** OCaml bindings for libvirt. *) -(* (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA -*) - -(** - {2 Introduction and examples} - - This is a set of bindings for writing OCaml programs to - manage virtual machines through {{:http://libvirt.org/}libvirt}. - - {3 Using libvirt interactively} - - Using the interactive toplevel: - -{v -$ ocaml -I +libvirt - Objective Caml version 3.10.0 - -# #load "unix.cma";; -# #load "mllibvirt.cma";; -# let name = "test:///default";; -val name : string = "test:///default" -# let conn = Libvirt.Connect.connect_readonly ~name () ;; -val conn : Libvirt.ro Libvirt.Connect.t = <abstr> -# Libvirt.Connect.get_node_info conn;; - : Libvirt.Connect.node_info = -{Libvirt.Connect.model = "i686"; Libvirt.Connect.memory = 3145728L; - Libvirt.Connect.cpus = 16; Libvirt.Connect.mhz = 1400; - Libvirt.Connect.nodes = 2; Libvirt.Connect.sockets = 2; - Libvirt.Connect.cores = 2; Libvirt.Connect.threads = 2} -v} - - {3 Compiling libvirt programs} - - This command compiles a program to native code: - -{v -ocamlopt -I +libvirt mllibvirt.cmxa list_domains.ml -o list_domains -v} - - {3 Example: Connect to the hypervisor} - - The main modules are {!Libvirt.Connect}, {!Libvirt.Domain} and - {!Libvirt.Network} corresponding respectively to the - {{:http://libvirt.org/html/libvirt-libvirt.html}virConnect*, virDomain* and virNetwork* functions from libvirt}. - For brevity I usually rename these modules like this: - -{v -module C = Libvirt.Connect -module D = Libvirt.Domain -module N = Libvirt.Network -v} - - To get a connection handle, assuming a Xen hypervisor: - -{v -let name = "xen:///" -let conn = C.connect_readonly ~name () -v} - - {3 Example: List running domains} - -{v -open Printf - -let n = C.num_of_domains conn in -let ids = C.list_domains conn n in -let domains = Array.map (D.lookup_by_id conn) ids in -Array.iter ( - fun dom -> - printf "%8d %s\n%!" (D.get_id dom) (D.get_name dom) -) domains; -v} - - {3 Example: List inactive domains} - -{v -let n = C.num_of_defined_domains conn in -let names = C.list_defined_domains conn n in -Array.iter ( - fun name -> - printf "inactive %s\n%!" name -) names; -v} - - {3 Example: Print node info} - -{v -let node_info = C.get_node_info conn in -printf "model = %s\n" node_info.C.model; -printf "memory = %Ld K\n" node_info.C.memory; -printf "cpus = %d\n" node_info.C.cpus; -printf "mhz = %d\n" node_info.C.mhz; -printf "nodes = %d\n" node_info.C.nodes; -printf "sockets = %d\n" node_info.C.sockets; -printf "cores = %d\n" node_info.C.cores; -printf "threads = %d\n%!" node_info.C.threads; - -let hostname = C.get_hostname conn in -printf "hostname = %s\n%!" hostname; - -let uri = C.get_uri conn in -printf "uri = %s\n%!" uri -v} - -*) - - -(** {2 Programming issues} - - {3 General safety issues} - - Memory allocation / automatic garbage collection of all libvirt - objects should be completely safe (except in the specific - virterror case noted below). If you find any safety issues or if your - pure OCaml program ever segfaults, please contact the author. - - You can force a libvirt object to be freed early by calling - the [close] function on the object. This shouldn't affect - the safety of garbage collection and should only be used when - you want to explicitly free memory. Note that explicitly - closing a connection object does nothing if there are still - unclosed domain or network objects referencing it. - - Note that even though you hold open (eg) a domain object, that - doesn't mean that the domain (virtual machine) actually exists. - The domain could have been shut down or deleted by another user. - Thus domain objects can through odd exceptions at any time. - This is just the nature of virtualisation. - - Virterror has a specific design error which means that the - objects embedded in a virterror exception message are only - valid as long as the connection handle is still open. This - is a design flaw in the C code of libvirt and we cannot fix - or work around it in the OCaml bindings. - - {3 Backwards and forwards compatibility} - - OCaml-libvirt is backwards and forwards compatible with - any libvirt >= 0.2.1. One consequence of this is that - your program can dynamically link to a {i newer} version of - libvirt than it was compiled with, and it should still - work. - - When we link to an older version of libvirt.so, there may - be missing functions. If ocaml-libvirt was compiled with - gcc, then these are turned into OCaml {!Libvirt.Not_supported} - exceptions. - - We don't support libvirt < 0.2.1, and never will so don't ask us. - - {3 Threads} - - You can issue multiple concurrent libvirt requests in - different threads. However you must follow this rule: - Each thread must have its own separate libvirt connection, {i or} - you must implement your own mutex scheme to ensure that no - two threads can ever make concurrent calls using the same - libvirt connection. - - (Note that multithreaded code is not well tested. If you find - bugs please report them.) - - {3 Initialisation} - - Libvirt requires all callers to call virInitialize before - using the library. This is done automatically for you by - these bindings when the program starts up, and we believe - that the way this is done is safe. - - {2 Reference} -*) - -type uuid = string - (** This is a "raw" UUID, ie. a packed string of bytes. *) - -type xml = string - (** Type of XML (an uninterpreted string of bytes). Use PXP, expat, - xml-light, etc. if you want to do anything useful with the XML. - *) - -type filename = string - (** A filename. *) - -val get_version : ?driver:string -> unit -> int * int - (** [get_version ()] returns the library version in the first part - of the tuple, and [0] in the second part. - - [get_version ~driver ()] returns the library version in the first - part of the tuple, and the version of the driver called [driver] - in the second part. - - The version numbers are encoded as - 1,000,000 * major + 1,000 * minor + release. - *) - -val uuid_length : int - (** Length of packed UUIDs. *) - -val uuid_string_length : int - (** Length of UUID strings. *) - -type rw = [`R|`W] -type ro = [`R] - (** These - {{:http://caml.inria.fr/pub/ml-archives/caml-list/2004/07/80683af867cce6bf8fff273973f70c95.en.html}phantom types} - are used to ensure the type-safety of read-only - versus read-write connections. - - All connection/domain/etc. objects are marked with - a phantom read-write or read-only type, and trying to - pass a read-only object into a function which could - mutate the object will cause a compile time error. - - Each module provides a function like {!Libvirt.Connect.const} - to demote a read-write object into a read-only object. The - opposite operation is, of course, not allowed. - - If you want to handle both read-write and read-only - connections at runtime, use a variant similar to this: -{v -type conn_t = - | No_connection - | Read_only of Libvirt.ro Libvirt.Connect.t - | Read_write of Libvirt.rw Libvirt.Connect.t -v} - See also the source of [mlvirsh]. - *) - -type ('a, 'b) job_t -(** Forward definition of {!Job.t} to avoid recursive module dependencies. *) - -(** {3 Connections} *) - -module Connect : -sig - type 'rw t - (** Connection. Read-only connections have type [ro Connect.t] and - read-write connections have type [rw Connect.t]. - *) - - type node_info = { - model : string; (** CPU model *) - memory : int64; (** memory size in kilobytes *) - cpus : int; (** number of active CPUs *) - mhz : int; (** expected CPU frequency *) - nodes : int; (** number of NUMA nodes (1 = UMA) *) - sockets : int; (** number of CPU sockets per node *) - cores : int; (** number of cores per socket *) - threads : int; (** number of threads per core *) - } - - val connect : ?name:string -> unit -> rw t - val connect_readonly : ?name:string -> unit -> ro t - (** [connect ~name ()] connects to the hypervisor with URI [name]. - - [connect ()] connects to the default hypervisor. - - [connect_readonly] is the same but connects in read-only mode. - *) - - val close : [>`R] t -> unit - (** [close conn] closes and frees the connection object in memory. - - The connection is automatically closed if it is garbage - collected. This function just forces it to be closed - and freed right away. - *) - - val get_type : [>`R] t -> string - (** Returns the name of the driver (hypervisor). *) - - val get_version : [>`R] t -> int - (** Returns the driver version - [major * 1_000_000 + minor * 1000 + release] - *) - val get_hostname : [>`R] t -> string - (** Returns the hostname of the physical server. *) - val get_uri : [>`R] t -> string - (** Returns the canonical connection URI. *) - val get_max_vcpus : [>`R] t -> ?type_:string -> unit -> int - (** Returns the maximum number of virtual CPUs - supported by a guest VM of a particular type. *) - val list_domains : [>`R] t -> int -> int array - (** [list_domains conn max] returns the running domain IDs, - up to a maximum of [max] entries. - Call {!num_of_domains} first to get a value for [max]. - *) - val num_of_domains : [>`R] t -> int - (** Returns the number of running domains. *) - val get_capabilities : [>`R] t -> xml - (** Returns the hypervisor capabilities (as XML). *) - val num_of_defined_domains : [>`R] t -> int - (** Returns the number of inactive (shutdown) domains. *) - val list_defined_domains : [>`R] t -> int -> string array - (** [list_defined_domains conn max] - returns the names of the inactive domains, up to - a maximum of [max] entries. - Call {!num_of_defined_domains} first to get a value for [max]. - *) - val num_of_networks : [>`R] t -> int - (** Returns the number of networks. *) - val list_networks : [>`R] t -> int -> string array - (** [list_networks conn max] - returns the names of the networks, up to a maximum - of [max] entries. - Call {!num_of_networks} first to get a value for [max]. - *) - val num_of_defined_networks : [>`R] t -> int - (** Returns the number of inactive networks. *) - val list_defined_networks : [>`R] t -> int -> string array - (** [list_defined_networks conn max] - returns the names of the inactive networks, up to a maximum - of [max] entries. - Call {!num_of_defined_networks} first to get a value for [max]. - *) - - val num_of_pools : [>`R] t -> int - (** Returns the number of storage pools. *) - val list_pools : [>`R] t -> int -> string array - (** Return list of storage pools. *) - val num_of_defined_pools : [>`R] t -> int - (** Returns the number of storage pools. *) - val list_defined_pools : [>`R] t -> int -> string array - (** Return list of storage pools. *) - - (* The name of this function is inconsistent, but the inconsistency - * is really in libvirt itself. - *) - val get_node_info : [>`R] t -> node_info - (** Return information about the physical server. *) - - val node_get_free_memory : [> `R] t -> int64 - (** - [node_get_free_memory conn] - returns the amount of free memory (not allocated to any guest) - in the machine. - *) - - val node_get_cells_free_memory : [> `R] t -> int -> int -> int64 array - (** - [node_get_cells_free_memory conn start max] - returns the amount of free memory on each NUMA cell in kilobytes. - [start] is the first cell for which we return free memory. - [max] is the maximum number of cells for which we return free memory. - Returns an array of up to [max] entries in length. - *) - - val maxcpus_of_node_info : node_info -> int - (** Calculate the total number of CPUs supported (but not necessarily - active) in the host. - *) - - val cpumaplen : int -> int - (** Calculate the length (in bytes) required to store the complete - CPU map between a single virtual and all physical CPUs of a domain. - *) - - val use_cpu : string -> int -> unit - (** [use_cpu cpumap cpu] marks [cpu] as usable in [cpumap]. *) - val unuse_cpu : string -> int -> unit - (** [unuse_cpu cpumap cpu] marks [cpu] as not usable in [cpumap]. *) - val cpu_usable : string -> int -> int -> int -> bool - (** [cpu_usable cpumaps maplen vcpu cpu] checks returns true iff the - [cpu] is usable by [vcpu]. *) - - external const : [>`R] t -> ro t = "%identity" - (** [const conn] turns a read/write connection into a read-only - connection. Note that the opposite operation is impossible. - *) -end - (** Module dealing with connections. [Connect.t] is the - connection object. *) - -(** {3 Domains} *) - -module Domain : -sig - type 'rw t - (** Domain handle. Read-only handles have type [ro Domain.t] and - read-write handles have type [rw Domain.t]. - *) - - type state = - | InfoNoState | InfoRunning | InfoBlocked | InfoPaused - | InfoShutdown | InfoShutoff | InfoCrashed - - type info = { - state : state; (** running state *) - max_mem : int64; (** maximum memory in kilobytes *) - memory : int64; (** memory used in kilobytes *) - nr_virt_cpu : int; (** number of virtual CPUs *) - cpu_time : int64; (** CPU time used in nanoseconds *) - } - - type vcpu_state = VcpuOffline | VcpuRunning | VcpuBlocked - - type vcpu_info = { - number : int; (** virtual CPU number *) - vcpu_state : vcpu_state; (** state *) - vcpu_time : int64; (** CPU time used in nanoseconds *) - cpu : int; (** real CPU number, -1 if offline *) - } - - type sched_param = string * sched_param_value - and sched_param_value = - | SchedFieldInt32 of int32 | SchedFieldUInt32 of int32 - | SchedFieldInt64 of int64 | SchedFieldUInt64 of int64 - | SchedFieldFloat of float | SchedFieldBool of bool - - type migrate_flag = Live - - type block_stats = { - rd_req : int64; - rd_bytes : int64; - wr_req : int64; - wr_bytes : int64; - errs : int64; - } - - type interface_stats = { - rx_bytes : int64; - rx_packets : int64; - rx_errs : int64; - rx_drop : int64; - tx_bytes : int64; - tx_packets : int64; - tx_errs : int64; - tx_drop : int64; - } - - val create_linux : [>`W] Connect.t -> xml -> rw t - (** Create a new guest domain (not necessarily a Linux one) - from the given XML. - *) - val create_linux_job : [>`W] Connect.t -> xml -> ([`Domain], rw) job_t - (** Asynchronous domain creation. *) - val lookup_by_id : 'a Connect.t -> int -> 'a t - (** Lookup a domain by ID. *) - val lookup_by_uuid : 'a Connect.t -> uuid -> 'a t - (** Lookup a domain by UUID. This uses the packed byte array UUID. *) - val lookup_by_uuid_string : 'a Connect.t -> string -> 'a t - (** Lookup a domain by (string) UUID. *) - val lookup_by_name : 'a Connect.t -> string -> 'a t - (** Lookup a domain by name. *) - val destroy : [>`W] t -> unit - (** Abruptly destroy a domain. *) - val free : [>`R] t -> unit - (** [free domain] frees the domain object in memory. - - The domain object is automatically freed if it is garbage - collected. This function just forces it to be freed right - away. - *) - - val suspend : [>`W] t -> unit - (** Suspend a domain. *) - val resume : [>`W] t -> unit - (** Resume a domain. *) - val save : [>`W] t -> filename -> unit - (** Suspend a domain, then save it to the file. *) - val save_job : [>`W] t -> filename -> ([`Domain_nocreate], rw) job_t - (** Asynchronous domain suspend. *) - val restore : [>`W] Connect.t -> filename -> unit - (** Restore a domain from a file. *) - val restore_job : [>`W] Connect.t -> filename -> ([`Domain_nocreate], rw) job_t - (** Asynchronous domain restore. *) - val core_dump : [>`W] t -> filename -> unit - (** Force a domain to core dump to the named file. *) - val core_dump_job : [>`W] t -> filename -> ([`Domain_nocreate], rw) job_t - (** Asynchronous core dump. *) - val shutdown : [>`W] t -> unit - (** Shutdown a domain. *) - val reboot : [>`W] t -> unit - (** Reboot a domain. *) - val get_name : [>`R] t -> string - (** Get the domain name. *) - val get_uuid : [>`R] t -> uuid - (** Get the domain UUID (as a packed byte array). *) - val get_uuid_string : [>`R] t -> string - (** Get the domain UUID (as a printable string). *) - val get_id : [>`R] t -> int - (** [getid dom] returns the ID of the domain. - - Do not call this on a defined but not running domain. Those - domains don't have IDs, and you'll get an error here. - *) - - val get_os_type : [>`R] t -> string - (** Get the operating system type. *) - val get_max_memory : [>`R] t -> int64 - (** Get the maximum memory allocation. *) - val set_max_memory : [>`W] t -> int64 -> unit - (** Set the maximum memory allocation. *) - val set_memory : [>`W] t -> int64 -> unit - (** Set the normal memory allocation. *) - val get_info : [>`R] t -> info - (** Get information about a domain. *) - val get_xml_desc : [>`R] t -> xml - (** Get the XML description of a domain. *) - val get_scheduler_type : [>`R] t -> string * int - (** Get the scheduler type. *) - val get_scheduler_parameters : [>`R] t -> int -> sched_param array - (** Get the array of scheduler parameters. *) - val set_scheduler_parameters : [>`W] t -> sched_param array -> unit - (** Set the array of scheduler parameters. *) - val define_xml : [>`W] Connect.t -> xml -> rw t - (** Define a new domain (but don't start it up) from the XML. *) - val undefine : [>`W] t -> unit - (** Undefine a domain - removes its configuration. *) - val create : [>`W] t -> unit - (** Launch a defined (inactive) domain. *) - val create_job : [>`W] t -> ([`Domain_nocreate], rw) job_t - (** Asynchronous launch domain. *) - val get_autostart : [>`R] t -> bool - (** Get the autostart flag for a domain. *) - val set_autostart : [>`W] t -> bool -> unit - (** Set the autostart flag for a domain. *) - val set_vcpus : [>`W] t -> int -> unit - (** Change the number of vCPUs available to a domain. *) - val pin_vcpu : [>`W] t -> int -> string -> unit - (** [pin_vcpu dom vcpu bitmap] pins a domain vCPU to a bitmap of physical - CPUs. See the libvirt documentation for details of the - layout of the bitmap. *) - val get_vcpus : [>`R] t -> int -> int -> int * vcpu_info array * string - (** [get_vcpus dom maxinfo maplen] returns the pinning information - for a domain. See the libvirt documentation for details - of the array and bitmap returned from this function. - *) - val get_max_vcpus : [>`R] t -> int - (** Returns the maximum number of vCPUs supported for this domain. *) - val attach_device : [>`W] t -> xml -> unit - (** Attach a device (described by the device XML) to a domain. *) - val detach_device : [>`W] t -> xml -> unit - (** Detach a device (described by the device XML) from a domain. *) - - val migrate : [>`W] t -> [>`W] Connect.t -> migrate_flag list -> - ?dname:string -> ?uri:string -> ?bandwidth:int -> unit -> rw t - (** [migrate dom dconn flags ()] migrates a domain to a - destination host described by [dconn]. - - The optional flag [?dname] is used to rename the domain. - - The optional flag [?uri] is used to route the migration. - - The optional flag [?bandwidth] is used to limit the bandwidth - used for migration (in Mbps). *) - - val block_stats : [>`R] t -> string -> block_stats - (** Returns block device stats. *) - val interface_stats : [>`R] t -> string -> interface_stats - (** Returns network interface stats. *) - - external const : [>`R] t -> ro t = "%identity" - (** [const dom] turns a read/write domain handle into a read-only - domain handle. Note that the opposite operation is impossible. - *) -end - (** Module dealing with domains. [Domain.t] is the - domain object. *) - -(** {3 Networks} *) - -module Network : -sig - type 'rw t - (** Network handle. Read-only handles have type [ro Network.t] and - read-write handles have type [rw Network.t]. - *) - - val lookup_by_name : 'a Connect.t -> string -> 'a t - (** Lookup a network by name. *) - val lookup_by_uuid : 'a Connect.t -> uuid -> 'a t - (** Lookup a network by (packed) UUID. *) - val lookup_by_uuid_string : 'a Connect.t -> string -> 'a t - (** Lookup a network by UUID string. *) - val create_xml : [>`W] Connect.t -> xml -> rw t - (** Create a network. *) - val create_xml_job : [>`W] Connect.t -> xml -> ([`Network], rw) job_t - (** Asynchronous create network. *) - val define_xml : [>`W] Connect.t -> xml -> rw t - (** Define but don't activate a network. *) - val undefine : [>`W] t -> unit - (** Undefine configuration of a network. *) - val create : [>`W] t -> unit - (** Start up a defined (inactive) network. *) - val create_job : [>`W] t -> ([`Network_nocreate], rw) job_t - (** Asynchronous start network. *) - val destroy : [>`W] t -> unit - (** Destroy a network. *) - val free : [>`R] t -> unit - (** [free network] frees the network object in memory. - - The network object is automatically freed if it is garbage - collected. This function just forces it to be freed right - away. - *) - - val get_name : [>`R] t -> string - (** Get network name. *) - val get_uuid : [>`R] t -> uuid - (** Get network packed UUID. *) - val get_uuid_string : [>`R] t -> string - (** Get network UUID as a printable string. *) - val get_xml_desc : [>`R] t -> xml - (** Get XML description of a network. *) - val get_bridge_name : [>`R] t -> string - (** Get bridge device name of a network. *) - val get_autostart : [>`R] t -> bool - (** Get the autostart flag for a network. *) - val set_autostart : [>`W] t -> bool -> unit - (** Set the autostart flag for a network. *) - - external const : [>`R] t -> ro t = "%identity" - (** [const network] turns a read/write network handle into a read-only - network handle. Note that the opposite operation is impossible. - *) -end - (** Module dealing with networks. [Network.t] is the - network object. *) - -(** {3 Storage pools} *) - -module Pool : -sig - type 'rw t - (** Storage pool handle. *) - - type pool_state = Inactive | Building | Running | Degraded - (** State of the storage pool. *) - - type pool_build_flags = New | Repair | Resize - (** Flags for creating a storage pool. *) - - type pool_delete_flags = Normal | Zeroed - (** Flags for deleting a storage pool. *) - - type pool_info = { - state : pool_state; (** Pool state. *) - capacity : int64; (** Logical size in bytes. *) - allocation : int64; (** Currently allocated in bytes. *) - available : int64; (** Remaining free space bytes. *) - } - - val lookup_by_name : 'a Connect.t -> string -> 'a t - val lookup_by_uuid : 'a Connect.t -> uuid -> 'a t - val lookup_by_uuid_string : 'a Connect.t -> string -> 'a t - (** Look up a storage pool by name, UUID or UUID string. *) - - val create_xml : [>`W] Connect.t -> xml -> rw t - (** Create a storage pool. *) - val define_xml : [>`W] Connect.t -> xml -> rw t - (** Define but don't activate a storage pool. *) - val build : [>`W] t -> pool_build_flags -> unit - (** Build a storage pool. *) - val undefine : [>`W] t -> unit - (** Undefine configuration of a storage pool. *) - val create : [>`W] t -> unit - (** Start up a defined (inactive) storage pool. *) - val destroy : [>`W] t -> unit - (** Destroy a storage pool. *) - val delete : [>`W] t -> unit - (** Delete a storage pool. *) - val free : [>`R] t -> unit - (** Free a storage pool object in memory. - - The storage pool object is automatically freed if it is garbage - collected. This function just forces it to be freed right - away. - *) - val refresh : [`R] t -> unit - (** Refresh the list of volumes in the storage pool. *) - - val get_name : [`R] t -> string - (** Name of the pool. *) - val get_uuid : [`R] t -> uuid - (** Get the UUID (as a packed byte array). *) - val get_uuid_string : [`R] t -> string - (** Get the UUID (as a printable string). *) - val get_info : [`R] t -> pool_info - (** Get information about the pool. *) - val get_xml_desc : [`R] t -> xml - (** Get the XML description. *) - val get_autostart : [`R] t -> bool - (** Get the autostart flag for the storage pool. *) - val set_autostart : [`W] t -> bool -> unit - (** Set the autostart flag for the storage pool. *) - - val num_of_volumes : [`R] t -> int - (** Returns the number of storage volumes within the storage pool. *) - val list_volumes : [`R] t -> int -> string array - (** Return list of storage volumes. *) - - external const : [>`R] t -> ro t = "%identity" - (** [const conn] turns a read/write storage pool into a read-only - pool. Note that the opposite operation is impossible. - *) -end - (** Module dealing with storage pools. *) - -(** {3 Storage volumes} *) - -module Volume : -sig - type 'rw t - (** Storage volume handle. *) - - type vol_type = File | Block - (** Type of a storage volume. *) - - type vol_delete_flags = Normal | Zeroed - (** Flags for deleting a storage volume. *) - - type vol_info = { - typ : vol_type; (** Type of storage volume. *) - capacity : int64; (** Logical size in bytes. *) - allocation : int64; (** Currently allocated in bytes. *) - } - - val lookup_by_name : 'a Pool.t -> string -> 'a t - val lookup_by_key : 'a Connect.t -> string -> 'a t - val lookup_by_path : 'a Connect.t -> string -> 'a t - (** Look up a storage volume by name, key or path volume. *) - - val pool_of_volume : 'a t -> 'a Pool.t - (** Get the storage pool containing this volume. *) - - val get_name : [`R] t -> string - (** Name of the volume. *) - val get_key : [`R] t -> string - (** Key of the volume. *) - val get_path : [`R] t -> string - (** Path of the volume. *) - val get_info : [`R] t -> vol_info - (** Get information about the storage volume. *) - val get_xml_desc : [`R] t -> xml - (** Get the XML description. *) - - val create_xml : [`W] Pool.t -> xml -> unit - (** Create a storage volume. *) - val delete : [`W] t -> unit - (** Delete a storage volume. *) - val free : [>`R] t -> unit - (** Free a storage volume object in memory. - - The storage volume object is automatically freed if it is garbage - collected. This function just forces it to be freed right - away. - *) - - external const : [>`R] t -> ro t = "%identity" - (** [const conn] turns a read/write storage volume into a read-only - volume. Note that the opposite operation is impossible. - *) -end - (** Module dealing with storage volumes. *) - -(** {3 Jobs and asynchronous processing} *) - -module Job : -sig - type ('jobclass, 'rw) t = ('jobclass, 'rw) job_t - (** A background asynchronous job. - - Jobs represent a pending operation such as domain creation. - The possible types for a job are: - -{v -(`Domain, `W) Job.t Job creating a new domain -(`Domain_nocreate, `W) Job.t Job acting on an existing domain -(`Network, `W) Job.t Job creating a new network -(`Network_nocreate, `W) Job.t Job acting on an existing network -v} - *) - - type job_type = Bounded | Unbounded - (** A Bounded job is one where we can estimate time to completion. *) - - type job_state = Running | Complete | Failed | Cancelled - (** State of the job. *) - - type job_info = { - typ : job_type; (** Job type (Bounded, Unbounded) *) - state : job_state; (** Job state (Running, etc.) *) - running_time : int; (** Actual running time (seconds) *) - (** The following fields are only available in Bounded jobs: *) - remaining_time : int; (** Estimated time left (seconds) *) - percent_complete : int (** Estimated percent complete *) - } - - val get_info : ('a,'b) t -> job_info - (** Get information and status about the job. *) - - val get_domain : ([`Domain], 'a) t -> 'a Domain.t - (** Get the completed domain from a job. - - You should only call it on a job in state Complete. *) - - val get_network : ([`Network], 'a) t -> 'a Network.t - (** Get the completed network from a job. - - You should only call it on a job in state Complete. *) - - val cancel : ('a,'b) t -> unit - (** Cancel a job. *) - - val free : ('a, [>`R]) t -> unit - (** Free a job object in memory. - - The job object is automatically freed if it is garbage - collected. This function just forces it to be freed right - away. - *) - - external const : ('a, [>`R]) t -> ('a, ro) t = "%identity" - (** [const conn] turns a read/write job into a read-only - job. Note that the opposite operation is impossible. - *) -end - (** Module dealing with asynchronous jobs. *) - -(** {3 Error handling and exceptions} *) - -module Virterror : -sig - type code = - | VIR_ERR_OK - | VIR_ERR_INTERNAL_ERROR - | VIR_ERR_NO_MEMORY - | VIR_ERR_NO_SUPPORT - | VIR_ERR_UNKNOWN_HOST - | VIR_ERR_NO_CONNECT - | VIR_ERR_INVALID_CONN - | VIR_ERR_INVALID_DOMAIN - | VIR_ERR_INVALID_ARG - | VIR_ERR_OPERATION_FAILED - | VIR_ERR_GET_FAILED - | VIR_ERR_POST_FAILED - | VIR_ERR_HTTP_ERROR - | VIR_ERR_SEXPR_SERIAL - | VIR_ERR_NO_XEN - | VIR_ERR_XEN_CALL - | VIR_ERR_OS_TYPE - | VIR_ERR_NO_KERNEL - | VIR_ERR_NO_ROOT - | VIR_ERR_NO_SOURCE - | VIR_ERR_NO_TARGET - | VIR_ERR_NO_NAME - | VIR_ERR_NO_OS - | VIR_ERR_NO_DEVICE - | VIR_ERR_NO_XENSTORE - | VIR_ERR_DRIVER_FULL - | VIR_ERR_CALL_FAILED - | VIR_ERR_XML_ERROR - | VIR_ERR_DOM_EXIST - | VIR_ERR_OPERATION_DENIED - | VIR_ERR_OPEN_FAILED - | VIR_ERR_READ_FAILED - | VIR_ERR_PARSE_FAILED - | VIR_ERR_CONF_SYNTAX - | VIR_ERR_WRITE_FAILED - | VIR_ERR_XML_DETAIL - | VIR_ERR_INVALID_NETWORK - | VIR_ERR_NETWORK_EXIST - | VIR_ERR_SYSTEM_ERROR - | VIR_ERR_RPC - | VIR_ERR_GNUTLS_ERROR - | VIR_WAR_NO_NETWORK - | VIR_ERR_NO_DOMAIN - | VIR_ERR_NO_NETWORK - | VIR_ERR_INVALID_MAC - | VIR_ERR_AUTH_FAILED - | VIR_ERR_INVALID_STORAGE_POOL - | VIR_ERR_INVALID_STORAGE_VOL - | VIR_WAR_NO_STORAGE - | VIR_ERR_NO_STORAGE_POOL - | VIR_ERR_NO_STORAGE_VOL - (* ^^ NB: If you add a variant you MUST edit - libvirt_c_epilogue.c:MAX_VIR_* *) - | VIR_ERR_UNKNOWN of int - (** See [<libvirt/virterror.h>] for meaning of these codes. *) - - val string_of_code : code -> string - - type domain = - | VIR_FROM_NONE - | VIR_FROM_XEN - | VIR_FROM_XEND - | VIR_FROM_XENSTORE - | VIR_FROM_SEXPR - | VIR_FROM_XML - | VIR_FROM_DOM - | VIR_FROM_RPC - | VIR_FROM_PROXY - | VIR_FROM_CONF - | VIR_FROM_QEMU - | VIR_FROM_NET - | VIR_FROM_TEST - | VIR_FROM_REMOTE - | VIR_FROM_OPENVZ - | VIR_FROM_XENXM - | VIR_FROM_STATS_LINUX - | VIR_FROM_STORAGE - (* ^^ NB: If you add a variant you MUST edit - libvirt_c_epilogue.c: MAX_VIR_* *) - | VIR_FROM_UNKNOWN of int - (** Subsystem / driver which produced the error. *) - - val string_of_domain : domain -> string - - type level = - | VIR_ERR_NONE - | VIR_ERR_WARNING - | VIR_ERR_ERROR - (* ^^ NB: If you add a variant you MUST edit libvirt_c.c: MAX_VIR_* *) - | VIR_ERR_UNKNOWN_LEVEL of int - (** No error, a warning or an error. *) - - val string_of_level : level -> string - - type t = { - code : code; (** Error code. *) - domain : domain; (** Origin of the error. *) - message : string option; (** Human-readable message. *) - level : level; (** Error or warning. *) - conn : ro Connect.t option; (** Associated connection. *) - dom : ro Domain.t option; (** Associated domain. *) - str1 : string option; (** Informational string. *) - str2 : string option; (** Informational string. *) - str3 : string option; (** Informational string. *) - int1 : int32; (** Informational integer. *) - int2 : int32; (** Informational integer. *) - net : ro Network.t option; (** Associated network. *) - } - (** An error object. *) - - val to_string : t -> string - (** Turn the exception into a printable string. *) - - val get_last_error : unit -> t option - val get_last_conn_error : [>`R] Connect.t -> t option - (** Get the last error at a global or connection level. - - Normally you do not need to use these functions because - the library automatically turns errors into exceptions. - *) - - val reset_last_error : unit -> unit - val reset_last_conn_error : [>`R] Connect.t -> unit - (** Reset the error at a global or connection level. - - Normally you do not need to use these functions. - *) - - val no_error : unit -> t - (** Creates an empty error message. - - Normally you do not need to use this function. - *) -end - (** Module dealing with errors. *) - -exception Virterror of Virterror.t -(** This exception can be raised by any library function that detects - an error. To get a printable error message, call - {!Virterror.to_string} on the content of this exception. -*) - -exception Not_supported of string -(** - Functions may raise - [Not_supported "virFoo"] - (where [virFoo] is the libvirt function name) if a function is - not supported at either compile or run time. This applies to - any libvirt function added after version 0.2.1. - - See also {{:http://libvirt.org/hvsupport.html}http://libvirt.org/hvsupport.html} -*) - diff --git a/libvirt/libvirt_c.c b/libvirt/libvirt_c.c deleted file mode 100644 index ca7f303..0000000 --- a/libvirt/libvirt_c.c +++ /dev/null @@ -1,3017 +0,0 @@ -/* !!! WARNING WARNING WARNING WARNING WARNING WARNING WARNING !!! - * - * THIS FILE IS AUTOMATICALLY GENERATED BY 'generator.pl'. - * - * Any changes you make to this file may be overwritten. - */ - -/* OCaml bindings for libvirt. - * (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc. - * http://libvirt.org/ - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2 of the License, or (at your option) any later version. - * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - */ - -#include "config.h" - -#include <stdio.h> -#include <stdlib.h> -#include <string.h> - -#include <libvirt/libvirt.h> -#include <libvirt/virterror.h> - -#include <caml/config.h> -#include <caml/alloc.h> -#include <caml/callback.h> -#include <caml/custom.h> -#include <caml/fail.h> -#include <caml/memory.h> -#include <caml/misc.h> -#include <caml/mlvalues.h> -#include <caml/signals.h> - -#include "libvirt_c_prologue.c" - -#include "libvirt_c_oneoffs.c" - -/* Automatically generated binding for virConnectClose. - * In generator.pl this function has signature "conn : free". - */ - -CAMLprim value -ocaml_libvirt_connect_close (value connv) -{ - CAMLparam1 (connv); - - virConnectPtr conn = Connect_val (connv); - int r; - - NONBLOCKING (r = virConnectClose (conn)); - CHECK_ERROR (r == -1, conn, "virConnectClose"); - - /* So that we don't double-free in the finalizer: */ - Connect_val (connv) = NULL; - - CAMLreturn (Val_unit); -} - -/* Automatically generated binding for virConnectGetHostname. - * In generator.pl this function has signature "conn : string". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRCONNECTGETHOSTNAME -extern char *virConnectGetHostname (virConnectPtr conn) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_connect_get_hostname (value connv) -{ - CAMLparam1 (connv); -#ifndef HAVE_VIRCONNECTGETHOSTNAME - /* Symbol virConnectGetHostname not found at compile time. */ - not_supported ("virConnectGetHostname"); - CAMLnoreturn; -#else - /* Check that the symbol virConnectGetHostname - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virConnectGetHostname); - - CAMLlocal1 (rv); - virConnectPtr conn = Connect_val (connv); - char *r; - - NONBLOCKING (r = virConnectGetHostname (conn)); - CHECK_ERROR (!r, conn, "virConnectGetHostname"); - - rv = caml_copy_string (r); - free (r); - CAMLreturn (rv); -#endif -} - -/* Automatically generated binding for virConnectGetURI. - * In generator.pl this function has signature "conn : string". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRCONNECTGETURI -extern char *virConnectGetURI (virConnectPtr conn) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_connect_get_uri (value connv) -{ - CAMLparam1 (connv); -#ifndef HAVE_VIRCONNECTGETURI - /* Symbol virConnectGetURI not found at compile time. */ - not_supported ("virConnectGetURI"); - CAMLnoreturn; -#else - /* Check that the symbol virConnectGetURI - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virConnectGetURI); - - CAMLlocal1 (rv); - virConnectPtr conn = Connect_val (connv); - char *r; - - NONBLOCKING (r = virConnectGetURI (conn)); - CHECK_ERROR (!r, conn, "virConnectGetURI"); - - rv = caml_copy_string (r); - free (r); - CAMLreturn (rv); -#endif -} - -/* Automatically generated binding for virConnectGetType. - * In generator.pl this function has signature "conn : static string". - */ - -CAMLprim value -ocaml_libvirt_connect_get_type (value connv) -{ - CAMLparam1 (connv); - - CAMLlocal1 (rv); - virConnectPtr conn = Connect_val (connv); - const char *r; - - NONBLOCKING (r = virConnectGetType (conn)); - CHECK_ERROR (!r, conn, "virConnectGetType"); - - rv = caml_copy_string (r); - CAMLreturn (rv); -} - -/* Automatically generated binding for virConnectNumOfDomains. - * In generator.pl this function has signature "conn : int". - */ - -CAMLprim value -ocaml_libvirt_connect_num_of_domains (value connv) -{ - CAMLparam1 (connv); - - virConnectPtr conn = Connect_val (connv); - int r; - - NONBLOCKING (r = virConnectNumOfDomains (conn)); - CHECK_ERROR (r == -1, conn, "virConnectNumOfDomains"); - - CAMLreturn (Val_int (r)); -} - -/* Automatically generated binding for virConnectListDomains. - * In generator.pl this function has signature "conn, int : int array". - */ - -CAMLprim value -ocaml_libvirt_connect_list_domains (value connv, value iv) -{ - CAMLparam2 (connv, iv); - - CAMLlocal1 (rv); - virConnectPtr conn = Connect_val (connv); - int i = Int_val (iv); - int ids[i], r; - - NONBLOCKING (r = virConnectListDomains (conn, ids, i)); - CHECK_ERROR (r == -1, conn, "virConnectListDomains"); - - rv = caml_alloc (r, 0); - for (i = 0; i < r; ++i) - Store_field (rv, i, Val_int (ids[i])); - - CAMLreturn (rv); -} - -/* Automatically generated binding for virConnectNumOfDefinedDomains. - * In generator.pl this function has signature "conn : int". - */ - -CAMLprim value -ocaml_libvirt_connect_num_of_defined_domains (value connv) -{ - CAMLparam1 (connv); - - virConnectPtr conn = Connect_val (connv); - int r; - - NONBLOCKING (r = virConnectNumOfDefinedDomains (conn)); - CHECK_ERROR (r == -1, conn, "virConnectNumOfDefinedDomains"); - - CAMLreturn (Val_int (r)); -} - -/* Automatically generated binding for virConnectListDefinedDomains. - * In generator.pl this function has signature "conn, int : string array". - */ - -CAMLprim value -ocaml_libvirt_connect_list_defined_domains (value connv, value iv) -{ - CAMLparam2 (connv, iv); - - CAMLlocal2 (rv, strv); - virConnectPtr conn = Connect_val (connv); - int i = Int_val (iv); - char *names[i]; - int r; - - NONBLOCKING (r = virConnectListDefinedDomains (conn, names, i)); - CHECK_ERROR (r == -1, conn, "virConnectListDefinedDomains"); - - rv = caml_alloc (r, 0); - for (i = 0; i < r; ++i) { - strv = caml_copy_string (names[i]); - Store_field (rv, i, strv); - free (names[i]); - } - - CAMLreturn (rv); -} - -/* Automatically generated binding for virConnectNumOfNetworks. - * In generator.pl this function has signature "conn : int". - */ - -CAMLprim value -ocaml_libvirt_connect_num_of_networks (value connv) -{ - CAMLparam1 (connv); - - virConnectPtr conn = Connect_val (connv); - int r; - - NONBLOCKING (r = virConnectNumOfNetworks (conn)); - CHECK_ERROR (r == -1, conn, "virConnectNumOfNetworks"); - - CAMLreturn (Val_int (r)); -} - -/* Automatically generated binding for virConnectListNetworks. - * In generator.pl this function has signature "conn, int : string array". - */ - -CAMLprim value -ocaml_libvirt_connect_list_networks (value connv, value iv) -{ - CAMLparam2 (connv, iv); - - CAMLlocal2 (rv, strv); - virConnectPtr conn = Connect_val (connv); - int i = Int_val (iv); - char *names[i]; - int r; - - NONBLOCKING (r = virConnectListNetworks (conn, names, i)); - CHECK_ERROR (r == -1, conn, "virConnectListNetworks"); - - rv = caml_alloc (r, 0); - for (i = 0; i < r; ++i) { - strv = caml_copy_string (names[i]); - Store_field (rv, i, strv); - free (names[i]); - } - - CAMLreturn (rv); -} - -/* Automatically generated binding for virConnectNumOfDefinedNetworks. - * In generator.pl this function has signature "conn : int". - */ - -CAMLprim value -ocaml_libvirt_connect_num_of_defined_networks (value connv) -{ - CAMLparam1 (connv); - - virConnectPtr conn = Connect_val (connv); - int r; - - NONBLOCKING (r = virConnectNumOfDefinedNetworks (conn)); - CHECK_ERROR (r == -1, conn, "virConnectNumOfDefinedNetworks"); - - CAMLreturn (Val_int (r)); -} - -/* Automatically generated binding for virConnectListDefinedNetworks. - * In generator.pl this function has signature "conn, int : string array". - */ - -CAMLprim value -ocaml_libvirt_connect_list_defined_networks (value connv, value iv) -{ - CAMLparam2 (connv, iv); - - CAMLlocal2 (rv, strv); - virConnectPtr conn = Connect_val (connv); - int i = Int_val (iv); - char *names[i]; - int r; - - NONBLOCKING (r = virConnectListDefinedNetworks (conn, names, i)); - CHECK_ERROR (r == -1, conn, "virConnectListDefinedNetworks"); - - rv = caml_alloc (r, 0); - for (i = 0; i < r; ++i) { - strv = caml_copy_string (names[i]); - Store_field (rv, i, strv); - free (names[i]); - } - - CAMLreturn (rv); -} - -/* Automatically generated binding for virConnectNumOfStoragePools. - * In generator.pl this function has signature "conn : int". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRCONNECTNUMOFSTORAGEPOOLS -extern int virConnectNumOfStoragePools (virConnectPtr conn) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_connect_num_of_storage_pools (value connv) -{ - CAMLparam1 (connv); -#ifndef HAVE_VIRCONNECTNUMOFSTORAGEPOOLS - /* Symbol virConnectNumOfStoragePools not found at compile time. */ - not_supported ("virConnectNumOfStoragePools"); - CAMLnoreturn; -#else - /* Check that the symbol virConnectNumOfStoragePools - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virConnectNumOfStoragePools); - - virConnectPtr conn = Connect_val (connv); - int r; - - NONBLOCKING (r = virConnectNumOfStoragePools (conn)); - CHECK_ERROR (r == -1, conn, "virConnectNumOfStoragePools"); - - CAMLreturn (Val_int (r)); -#endif -} - -/* Automatically generated binding for virConnectListStoragePools. - * In generator.pl this function has signature "conn, int : string array". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRCONNECTLISTSTORAGEPOOLS -extern int virConnectListStoragePools (virConnectPtr conn, char **const names, int maxnames) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_connect_list_storage_pools (value connv, value iv) -{ - CAMLparam2 (connv, iv); -#ifndef HAVE_VIRCONNECTLISTSTORAGEPOOLS - /* Symbol virConnectListStoragePools not found at compile time. */ - not_supported ("virConnectListStoragePools"); - CAMLnoreturn; -#else - /* Check that the symbol virConnectListStoragePools - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virConnectListStoragePools); - - CAMLlocal2 (rv, strv); - virConnectPtr conn = Connect_val (connv); - int i = Int_val (iv); - char *names[i]; - int r; - - NONBLOCKING (r = virConnectListStoragePools (conn, names, i)); - CHECK_ERROR (r == -1, conn, "virConnectListStoragePools"); - - rv = caml_alloc (r, 0); - for (i = 0; i < r; ++i) { - strv = caml_copy_string (names[i]); - Store_field (rv, i, strv); - free (names[i]); - } - - CAMLreturn (rv); -#endif -} - -/* Automatically generated binding for virConnectNumOfDefinedStoragePools. - * In generator.pl this function has signature "conn : int". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRCONNECTNUMOFDEFINEDSTORAGEPOOLS -extern int virConnectNumOfDefinedStoragePools (virConnectPtr conn) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_connect_num_of_defined_storage_pools (value connv) -{ - CAMLparam1 (connv); -#ifndef HAVE_VIRCONNECTNUMOFDEFINEDSTORAGEPOOLS - /* Symbol virConnectNumOfDefinedStoragePools not found at compile time. */ - not_supported ("virConnectNumOfDefinedStoragePools"); - CAMLnoreturn; -#else - /* Check that the symbol virConnectNumOfDefinedStoragePools - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virConnectNumOfDefinedStoragePools); - - virConnectPtr conn = Connect_val (connv); - int r; - - NONBLOCKING (r = virConnectNumOfDefinedStoragePools (conn)); - CHECK_ERROR (r == -1, conn, "virConnectNumOfDefinedStoragePools"); - - CAMLreturn (Val_int (r)); -#endif -} - -/* Automatically generated binding for virConnectListDefinedStoragePools. - * In generator.pl this function has signature "conn, int : string array". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRCONNECTLISTDEFINEDSTORAGEPOOLS -extern int virConnectListDefinedStoragePools (virConnectPtr conn, char **const names, int maxnames) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_connect_list_defined_storage_pools (value connv, value iv) -{ - CAMLparam2 (connv, iv); -#ifndef HAVE_VIRCONNECTLISTDEFINEDSTORAGEPOOLS - /* Symbol virConnectListDefinedStoragePools not found at compile time. */ - not_supported ("virConnectListDefinedStoragePools"); - CAMLnoreturn; -#else - /* Check that the symbol virConnectListDefinedStoragePools - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virConnectListDefinedStoragePools); - - CAMLlocal2 (rv, strv); - virConnectPtr conn = Connect_val (connv); - int i = Int_val (iv); - char *names[i]; - int r; - - NONBLOCKING (r = virConnectListDefinedStoragePools (conn, names, i)); - CHECK_ERROR (r == -1, conn, "virConnectListDefinedStoragePools"); - - rv = caml_alloc (r, 0); - for (i = 0; i < r; ++i) { - strv = caml_copy_string (names[i]); - Store_field (rv, i, strv); - free (names[i]); - } - - CAMLreturn (rv); -#endif -} - -/* Automatically generated binding for virConnectGetCapabilities. - * In generator.pl this function has signature "conn : string". - */ - -CAMLprim value -ocaml_libvirt_connect_get_capabilities (value connv) -{ - CAMLparam1 (connv); - - CAMLlocal1 (rv); - virConnectPtr conn = Connect_val (connv); - char *r; - - NONBLOCKING (r = virConnectGetCapabilities (conn)); - CHECK_ERROR (!r, conn, "virConnectGetCapabilities"); - - rv = caml_copy_string (r); - free (r); - CAMLreturn (rv); -} - -/* Automatically generated binding for virDomainCreateLinux. - * In generator.pl this function has signature "conn, string, 0U : dom". - */ - -CAMLprim value -ocaml_libvirt_domain_create_linux (value connv, value strv) -{ - CAMLparam2 (connv, strv); - - CAMLlocal1 (rv); - virConnectPtr conn = Connect_val (connv); - char *str = String_val (strv); - virDomainPtr r; - - NONBLOCKING (r = virDomainCreateLinux (conn, str, 0)); - CHECK_ERROR (!r, conn, "virDomainCreateLinux"); - - rv = Val_domain (r, connv); - - CAMLreturn (rv); -} - -/* Automatically generated binding for virDomainCreateLinuxJob. - * In generator.pl this function has signature "conn, string, 0U : job". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRDOMAINCREATELINUXJOB -extern virJobPtr virDomainCreateLinuxJob (virConnectPtr conn, const char *str, unsigned int flags) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_domain_create_linux_job (value connv, value strv) -{ - CAMLparam2 (connv, strv); -#ifndef HAVE_VIRDOMAINCREATELINUXJOB - /* Symbol virDomainCreateLinuxJob not found at compile time. */ - not_supported ("virDomainCreateLinuxJob"); - CAMLnoreturn; -#else - /* Check that the symbol virDomainCreateLinuxJob - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virDomainCreateLinuxJob); - - CAMLlocal1 (rv); - virConnectPtr conn = Connect_val (connv); - char *str = String_val (strv); - virJobPtr r; - - NONBLOCKING (r = virDomainCreateLinuxJob (conn, str, 0)); - CHECK_ERROR (!r, conn, "virDomainCreateLinuxJob"); - - rv = Val_job (r, connv); - - CAMLreturn (rv); -#endif -} - -/* Automatically generated binding for virDomainFree. - * In generator.pl this function has signature "dom : free". - */ - -CAMLprim value -ocaml_libvirt_domain_free (value domv) -{ - CAMLparam1 (domv); - - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - int r; - - NONBLOCKING (r = virDomainFree (dom)); - CHECK_ERROR (r == -1, conn, "virDomainFree"); - - /* So that we don't double-free in the finalizer: */ - Domain_val (domv) = NULL; - - CAMLreturn (Val_unit); -} - -/* Automatically generated binding for virDomainDestroy. - * In generator.pl this function has signature "dom : free". - */ - -CAMLprim value -ocaml_libvirt_domain_destroy (value domv) -{ - CAMLparam1 (domv); - - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - int r; - - NONBLOCKING (r = virDomainDestroy (dom)); - CHECK_ERROR (r == -1, conn, "virDomainDestroy"); - - /* So that we don't double-free in the finalizer: */ - Domain_val (domv) = NULL; - - CAMLreturn (Val_unit); -} - -/* Automatically generated binding for virDomainLookupByName. - * In generator.pl this function has signature "conn, string : dom". - */ - -CAMLprim value -ocaml_libvirt_domain_lookup_by_name (value connv, value strv) -{ - CAMLparam2 (connv, strv); - - CAMLlocal1 (rv); - virConnectPtr conn = Connect_val (connv); - char *str = String_val (strv); - virDomainPtr r; - - NONBLOCKING (r = virDomainLookupByName (conn, str)); - CHECK_ERROR (!r, conn, "virDomainLookupByName"); - - rv = Val_domain (r, connv); - - CAMLreturn (rv); -} - -/* Automatically generated binding for virDomainLookupByID. - * In generator.pl this function has signature "conn, int : dom". - */ - -CAMLprim value -ocaml_libvirt_domain_lookup_by_id (value connv, value iv) -{ - CAMLparam2 (connv, iv); - - CAMLlocal1 (rv); - virConnectPtr conn = Connect_val (connv); - int i = Int_val (iv); - virDomainPtr r; - - NONBLOCKING (r = virDomainLookupByID (conn, i)); - CHECK_ERROR (!r, conn, "virDomainLookupByID"); - - rv = Val_domain (r, connv); - - CAMLreturn (rv); -} - -/* Automatically generated binding for virDomainLookupByUUID. - * In generator.pl this function has signature "conn, uuid : dom". - */ - -CAMLprim value -ocaml_libvirt_domain_lookup_by_uuid (value connv, value uuidv) -{ - CAMLparam2 (connv, uuidv); - - CAMLlocal1 (rv); - virConnectPtr conn = Connect_val (connv); - unsigned char *uuid = (unsigned char *) String_val (uuidv); - virDomainPtr r; - - NONBLOCKING (r = virDomainLookupByUUID (conn, uuid)); - CHECK_ERROR (!r, conn, "virDomainLookupByUUID"); - - rv = Val_domain (r, connv); - - CAMLreturn (rv); -} - -/* Automatically generated binding for virDomainLookupByUUIDString. - * In generator.pl this function has signature "conn, string : dom". - */ - -CAMLprim value -ocaml_libvirt_domain_lookup_by_uuid_string (value connv, value strv) -{ - CAMLparam2 (connv, strv); - - CAMLlocal1 (rv); - virConnectPtr conn = Connect_val (connv); - char *str = String_val (strv); - virDomainPtr r; - - NONBLOCKING (r = virDomainLookupByUUIDString (conn, str)); - CHECK_ERROR (!r, conn, "virDomainLookupByUUIDString"); - - rv = Val_domain (r, connv); - - CAMLreturn (rv); -} - -/* Automatically generated binding for virDomainGetName. - * In generator.pl this function has signature "dom : static string". - */ - -CAMLprim value -ocaml_libvirt_domain_get_name (value domv) -{ - CAMLparam1 (domv); - - CAMLlocal1 (rv); - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - const char *r; - - NONBLOCKING (r = virDomainGetName (dom)); - CHECK_ERROR (!r, conn, "virDomainGetName"); - - rv = caml_copy_string (r); - CAMLreturn (rv); -} - -/* Automatically generated binding for virDomainGetOSType. - * In generator.pl this function has signature "dom : string". - */ - -CAMLprim value -ocaml_libvirt_domain_get_os_type (value domv) -{ - CAMLparam1 (domv); - - CAMLlocal1 (rv); - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - char *r; - - NONBLOCKING (r = virDomainGetOSType (dom)); - CHECK_ERROR (!r, conn, "virDomainGetOSType"); - - rv = caml_copy_string (r); - free (r); - CAMLreturn (rv); -} - -/* Automatically generated binding for virDomainGetXMLDesc. - * In generator.pl this function has signature "dom, 0 : string". - */ - -CAMLprim value -ocaml_libvirt_domain_get_xml_desc (value domv) -{ - CAMLparam1 (domv); - - CAMLlocal1 (rv); - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - char *r; - - NONBLOCKING (r = virDomainGetXMLDesc (dom, 0)); - CHECK_ERROR (!r, conn, "virDomainGetXMLDesc"); - - rv = caml_copy_string (r); - free (r); - CAMLreturn (rv); -} - -/* Automatically generated binding for virDomainGetUUID. - * In generator.pl this function has signature "dom : uuid". - */ - -CAMLprim value -ocaml_libvirt_domain_get_uuid (value domv) -{ - CAMLparam1 (domv); - - CAMLlocal1 (rv); - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - unsigned char uuid[VIR_UUID_BUFLEN]; - int r; - - NONBLOCKING (r = virDomainGetUUID (dom, uuid)); - CHECK_ERROR (r == -1, conn, "virDomainGetUUID"); - - /* UUIDs are byte arrays with a fixed length. */ - rv = caml_alloc_string (VIR_UUID_BUFLEN); - memcpy (String_val (rv), uuid, VIR_UUID_BUFLEN); - CAMLreturn (rv); -} - -/* Automatically generated binding for virDomainGetUUIDString. - * In generator.pl this function has signature "dom : uuid string". - */ - -CAMLprim value -ocaml_libvirt_domain_get_uuid_string (value domv) -{ - CAMLparam1 (domv); - - CAMLlocal1 (rv); - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - char uuid[VIR_UUID_STRING_BUFLEN]; - int r; - - NONBLOCKING (r = virDomainGetUUIDString (dom, uuid)); - CHECK_ERROR (r == -1, conn, "virDomainGetUUIDString"); - - rv = caml_copy_string (uuid); - CAMLreturn (rv); -} - -/* Automatically generated binding for virDomainGetMaxVcpus. - * In generator.pl this function has signature "dom : int". - */ - -CAMLprim value -ocaml_libvirt_domain_get_max_vcpus (value domv) -{ - CAMLparam1 (domv); - - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - int r; - - NONBLOCKING (r = virDomainGetMaxVcpus (dom)); - CHECK_ERROR (r == -1, conn, "virDomainGetMaxVcpus"); - - CAMLreturn (Val_int (r)); -} - -/* Automatically generated binding for virDomainSave. - * In generator.pl this function has signature "dom, string : unit". - */ - -CAMLprim value -ocaml_libvirt_domain_save (value domv, value strv) -{ - CAMLparam2 (domv, strv); - - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - char *str = String_val (strv); - int r; - - NONBLOCKING (r = virDomainSave (dom, str)); - CHECK_ERROR (r == -1, conn, "virDomainSave"); - - CAMLreturn (Val_unit); -} - -/* Automatically generated binding for virDomainSaveJob. - * In generator.pl this function has signature "dom, string : job from dom". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRDOMAINSAVEJOB -extern virJobPtr virDomainSaveJob (virDomainPtr dom, const char *str) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_domain_save_job (value domv, value strv) -{ - CAMLparam2 (domv, strv); -#ifndef HAVE_VIRDOMAINSAVEJOB - /* Symbol virDomainSaveJob not found at compile time. */ - not_supported ("virDomainSaveJob"); - CAMLnoreturn; -#else - /* Check that the symbol virDomainSaveJob - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virDomainSaveJob); - - CAMLlocal2 (rv, connv); - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - char *str = String_val (strv); - virJobPtr r; - - NONBLOCKING (r = virDomainSaveJob (dom, str)); - CHECK_ERROR (!r, conn, "virDomainSaveJob"); - - connv = Field (domv, 1); - rv = Val_job (r, connv); - - CAMLreturn (rv); -#endif -} - -/* Automatically generated binding for virDomainRestore. - * In generator.pl this function has signature "conn, string : unit". - */ - -CAMLprim value -ocaml_libvirt_domain_restore (value connv, value strv) -{ - CAMLparam2 (connv, strv); - - virConnectPtr conn = Connect_val (connv); - char *str = String_val (strv); - int r; - - NONBLOCKING (r = virDomainRestore (conn, str)); - CHECK_ERROR (r == -1, conn, "virDomainRestore"); - - CAMLreturn (Val_unit); -} - -/* Automatically generated binding for virDomainRestoreJob. - * In generator.pl this function has signature "conn, string : job". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRDOMAINRESTOREJOB -extern virJobPtr virDomainRestoreJob (virConnectPtr conn, const char *str) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_domain_restore_job (value connv, value strv) -{ - CAMLparam2 (connv, strv); -#ifndef HAVE_VIRDOMAINRESTOREJOB - /* Symbol virDomainRestoreJob not found at compile time. */ - not_supported ("virDomainRestoreJob"); - CAMLnoreturn; -#else - /* Check that the symbol virDomainRestoreJob - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virDomainRestoreJob); - - CAMLlocal1 (rv); - virConnectPtr conn = Connect_val (connv); - char *str = String_val (strv); - virJobPtr r; - - NONBLOCKING (r = virDomainRestoreJob (conn, str)); - CHECK_ERROR (!r, conn, "virDomainRestoreJob"); - - rv = Val_job (r, connv); - - CAMLreturn (rv); -#endif -} - -/* Automatically generated binding for virDomainCoreDump. - * In generator.pl this function has signature "dom, string, 0 : unit". - */ - -CAMLprim value -ocaml_libvirt_domain_core_dump (value domv, value strv) -{ - CAMLparam2 (domv, strv); - - CAMLlocal1 (rv); - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - char *str = String_val (strv); - int r; - - NONBLOCKING (r = virDomainCoreDump (dom, str, 0)); - CHECK_ERROR (!r, conn, "virDomainCoreDump"); - - CAMLreturn (Val_unit); -} - -/* Automatically generated binding for virDomainCoreDumpJob. - * In generator.pl this function has signature "dom, string, 0 : job from dom". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRDOMAINCOREDUMPJOB -extern virJobPtr virDomainCoreDumpJob (virDomainPtr dom, const char *str, int flags) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_domain_core_dump_job (value domv, value strv) -{ - CAMLparam2 (domv, strv); -#ifndef HAVE_VIRDOMAINCOREDUMPJOB - /* Symbol virDomainCoreDumpJob not found at compile time. */ - not_supported ("virDomainCoreDumpJob"); - CAMLnoreturn; -#else - /* Check that the symbol virDomainCoreDumpJob - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virDomainCoreDumpJob); - - CAMLlocal2 (rv, connv); - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - char *str = String_val (strv); - virJobPtr r; - - NONBLOCKING (r = virDomainCoreDumpJob (dom, str, 0)); - CHECK_ERROR (!r, conn, "virDomainCoreDumpJob"); - - connv = Field (domv, 1); - rv = Val_job (r, connv); - - CAMLreturn (rv); -#endif -} - -/* Automatically generated binding for virDomainSuspend. - * In generator.pl this function has signature "dom : unit". - */ - -CAMLprim value -ocaml_libvirt_domain_suspend (value domv) -{ - CAMLparam1 (domv); - - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - int r; - - NONBLOCKING (r = virDomainSuspend (dom)); - CHECK_ERROR (r == -1, conn, "virDomainSuspend"); - - CAMLreturn (Val_unit); -} - -/* Automatically generated binding for virDomainResume. - * In generator.pl this function has signature "dom : unit". - */ - -CAMLprim value -ocaml_libvirt_domain_resume (value domv) -{ - CAMLparam1 (domv); - - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - int r; - - NONBLOCKING (r = virDomainResume (dom)); - CHECK_ERROR (r == -1, conn, "virDomainResume"); - - CAMLreturn (Val_unit); -} - -/* Automatically generated binding for virDomainShutdown. - * In generator.pl this function has signature "dom : unit". - */ - -CAMLprim value -ocaml_libvirt_domain_shutdown (value domv) -{ - CAMLparam1 (domv); - - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - int r; - - NONBLOCKING (r = virDomainShutdown (dom)); - CHECK_ERROR (r == -1, conn, "virDomainShutdown"); - - CAMLreturn (Val_unit); -} - -/* Automatically generated binding for virDomainReboot. - * In generator.pl this function has signature "dom, 0 : unit". - */ - -CAMLprim value -ocaml_libvirt_domain_reboot (value domv) -{ - CAMLparam1 (domv); - - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - int r; - - NONBLOCKING (r = virDomainReboot (dom, 0)); - CHECK_ERROR (r == -1, conn, "virDomainReboot"); - - CAMLreturn (Val_unit); -} - -/* Automatically generated binding for virDomainDefineXML. - * In generator.pl this function has signature "conn, string : dom". - */ - -CAMLprim value -ocaml_libvirt_domain_define_xml (value connv, value strv) -{ - CAMLparam2 (connv, strv); - - CAMLlocal1 (rv); - virConnectPtr conn = Connect_val (connv); - char *str = String_val (strv); - virDomainPtr r; - - NONBLOCKING (r = virDomainDefineXML (conn, str)); - CHECK_ERROR (!r, conn, "virDomainDefineXML"); - - rv = Val_domain (r, connv); - - CAMLreturn (rv); -} - -/* Automatically generated binding for virDomainUndefine. - * In generator.pl this function has signature "dom : unit". - */ - -CAMLprim value -ocaml_libvirt_domain_undefine (value domv) -{ - CAMLparam1 (domv); - - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - int r; - - NONBLOCKING (r = virDomainUndefine (dom)); - CHECK_ERROR (r == -1, conn, "virDomainUndefine"); - - CAMLreturn (Val_unit); -} - -/* Automatically generated binding for virDomainCreate. - * In generator.pl this function has signature "dom : unit". - */ - -CAMLprim value -ocaml_libvirt_domain_create (value domv) -{ - CAMLparam1 (domv); - - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - int r; - - NONBLOCKING (r = virDomainCreate (dom)); - CHECK_ERROR (r == -1, conn, "virDomainCreate"); - - CAMLreturn (Val_unit); -} - -/* Automatically generated binding for virDomainCreateJob. - * In generator.pl this function has signature "dom, 0U : job from dom". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRDOMAINCREATEJOB -extern virJobPtr virDomainCreateJob (virDomainPtr dom, unsigned int flags) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_domain_create_job (value domv) -{ - CAMLparam1 (domv); -#ifndef HAVE_VIRDOMAINCREATEJOB - /* Symbol virDomainCreateJob not found at compile time. */ - not_supported ("virDomainCreateJob"); - CAMLnoreturn; -#else - /* Check that the symbol virDomainCreateJob - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virDomainCreateJob); - - CAMLlocal2 (rv, connv); - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - virJobPtr r; - - NONBLOCKING (r = virDomainCreateJob (dom, 0)); - CHECK_ERROR (!r, conn, "virDomainCreateJob"); - - connv = Field (domv, 1); - rv = Val_job (r, connv); - - CAMLreturn (rv); -#endif -} - -/* Automatically generated binding for virDomainAttachDevice. - * In generator.pl this function has signature "dom, string : unit". - */ - -CAMLprim value -ocaml_libvirt_domain_attach_device (value domv, value strv) -{ - CAMLparam2 (domv, strv); - - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - char *str = String_val (strv); - int r; - - NONBLOCKING (r = virDomainAttachDevice (dom, str)); - CHECK_ERROR (r == -1, conn, "virDomainAttachDevice"); - - CAMLreturn (Val_unit); -} - -/* Automatically generated binding for virDomainDetachDevice. - * In generator.pl this function has signature "dom, string : unit". - */ - -CAMLprim value -ocaml_libvirt_domain_detach_device (value domv, value strv) -{ - CAMLparam2 (domv, strv); - - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - char *str = String_val (strv); - int r; - - NONBLOCKING (r = virDomainDetachDevice (dom, str)); - CHECK_ERROR (r == -1, conn, "virDomainDetachDevice"); - - CAMLreturn (Val_unit); -} - -/* Automatically generated binding for virDomainGetAutostart. - * In generator.pl this function has signature "dom : bool". - */ - -CAMLprim value -ocaml_libvirt_domain_get_autostart (value domv) -{ - CAMLparam1 (domv); - - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - int r, b; - - NONBLOCKING (r = virDomainGetAutostart (dom, &b)); - CHECK_ERROR (r == -1, conn, "virDomainGetAutostart"); - - CAMLreturn (b ? Val_true : Val_false); -} - -/* Automatically generated binding for virDomainSetAutostart. - * In generator.pl this function has signature "dom, bool : unit". - */ - -CAMLprim value -ocaml_libvirt_domain_set_autostart (value domv, value bv) -{ - CAMLparam2 (domv, bv); - - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - int r, b; - - b = bv == Val_true ? 1 : 0; - - NONBLOCKING (r = virDomainSetAutostart (dom, b)); - CHECK_ERROR (r == -1, conn, "virDomainSetAutostart"); - - CAMLreturn (Val_unit); -} - -/* Automatically generated binding for virNetworkFree. - * In generator.pl this function has signature "net : free". - */ - -CAMLprim value -ocaml_libvirt_network_free (value netv) -{ - CAMLparam1 (netv); - - virNetworkPtr net = Network_val (netv); - virConnectPtr conn = Connect_netv (netv); - int r; - - NONBLOCKING (r = virNetworkFree (net)); - CHECK_ERROR (r == -1, conn, "virNetworkFree"); - - /* So that we don't double-free in the finalizer: */ - Network_val (netv) = NULL; - - CAMLreturn (Val_unit); -} - -/* Automatically generated binding for virNetworkDestroy. - * In generator.pl this function has signature "net : free". - */ - -CAMLprim value -ocaml_libvirt_network_destroy (value netv) -{ - CAMLparam1 (netv); - - virNetworkPtr net = Network_val (netv); - virConnectPtr conn = Connect_netv (netv); - int r; - - NONBLOCKING (r = virNetworkDestroy (net)); - CHECK_ERROR (r == -1, conn, "virNetworkDestroy"); - - /* So that we don't double-free in the finalizer: */ - Network_val (netv) = NULL; - - CAMLreturn (Val_unit); -} - -/* Automatically generated binding for virNetworkLookupByName. - * In generator.pl this function has signature "conn, string : net". - */ - -CAMLprim value -ocaml_libvirt_network_lookup_by_name (value connv, value strv) -{ - CAMLparam2 (connv, strv); - - CAMLlocal1 (rv); - virConnectPtr conn = Connect_val (connv); - char *str = String_val (strv); - virNetworkPtr r; - - NONBLOCKING (r = virNetworkLookupByName (conn, str)); - CHECK_ERROR (!r, conn, "virNetworkLookupByName"); - - rv = Val_network (r, connv); - - CAMLreturn (rv); -} - -/* Automatically generated binding for virNetworkLookupByUUID. - * In generator.pl this function has signature "conn, uuid : net". - */ - -CAMLprim value -ocaml_libvirt_network_lookup_by_uuid (value connv, value uuidv) -{ - CAMLparam2 (connv, uuidv); - - CAMLlocal1 (rv); - virConnectPtr conn = Connect_val (connv); - unsigned char *uuid = (unsigned char *) String_val (uuidv); - virNetworkPtr r; - - NONBLOCKING (r = virNetworkLookupByUUID (conn, uuid)); - CHECK_ERROR (!r, conn, "virNetworkLookupByUUID"); - - rv = Val_network (r, connv); - - CAMLreturn (rv); -} - -/* Automatically generated binding for virNetworkLookupByUUIDString. - * In generator.pl this function has signature "conn, string : net". - */ - -CAMLprim value -ocaml_libvirt_network_lookup_by_uuid_string (value connv, value strv) -{ - CAMLparam2 (connv, strv); - - CAMLlocal1 (rv); - virConnectPtr conn = Connect_val (connv); - char *str = String_val (strv); - virNetworkPtr r; - - NONBLOCKING (r = virNetworkLookupByUUIDString (conn, str)); - CHECK_ERROR (!r, conn, "virNetworkLookupByUUIDString"); - - rv = Val_network (r, connv); - - CAMLreturn (rv); -} - -/* Automatically generated binding for virNetworkGetName. - * In generator.pl this function has signature "net : static string". - */ - -CAMLprim value -ocaml_libvirt_network_get_name (value netv) -{ - CAMLparam1 (netv); - - CAMLlocal1 (rv); - virNetworkPtr net = Network_val (netv); - virConnectPtr conn = Connect_netv (netv); - const char *r; - - NONBLOCKING (r = virNetworkGetName (net)); - CHECK_ERROR (!r, conn, "virNetworkGetName"); - - rv = caml_copy_string (r); - CAMLreturn (rv); -} - -/* Automatically generated binding for virNetworkGetXMLDesc. - * In generator.pl this function has signature "net, 0 : string". - */ - -CAMLprim value -ocaml_libvirt_network_get_xml_desc (value netv) -{ - CAMLparam1 (netv); - - CAMLlocal1 (rv); - virNetworkPtr net = Network_val (netv); - virConnectPtr conn = Connect_netv (netv); - char *r; - - NONBLOCKING (r = virNetworkGetXMLDesc (net, 0)); - CHECK_ERROR (!r, conn, "virNetworkGetXMLDesc"); - - rv = caml_copy_string (r); - free (r); - CAMLreturn (rv); -} - -/* Automatically generated binding for virNetworkGetBridgeName. - * In generator.pl this function has signature "net : string". - */ - -CAMLprim value -ocaml_libvirt_network_get_bridge_name (value netv) -{ - CAMLparam1 (netv); - - CAMLlocal1 (rv); - virNetworkPtr net = Network_val (netv); - virConnectPtr conn = Connect_netv (netv); - char *r; - - NONBLOCKING (r = virNetworkGetBridgeName (net)); - CHECK_ERROR (!r, conn, "virNetworkGetBridgeName"); - - rv = caml_copy_string (r); - free (r); - CAMLreturn (rv); -} - -/* Automatically generated binding for virNetworkGetUUID. - * In generator.pl this function has signature "net : uuid". - */ - -CAMLprim value -ocaml_libvirt_network_get_uuid (value netv) -{ - CAMLparam1 (netv); - - CAMLlocal1 (rv); - virNetworkPtr net = Network_val (netv); - virConnectPtr conn = Connect_netv (netv); - unsigned char uuid[VIR_UUID_BUFLEN]; - int r; - - NONBLOCKING (r = virNetworkGetUUID (net, uuid)); - CHECK_ERROR (r == -1, conn, "virNetworkGetUUID"); - - /* UUIDs are byte arrays with a fixed length. */ - rv = caml_alloc_string (VIR_UUID_BUFLEN); - memcpy (String_val (rv), uuid, VIR_UUID_BUFLEN); - CAMLreturn (rv); -} - -/* Automatically generated binding for virNetworkGetUUIDString. - * In generator.pl this function has signature "net : uuid string". - */ - -CAMLprim value -ocaml_libvirt_network_get_uuid_string (value netv) -{ - CAMLparam1 (netv); - - CAMLlocal1 (rv); - virNetworkPtr net = Network_val (netv); - virConnectPtr conn = Connect_netv (netv); - char uuid[VIR_UUID_STRING_BUFLEN]; - int r; - - NONBLOCKING (r = virNetworkGetUUIDString (net, uuid)); - CHECK_ERROR (r == -1, conn, "virNetworkGetUUIDString"); - - rv = caml_copy_string (uuid); - CAMLreturn (rv); -} - -/* Automatically generated binding for virNetworkUndefine. - * In generator.pl this function has signature "net : unit". - */ - -CAMLprim value -ocaml_libvirt_network_undefine (value netv) -{ - CAMLparam1 (netv); - - virNetworkPtr net = Network_val (netv); - virConnectPtr conn = Connect_netv (netv); - int r; - - NONBLOCKING (r = virNetworkUndefine (net)); - CHECK_ERROR (r == -1, conn, "virNetworkUndefine"); - - CAMLreturn (Val_unit); -} - -/* Automatically generated binding for virNetworkCreateXML. - * In generator.pl this function has signature "conn, string : net". - */ - -CAMLprim value -ocaml_libvirt_network_create_xml (value connv, value strv) -{ - CAMLparam2 (connv, strv); - - CAMLlocal1 (rv); - virConnectPtr conn = Connect_val (connv); - char *str = String_val (strv); - virNetworkPtr r; - - NONBLOCKING (r = virNetworkCreateXML (conn, str)); - CHECK_ERROR (!r, conn, "virNetworkCreateXML"); - - rv = Val_network (r, connv); - - CAMLreturn (rv); -} - -/* Automatically generated binding for virNetworkCreateXMLJob. - * In generator.pl this function has signature "conn, string : job". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRNETWORKCREATEXMLJOB -extern virJobPtr virNetworkCreateXMLJob (virConnectPtr conn, const char *str) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_network_create_xml_job (value connv, value strv) -{ - CAMLparam2 (connv, strv); -#ifndef HAVE_VIRNETWORKCREATEXMLJOB - /* Symbol virNetworkCreateXMLJob not found at compile time. */ - not_supported ("virNetworkCreateXMLJob"); - CAMLnoreturn; -#else - /* Check that the symbol virNetworkCreateXMLJob - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virNetworkCreateXMLJob); - - CAMLlocal1 (rv); - virConnectPtr conn = Connect_val (connv); - char *str = String_val (strv); - virJobPtr r; - - NONBLOCKING (r = virNetworkCreateXMLJob (conn, str)); - CHECK_ERROR (!r, conn, "virNetworkCreateXMLJob"); - - rv = Val_job (r, connv); - - CAMLreturn (rv); -#endif -} - -/* Automatically generated binding for virNetworkDefineXML. - * In generator.pl this function has signature "conn, string : net". - */ - -CAMLprim value -ocaml_libvirt_network_define_xml (value connv, value strv) -{ - CAMLparam2 (connv, strv); - - CAMLlocal1 (rv); - virConnectPtr conn = Connect_val (connv); - char *str = String_val (strv); - virNetworkPtr r; - - NONBLOCKING (r = virNetworkDefineXML (conn, str)); - CHECK_ERROR (!r, conn, "virNetworkDefineXML"); - - rv = Val_network (r, connv); - - CAMLreturn (rv); -} - -/* Automatically generated binding for virNetworkCreate. - * In generator.pl this function has signature "net : unit". - */ - -CAMLprim value -ocaml_libvirt_network_create (value netv) -{ - CAMLparam1 (netv); - - virNetworkPtr net = Network_val (netv); - virConnectPtr conn = Connect_netv (netv); - int r; - - NONBLOCKING (r = virNetworkCreate (net)); - CHECK_ERROR (r == -1, conn, "virNetworkCreate"); - - CAMLreturn (Val_unit); -} - -/* Automatically generated binding for virNetworkCreateJob. - * In generator.pl this function has signature "net : job from net". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRNETWORKCREATEJOB -extern virJobPtr virNetworkCreateJob (virNetworkPtr net) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_network_create_job (value netv) -{ - CAMLparam1 (netv); -#ifndef HAVE_VIRNETWORKCREATEJOB - /* Symbol virNetworkCreateJob not found at compile time. */ - not_supported ("virNetworkCreateJob"); - CAMLnoreturn; -#else - /* Check that the symbol virNetworkCreateJob - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virNetworkCreateJob); - - CAMLlocal2 (rv, connv); - virNetworkPtr net = Network_val (netv); - virConnectPtr conn = Connect_netv (netv); - virJobPtr r; - - NONBLOCKING (r = virNetworkCreateJob (net)); - CHECK_ERROR (!r, conn, "virNetworkCreateJob"); - - connv = Field (netv, 1); - rv = Val_job (r, connv); - - CAMLreturn (rv); -#endif -} - -/* Automatically generated binding for virNetworkGetAutostart. - * In generator.pl this function has signature "net : bool". - */ - -CAMLprim value -ocaml_libvirt_network_get_autostart (value netv) -{ - CAMLparam1 (netv); - - virNetworkPtr net = Network_val (netv); - virConnectPtr conn = Connect_netv (netv); - int r, b; - - NONBLOCKING (r = virNetworkGetAutostart (net, &b)); - CHECK_ERROR (r == -1, conn, "virNetworkGetAutostart"); - - CAMLreturn (b ? Val_true : Val_false); -} - -/* Automatically generated binding for virNetworkSetAutostart. - * In generator.pl this function has signature "net, bool : unit". - */ - -CAMLprim value -ocaml_libvirt_network_set_autostart (value netv, value bv) -{ - CAMLparam2 (netv, bv); - - virNetworkPtr net = Network_val (netv); - virConnectPtr conn = Connect_netv (netv); - int r, b; - - b = bv == Val_true ? 1 : 0; - - NONBLOCKING (r = virNetworkSetAutostart (net, b)); - CHECK_ERROR (r == -1, conn, "virNetworkSetAutostart"); - - CAMLreturn (Val_unit); -} - -/* Automatically generated binding for virStoragePoolFree. - * In generator.pl this function has signature "pool : free". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEPOOLFREE -extern int virStoragePoolFree (virStoragePoolPtr pool) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_pool_free (value poolv) -{ - CAMLparam1 (poolv); -#ifndef HAVE_VIRSTORAGEPOOLFREE - /* Symbol virStoragePoolFree not found at compile time. */ - not_supported ("virStoragePoolFree"); - CAMLnoreturn; -#else - /* Check that the symbol virStoragePoolFree - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virStoragePoolFree); - - virStoragePoolPtr pool = Pool_val (poolv); - virConnectPtr conn = Connect_polv (poolv); - int r; - - NONBLOCKING (r = virStoragePoolFree (pool)); - CHECK_ERROR (r == -1, conn, "virStoragePoolFree"); - - /* So that we don't double-free in the finalizer: */ - Pool_val (poolv) = NULL; - - CAMLreturn (Val_unit); -#endif -} - -/* Automatically generated binding for virStoragePoolDestroy. - * In generator.pl this function has signature "pool : free". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEPOOLDESTROY -extern int virStoragePoolDestroy (virStoragePoolPtr pool) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_pool_destroy (value poolv) -{ - CAMLparam1 (poolv); -#ifndef HAVE_VIRSTORAGEPOOLDESTROY - /* Symbol virStoragePoolDestroy not found at compile time. */ - not_supported ("virStoragePoolDestroy"); - CAMLnoreturn; -#else - /* Check that the symbol virStoragePoolDestroy - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virStoragePoolDestroy); - - virStoragePoolPtr pool = Pool_val (poolv); - virConnectPtr conn = Connect_polv (poolv); - int r; - - NONBLOCKING (r = virStoragePoolDestroy (pool)); - CHECK_ERROR (r == -1, conn, "virStoragePoolDestroy"); - - /* So that we don't double-free in the finalizer: */ - Pool_val (poolv) = NULL; - - CAMLreturn (Val_unit); -#endif -} - -/* Automatically generated binding for virStoragePoolLookupByName. - * In generator.pl this function has signature "conn, string : pool". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEPOOLLOOKUPBYNAME -extern virStoragePoolPtr virStoragePoolLookupByName (virConnectPtr conn, const char *str) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_pool_lookup_by_name (value connv, value strv) -{ - CAMLparam2 (connv, strv); -#ifndef HAVE_VIRSTORAGEPOOLLOOKUPBYNAME - /* Symbol virStoragePoolLookupByName not found at compile time. */ - not_supported ("virStoragePoolLookupByName"); - CAMLnoreturn; -#else - /* Check that the symbol virStoragePoolLookupByName - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virStoragePoolLookupByName); - - CAMLlocal1 (rv); - virConnectPtr conn = Connect_val (connv); - char *str = String_val (strv); - virStoragePoolPtr r; - - NONBLOCKING (r = virStoragePoolLookupByName (conn, str)); - CHECK_ERROR (!r, conn, "virStoragePoolLookupByName"); - - rv = Val_pool (r, connv); - - CAMLreturn (rv); -#endif -} - -/* Automatically generated binding for virStoragePoolLookupByUUID. - * In generator.pl this function has signature "conn, uuid : pool". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEPOOLLOOKUPBYUUID -extern virStoragePoolPtr virStoragePoolLookupByUUID (virConnectPtr conn, const unsigned char *str) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_pool_lookup_by_uuid (value connv, value uuidv) -{ - CAMLparam2 (connv, uuidv); -#ifndef HAVE_VIRSTORAGEPOOLLOOKUPBYUUID - /* Symbol virStoragePoolLookupByUUID not found at compile time. */ - not_supported ("virStoragePoolLookupByUUID"); - CAMLnoreturn; -#else - /* Check that the symbol virStoragePoolLookupByUUID - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virStoragePoolLookupByUUID); - - CAMLlocal1 (rv); - virConnectPtr conn = Connect_val (connv); - unsigned char *uuid = (unsigned char *) String_val (uuidv); - virStoragePoolPtr r; - - NONBLOCKING (r = virStoragePoolLookupByUUID (conn, uuid)); - CHECK_ERROR (!r, conn, "virStoragePoolLookupByUUID"); - - rv = Val_pool (r, connv); - - CAMLreturn (rv); -#endif -} - -/* Automatically generated binding for virStoragePoolLookupByUUIDString. - * In generator.pl this function has signature "conn, string : pool". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEPOOLLOOKUPBYUUIDSTRING -extern virStoragePoolPtr virStoragePoolLookupByUUIDString (virConnectPtr conn, const char *str) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_pool_lookup_by_uuid_string (value connv, value strv) -{ - CAMLparam2 (connv, strv); -#ifndef HAVE_VIRSTORAGEPOOLLOOKUPBYUUIDSTRING - /* Symbol virStoragePoolLookupByUUIDString not found at compile time. */ - not_supported ("virStoragePoolLookupByUUIDString"); - CAMLnoreturn; -#else - /* Check that the symbol virStoragePoolLookupByUUIDString - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virStoragePoolLookupByUUIDString); - - CAMLlocal1 (rv); - virConnectPtr conn = Connect_val (connv); - char *str = String_val (strv); - virStoragePoolPtr r; - - NONBLOCKING (r = virStoragePoolLookupByUUIDString (conn, str)); - CHECK_ERROR (!r, conn, "virStoragePoolLookupByUUIDString"); - - rv = Val_pool (r, connv); - - CAMLreturn (rv); -#endif -} - -/* Automatically generated binding for virStoragePoolGetName. - * In generator.pl this function has signature "pool : static string". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEPOOLGETNAME -extern const char *virStoragePoolGetName (virStoragePoolPtr pool) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_pool_get_name (value poolv) -{ - CAMLparam1 (poolv); -#ifndef HAVE_VIRSTORAGEPOOLGETNAME - /* Symbol virStoragePoolGetName not found at compile time. */ - not_supported ("virStoragePoolGetName"); - CAMLnoreturn; -#else - /* Check that the symbol virStoragePoolGetName - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virStoragePoolGetName); - - CAMLlocal1 (rv); - virStoragePoolPtr pool = Pool_val (poolv); - virConnectPtr conn = Connect_polv (poolv); - const char *r; - - NONBLOCKING (r = virStoragePoolGetName (pool)); - CHECK_ERROR (!r, conn, "virStoragePoolGetName"); - - rv = caml_copy_string (r); - CAMLreturn (rv); -#endif -} - -/* Automatically generated binding for virStoragePoolGetXMLDesc. - * In generator.pl this function has signature "pool, 0U : string". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEPOOLGETXMLDESC -extern char *virStoragePoolGetXMLDesc (virStoragePoolPtr pool, unsigned int flags) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_pool_get_xml_desc (value poolv) -{ - CAMLparam1 (poolv); -#ifndef HAVE_VIRSTORAGEPOOLGETXMLDESC - /* Symbol virStoragePoolGetXMLDesc not found at compile time. */ - not_supported ("virStoragePoolGetXMLDesc"); - CAMLnoreturn; -#else - /* Check that the symbol virStoragePoolGetXMLDesc - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virStoragePoolGetXMLDesc); - - CAMLlocal1 (rv); - virStoragePoolPtr pool = Pool_val (poolv); - virConnectPtr conn = Connect_polv (poolv); - char *r; - - NONBLOCKING (r = virStoragePoolGetXMLDesc (pool, 0)); - CHECK_ERROR (!r, conn, "virStoragePoolGetXMLDesc"); - - rv = caml_copy_string (r); - free (r); - CAMLreturn (rv); -#endif -} - -/* Automatically generated binding for virStoragePoolGetUUID. - * In generator.pl this function has signature "pool : uuid". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEPOOLGETUUID -extern int virStoragePoolGetUUID (virStoragePoolPtr pool, unsigned char *) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_pool_get_uuid (value poolv) -{ - CAMLparam1 (poolv); -#ifndef HAVE_VIRSTORAGEPOOLGETUUID - /* Symbol virStoragePoolGetUUID not found at compile time. */ - not_supported ("virStoragePoolGetUUID"); - CAMLnoreturn; -#else - /* Check that the symbol virStoragePoolGetUUID - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virStoragePoolGetUUID); - - CAMLlocal1 (rv); - virStoragePoolPtr pool = Pool_val (poolv); - virConnectPtr conn = Connect_polv (poolv); - unsigned char uuid[VIR_UUID_BUFLEN]; - int r; - - NONBLOCKING (r = virStoragePoolGetUUID (pool, uuid)); - CHECK_ERROR (r == -1, conn, "virStoragePoolGetUUID"); - - /* UUIDs are byte arrays with a fixed length. */ - rv = caml_alloc_string (VIR_UUID_BUFLEN); - memcpy (String_val (rv), uuid, VIR_UUID_BUFLEN); - CAMLreturn (rv); -#endif -} - -/* Automatically generated binding for virStoragePoolGetUUIDString. - * In generator.pl this function has signature "pool : uuid string". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEPOOLGETUUIDSTRING -extern int virStoragePoolGetUUIDString (virStoragePoolPtr pool, char *) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_pool_get_uuid_string (value poolv) -{ - CAMLparam1 (poolv); -#ifndef HAVE_VIRSTORAGEPOOLGETUUIDSTRING - /* Symbol virStoragePoolGetUUIDString not found at compile time. */ - not_supported ("virStoragePoolGetUUIDString"); - CAMLnoreturn; -#else - /* Check that the symbol virStoragePoolGetUUIDString - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virStoragePoolGetUUIDString); - - CAMLlocal1 (rv); - virStoragePoolPtr pool = Pool_val (poolv); - virConnectPtr conn = Connect_polv (poolv); - char uuid[VIR_UUID_STRING_BUFLEN]; - int r; - - NONBLOCKING (r = virStoragePoolGetUUIDString (pool, uuid)); - CHECK_ERROR (r == -1, conn, "virStoragePoolGetUUIDString"); - - rv = caml_copy_string (uuid); - CAMLreturn (rv); -#endif -} - -/* Automatically generated binding for virStoragePoolCreateXML. - * In generator.pl this function has signature "conn, string, 0U : pool". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEPOOLCREATEXML -extern virStoragePoolPtr virStoragePoolCreateXML (virConnectPtr conn, const char *str, unsigned int flags) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_pool_create_xml (value connv, value strv) -{ - CAMLparam2 (connv, strv); -#ifndef HAVE_VIRSTORAGEPOOLCREATEXML - /* Symbol virStoragePoolCreateXML not found at compile time. */ - not_supported ("virStoragePoolCreateXML"); - CAMLnoreturn; -#else - /* Check that the symbol virStoragePoolCreateXML - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virStoragePoolCreateXML); - - CAMLlocal1 (rv); - virConnectPtr conn = Connect_val (connv); - char *str = String_val (strv); - virStoragePoolPtr r; - - NONBLOCKING (r = virStoragePoolCreateXML (conn, str, 0)); - CHECK_ERROR (!r, conn, "virStoragePoolCreateXML"); - - rv = Val_pool (r, connv); - - CAMLreturn (rv); -#endif -} - -/* Automatically generated binding for virStoragePoolDefineXML. - * In generator.pl this function has signature "conn, string, 0U : pool". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEPOOLDEFINEXML -extern virStoragePoolPtr virStoragePoolDefineXML (virConnectPtr conn, const char *str, unsigned int flags) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_pool_define_xml (value connv, value strv) -{ - CAMLparam2 (connv, strv); -#ifndef HAVE_VIRSTORAGEPOOLDEFINEXML - /* Symbol virStoragePoolDefineXML not found at compile time. */ - not_supported ("virStoragePoolDefineXML"); - CAMLnoreturn; -#else - /* Check that the symbol virStoragePoolDefineXML - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virStoragePoolDefineXML); - - CAMLlocal1 (rv); - virConnectPtr conn = Connect_val (connv); - char *str = String_val (strv); - virStoragePoolPtr r; - - NONBLOCKING (r = virStoragePoolDefineXML (conn, str, 0)); - CHECK_ERROR (!r, conn, "virStoragePoolDefineXML"); - - rv = Val_pool (r, connv); - - CAMLreturn (rv); -#endif -} - -/* Automatically generated binding for virStoragePoolBuild. - * In generator.pl this function has signature "pool, uint : unit". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEPOOLBUILD -extern int virStoragePoolBuild (virStoragePoolPtr pool, unsigned int i) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_pool_build (value poolv, value iv) -{ - CAMLparam2 (poolv, iv); -#ifndef HAVE_VIRSTORAGEPOOLBUILD - /* Symbol virStoragePoolBuild not found at compile time. */ - not_supported ("virStoragePoolBuild"); - CAMLnoreturn; -#else - /* Check that the symbol virStoragePoolBuild - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virStoragePoolBuild); - - virStoragePoolPtr pool = Pool_val (poolv); - virConnectPtr conn = Connect_polv (poolv); - unsigned int i = Int_val (iv); - int r; - - NONBLOCKING (r = virStoragePoolBuild (pool, i)); - CHECK_ERROR (!r, conn, "virStoragePoolBuild"); - - CAMLreturn (Val_unit); -#endif -} - -/* Automatically generated binding for virStoragePoolUndefine. - * In generator.pl this function has signature "pool : unit". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEPOOLUNDEFINE -extern int virStoragePoolUndefine (virStoragePoolPtr pool) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_pool_undefine (value poolv) -{ - CAMLparam1 (poolv); -#ifndef HAVE_VIRSTORAGEPOOLUNDEFINE - /* Symbol virStoragePoolUndefine not found at compile time. */ - not_supported ("virStoragePoolUndefine"); - CAMLnoreturn; -#else - /* Check that the symbol virStoragePoolUndefine - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virStoragePoolUndefine); - - virStoragePoolPtr pool = Pool_val (poolv); - virConnectPtr conn = Connect_polv (poolv); - int r; - - NONBLOCKING (r = virStoragePoolUndefine (pool)); - CHECK_ERROR (r == -1, conn, "virStoragePoolUndefine"); - - CAMLreturn (Val_unit); -#endif -} - -/* Automatically generated binding for virStoragePoolCreate. - * In generator.pl this function has signature "pool, 0U : unit". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEPOOLCREATE -extern int virStoragePoolCreate (virStoragePoolPtr pool, unsigned int flags) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_pool_create (value poolv) -{ - CAMLparam1 (poolv); -#ifndef HAVE_VIRSTORAGEPOOLCREATE - /* Symbol virStoragePoolCreate not found at compile time. */ - not_supported ("virStoragePoolCreate"); - CAMLnoreturn; -#else - /* Check that the symbol virStoragePoolCreate - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virStoragePoolCreate); - - virStoragePoolPtr pool = Pool_val (poolv); - virConnectPtr conn = Connect_polv (poolv); - int r; - - NONBLOCKING (r = virStoragePoolCreate (pool, 0)); - CHECK_ERROR (r == -1, conn, "virStoragePoolCreate"); - - CAMLreturn (Val_unit); -#endif -} - -/* Automatically generated binding for virStoragePoolDelete. - * In generator.pl this function has signature "pool, uint : unit". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEPOOLDELETE -extern int virStoragePoolDelete (virStoragePoolPtr pool, unsigned int i) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_pool_delete (value poolv, value iv) -{ - CAMLparam2 (poolv, iv); -#ifndef HAVE_VIRSTORAGEPOOLDELETE - /* Symbol virStoragePoolDelete not found at compile time. */ - not_supported ("virStoragePoolDelete"); - CAMLnoreturn; -#else - /* Check that the symbol virStoragePoolDelete - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virStoragePoolDelete); - - virStoragePoolPtr pool = Pool_val (poolv); - virConnectPtr conn = Connect_polv (poolv); - unsigned int i = Int_val (iv); - int r; - - NONBLOCKING (r = virStoragePoolDelete (pool, i)); - CHECK_ERROR (!r, conn, "virStoragePoolDelete"); - - CAMLreturn (Val_unit); -#endif -} - -/* Automatically generated binding for virStoragePoolRefresh. - * In generator.pl this function has signature "pool, 0U : unit". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEPOOLREFRESH -extern int virStoragePoolRefresh (virStoragePoolPtr pool, unsigned int flags) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_pool_refresh (value poolv) -{ - CAMLparam1 (poolv); -#ifndef HAVE_VIRSTORAGEPOOLREFRESH - /* Symbol virStoragePoolRefresh not found at compile time. */ - not_supported ("virStoragePoolRefresh"); - CAMLnoreturn; -#else - /* Check that the symbol virStoragePoolRefresh - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virStoragePoolRefresh); - - virStoragePoolPtr pool = Pool_val (poolv); - virConnectPtr conn = Connect_polv (poolv); - int r; - - NONBLOCKING (r = virStoragePoolRefresh (pool, 0)); - CHECK_ERROR (r == -1, conn, "virStoragePoolRefresh"); - - CAMLreturn (Val_unit); -#endif -} - -/* Automatically generated binding for virStoragePoolGetAutostart. - * In generator.pl this function has signature "pool : bool". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEPOOLGETAUTOSTART -extern int virStoragePoolGetAutostart (virStoragePoolPtr pool, int *r) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_pool_get_autostart (value poolv) -{ - CAMLparam1 (poolv); -#ifndef HAVE_VIRSTORAGEPOOLGETAUTOSTART - /* Symbol virStoragePoolGetAutostart not found at compile time. */ - not_supported ("virStoragePoolGetAutostart"); - CAMLnoreturn; -#else - /* Check that the symbol virStoragePoolGetAutostart - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virStoragePoolGetAutostart); - - virStoragePoolPtr pool = Pool_val (poolv); - virConnectPtr conn = Connect_polv (poolv); - int r, b; - - NONBLOCKING (r = virStoragePoolGetAutostart (pool, &b)); - CHECK_ERROR (r == -1, conn, "virStoragePoolGetAutostart"); - - CAMLreturn (b ? Val_true : Val_false); -#endif -} - -/* Automatically generated binding for virStoragePoolSetAutostart. - * In generator.pl this function has signature "pool, bool : unit". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEPOOLSETAUTOSTART -extern int virStoragePoolSetAutostart (virStoragePoolPtr pool, int b) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_pool_set_autostart (value poolv, value bv) -{ - CAMLparam2 (poolv, bv); -#ifndef HAVE_VIRSTORAGEPOOLSETAUTOSTART - /* Symbol virStoragePoolSetAutostart not found at compile time. */ - not_supported ("virStoragePoolSetAutostart"); - CAMLnoreturn; -#else - /* Check that the symbol virStoragePoolSetAutostart - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virStoragePoolSetAutostart); - - virStoragePoolPtr pool = Pool_val (poolv); - virConnectPtr conn = Connect_polv (poolv); - int r, b; - - b = bv == Val_true ? 1 : 0; - - NONBLOCKING (r = virStoragePoolSetAutostart (pool, b)); - CHECK_ERROR (r == -1, conn, "virStoragePoolSetAutostart"); - - CAMLreturn (Val_unit); -#endif -} - -/* Automatically generated binding for virStoragePoolNumOfVolumes. - * In generator.pl this function has signature "pool : int". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEPOOLNUMOFVOLUMES -extern int virStoragePoolNumOfVolumes (virStoragePoolPtr pool) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_pool_num_of_volumes (value poolv) -{ - CAMLparam1 (poolv); -#ifndef HAVE_VIRSTORAGEPOOLNUMOFVOLUMES - /* Symbol virStoragePoolNumOfVolumes not found at compile time. */ - not_supported ("virStoragePoolNumOfVolumes"); - CAMLnoreturn; -#else - /* Check that the symbol virStoragePoolNumOfVolumes - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virStoragePoolNumOfVolumes); - - virStoragePoolPtr pool = Pool_val (poolv); - virConnectPtr conn = Connect_polv (poolv); - int r; - - NONBLOCKING (r = virStoragePoolNumOfVolumes (pool)); - CHECK_ERROR (r == -1, conn, "virStoragePoolNumOfVolumes"); - - CAMLreturn (Val_int (r)); -#endif -} - -/* Automatically generated binding for virStoragePoolListVolumes. - * In generator.pl this function has signature "pool, int : string array". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEPOOLLISTVOLUMES -extern int virStoragePoolListVolumes (virStoragePoolPtr pool, char **const names, int maxnames) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_pool_list_volumes (value poolv, value iv) -{ - CAMLparam2 (poolv, iv); -#ifndef HAVE_VIRSTORAGEPOOLLISTVOLUMES - /* Symbol virStoragePoolListVolumes not found at compile time. */ - not_supported ("virStoragePoolListVolumes"); - CAMLnoreturn; -#else - /* Check that the symbol virStoragePoolListVolumes - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virStoragePoolListVolumes); - - CAMLlocal2 (rv, strv); - virStoragePoolPtr pool = Pool_val (poolv); - virConnectPtr conn = Connect_polv (poolv); - int i = Int_val (iv); - char *names[i]; - int r; - - NONBLOCKING (r = virStoragePoolListVolumes (pool, names, i)); - CHECK_ERROR (r == -1, conn, "virStoragePoolListVolumes"); - - rv = caml_alloc (r, 0); - for (i = 0; i < r; ++i) { - strv = caml_copy_string (names[i]); - Store_field (rv, i, strv); - free (names[i]); - } - - CAMLreturn (rv); -#endif -} - -/* Automatically generated binding for virStorageVolFree. - * In generator.pl this function has signature "vol : free". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEVOLFREE -extern int virStorageVolFree (virStorageVolPtr vol) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_vol_free (value volv) -{ - CAMLparam1 (volv); -#ifndef HAVE_VIRSTORAGEVOLFREE - /* Symbol virStorageVolFree not found at compile time. */ - not_supported ("virStorageVolFree"); - CAMLnoreturn; -#else - /* Check that the symbol virStorageVolFree - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virStorageVolFree); - - virStorageVolPtr vol = Volume_val (volv); - virConnectPtr conn = Connect_volv (volv); - int r; - - NONBLOCKING (r = virStorageVolFree (vol)); - CHECK_ERROR (r == -1, conn, "virStorageVolFree"); - - /* So that we don't double-free in the finalizer: */ - Volume_val (volv) = NULL; - - CAMLreturn (Val_unit); -#endif -} - -/* Automatically generated binding for virStorageVolDelete. - * In generator.pl this function has signature "vol, uint : unit". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEVOLDELETE -extern int virStorageVolDelete (virStorageVolPtr vol, unsigned int i) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_vol_delete (value volv, value iv) -{ - CAMLparam2 (volv, iv); -#ifndef HAVE_VIRSTORAGEVOLDELETE - /* Symbol virStorageVolDelete not found at compile time. */ - not_supported ("virStorageVolDelete"); - CAMLnoreturn; -#else - /* Check that the symbol virStorageVolDelete - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virStorageVolDelete); - - virStorageVolPtr vol = Volume_val (volv); - virConnectPtr conn = Connect_volv (volv); - unsigned int i = Int_val (iv); - int r; - - NONBLOCKING (r = virStorageVolDelete (vol, i)); - CHECK_ERROR (!r, conn, "virStorageVolDelete"); - - CAMLreturn (Val_unit); -#endif -} - -/* Automatically generated binding for virStorageVolLookupByName. - * In generator.pl this function has signature "pool, string : vol from pool". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEVOLLOOKUPBYNAME -extern virStorageVolPtr virStorageVolLookupByName (virStoragePoolPtr pool, const char *str) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_vol_lookup_by_name (value poolv, value strv) -{ - CAMLparam2 (poolv, strv); -#ifndef HAVE_VIRSTORAGEVOLLOOKUPBYNAME - /* Symbol virStorageVolLookupByName not found at compile time. */ - not_supported ("virStorageVolLookupByName"); - CAMLnoreturn; -#else - /* Check that the symbol virStorageVolLookupByName - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virStorageVolLookupByName); - - CAMLlocal2 (rv, connv); - virStoragePoolPtr pool = Pool_val (poolv); - virConnectPtr conn = Connect_polv (poolv); - char *str = String_val (strv); - virStorageVolPtr r; - - NONBLOCKING (r = virStorageVolLookupByName (pool, str)); - CHECK_ERROR (!r, conn, "virStorageVolLookupByName"); - - connv = Field (poolv, 1); - rv = Val_volume (r, connv); - - CAMLreturn (rv); -#endif -} - -/* Automatically generated binding for virStorageVolLookupByKey. - * In generator.pl this function has signature "conn, string : vol". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEVOLLOOKUPBYKEY -extern virStorageVolPtr virStorageVolLookupByKey (virConnectPtr conn, const char *str) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_vol_lookup_by_key (value connv, value strv) -{ - CAMLparam2 (connv, strv); -#ifndef HAVE_VIRSTORAGEVOLLOOKUPBYKEY - /* Symbol virStorageVolLookupByKey not found at compile time. */ - not_supported ("virStorageVolLookupByKey"); - CAMLnoreturn; -#else - /* Check that the symbol virStorageVolLookupByKey - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virStorageVolLookupByKey); - - CAMLlocal1 (rv); - virConnectPtr conn = Connect_val (connv); - char *str = String_val (strv); - virStorageVolPtr r; - - NONBLOCKING (r = virStorageVolLookupByKey (conn, str)); - CHECK_ERROR (!r, conn, "virStorageVolLookupByKey"); - - rv = Val_volume (r, connv); - - CAMLreturn (rv); -#endif -} - -/* Automatically generated binding for virStorageVolLookupByPath. - * In generator.pl this function has signature "conn, string : vol". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEVOLLOOKUPBYPATH -extern virStorageVolPtr virStorageVolLookupByPath (virConnectPtr conn, const char *str) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_vol_lookup_by_path (value connv, value strv) -{ - CAMLparam2 (connv, strv); -#ifndef HAVE_VIRSTORAGEVOLLOOKUPBYPATH - /* Symbol virStorageVolLookupByPath not found at compile time. */ - not_supported ("virStorageVolLookupByPath"); - CAMLnoreturn; -#else - /* Check that the symbol virStorageVolLookupByPath - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virStorageVolLookupByPath); - - CAMLlocal1 (rv); - virConnectPtr conn = Connect_val (connv); - char *str = String_val (strv); - virStorageVolPtr r; - - NONBLOCKING (r = virStorageVolLookupByPath (conn, str)); - CHECK_ERROR (!r, conn, "virStorageVolLookupByPath"); - - rv = Val_volume (r, connv); - - CAMLreturn (rv); -#endif -} - -/* Automatically generated binding for virStorageVolCreateXML. - * In generator.pl this function has signature "pool, string, 0U : vol from pool". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEVOLCREATEXML -extern virStorageVolPtr virStorageVolCreateXML (virStoragePoolPtr pool, const char *str, unsigned int flags) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_vol_create_xml (value poolv, value strv) -{ - CAMLparam2 (poolv, strv); -#ifndef HAVE_VIRSTORAGEVOLCREATEXML - /* Symbol virStorageVolCreateXML not found at compile time. */ - not_supported ("virStorageVolCreateXML"); - CAMLnoreturn; -#else - /* Check that the symbol virStorageVolCreateXML - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virStorageVolCreateXML); - - CAMLlocal2 (rv, connv); - virStoragePoolPtr pool = Pool_val (poolv); - virConnectPtr conn = Connect_polv (poolv); - char *str = String_val (strv); - virStorageVolPtr r; - - NONBLOCKING (r = virStorageVolCreateXML (pool, str, 0)); - CHECK_ERROR (!r, conn, "virStorageVolCreateXML"); - - connv = Field (poolv, 1); - rv = Val_volume (r, connv); - - CAMLreturn (rv); -#endif -} - -/* Automatically generated binding for virStorageVolGetXMLDesc. - * In generator.pl this function has signature "vol, 0U : string". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEVOLGETXMLDESC -extern char *virStorageVolGetXMLDesc (virStorageVolPtr vol, unsigned int flags) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_vol_get_xml_desc (value volv) -{ - CAMLparam1 (volv); -#ifndef HAVE_VIRSTORAGEVOLGETXMLDESC - /* Symbol virStorageVolGetXMLDesc not found at compile time. */ - not_supported ("virStorageVolGetXMLDesc"); - CAMLnoreturn; -#else - /* Check that the symbol virStorageVolGetXMLDesc - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virStorageVolGetXMLDesc); - - CAMLlocal1 (rv); - virStorageVolPtr vol = Volume_val (volv); - virConnectPtr conn = Connect_volv (volv); - char *r; - - NONBLOCKING (r = virStorageVolGetXMLDesc (vol, 0)); - CHECK_ERROR (!r, conn, "virStorageVolGetXMLDesc"); - - rv = caml_copy_string (r); - free (r); - CAMLreturn (rv); -#endif -} - -/* Automatically generated binding for virStorageVolGetPath. - * In generator.pl this function has signature "vol : string". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEVOLGETPATH -extern char *virStorageVolGetPath (virStorageVolPtr vol) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_vol_get_path (value volv) -{ - CAMLparam1 (volv); -#ifndef HAVE_VIRSTORAGEVOLGETPATH - /* Symbol virStorageVolGetPath not found at compile time. */ - not_supported ("virStorageVolGetPath"); - CAMLnoreturn; -#else - /* Check that the symbol virStorageVolGetPath - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virStorageVolGetPath); - - CAMLlocal1 (rv); - virStorageVolPtr vol = Volume_val (volv); - virConnectPtr conn = Connect_volv (volv); - char *r; - - NONBLOCKING (r = virStorageVolGetPath (vol)); - CHECK_ERROR (!r, conn, "virStorageVolGetPath"); - - rv = caml_copy_string (r); - free (r); - CAMLreturn (rv); -#endif -} - -/* Automatically generated binding for virStorageVolGetKey. - * In generator.pl this function has signature "vol : static string". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEVOLGETKEY -extern const char *virStorageVolGetKey (virStorageVolPtr vol) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_vol_get_key (value volv) -{ - CAMLparam1 (volv); -#ifndef HAVE_VIRSTORAGEVOLGETKEY - /* Symbol virStorageVolGetKey not found at compile time. */ - not_supported ("virStorageVolGetKey"); - CAMLnoreturn; -#else - /* Check that the symbol virStorageVolGetKey - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virStorageVolGetKey); - - CAMLlocal1 (rv); - virStorageVolPtr vol = Volume_val (volv); - virConnectPtr conn = Connect_volv (volv); - const char *r; - - NONBLOCKING (r = virStorageVolGetKey (vol)); - CHECK_ERROR (!r, conn, "virStorageVolGetKey"); - - rv = caml_copy_string (r); - CAMLreturn (rv); -#endif -} - -/* Automatically generated binding for virStorageVolGetName. - * In generator.pl this function has signature "vol : static string". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEVOLGETNAME -extern const char *virStorageVolGetName (virStorageVolPtr vol) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_vol_get_name (value volv) -{ - CAMLparam1 (volv); -#ifndef HAVE_VIRSTORAGEVOLGETNAME - /* Symbol virStorageVolGetName not found at compile time. */ - not_supported ("virStorageVolGetName"); - CAMLnoreturn; -#else - /* Check that the symbol virStorageVolGetName - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virStorageVolGetName); - - CAMLlocal1 (rv); - virStorageVolPtr vol = Volume_val (volv); - virConnectPtr conn = Connect_volv (volv); - const char *r; - - NONBLOCKING (r = virStorageVolGetName (vol)); - CHECK_ERROR (!r, conn, "virStorageVolGetName"); - - rv = caml_copy_string (r); - CAMLreturn (rv); -#endif -} - -/* Automatically generated binding for virStoragePoolLookupByVolume. - * In generator.pl this function has signature "vol : pool from vol". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEPOOLLOOKUPBYVOLUME -extern virStoragePoolPtr virStoragePoolLookupByVolume (virStorageVolPtr vol) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_pool_lookup_by_volume (value volv) -{ - CAMLparam1 (volv); -#ifndef HAVE_VIRSTORAGEPOOLLOOKUPBYVOLUME - /* Symbol virStoragePoolLookupByVolume not found at compile time. */ - not_supported ("virStoragePoolLookupByVolume"); - CAMLnoreturn; -#else - /* Check that the symbol virStoragePoolLookupByVolume - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virStoragePoolLookupByVolume); - - CAMLlocal2 (rv, connv); - virStorageVolPtr vol = Volume_val (volv); - virConnectPtr conn = Connect_volv (volv); - virStoragePoolPtr r; - - NONBLOCKING (r = virStoragePoolLookupByVolume (vol)); - CHECK_ERROR (!r, conn, "virStoragePoolLookupByVolume"); - - connv = Field (volv, 1); - rv = Val_pool (r, connv); - - CAMLreturn (rv); -#endif -} - -/* Automatically generated binding for virJobFree. - * In generator.pl this function has signature "job : free". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRJOBFREE -extern int virJobFree (virJobPtr job) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_job_free (value jobv) -{ - CAMLparam1 (jobv); -#ifndef HAVE_VIRJOBFREE - /* Symbol virJobFree not found at compile time. */ - not_supported ("virJobFree"); - CAMLnoreturn; -#else - /* Check that the symbol virJobFree - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virJobFree); - - virJobPtr job = Job_val (jobv); - virConnectPtr conn = Connect_jobv (jobv); - int r; - - NONBLOCKING (r = virJobFree (job)); - CHECK_ERROR (r == -1, conn, "virJobFree"); - - /* So that we don't double-free in the finalizer: */ - Job_val (jobv) = NULL; - - CAMLreturn (Val_unit); -#endif -} - -/* Automatically generated binding for virJobCancel. - * In generator.pl this function has signature "job : unit". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRJOBCANCEL -extern int virJobCancel (virJobPtr job) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_job_cancel (value jobv) -{ - CAMLparam1 (jobv); -#ifndef HAVE_VIRJOBCANCEL - /* Symbol virJobCancel not found at compile time. */ - not_supported ("virJobCancel"); - CAMLnoreturn; -#else - /* Check that the symbol virJobCancel - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virJobCancel); - - virJobPtr job = Job_val (jobv); - virConnectPtr conn = Connect_jobv (jobv); - int r; - - NONBLOCKING (r = virJobCancel (job)); - CHECK_ERROR (r == -1, conn, "virJobCancel"); - - CAMLreturn (Val_unit); -#endif -} - -/* Automatically generated binding for virJobGetNetwork. - * In generator.pl this function has signature "job : net from job". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRJOBGETNETWORK -extern virNetworkPtr virJobGetNetwork (virJobPtr job) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_job_get_network (value jobv) -{ - CAMLparam1 (jobv); -#ifndef HAVE_VIRJOBGETNETWORK - /* Symbol virJobGetNetwork not found at compile time. */ - not_supported ("virJobGetNetwork"); - CAMLnoreturn; -#else - /* Check that the symbol virJobGetNetwork - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virJobGetNetwork); - - CAMLlocal2 (rv, connv); - virJobPtr job = Job_val (jobv); - virConnectPtr conn = Connect_jobv (jobv); - virNetworkPtr r; - - NONBLOCKING (r = virJobGetNetwork (job)); - CHECK_ERROR (!r, conn, "virJobGetNetwork"); - - connv = Field (jobv, 1); - rv = Val_network (r, connv); - - CAMLreturn (rv); -#endif -} - -/* Automatically generated binding for virJobGetDomain. - * In generator.pl this function has signature "job : dom from job". - */ - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRJOBGETDOMAIN -extern virDomainPtr virJobGetDomain (virJobPtr job) __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_job_get_domain (value jobv) -{ - CAMLparam1 (jobv); -#ifndef HAVE_VIRJOBGETDOMAIN - /* Symbol virJobGetDomain not found at compile time. */ - not_supported ("virJobGetDomain"); - CAMLnoreturn; -#else - /* Check that the symbol virJobGetDomain - * is in runtime version of libvirt. - */ - WEAK_SYMBOL_CHECK (virJobGetDomain); - - CAMLlocal2 (rv, connv); - virJobPtr job = Job_val (jobv); - virConnectPtr conn = Connect_jobv (jobv); - virDomainPtr r; - - NONBLOCKING (r = virJobGetDomain (job)); - CHECK_ERROR (!r, conn, "virJobGetDomain"); - - connv = Field (jobv, 1); - rv = Val_domain (r, connv); - - CAMLreturn (rv); -#endif -} - -#include "libvirt_c_epilogue.c" - -/* EOF */ diff --git a/libvirt/libvirt_c_epilogue.c b/libvirt/libvirt_c_epilogue.c deleted file mode 100644 index 78bd23e..0000000 --- a/libvirt/libvirt_c_epilogue.c +++ /dev/null @@ -1,548 +0,0 @@ -/* OCaml bindings for libvirt. - * (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - * http://libvirt.org/ - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2 of the License, or (at your option) any later version. - * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - */ - -/* Please read libvirt/README file. */ - -static char * -Optstring_val (value strv) -{ - if (strv == Val_int (0)) /* None */ - return NULL; - else /* Some string */ - return String_val (Field (strv, 0)); -} - -static value -Val_opt (void *ptr, Val_ptr_t Val_ptr) -{ - CAMLparam0 (); - CAMLlocal2 (optv, ptrv); - - if (ptr) { /* Some ptr */ - optv = caml_alloc (1, 0); - ptrv = Val_ptr (ptr); - Store_field (optv, 0, ptrv); - } else /* None */ - optv = Val_int (0); - - CAMLreturn (optv); -} - -#if 0 -static value -option_default (value option, value deflt) -{ - if (option == Val_int (0)) /* "None" */ - return deflt; - else /* "Some 'a" */ - return Field (option, 0); -} -#endif - -static void -_raise_virterror (virConnectPtr conn, const char *fn) -{ - CAMLparam0 (); - CAMLlocal1 (rv); - virErrorPtr errp; - struct _virError err; - - errp = conn ? virConnGetLastError (conn) : virGetLastError (); - - if (!errp) { - /* Fake a _virError structure. */ - memset (&err, 0, sizeof err); - err.code = VIR_ERR_INTERNAL_ERROR; - err.domain = VIR_FROM_NONE; - err.level = VIR_ERR_ERROR; - err.message = (char *) fn; - errp = &err; - } - - rv = Val_virterror (errp); - caml_raise_with_arg (*caml_named_value ("ocaml_libvirt_virterror"), rv); - - /*NOTREACHED*/ - /* Suppresses a compiler warning. */ - (void) caml__frame; -} - -/* Raise an error if a function is not supported. */ -static void -not_supported (const char *fn) -{ - CAMLparam0 (); - CAMLlocal1 (fnv); - - fnv = caml_copy_string (fn); - caml_raise_with_arg (*caml_named_value ("ocaml_libvirt_not_supported"), fnv); - - /*NOTREACHED*/ - /* Suppresses a compiler warning. */ - (void) caml__frame; -} - -/* Convert the virErrorNumber, virErrorDomain and virErrorLevel enums - * into values (longs because they are variants in OCaml). - * - * The enum values are part of the libvirt ABI so they cannot change, - * which means that we can convert these numbers directly into - * OCaml variants (which use the same ordering) very fast. - * - * The tricky part here is when we are linked to a newer version of - * libvirt than the one we were compiled against. If the newer libvirt - * generates an error code which we don't know about then we need - * to convert it into VIR_*_UNKNOWN (code). - */ - -#define MAX_VIR_CODE 50 /* VIR_ERR_NO_STORAGE_VOL */ -#define MAX_VIR_DOMAIN 17 /* VIR_FROM_STORAGE */ -#define MAX_VIR_LEVEL VIR_ERR_ERROR - -static inline value -Val_err_number (virErrorNumber code) -{ - CAMLparam0 (); - CAMLlocal1 (rv); - - if (0 <= code && code <= MAX_VIR_CODE) - rv = Val_int (code); - else { - rv = caml_alloc (1, 0); /* VIR_ERR_UNKNOWN (code) */ - Store_field (rv, 0, Val_int (code)); - } - - CAMLreturn (rv); -} - -static inline value -Val_err_domain (virErrorDomain code) -{ - CAMLparam0 (); - CAMLlocal1 (rv); - - if (0 <= code && code <= MAX_VIR_DOMAIN) - rv = Val_int (code); - else { - rv = caml_alloc (1, 0); /* VIR_FROM_UNKNOWN (code) */ - Store_field (rv, 0, Val_int (code)); - } - - CAMLreturn (rv); -} - -static inline value -Val_err_level (virErrorLevel code) -{ - CAMLparam0 (); - CAMLlocal1 (rv); - - if (0 <= code && code <= MAX_VIR_LEVEL) - rv = Val_int (code); - else { - rv = caml_alloc (1, 0); /* VIR_ERR_UNKNOWN_LEVEL (code) */ - Store_field (rv, 0, Val_int (code)); - } - - CAMLreturn (rv); -} - -/* Convert a virterror to a value. */ -static value -Val_virterror (virErrorPtr err) -{ - CAMLparam0 (); - CAMLlocal3 (rv, connv, optv); - - rv = caml_alloc (12, 0); - Store_field (rv, 0, Val_err_number (err->code)); - Store_field (rv, 1, Val_err_domain (err->domain)); - Store_field (rv, 2, - Val_opt (err->message, (Val_ptr_t) caml_copy_string)); - Store_field (rv, 3, Val_err_level (err->level)); - - /* conn, dom and net fields, all optional */ - if (err->conn) { - connv = Val_connect_no_finalize (err->conn); - optv = caml_alloc (1, 0); - Store_field (optv, 0, connv); - Store_field (rv, 4, optv); /* Some conn */ - - if (err->dom) { - optv = caml_alloc (1, 0); - Store_field (optv, 0, Val_domain_no_finalize (err->dom, connv)); - Store_field (rv, 5, optv); /* Some (dom, conn) */ - } - else - Store_field (rv, 5, Val_int (0)); /* None */ - if (err->net) { - optv = caml_alloc (1, 0); - Store_field (optv, 0, Val_network_no_finalize (err->net, connv)); - Store_field (rv, 11, optv); /* Some (net, conn) */ - } else - Store_field (rv, 11, Val_int (0)); /* None */ - } else { - Store_field (rv, 4, Val_int (0)); /* None */ - Store_field (rv, 5, Val_int (0)); /* None */ - Store_field (rv, 11, Val_int (0)); /* None */ - } - - Store_field (rv, 6, - Val_opt (err->str1, (Val_ptr_t) caml_copy_string)); - Store_field (rv, 7, - Val_opt (err->str2, (Val_ptr_t) caml_copy_string)); - Store_field (rv, 8, - Val_opt (err->str3, (Val_ptr_t) caml_copy_string)); - Store_field (rv, 9, caml_copy_int32 (err->int1)); - Store_field (rv, 10, caml_copy_int32 (err->int2)); - - CAMLreturn (rv); -} - -static void conn_finalize (value); -static void dom_finalize (value); -static void net_finalize (value); -#ifdef HAVE_VIRSTORAGEPOOLPTR -static void pol_finalize (value); -#endif -#ifdef HAVE_VIRSTORAGEVOLPTR -static void vol_finalize (value); -#endif -#ifdef HAVE_VIRJOBPTR -static void jb_finalize (value); -#endif - -static struct custom_operations conn_custom_operations = { - "conn_custom_operations", - conn_finalize, - custom_compare_default, - custom_hash_default, - custom_serialize_default, - custom_deserialize_default -}; - -static struct custom_operations dom_custom_operations = { - "dom_custom_operations", - dom_finalize, - custom_compare_default, - custom_hash_default, - custom_serialize_default, - custom_deserialize_default - -}; - -static struct custom_operations net_custom_operations = { - "net_custom_operations", - net_finalize, - custom_compare_default, - custom_hash_default, - custom_serialize_default, - custom_deserialize_default -}; - -#ifdef HAVE_VIRSTORAGEPOOLPTR -static struct custom_operations pol_custom_operations = { - "pol_custom_operations", - pol_finalize, - custom_compare_default, - custom_hash_default, - custom_serialize_default, - custom_deserialize_default -}; -#endif - -#ifdef HAVE_VIRSTORAGEVOLPTR -static struct custom_operations vol_custom_operations = { - "vol_custom_operations", - vol_finalize, - custom_compare_default, - custom_hash_default, - custom_serialize_default, - custom_deserialize_default -}; -#endif - -#ifdef HAVE_VIRJOBPTR -static struct custom_operations jb_custom_operations = { - "jb_custom_operations", - jb_finalize, - custom_compare_default, - custom_hash_default, - custom_serialize_default, - custom_deserialize_default -}; -#endif - -static value -Val_connect (virConnectPtr conn) -{ - CAMLparam0 (); - CAMLlocal1 (rv); - rv = caml_alloc_custom (&conn_custom_operations, - sizeof (virConnectPtr), 0, 1); - Connect_val (rv) = conn; - CAMLreturn (rv); -} - -static value -Val_dom (virDomainPtr dom) -{ - CAMLparam0 (); - CAMLlocal1 (rv); - rv = caml_alloc_custom (&dom_custom_operations, - sizeof (virDomainPtr), 0, 1); - Dom_val (rv) = dom; - CAMLreturn (rv); -} - -static value -Val_net (virNetworkPtr net) -{ - CAMLparam0 (); - CAMLlocal1 (rv); - rv = caml_alloc_custom (&net_custom_operations, - sizeof (virNetworkPtr), 0, 1); - Net_val (rv) = net; - CAMLreturn (rv); -} - -#ifdef HAVE_VIRSTORAGEPOOLPTR -static value -Val_pol (virStoragePoolPtr pol) -{ - CAMLparam0 (); - CAMLlocal1 (rv); - rv = caml_alloc_custom (&pol_custom_operations, - sizeof (virStoragePoolPtr), 0, 1); - Pol_val (rv) = pol; - CAMLreturn (rv); -} -#endif - -#ifdef HAVE_VIRSTORAGEVOLPTR -static value -Val_vol (virStorageVolPtr vol) -{ - CAMLparam0 (); - CAMLlocal1 (rv); - rv = caml_alloc_custom (&vol_custom_operations, - sizeof (virStorageVolPtr), 0, 1); - Vol_val (rv) = vol; - CAMLreturn (rv); -} -#endif - -#ifdef HAVE_VIRJOBPTR -static value -Val_jb (virJobPtr jb) -{ - CAMLparam0 (); - CAMLlocal1 (rv); - rv = caml_alloc_custom (&jb_custom_operations, - sizeof (virJobPtr), 0, 1); - Jb_val (rv) = jb; - CAMLreturn (rv); -} -#endif - -/* No-finalize versions of Val_connect, Val_dom, Val_net ONLY for use - * by virterror wrappers. - */ -static value -Val_connect_no_finalize (virConnectPtr conn) -{ - CAMLparam0 (); - CAMLlocal1 (rv); - rv = caml_alloc (1, Abstract_tag); - Store_field (rv, 0, (value) conn); - CAMLreturn (rv); -} - -static value -Val_dom_no_finalize (virDomainPtr dom) -{ - CAMLparam0 (); - CAMLlocal1 (rv); - rv = caml_alloc (1, Abstract_tag); - Store_field (rv, 0, (value) dom); - CAMLreturn (rv); -} - -static value -Val_net_no_finalize (virNetworkPtr net) -{ - CAMLparam0 (); - CAMLlocal1 (rv); - rv = caml_alloc (1, Abstract_tag); - Store_field (rv, 0, (value) net); - CAMLreturn (rv); -} - -/* This wraps up the (dom, conn) pair (Domain.t). */ -static value -Val_domain (virDomainPtr dom, value connv) -{ - CAMLparam1 (connv); - CAMLlocal2 (rv, v); - - rv = caml_alloc_tuple (2); - v = Val_dom (dom); - Store_field (rv, 0, v); - Store_field (rv, 1, connv); - CAMLreturn (rv); -} - -/* This wraps up the (net, conn) pair (Network.t). */ -static value -Val_network (virNetworkPtr net, value connv) -{ - CAMLparam1 (connv); - CAMLlocal2 (rv, v); - - rv = caml_alloc_tuple (2); - v = Val_net (net); - Store_field (rv, 0, v); - Store_field (rv, 1, connv); - CAMLreturn (rv); -} - -#ifdef HAVE_VIRSTORAGEPOOLPTR -/* This wraps up the (pol, conn) pair (Pool.t). */ -static value -Val_pool (virStoragePoolPtr pol, value connv) -{ - CAMLparam1 (connv); - CAMLlocal2 (rv, v); - - rv = caml_alloc_tuple (2); - v = Val_pol (pol); - Store_field (rv, 0, v); - Store_field (rv, 1, connv); - CAMLreturn (rv); -} -#endif - -#ifdef HAVE_VIRSTORAGEVOLPTR -/* This wraps up the (vol, conn) pair (Volume.t). */ -static value -Val_volume (virStorageVolPtr vol, value connv) -{ - CAMLparam1 (connv); - CAMLlocal2 (rv, v); - - rv = caml_alloc_tuple (2); - v = Val_vol (vol); - Store_field (rv, 0, v); - Store_field (rv, 1, connv); - CAMLreturn (rv); -} -#endif - -#ifdef HAVE_VIRJOBPTR -/* This wraps up the (jb, conn) pair (Job.t). */ -static value -Val_job (virJobPtr jb, value connv) -{ - CAMLparam1 (connv); - CAMLlocal2 (rv, v); - - rv = caml_alloc_tuple (2); - v = Val_jb (jb); - Store_field (rv, 0, v); - Store_field (rv, 1, connv); - CAMLreturn (rv); -} -#endif - -/* No-finalize versions of Val_domain, Val_network ONLY for use by - * virterror wrappers. - */ -static value -Val_domain_no_finalize (virDomainPtr dom, value connv) -{ - CAMLparam1 (connv); - CAMLlocal2 (rv, v); - - rv = caml_alloc_tuple (2); - v = Val_dom_no_finalize (dom); - Store_field (rv, 0, v); - Store_field (rv, 1, connv); - CAMLreturn (rv); -} - -static value -Val_network_no_finalize (virNetworkPtr net, value connv) -{ - CAMLparam1 (connv); - CAMLlocal2 (rv, v); - - rv = caml_alloc_tuple (2); - v = Val_net_no_finalize (net); - Store_field (rv, 0, v); - Store_field (rv, 1, connv); - CAMLreturn (rv); -} - -static void -conn_finalize (value connv) -{ - virConnectPtr conn = Connect_val (connv); - if (conn) (void) virConnectClose (conn); -} - -static void -dom_finalize (value domv) -{ - virDomainPtr dom = Dom_val (domv); - if (dom) (void) virDomainFree (dom); -} - -static void -net_finalize (value netv) -{ - virNetworkPtr net = Net_val (netv); - if (net) (void) virNetworkFree (net); -} - -#ifdef HAVE_VIRSTORAGEPOOLPTR -static void -pol_finalize (value polv) -{ - virStoragePoolPtr pol = Pol_val (polv); - if (pol) (void) virStoragePoolFree (pol); -} -#endif - -#ifdef HAVE_VIRSTORAGEVOLPTR -static void -vol_finalize (value volv) -{ - virStorageVolPtr vol = Vol_val (volv); - if (vol) (void) virStorageVolFree (vol); -} -#endif - -#ifdef HAVE_VIRJOBPTR -static void -jb_finalize (value jbv) -{ - virJobPtr jb = Jb_val (jbv); - if (jb) (void) virJobFree (jb); -} -#endif diff --git a/libvirt/libvirt_c_oneoffs.c b/libvirt/libvirt_c_oneoffs.c deleted file mode 100644 index 5df783e..0000000 --- a/libvirt/libvirt_c_oneoffs.c +++ /dev/null @@ -1,822 +0,0 @@ -/* OCaml bindings for libvirt. - * (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - * http://libvirt.org/ - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2 of the License, or (at your option) any later version. - * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - */ - -/* Please read libvirt/README file. */ - -/*----------------------------------------------------------------------*/ - -CAMLprim value -ocaml_libvirt_get_version (value driverv, value unit) -{ - CAMLparam2 (driverv, unit); - CAMLlocal1 (rv); - const char *driver = Optstring_val (driverv); - unsigned long libVer, typeVer = 0, *typeVer_ptr; - int r; - - typeVer_ptr = driver ? &typeVer : NULL; - NONBLOCKING (r = virGetVersion (&libVer, driver, typeVer_ptr)); - CHECK_ERROR (r == -1, NULL, "virGetVersion"); - - rv = caml_alloc_tuple (2); - Store_field (rv, 0, Val_int (libVer)); - Store_field (rv, 1, Val_int (typeVer)); - CAMLreturn (rv); -} - -/*----------------------------------------------------------------------*/ - -/* Connection object. */ - -CAMLprim value -ocaml_libvirt_connect_open (value namev, value unit) -{ - CAMLparam2 (namev, unit); - CAMLlocal1 (rv); - const char *name = Optstring_val (namev); - virConnectPtr conn; - - NONBLOCKING (conn = virConnectOpen (name)); - CHECK_ERROR (!conn, NULL, "virConnectOpen"); - - rv = Val_connect (conn); - - CAMLreturn (rv); -} - -CAMLprim value -ocaml_libvirt_connect_open_readonly (value namev, value unit) -{ - CAMLparam2 (namev, unit); - CAMLlocal1 (rv); - const char *name = Optstring_val (namev); - virConnectPtr conn; - - NONBLOCKING (conn = virConnectOpenReadOnly (name)); - CHECK_ERROR (!conn, NULL, "virConnectOpen"); - - rv = Val_connect (conn); - - CAMLreturn (rv); -} - -CAMLprim value -ocaml_libvirt_connect_get_version (value connv) -{ - CAMLparam1 (connv); - virConnectPtr conn = Connect_val (connv); - unsigned long hvVer; - int r; - - NONBLOCKING (r = virConnectGetVersion (conn, &hvVer)); - CHECK_ERROR (r == -1, conn, "virConnectGetVersion"); - - CAMLreturn (Val_int (hvVer)); -} - -CAMLprim value -ocaml_libvirt_connect_get_max_vcpus (value connv, value typev) -{ - CAMLparam2 (connv, typev); - virConnectPtr conn = Connect_val (connv); - const char *type = Optstring_val (typev); - int r; - - NONBLOCKING (r = virConnectGetMaxVcpus (conn, type)); - CHECK_ERROR (r == -1, conn, "virConnectGetMaxVcpus"); - - CAMLreturn (Val_int (r)); -} - -CAMLprim value -ocaml_libvirt_connect_get_node_info (value connv) -{ - CAMLparam1 (connv); - CAMLlocal2 (rv, v); - virConnectPtr conn = Connect_val (connv); - virNodeInfo info; - int r; - - NONBLOCKING (r = virNodeGetInfo (conn, &info)); - CHECK_ERROR (r == -1, conn, "virNodeGetInfo"); - - rv = caml_alloc (8, 0); - v = caml_copy_string (info.model); Store_field (rv, 0, v); - v = caml_copy_int64 (info.memory); Store_field (rv, 1, v); - Store_field (rv, 2, Val_int (info.cpus)); - Store_field (rv, 3, Val_int (info.mhz)); - Store_field (rv, 4, Val_int (info.nodes)); - Store_field (rv, 5, Val_int (info.sockets)); - Store_field (rv, 6, Val_int (info.cores)); - Store_field (rv, 7, Val_int (info.threads)); - - CAMLreturn (rv); -} - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRNODEGETFREEMEMORY -extern unsigned long long virNodeGetFreeMemory (virConnectPtr conn) - __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_connect_node_get_free_memory (value connv) -{ -#ifdef HAVE_VIRNODEGETFREEMEMORY - CAMLparam1 (connv); - CAMLlocal1 (rv); - virConnectPtr conn = Connect_val (connv); - unsigned long long r; - - WEAK_SYMBOL_CHECK (virNodeGetFreeMemory); - NONBLOCKING (r = virNodeGetFreeMemory (conn)); - CHECK_ERROR (r == 0, conn, "virNodeGetFreeMemory"); - - rv = caml_copy_int64 ((int64) r); - CAMLreturn (rv); -#else - not_supported ("virNodeGetFreeMemory"); -#endif -} - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRNODEGETCELLSFREEMEMORY -extern int virNodeGetCellsFreeMemory (virConnectPtr conn, - unsigned long long *freeMems, - int startCell, int maxCells) - __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_connect_node_get_cells_free_memory (value connv, - value startv, value maxv) -{ -#ifdef HAVE_VIRNODEGETCELLSFREEMEMORY - CAMLparam3 (connv, startv, maxv); - CAMLlocal2 (rv, iv); - virConnectPtr conn = Connect_val (connv); - int start = Int_val (startv); - int max = Int_val (maxv); - int r, i; - unsigned long long freemems[max]; - - WEAK_SYMBOL_CHECK (virNodeGetCellsFreeMemory); - NONBLOCKING (r = virNodeGetCellsFreeMemory (conn, freemems, start, max)); - CHECK_ERROR (r == -1, conn, "virNodeGetCellsFreeMemory"); - - rv = caml_alloc (r, 0); - for (i = 0; i < r; ++i) { - iv = caml_copy_int64 ((int64) freemems[i]); - Store_field (rv, i, iv); - } - - CAMLreturn (rv); -#else - not_supported ("virNodeGetCellsFreeMemory"); -#endif -} - -CAMLprim value -ocaml_libvirt_domain_get_id (value domv) -{ - CAMLparam1 (domv); - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - unsigned int r; - - NONBLOCKING (r = virDomainGetID (dom)); - /* There's a bug in libvirt which means that if you try to get - * the ID of a defined-but-not-running domain, it returns -1, - * and there's no way to distinguish that from an error. - */ - CHECK_ERROR (r == (unsigned int) -1, conn, "virDomainGetID"); - - CAMLreturn (Val_int ((int) r)); -} - -CAMLprim value -ocaml_libvirt_domain_get_max_memory (value domv) -{ - CAMLparam1 (domv); - CAMLlocal1 (rv); - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - unsigned long r; - - NONBLOCKING (r = virDomainGetMaxMemory (dom)); - CHECK_ERROR (r == 0 /* [sic] */, conn, "virDomainGetMaxMemory"); - - rv = caml_copy_int64 (r); - CAMLreturn (rv); -} - -CAMLprim value -ocaml_libvirt_domain_set_max_memory (value domv, value memv) -{ - CAMLparam2 (domv, memv); - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - unsigned long mem = Int64_val (memv); - int r; - - NONBLOCKING (r = virDomainSetMaxMemory (dom, mem)); - CHECK_ERROR (r == -1, conn, "virDomainSetMaxMemory"); - - CAMLreturn (Val_unit); -} - -CAMLprim value -ocaml_libvirt_domain_set_memory (value domv, value memv) -{ - CAMLparam2 (domv, memv); - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - unsigned long mem = Int64_val (memv); - int r; - - NONBLOCKING (r = virDomainSetMemory (dom, mem)); - CHECK_ERROR (r == -1, conn, "virDomainSetMemory"); - - CAMLreturn (Val_unit); -} - -CAMLprim value -ocaml_libvirt_domain_get_info (value domv) -{ - CAMLparam1 (domv); - CAMLlocal2 (rv, v); - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - virDomainInfo info; - int r; - - NONBLOCKING (r = virDomainGetInfo (dom, &info)); - CHECK_ERROR (r == -1, conn, "virDomainGetInfo"); - - rv = caml_alloc (5, 0); - Store_field (rv, 0, Val_int (info.state)); // These flags are compatible. - v = caml_copy_int64 (info.maxMem); Store_field (rv, 1, v); - v = caml_copy_int64 (info.memory); Store_field (rv, 2, v); - Store_field (rv, 3, Val_int (info.nrVirtCpu)); - v = caml_copy_int64 (info.cpuTime); Store_field (rv, 4, v); - - CAMLreturn (rv); -} - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRDOMAINGETSCHEDULERTYPE -extern char *virDomainGetSchedulerType(virDomainPtr domain, - int *nparams) - __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_domain_get_scheduler_type (value domv) -{ -#ifdef HAVE_VIRDOMAINGETSCHEDULERTYPE - CAMLparam1 (domv); - CAMLlocal2 (rv, strv); - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - char *r; - int nparams; - - WEAK_SYMBOL_CHECK (virDomainGetSchedulerType); - NONBLOCKING (r = virDomainGetSchedulerType (dom, &nparams)); - CHECK_ERROR (!r, conn, "virDomainGetSchedulerType"); - - rv = caml_alloc_tuple (2); - strv = caml_copy_string (r); Store_field (rv, 0, strv); - free (r); - Store_field (rv, 1, nparams); - CAMLreturn (rv); -#else - not_supported ("virDomainGetSchedulerType"); -#endif -} - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRDOMAINGETSCHEDULERPARAMETERS -extern int virDomainGetSchedulerParameters (virDomainPtr domain, - virSchedParameterPtr params, - int *nparams) - __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_domain_get_scheduler_parameters (value domv, value nparamsv) -{ -#ifdef HAVE_VIRDOMAINGETSCHEDULERPARAMETERS - CAMLparam2 (domv, nparamsv); - CAMLlocal4 (rv, v, v2, v3); - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - int nparams = Int_val (nparamsv); - virSchedParameter params[nparams]; - int r, i; - - WEAK_SYMBOL_CHECK (virDomainGetSchedulerParameters); - NONBLOCKING (r = virDomainGetSchedulerParameters (dom, params, &nparams)); - CHECK_ERROR (r == -1, conn, "virDomainGetSchedulerParameters"); - - rv = caml_alloc (nparams, 0); - for (i = 0; i < nparams; ++i) { - v = caml_alloc_tuple (2); Store_field (rv, i, v); - v2 = caml_copy_string (params[i].field); Store_field (v, 0, v2); - switch (params[i].type) { - case VIR_DOMAIN_SCHED_FIELD_INT: - v2 = caml_alloc (1, 0); - v3 = caml_copy_int32 (params[i].value.i); Store_field (v2, 0, v3); - break; - case VIR_DOMAIN_SCHED_FIELD_UINT: - v2 = caml_alloc (1, 1); - v3 = caml_copy_int32 (params[i].value.ui); Store_field (v2, 0, v3); - break; - case VIR_DOMAIN_SCHED_FIELD_LLONG: - v2 = caml_alloc (1, 2); - v3 = caml_copy_int64 (params[i].value.l); Store_field (v2, 0, v3); - break; - case VIR_DOMAIN_SCHED_FIELD_ULLONG: - v2 = caml_alloc (1, 3); - v3 = caml_copy_int64 (params[i].value.ul); Store_field (v2, 0, v3); - break; - case VIR_DOMAIN_SCHED_FIELD_DOUBLE: - v2 = caml_alloc (1, 4); - v3 = caml_copy_double (params[i].value.d); Store_field (v2, 0, v3); - break; - case VIR_DOMAIN_SCHED_FIELD_BOOLEAN: - v2 = caml_alloc (1, 5); - Store_field (v2, 0, Val_int (params[i].value.b)); - break; - default: - caml_failwith ((char *)__FUNCTION__); - } - Store_field (v, 1, v2); - } - CAMLreturn (rv); -#else - not_supported ("virDomainGetSchedulerParameters"); -#endif -} - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRDOMAINSETSCHEDULERPARAMETERS -extern int virDomainSetSchedulerParameters (virDomainPtr domain, - virSchedParameterPtr params, - int nparams) - __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_domain_set_scheduler_parameters (value domv, value paramsv) -{ -#ifdef HAVE_VIRDOMAINSETSCHEDULERPARAMETERS - CAMLparam2 (domv, paramsv); - CAMLlocal1 (v); - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - int nparams = Wosize_val (paramsv); - virSchedParameter params[nparams]; - int r, i; - char *name; - - for (i = 0; i < nparams; ++i) { - v = Field (paramsv, i); /* Points to the two-element tuple. */ - name = String_val (Field (v, 0)); - strncpy (params[i].field, name, VIR_DOMAIN_SCHED_FIELD_LENGTH); - params[i].field[VIR_DOMAIN_SCHED_FIELD_LENGTH-1] = '\0'; - v = Field (v, 1); /* Points to the sched_param_value block. */ - switch (Tag_val (v)) { - case 0: - params[i].type = VIR_DOMAIN_SCHED_FIELD_INT; - params[i].value.i = Int32_val (Field (v, 0)); - break; - case 1: - params[i].type = VIR_DOMAIN_SCHED_FIELD_UINT; - params[i].value.ui = Int32_val (Field (v, 0)); - break; - case 2: - params[i].type = VIR_DOMAIN_SCHED_FIELD_LLONG; - params[i].value.l = Int64_val (Field (v, 0)); - break; - case 3: - params[i].type = VIR_DOMAIN_SCHED_FIELD_ULLONG; - params[i].value.ul = Int64_val (Field (v, 0)); - break; - case 4: - params[i].type = VIR_DOMAIN_SCHED_FIELD_DOUBLE; - params[i].value.d = Double_val (Field (v, 0)); - break; - case 5: - params[i].type = VIR_DOMAIN_SCHED_FIELD_BOOLEAN; - params[i].value.b = Int_val (Field (v, 0)); - break; - default: - caml_failwith ((char *)__FUNCTION__); - } - } - - WEAK_SYMBOL_CHECK (virDomainSetSchedulerParameters); - NONBLOCKING (r = virDomainSetSchedulerParameters (dom, params, nparams)); - CHECK_ERROR (r == -1, conn, "virDomainSetSchedulerParameters"); - - CAMLreturn (Val_unit); -#else - not_supported ("virDomainSetSchedulerParameters"); -#endif -} - -CAMLprim value -ocaml_libvirt_domain_set_vcpus (value domv, value nvcpusv) -{ - CAMLparam2 (domv, nvcpusv); - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - int r, nvcpus = Int_val (nvcpusv); - - NONBLOCKING (r = virDomainSetVcpus (dom, nvcpus)); - CHECK_ERROR (r == -1, conn, "virDomainSetVcpus"); - - CAMLreturn (Val_unit); -} - -CAMLprim value -ocaml_libvirt_domain_pin_vcpu (value domv, value vcpuv, value cpumapv) -{ - CAMLparam3 (domv, vcpuv, cpumapv); - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - int maplen = caml_string_length (cpumapv); - unsigned char *cpumap = (unsigned char *) String_val (cpumapv); - int vcpu = Int_val (vcpuv); - int r; - - NONBLOCKING (r = virDomainPinVcpu (dom, vcpu, cpumap, maplen)); - CHECK_ERROR (r == -1, conn, "virDomainPinVcpu"); - - CAMLreturn (Val_unit); -} - -CAMLprim value -ocaml_libvirt_domain_get_vcpus (value domv, value maxinfov, value maplenv) -{ - CAMLparam3 (domv, maxinfov, maplenv); - CAMLlocal5 (rv, infov, strv, v, v2); - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - int maxinfo = Int_val (maxinfov); - int maplen = Int_val (maplenv); - virVcpuInfo info[maxinfo]; - unsigned char cpumaps[maxinfo * maplen]; - int r, i; - - memset (info, 0, sizeof (virVcpuInfo) * maxinfo); - memset (cpumaps, 0, maxinfo * maplen); - - NONBLOCKING (r = virDomainGetVcpus (dom, info, maxinfo, cpumaps, maplen)); - CHECK_ERROR (r == -1, conn, "virDomainPinVcpu"); - - /* Copy the virVcpuInfo structures. */ - infov = caml_alloc (maxinfo, 0); - for (i = 0; i < maxinfo; ++i) { - v2 = caml_alloc (4, 0); Store_field (infov, i, v2); - Store_field (v2, 0, Val_int (info[i].number)); - Store_field (v2, 1, Val_int (info[i].state)); - v = caml_copy_int64 (info[i].cpuTime); Store_field (v2, 2, v); - Store_field (v2, 3, Val_int (info[i].cpu)); - } - - /* Copy the bitmap. */ - strv = caml_alloc_string (maxinfo * maplen); - memcpy (String_val (strv), cpumaps, maxinfo * maplen); - - /* Allocate the tuple and return it. */ - rv = caml_alloc_tuple (3); - Store_field (rv, 0, Val_int (r)); /* number of CPUs. */ - Store_field (rv, 1, infov); - Store_field (rv, 2, strv); - - CAMLreturn (rv); -} - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRDOMAINMIGRATE -extern virDomainPtr virDomainMigrate (virDomainPtr domain, virConnectPtr dconn, - unsigned long flags, const char *dname, - const char *uri, unsigned long bandwidth) - __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_domain_migrate_native (value domv, value dconnv, value flagsv, value optdnamev, value opturiv, value optbandwidthv, value unitv) -{ -#ifdef HAVE_VIRDOMAINMIGRATE - CAMLparam5 (domv, dconnv, flagsv, optdnamev, opturiv); - CAMLxparam2 (optbandwidthv, unitv); - CAMLlocal2 (flagv, rv); - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - virConnectPtr dconn = Connect_val (dconnv); - int flags = 0; - const char *dname = Optstring_val (optdnamev); - const char *uri = Optstring_val (opturiv); - unsigned long bandwidth; - virDomainPtr r; - - /* Iterate over the list of flags. */ - for (; flagsv != Val_int (0); flagsv = Field (flagsv, 1)) - { - flagv = Field (flagsv, 0); - if (flagv == Int_val(0)) - flags |= VIR_MIGRATE_LIVE; - } - - if (optbandwidthv == Val_int (0)) /* None */ - bandwidth = 0; - else /* Some bandwidth */ - bandwidth = Int_val (Field (optbandwidthv, 0)); - - WEAK_SYMBOL_CHECK (virDomainMigrate); - NONBLOCKING (r = virDomainMigrate (dom, dconn, flags, dname, uri, bandwidth)); - CHECK_ERROR (!r, conn, "virDomainMigrate"); - - rv = Val_domain (r, dconnv); - - CAMLreturn (rv); - -#else /* virDomainMigrate not supported */ - not_supported ("virDomainMigrate"); -#endif -} - -CAMLprim value -ocaml_libvirt_domain_migrate_bytecode (value *argv, int argn) -{ - return ocaml_libvirt_domain_migrate_native (argv[0], argv[1], argv[2], - argv[3], argv[4], argv[5], - argv[6]); -} - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRDOMAINBLOCKSTATS -extern int virDomainBlockStats (virDomainPtr dom, - const char *path, - virDomainBlockStatsPtr stats, - size_t size) - __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_domain_block_stats (value domv, value pathv) -{ -#if HAVE_VIRDOMAINBLOCKSTATS - CAMLparam2 (domv, pathv); - CAMLlocal2 (rv,v); - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - char *path = String_val (pathv); - struct _virDomainBlockStats stats; - int r; - - WEAK_SYMBOL_CHECK (virDomainBlockStats); - NONBLOCKING (r = virDomainBlockStats (dom, path, &stats, sizeof stats)); - CHECK_ERROR (r == -1, conn, "virDomainBlockStats"); - - rv = caml_alloc (5, 0); - v = caml_copy_int64 (stats.rd_req); Store_field (rv, 0, v); - v = caml_copy_int64 (stats.rd_bytes); Store_field (rv, 1, v); - v = caml_copy_int64 (stats.wr_req); Store_field (rv, 2, v); - v = caml_copy_int64 (stats.wr_bytes); Store_field (rv, 3, v); - v = caml_copy_int64 (stats.errs); Store_field (rv, 4, v); - - CAMLreturn (rv); -#else - not_supported ("virDomainBlockStats"); -#endif -} - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRDOMAININTERFACESTATS -extern int virDomainInterfaceStats (virDomainPtr dom, - const char *path, - virDomainInterfaceStatsPtr stats, - size_t size) - __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_domain_interface_stats (value domv, value pathv) -{ -#if HAVE_VIRDOMAININTERFACESTATS - CAMLparam2 (domv, pathv); - CAMLlocal2 (rv,v); - virDomainPtr dom = Domain_val (domv); - virConnectPtr conn = Connect_domv (domv); - char *path = String_val (pathv); - struct _virDomainInterfaceStats stats; - int r; - - WEAK_SYMBOL_CHECK (virDomainInterfaceStats); - NONBLOCKING (r = virDomainInterfaceStats (dom, path, &stats, sizeof stats)); - CHECK_ERROR (r == -1, conn, "virDomainInterfaceStats"); - - rv = caml_alloc (8, 0); - v = caml_copy_int64 (stats.rx_bytes); Store_field (rv, 0, v); - v = caml_copy_int64 (stats.rx_packets); Store_field (rv, 1, v); - v = caml_copy_int64 (stats.rx_errs); Store_field (rv, 2, v); - v = caml_copy_int64 (stats.rx_drop); Store_field (rv, 3, v); - v = caml_copy_int64 (stats.tx_bytes); Store_field (rv, 4, v); - v = caml_copy_int64 (stats.tx_packets); Store_field (rv, 5, v); - v = caml_copy_int64 (stats.tx_errs); Store_field (rv, 6, v); - v = caml_copy_int64 (stats.tx_drop); Store_field (rv, 7, v); - - CAMLreturn (rv); -#else - not_supported ("virDomainInterfaceStats"); -#endif -} - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEPOOLGETINFO -extern int virStoragePoolGetInfo(virStoragePoolPtr pool, virStoragePoolInfoPtr info) - __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_pool_get_info (value poolv) -{ -#if HAVE_VIRSTORAGEPOOLGETINFO - CAMLparam1 (poolv); - CAMLlocal2 (rv, v); - virStoragePoolPtr pool = Pool_val (poolv); - virConnectPtr conn = Connect_polv (poolv); - virStoragePoolInfo info; - int r; - - WEAK_SYMBOL_CHECK (virStoragePoolGetInfo); - NONBLOCKING (r = virStoragePoolGetInfo (pool, &info)); - CHECK_ERROR (r == -1, conn, "virStoragePoolGetInfo"); - - rv = caml_alloc (4, 0); - Store_field (rv, 0, Val_int (info.state)); - v = caml_copy_int64 (info.capacity); Store_field (rv, 1, v); - v = caml_copy_int64 (info.allocation); Store_field (rv, 2, v); - v = caml_copy_int64 (info.available); Store_field (rv, 3, v); - - CAMLreturn (rv); -#else - not_supported ("virStoragePoolGetInfo"); -#endif -} - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRSTORAGEVOLGETINFO -extern int virStorageVolGetInfo(virStorageVolPtr vol, virStorageVolInfoPtr info) - __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_storage_vol_get_info (value volv) -{ -#if HAVE_VIRSTORAGEVOLGETINFO - CAMLparam1 (volv); - CAMLlocal2 (rv, v); - virStorageVolPtr vol = Volume_val (volv); - virConnectPtr conn = Connect_volv (volv); - virStorageVolInfo info; - int r; - - WEAK_SYMBOL_CHECK (virStorageVolGetInfo); - NONBLOCKING (r = virStorageVolGetInfo (vol, &info)); - CHECK_ERROR (r == -1, conn, "virStorageVolGetInfo"); - - rv = caml_alloc (3, 0); - Store_field (rv, 0, Val_int (info.type)); - v = caml_copy_int64 (info.capacity); Store_field (rv, 1, v); - v = caml_copy_int64 (info.allocation); Store_field (rv, 1, v); - - CAMLreturn (rv); -#else - not_supported ("virStorageVolGetInfo"); -#endif -} - -#ifdef HAVE_WEAK_SYMBOLS -#ifdef HAVE_VIRJOBGETINFO -extern int virJobGetInfo(virJobPtr job, virJobInfoPtr info) - __attribute__((weak)); -#endif -#endif - -CAMLprim value -ocaml_libvirt_job_get_info (value jobv) -{ -#if HAVE_VIRJOBGETINFO - CAMLparam1 (jobv); - CAMLlocal1 (rv); - virJobPtr job = Job_val (jobv); - virConnectPtr conn = Connect_jobv (jobv); - virJobInfo info; - int r; - - WEAK_SYMBOL_CHECK (virJobGetInfo); - NONBLOCKING (r = virJobGetInfo (job, &info)); - CHECK_ERROR (r == -1, conn, "virJobGetInfo"); - - rv = caml_alloc (5, 0); - Store_field (rv, 0, Val_int (info.type)); - Store_field (rv, 1, Val_int (info.state)); - Store_field (rv, 2, Val_int (info.runningTime)); - Store_field (rv, 3, Val_int (info.remainingTime)); - Store_field (rv, 4, Val_int (info.percentComplete)); - - CAMLreturn (rv); -#else - not_supported ("virJobGetInfo"); -#endif -} - -/*----------------------------------------------------------------------*/ - -CAMLprim value -ocaml_libvirt_virterror_get_last_error (value unitv) -{ - CAMLparam1 (unitv); - CAMLlocal1 (rv); - virErrorPtr err = virGetLastError (); - - rv = Val_opt (err, (Val_ptr_t) Val_virterror); - - CAMLreturn (rv); -} - -CAMLprim value -ocaml_libvirt_virterror_get_last_conn_error (value connv) -{ - CAMLparam1 (connv); - CAMLlocal1 (rv); - virConnectPtr conn = Connect_val (connv); - - rv = Val_opt (conn, (Val_ptr_t) Val_connect); - - CAMLreturn (rv); -} - -CAMLprim value -ocaml_libvirt_virterror_reset_last_error (value unitv) -{ - CAMLparam1 (unitv); - virResetLastError (); - CAMLreturn (Val_unit); -} - -CAMLprim value -ocaml_libvirt_virterror_reset_last_conn_error (value connv) -{ - CAMLparam1 (connv); - virConnectPtr conn = Connect_val (connv); - virConnResetLastError (conn); - CAMLreturn (Val_unit); -} - -/*----------------------------------------------------------------------*/ - -/* Initialise the library. */ -CAMLprim value -ocaml_libvirt_init (value unit) -{ - CAMLparam1 (unit); - CAMLlocal1 (rv); - int r; - - r = virInitialize (); - CHECK_ERROR (r == -1, NULL, "virInitialize"); - - CAMLreturn (Val_unit); -} diff --git a/libvirt/libvirt_c_prologue.c b/libvirt/libvirt_c_prologue.c deleted file mode 100644 index 7fe9714..0000000 --- a/libvirt/libvirt_c_prologue.c +++ /dev/null @@ -1,191 +0,0 @@ -/* OCaml bindings for libvirt. - * (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - * http://libvirt.org/ - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2 of the License, or (at your option) any later version. - * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - */ - -/* Please read libvirt/README file. */ - -static char *Optstring_val (value strv); -typedef value (*Val_ptr_t) (void *); -static value Val_opt (void *ptr, Val_ptr_t Val_ptr); -/*static value option_default (value option, value deflt);*/ -static void _raise_virterror (virConnectPtr conn, const char *fn) Noreturn; -static void not_supported (const char *fn) Noreturn; -static value Val_virterror (virErrorPtr err); - -/* Use this around synchronous libvirt API calls to release the OCaml - * lock, allowing other threads to run simultaneously. 'code' must not - * perform any caml_* calls, run any OCaml code, or raise any exception. - * http://web.archive.org/web/20030521020915/http://caml.inria.fr/archives/200106/msg00199.html - */ -#define NONBLOCKING(code) \ - do { \ - caml_enter_blocking_section (); \ - code; \ - caml_leave_blocking_section (); \ - } while (0) - -/* Check error condition from a libvirt function, and automatically raise - * an exception if one is found. - */ -#define CHECK_ERROR(cond, conn, fn) \ - do { if (cond) _raise_virterror (conn, fn); } while (0) - -/* For more about weak symbols, see: - * http://kolpackov.net/pipermail/notes/2004-March/000006.html - * We are using this to do runtime detection of library functions - * so that if we dynamically link with an older version of - * libvirt than we were compiled against, it won't fail (provided - * libvirt >= 0.2.1 - we don't support anything older). - */ -#ifdef __GNUC__ -#ifdef linux -#if (__GNUC__ == 3 && __GNUC_MINOR__ >= 3) || (__GNUC__ > 3) -#define HAVE_WEAK_SYMBOLS 1 -#endif -#endif -#endif - -#ifdef HAVE_WEAK_SYMBOLS -#define WEAK_SYMBOL_CHECK(sym) \ - do { if (!sym) not_supported(#sym); } while (0) -#else -#define WEAK_SYMBOL_CHECK(sym) -#endif /* HAVE_WEAK_SYMBOLS */ - -/*----------------------------------------------------------------------*/ - -/* Some notes about the use of custom blocks to store virConnectPtr, - * virDomainPtr and virNetworkPtr. - *------------------------------------------------------------------ - * - * Libvirt does some tricky reference counting to keep track of - * virConnectPtr's, virDomainPtr's and virNetworkPtr's. - * - * There is only one function which can return a virConnectPtr - * (virConnectOpen*) and that allocates a new one each time. - * - * virDomainPtr/virNetworkPtr's on the other hand can be returned - * repeatedly (for the same underlying domain/network), and we must - * keep track of each one and explicitly free it with virDomainFree - * or virNetworkFree. If we lose track of one then the reference - * counting in libvirt will keep it open. We therefore wrap these - * in a custom block with a finalizer function. - * - * We also have to allow the user to explicitly free them, in - * which case we set the pointer inside the custom block to NULL. - * The finalizer notices this and doesn't free the object. - * - * Domains and networks "belong to" a connection. We have to avoid - * the situation like this: - * - * let conn = Connect.open ... in - * let dom = Domain.lookup_by_id conn 0 in - * (* conn goes out of scope and is garbage collected *) - * printf "dom name = %s\n" (Domain.get_name dom) - * - * The reason is that when conn is garbage collected, virConnectClose - * is called and any subsequent operations on dom will fail (in fact - * will probably segfault). To stop this from happening, the OCaml - * wrappers store domains (and networks) as explicit (dom, conn) - * pairs. - * - * Further complication with virterror / exceptions: Virterror gives - * us virConnectPtr, virDomainPtr, virNetworkPtr pointers. If we - * follow standard practice and wrap these up in blocks with - * finalizers then we'll end up double-freeing (in particular, calling - * virConnectClose at the wrong time). So for virterror, we have - * "special" wrapper functions (Val_connect_no_finalize, etc.). - * - * Update 2008/01: Storage pools and volumes work the same way as - * domains and networks. And jobs. - */ - -/* Unwrap a custom block. */ -#define Connect_val(rv) (*((virConnectPtr *)Data_custom_val(rv))) -#define Dom_val(rv) (*((virDomainPtr *)Data_custom_val(rv))) -#define Net_val(rv) (*((virNetworkPtr *)Data_custom_val(rv))) -#ifdef HAVE_VIRSTORAGEPOOLPTR -#define Pol_val(rv) (*((virStoragePoolPtr *)Data_custom_val(rv))) -#endif -#ifdef HAVE_VIRSTORAGEVOLPTR -#define Vol_val(rv) (*((virStorageVolPtr *)Data_custom_val(rv))) -#endif -#ifdef HAVE_VIRJOBPTR -#define Jb_val(rv) (*((virJobPtr *)Data_custom_val(rv))) -#endif - -/* Wrap up a pointer to something in a custom block. */ -static value Val_connect (virConnectPtr conn); -static value Val_dom (virDomainPtr dom); -static value Val_net (virNetworkPtr net); -#ifdef HAVE_VIRSTORAGEPOOLPTR -static value Val_pol (virStoragePoolPtr pool); -#endif -#ifdef HAVE_VIRSTORAGEVOLPTR -static value Val_vol (virStorageVolPtr vol); -#endif -#ifdef HAVE_VIRJOBPTR -static value Val_jb (virJobPtr jb); -#endif - -/* ONLY for use by virterror wrappers. */ -static value Val_connect_no_finalize (virConnectPtr conn); -static value Val_dom_no_finalize (virDomainPtr dom); -static value Val_net_no_finalize (virNetworkPtr net); - -/* Domains and networks are stored as pairs (dom/net, conn), so have - * some convenience functions for unwrapping and wrapping them. - */ -#define Domain_val(rv) (Dom_val(Field((rv),0))) -#define Network_val(rv) (Net_val(Field((rv),0))) -#ifdef HAVE_VIRSTORAGEPOOLPTR -#define Pool_val(rv) (Pol_val(Field((rv),0))) -#endif -#ifdef HAVE_VIRSTORAGEVOLPTR -#define Volume_val(rv) (Vol_val(Field((rv),0))) -#endif -#ifdef HAVE_VIRJOBPTR -#define Job_val(rv) (Jb_val(Field((rv),0))) -#endif -#define Connect_domv(rv) (Connect_val(Field((rv),1))) -#define Connect_netv(rv) (Connect_val(Field((rv),1))) -#ifdef HAVE_VIRSTORAGEPOOLPTR -#define Connect_polv(rv) (Connect_val(Field((rv),1))) -#endif -#ifdef HAVE_VIRSTORAGEVOLPTR -#define Connect_volv(rv) (Connect_val(Field((rv),1))) -#endif -#ifdef HAVE_VIRJOBPTR -#define Connect_jobv(rv) (Connect_val(Field((rv),1))) -#endif - -static value Val_domain (virDomainPtr dom, value connv); -static value Val_network (virNetworkPtr net, value connv); -#ifdef HAVE_VIRSTORAGEPOOLPTR -static value Val_pool (virStoragePoolPtr pol, value connv); -#endif -#ifdef HAVE_VIRSTORAGEVOLPTR -static value Val_volume (virStorageVolPtr vol, value connv); -#endif -#ifdef HAVE_VIRJOBPTR -static value Val_job (virJobPtr jb, value connv); -#endif - -/* ONLY for use by virterror wrappers. */ -static value Val_domain_no_finalize (virDomainPtr dom, value connv); -static value Val_network_no_finalize (virNetworkPtr net, value connv); diff --git a/libvirt/libvirt_version.ml.in b/libvirt/libvirt_version.ml.in deleted file mode 100755 index ef7aea5..0000000 --- a/libvirt/libvirt_version.ml.in +++ /dev/null @@ -1,21 +0,0 @@ -(* Helper module containing the version of the OCaml bindings. - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - *) - -let package = "@PACKAGE_NAME@" -let version = "@PACKAGE_VERSION@" diff --git a/libvirt/libvirt_version.mli b/libvirt/libvirt_version.mli deleted file mode 100755 index b1755ba..0000000 --- a/libvirt/libvirt_version.mli +++ /dev/null @@ -1,25 +0,0 @@ -(** OCaml bindings for libvirt. - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA -*) - -val package : string -val version : string -(** The name and version of the OCaml libvirt bindings. - - (To get the version of libvirt C library itself - use {!Libvirt.get_version}). *) diff --git a/mlvirsh/Makefile.in b/mlvirsh/Makefile.in deleted file mode 100644 index 23d6e1e..0000000 --- a/mlvirsh/Makefile.in +++ /dev/null @@ -1,93 +0,0 @@ -# mlvirsh -# Copyright (C) 2007 Red Hat Inc., Richard W.M. Jones -# -# 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. - -INSTALL := @INSTALL@ - -prefix = @prefix@ -exec_prefix = @exec_prefix@ -bindir = @bindir@ - -pkg_gettext = @pkg_gettext@ - -OCAMLFIND = @OCAMLFIND@ - -ifneq ($(OCAMLFIND),) -OCAMLCPACKAGES := -package unix -I ../libvirt -OCAMLCFLAGS := -g -OCAMLCLIBS := -linkpkg -OCAMLOPTPACKAGES := $(OCAMLCPACKAGES) -OCAMLOPTFLAGS := -OCAMLOPTLIBS := $(OCAMLCLIBS) -else -OCAMLCINCS := -I ../libvirt -OCAMLCFLAGS := -g -OCAMLCLIBS := unix.cma -OCAMLOPTINCS := $(OCAMLCINCS) -OCAMLOPTFLAGS := -OCAMLOPTLIBS := unix.cmxa -endif - -ifneq ($(pkg_gettext),no) -ifneq ($(OCAMLFIND),) -OCAMLCPACKAGES += -package gettext-stub -OCAMLOPTPACKAGES += -package gettext-stub -else -OCAMLCINCS += -I gettext -I gettext-stub -OCAMLOPTINCS += -I gettext -I gettext-stub -endif -endif - -OBJS := mlvirsh_gettext.cmo mlvirsh.cmo -XOBJS := $(OBJS:.cmo=.cmx) - -export LIBRARY_PATH=../libvirt -export LD_LIBRARY_PATH=../libvirt - -BYTE_TARGETS := mlvirsh -OPT_TARGETS := mlvirsh.opt - -all: $(BYTE_TARGETS) - -opt: $(OPT_TARGETS) - -ifneq ($(OCAMLFIND),) -mlvirsh: $(OBJS) - $(OCAMLFIND) ocamlc $(OCAMLCPACKAGES) $(OCAMLCFLAGS) $(OCAMLCLIBS) \ - ../libvirt/mllibvirt.cma -o $@ $^ - -mlvirsh.opt: $(XOBJS) - $(OCAMLFIND) ocamlopt \ - $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \ - ../libvirt/mllibvirt.cmxa -o $@ $^ -else -mlvirsh: $(OBJS) - $(OCAMLC) $(OCAMLCINCS) $(OCAMLCFLAGS) $(OCAMLCLIBS) \ - ../libvirt/mllibvirt.cma -o $@ $^ - -mlvirsh.opt: $(XOBJS) - $(OCAMLOPT) \ - $(OCAMLOPTINCS) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \ - ../libvirt/mllibvirt.cmxa -o $@ $^ -endif - -install: - if [ -x mlvirsh.opt ]; then \ - mkdir -p $(DESTDIR)$(bindir); \ - $(INSTALL) -m 0755 mlvirsh.opt $(DESTDIR)$(bindir)/mlvirsh; \ - fi - -include ../Make.rules diff --git a/mlvirsh/mlvirsh.ml b/mlvirsh/mlvirsh.ml deleted file mode 100644 index ba4860f..0000000 --- a/mlvirsh/mlvirsh.ml +++ /dev/null @@ -1,770 +0,0 @@ -(* virsh-like command line tool. - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - 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. -*) - -open Printf -open Mlvirsh_gettext.Gettext - -module C = Libvirt.Connect -module D = Libvirt.Domain -module N = Libvirt.Network - -(* Program name. *) -let program_name = Filename.basename Sys.executable_name - -(* Parse arguments. *) -let name = ref "" -let readonly = ref false - -let argspec = Arg.align [ - "-c", Arg.Set_string name, "URI " ^ s_ "Hypervisor connection URI"; - "-r", Arg.Set readonly, " " ^ s_ "Read-only connection"; -] - -let usage_msg = - sprintf (f_ "Synopsis: - %s [options] [command] - -List of all commands: - %s help - -Full description of a single command: - %s help command - -Options:") - program_name program_name program_name - -let add_extra_arg, get_extra_args = - let extra_args = ref [] in - let add_extra_arg s = extra_args := s :: !extra_args in - let get_extra_args () = List.rev !extra_args in - add_extra_arg, get_extra_args - -let () = Arg.parse argspec add_extra_arg usage_msg - -let name = match !name with "" -> None | name -> Some name -let readonly = !readonly -let extra_args = get_extra_args () - -(* Read a whole file into memory and return it (as a string). *) -let rec input_file filename = - let chan = open_in_bin filename in - let data = input_all chan in - close_in chan; - data -and input_all chan = - let buf = Buffer.create 16384 in - let tmpsize = 16384 in - let tmp = String.create tmpsize in - let n = ref 0 in - while n := input chan tmp 0 tmpsize; !n > 0 do - Buffer.add_substring buf tmp 0 !n; - done; - Buffer.contents buf - -(* Split a string at a separator. - * Functions copied from extlib Copyright (C) 2003 Nicolas Cannasse et al. - * to avoid the explicit dependency on extlib. - *) -let str_find str sub = - let sublen = String.length sub in - if sublen = 0 then - 0 - else - let found = ref 0 in - let len = String.length str in - try - for i = 0 to len - sublen do - let j = ref 0 in - while String.unsafe_get str (i + !j) = String.unsafe_get sub !j do - incr j; - if !j = sublen then begin found := i; raise Exit; end; - done; - done; - raise Not_found - with - Exit -> !found - -let str_split str sep = - let p = str_find str sep in - let len = String.length sep in - let slen = String.length str in - String.sub str 0 p, String.sub str (p + len) (slen - p - len) - -let str_nsplit str sep = - if str = "" then [] - else ( - let rec nsplit str sep = - try - let s1 , s2 = str_split str sep in - s1 :: nsplit s2 sep - with - Not_found -> [str] - in - nsplit str sep - ) - -(* Hypervisor connection. *) -type conn_t = No_connection | RO of Libvirt.ro C.t | RW of Libvirt.rw C.t -let conn = ref No_connection - -let close_connection () = - match !conn with - | No_connection -> () - | RO c -> - C.close c; - conn := No_connection - | RW c -> - C.close c; - conn := No_connection - -let do_command = - (* Command helper functions. - * - * Each cmd<n> is a function that constructs a command. - * string string string ... <--- user types on the command line - * | | | - * arg1 arg2 arg3 ... <--- conversion functions - * | | | - * V V V - * function f <--- work function - * | - * V - * print result <--- printing function - * - * (Note that cmd<n> function constructs and returns the above - * function, it isn't the function itself.) - * - * Example: If the function takes one parameter (an int) and - * returns a string to be printed, you would use: - * - * cmd1 print_endline f int_of_string - *) - let cmd0 print fn = function (* Command with no args. *) - | [] -> print (fn ()) - | _ -> failwith (s_ "incorrect number of arguments for function") - in - let cmd1 print fn arg1 = function (* Command with one arg. *) - | [str1] -> print (fn (arg1 str1)) - | _ -> failwith (s_ "incorrect number of arguments for function") - in - let cmd2 print fn arg1 arg2 = function (* Command with 2 args. *) - | [str1; str2] -> print (fn (arg1 str1) (arg2 str2)) - | _ -> failwith (s_ "incorrect number of arguments for function") - in - let cmd3 print fn arg1 arg2 arg3 = function (* Command with 3 args. *) - | [str1; str2; str3] -> print (fn (arg1 str1) (arg2 str2) (arg3 str3)) - | _ -> failwith (s_ "incorrect number of arguments for function") - in - let cmd01 print fn arg1 = function (* Command with 0 or 1 arg. *) - | [] -> print (fn None) - | [str1] -> print (fn (Some (arg1 str1))) - | _ -> failwith (s_ "incorrect number of arguments for function") - in - let cmd12 print fn arg1 arg2 = function (* Command with 1 or 2 args. *) - | [str1] -> print (fn (arg1 str1) None) - | [str1; str2] -> print (fn (arg1 str1) (Some (arg2 str2))) - | _ -> failwith (s_ "incorrect number of arguments for function") - in - let cmd012 print fn arg1 arg2 = function (* Command with 0, 1 or 2 args. *) - | [] -> print (fn None None) - | [str1] -> print (fn (Some (arg1 str1)) None) - | [str1; str2] -> print (fn (Some (arg1 str1)) (Some (arg2 str2))) - | _ -> failwith (s_ "incorrect number of arguments for function") - in - let cmdN print fn = (* Command with any number of args. *) - fun args -> print (fn args) - in - - (* Get the connection or fail if we don't have one. *) - let rec get_full_connection () = - match !conn with - | No_connection -> failwith (s_ "not connected to the hypervisor") - | RO _ -> failwith (s_ "tried to do read-write operation on read-only hypervisor connection") - | RW conn -> conn - and get_readonly_connection () = - match !conn with - | No_connection -> failwith (s_ "not connected to the hypervisor") - | RO conn -> conn - | RW conn -> C.const conn -(* - and with_full_connection fn = - fun () -> fn (get_full_connection ()) -*) - and with_readonly_connection fn = - fun () -> fn (get_readonly_connection ()) - and arg_full_connection fn = - fun str -> fn (get_full_connection ()) str - and arg_readonly_connection fn = - fun str -> fn (get_readonly_connection ()) str - in - - (* Parsing of command arguments. *) - let string_of_readonly = function - | "readonly" | "read-only" | "ro" -> true - | _ -> failwith (sprintf (f_ "flag should be '%s'") "readonly") - in - let string_of_string (str : string) = str in - let boolean_of_string = function - | "enable" | "enabled" | "on" | "1" | "true" -> true - | "disable" | "disabled" | "off" | "0" | "false" -> false - | _ -> failwith (sprintf (f_ "setting should be '%s' or '%s'") "on" "off") - in - let domain_of_string conn str = - try - (try - let id = int_of_string str in - D.lookup_by_id conn id - with - Failure "int_of_string" -> - if String.length str = Libvirt.uuid_string_length then - D.lookup_by_uuid_string conn str - else - D.lookup_by_name conn str - ) - with - Libvirt.Virterror err -> - failwith (sprintf (f_ "domain %s: not found. Additional info: %s") - str (Libvirt.Virterror.to_string err)); - in - let network_of_string conn str = - try - if String.length str = Libvirt.uuid_string_length then - N.lookup_by_uuid_string conn str - else - N.lookup_by_name conn str - with - Libvirt.Virterror err -> - failwith (sprintf (f_ "network %s: not found. Additional info: %s") - str (Libvirt.Virterror.to_string err)); - in - let rec parse_sched_params = function - | [] -> [] - | [_] -> failwith (s_ "expected field value pairs, but got an odd number of arguments") - | field :: value :: rest -> - (* XXX We only support the UINT type at the moment. *) - (field, D.SchedFieldUInt32 (Int32.of_string value)) - :: parse_sched_params rest - in - let cpumap_of_string str = - let c = get_readonly_connection () in - let info = C.get_node_info c in - let cpumap = - String.make (C.cpumaplen (C.maxcpus_of_node_info info)) '\000' in - List.iter (C.use_cpu cpumap) - (List.map int_of_string (str_nsplit str ",")); - cpumap - in - - (* Printing of command results. *) - let no_return _ = () in - let print_int i = print_endline (string_of_int i) in - let print_int64 i = print_endline (Int64.to_string i) in - let print_int64_array a = Array.iter print_int64 a in - let print_bool b = print_endline (string_of_bool b) in - let print_version v = - let major = v / 1000000 in - let minor = (v - major * 1000000) / 1000 in - let release = (v - major * 1000000 - minor * 1000) in - printf "%d.%d.%d\n" major minor release - in - let string_of_domain_state = function - | D.InfoNoState -> s_ "unknown" - | D.InfoRunning -> s_ "running" - | D.InfoBlocked -> s_ "blocked" - | D.InfoPaused -> s_ "paused" - | D.InfoShutdown -> s_ "shutdown" - | D.InfoShutoff -> s_ "shutoff" - | D.InfoCrashed -> s_ "crashed" - in - let string_of_vcpu_state = function - | D.VcpuOffline -> s_ "offline" - | D.VcpuRunning -> s_ "running" - | D.VcpuBlocked -> s_ "blocked" - in - let print_domain_array doms = - Array.iter ( - fun dom -> - let id = - try sprintf "%d" (D.get_id dom) - with Libvirt.Virterror _ -> "" in - let name = - try sprintf "%s" (D.get_name dom) - with Libvirt.Virterror _ -> "" in - let state = - try - let { D.state = state } = D.get_info dom in - string_of_domain_state state - with Libvirt.Virterror _ -> "" in - printf "%5s %-30s %s\n" id name state - ) doms - in - let print_network_array nets = - Array.iter ( - fun net -> - printf "%s\n" (N.get_name net) - ) nets - in - let print_node_info info = - let () = printf (f_ "model: %s\n") info.C.model in - let () = printf (f_ "memory: %Ld K\n") info.C.memory in - let () = printf (f_ "cpus: %d\n") info.C.cpus in - let () = printf (f_ "mhz: %d\n") info.C.mhz in - let () = printf (f_ "nodes: %d\n") info.C.nodes in - let () = printf (f_ "sockets: %d\n") info.C.sockets in - let () = printf (f_ "cores: %d\n") info.C.cores in - let () = printf (f_ "threads: %d\n") info.C.threads in - () - in - let print_domain_state { D.state = state } = - print_endline (string_of_domain_state state) - in - let print_domain_info info = - let () = printf (f_ "state: %s\n") (string_of_domain_state info.D.state) in - let () = printf (f_ "max_mem: %Ld K\n") info.D.max_mem in - let () = printf (f_ "memory: %Ld K\n") info.D.memory in - let () = printf (f_ "nr_virt_cpu: %d\n") info.D.nr_virt_cpu in - let () = printf (f_ "cpu_time: %Ld ns\n") info.D.cpu_time in - () - in - let print_sched_param_array params = - Array.iter ( - fun (name, value) -> - printf "%-20s" name; - match value with - | D.SchedFieldInt32 i -> printf " %ld\n" i - | D.SchedFieldUInt32 i -> printf " %lu\n" i - | D.SchedFieldInt64 i -> printf " %Ld\n" i - | D.SchedFieldUInt64 i -> printf " %Lu\n" i - | D.SchedFieldFloat f -> printf " %g\n" f - | D.SchedFieldBool b -> printf " %b\n" b - ) params - in - let print_vcpu_info (ncpus, vcpu_infos, cpumaps, maplen, maxcpus) = - for n = 0 to ncpus-1 do - let () = printf (f_ "virtual CPU: %d\n") n in - let () = printf (f_ "\ton physical CPU: %d\n") vcpu_infos.(n).D.cpu in - let () = printf (f_ "\tcurrent state: %s\n") - (string_of_vcpu_state vcpu_infos.(n).D.vcpu_state) in - let () = printf (f_ "\tCPU time: %Ld ns\n") vcpu_infos.(n).D.vcpu_time in - print_string ("\t" ^ s_ "CPU affinity" ^ ": "); - for m = 0 to maxcpus-1 do - print_char (if C.cpu_usable cpumaps maplen n m then 'y' else '-') - done; - print_endline ""; - done - in - let print_block_stats { D.rd_req = rd_req; rd_bytes = rd_bytes; - wr_req = wr_req; wr_bytes = wr_bytes; - errs = errs } = - if rd_req >= 0L then printf (f_ "read requests: %Ld\n") rd_req; - if rd_bytes >= 0L then printf (f_ "read bytes: %Ld\n") rd_bytes; - if wr_req >= 0L then printf (f_ "write requests: %Ld\n") wr_req; - if wr_bytes >= 0L then printf (f_ "write bytes: %Ld\n") wr_bytes; - if errs >= 0L then printf (f_ "errors: %Ld\n") errs; - and print_interface_stats { D.rx_bytes = rx_bytes; rx_packets = rx_packets; - rx_errs = rx_errs; rx_drop = rx_drop; - tx_bytes = tx_bytes; tx_packets = tx_packets; - tx_errs = tx_errs; tx_drop = tx_drop } = - if rx_bytes >= 0L then printf (f_ "rx bytes: %Ld\n") rx_bytes; - if rx_packets >= 0L then printf (f_ "rx packets: %Ld\n") rx_packets; - if rx_errs >= 0L then printf (f_ "rx errs: %Ld\n") rx_errs; - if rx_drop >= 0L then printf (f_ "rx dropped: %Ld\n") rx_drop; - if tx_bytes >= 0L then printf (f_ "tx bytes: %Ld\n") tx_bytes; - if tx_packets >= 0L then printf (f_ "tx packets: %Ld\n") tx_packets; - if tx_errs >= 0L then printf (f_ "tx errs: %Ld\n") tx_errs; - if tx_drop >= 0L then printf (f_ "tx dropped: %Ld\n") tx_drop; - in - - (* List of commands. *) - let commands = [ - "attach-device", - cmd2 no_return D.attach_device - (arg_full_connection domain_of_string) input_file, - s_ "Attach device to domain."; - "autostart", - cmd2 no_return D.set_autostart - (arg_full_connection domain_of_string) boolean_of_string, - s_ "Set whether a domain autostarts at boot."; - "capabilities", - cmd0 print_endline (with_readonly_connection C.get_capabilities), - s_ "Returns capabilities of hypervisor/driver."; - "close", - cmd0 no_return close_connection, - s_ "Close an existing hypervisor connection."; - "connect", - cmd12 no_return - (fun name readonly -> - close_connection (); - match readonly with - | None | Some false -> conn := RW (C.connect ~name ()) - | Some true -> conn := RO (C.connect_readonly ~name ()) - ) string_of_string string_of_readonly, - s_ "Open a new hypervisor connection."; - "create", - cmd1 no_return - (fun xml -> D.create_linux (get_full_connection ()) xml) input_file, - s_ "Create a domain from an XML file."; - "define", - cmd1 no_return - (fun xml -> D.define_xml (get_full_connection ()) xml) input_file, - s_ "Define (but don't start) a domain from an XML file."; - "detach-device", - cmd2 no_return D.detach_device - (arg_full_connection domain_of_string) input_file, - s_ "Detach device from domain."; - "destroy", - cmd1 no_return D.destroy (arg_full_connection domain_of_string), - s_ "Destroy a domain."; - "domblkstat", - cmd2 print_block_stats D.block_stats - (arg_readonly_connection domain_of_string) string_of_string, - s_ "Display the block device statistics for a domain."; - "domid", - cmd1 print_int D.get_id (arg_readonly_connection domain_of_string), - s_ "Print the ID of a domain."; - "domifstat", - cmd2 print_interface_stats D.interface_stats - (arg_readonly_connection domain_of_string) string_of_string, - s_ "Display the network interface statistics for a domain."; - "dominfo", - cmd1 print_domain_info D.get_info - (arg_readonly_connection domain_of_string), - s_ "Print the domain info."; - "dommaxmem", - cmd1 print_int64 D.get_max_memory - (arg_readonly_connection domain_of_string), - s_ "Print the max memory (in kilobytes) of a domain."; - "dommaxvcpus", - cmd1 print_int D.get_max_vcpus - (arg_readonly_connection domain_of_string), - s_ "Print the max VCPUs of a domain."; - "domname", - cmd1 print_endline D.get_name - (arg_readonly_connection domain_of_string), - s_ "Print the name of a domain."; - "domostype", - cmd1 print_endline D.get_os_type - (arg_readonly_connection domain_of_string), - s_ "Print the OS type of a domain."; - "domstate", - cmd1 print_domain_state D.get_info - (arg_readonly_connection domain_of_string), - s_ "Print the domain state."; - "domuuid", - cmd1 print_endline D.get_uuid_string - (arg_readonly_connection domain_of_string), - s_ "Print the UUID of a domain."; - "dump", - cmd2 no_return D.core_dump - (arg_full_connection domain_of_string) string_of_string, - s_ "Core dump a domain to a file for analysis."; - "dumpxml", - cmd1 print_endline D.get_xml_desc - (arg_full_connection domain_of_string), - s_ "Print the XML description of a domain."; - "freecell", - cmd012 print_int64_array ( - fun start max -> - let conn = get_readonly_connection () in - match start, max with - | None, _ -> - [| C.node_get_free_memory conn |] - | Some start, None -> - C.node_get_cells_free_memory conn start 1 - | Some start, Some max -> - C.node_get_cells_free_memory conn start max - ) int_of_string int_of_string, - s_ "Display free memory for machine, NUMA cell or range of cells"; - "get-autostart", - cmd1 print_bool D.get_autostart - (arg_readonly_connection domain_of_string), - s_ "Print whether a domain autostarts at boot."; - "hostname", - cmd0 print_endline (with_readonly_connection C.get_hostname), - s_ "Print the hostname."; - "list", - cmd0 print_domain_array - (fun () -> - let c = get_readonly_connection () in - let n = C.num_of_domains c in - let domids = C.list_domains c n in - Array.map (D.lookup_by_id c) domids), - s_ "List the running domains."; - "list-defined", - cmd0 print_domain_array - (fun () -> - let c = get_readonly_connection () in - let n = C.num_of_defined_domains c in - let domnames = C.list_defined_domains c n in - Array.map (D.lookup_by_name c) domnames), - s_ "List the defined but not running domains."; - "quit", - cmd0 no_return (fun () -> exit 0), - s_ "Quit the interactive terminal."; - "maxvcpus", - cmd0 print_int (fun () -> C.get_max_vcpus (get_readonly_connection ()) ()), - s_ "Print the max VCPUs available."; - "net-autostart", - cmd2 no_return N.set_autostart - (arg_full_connection network_of_string) boolean_of_string, - s_ "Set whether a network autostarts at boot."; - "net-bridgename", - cmd1 print_endline N.get_bridge_name - (arg_readonly_connection network_of_string), - s_ "Print the bridge name of a network."; - "net-create", - cmd1 no_return - (fun xml -> N.create_xml (get_full_connection ()) xml) input_file, - s_ "Create a network from an XML file."; - "net-define", - cmd1 no_return - (fun xml -> N.define_xml (get_full_connection ()) xml) input_file, - s_ "Define (but don't start) a network from an XML file."; - "net-destroy", - cmd1 no_return N.destroy (arg_full_connection network_of_string), - s_ "Destroy a network."; - "net-dumpxml", - cmd1 print_endline N.get_xml_desc - (arg_full_connection network_of_string), - s_ "Print the XML description of a network."; - "net-get-autostart", - cmd1 print_bool N.get_autostart - (arg_full_connection network_of_string), - s_ "Print whether a network autostarts at boot."; - "net-list", - cmd0 print_network_array - (fun () -> - let c = get_readonly_connection () in - let n = C.num_of_networks c in - let nets = C.list_networks c n in - Array.map (N.lookup_by_name c) nets), - s_ "List the active networks."; - "net-list-defined", - cmd0 print_network_array - (fun () -> - let c = get_readonly_connection () in - let n = C.num_of_defined_networks c in - let nets = C.list_defined_networks c n in - Array.map (N.lookup_by_name c) nets), - s_ "List the defined but inactive networks."; - "net-name", - cmd1 print_endline N.get_name - (arg_readonly_connection network_of_string), - s_ "Print the name of a network."; - "net-start", - cmd1 no_return N.create - (arg_full_connection network_of_string), - s_ "Start a previously defined inactive network."; - "net-undefine", - cmd1 no_return N.undefine - (arg_full_connection network_of_string), - s_ "Undefine an inactive network."; - "net-uuid", - cmd1 print_endline N.get_uuid_string - (arg_readonly_connection network_of_string), - s_ "Print the UUID of a network."; - "nodeinfo", - cmd0 print_node_info (with_readonly_connection C.get_node_info), - s_ "Print node information."; - "reboot", - cmd1 no_return D.reboot (arg_full_connection domain_of_string), - s_ "Reboot a domain."; - "restore", - cmd1 no_return ( - fun path -> D.restore (get_full_connection ()) path - ) string_of_string, - s_ "Restore a domain from the named file."; - "resume", - cmd1 no_return D.resume (arg_full_connection domain_of_string), - s_ "Resume a domain."; - "save", - cmd2 no_return D.save - (arg_full_connection domain_of_string) string_of_string, - s_ "Save a domain to a file."; - "schedparams", - cmd1 print_sched_param_array ( - fun dom -> - let n = snd (D.get_scheduler_type dom) in - D.get_scheduler_parameters dom n - ) (arg_readonly_connection domain_of_string), - s_ "Get the current scheduler parameters for a domain."; - "schedparamset", - cmdN no_return ( - function - | [] -> failwith (s_ "expecting domain followed by field value pairs") - | dom :: pairs -> - let conn = get_full_connection () in - let dom = domain_of_string conn dom in - let params = parse_sched_params pairs in - let params = Array.of_list params in - D.set_scheduler_parameters dom params - ), - s_ "Set the scheduler parameters for a domain."; - "schedtype", - cmd1 print_endline - (fun dom -> fst (D.get_scheduler_type dom)) - (arg_readonly_connection domain_of_string), - s_ "Get the scheduler type."; - "setmem", - cmd2 no_return D.set_memory - (arg_full_connection domain_of_string) Int64.of_string, - s_ "Set the memory used by the domain (in kilobytes)."; - "setmaxmem", - cmd2 no_return D.set_max_memory - (arg_full_connection domain_of_string) Int64.of_string, - s_ "Set the maximum memory used by the domain (in kilobytes)."; - "shutdown", - cmd1 no_return D.shutdown - (arg_full_connection domain_of_string), - s_ "Gracefully shutdown a domain."; - "start", - cmd1 no_return D.create - (arg_full_connection domain_of_string), - s_ "Start a previously defined inactive domain."; - "suspend", - cmd1 no_return D.suspend - (arg_full_connection domain_of_string), - s_ "Suspend a domain."; - "type", - cmd0 print_endline (with_readonly_connection C.get_type), - s_ "Print the driver name"; - "undefine", - cmd1 no_return D.undefine - (arg_full_connection domain_of_string), - s_ "Undefine an inactive domain."; - "uri", - cmd0 print_endline (with_readonly_connection C.get_uri), - s_ "Print the canonical URI."; - "vcpuinfo", - cmd1 print_vcpu_info ( - fun dom -> - let c = get_readonly_connection () in - let info = C.get_node_info c in - let dominfo = D.get_info dom in - let maxcpus = C.maxcpus_of_node_info info in - let maplen = C.cpumaplen maxcpus in - let maxinfo = dominfo.D.nr_virt_cpu in - let ncpus, vcpu_infos, cpumaps = D.get_vcpus dom maxinfo maplen in - ncpus, vcpu_infos, cpumaps, maplen, maxcpus - ) (arg_readonly_connection domain_of_string), - s_ "Pin domain VCPU to a list of physical CPUs."; - "vcpupin", - cmd3 no_return D.pin_vcpu - (arg_full_connection domain_of_string) int_of_string cpumap_of_string, - s_ "Pin domain VCPU to a list of physical CPUs."; - "vcpus", - cmd2 no_return D.set_vcpus - (arg_full_connection domain_of_string) int_of_string, - s_ "Set the number of virtual CPUs assigned to a domain."; - "version", - cmd0 print_version (with_readonly_connection C.get_version), - s_ "Print the driver version"; - ] in - - (* Command help. *) - let help = function - | None -> (* List of commands. *) - String.concat "\n" ( - List.map ( - fun (cmd, _, description) -> - sprintf "%-12s %s" cmd description - ) commands - ) ^ - "\n\n" ^ - (sprintf (f_ "Use '%s help command' for help on a command.") - program_name) - - | Some command -> (* Full description of one command. *) - try - let (command, _, description) = - List.find (fun (c, _, _) -> c = command) commands in - sprintf "%s %s\n\n%s" program_name command description - with - Not_found -> - failwith (sprintf (f_ "help: %s: command not found") command); - in - - let commands = - ("help", - cmd01 print_endline help string_of_string, - s_ "Print list of commands or full description of one command."; - ) :: commands in - - (* Execute a command. *) - let do_command command args = - try - let (_, cmd, _) = List.find (fun (c, _, _) -> c = command) commands in - cmd args - with - Not_found -> - failwith (sprintf (f_ "%s: command not found") command); - in - - do_command - -(* Interactive mode. *) -let rec interactive_mode () = - let prompt = - match !conn with - | No_connection -> s_ "mlvirsh(no connection)" ^ "$ " - | RO _ -> s_ "mlvirsh(ro)" ^ "$ " - | RW _ -> s_ "mlvirsh" ^ "# " in - print_string prompt; - let command = read_line () in - (match str_nsplit command " " with - | [] -> () - | command :: args -> - do_command command args - ); - Gc.full_major (); (* Free up all unreachable domain and network objects. *) - interactive_mode () - -(* Connect to hypervisor. Allow the connection to fail. *) -let () = - conn := - try - if readonly then RO (C.connect_readonly ?name ()) - else RW (C.connect ?name ()) - with - Libvirt.Virterror err -> - eprintf "%s: %s\n" program_name (Libvirt.Virterror.to_string err); - No_connection - -let () = - try - (* Execute the command on the command line, if there was one. - * Otherwise go into interactive mode. - *) - (match extra_args with - | command :: args -> - do_command command args - | [] -> - try interactive_mode () with End_of_file -> () - ); - - (* If we are connected to a hypervisor, close the connection. *) - close_connection (); - - (* A good way to find heap bugs: *) - Gc.compact () - with - | Libvirt.Virterror err -> - eprintf "%s: %s\n" program_name (Libvirt.Virterror.to_string err) - | Failure msg -> - eprintf "%s: %s\n" program_name msg diff --git a/virt-ctrl/Makefile.in b/virt-ctrl/Makefile.in deleted file mode 100644 index 7e7c5c4..0000000 --- a/virt-ctrl/Makefile.in +++ /dev/null @@ -1,136 +0,0 @@ -# virt-ctrl (originally called mlvirtmanager) -# Copyright (C) 2007 Red Hat Inc., Richard W.M. Jones -# -# 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. - -INSTALL := @INSTALL@ - -prefix = @prefix@ -exec_prefix = @exec_prefix@ -bindir = @bindir@ - -with_icons = @with_icons@ -icons = @icons@ - -HAVE_GDK_PIXBUF_MLSOURCE = @HAVE_GDK_PIXBUF_MLSOURCE@ - -pkg_dbus = @pkg_dbus@ -pkg_gettext = @pkg_gettext@ - -OCAMLFIND = @OCAMLFIND@ - -OBJS := \ - virt_ctrl_gettext.cmo \ - vc_helpers.cmo \ - vc_connections.cmo \ - vc_domain_ops.cmo \ - vc_connection_dlg.cmo \ - vc_mainwindow.cmo - -ifneq ($(OCAMLFIND),) -# Good, we have ocamlfind. -OCAMLCPACKAGES := -I ../libvirt -package unix,lablgtk2 -ifeq ($(pkg_dbus),yes) -OCAMLCPACKAGES += -package dbus -OBJS += vc_dbus.cmo -endif -ifeq ($(pkg_gettext),yes) -OCAMLCPACKAGES += -package gettext-stub -endif -OCAMLCFLAGS := -g -OCAMLCLIBS := -linkpkg -OCAMLOPTPACKAGES := $(OCAMLCPACKAGES) -OCAMLOPTFLAGS := -OCAMLOPTLIBS := $(OCAMLCLIBS) -else -# Bad boy, please install ocamlfind. -OCAMLCINCS := -I ../libvirt -I @pkg_lablgtk2@ -OCAMLCFLAGS := -g -OCAMLCLIBS := unix.cma lablgtk.cma -OCAMLOPTINCS := $(OCAMLCINCS) -OCAMLOPTFLAGS := -OCAMLOPTLIBS := unix.cmxa lablgtk.cmxa -endif - -ifneq ($(with_icons),no) -OBJS += vc_icons.cmo -endif - -export LIBRARY_PATH=../libvirt -export LD_LIBRARY_PATH=../libvirt - -BYTE_TARGETS := virt-ctrl -OPT_TARGETS := virt-ctrl.opt - -OBJS += virt_ctrl.cmo - -XOBJS := $(OBJS:.cmo=.cmx) - -all: $(BYTE_TARGETS) - -opt: $(OPT_TARGETS) - -ifneq ($(OCAMLFIND),) -virt-ctrl: $(OBJS) - $(OCAMLFIND) ocamlc $(OCAMLCPACKAGES) $(OCAMLCFLAGS) $(OCAMLCLIBS) \ - ../libvirt/mllibvirt.cma gtkInit.cmo -o $@ $^ - -virt-ctrl.opt: $(XOBJS) - $(OCAMLFIND) ocamlopt \ - $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \ - ../libvirt/mllibvirt.cmxa gtkInit.cmx -o $@ $^ -else -virt-ctrl: $(OBJS) - $(OCAMLC) $(OCAMLCINCS) $(OCAMLCFLAGS) $(OCAMLCLIBS) \ - ../libvirt/mllibvirt.cma gtkInit.cmo -o $@ $^ - -host_os = @host_os@ - -ifneq ($(host_os),mingw32) -virt-ctrl.opt: $(XOBJS) - $(OCAMLOPT) $(OCAMLOPTINCS) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \ - $(patsubst %,-cclib %,$(LDFLAGS)) \ - ../libvirt/mllibvirt.cmxa gtkInit.cmx -o $@ $^ -else -# On MinGW, use a hacked 'gcc' wrapper which understands the @... -# syntax for extending the command line. -gcc.exe: mingw-gcc-wrapper.ml - $(OCAMLC) unix.cma $< -o $@ - -virt-ctrl.opt: $(XOBJS) gcc.exe - PATH=.:$$PATH \ - $(OCAMLOPT) $(OCAMLOPTINCS) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \ - $(patsubst %,-cclib %,$(LDFLAGS)) \ - ../libvirt/mllibvirt.cmxa gtkInit.cmx -o $@ $(XOBJS) -endif -endif - -# Rebuild the icons if newer ones available. -ifneq ($(with_icons),no) -ifneq ($(icons),) -ifeq ($(HAVE_GDK_PIXBUF_MLSOURCE),gdk-pixbuf-mlsource) -vc_icons.ml: rebuild-icons.sh - ./rebuild-icons.sh $(icons) > $@ -endif -endif -endif - -install: - if [ -x virt-ctrl.opt ]; then \ - mkdir -p $(DESTDIR)$(bindir); \ - $(INSTALL) -m 0755 virt-ctrl.opt $(DESTDIR)$(bindir)/virt-ctrl; \ - fi - -include ../Make.rules diff --git a/virt-ctrl/mingw-gcc-wrapper.ml b/virt-ctrl/mingw-gcc-wrapper.ml deleted file mode 100755 index 21cdb8f..0000000 --- a/virt-ctrl/mingw-gcc-wrapper.ml +++ /dev/null @@ -1,70 +0,0 @@ -(* Wrapper around 'gcc'. On MinGW, this wrapper understands the '@...'
- * syntax for extending the command line.
- *)
-
-open Printf
-open Unix
-
-let (//) = Filename.concat
-
-(* Substitute any @... arguments with the file content. *)
-let rec input_all_lines chan =
- try
- let line = input_line chan in
- line :: input_all_lines chan
- with
- End_of_file -> []
-
-let argv = Array.map (
- fun arg ->
- if arg.[0] = '@' then (
- let chan = open_in (String.sub arg 1 (String.length arg - 1)) in
- let lines = input_all_lines chan in
- close_in chan;
- lines
- ) else
- [arg]
-) Sys.argv
-
-let argv = Array.to_list argv
-let argv = List.flatten argv
-
-(* Find the real gcc.exe on $PATH, but ignore any '.' elements in the path.
- * Note that on Windows, $PATH is split with ';' characters.
- *)
-let rec split_find str sep f =
- try
- let i = String.index str sep in
- let n = String.length str in
- let str, str' = String.sub str 0 i, String.sub str (i+1) (n-i-1) in
- match f str with
- | None -> split_find str' sep f (* not found, keep searching *)
- | Some found -> found
- with
- Not_found ->
- match f str with
- | None -> raise Not_found (* not found at all *)
- | Some found -> found
-
-let exists filename =
- try access filename [F_OK]; true with Unix_error _ -> false
-
-let gcc =
- split_find (Sys.getenv "PATH") ';'
- (function
- | "." -> None (* ignore current directory in path *)
- | path ->
- let gcc = path // "gcc.exe" in
- if exists gcc then Some gcc else None)
-
-(* Finally execute the real gcc with the full argument list.
- * Can't use execv here because then the parent process (ocamlopt) thinks
- * that this process has finished and deletes all the temp files. Stupid
- * Windoze!
- *)
-let _ =
- let argv = List.map Filename.quote (List.tl argv) in
- let cmd = String.concat " " (gcc :: argv) in
- eprintf "mingw-gcc-wrapper: %s\n%!" cmd;
- let r = Sys.command cmd in
- exit r
diff --git a/virt-ctrl/rebuild-icons.sh b/virt-ctrl/rebuild-icons.sh deleted file mode 100755 index 399e182..0000000 --- a/virt-ctrl/rebuild-icons.sh +++ /dev/null @@ -1,44 +0,0 @@ -#!/bin/sh - -# Copyright (C) 2008 Red Hat Inc., Richard W.M. Jones -# -# 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. - -# Generate vc_icons.ml - -echo <<'EOF' -(* The file vc_icons.ml is automatically generated from rebuild-icons.sh - * Any changes you make will be lost. - *) - -EOF -echo - -# Open any modules which may use icons. -echo "open Vc_connection_dlg" -echo - -while [ $# -gt 0 ]; do - size="$1" - name="$2" - filename="$3" - shift 3 - - gdk-pixbuf-mlsource "$filename" - echo ";;" - - name=`echo -n $name | tr -cs '[0-9a-zA-Z]' '_'` - - echo "icon_${size}x${size}_$name := Some (pixbuf ()) ;;" -done
\ No newline at end of file diff --git a/virt-ctrl/vc_connection_dlg.ml b/virt-ctrl/vc_connection_dlg.ml deleted file mode 100644 index f072a1d..0000000 --- a/virt-ctrl/vc_connection_dlg.ml +++ /dev/null @@ -1,203 +0,0 @@ -(* virt-ctrl: A graphical management tool. - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - 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. -*) - -open Virt_ctrl_gettext.Gettext - -type name = string -type uri = string -type service = name * uri - -let local_xen_uri = "xen:///" -let local_qemu_uri = "qemu:///system" - -(* Code in Vc_dbus overrides this, if that capability was compiled in. *) -let find_libvirtd_with_zeroconf = ref (fun () -> []) - -(* Code in Vc_icons may override these with icons. *) -let icon_16x16_devices_computer_png = ref None -let icon_24x24_devices_computer_png = ref None -let icon_32x32_devices_computer_png = ref None -let icon_48x48_devices_computer_png = ref None - -(* Open connection dialog. *) -let open_connection parent () = - let title = s_ "Open connection to hypervisor" in - let position = `CENTER_ON_PARENT in - - let dlg = GWindow.dialog ~title ~position ~parent - ~modal:true ~width:450 () in - - (* We will enter the Gtk main loop recursively. Wire up close and - * other buttons to quit the recursive main loop. - *) - ignore (dlg#connect#destroy ~callback:GMain.quit); - ignore (dlg#event#connect#delete - ~callback:(fun _ -> GMain.quit (); false)); - - let uri = ref None in - - (* Pack the buttons into the dialog. *) - let vbox = dlg#vbox in - vbox#set_spacing 5; - - (* Local connections. *) - let () = - let frame = - GBin.frame ~label:(s_ "This machine") ~packing:vbox#pack () in - let hbox = GPack.hbox ~packing:frame#add () in - hbox#set_spacing 20; - ignore ( - let packing = hbox#pack in - match !icon_24x24_devices_computer_png with - | None -> GMisc.image ~stock:`DIRECTORY ~packing () - | Some pixbuf -> GMisc.image ~pixbuf ~packing () - ); - - let vbox = GPack.vbox ~packing:hbox#pack () in - vbox#set_spacing 5; - - let xen_button = - GButton.button ~label:(s_ "Xen hypervisor") - ~packing:vbox#pack () in - ignore (xen_button#connect#clicked - ~callback:(fun () -> - uri := Some local_xen_uri; - dlg#destroy ())); - let qemu_button = - GButton.button ~label:(s_ "QEMU or KVM") - ~packing:vbox#pack () in - ignore (qemu_button#connect#clicked - ~callback:(fun () -> - uri := Some local_qemu_uri; - dlg#destroy ())) in - - (* Network connections. *) - let () = - let frame = - GBin.frame ~label:(s_ "Local network") - ~packing:(vbox#pack ~expand:true) () in - let hbox = GPack.hbox ~packing:frame#add () in - hbox#set_spacing 20; - ignore (GMisc.image ~stock:`NETWORK ~packing:hbox#pack ()); - - let vbox = GPack.vbox ~packing:(hbox#pack ~expand:true) () in - vbox#set_spacing 5; - - let cols = new GTree.column_list in - (*let col_icon = cols#add Gobject.Data.string in*) - let col_name = cols#add Gobject.Data.string in - let model = GTree.list_store cols in - - let icons = GTree.icon_view - ~selection_mode:`SINGLE ~model - ~height:200 - ~packing:(vbox#pack ~expand:true ~fill:true) () in - icons#set_border_width 4; - - (*icons#set_pixbuf_column col_icon;*) - icons#set_text_column col_name; - - let refresh () = - model#clear (); - let services = !find_libvirtd_with_zeroconf () in - - (*let pixbuf = !icon_16x16_devices_computer_png in*) - List.iter ( - fun (name, _) -> - let row = model#append () in - model#set ~row ~column:col_name name; - (*match pixbuf with - | None -> () - | Some pixbuf -> model#set ~row ~column:col_icon pixbuf*) - ) services - in - refresh (); - - let hbox = GPack.hbox ~packing:vbox#pack () in - let refresh_button = - GButton.button ~label:(s_ "Refresh") - ~stock:`REFRESH ~packing:hbox#pack () in - let open_button = - GButton.button ~label:(s_ "Open") ~packing:hbox#pack () in - - ignore (refresh_button#connect#clicked ~callback:refresh); - - (* Function callback when someone selects and hits Open. *) - let callback () = - match icons#get_selected_items with - | [] -> () (* nothing selected *) - | path :: _ -> - let row = model#get_iter path in - let name = model#get ~row ~column:col_name in - let services = !find_libvirtd_with_zeroconf () in - try - uri := Some (List.assoc name services); - dlg#destroy () - with - Not_found -> () in - - ignore (open_button#connect#clicked ~callback) in - - (* Custom connections. *) - let () = - let frame = - GBin.frame ~label:(s_ "URI connection") ~packing:vbox#pack () in - let hbox = GPack.hbox ~packing:frame#add () in - hbox#set_spacing 20; - ignore (GMisc.image ~stock:`CONNECT ~packing:hbox#pack ()); - - let hbox = GPack.hbox ~packing:(hbox#pack ~expand:true) () in - let entry = - GEdit.entry ~text:"xen://localhost/" - ~packing:(hbox#pack ~expand:true ~fill:true) () in - let button = - GButton.button ~label:(s_ "Open") ~packing:hbox#pack () in - - ignore (button#connect#clicked - ~callback:(fun () -> - uri := Some entry#text; - dlg#destroy ())); - - () in - - - (* Just a cancel button in the action area. *) - let cancel_button = - GButton.button ~label:(s_ "Cancel") - ~packing:dlg#action_area#pack () in - ignore (cancel_button#connect#clicked - ~callback:(fun () -> - uri := None; - dlg#destroy ())); - - dlg#show (); - - (* Enter Gtk main loop recursively. *) - GMain.main (); - - match !uri with - | None -> () - | Some uri -> Vc_connections.open_connection uri - -(* Callback from the Connect button drop-down menu. *) -let open_local_xen () = - Vc_connections.open_connection local_xen_uri - -let open_local_qemu () = - Vc_connections.open_connection local_qemu_uri diff --git a/virt-ctrl/vc_connection_dlg.mli b/virt-ctrl/vc_connection_dlg.mli deleted file mode 100644 index 0102713..0000000 --- a/virt-ctrl/vc_connection_dlg.mli +++ /dev/null @@ -1,43 +0,0 @@ -(* virt-ctrl: A graphical management tool. - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - 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. - - Make the main window. -*) - -(** The connection dialog. *) -val open_connection : GWindow.window -> unit -> unit - -(** Quick connect to local Xen. *) -val open_local_xen : unit -> unit - -(** Quick connect to local QEMU or KVM. *) -val open_local_qemu : unit -> unit - -type name = string -type uri = string -type service = name * uri - -(** Hook to find libvirtd network services with zeroconf using some - external method, eg. D-Bus or Avahi. *) -val find_libvirtd_with_zeroconf : (unit -> service list) ref - -(** Hooks for icons. *) -val icon_16x16_devices_computer_png : GdkPixbuf.pixbuf option ref -val icon_24x24_devices_computer_png : GdkPixbuf.pixbuf option ref -val icon_32x32_devices_computer_png : GdkPixbuf.pixbuf option ref -val icon_48x48_devices_computer_png : GdkPixbuf.pixbuf option ref diff --git a/virt-ctrl/vc_connections.ml b/virt-ctrl/vc_connections.ml deleted file mode 100644 index 8f5fba0..0000000 --- a/virt-ctrl/vc_connections.ml +++ /dev/null @@ -1,477 +0,0 @@ -(* virt-ctrl: A graphical management tool. - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - 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. -*) - -open Printf -open Virt_ctrl_gettext.Gettext - -module C = Libvirt.Connect -module D = Libvirt.Domain -module N = Libvirt.Network - -open Vc_helpers - -(* List of currently open connections. Actually it's a list of - * (id, Libvirt.Connect.t) so that we can easily identify - * connections by their unique ID. - *) -let get_conns, add_conn, del_conn = - let conns = ref [] in - let id = ref 0 in - let get_conns () = !conns in - let add_conn conn = - incr id; let id = !id in - conns := (id, conn) :: !conns; - id - in - let del_conn id = - conns := List.filter (fun (id', _) -> id <> id') !conns - in - get_conns, add_conn, del_conn - -(* Store the node_info and hostname for each connection, fetched - * once just after we connect since these don't normally change. - * Hash of connid -> (C.node_info, hostname option, uri) - *) -let static_conn_info = Hashtbl.create 13 - -let open_connection uri = - (* If this fails, let the exception escape and be printed - * in the global exception handler. - *) - let conn = C.connect ~name:uri () in - - let node_info = C.get_node_info conn in - let hostname = - try Some (C.get_hostname conn) - with - | Libvirt.Not_supported "virConnectGetHostname" - | Libvirt.Virterror _ -> None in - - (* Add it to our list of connections. *) - let conn_id = add_conn conn in - Hashtbl.add static_conn_info conn_id (node_info, hostname, uri) - -(* Stores the state and history for each domain. - * Hash of (connid, domid) -> mutable domhistory structure. - * We never delete entries in this hash table, which may be a problem - * for very very long-lived instances of virt-ctrl. - *) -type domhistory = { - (* for %CPU calculation: *) - mutable last_cpu_time : int64; (* last virDomainInfo->cpuTime *) - mutable last_time : float; (* exact time we measured the above *) - - (* historical data for graphs etc: *) - mutable hist : dhentry array; (* historical data *) - mutable hist_posn : int; (* position within array *) -} -and dhentry = { - hist_cpu : int; (* historical %CPU entry *) - hist_mem : int64; (* historical memory entry (KB) *) -} - -let domhistory = Hashtbl.create 13 - -let empty_dhentry = { - hist_cpu = 0; hist_mem = 0L; -} -let new_domhistory () = { - last_cpu_time = 0L; last_time = 0.; - hist = Array.make 0 empty_dhentry; hist_posn = 0; -} - -(* These set limits on the amount of history we collect. *) -let hist_max = 86400 (* max history stored, seconds *) -let hist_rot = 3600 (* rotation of array when we hit max *) - -(* The current state. This is used so that we can see changes that - * have happened and add or remove parts of the model. (Previously - * we used to recreate the whole model each time, but the problem - * with that is we "forget" things like the selection). - *) -type state = connection list -and connection = int (* connection ID *) * (active list * inactive list) -and active = int (* domain's ID *) -and inactive = string (* domain's name *) - -(* The types of the display columns in the main window. The interesting - * one of the final (int) field which stores the ID of the row, either - * connid or domid. - *) -type columns = string GTree.column * string GTree.column * string GTree.column * string GTree.column * string GTree.column * int GTree.column - -let debug_repopulate = false - -(* Populate the tree with the current list of connections, domains. - * This function is called once per second. - *) -let repopulate (tree : GTree.view) (model : GTree.tree_store) - (col_name_id, col_domname, col_status, col_cpu, col_mem, col_id) - state = - (* Which connections have been added or removed? *) - let conns = get_conns () in - let added, _, removed = - let old_conn_ids = List.map fst state - and new_conn_ids = List.map fst conns in - differences old_conn_ids new_conn_ids in - - (* Remove the subtrees for any connections which have gone. *) - if debug_repopulate then List.iter (eprintf "-connection %d\n%!") removed; - - List.iter ( - fun conn_id -> - filter_top_level_rows model - (fun row -> conn_id <> model#get ~row ~column:col_id) - ) removed; - - (* Add placeholder subtree for any new connections. *) - if debug_repopulate then List.iter (eprintf "+connection %d\n%!") added; - - List.iter ( - fun conn_id -> - let row = model#append () in - (* Get the connection name, usually the hostname. *) - let name = - match Hashtbl.find static_conn_info conn_id with - | (_, Some hostname, _) -> hostname - | (_, None, _) -> sprintf "Conn #%d" conn_id in - model#set ~row ~column:col_name_id name; - model#set ~row ~column:col_id conn_id; - (* Expand the new row. *) - (* XXX This doesn't work, why? - Because we haven't create subrows yet.*) - tree#expand_row (model#get_path row) - ) added; - - let new_state = - List.map ( - fun (conn_id, conn) -> - (* Get the old list of active and inactive domains. If this - * connection is newly created, start with empty lists. - *) - let old_active, old_inactive = - try List.assoc conn_id state - with Not_found -> [], [] in - - (* Get the top level row in the model corresponding to this - * connection. - *) - let parent = - try find_top_level_row model - (fun row -> conn_id = model#get ~row ~column:col_id) - with Not_found -> assert false (* Should never happen. *) in - - try - (* Number of CPUs available. *) - let node_info, _, _ = Hashtbl.find static_conn_info conn_id in - let nr_cpus = C.maxcpus_of_node_info node_info in - - (* For this connection, get a current list of active domains (IDs) *) - let active = - let n = C.num_of_domains conn in - let doms = C.list_domains conn n in - Array.to_list doms in - - (* Which active domains have been added or removed? *) - let added, _, removed = differences old_active active in - - (* Remove any active domains which have disappeared. *) - if debug_repopulate then - List.iter (eprintf "-active %d\n%!") removed; - - List.iter ( - fun domid -> - filter_rows model - (fun row -> domid <> model#get ~row ~column:col_id) - (model#iter_children (Some parent)) - ) removed; - - (* Add any active domains which have appeared. *) - if debug_repopulate then - List.iter (eprintf "+active %d\n%!") added; - - List.iter ( - fun domid -> - let domname = - try - let dom = D.lookup_by_id conn domid in - D.get_name dom - with _ -> "" in (* Ignore any transient error. *) - - let row = model#append ~parent () in - model#set ~row ~column:col_name_id (string_of_int domid); - model#set ~row ~column:col_domname domname; - model#set ~row ~column:col_id domid - ) added; - - (* Get a current list of inactive domains (names). *) - let inactive = - let n = C.num_of_defined_domains conn in - let doms = C.list_defined_domains conn n in - Array.to_list doms in - - (* Which inactive domains have been added or removed? *) - let added, _, removed = differences old_inactive inactive in - - (* Remove any inactive domains which have disappeared. *) - if debug_repopulate then - List.iter (eprintf "-inactive %s\n%!") removed; - - List.iter ( - fun domname -> - filter_rows model - (fun row -> - model#get ~row ~column:col_id <> -1 || - model#get ~row ~column:col_domname <> domname) - (model#iter_children (Some parent)) - ) removed; - - (* Add any inactive domains which have appeared. *) - if debug_repopulate then - List.iter (eprintf "+inactive %s\n%!") added; - - List.iter ( - fun domname -> - let row = model#append ~parent () in - model#set ~row ~column:col_name_id ""; - model#set ~row ~column:col_domname domname; - model#set ~row ~column:col_status "inactive"; - model#set ~row ~column:col_id (-1) - ) added; - - (* Now iterate over all active domains and update their state, - * CPU and memory. - *) - iter_rows model ( - fun row -> - let domid = model#get ~row ~column:col_id in - if domid >= 0 then ( (* active *) - try - let dom = D.lookup_by_id conn domid in - let info = D.get_info dom in - let status = string_of_domain_state info.D.state in - model#set ~row ~column:col_status status; - let memory = sprintf "%Ld K" info.D.memory in - model#set ~row ~column:col_mem memory; - - (* Get domhistory. For a new domain it won't exist, so - * create an empty one. - *) - let dh = - let key = conn_id, domid in - try Hashtbl.find domhistory key - with Not_found -> - let dh = new_domhistory () in - Hashtbl.add domhistory key dh; - dh in - - (* Measure current time and domain cpuTime as close - * together as possible. - *) - let time_now = Unix.gettimeofday () in - let cpu_now = info.D.cpu_time in - - let time_prev = dh.last_time in - let cpu_prev = - if dh.last_cpu_time > cpu_now then 0L (* Rebooted? *) - else dh.last_cpu_time in - - dh.last_time <- time_now; - dh.last_cpu_time <- cpu_now; - - let cpu_percent = - if time_prev > 0. then ( - let cpu_now = Int64.to_float cpu_now in - let cpu_prev = Int64.to_float cpu_prev in - let cpu_used = cpu_now -. cpu_prev in - let cpu_available = 1_000_000_000. *. float nr_cpus in - let time_passed = time_now -. time_prev in - - let cpu_percent = - 100. *. (cpu_used /. cpu_available) /. time_passed in - - let cpu_percent = - if cpu_percent < 0. then 0. - else if cpu_percent > 100. then 100. - else cpu_percent in - - let cpu_percent_str = sprintf "%.1f %%" cpu_percent in - model#set ~row ~column:col_cpu cpu_percent_str; - int_of_float cpu_percent - ) else -1 in - - (* Store history. *) - let datum = { hist_cpu = cpu_percent; - hist_mem = info.D.memory } in - - if dh.hist_posn >= hist_max then ( - (* rotate the array *) - Array.blit dh.hist hist_rot dh.hist 0 (hist_max-hist_rot); - dh.hist_posn <- dh.hist_posn - hist_rot; - dh.hist.(dh.hist_posn) <- datum; - ) else ( - let len = Array.length dh.hist in - if dh.hist_posn < len then - (* normal update *) - dh.hist.(dh.hist_posn) <- datum - else ( - (* extend the array *) - let len' = min (max (2*len) 1) hist_max in - let arr' = Array.make len' datum in - Array.blit dh.hist 0 arr' 0 len; - dh.hist <- arr'; - ) - ); - dh.hist_posn <- dh.hist_posn+1 - - with - Libvirt.Virterror _ -> () (* Ignore any transient error *) - ) - ) (model#iter_children (Some parent)); - - (* Return new state. *) - conn_id, (active, inactive) - with - (* Libvirt errors here are not really fatal. They can happen - * if the state changes at the moment we read it. If it does - * happen, just return the old state, and next time we come - * around to this connection it'll be fixed. - *) - | Libvirt.Virterror err -> - prerr_endline (Libvirt.Virterror.to_string err); - conn_id, (old_active, old_inactive) - | Failure msg -> - prerr_endline msg; - conn_id, (old_active, old_inactive) - ) conns in - - (* Return the updated state. *) - new_state - -(* Make the treeview which displays the connections and domains. *) -let make_treeview ?packing () = - let cols = new GTree.column_list in - let col_name_id = cols#add Gobject.Data.string in - let col_domname = cols#add Gobject.Data.string in - let col_status = cols#add Gobject.Data.string in - let col_cpu = cols#add Gobject.Data.string in - let col_mem = cols#add Gobject.Data.string in - (* Hidden column containing the connection ID or domain ID. For - * inactive domains, this contains -1 and col_domname is the name. *) - let col_id = cols#add Gobject.Data.int in - let model = GTree.tree_store cols in - - (* Column sorting functions. *) - let make_sort_func_on column = - fun (model : GTree.model) row1 row2 -> - let col1 = model#get ~row:row1 ~column in - let col2 = model#get ~row:row2 ~column in - compare col1 col2 - in - (*model#set_default_sort_func (make_sort_func_on col_domname);*) - model#set_sort_func 0 (make_sort_func_on col_name_id); - model#set_sort_func 1 (make_sort_func_on col_domname); - model#set_sort_column_id 1 `ASCENDING; - - (* Make the GtkTreeView and attach column renderers to it. *) - let tree = GTree.view ~model ~reorderable:false ?packing () in - - let append_visible_column title column sort = - let renderer = GTree.cell_renderer_text [], ["text", column] in - let view_col = GTree.view_column ~title ~renderer () in - ignore (tree#append_column view_col); - match sort with - | None -> () - | Some (sort_indicator, sort_order, sort_column_id) -> - view_col#set_sort_indicator sort_indicator; - view_col#set_sort_order sort_order; - view_col#set_sort_column_id sort_column_id - in - append_visible_column (s_ "ID") col_name_id (Some (false, `ASCENDING, 0)); - append_visible_column (s_ "Name") col_domname (Some (true, `ASCENDING, 1)); - append_visible_column (s_ "Status") col_status None; - append_visible_column (s_ "CPU") col_cpu None; - append_visible_column (s_ "Memory") col_mem None; - - let columns = - col_name_id, col_domname, col_status, col_cpu, col_mem, col_id in - let state = repopulate tree model columns [] in - - (tree, model, columns, state) - -(* Get historical data size. *) -let get_hist_size connid domid = - try - let dh = Hashtbl.find domhistory (connid, domid) in - dh.hist_posn - with - Not_found -> 0 - -(* Get historical data entries. *) -let _get_hist ?(latest=0) ?earliest ?(granularity=1) - extract fold zero connid domid = - try - let dh = Hashtbl.find domhistory (connid, domid) in - let earliest = - match earliest with - | None -> dh.hist_posn - | Some e -> min e dh.hist_posn in - - let src = dh.hist in - let src_start = dh.hist_posn - earliest in assert (src_start >= 0); - let src_end = dh.hist_posn - latest in assert (src_end <= dh.hist_posn); - - (* Create a sufficiently large array to store the result. *) - let len = (earliest-latest) / granularity in - let r = Array.make len zero in - - if granularity = 1 then ( - for j = 0 to len-1 do - r.(j) <- extract src.(src_start+j) - done - ) else ( - let i = ref src_start in - for j = 0 to len-1 do - let sub = Array.sub src !i (min (!i+granularity) src_end - !i) in - let sub = Array.map extract sub in - r.(j) <- fold sub; - i := !i + granularity - done - ); - r - with - Not_found -> [| |] - -let get_hist_cpu ?latest ?earliest ?granularity connid domid = - let zero = 0 in - let extract { hist_cpu = c } = c in - let fold a = - let len = Array.length a in - if len > 0 then Array.fold_left (+) zero a / len else -1 in - _get_hist ?latest ?earliest ?granularity extract fold zero connid domid - -let get_hist_mem ?latest ?earliest ?granularity connid domid = - let zero = 0L in - let extract { hist_mem = m } = m in - let fold a = - let len = Array.length a in - if len > 0 then - Int64.div (Array.fold_left (Int64.add) zero a) (Int64.of_int len) - else - -1L in - _get_hist ?latest ?earliest ?granularity extract fold zero connid domid diff --git a/virt-ctrl/vc_connections.mli b/virt-ctrl/vc_connections.mli deleted file mode 100644 index 261f853..0000000 --- a/virt-ctrl/vc_connections.mli +++ /dev/null @@ -1,102 +0,0 @@ -(* virt-ctrl: A graphical management tool. - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - 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. - - Handle connections and the complicated GtkTreeView which - displays the connections / domains. -*) - -(** Get the list of current connections. *) -val get_conns : unit -> (int * Libvirt.rw Libvirt.Connect.t) list - -(** The current/previous state last time repopulate was called. The - repopulate function uses this state to determine what has changed - (eg. domains added, removed) since last time. -*) -type state - -type columns = string GTree.column * string GTree.column * string GTree.column * string GTree.column * string GTree.column * int GTree.column - -(** This function should be called once per second in order to - redraw the GtkTreeView. - - Takes the previous state as a parameter and returns the new state. -*) -val repopulate : GTree.view -> GTree.tree_store -> columns -> state -> state - -(** Create the GtkTreeView. Returns the widget itself, the model, - the list of columns, and the initial state. -*) -val make_treeview : - ?packing:(GObj.widget -> unit) -> unit -> - GTree.view * GTree.tree_store * columns * state - -(** Open a new connection to the hypervisor URI given. *) -val open_connection : string -> unit - -(** Return the amount of historical data that we hold about a - domain (in seconds). - - The parameters are connection ID (see {!get_conns}) and domain ID. - - This can return from [0] to [86400] (or 1 day of data). -*) -val get_hist_size : int -> int -> int - -(** Return a slice of historical %CPU data about a domain. - - The required parameters are connection ID (see {!get_conns}) - and domain ID. - - The optional [latest] parameter is the latest data we should - return. It defaults to [0] meaning to return everything up to now. - - The optional [earliest] parameter is the earliest data we should - return. This is a positive number representing number of seconds - back in time. It defaults to returning all data. - - The optional [granularity] parameter is the granularity of data - that we should return, in seconds. This defaults to [1], meaning - to return all data (once per second), but you might for example - set this to [60] to return data for each minute. - - This returns an array of data. The first element of the array is - the oldest data. The last element of the array is the most recent - data. The array returned might be shorter than you expect (if - data is missing or for some other reason) so always check the - length. - - Entries in the array are clamped to [0..100], except that if an - entry is [-1] it means "no data". - - This returns a zero-length array if we don't know about the domain. -*) -val get_hist_cpu : ?latest:int -> ?earliest:int -> ?granularity:int -> - int -> int -> - int array - -(** Return a slice of historical memory data about a domain. - - Parameters as above. - - Entries in the array are 64 bit integers corresponding to the - amount of memory in KB allocated to the domain (not necessarily - the amount being used, which we don't know about). -*) -val get_hist_mem : ?latest:int -> ?earliest:int -> ?granularity:int -> - int -> int -> - int64 array diff --git a/virt-ctrl/vc_dbus.ml b/virt-ctrl/vc_dbus.ml deleted file mode 100644 index 82b66dd..0000000 --- a/virt-ctrl/vc_dbus.ml +++ /dev/null @@ -1,317 +0,0 @@ -(* virt-ctrl: A graphical management tool. - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - 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. - - This file contains any code which needs optional package OCaml-DBUS. -*) - -(* There is *zero* documentation for this. I examined a lot of code - * to do this, and the following page was also very helpful: - * http://www.amk.ca/diary/2007/04/rough_notes_python_and_dbus.html - * See also the DBus API reference: - * http://dbus.freedesktop.org/doc/dbus/api/html/index.html - * See also Dan Berrange's Perl bindings: - * http://search.cpan.org/src/DANBERR/Net-DBus-0.33.5/lib/Net/ - * - * This code is a complicated state machine because that's what - * D-Bus requires. Enable debugging below to trace messages. - * - * It's also very unelegant and leaks memory. - * - * The code connects to D-Bus only the first time that the - * connection dialog is opened, and thereafter it attaches itself - * to the Gtk main loop, waiting for events. It's probably not - * safe if the avahi or dbus daemon restarts. - *) - -open Printf -open Virt_ctrl_gettext.Gettext -open DBus - -let debug = true - -let service = "_libvirt._tcp" - -let rec print_msg msg = - (match Message.get_type msg with - | Message.Invalid -> - eprintf "Invalid"; - | Message.Method_call -> - eprintf "Method_call"; - | Message.Method_return -> - eprintf "Method_return"; - | Message.Error -> - eprintf "Error"; - | Message.Signal -> - eprintf "Signal"); - - let print_opt f name = - match f msg with - | None -> () - | Some value -> eprintf "\n\t%s=%S" name value - in - print_opt Message.get_member "member"; - print_opt Message.get_path "path"; - print_opt Message.get_interface "interface"; - print_opt Message.get_sender "sender"; - - let fields = Message.get msg in - eprintf "\n\t["; - print_fields fields; - eprintf "]\n%!"; - -and print_fields fields = - eprintf "%s" (String.concat ", " (List.map string_of_ty fields)) - -(* Perform a synchronous call to an object method. *) -let call_method ~bus ~err ~name ~path ~interface ~methd args = - (* Create the method_call message. *) - let msg = Message.new_method_call name path interface methd in - Message.append msg args; - (* Send the message, get reply. *) - let r = Connection.send_with_reply_and_block bus msg (-1) err in - Message.get r - -(* Services we've found. - * This is a map from name -> URI. - * XXX We just assume Xen at the moment. - * XXX The same machine can appear on multiple interfaces, so this - * isn't right. - *) -let services : (string, string) Hashtbl.t = Hashtbl.create 13 - -(* Process a Found message, indicating that we've found and fully - * resolved a new service. - *) -let add_service bus err msg = - (* match fields in the Found message from ServiceResolver. *) - match Message.get msg with - | Int32 _ :: (* interface *) - Int32 (*protocol*)_ :: (* 0 = IPv4, 1=IPv6 *) - String name :: (* "Virtualization Host foo" *) - String _ :: (* "_libvirt._tcp" *) - String _ :: (* domain name *) - String hostname :: (* this is the hostname as a string *) - Int32 _ :: (* ? aprotocol *) - String address :: (* IP address as a string *) - UInt16 (*port*)_ :: _ -> (* port is set to 0 by libvirtd *) - - let hostname = if hostname <> "" then hostname else address in - (*let protocol = if protocol = 1_l then IPv6 else IPv4 in*) - - (* XXX *) - let uri = "xen://" ^ hostname ^ "/" in - - if debug then eprintf "adding %s %s\n%!" name uri; - - Hashtbl.replace services name uri - - | _ -> - prerr_endline (s_ "warning: unexpected message contents of Found signal") - -(* Process an ItemRemove message, indicating that a service has - * gone away. - *) -let remove_service bus err msg = - (* match fields in the ItemRemove message from ServiceBrowser. *) - match Message.get msg with - | Int32 _ :: (* interface *) - Int32 _ :: (* protocol *) - String name :: _ -> (* name *) - if debug then eprintf "removing %s\n%!" name; - Hashtbl.remove services name - - | _ -> - prerr_endline - (s_ "warning: unexpected message contents of ItemRemove signal") - -(* A service has appeared on the network. Resolve its IP address, etc. *) -let start_resolve_service bus err sb_path msg = - (* match fields in the ItemNew message from ServiceBrowser. *) - match Message.get msg with - | ((Int32 _) as interface) :: - ((Int32 _) as protocol) :: - ((String _) as name) :: - ((String _) as service) :: - ((String _) as domain) :: _ -> - (* Create a new ServiceResolver object which is used to resolve - * the actual locations of network services found by the ServiceBrowser. - *) - let sr = - call_method ~bus ~err - ~name:"org.freedesktop.Avahi" - ~path:"/" - ~interface:"org.freedesktop.Avahi.Server" - ~methd:"ServiceResolverNew" - [ - interface; - protocol; - name; - service; - domain; - Int32 (-1_l); (* AVAHI_PROTO_UNSPEC *) - UInt32 0_l; (* flags *) - ] in - let sr_path = - match sr with - | [ ObjectPath path ] -> path - | _ -> assert false in - - if debug then eprintf "ServiceResolver path = %S\n%!" sr_path; - - (* Add a match rule so we see these all signals of interest. *) - Bus.add_match bus - (String.concat "," [ - "type='signal'"; - "sender='org.freedesktop.Avahi.ServiceResolver'"; - "path='" ^ sr_path ^ "'"; - ]) err; - - () - - | _ -> - prerr_endline - (s_ "warning: unexpected message contents of ItemNew signal") - -(* This is called when we get a message/signal. Could be from the - * (global) ServiceBrowser or any of the ServiceResolver objects. - *) -let got_message bus err sb_path msg = - if debug then print_msg msg; - - let typ = Message.get_type msg in - let member = match Message.get_member msg with None -> "" | Some m -> m in - let interface = - match Message.get_interface msg with None -> "" | Some m -> m in - - if typ = Message.Signal then ( - match interface, member with - | "org.freedesktop.Avahi.ServiceBrowser", "CacheExhausted" -> () - | "org.freedesktop.Avahi.ServiceBrowser", "AllForNow" -> () - | "org.freedesktop.Avahi.ServiceBrowser", "ItemNew" -> - (* New service has appeared, start to resolve it. *) - start_resolve_service bus err sb_path msg - | "org.freedesktop.Avahi.ServiceResolver", "Found" -> - (* Resolver has finished resolving the name of a previously - * appearing service. - *) - add_service bus err msg - | "org.freedesktop.Avahi.ServiceBrowser", "ItemRemove" -> - (* Service has disappeared. *) - remove_service bus err msg - | "org.freedesktop.DBus", _ -> () - | interface, member -> - let () = - eprintf (f_ "warning: ignored unknown message %s from %s\n%!") - member interface in - () - ); - true - -(* Store the connection ((bus, err, io_id) tuple). However don't bother - * connecting to D-Bus at all until the user opens the connection - * dialog for the first time. - *) -let connection = ref None - -(* Create global error and system bus object, and create the service browser. *) -let connect () = - match !connection with - | Some (bus, err, _) -> (bus, err, false) - | None -> - let err = Error.init () in - let bus = Bus.get Bus.System err in - if Error.is_set err then - failwith (s_ "error set after getting System bus"); - - (* Create a new ServiceBrowser object which emits a signal whenever - * a new network service of the type specified is found on the network. - *) - let sb = - call_method ~bus ~err - ~name:"org.freedesktop.Avahi" - ~path:"/" - ~interface:"org.freedesktop.Avahi.Server" - ~methd:"ServiceBrowserNew" - [ - Int32 (-1_l); (* interface, -1=AVAHI_IF_UNSPEC *) - Int32 (-1_l); (* AVAHI_PROTO_UNSPEC *) - String service; (* service type *) - String ""; (* XXX call GetDomainName() *) - UInt32 0_l; (* flags *) - ] in - let sb_path = - match sb with - | [ ObjectPath path ] -> path - | _ -> assert false in - - if debug then eprintf "ServiceBrowser path = %S\n%!" sb_path; - - (* Register a callback to accept the signals. *) - (* XXX This leaks memory because it is never freed. *) - Connection.add_filter bus ( - fun bus msg -> got_message bus err sb_path msg - ); - - (* Add a match rule so we see these all signals of interest. *) - Bus.add_match bus - (String.concat "," [ - "type='signal'"; - "sender='org.freedesktop.Avahi.ServiceBrowser'"; - "path='" ^ sb_path ^ "'"; - ]) err; - - (* This is called from the Gtk main loop whenever there is new - * data to read on the D-Bus socket. - *) - let callback _ = - if debug then eprintf "dbus callback\n%!"; - if Connection.read_write_dispatch bus 0 then true - else ( (* Disconnected. *) - connection := None; - false - ) - in - - (* Get the file descriptor and attach to the Gtk main loop. *) - let fd = Connection.get_fd bus in - let channel = GMain.Io.channel_of_descr fd in - let io_id = GMain.Io.add_watch ~cond:[`IN] ~callback channel in - - connection := Some (bus, err, io_id); - (bus, err, true) - -(* This function is called by the connection dialog and is expected - * to return a list of services we know about now. - *) -let find_services () = - let bus, err, just_connected = connect () in - - (* If we've just connected, wait briefly for the list to stablise. *) - if just_connected then ( - let start_time = Unix.gettimeofday () in - while Unix.gettimeofday () -. start_time < 0.5 do - ignore (Connection.read_write_dispatch bus 500) - done - ); - - (* Return the services we know about. *) - Hashtbl.fold (fun k v vs -> (k, v) :: vs) services [] - -;; - -Vc_connection_dlg.find_libvirtd_with_zeroconf := find_services diff --git a/virt-ctrl/vc_dbus.mli b/virt-ctrl/vc_dbus.mli deleted file mode 100644 index 884093e..0000000 --- a/virt-ctrl/vc_dbus.mli +++ /dev/null @@ -1,22 +0,0 @@ -(* virt-ctrl: A graphical management tool. - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - 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. - - This file contains any code which needs optional package OCaml-DBUS. -*) - -(* No public API. If loaded this module hooks into Vc_connection_dlg. *) diff --git a/virt-ctrl/vc_domain_ops.ml b/virt-ctrl/vc_domain_ops.ml deleted file mode 100644 index deace05..0000000 --- a/virt-ctrl/vc_domain_ops.ml +++ /dev/null @@ -1,109 +0,0 @@ -(* virt-ctrl: A graphical management tool. - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - 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. - - Domain operations buttons. -*) - -open Printf -open Virt_ctrl_gettext.Gettext - -module C = Libvirt.Connect -module D = Libvirt.Domain -module N = Libvirt.Network - -(* Get the selected domain (if there is one) or return None. *) -let get_domain (tree : GTree.view) (model : GTree.tree_store) - (columns : Vc_connections.columns) = - let path, _ = tree#get_cursor () in - match path with - | None -> None (* No row at all selected. *) - | Some path -> - let row = model#get_iter path in - (* Visit parent to get the connid. - * If this returns None, then it's a top-level row which is - * selected (ie. a connection), so just ignore. - *) - match model#iter_parent row with - | None -> None - | Some parent -> - try - let (_, col_domname, _, _, _, col_id) = columns in - let connid = model#get ~row:parent ~column:col_id in - let conn = - List.assoc connid (Vc_connections.get_conns ()) in - let domid = model#get ~row ~column:col_id in - if domid = -1 then ( (* Inactive domain. *) - let domname = model#get ~row ~column:col_domname in - let dom = D.lookup_by_name conn domname in - let info = D.get_info dom in - Some (dom, info, connid, -1) - ) else ( (* Active domU. *) - let dom = D.lookup_by_id conn domid in - let info = D.get_info dom in - Some (dom, info, connid, domid) - ) - with - (* Domain or connection disappeared under us. *) - | Not_found -> None - | Failure msg -> - prerr_endline msg; - None - | Libvirt.Virterror err -> - prerr_endline (Libvirt.Virterror.to_string err); - None - -type dops_callback_fn = - GTree.view -> GTree.tree_store -> Vc_connections.columns -> unit -> unit - -let start_domain tree model columns () = - match get_domain tree model columns with - | None -> () - | Some (dom, _, _, domid) -> - if domid = -1 then - D.create dom - -let pause_domain tree model columns () = - match get_domain tree model columns with - | None -> () - | Some (dom, info, _, domid) -> - if domid >= 0 && info.D.state <> D.InfoPaused then - D.suspend dom - -let resume_domain tree model columns () = - match get_domain tree model columns with - | None -> () - | Some (dom, info, _, domid) -> - if domid >= 0 && info.D.state = D.InfoPaused then - D.resume dom - -let shutdown_domain tree model columns () = - match get_domain tree model columns with - | None -> () - | Some (dom, info, _, domid) -> - if domid >= 0 && info.D.state <> D.InfoShutdown then - D.shutdown dom - -let open_domain_details tree model columns () = - match get_domain tree model columns with - | None -> () - | Some (dom, info, connid, domid) -> - if domid >= 0 then ( - - - - ) diff --git a/virt-ctrl/vc_domain_ops.mli b/virt-ctrl/vc_domain_ops.mli deleted file mode 100644 index 38a2015..0000000 --- a/virt-ctrl/vc_domain_ops.mli +++ /dev/null @@ -1,35 +0,0 @@ -(* virt-ctrl: A graphical management tool. - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - 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. - - Domain operations buttons. -*) - -type dops_callback_fn = - GTree.view -> GTree.tree_store -> Vc_connections.columns -> unit -> unit - (** Domain ops callback function type. - - The parameters are: tree (view), model, columns. - The extra unit parameter is there to make it easier to - turn into a callback. - *) - -val start_domain : dops_callback_fn -val pause_domain : dops_callback_fn -val resume_domain : dops_callback_fn -val shutdown_domain : dops_callback_fn -val open_domain_details : dops_callback_fn diff --git a/virt-ctrl/vc_helpers.ml b/virt-ctrl/vc_helpers.ml deleted file mode 100644 index 74e70cb..0000000 --- a/virt-ctrl/vc_helpers.ml +++ /dev/null @@ -1,97 +0,0 @@ -(* virt-ctrl: A graphical management tool. - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - 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. -*) - -open Virt_ctrl_gettext.Gettext - -module C = Libvirt.Connect -module D = Libvirt.Domain -module N = Libvirt.Network - -(* Given two lists, xs and ys, return a list of items which have been - * added to ys, items which are the same, and items which have been - * removed from ys. - * Returns a triplet (list of added, list of same, list of removed). - *) -let differences xs ys = - let rec d = function - | [], [] -> (* Base case. *) - ([], [], []) - | [], ys -> (* All ys have been added. *) - (ys, [], []) - | xs, [] -> (* All xs have been removed. *) - ([], [], xs) - | (x :: xs), (y :: ys) when x = y -> (* Not added or removed. *) - let added, unchanged, removed = d (xs, ys) in - added, x :: unchanged, removed - | (x :: xs), ((y :: _) as ys) when x < y -> (* x removed. *) - let added, unchanged, removed = d (xs, ys) in - added, unchanged, x :: removed - | ((x :: _) as xs), (y :: ys) (* when x > y *) -> (* y added. *) - let added, unchanged, removed = d (xs, ys) in - y :: added, unchanged, removed - in - d (List.sort compare xs, List.sort compare ys) - -let string_of_domain_state = function - | D.InfoNoState -> s_ "unknown" - | D.InfoRunning -> s_ "running" - | D.InfoBlocked -> s_ "blocked" - | D.InfoPaused -> s_ "paused" - | D.InfoShutdown -> s_ "shutdown" - | D.InfoShutoff -> s_ "shutoff" - | D.InfoCrashed -> s_ "crashed" - -(* Filter top level rows (only) in a tree_store. If function f returns - * true then the row remains, but if it returns false then the row is - * removed. - *) -let rec filter_top_level_rows (model : GTree.tree_store) f = - match model#get_iter_first with - | None -> () - | Some iter -> filter_rows model f iter - -(* Filter rows in a tree_store at a particular level. *) -and filter_rows model f row = - let keep = f row in - let iter_still_valid = - if not keep then model#remove row else model#iter_next row in - if iter_still_valid then filter_rows model f row - -(* Find the first top level row matching predicate f and return it. *) -let rec find_top_level_row (model : GTree.tree_store) f = - match model#get_iter_first with - | None -> raise Not_found (* no rows *) - | Some row -> find_row model f row - -(* Find the first row matching predicate f at a particular level. *) -and find_row model f row = - if f row then row - else if model#iter_next row then find_row model f row - else raise Not_found - -(* Iterate over top level rows (only) in a tree_store. *) -let rec iter_top_level_rows (model : GTree.tree_store) f = - match model#get_iter_first with - | None -> () - | Some iter -> iter_rows model f iter - -(* Iterate over rows in a tree_store at a particular level. *) -and iter_rows model f row = - f row; - if model#iter_next row then iter_rows model f row diff --git a/virt-ctrl/vc_helpers.mli b/virt-ctrl/vc_helpers.mli deleted file mode 100644 index b533024..0000000 --- a/virt-ctrl/vc_helpers.mli +++ /dev/null @@ -1,51 +0,0 @@ -(* virt-ctrl: A graphical management tool. - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - 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. - - Helper functions. -*) - -(** Given two lists, xs and ys, return a list of items which have been - added to ys, items which are the same, and items which have been - removed from ys. - Returns a triplet (list of added, list of same, list of removed). -*) -val differences : 'a list -> 'a list -> 'a list * 'a list * 'a list - -(** Convert libvirt domain state to a string. *) -val string_of_domain_state : Libvirt.Domain.state -> string - -(** Filter top level rows (only) in a GtkTreeStore. If function f returns - true then the row remains, but if it returns false then the row is - removed. -*) -val filter_top_level_rows : GTree.tree_store -> (Gtk.tree_iter -> bool) -> unit - -(** Filter rows in a tree_store at a particular level. *) -val filter_rows : GTree.tree_store -> (Gtk.tree_iter -> bool) -> Gtk.tree_iter -> unit - -(** Find the first top level row matching predicate and return it. *) -val find_top_level_row : GTree.tree_store -> (Gtk.tree_iter -> bool) -> Gtk.tree_iter - -(** Find the first row matching predicate f at a particular level. *) -val find_row : GTree.tree_store -> (Gtk.tree_iter -> bool) -> Gtk.tree_iter -> Gtk.tree_iter - -(** Iterate over top level rows (only) in a GtkTreeStore. *) -val iter_top_level_rows : GTree.tree_store -> (Gtk.tree_iter -> unit) -> unit - -(** Iterate over rows in a tree_store at a particular level. *) -val iter_rows : GTree.tree_store -> (Gtk.tree_iter -> unit) -> Gtk.tree_iter -> unit diff --git a/virt-ctrl/vc_icons.ml b/virt-ctrl/vc_icons.ml deleted file mode 100644 index 911e487..0000000 --- a/virt-ctrl/vc_icons.ml +++ /dev/null @@ -1,270 +0,0 @@ - - -open Vc_connection_dlg - - -let pixbuf_data = "\ -\132\149\166\190\000\000\010\192\000\000\000\001\000\000\000\003\000\000\000\003\ -\018\071\100\107\080\105\120\098\117\102\047\050\046\048\047\000\000\000\010\172\ -\071\100\107\080\000\000\010\172\002\001\000\002\000\000\000\128\000\000\000\032\ -\000\000\000\032\161\255\255\255\000\003\136\138\133\023\140\142\137\150\138\140\ -\135\247\152\136\138\133\255\003\138\140\135\246\140\142\137\156\136\138\133\030\ -\130\255\255\255\000\003\141\143\138\165\190\191\188\251\249\249\249\255\152\255\ -\255\255\255\009\248\248\247\255\194\196\192\253\141\143\138\165\255\255\255\000\ -\136\138\133\010\139\141\136\246\250\250\249\255\128\152\186\255\033\075\135\255\ -\150\032\074\135\255\010\033\075\135\255\113\140\178\255\244\245\246\255\139\141\ -\136\246\136\138\133\009\136\138\133\024\141\143\138\246\255\255\255\255\033\075\ -\135\255\160\182\205\255\130\173\191\212\255\134\173\192\212\255\131\174\193\213\ -\255\134\175\193\213\255\134\176\194\213\255\003\041\081\139\255\255\255\255\255\ -\141\143\138\246\130\136\138\133\024\004\141\143\138\246\255\255\255\255\032\074\ -\135\255\154\177\202\255\151\164\185\208\255\003\040\080\139\255\255\255\255\255\ -\141\143\138\246\130\136\138\133\024\004\141\143\138\246\255\255\255\255\032\074\ -\135\255\144\169\197\255\151\153\176\202\255\003\040\080\139\255\255\255\255\255\ -\141\143\138\246\130\136\138\133\024\004\141\143\138\246\255\255\255\255\032\074\ -\135\255\134\162\192\255\151\142\168\196\255\003\040\080\139\255\255\255\255\255\ -\141\143\138\246\130\136\138\133\024\004\141\143\138\246\255\255\255\255\032\074\ -\135\255\123\154\186\255\134\131\159\190\255\002\132\160\190\255\133\161\191\255\ -\130\133\161\192\255\003\134\162\192\255\134\162\193\255\134\162\192\255\131\133\ -\161\192\255\001\132\160\190\255\132\131\159\190\255\005\121\152\185\255\103\138\ -\176\255\040\080\139\255\255\255\255\255\141\143\138\246\130\136\138\133\024\004\ -\141\143\138\246\255\255\255\255\032\074\135\255\113\145\181\255\131\119\150\184\ -\255\007\121\152\185\255\122\153\187\255\123\154\188\255\125\155\189\255\125\156\ -\189\255\126\157\190\255\127\157\191\255\132\127\158\191\255\007\126\157\190\255\ -\125\156\189\255\123\155\188\255\105\140\178\255\088\127\169\255\072\114\160\255\ -\055\101\150\255\130\050\097\148\255\003\040\080\139\255\255\255\255\255\141\143\ -\138\246\130\136\138\133\024\030\141\143\138\246\255\255\255\255\032\074\135\255\ -\103\138\176\255\108\142\178\255\110\144\180\255\112\145\182\255\114\147\183\255\ -\115\149\185\255\117\150\186\255\118\151\187\255\119\152\188\255\120\153\189\255\ -\120\154\190\255\121\154\190\255\121\155\190\255\121\154\190\255\120\154\190\255\ -\115\149\186\255\091\131\174\255\068\113\163\255\062\109\159\255\060\107\157\255\ -\058\105\155\255\056\102\153\255\053\100\151\255\050\097\148\255\040\080\139\255\ -\255\255\255\255\141\143\138\246\130\136\138\133\024\030\141\143\138\246\255\255\ -\255\255\032\074\135\255\094\131\171\255\100\136\175\255\102\138\178\255\105\141\ -\179\255\107\142\181\255\108\145\183\255\111\146\185\255\112\148\186\255\113\149\ -\188\255\115\150\188\255\115\151\189\255\115\152\189\255\116\152\190\255\106\145\ -\185\255\088\130\176\255\073\119\169\255\071\118\168\255\070\116\166\255\068\114\ -\164\255\066\112\162\255\063\110\160\255\060\107\158\255\058\104\155\255\055\102\ -\152\255\040\080\139\255\255\255\255\255\141\143\138\246\130\136\138\133\024\030\ -\141\143\138\246\255\255\255\255\032\074\135\255\087\126\169\255\092\131\173\255\ -\096\133\175\255\098\136\178\255\101\138\180\255\102\141\182\255\105\143\184\255\ -\106\144\185\255\108\146\187\255\110\147\189\255\109\147\189\255\099\140\184\255\ -\086\131\179\255\081\127\177\255\080\126\176\255\079\125\175\255\077\124\173\255\ -\076\122\171\255\073\120\169\255\071\117\167\255\068\114\165\255\065\112\162\255\ -\062\109\159\255\059\106\156\255\040\081\139\255\255\255\255\255\141\143\138\246\ -\130\136\138\133\024\030\141\143\138\246\255\255\255\255\032\074\135\255\080\121\ -\166\255\085\126\170\255\088\129\173\255\091\132\175\255\094\134\178\255\096\137\ -\181\255\099\139\183\255\102\142\185\255\099\141\185\255\093\137\183\255\086\132\ -\182\255\087\133\182\255\088\134\183\255\087\133\183\255\087\132\182\255\085\131\ -\180\255\083\129\179\255\081\127\176\255\078\124\174\255\075\122\171\255\072\119\ -\169\255\069\116\166\255\066\112\163\255\062\109\159\255\040\081\139\255\255\255\ -\255\255\141\143\138\246\130\136\138\133\024\030\141\143\138\246\255\255\255\255\ -\032\074\135\255\073\117\164\255\077\121\168\255\081\124\171\255\084\128\174\255\ -\086\129\176\255\087\131\178\255\087\131\180\255\088\132\182\255\088\134\183\255\ -\091\136\185\255\093\138\187\255\094\139\188\255\094\140\189\255\094\140\188\255\ -\093\138\187\255\091\137\186\255\089\134\183\255\086\132\181\255\083\129\178\255\ -\080\126\175\255\076\122\172\255\073\119\169\255\069\115\166\255\065\112\162\255\ -\040\081\140\255\255\255\255\255\141\143\138\246\130\136\138\133\024\030\141\143\ -\138\246\255\255\255\255\032\074\135\255\063\110\160\255\067\114\164\255\071\117\ -\167\255\075\121\171\255\079\125\174\255\082\128\178\255\086\132\181\255\090\135\ -\184\255\093\139\187\255\096\141\190\255\098\144\193\255\100\146\194\255\101\146\ -\195\255\100\146\194\255\099\144\193\255\096\142\191\255\093\139\188\255\090\136\ -\185\255\086\132\182\255\083\129\178\255\079\125\175\255\075\121\171\255\071\118\ -\168\255\068\114\164\255\040\081\140\255\255\255\255\255\141\143\138\246\130\136\ -\138\133\024\030\141\143\138\246\255\255\255\255\032\074\135\255\065\111\161\255\ -\069\115\165\255\073\119\169\255\077\123\172\255\080\127\176\255\084\130\180\255\ -\088\134\183\255\092\138\187\255\096\142\190\255\100\145\194\255\103\149\197\255\ -\106\151\200\255\107\153\201\255\106\152\200\255\104\149\197\255\100\146\194\255\ -\096\142\191\255\093\138\187\255\089\135\184\255\085\131\180\255\081\127\176\255\ -\077\123\173\255\073\119\169\255\069\115\165\255\041\081\140\255\255\255\255\255\ -\141\143\138\246\130\136\138\133\024\030\141\143\138\246\255\255\255\255\032\074\ -\135\255\065\111\162\255\069\115\165\255\073\119\169\255\077\123\173\255\081\127\ -\177\255\085\131\180\255\089\135\184\255\093\139\188\255\097\143\191\255\101\147\ -\195\255\105\151\199\255\109\154\203\255\113\158\206\255\110\155\203\255\106\151\ -\199\255\102\147\196\255\098\143\192\255\094\139\188\255\090\135\184\255\086\131\ -\181\255\081\127\177\255\077\124\173\255\073\120\170\255\069\116\166\255\041\081\ -\140\255\255\255\255\255\141\143\138\246\130\136\138\133\024\006\141\143\138\246\ -\255\255\255\255\032\074\135\255\047\087\143\255\048\088\144\255\048\088\145\255\ -\130\049\089\145\255\130\050\090\146\255\130\051\091\147\255\001\052\091\148\255\ -\130\052\092\148\255\001\053\092\148\255\130\052\092\148\255\001\052\091\148\255\ -\130\051\091\147\255\130\050\090\146\255\130\049\089\145\255\005\048\088\145\255\ -\048\088\144\255\032\075\135\255\255\255\255\255\141\143\138\246\130\136\138\133\ -\024\005\141\143\138\246\255\255\255\255\198\206\214\255\197\205\214\255\196\204\ -\214\255\132\196\204\213\255\131\196\204\212\255\131\195\203\211\255\130\194\202\ -\211\255\132\194\202\210\255\134\193\201\210\255\007\192\200\209\255\254\254\254\ -\255\141\143\138\246\136\138\133\024\136\138\133\009\138\140\135\247\244\244\244\ -\255\151\254\254\254\255\131\255\255\255\255\006\247\247\246\255\138\140\135\248\ -\136\138\133\008\255\255\255\000\141\143\138\132\138\140\135\245\154\136\138\133\ -\255\002\138\140\135\245\141\143\138\149\135\255\255\255\000\025\000\000\000\001\ -\000\000\000\005\110\110\110\037\127\129\125\120\121\123\119\247\193\193\191\255\ -\203\203\201\255\205\205\204\255\207\207\206\255\210\210\208\255\213\213\211\255\ -\216\216\214\255\218\218\217\255\221\221\219\255\197\198\196\255\134\139\137\248\ -\121\146\173\203\110\153\198\187\112\156\204\189\113\156\204\192\113\158\205\195\ -\115\158\207\198\115\159\207\236\114\158\207\206\111\162\204\030\132\255\255\255\ -\000\008\000\000\000\002\000\000\000\007\000\000\000\011\000\000\000\015\124\126\ -\122\117\139\142\137\248\166\167\165\248\197\197\195\255\136\212\212\211\255\130\ -\211\211\211\255\011\185\185\185\255\156\157\154\246\138\140\134\244\082\082\078\ -\068\093\131\171\109\103\143\187\146\101\142\183\124\093\128\168\082\106\147\192\ -\147\112\156\204\205\000\000\000\002\130\255\255\255\000\008\000\000\000\003\000\ -\000\000\008\000\000\000\013\000\000\000\018\000\000\000\023\138\141\136\217\200\ -\200\197\255\251\251\251\255\140\254\254\254\255\010\241\241\241\255\174\176\172\ -\252\122\129\130\164\112\156\205\244\092\129\169\152\100\139\181\170\107\151\195\ -\206\112\157\203\235\106\147\192\187\000\000\000\011\130\255\255\255\000\006\000\ -\000\000\001\000\000\000\007\000\000\000\012\000\000\000\017\000\000\000\022\135\ -\137\132\208\132\137\139\134\248\138\137\139\134\249\130\137\139\134\248\008\123\ -\126\122\156\112\156\203\245\052\075\094\054\000\000\000\020\000\000\000\019\000\ -\000\000\020\000\000\000\015\000\000\000\002\130\255\255\255\000\003\136\138\133\ -\056\154\156\152\242\185\187\182\255\136\186\189\182\255\010\187\190\183\255\186\ -\189\182\255\187\190\184\255\186\189\182\255\188\191\184\255\186\188\182\255\184\ -\186\181\255\186\189\182\255\187\190\183\255\186\189\182\255\130\186\188\183\255\ -\006\186\189\182\255\187\190\183\255\185\188\181\255\182\183\179\255\140\142\137\ -\238\136\138\133\053\130\255\255\255\000\030\136\138\133\010\148\150\145\234\225\ -\226\224\255\199\201\196\255\211\215\207\255\217\220\213\255\211\215\207\255\219\ -\222\215\255\211\215\207\255\220\223\217\255\211\215\207\255\221\224\218\255\211\ -\215\207\255\222\225\219\255\211\215\207\255\223\226\221\255\211\215\207\255\208\ -\211\206\255\207\209\202\255\203\205\200\255\186\189\182\255\204\206\201\255\190\ -\194\187\255\206\208\202\255\214\216\211\255\211\215\207\255\220\222\217\255\188\ -\191\184\255\227\227\224\255\141\143\138\216\130\255\255\255\000\067\138\140\135\ -\151\212\212\210\251\190\193\186\255\207\210\202\255\224\226\221\255\211\215\207\ -\255\226\228\223\255\211\215\207\255\228\231\226\255\211\215\207\255\230\232\228\ -\255\211\215\207\255\232\234\230\255\211\215\207\255\234\236\232\255\211\215\207\ -\255\235\237\233\255\189\193\186\255\218\219\214\255\191\195\188\255\220\222\218\ -\255\187\190\183\255\228\230\226\255\211\213\207\255\194\197\190\255\232\234\230\ -\255\211\215\207\255\227\228\225\255\218\220\216\255\165\167\163\246\136\138\133\ -\076\136\138\133\050\151\153\148\247\238\238\237\255\187\190\183\255\210\212\207\ -\255\186\189\182\255\214\216\212\255\186\189\182\255\219\220\216\255\186\189\182\ -\255\223\224\221\255\186\189\182\255\227\229\226\255\186\189\182\255\232\233\230\ -\255\186\189\182\255\236\237\235\255\186\189\182\255\241\241\240\255\215\216\212\ -\255\227\229\226\255\186\189\182\255\232\233\230\255\185\188\181\255\221\222\218\ -\255\228\229\226\255\186\189\182\255\232\233\230\255\186\189\182\255\204\206\201\ -\255\236\237\235\255\141\143\138\216\136\138\133\092\170\172\167\245\252\252\251\ -\255\254\254\254\255\142\253\253\253\255\002\254\254\254\255\255\255\255\255\132\ -\253\253\253\255\002\255\255\255\255\254\254\254\255\131\253\253\253\255\006\255\ -\255\255\255\236\236\234\255\139\141\136\243\136\138\133\015\141\143\138\202\136\ -\138\133\253\131\136\138\133\255\131\136\138\133\254\132\136\138\133\253\133\137\ -\139\134\252\131\137\139\134\251\134\138\140\135\250\001\138\140\135\249\130\139\ -\141\136\249\002\141\143\138\230\137\139\134\083" - -let pixbuf () : GdkPixbuf.pixbuf = Marshal.from_string pixbuf_data 0 -;; -icon_32x32_devices_computer_png := Some (pixbuf ()) ;; - -let pixbuf_data = "\ -\132\149\166\190\000\000\005\123\000\000\000\001\000\000\000\003\000\000\000\003\ -\018\071\100\107\080\105\120\098\117\102\047\050\046\048\047\000\000\000\005\103\ -\071\100\107\080\000\000\005\103\002\001\000\002\000\000\000\096\000\000\000\024\ -\000\000\000\024\154\000\000\000\000\002\131\131\134\116\128\128\131\253\144\128\ -\128\131\255\002\128\128\131\253\131\131\134\116\132\000\000\000\000\002\128\128\ -\131\253\250\250\250\255\144\255\255\255\255\002\250\250\250\255\128\128\131\253\ -\132\000\000\000\000\003\128\128\131\255\252\252\253\255\048\087\143\255\142\032\ -\074\135\255\003\050\088\144\255\255\255\255\255\128\128\131\255\132\000\000\000\ -\000\009\128\128\131\255\248\249\251\255\034\075\135\255\090\129\181\255\093\132\ -\182\255\097\135\184\255\101\138\186\255\105\141\187\255\109\144\189\255\136\113\ -\147\191\255\003\032\074\135\255\255\255\255\255\128\128\131\255\132\000\000\000\ -\000\020\128\128\131\255\248\249\251\255\034\075\135\255\086\126\179\255\089\129\ -\180\255\094\133\183\255\100\137\185\255\105\142\188\255\108\145\190\255\113\148\ -\192\255\117\151\194\255\118\151\194\255\117\151\194\255\116\150\193\255\116\149\ -\192\255\114\148\192\255\113\147\191\255\032\074\135\255\255\255\255\255\128\128\ -\131\255\132\000\000\000\000\011\128\128\131\255\248\249\251\255\034\075\135\255\ -\084\125\178\255\090\131\182\255\096\135\185\255\102\140\188\255\106\144\191\255\ -\111\147\193\255\115\151\194\255\119\153\196\255\130\123\156\198\255\007\122\155\ -\197\255\120\154\196\255\119\153\195\255\117\151\194\255\032\074\135\255\255\255\ -\255\255\128\128\131\255\132\000\000\000\000\020\128\128\131\255\248\249\251\255\ -\034\076\135\255\086\128\181\255\092\133\184\255\098\138\188\255\104\143\190\255\ -\108\147\193\255\113\150\195\255\118\153\197\255\121\156\199\255\125\159\200\255\ -\117\153\197\255\102\142\190\255\091\134\185\255\081\125\180\255\069\116\174\255\ -\032\074\135\255\255\255\255\255\128\128\131\255\132\000\000\000\000\020\128\128\ -\131\255\248\249\251\255\034\076\136\255\086\129\183\255\094\136\186\255\100\141\ -\190\255\105\145\192\255\110\150\195\255\115\153\198\255\119\156\200\255\114\153\ -\197\255\094\138\190\255\081\128\184\255\079\127\183\255\077\124\181\255\074\122\ -\179\255\071\119\177\255\032\074\135\255\255\255\255\255\128\128\131\255\132\000\ -\000\000\000\020\128\128\131\255\248\249\251\255\034\076\136\255\087\131\184\255\ -\094\137\188\255\101\142\191\255\107\147\195\255\113\152\198\255\111\151\197\255\ -\098\143\193\255\091\137\191\255\090\137\190\255\089\135\189\255\086\133\188\255\ -\083\130\186\255\080\127\183\255\076\124\181\255\032\074\135\255\255\255\255\255\ -\128\128\131\255\132\000\000\000\000\020\128\128\131\255\248\249\251\255\034\076\ -\136\255\086\130\184\255\091\136\188\255\095\139\191\255\098\142\192\255\097\142\ -\193\255\096\142\194\255\098\144\195\255\098\144\196\255\098\144\195\255\095\142\ -\194\255\092\139\192\255\089\135\189\255\085\131\186\255\080\127\183\255\032\074\ -\135\255\255\255\255\255\128\128\131\255\132\000\000\000\000\020\128\128\131\255\ -\248\249\251\255\034\076\136\255\078\126\182\255\083\130\185\255\088\135\189\255\ -\093\139\192\255\097\143\195\255\101\147\198\255\105\150\200\255\106\152\201\255\ -\105\150\200\255\101\147\198\255\097\143\195\255\092\139\192\255\088\134\189\255\ -\083\130\185\255\032\074\135\255\255\255\255\255\128\128\131\255\132\000\000\000\ -\000\003\128\128\131\255\252\252\253\255\048\088\143\255\142\032\074\135\255\003\ -\050\089\145\255\255\255\255\255\128\128\131\255\132\000\000\000\000\002\128\128\ -\131\255\255\255\255\255\144\228\228\225\255\002\255\255\255\255\128\128\131\255\ -\132\000\000\000\000\002\128\128\131\253\250\250\250\255\144\255\255\255\255\002\ -\250\250\250\255\128\128\131\253\132\000\000\000\000\002\131\131\134\116\128\128\ -\131\253\144\128\128\131\255\002\128\128\131\253\131\131\134\116\138\000\000\000\ -\000\008\134\136\131\255\141\144\138\255\147\150\144\255\153\156\150\255\159\162\ -\156\255\165\168\162\255\171\174\167\255\134\136\131\255\137\000\000\000\000\022\ -\131\132\132\003\137\138\137\223\139\140\139\241\179\181\175\254\181\184\177\255\ -\184\187\180\255\181\184\177\255\184\187\180\255\181\184\177\255\184\187\180\255\ -\181\184\177\255\184\187\180\255\181\184\177\255\184\187\180\255\181\184\177\255\ -\184\187\180\255\181\184\177\255\184\187\180\255\179\181\175\254\139\140\139\241\ -\136\137\137\224\131\132\132\004\130\000\000\000\000\022\126\127\127\054\152\153\ -\153\236\221\222\219\255\186\189\181\255\187\190\183\255\191\197\186\255\198\201\ -\194\255\191\197\186\255\211\213\208\255\191\197\186\255\221\223\218\255\191\197\ -\186\255\220\223\218\255\191\197\186\255\211\213\208\255\191\197\186\255\198\200\ -\194\255\191\197\186\255\186\189\181\255\221\222\219\255\153\154\153\237\126\127\ -\127\058\130\000\000\000\000\003\124\125\126\122\183\183\183\251\219\220\217\255\ -\130\181\184\177\255\003\188\191\185\255\181\184\177\255\202\204\198\255\135\181\ -\184\177\255\007\202\204\198\255\181\184\177\255\188\191\184\255\181\184\177\255\ -\219\220\217\255\184\185\184\252\124\125\126\129\130\000\000\000\000\002\126\126\ -\127\200\248\248\248\255\146\255\255\255\255\002\248\248\248\255\125\125\127\208\ -\130\000\000\000\000\004\119\119\121\203\117\117\120\240\118\118\120\240\117\117\ -\120\240\130\117\117\120\241\001\117\117\119\242\130\116\116\119\242\132\116\116\ -\119\243\131\116\116\118\243\006\116\116\118\244\116\116\118\243\115\115\118\244\ -\116\116\118\244\115\115\118\244\118\118\120\210\131\000\000\000\000\020\000\000\ -\000\002\000\000\000\009\000\000\000\017\000\000\000\022\000\000\000\028\000\000\ -\000\034\000\000\000\040\000\000\000\047\000\000\000\053\000\000\000\059\000\000\ -\000\060\000\000\000\056\000\000\000\051\000\000\000\045\000\000\000\038\000\000\ -\000\032\000\000\000\026\000\000\000\021\000\000\000\012\000\000\000\003\154\000\ -\000\000\000" - -let pixbuf () : GdkPixbuf.pixbuf = Marshal.from_string pixbuf_data 0 -;; -icon_24x24_devices_computer_png := Some (pixbuf ()) ;; - -let pixbuf_data = "\ -\132\149\166\190\000\000\002\203\000\000\000\001\000\000\000\003\000\000\000\003\ -\018\071\100\107\080\105\120\098\117\102\047\050\046\048\047\000\000\000\002\183\ -\071\100\107\080\000\000\002\183\002\001\000\002\000\000\000\064\000\000\000\016\ -\000\000\000\016\003\000\000\000\000\129\129\132\172\128\128\131\253\138\128\128\ -\131\255\002\128\128\131\253\129\129\132\172\130\000\000\000\000\002\128\128\131\ -\253\242\242\242\255\138\255\255\255\255\002\242\242\242\255\128\128\131\253\130\ -\000\000\000\000\002\128\128\131\255\255\255\255\255\138\032\074\135\255\002\255\ -\255\255\255\128\128\131\255\130\000\000\000\000\004\128\128\131\255\255\255\255\ -\255\032\074\135\255\112\146\191\255\130\113\147\191\255\003\113\148\191\255\113\ -\148\192\255\113\148\191\255\130\113\147\191\255\003\032\074\135\255\255\255\255\ -\255\128\128\131\255\130\000\000\000\000\014\128\128\131\255\255\255\255\255\032\ -\074\135\255\106\143\189\255\111\147\191\255\115\151\194\255\119\154\196\255\122\ -\155\197\255\121\155\197\255\117\152\195\255\106\143\189\255\032\074\135\255\255\ -\255\255\255\128\128\131\255\130\000\000\000\000\014\128\128\131\255\255\255\255\ -\255\032\074\135\255\105\142\189\255\111\148\193\255\116\153\197\255\120\155\198\ -\255\106\145\193\255\084\129\183\255\073\121\179\255\069\117\176\255\032\074\135\ -\255\255\255\255\255\128\128\131\255\130\000\000\000\000\014\128\128\131\255\255\ -\255\255\255\032\074\135\255\101\141\190\255\103\144\192\255\103\145\193\255\091\ -\137\189\255\089\135\189\255\087\134\188\255\084\131\186\255\078\126\182\255\032\ -\074\135\255\255\255\255\255\128\128\131\255\130\000\000\000\000\014\128\128\131\ -\255\255\255\255\255\032\074\135\255\078\125\182\255\086\132\187\255\092\139\192\ -\255\098\144\196\255\100\146\197\255\098\144\196\255\092\139\192\255\086\132\187\ -\255\032\074\135\255\255\255\255\255\128\128\131\255\130\000\000\000\000\002\128\ -\128\131\255\255\255\255\255\138\032\074\135\255\002\255\255\255\255\128\128\131\ -\255\130\000\000\000\000\002\128\128\131\253\241\241\241\255\138\255\255\255\255\ -\002\241\241\241\255\128\128\131\253\130\000\000\000\000\002\129\129\132\172\128\ -\128\131\253\138\128\128\131\255\002\128\128\131\253\129\129\132\172\134\000\000\ -\000\000\002\134\136\131\255\201\206\196\255\130\165\174\157\255\002\201\206\196\ -\255\134\136\131\255\133\000\000\000\000\034\136\138\133\004\136\138\133\116\169\ -\172\166\255\205\208\201\255\186\189\182\255\205\208\201\255\186\189\182\255\205\ -\208\201\255\186\189\182\255\205\208\201\255\186\189\182\255\205\208\201\255\186\ -\189\182\255\155\158\152\255\136\138\133\119\136\138\133\009\136\138\133\105\136\ -\138\133\255\196\198\192\255\186\189\182\255\204\207\200\255\186\189\182\255\192\ -\195\189\255\186\189\182\255\190\193\186\255\186\189\182\255\193\196\189\255\186\ -\189\182\255\206\209\202\255\196\198\192\255\136\138\133\255\136\138\133\115\136\ -\138\133\255\213\213\211\255\140\255\255\255\255\003\213\213\211\255\136\138\133\ -\255\142\143\139\214\142\136\138\133\255\001\142\143\139\214" - -let pixbuf () : GdkPixbuf.pixbuf = Marshal.from_string pixbuf_data 0 -;; -icon_16x16_devices_computer_png := Some (pixbuf ()) ;; diff --git a/virt-ctrl/vc_mainwindow.ml b/virt-ctrl/vc_mainwindow.ml deleted file mode 100644 index c34a803..0000000 --- a/virt-ctrl/vc_mainwindow.ml +++ /dev/null @@ -1,202 +0,0 @@ -(* virt-ctrl: A graphical management tool. - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - 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. -*) - -open Printf -open Virt_ctrl_gettext.Gettext - -let title = s_ "Virtual Control" - -let utf8_copyright = "\194\169" - -let help_about () = - let gtk_version = - let gtk_major, gtk_minor, gtk_micro = GMain.Main.version in - sprintf "%d.%d.%d" gtk_major gtk_minor gtk_micro in - let virt_version = string_of_int (fst (Libvirt.get_version ())) in - let title = "About " ^ title in - let icon = GMisc.image () in - icon#set_stock `DIALOG_INFO; - icon#set_icon_size `DIALOG; - GToolbox.message_box - ~title - ~icon - (sprintf (f_ "Virtualization control tool (virt-ctrl) by -Richard W.M. Jones (rjones@redhat.com). - -Copyright %s 2007-2008 Red Hat Inc. - -Libvirt version: %s - -Gtk toolkit version: %s") utf8_copyright virt_version gtk_version) - -(* Catch any exception and throw up a dialog. *) -let () = - (* A nicer exception printing function. *) - let string_of_exn = function - | Libvirt.Virterror err -> - s_ "Virtualisation error" ^ ": " ^ (Libvirt.Virterror.to_string err) - | Failure msg -> msg - | exn -> Printexc.to_string exn - in - GtkSignal.user_handler := - fun exn -> - let label = string_of_exn exn in - prerr_endline label; - let title = s_ "Error" in - let icon = GMisc.image () in - icon#set_stock `DIALOG_ERROR; - icon#set_icon_size `DIALOG; - GToolbox.message_box ~title ~icon label - -let make - ~start_domain ~pause_domain ~resume_domain ~shutdown_domain - ~open_domain_details = - (* Create the main window. *) - let window = GWindow.window ~width:800 ~height:600 ~title () in - let vbox = GPack.vbox ~packing:window#add () in - - (* Menu bar. *) - let quit_item = - 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 = factory#add_submenu (s_ "File") in - let help_menu = factory#add_submenu (s_ "Help") in - - window#add_accel_group accel_group; - - (* File menu. *) - let factory = new GMenu.factory file_menu ~accel_group in - let open_item = factory#add_item (s_ "Open connection ...") - ~key:GdkKeysyms._O in - ignore (factory#add_separator ()); - let quit_item = factory#add_item (s_ "Quit") ~key:GdkKeysyms._Q in - - ignore (open_item#connect#activate - ~callback:(Vc_connection_dlg.open_connection window)); - - (* Help menu. *) - let factory = new GMenu.factory help_menu ~accel_group in - let help_item = factory#add_item (s_ "Help") in - let help_about_item = factory#add_item (s_ "About ...") in - - ignore (help_about_item#connect#activate ~callback:help_about); - - quit_item in - - (* The toolbar. *) - let toolbar = GButton.toolbar ~packing:vbox#pack () in - - (* The treeview. *) - let (tree, model, columns, initial_state) = - Vc_connections.make_treeview - ~packing:(vbox#pack ~expand:true ~fill:true) () in - - (* Add buttons to the toolbar (requires the treeview to - * have been made above). - *) - let () = - let connect_button_menu = GMenu.menu () in - let connect_button = - GButton.menu_tool_button - ~label:(s_ "Connect ...") ~stock:`CONNECT - ~menu:connect_button_menu - ~packing:toolbar#insert () in - ignore (GButton.separator_tool_item ~packing:toolbar#insert ()); - let open_button = - GButton.tool_button ~label:(s_ "Details") ~stock:`OPEN - ~packing:toolbar#insert () in - ignore (GButton.separator_tool_item ~packing:toolbar#insert ()); - let start_button = - GButton.tool_button ~label:(s_ "Start") ~stock:`ADD - ~packing:toolbar#insert () in - let pause_button = - GButton.tool_button ~label:(s_ "Pause") ~stock:`MEDIA_PAUSE - ~packing:toolbar#insert () in - let resume_button = - GButton.tool_button ~label:(s_ "Resume") ~stock:`MEDIA_PLAY - ~packing:toolbar#insert () in - ignore (GButton.separator_tool_item ~packing:toolbar#insert ()); - let shutdown_button = - GButton.tool_button ~label:(s_ "Shutdown") ~stock:`STOP - ~packing:toolbar#insert () in - - (* Set callbacks for the toolbar buttons. *) - ignore (connect_button#connect#clicked - ~callback:(Vc_connection_dlg.open_connection window)); - ignore (open_button#connect#clicked - ~callback:(open_domain_details tree model columns)); - ignore (start_button#connect#clicked - ~callback:(start_domain tree model columns)); - ignore (pause_button#connect#clicked - ~callback:(pause_domain tree model columns)); - ignore (resume_button#connect#clicked - ~callback:(resume_domain tree model columns)); - ignore (shutdown_button#connect#clicked - ~callback:(shutdown_domain tree model columns)); - - (* Set a menu on the connect menu-button. *) - let () = - let factory = new GMenu.factory connect_button_menu (*~accel_group*) in - let local_xen = factory#add_item (s_ "Local Xen") in - let local_qemu = factory#add_item (s_ "Local QEMU/KVM") in - ignore (factory#add_separator ()); - let open_dialog = factory#add_item (s_ "Connect to ...") in - ignore (local_xen#connect#activate - ~callback:Vc_connection_dlg.open_local_xen); - ignore (local_qemu#connect#activate - ~callback:Vc_connection_dlg.open_local_qemu); - ignore (open_dialog#connect#activate - ~callback:(Vc_connection_dlg.open_connection window)) in - () in - - (* Make a timeout function which is called once per second. *) - let state = ref initial_state in - let callback () = - (* Gc.compact is generally not safe in lablgtk programs, but - * is explicitly allowed in timeouts (see lablgtk README). - * This ensures memory is compacted regularly, but is also an - * excellent way to catch memory bugs in the ocaml libvirt bindings. - *) - Gc.compact (); - - (* Ugh: Bug in lablgtk causes a segfault if a timeout raises an - * exception. Catch and print exceptions instead. - *) - (try state := Vc_connections.repopulate tree model columns !state - with exn -> prerr_endline (Printexc.to_string exn)); - - true - in - let timeout_id = GMain.Timeout.add ~ms:1000 ~callback in - - (* Quit. *) - let quit _ = - GMain.Timeout.remove timeout_id; - GMain.quit (); - false - in - - ignore (window#connect#destroy ~callback:GMain.quit); - ignore (window#event#connect#delete ~callback:quit); - ignore (quit_item#connect#activate - ~callback:(fun () -> ignore (quit ()); ())); - - (* Display the window. *) - window#show () diff --git a/virt-ctrl/vc_mainwindow.mli b/virt-ctrl/vc_mainwindow.mli deleted file mode 100644 index 39439e9..0000000 --- a/virt-ctrl/vc_mainwindow.mli +++ /dev/null @@ -1,31 +0,0 @@ -(* virt-ctrl: A graphical management tool. - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - 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. - - Make the main window. -*) - -(** This function creates the main window. You have to pass in - callback functions to wire everything up. -*) -val make : - start_domain:Vc_domain_ops.dops_callback_fn -> - pause_domain:Vc_domain_ops.dops_callback_fn -> - resume_domain:Vc_domain_ops.dops_callback_fn -> - shutdown_domain:Vc_domain_ops.dops_callback_fn -> - open_domain_details:Vc_domain_ops.dops_callback_fn -> - unit diff --git a/virt-ctrl/virt_ctrl.ml b/virt-ctrl/virt_ctrl.ml deleted file mode 100644 index 9e5053e..0000000 --- a/virt-ctrl/virt_ctrl.ml +++ /dev/null @@ -1,36 +0,0 @@ -(* virt-ctrl: A graphical management tool. - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - 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. -*) - -open Printf -open Virt_ctrl_gettext.Gettext - -let () = - (* Build the main window and wire up the buttons to the callback functions *) - Vc_mainwindow.make - ~start_domain:Vc_domain_ops.start_domain - ~pause_domain:Vc_domain_ops.pause_domain - ~resume_domain:Vc_domain_ops.resume_domain - ~shutdown_domain:Vc_domain_ops.shutdown_domain - ~open_domain_details:Vc_domain_ops.open_domain_details; - - (* Enter the Gtk main loop. *) - GMain.main (); - - (* Useful to catch memory bugs in the ocaml libvirt bindings. *) - Gc.compact () diff --git a/virt-df/Makefile.in b/virt-df/Makefile.in deleted file mode 100644 index 4fb088c..0000000 --- a/virt-df/Makefile.in +++ /dev/null @@ -1,109 +0,0 @@ -# virt-df -# Copyright (C) 2007 Red Hat Inc., Richard W.M. Jones -# -# 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. - -PACKAGE := @PACKAGE_NAME@ -VERSION := @PACKAGE_VERSION@ - -INSTALL := @INSTALL@ -HAVE_PERLDOC := @HAVE_PERLDOC@ - -prefix = @prefix@ -exec_prefix = @exec_prefix@ -bindir = @bindir@ - -pkg_gettext = @pkg_gettext@ - -#OCAMLCPACKAGES := -package unix,extlib,xml-light,bitmatch -OCAMLCPACKAGES := -package unix,extlib,xml-light -I +bitmatch - -ifneq ($(pkg_gettext),no) -OCAMLCPACKAGES += -package gettext-stub -endif - -OBJS := \ - virt_df_gettext.cmo \ - virt_df.cmo \ - virt_df_ext2.cmo \ - virt_df_linux_swap.cmo \ - virt_df_lvm2_metadata.cmo \ - virt_df_lvm2_parser.cmo \ - virt_df_lvm2_lexer.cmo \ - virt_df_lvm2.cmo \ - virt_df_mbr.cmo \ - virt_df_main.cmo - -XOBJS := $(OBJS:.cmo=.cmx) - -SYNTAX := -pp "camlp4o -I`ocamlc -where`/bitmatch pa_bitmatch.cmo" - -OCAMLCPACKAGES += -I ../libvirt -OCAMLCFLAGS := -g -w s $(SYNTAX) -#OCAMLCLIBS := -linkpkg -OCAMLCLIBS := -linkpkg bitmatch.cma - -OCAMLOPTPACKAGES := $(OCAMLCPACKAGES) -OCAMLOPTFLAGS := -w s $(SYNTAX) -#OCAMLOPTLIBS := $(OCAMLCLIBS) -OCAMLOPTLIBS := -linkpkg bitmatch.cmxa - -OCAMLDEPFLAGS := $(SYNTAX) - -export LIBRARY_PATH=../libvirt -export LD_LIBRARY_PATH=../libvirt - -BYTE_TARGETS := virt-df -OPT_TARGETS := virt-df.opt - -ifeq ($(HAVE_PERLDOC),perldoc) -BYTE_TARGETS += virt-df.1 virt-df.txt -endif - -all: $(BYTE_TARGETS) - -opt: $(OPT_TARGETS) - -virt-df: $(OBJS) - ocamlfind ocamlc $(OCAMLCPACKAGES) $(OCAMLCFLAGS) $(OCAMLCLIBS) \ - ../libvirt/mllibvirt.cma -o $@ $^ - -virt-df.opt: $(XOBJS) - ocamlfind ocamlopt \ - $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \ - ../libvirt/mllibvirt.cmxa -o $@ $^ - -# 'make depend' doesn't catch these dependencies because the .mli file -# is auto-generated. -virt_df_lvm2_parser.cmo: virt_df_lvm2_parser.mli -virt_df_lvm2_parser.cmx: virt_df_lvm2_parser.mli - -# Manual page. -ifeq ($(HAVE_PERLDOC),perldoc) -virt-df.1: virt-df.pod - pod2man -c "Virtualization Support" --release "$(PACKAGE)-$(VERSION)" \ - $< > $@ - -virt-df.txt: virt-df.pod - pod2text $< > $@ -endif - -install: - if [ -x virt-df.opt ]; then \ - mkdir -p $(DESTDIR)$(bindir); \ - $(INSTALL) -m 0755 virt-df.opt $(DESTDIR)$(bindir)/virt-df; \ - fi - -include ../Make.rules diff --git a/virt-df/README b/virt-df/README deleted file mode 100644 index 65acef9..0000000 --- a/virt-df/README +++ /dev/null @@ -1,68 +0,0 @@ -$Id$ - -For user documentation: - -Please see the manual page (virt-df.pod or virt-df.txt in this -directory). - -Developer documentation ----------------------------------------------------------------------- - -This program has suddenly become rather large and confusing. -Hopefully this documentation should go some way towards explaining -what is going on inside the source. - -The main program consists of two modules: - - - virt_df.ml / virt_df.mli (module name: Virt_df) - - This has evolved into a library of miscellaneous functions - and values which are included throughout the rest of the - program. If you see an unexplained function then it's - likely that it is defined in here. - - Start by reading virt_df.mli which contains the full types - and plenty of documentation. - - - virt_df_main.ml - - This is the program. It reads the command line arguments, - loads the domain descriptions, calls out to the plug-ins - to probe for disks / partitions / filesystems / etc., and - finally prints the results. - - The file consists of basically one large program that - does all of the above in sequence. - -Everything else in this directory is a plug-in specialized for probing -a particular filesystem, partition scheme or type of LVM. The -plug-ins at time of writing are: - - - virt_df_ext2.ml / virt_df_ext2.mli - - EXT2/3/4 plug-in. - - - virt_df_linux_swap.ml / virt_df_linux_swap.mli - - Linux swap (new style) plug-in. - - - virt_df_mbr.ml / virt_df_mbr.mli - - Master Boot Record (MS-DOS) disk partitioning plug-in. - - - virt_df_lvm2* - - LVM2 parsing, which is by far the most complex plug-in. - It consists of: - - - virt_df_lvm2.ml - - virt_df_lvm2.mli - LVM2 probing, PV detection. - - - virt_df_lvm2_parser.mly - - virt_df_lvm2_lexer.mll - Scanner/parser for parsing LVM2 metadata definitions. - - - virt_df_lvm2_metadata.ml - - virt_df_lvm2_metadata.mli - AST for LVM2 metadata definitions. diff --git a/virt-df/virt-df.1 b/virt-df/virt-df.1 deleted file mode 100644 index 93c4ad7..0000000 --- a/virt-df/virt-df.1 +++ /dev/null @@ -1,285 +0,0 @@ -.\" Automatically generated by Pod::Man v1.37, Pod::Parser v1.32 -.\" -.\" Standard preamble: -.\" ======================================================================== -.de Sh \" Subsection heading -.br -.if t .Sp -.ne 5 -.PP -\fB\\$1\fR -.PP -.. -.de Sp \" Vertical space (when we can't use .PP) -.if t .sp .5v -.if n .sp -.. -.de Vb \" Begin verbatim text -.ft CW -.nf -.ne \\$1 -.. -.de Ve \" End verbatim text -.ft R -.fi -.. -.\" Set up some character translations and predefined strings. \*(-- will -.\" give an unbreakable dash, \*(PI will give pi, \*(L" will give a left -.\" double quote, and \*(R" will give a right double quote. | will give a -.\" real vertical bar. \*(C+ will give a nicer C++. Capital omega is used to -.\" do unbreakable dashes and therefore won't be available. \*(C` and \*(C' -.\" expand to `' in nroff, nothing in troff, for use with C<>. -.tr \(*W-|\(bv\*(Tr -.ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p' -.ie n \{\ -. ds -- \(*W- -. ds PI pi -. if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch -. if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch -. ds L" "" -. ds R" "" -. ds C` "" -. ds C' "" -'br\} -.el\{\ -. ds -- \|\(em\| -. ds PI \(*p -. ds L" `` -. ds R" '' -'br\} -.\" -.\" If the F register is turned on, we'll generate index entries on stderr for -.\" titles (.TH), headers (.SH), subsections (.Sh), items (.Ip), and index -.\" entries marked with X<> in POD. Of course, you'll have to process the -.\" output yourself in some meaningful fashion. -.if \nF \{\ -. de IX -. tm Index:\\$1\t\\n%\t"\\$2" -.. -. nr % 0 -. rr F -.\} -.\" -.\" For nroff, turn off justification. Always turn off hyphenation; it makes -.\" way too many mistakes in technical documents. -.hy 0 -.if n .na -.\" -.\" Accent mark definitions (@(#)ms.acc 1.5 88/02/08 SMI; from UCB 4.2). -.\" Fear. Run. Save yourself. No user-serviceable parts. -. \" fudge factors for nroff and troff -.if n \{\ -. ds #H 0 -. ds #V .8m -. ds #F .3m -. ds #[ \f1 -. ds #] \fP -.\} -.if t \{\ -. ds #H ((1u-(\\\\n(.fu%2u))*.13m) -. ds #V .6m -. ds #F 0 -. ds #[ \& -. ds #] \& -.\} -. \" simple accents for nroff and troff -.if n \{\ -. ds ' \& -. ds ` \& -. ds ^ \& -. ds , \& -. ds ~ ~ -. ds / -.\} -.if t \{\ -. ds ' \\k:\h'-(\\n(.wu*8/10-\*(#H)'\'\h"|\\n:u" -. ds ` \\k:\h'-(\\n(.wu*8/10-\*(#H)'\`\h'|\\n:u' -. ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'^\h'|\\n:u' -. ds , \\k:\h'-(\\n(.wu*8/10)',\h'|\\n:u' -. ds ~ \\k:\h'-(\\n(.wu-\*(#H-.1m)'~\h'|\\n:u' -. ds / \\k:\h'-(\\n(.wu*8/10-\*(#H)'\z\(sl\h'|\\n:u' -.\} -. \" troff and (daisy-wheel) nroff accents -.ds : \\k:\h'-(\\n(.wu*8/10-\*(#H+.1m+\*(#F)'\v'-\*(#V'\z.\h'.2m+\*(#F'.\h'|\\n:u'\v'\*(#V' -.ds 8 \h'\*(#H'\(*b\h'-\*(#H' -.ds o \\k:\h'-(\\n(.wu+\w'\(de'u-\*(#H)/2u'\v'-.3n'\*(#[\z\(de\v'.3n'\h'|\\n:u'\*(#] -.ds d- \h'\*(#H'\(pd\h'-\w'~'u'\v'-.25m'\f2\(hy\fP\v'.25m'\h'-\*(#H' -.ds D- D\\k:\h'-\w'D'u'\v'-.11m'\z\(hy\v'.11m'\h'|\\n:u' -.ds th \*(#[\v'.3m'\s+1I\s-1\v'-.3m'\h'-(\w'I'u*2/3)'\s-1o\s+1\*(#] -.ds Th \*(#[\s+2I\s-2\h'-\w'I'u*3/5'\v'-.3m'o\v'.3m'\*(#] -.ds ae a\h'-(\w'a'u*4/10)'e -.ds Ae A\h'-(\w'A'u*4/10)'E -. \" corrections for vroff -.if v .ds ~ \\k:\h'-(\\n(.wu*9/10-\*(#H)'\s-2\u~\d\s+2\h'|\\n:u' -.if v .ds ^ \\k:\h'-(\\n(.wu*10/11-\*(#H)'\v'-.4m'^\v'.4m'\h'|\\n:u' -. \" for low resolution devices (crt and lpr) -.if \n(.H>23 .if \n(.V>19 \ -\{\ -. ds : e -. ds 8 ss -. ds o a -. ds d- d\h'-1'\(ga -. ds D- D\h'-1'\(hy -. ds th \o'bp' -. ds Th \o'LP' -. ds ae ae -. ds Ae AE -.\} -.rm #[ #] #H #V #F C -.\" ======================================================================== -.\" -.IX Title "VIRT-DF 1" -.TH VIRT-DF 1 "2008-04-16" "ocaml-libvirt-0.4.1.1" "Virtualization Support" -.SH "NAME" -virt\-df \- 'df'\-like utility for virtualization stats -.SH "SUMMARY" -.IX Header "SUMMARY" -virt-df [\-options] -.SH "DESCRIPTION" -.IX Header "DESCRIPTION" -virt-df is a \fIdf\fR\|(1)\-like utility for showing the actual disk usage -of guests. Many command line options are the same as for ordinary -\&\fIdf\fR. -.PP -It uses libvirt so it is capable of showing stats across a variety of -different virtualization systems. -.PP -There are some shortcomings to the whole approach of reading disk -state from outside the guest. Please read \s-1SHORTCOMINGS\s0 section below -for more details. -.SH "OPTIONS" -.IX Header "OPTIONS" -.IP "\fB\-a\fR, \fB\-\-all\fR" 4 -.IX Item "-a, --all" -Show all domains. The default is show only running (active) domains. -.IP "\fB\-c uri\fR, \fB\-\-connect uri\fR" 4 -.IX Item "-c uri, --connect uri" -Connect to libvirt \s-1URI\s0. The default is to connect to the default -libvirt \s-1URI\s0, normally Xen. -.IP "\fB\-\-debug\fR" 4 -.IX Item "--debug" -Emit debugging information on stderr. Please supply this if you -report a bug. -.IP "\fB\-h\fR, \fB\-\-human\-readable\fR" 4 -.IX Item "-h, --human-readable" -Display human-readable sizes (eg. 10GiB). -.IP "\fB\-i\fR, \fB\-\-inodes\fR" 4 -.IX Item "-i, --inodes" -Display inode information. -.IP "\fB\-\-help\fR" 4 -.IX Item "--help" -Display usage summary. -.IP "\fB\-t diskimage\fR" 4 -.IX Item "-t diskimage" -Test mode. Instead of checking libvirt for domain information, this -runs virt-df directly on the disk image (or device) supplied. You may -specify the \fB\-t\fR option multiple times. -.IP "\fB\-\-version\fR" 4 -.IX Item "--version" -Display version and exit. -.SH "SHORTCOMINGS" -.IX Header "SHORTCOMINGS" -virt-df spies on the guest's disk image to try to work out how much -disk space it is actually using. There are some shortcomings to this, -described here. -.PP -(1) It does not work over remote connections. The storage \s-1API\s0 does -not support peeking into remote disks, and libvirt has rejected a -request to add this support. -.PP -(2) It only understands a limited set of partition types. Assuming -that the files and partitions that we get back from libvirt / Xen -correspond to block devices in the guests, we can go some way towards -manually parsing those partitions to find out what they contain. We -can read the \s-1MBR\s0, \s-1LVM\s0, superblocks and so on. However that's a lot of -parsing work, and currently there is no library which understands a -wide range of partition schemes and filesystem types (not even -libparted which doesn't support \s-1LVM\s0 yet). The Linux kernel does -support that, but there's not really any good way to access that work. -.PP -The current implementation uses a hand-coded parser which understands -some simple formats (\s-1MBR\s0, \s-1LVM2\s0, ext2/3). In future we should use -something like libparted. -.PP -(3) The statistics you get are delayed. The real state of, for -example, an ext2 filesystem is only stored in the memory of the -guest's kernel. The ext2 superblock contains some meta-information -about blocks used and free, but this superblock is not up to date. In -fact the guest kernel may not update it even on a 'sync', not until -the filesystem is unmounted. Some operations do appear to write the -superblock, for example \fIfsync\fR\|(2) [that is my reading of the ext2/3 -source code at least]. -.SH "SECURITY" -.IX Header "SECURITY" -The current code tries hard to be secure against malicious guests, for -example guests which set up malicious disk partitions. -.SH "SEE ALSO" -.IX Header "SEE ALSO" -\&\fIdf\fR\|(1), -\&\fIvirsh\fR\|(1), -\&\fIxm\fR\|(1), -<http://www.libvirt.org/ocaml/>, -<http://www.libvirt.org/>, -<http://et.redhat.com/~rjones/>, -<http://caml.inria.fr/> -.SH "AUTHORS" -.IX Header "AUTHORS" -Richard W.M. Jones <rjones @ redhat . com> -.SH "COPYRIGHT" -.IX Header "COPYRIGHT" -(C) Copyright 2007\-2008 Red Hat Inc., Richard W.M. Jones -http://libvirt.org/ -.PP -This program is free software; you can redistribute it and/or modify -it under the terms of the \s-1GNU\s0 General Public License as published by -the Free Software Foundation; either version 2 of the License, or -(at your option) any later version. -.PP -This program is distributed in the hope that it will be useful, -but \s-1WITHOUT\s0 \s-1ANY\s0 \s-1WARRANTY\s0; without even the implied warranty of -\&\s-1MERCHANTABILITY\s0 or \s-1FITNESS\s0 \s-1FOR\s0 A \s-1PARTICULAR\s0 \s-1PURPOSE\s0. See the -\&\s-1GNU\s0 General Public License for more details. -.PP -You should have received a copy of the \s-1GNU\s0 General Public License -along with this program; if not, write to the Free Software -Foundation, Inc., 675 Mass Ave, Cambridge, \s-1MA\s0 02139, \s-1USA\s0. -.SH "REPORTING BUGS" -.IX Header "REPORTING BUGS" -Bugs can be viewed on the Red Hat Bugzilla page: -<https://bugzilla.redhat.com/>. -.PP -If you find a bug in virt\-df, please follow these steps to report it: -.IP "1. Check for existing bug reports" 4 -.IX Item "1. Check for existing bug reports" -Go to <https://bugzilla.redhat.com/> and search for similar bugs. -Someone may already have reported the same bug, and they may even -have fixed it. -.IP "2. Capture debug and error messages" 4 -.IX Item "2. Capture debug and error messages" -Run -.Sp -.Vb 1 -\& virt-df --debug > virt-df.log 2>&1 -.Ve -.Sp -and keep \fIvirt\-df.log\fR. It contains error messages which you should -submit with your bug report. -.IP "3. Get version of virt-df and version of libvirt." 4 -.IX Item "3. Get version of virt-df and version of libvirt." -Run -.Sp -.Vb 1 -\& virt-df --version -.Ve -.IP "4. Submit a bug report." 4 -.IX Item "4. Submit a bug report." -Go to <https://bugzilla.redhat.com/> and enter a new bug. -Please describe the problem in as much detail as possible. -.Sp -Remember to include the version numbers (step 3) and the debug -messages file (step 2). -.IP "5. Assign the bug to rjones @ redhat.com" 4 -.IX Item "5. Assign the bug to rjones @ redhat.com" -Assign or reassign the bug to \fBrjones @ redhat.com\fR (without the -spaces). You can also send me an email with the bug number if you -want a faster response. diff --git a/virt-df/virt-df.pod b/virt-df/virt-df.pod deleted file mode 100644 index ffde02b..0000000 --- a/virt-df/virt-df.pod +++ /dev/null @@ -1,181 +0,0 @@ -=head1 NAME - -virt-df - 'df'-like utility for virtualization stats - -=head1 SUMMARY - -virt-df [-options] - -=head1 DESCRIPTION - -virt-df is a L<df(1)>-like utility for showing the actual disk usage -of guests. Many command line options are the same as for ordinary -I<df>. - -It uses libvirt so it is capable of showing stats across a variety of -different virtualization systems. - -There are some shortcomings to the whole approach of reading disk -state from outside the guest. Please read SHORTCOMINGS section below -for more details. - -=head1 OPTIONS - -=over 4 - -=item B<-a>, B<--all> - -Show all domains. The default is show only running (active) domains. - -=item B<-c uri>, B<--connect uri> - -Connect to libvirt URI. The default is to connect to the default -libvirt URI, normally Xen. - -=item B<--debug> - -Emit debugging information on stderr. Please supply this if you -report a bug. - -=item B<-h>, B<--human-readable> - -Display human-readable sizes (eg. 10GiB). - -=item B<-i>, B<--inodes> - -Display inode information. - -=item B<--help> - -Display usage summary. - -=item B<-t diskimage> - -Test mode. Instead of checking libvirt for domain information, this -runs virt-df directly on the disk image (or device) supplied. You may -specify the B<-t> option multiple times. - -=item B<--version> - -Display version and exit. - -=back - -=head1 SHORTCOMINGS - -virt-df spies on the guest's disk image to try to work out how much -disk space it is actually using. There are some shortcomings to this, -described here. - -(1) It does not work over remote connections. The storage API does -not support peeking into remote disks, and libvirt has rejected a -request to add this support. - -(2) It only understands a limited set of partition types. Assuming -that the files and partitions that we get back from libvirt / Xen -correspond to block devices in the guests, we can go some way towards -manually parsing those partitions to find out what they contain. We -can read the MBR, LVM, superblocks and so on. However that's a lot of -parsing work, and currently there is no library which understands a -wide range of partition schemes and filesystem types (not even -libparted which doesn't support LVM yet). The Linux kernel does -support that, but there's not really any good way to access that work. - -The current implementation uses a hand-coded parser which understands -some simple formats (MBR, LVM2, ext2/3). In future we should use -something like libparted. - -(3) The statistics you get are delayed. The real state of, for -example, an ext2 filesystem is only stored in the memory of the -guest's kernel. The ext2 superblock contains some meta-information -about blocks used and free, but this superblock is not up to date. In -fact the guest kernel may not update it even on a 'sync', not until -the filesystem is unmounted. Some operations do appear to write the -superblock, for example L<fsync(2)> [that is my reading of the ext2/3 -source code at least]. - -=head1 SECURITY - -The current code tries hard to be secure against malicious guests, for -example guests which set up malicious disk partitions. - -=head1 SEE ALSO - -L<df(1)>, -L<virsh(1)>, -L<xm(1)>, -L<http://www.libvirt.org/ocaml/>, -L<http://www.libvirt.org/>, -L<http://et.redhat.com/~rjones/>, -L<http://caml.inria.fr/> - -=head1 AUTHORS - -Richard W.M. Jones <rjones @ redhat . com> - -=head1 COPYRIGHT - -(C) Copyright 2007-2008 Red Hat Inc., Richard W.M. Jones -http://libvirt.org/ - -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. - -=head1 REPORTING BUGS - -Bugs can be viewed on the Red Hat Bugzilla page: -L<https://bugzilla.redhat.com/>. - -If you find a bug in virt-df, please follow these steps to report it: - -=over 4 - -=item 1. Check for existing bug reports - -Go to L<https://bugzilla.redhat.com/> and search for similar bugs. -Someone may already have reported the same bug, and they may even -have fixed it. - -=item 2. Capture debug and error messages - -Run - - virt-df --debug > virt-df.log 2>&1 - -and keep I<virt-df.log>. It contains error messages which you should -submit with your bug report. - -=item 3. Get version of virt-df and version of libvirt. - -Run - - virt-df --version - -=item 4. Submit a bug report. - -Go to L<https://bugzilla.redhat.com/> and enter a new bug. -Please describe the problem in as much detail as possible. - -Remember to include the version numbers (step 3) and the debug -messages file (step 2). - -=item 5. Assign the bug to rjones @ redhat.com - -Assign or reassign the bug to B<rjones @ redhat.com> (without the -spaces). You can also send me an email with the bug number if you -want a faster response. - -=back - -=end diff --git a/virt-df/virt-df.txt b/virt-df/virt-df.txt deleted file mode 100644 index aa02a8f..0000000 --- a/virt-df/virt-df.txt +++ /dev/null @@ -1,144 +0,0 @@ -NAME - virt-df - 'df'-like utility for virtualization stats - -SUMMARY - virt-df [-options] - -DESCRIPTION - virt-df is a df(1)-like utility for showing the actual disk usage of - guests. Many command line options are the same as for ordinary *df*. - - It uses libvirt so it is capable of showing stats across a variety of - different virtualization systems. - - There are some shortcomings to the whole approach of reading disk state - from outside the guest. Please read SHORTCOMINGS section below for more - details. - -OPTIONS - -a, --all - Show all domains. The default is show only running (active) domains. - - -c uri, --connect uri - Connect to libvirt URI. The default is to connect to the default - libvirt URI, normally Xen. - - --debug - Emit debugging information on stderr. Please supply this if you - report a bug. - - -h, --human-readable - Display human-readable sizes (eg. 10GiB). - - -i, --inodes - Display inode information. - - --help - Display usage summary. - - -t diskimage - Test mode. Instead of checking libvirt for domain information, this - runs virt-df directly on the disk image (or device) supplied. You - may specify the -t option multiple times. - - --version - Display version and exit. - -SHORTCOMINGS - virt-df spies on the guest's disk image to try to work out how much disk - space it is actually using. There are some shortcomings to this, - described here. - - (1) It does not work over remote connections. The storage API does not - support peeking into remote disks, and libvirt has rejected a request to - add this support. - - (2) It only understands a limited set of partition types. Assuming that - the files and partitions that we get back from libvirt / Xen correspond - to block devices in the guests, we can go some way towards manually - parsing those partitions to find out what they contain. We can read the - MBR, LVM, superblocks and so on. However that's a lot of parsing work, - and currently there is no library which understands a wide range of - partition schemes and filesystem types (not even libparted which doesn't - support LVM yet). The Linux kernel does support that, but there's not - really any good way to access that work. - - The current implementation uses a hand-coded parser which understands - some simple formats (MBR, LVM2, ext2/3). In future we should use - something like libparted. - - (3) The statistics you get are delayed. The real state of, for example, - an ext2 filesystem is only stored in the memory of the guest's kernel. - The ext2 superblock contains some meta-information about blocks used and - free, but this superblock is not up to date. In fact the guest kernel - may not update it even on a 'sync', not until the filesystem is - unmounted. Some operations do appear to write the superblock, for - example fsync(2) [that is my reading of the ext2/3 source code at - least]. - -SECURITY - The current code tries hard to be secure against malicious guests, for - example guests which set up malicious disk partitions. - -SEE ALSO - df(1), virsh(1), xm(1), <http://www.libvirt.org/ocaml/>, - <http://www.libvirt.org/>, <http://et.redhat.com/~rjones/>, - <http://caml.inria.fr/> - -AUTHORS - Richard W.M. Jones <rjones @ redhat . com> - -COPYRIGHT - (C) Copyright 2007-2008 Red Hat Inc., Richard W.M. Jones - http://libvirt.org/ - - 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. - -REPORTING BUGS - Bugs can be viewed on the Red Hat Bugzilla page: - <https://bugzilla.redhat.com/>. - - If you find a bug in virt-df, please follow these steps to report it: - - 1. Check for existing bug reports - Go to <https://bugzilla.redhat.com/> and search for similar bugs. - Someone may already have reported the same bug, and they may even - have fixed it. - - 2. Capture debug and error messages - Run - - virt-df --debug > virt-df.log 2>&1 - - and keep *virt-df.log*. It contains error messages which you should - submit with your bug report. - - 3. Get version of virt-df and version of libvirt. - Run - - virt-df --version - - 4. Submit a bug report. - Go to <https://bugzilla.redhat.com/> and enter a new bug. Please - describe the problem in as much detail as possible. - - Remember to include the version numbers (step 3) and the debug - messages file (step 2). - - 5. Assign the bug to rjones @ redhat.com - Assign or reassign the bug to rjones @ redhat.com (without the - spaces). You can also send me an email with the bug number if you - want a faster response. - diff --git a/virt-df/virt_df.ml b/virt-df/virt_df.ml deleted file mode 100644 index c02c8e3..0000000 --- a/virt-df/virt_df.ml +++ /dev/null @@ -1,293 +0,0 @@ -(* 'df' command for virtual domains. - (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - 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. - *) - -open Printf -open ExtList -open Unix - -open Virt_df_gettext.Gettext - -let ( +* ) = Int32.add -let ( -* ) = Int32.sub -let ( ** ) = Int32.mul -let ( /* ) = Int32.div - -let ( +^ ) = Int64.add -let ( -^ ) = Int64.sub -let ( *^ ) = Int64.mul -let ( /^ ) = Int64.div - -let debug = ref false -let uri = ref None -let inodes = ref false -let human = ref false -let all = ref false -let test_files = ref [] - -class virtual device = -object (self) - method virtual read : int64 -> int -> string - method virtual size : int64 - method virtual name : string - - (* Helper method to read a chunk of data into a bitstring. *) - method read_bitstring offset len = - let str = self#read offset len in - (str, 0, len * 8) -end - -(* A concrete device which just direct-maps a file or /dev device. *) -class block_device filename = - let fd = openfile filename [ O_RDONLY ] 0 in - let size = (LargeFile.fstat fd).LargeFile.st_size in -object (self) - inherit device - method read offset len = - ignore (LargeFile.lseek fd offset SEEK_SET); - let str = String.make len '\000' in - read fd str 0 len; - str - method size = size - method name = filename -end - -(* A linear offset/size from an underlying device. *) -class offset_device name start size (dev : device) = -object - inherit device - method name = name - method size = size - method read offset len = - if offset < 0L || len < 0 || offset +^ Int64.of_int len > size then - invalid_arg ( - sprintf "%s: tried to read outside device boundaries (%Ld/%d/%Ld)" - name offset len size - ); - dev#read (start+^offset) len -end - -(* The null device. Any attempt to read generates an error. *) -let null_device : device = -object - inherit device - method read _ _ = assert false - method size = 0L - method name = "null" -end - -type domain = { - dom_name : string; (* Domain name. *) - dom_id : int option; (* Domain ID (if running). *) - dom_disks : disk list; (* Domain disks. *) - dom_lv_filesystems : - (lv * filesystem) list; (* Domain LV filesystems. *) -} -and disk = { - (* From the XML ... *) - d_type : string option; (* The <disk type=...> *) - d_device : string; (* The <disk device=...> (eg "disk") *) - d_source : string; (* The <source file=... or dev> *) - d_target : string; (* The <target dev=...> (eg "hda") *) - - (* About the device itself. *) - d_dev : device; (* Disk device. *) - d_content : disk_content; (* What's on it. *) -} -and disk_content = - [ `Unknown (* Not probed or unknown. *) - | `Partitions of partitions (* Contains partitions. *) - | `Filesystem of filesystem (* Contains a filesystem directly. *) - | `PhysicalVolume of pv (* Contains an LVM PV. *) - ] - -(* Partitions. *) - -and partitions = { - parts_name : string; (* Name of partitioning scheme. *) - parts : partition list (* Partitions. *) -} -and partition = { - part_status : partition_status; (* Bootable, etc. *) - part_type : int; (* Partition filesystem type. *) - part_dev : device; (* Partition device. *) - part_content : partition_content; (* What's on it. *) -} -and partition_status = Bootable | Nonbootable | Malformed | NullEntry -and partition_content = - [ `Unknown (* Not probed or unknown. *) - | `Filesystem of filesystem (* Filesystem. *) - | `PhysicalVolume of pv (* Contains an LVM PV. *) - ] - -(* Filesystems (also swap devices). *) -and filesystem = { - fs_name : string; (* Name of filesystem. *) - fs_block_size : int64; (* Block size (bytes). *) - fs_blocks_total : int64; (* Total blocks. *) - fs_is_swap : bool; (* If swap, following not valid. *) - fs_blocks_reserved : int64; (* Blocks reserved for super-user. *) - fs_blocks_avail : int64; (* Blocks free (available). *) - fs_blocks_used : int64; (* Blocks in use. *) - fs_inodes_total : int64; (* Total inodes. *) - fs_inodes_reserved : int64; (* Inodes reserved for super-user. *) - fs_inodes_avail : int64; (* Inodes free (available). *) - fs_inodes_used : int64; (* Inodes in use. *) -} - -(* Physical volumes. *) -and pv = { - lvm_plugin_id : lvm_plugin_id; (* The LVM plug-in. *) - pv_uuid : string; (* UUID. *) -} - -(* Logical volumes. *) -and lv = { - lv_dev : device; (* Logical volume device. *) -} - -and lvm_plugin_id = string - -(* Convert partition, filesystem types to printable strings for debugging. *) -let string_of_partition - { part_status = status; part_type = typ; part_dev = dev } = - sprintf "%s: %s partition type %d" - dev#name - (match status with - | Bootable -> "bootable" - | Nonbootable -> "nonbootable" - | Malformed -> "malformed" - | NullEntry -> "empty") - typ - -let string_of_filesystem { fs_name = name; fs_is_swap = swap } = - if not swap then name - else name ^ " [swap]" - -(* Convert a UUID (containing '-' chars) to canonical form. *) -let canonical_uuid uuid = - let uuid' = String.make 32 ' ' in - let j = ref 0 in - for i = 0 to String.length uuid - 1 do - if !j >= 32 then - invalid_arg (sprintf (f_ "canonical_uuid: UUID is too long: %s") uuid); - let c = uuid.[i] in - if c <> '-' then ( uuid'.[!j] <- c; incr j ) - done; - if !j <> 32 then - invalid_arg (sprintf (f_ "canonical_uuid: invalid UUID: %s") uuid); - uuid' - -(* Register a partition scheme. *) -let partition_types = ref [] -let partition_type_register (parts_name : string) probe_fn = - partition_types := (parts_name, probe_fn) :: !partition_types - -(* Probe a device for partitions. Returns [Some parts] or [None]. *) -let probe_for_partitions dev = - if !debug then eprintf "probing for partitions on %s ...\n%!" dev#name; - let rec loop = function - | [] -> None - | (parts_name, probe_fn) :: rest -> - try Some (probe_fn dev) - with Not_found -> loop rest - in - let r = loop !partition_types in - if !debug then ( - match r with - | None -> eprintf "no partitions found on %s\n%!" dev#name - | Some { parts_name = name; parts = parts } -> - eprintf "found %d %s partitions on %s:\n" - (List.length parts) name dev#name; - List.iter (fun p -> eprintf "\t%s\n%!" (string_of_partition p)) parts - ); - r - -(* Register a filesystem type (or swap). *) -let filesystem_types = ref [] -let filesystem_type_register (fs_name : string) probe_fn = - filesystem_types := (fs_name, probe_fn) :: !filesystem_types - -(* Probe a device for a filesystem. Returns [Some fs] or [None]. *) -let probe_for_filesystem dev = - if !debug then eprintf "probing for a filesystem on %s ...\n%!" dev#name; - let rec loop = function - | [] -> None - | (fs_name, probe_fn) :: rest -> - try Some (probe_fn dev) - with Not_found -> loop rest - in - let r = loop !filesystem_types in - if !debug then ( - match r with - | None -> eprintf "no filesystem found on %s\n%!" dev#name - | Some fs -> - eprintf "found a filesystem on %s:\n" dev#name; - eprintf "\t%s\n%!" (string_of_filesystem fs) - ); - r - -(* Register a volume management type. *) -let lvm_types = ref [] -let lvm_type_register (lvm_name : string) probe_fn list_lvs_fn = - lvm_types := (lvm_name, (probe_fn, list_lvs_fn)) :: !lvm_types - -(* Probe a device for a PV. Returns [Some lvm_name] or [None]. *) -let probe_for_pv dev = - if !debug then eprintf "probing if %s is a PV ...\n%!" dev#name; - let rec loop = function - | [] -> None - | (lvm_name, (probe_fn, _)) :: rest -> - try Some (probe_fn lvm_name dev) - with Not_found -> loop rest - in - let r = loop !lvm_types in - if !debug then ( - match r with - | None -> eprintf "no PV found on %s\n%!" dev#name - | Some { lvm_plugin_id = name } -> - eprintf "%s contains a %s PV\n%!" dev#name name - ); - r - -let list_lvs lvm_name devs = - let _, list_lvs_fn = List.assoc lvm_name !lvm_types in - list_lvs_fn devs - -(*----------------------------------------------------------------------*) - -(* This version by Isaac Trotts. *) -let group_by ?(cmp = Pervasives.compare) ls = - let ls' = - List.fold_left - (fun acc (day1, x1) -> - match acc with - [] -> [day1, [x1]] - | (day2, ls2) :: acctl -> - if cmp day1 day2 = 0 - then (day1, x1 :: ls2) :: acctl - else (day1, [x1]) :: acc) - [] - ls - in - let ls' = List.rev ls' in - List.map (fun (x, xs) -> x, List.rev xs) ls' - -let rec range a b = - if a < b then a :: range (a+1) b - else [] diff --git a/virt-df/virt_df.mli b/virt-df/virt_df.mli deleted file mode 100644 index f35e0db..0000000 --- a/virt-df/virt_df.mli +++ /dev/null @@ -1,237 +0,0 @@ -(** 'df' command for virtual domains. *) -(* (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - 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. - *) - -(** This module (Virt_df) contains functions and values which are - used throughout the plug-ins and main code. -*) - -val ( +* ) : int32 -> int32 -> int32 -val ( -* ) : int32 -> int32 -> int32 -val ( ** ) : int32 -> int32 -> int32 -val ( /* ) : int32 -> int32 -> int32 -val ( +^ ) : int64 -> int64 -> int64 -val ( -^ ) : int64 -> int64 -> int64 -val ( *^ ) : int64 -> int64 -> int64 -val ( /^ ) : int64 -> int64 -> int64 -(** int32 and int64 infix operators for convenience. *) - -val debug : bool ref (** If true, emit debug info to stderr*) -val uri : string option ref (** Hypervisor/libvirt URI. *) -val inodes : bool ref (** Display inodes. *) -val human : bool ref (** Display human-readable. *) -val all : bool ref (** Show all or just active domains. *) -val test_files : string list ref (** In test mode (-t) list of files. *) -(** State of command line arguments. *) - -(** - {2 Domain/device model} - - The "domain/device model" that we currently understand looks - like this: - -{v -domains - | - \--- host partitions / disk image files - || - guest block devices - | - +--> guest partitions (eg. using MBR) - | | - \-(1)->+--- filesystems (eg. ext3) - | - \--- PVs for LVM - ||| - VGs and LVs -v} - - (1) Filesystems and PVs may also appear directly on guest - block devices. - - Partition schemes (eg. MBR) and filesystems register themselves - with this main module and they are queried first to get an idea - of the physical devices, partitions and filesystems potentially - available to the guest. - - Volume management schemes (eg. LVM2) register themselves here - and are called later with "spare" physical devices and partitions - to see if they contain LVM data. If this results in additional - logical volumes then these are checked for filesystems. - - Swap space is considered to be a dumb filesystem for the purposes - of this discussion. -*) - -class virtual device : - object - method virtual name : string - method virtual read : int64 -> int -> string - method read_bitstring : int64 -> int -> string * int * int - method virtual size : int64 - end - (** - A virtual (or physical!) device, encapsulating any translation - that has to be done to access the device. eg. For partitions - there is a simple offset, but for LVM you may need complicated - table lookups. - - We keep the underlying file descriptors open for the duration - of the program. There aren't likely to be many of them, and - the program is short-lived, and it's easier than trying to - track which device is using what fd. As a result, there is no - need for any close/deallocation function. - - Note the very rare use of OOP in OCaml! - *) - -class block_device : string -> - object - method name : string - method read : int64 -> int -> string - method read_bitstring : int64 -> int -> string * int * int - method size : int64 - end - (** A concrete device which just direct-maps a file or /dev device. *) - -class offset_device : string -> int64 -> int64 -> device -> - object - method name : string - method read : int64 -> int -> string - method read_bitstring : int64 -> int -> string * int * int - method size : int64 - end - (** A concrete device which maps a linear part of an underlying device. - - [new offset_device name start size dev] creates a new - device which maps bytes from [start] to [start+size-1] - of the underlying device [dev] (ie. in this device they - appear as bytes [0] to [size-1]). - - Useful for things like partitions. - *) - -val null_device : device - (** The null device. Any attempt to read generates an error. *) - -type domain = { - dom_name : string; (** Domain name. *) - dom_id : int option; (** Domain ID (if running). *) - dom_disks : disk list; (** Domain disks. *) - dom_lv_filesystems : - (lv * filesystem) list; (** Domain LV filesystems. *) -} -and disk = { - d_type : string option; (** The <disk type=...> *) - d_device : string; (** The <disk device=...> (eg "disk") *) - d_source : string; (** The <source file=... or dev> *) - d_target : string; (** The <target dev=...> (eg "hda") *) - d_dev : device; (** Disk device. *) - d_content : disk_content; (** What's on it. *) -} -and disk_content = - [ `Filesystem of filesystem (** Contains a direct filesystem. *) - | `Partitions of partitions (** Contains partitions. *) - | `PhysicalVolume of pv (** Contains an LVM PV. *) - | `Unknown (** Not probed or unknown. *) - ] -and partitions = { - parts_name : string; (** Name of partitioning scheme. *) - parts : partition list; (** Partitions. *) -} -and partition = { - part_status : partition_status; (** Bootable, etc. *) - part_type : int; (** Partition filesystem type. *) - part_dev : device; (** Partition device. *) - part_content : partition_content; (** What's on it. *) -} -and partition_status = Bootable | Nonbootable | Malformed | NullEntry -and partition_content = - [ `Filesystem of filesystem (** Filesystem. *) - | `PhysicalVolume of pv (** Contains an LVM PV. *) - | `Unknown (** Not probed or unknown. *) - ] -and filesystem = { - fs_name : string; (** Name of filesystem. *) - fs_block_size : int64; (** Block size (bytes). *) - fs_blocks_total : int64; (** Total blocks. *) - fs_is_swap : bool; (** If swap, following not valid. *) - fs_blocks_reserved : int64; (** Blocks reserved for super-user. *) - fs_blocks_avail : int64; (** Blocks free (available). *) - fs_blocks_used : int64; (** Blocks in use. *) - fs_inodes_total : int64; (** Total inodes. *) - fs_inodes_reserved : int64; (** Inodes reserved for super-user. *) - fs_inodes_avail : int64; (** Inodes free (available). *) - fs_inodes_used : int64; (** Inodes in use. *) -} -and pv = { - lvm_plugin_id : lvm_plugin_id; (** The LVM plug-in which detected - this. *) - pv_uuid : string; (** UUID. *) -} -and lv = { - lv_dev : device; (** Logical volume device. *) -} - -and lvm_plugin_id - -val string_of_partition : partition -> string -val string_of_filesystem : filesystem -> string -(** Convert a partition or filesystem struct to a string (for debugging). *) - -val canonical_uuid : string -> string -(** Convert a UUID which may contain '-' characters to canonical form. *) - -(** {2 Plug-in registration functions} *) - -val partition_type_register : string -> (device -> partitions) -> unit -(** Register a partition probing plug-in. *) - -val probe_for_partitions : device -> partitions option -(** Do a partition probe on a device. Returns [Some partitions] or [None]. *) - -val filesystem_type_register : string -> (device -> filesystem) -> unit -(** Register a filesystem probing plug-in. *) - -val probe_for_filesystem : device -> filesystem option -(** Do a filesystem probe on a device. Returns [Some filesystem] or [None]. *) - -val lvm_type_register : - string -> (lvm_plugin_id -> device -> pv) -> (device list -> lv list) -> unit -(** [lvm_type_register lvm_name probe_fn list_lvs_fn] - registers a new LVM type. [probe_fn] is a function which - should probe a device to find out if it contains a PV. - [list_lvs_fn] is a function which should take a list of - devices (PVs) and construct a list of LV devices. -*) - -val probe_for_pv : device -> pv option -(** Do a PV probe on a device. Returns [Some pv] or [None]. *) - -val list_lvs : lvm_plugin_id -> device list -> lv list -(** Construct LV devices from a list of PVs. *) - -(** {2 Utility functions} *) - -val group_by : ?cmp:('a -> 'a -> int) -> ('a * 'b) list -> ('a * 'b list) list -(** Group a sorted list of pairs by the first element of the pair. *) - -val range : int -> int -> int list -(** [range a b] returns the list of integers [a <= i < b]. - If [a >= b] then the empty list is returned. -*) diff --git a/virt-df/virt_df_ext2.ml b/virt-df/virt_df_ext2.ml deleted file mode 100644 index 2d1d1b8..0000000 --- a/virt-df/virt_df_ext2.ml +++ /dev/null @@ -1,138 +0,0 @@ -(* 'df' command for virtual domains. - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - 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. - - Support for EXT2/EXT3 filesystems. -*) - -open Unix -open Printf - -open Virt_df_gettext.Gettext -open Virt_df - -let superblock_offset = 1024L - -let probe_ext2 dev = - (* Load the superblock. *) - let bits = dev#read_bitstring superblock_offset 1024 in - - (* The structure is straight from /usr/include/linux/ext3_fs.h *) - bitmatch bits with - | s_inodes_count : 32 : littleendian; (* Inodes count *) - s_blocks_count : 32 : littleendian; (* Blocks count *) - s_r_blocks_count : 32 : littleendian; (* Reserved blocks count *) - s_free_blocks_count : 32 : littleendian; (* Free blocks count *) - s_free_inodes_count : 32 : littleendian; (* Free inodes count *) - s_first_data_block : 32 : littleendian; (* First Data Block *) - s_log_block_size : 32 : littleendian; (* Block size *) - s_log_frag_size : 32 : littleendian; (* Fragment size *) - s_blocks_per_group : 32 : littleendian; (* # Blocks per group *) - s_frags_per_group : 32 : littleendian; (* # Fragments per group *) - s_inodes_per_group : 32 : littleendian; (* # Inodes per group *) - s_mtime : 32 : littleendian; (* Mount time *) - s_wtime : 32 : littleendian; (* Write time *) - s_mnt_count : 16 : littleendian; (* Mount count *) - s_max_mnt_count : 16 : littleendian; (* Maximal mount count *) - 0xef53 : 16 : littleendian; (* Magic signature *) - s_state : 16 : littleendian; (* File system state *) - s_errors : 16 : littleendian; (* Behaviour when detecting errors *) - s_minor_rev_level : 16 : littleendian; (* minor revision level *) - s_lastcheck : 32 : littleendian; (* time of last check *) - s_checkinterval : 32 : littleendian; (* max. time between checks *) - s_creator_os : 32 : littleendian; (* OS *) - s_rev_level : 32 : littleendian; (* Revision level *) - s_def_resuid : 16 : littleendian; (* Default uid for reserved blocks *) - s_def_resgid : 16 : littleendian; (* Default gid for reserved blocks *) - s_first_ino : 32 : littleendian; (* First non-reserved inode *) - s_inode_size : 16 : littleendian; (* size of inode structure *) - s_block_group_nr : 16 : littleendian; (* block group # of this superblock *) - s_feature_compat : 32 : littleendian; (* compatible feature set *) - s_feature_incompat : 32 : littleendian; (* incompatible feature set *) - s_feature_ro_compat : 32 : littleendian; (* readonly-compatible feature set *) - s_uuid : 128 : bitstring; (* 128-bit uuid for volume *) - s_volume_name : 128 : bitstring; (* volume name XXX string *) - s_last_mounted : 512 : bitstring; (* directory where last mounted XXX string *) - s_algorithm_usage_bitmap : 32 : littleendian; (* For compression *) - s_prealloc_blocks : 8; (* Nr of blocks to try to preallocate*) - s_prealloc_dir_blocks : 8; (* Nr to preallocate for dirs *) - s_reserved_gdt_blocks : 16 : littleendian; (* Per group desc for online growth *) - s_journal_uuid : 128 : bitstring; (* uuid of journal superblock *) - s_journal_inum : 32 : littleendian; (* inode number of journal file *) - s_journal_dev : 32 : littleendian; (* device number of journal file *) - s_last_orphan : 32 : littleendian; (* start of list of inodes to delete *) - s_hash_seed0 : 32 : littleendian; (* HTREE hash seed *) - s_hash_seed1 : 32 : littleendian; - s_hash_seed2 : 32 : littleendian; - s_hash_seed3 : 32 : littleendian; - s_def_hash_version : 8; (* Default hash version to use *) - s_reserved_char_pad : 8; - s_reserved_word_pad : 16 : littleendian; - s_default_mount_opts : 32 : littleendian; - s_first_meta_bg : 32 : littleendian; (* First metablock block group *) - s_reserved : 6080 : bitstring -> (* Padding to the end of the block *) - - (* Work out the block size in bytes. *) - let s_log_block_size = Int32.to_int s_log_block_size in - let block_size = 1024L in - let block_size = Int64.shift_left block_size s_log_block_size in - - (* Number of groups. *) - let s_groups_count = - Int64.of_int32 ( - (s_blocks_count -* s_first_data_block -* 1l) - /* s_blocks_per_group +* 1l - ) in - -(* - (* Number of group descriptors per block. *) - let s_inodes_per_block = s_blocksize / - let s_desc_per_block = block_size / s_inodes_per_block in - let db_count = - (s_groups_count +^ s_desc_per_block -^ 1L) - /^ s_desc_per_block -*) - - (* Calculate the block overhead (used by superblocks, inodes, etc.) - * See fs/ext2/super.c. - *) - let overhead = Int64.of_int32 s_first_data_block in - let overhead = (* XXX *) overhead in - - { - fs_name = s_ "Linux ext2/3"; - fs_block_size = block_size; - fs_blocks_total = Int64.of_int32 s_blocks_count -^ overhead; - fs_is_swap = false; - fs_blocks_reserved = Int64.of_int32 s_r_blocks_count; - fs_blocks_avail = Int64.of_int32 s_free_blocks_count; - fs_blocks_used = - Int64.of_int32 s_blocks_count -^ overhead - -^ Int64.of_int32 s_free_blocks_count; - fs_inodes_total = Int64.of_int32 s_inodes_count; - fs_inodes_reserved = 0L; (* XXX? *) - fs_inodes_avail = Int64.of_int32 s_free_inodes_count; - fs_inodes_used = Int64.of_int32 s_inodes_count - (*-^ 0L*) - -^ Int64.of_int32 s_free_inodes_count; - } - - | _ -> - raise Not_found (* Not an EXT2/3 superblock. *) - -(* Register with main code. *) -let () = filesystem_type_register "ext2" probe_ext2 diff --git a/virt-df/virt_df_ext2.mli b/virt-df/virt_df_ext2.mli deleted file mode 100644 index d32a0f8..0000000 --- a/virt-df/virt_df_ext2.mli +++ /dev/null @@ -1,22 +0,0 @@ -(* 'df' command for virtual domains. - (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - 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. - *) - -(* This file is empty to stop this plug-in from exporting any - symbols to other modules by accident. -*) diff --git a/virt-df/virt_df_linux_swap.ml b/virt-df/virt_df_linux_swap.ml deleted file mode 100644 index afd671f..0000000 --- a/virt-df/virt_df_linux_swap.ml +++ /dev/null @@ -1,54 +0,0 @@ -(* 'df' command for virtual domains. - - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - 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. - - Support for Linux swap partitions. -*) - -open Virt_df_gettext.Gettext -open Virt_df - -let probe_swap dev = - (* Load the "superblock" (ie. first 0x1000 bytes). *) - let bits = dev#read_bitstring 0L 0x1000 in - - bitmatch bits with - (* Actually this isn't just padding. *) - | padding : 8*0x1000 - 10*8 : bitstring; - magic : 10*8 : bitstring - when Bitmatch.string_of_bitstring magic = "SWAPSPACE2" -> - { - fs_name = s_ "Linux swap"; - fs_block_size = 4096L; (* XXX *) - fs_blocks_total = dev#size /^ 4096L; - - (* The remaining fields are ignored when fs_is_swap is true. *) - fs_is_swap = true; - fs_blocks_reserved = 0L; - fs_blocks_avail = 0L; - fs_blocks_used = 0L; - fs_inodes_total = 0L; - fs_inodes_reserved = 0L; - fs_inodes_avail = 0L; - fs_inodes_used = 0L; - } - | _ -> - raise Not_found (* Not Linux swapspace. *) - -(* Register with main code. *) -let () = filesystem_type_register "linux_swap" probe_swap diff --git a/virt-df/virt_df_linux_swap.mli b/virt-df/virt_df_linux_swap.mli deleted file mode 100644 index d32a0f8..0000000 --- a/virt-df/virt_df_linux_swap.mli +++ /dev/null @@ -1,22 +0,0 @@ -(* 'df' command for virtual domains. - (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - 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. - *) - -(* This file is empty to stop this plug-in from exporting any - symbols to other modules by accident. -*) diff --git a/virt-df/virt_df_lvm2.ml b/virt-df/virt_df_lvm2.ml deleted file mode 100644 index 6a8f573..0000000 --- a/virt-df/virt_df_lvm2.ml +++ /dev/null @@ -1,432 +0,0 @@ -(* 'df' command for virtual domains. - - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - 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. - - Support for LVM2 PVs. -*) - -open Printf -open ExtList - -open Virt_df_gettext.Gettext -open Virt_df - -open Virt_df_lvm2_metadata - -let plugin_name = "LVM2" - -let sector_size = 512 -let sector_size64 = 512L - -(*----------------------------------------------------------------------*) -(* Block device which can do linear maps, same as the kernel dm-linear.c *) -class linear_map_device name extent_size segments = - (* The segments are passed containing (start_extent, extent_count, ...) - * but it's easier to deal with (start_extent, end_extent, ...) so - * rewrite them. - *) - let segments = List.map - (fun (start_extent, extent_count, dev, pvoffset) -> - (start_extent, start_extent +^ extent_count, dev, pvoffset) - ) segments in - - (* Calculate the size of the device (in bytes). Note that because - * of the random nature of the mapping this doesn't imply that we can - * satisfy any read request up to the full size. - *) - let size_in_extents = - List.fold_left max 0L - (List.map (fun (_, end_extent, _, _) -> end_extent) segments) in - let size = size_in_extents *^ extent_size in -object - inherit device - method name = name - method size = size - - (* Read method checks which segment the request lies inside and - * maps it to the underlying device. If there is no mapping then - * we have to return an error. - * - * The request must lie inside a single extent, otherwise this is - * also an error (XXX - should lift this restriction, however default - * extent size is 4 MB so we probably won't hit this very often). - *) - method read offset len = - let offset_in_extents = offset /^ extent_size in - - (* Check we don't cross an extent boundary. *) - if (offset +^ Int64.of_int (len-1)) /^ extent_size <> offset_in_extents - then invalid_arg "linear_map_device: request crosses extent boundary"; - - if offset_in_extents < 0L || offset_in_extents >= size_in_extents then - invalid_arg "linear_map_device: read outside device"; - - let rec loop = function - | [] -> - invalid_arg "linear_map_device: offset not mapped" - | (start_extent, end_extent, dev, pvoffset) :: rest -> - eprintf "pvoffset = %Ld\n" pvoffset; - if start_extent <= offset_in_extents && - offset_in_extents < end_extent - then dev#read (offset +^ pvoffset *^ extent_size) len - else loop rest - in - loop segments -end - -(*----------------------------------------------------------------------*) -(* Probe to see if it's an LVM2 PV. *) -let rec probe_pv lvm_plugin_id dev = - try - let uuid, _ = read_pv_label dev in - if !debug then - eprintf "LVM2 detected PV UUID %s\n%!" uuid; - { lvm_plugin_id = lvm_plugin_id; pv_uuid = uuid } - with exn -> - if !debug then prerr_endline (Printexc.to_string exn); - raise Not_found - -and read_pv_label dev = - (* Load the first 8 sectors. I found by experimentation that - * the second sector contains the header ("LABELONE" etc) and - * the nineth sector contains some additional information about - * the location of the current metadata. - *) - let bits = dev#read_bitstring 0L (9 * sector_size) in - - (*Bitmatch.hexdump_bitstring stdout bits;*) - - bitmatch bits with - | sector0 : sector_size*8 : bitstring; (* sector 0 *) - labelone : 8*8 : bitstring; (* "LABELONE" *) - padding : 16*8 : bitstring; (* Seems to contain something. *) - lvm2_ver : 8*8 : bitstring; (* "LVM2 001" *) - uuid : 32*8 : bitstring; (* UUID *) - padding2 : (sector_size-64)*8 : bitstring; (* to end of second sector *) - sector234567 : sector_size*8 * 6 : bitstring; (* sectors 2-6 *) - padding3 : 0x28*8 : bitstring; (* start of sector 8 *) - metadata_offset : 32 : littleendian;(* metadata offset *) - padding4 : 4*8 : bitstring; - metadata_length : 32 : littleendian (* length of metadata (bytes) *) - when Bitmatch.string_of_bitstring labelone = "LABELONE" && - Bitmatch.string_of_bitstring lvm2_ver = "LVM2 001" -> - - (* Metadata offset is relative to end of PV label. *) - let metadata_offset = metadata_offset +* 0x1000_l in - (* Metadata length appears to include the trailing \000 which - * we don't want. - *) - let metadata_length = metadata_length -* 1_l in - - let metadata = read_metadata dev metadata_offset metadata_length in - - let uuid = Bitmatch.string_of_bitstring uuid in - - uuid, metadata - - | _ -> - invalid_arg - (sprintf "LVM2: read_pv_label: %s: not an LVM2 physical volume" dev#name) - -and read_metadata dev offset32 len32 = - if !debug then - eprintf "metadata: offset 0x%lx len %ld bytes\n%!" offset32 len32; - - (* Check the offset and length are sensible. *) - let offset64 = - if offset32 <= Int32.max_int then Int64.of_int32 offset32 - else invalid_arg "LVM2: read_metadata: metadata offset too large" in - let len64 = - if len32 <= 2_147_483_647_l then Int64.of_int32 len32 - else invalid_arg "LVM2: read_metadata: metadata length too large" in - - if offset64 <= 0x1200L || offset64 >= dev#size - || len64 <= 0L || offset64 +^ len64 >= dev#size then - invalid_arg "LVM2: read_metadata: bad metadata offset or length"; - - (* If it is outside the disk boundaries, this will throw an exception, - * otherwise it will read and return the metadata string. - *) - dev#read offset64 (Int64.to_int len64) - -(*----------------------------------------------------------------------*) -(* We are passed a list of devices which we previously identified - * as PVs belonging to us. From these produce a list of all LVs - * (as devices) and return them. Note that we don't try to detect - * what is on these LVs - that will be done in the main code. - *) -let rec list_lvs devs = - (* Read the UUID and metadata (again) from each device to end up with - * an assoc list of PVs, keyed on the UUID. - *) - let pvs = List.map ( - fun dev -> - let uuid, metadata = read_pv_label dev in - (uuid, (metadata, dev)) - ) devs in - - (* Parse the metadata using the external lexer/parser. *) - let pvs = List.map ( - fun (uuid, (metadata, dev)) -> - uuid, (Virt_df_lvm2_lexer.parse_lvm2_metadata_from_string metadata, - dev) - ) pvs in - - (* Print the parsed metadata. *) - if !debug then - List.iter ( - fun (uuid, (metadata, dev)) -> - eprintf "metadata for PV UUID %s on %s:\n" uuid dev#name; - output_metadata stderr metadata - ) pvs; - - (* Scan for volume groups. The first entry in the metadata - * appears to be the volume group name. This gives us a - * list of VGs and the metadata for each underlying PV. - *) - let vgnames = - List.filter_map ( - function - | pvuuid, (((vgname, Metadata vgmeta) :: _), dev) -> - Some (vgname, (pvuuid, vgmeta)) - | _ -> None - ) pvs in - - let cmp ((a:string),_) ((b:string),_) = compare a b in - let vgnames = List.sort ~cmp vgnames in - let vgs = group_by vgnames in - - (* Note that the metadata is supposed to be duplicated - * identically across all PVs (for redundancy purposes). - * In theory we should check this and use the 'seqno' - * field to find the latest metadata if it doesn't match, - * but in fact we don't check this. - *) - let vgs = List.map ( - fun (vgname, metas) -> - let pvuuids = List.map fst metas in - let _, vgmeta = List.hd metas in (* just pick any metadata *) - vgname, (pvuuids, vgmeta)) vgs in - - (* Print the VGs. *) - if !debug then - List.iter ( - fun (vgname, (pvuuids, vgmeta)) -> - eprintf "VG %s is on PVs: %s\n%!" vgname (String.concat "," pvuuids) - ) vgs; - - (* Some useful getter functions. If these can't get a value - * from the metadata or if the type is wrong they raise Not_found. - *) - let rec get_int64 field meta = - match List.assoc field meta with - | Int i -> i - | _ -> raise Not_found - and get_int field meta min max = - match List.assoc field meta with - | Int i when Int64.of_int min <= i && i <= Int64.of_int max -> - Int64.to_int i - | _ -> raise Not_found - and get_string field meta = - match List.assoc field meta with - | String s -> s - | _ -> raise Not_found - and get_meta field meta = - match List.assoc field meta with - | Metadata md -> md - | _ -> raise Not_found - and get_stripes field meta = (* List of (string,int) pairs. *) - match List.assoc field meta with - | List xs -> - let rec loop = function - | [] -> [] - | String pvname :: Int offset :: xs -> - (pvname, offset) :: loop xs - | _ -> raise Not_found - in - loop xs - | _ -> raise Not_found - in - - (* The volume groups refer to the physical volumes using their - * own naming system ("pv0", "pv1", etc.) instead of PV UUIDs. - * - * Each PV also has a start (in sectors) & count (in extents) - * of the writable area (the bit after the superblock and metadata) - * which normally starts at sector 384. - * - * Create a PV device (simple offset + size) and a map from PV - * names to these devices. - *) - let vgs = List.map ( - fun (vgname, (pvuuids, vgmeta)) -> - let pvdevs, extent_size = - try - (* NB: extent_size is in sectors here - we convert to bytes. *) - let extent_size = get_int "extent_size" vgmeta 0 (1024*1024) in - let extent_size = Int64.of_int extent_size *^ sector_size64 in - - (* Get the physical_volumes section of the metadata. *) - let pvdevs = get_meta "physical_volumes" vgmeta in - - List.filter_map ( - function - | (pvname, Metadata meta) -> - (* Get the UUID. *) - let pvuuid = get_string "id" meta in - let pvuuid = canonical_uuid pvuuid in - - (* Get the underlying physical device. *) - let _, dev = List.assoc pvuuid pvs in - - (* Construct a PV device. *) - let pe_start = get_int64 "pe_start" meta in - let pe_start = pe_start *^ sector_size64 in - let pe_count = get_int64 "pe_count" meta in - let pe_count = pe_count *^ extent_size in - let pvdev = new offset_device pvuuid pe_start pe_count dev in - - Some (pvname, pvdev) - | _ -> - None - ) pvdevs, extent_size - with - (* Something went wrong - just return an empty map. *) - Not_found -> [], 0L in - (vgname, (pvuuids, vgmeta, pvdevs, extent_size)) - ) vgs in - - (* Scan for logical volumes. Each VG contains several LVs. - * This gives us a list of LVs within each VG (hence extends - * the vgs variable). - *) - let vgs = List.map ( - fun (vgname, (pvuuids, vgmeta, pvdevs, extent_size)) -> - let lvs = - try - let lvs = get_meta "logical_volumes" vgmeta in - let lvs = List.filter_map ( - function - | lvname, Metadata lvmeta -> - (try - let segment_count = get_int "segment_count" lvmeta 0 1024 in - - (* Get the segments for this LV. *) - let segments = range 1 (segment_count+1) in - let segments = - List.map - (fun i -> get_meta ("segment" ^ string_of_int i) lvmeta) - segments in - - let segments = - List.map ( - fun segmeta -> - let start_extent = - get_int64 "start_extent" segmeta in - let extent_count = - get_int64 "extent_count" segmeta in - let segtype = get_string "type" segmeta in - - (* Can only handle striped segments at the - * moment. XXX - *) - if segtype <> "striped" then raise Not_found; - - let stripe_count = - get_int "stripe_count" segmeta 0 1024 in - let stripes = get_stripes "stripes" segmeta in - - if List.length stripes <> stripe_count then - raise Not_found; - - (* Can only handle linear striped segments at - * the moment. XXX - *) - if stripe_count <> 1 then raise Not_found; - let pvname, pvoffset = List.hd stripes in - - (start_extent, extent_count, pvname, pvoffset) - ) segments in - - Some (lvname, segments) - with - (* Something went wrong with segments - omit this LV. *) - Not_found -> None) - | _ -> None - ) lvs in - - lvs - with - Not_found -> - (* Something went wrong - assume no LVs found. *) - [] in - (vgname, (pvuuids, vgmeta, pvdevs, extent_size, lvs)) - ) vgs in - - (* Print the LVs. *) - if !debug then ( - List.iter ( - fun (vgname, (pvuuids, vgmeta, pvdevs, extent_size, lvs)) -> - eprintf "VG %s: (extent_size = %Ld bytes)\n" vgname extent_size; - List.iter ( - fun (lvname, segments) -> - eprintf " %s/%s:\n" vgname lvname; - List.iter ( - fun (start_extent, extent_count, pvname, pvoffset) -> - eprintf " start %Ld count %Ld at %s:%Ld\n" - start_extent extent_count pvname pvoffset - ) segments - ) lvs - ) vgs; - flush stderr - ); - - (* Finally we can set up devices for the LVs. *) - let lvs = - List.map ( - fun (vgname, (pvuuid, vgmeta, pvdevs, extent_size, lvs)) -> - try - List.map ( - fun (lvname, segments) -> - let name = vgname ^ "/" ^ lvname in - let segments = List.map ( - fun (start_extent, extent_count, pvname, pvoffset) -> - (* Get the PV device. *) - let pvdev = List.assoc pvname pvdevs in - - (* Extents mapped to: *) - (start_extent, extent_count, pvdev, pvoffset) - ) segments in - - (* Create a linear mapping device. *) - let lv_dev = new linear_map_device name extent_size segments in - - { lv_dev = lv_dev } - ) lvs - with - Not_found -> [] - ) vgs in - let lvs = List.concat lvs in - - (* Return the list of LV devices. *) - lvs - -(*----------------------------------------------------------------------*) -(* Register with main code. *) -let () = - lvm_type_register plugin_name probe_pv list_lvs diff --git a/virt-df/virt_df_lvm2.mli b/virt-df/virt_df_lvm2.mli deleted file mode 100644 index d32a0f8..0000000 --- a/virt-df/virt_df_lvm2.mli +++ /dev/null @@ -1,22 +0,0 @@ -(* 'df' command for virtual domains. - (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - 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. - *) - -(* This file is empty to stop this plug-in from exporting any - symbols to other modules by accident. -*) diff --git a/virt-df/virt_df_lvm2_lexer.mll b/virt-df/virt_df_lvm2_lexer.mll deleted file mode 100644 index 2dbe7e5..0000000 --- a/virt-df/virt_df_lvm2_lexer.mll +++ /dev/null @@ -1,165 +0,0 @@ -(* 'df' command for virtual domains. - (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - 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. - *) - -(* Scanner for LVM2 metadata. - * ocamllex tutorial: - * http://plus.kaist.ac.kr/~shoh/ocaml/ocamllex-ocamlyacc/ocamllex-tutorial/ - *) - -{ - open Printf - open Lexing - - open Virt_df - open Virt_df_lvm2_parser - - (* Temporary buffer used for parsing strings, etc. *) - let tmp = Buffer.create 80 - - exception Error of string -} - -let digit = ['0'-'9'] -let alpha = ['a'-'z' 'A'-'Z'] -let alphau = ['a'-'z' 'A'-'Z' '_'] -let alnum = ['a'-'z' 'A'-'Z' '0'-'9'] -let alnumu = ['a'-'z' 'A'-'Z' '0'-'9' '_'] -let ident = alphau alnumu* - -let whitespace = [' ' '\t' '\r' '\n']+ - -let escaped_char = '\\' _ - -rule token = parse - (* ignore whitespace and comments *) - | whitespace - | '#' [^ '\n']* - { token lexbuf } - - (* scan single character tokens *) - | '{' { LBRACE } - | '}' { RBRACE } - | '[' { LSQUARE } - | ']' { RSQUARE } - | '=' { EQ } - | ',' { COMMA } - - (* strings - see LVM2/lib/config/config.c *) - | '"' - { - Buffer.reset tmp; - STRING (dq_string lexbuf) - } - | '\'' - { - Buffer.reset tmp; - STRING (dq_string lexbuf) - } - - (* floats *) - | ('-'? digit+ '.' digit*) as f - { - let f = float_of_string f in - FLOAT f - } - - (* integers *) - | ('-'? digit+) as i - { - let i = Int64.of_string i in - INT i - } - - (* identifiers *) - | ident as id - { IDENT id } - - (* end of file *) - | eof - { EOF } - - | _ as c - { raise (Error (sprintf "%c: invalid character in input" c)) } - -and dq_string = parse - | '"' - { Buffer.contents tmp } - | escaped_char as str - { Buffer.add_char tmp str.[1]; dq_string lexbuf } - | eof - { raise (Error "unterminated string in metadata") } - | _ as c - { Buffer.add_char tmp c; dq_string lexbuf } - -and q_string = parse - | '\'' - { Buffer.contents tmp } - | escaped_char as str - { Buffer.add_char tmp str.[1]; q_string lexbuf } - | eof - { raise (Error "unterminated string in metadata") } - | _ as c - { Buffer.add_char tmp c; q_string lexbuf } - -{ - (* Demonstration of how to wrap the token function - with extra debugging statements: - let token lexbuf = - try - let r = token lexbuf in - if debug then - eprintf "Lexer: token returned is %s\n" - (match r with - | LBRACE -> "LBRACE" - | RBRACE -> "RBRACE" - | LSQUARE -> "LSQUARE" - | RSQUARE -> "RSQUARE" - | EQ -> "EQ" - | COMMA -> "COMMA" - | STRING s -> sprintf "STRING(%S)" s - | INT i -> sprintf "INT(%Ld)" i - | FLOAT f -> sprintf "FLOAT(%g)" f - | IDENT s -> sprintf "IDENT(%s)" s - | EOF -> "EOF"); - r - with - exn -> - prerr_endline (Printexc.to_string exn); - raise exn - *) - - (* Lex and parse input. - * - * Return the parsed metadata structure if everything went to plan. - * Raises [Error msg] if there was some parsing problem. - *) - let rec parse_lvm2_metadata_from_string str = - let lexbuf = Lexing.from_string str in - parse_lvm2_metadata lexbuf - and parse_lvm2_metadata_from_channel chan = - let lexbuf = Lexing.from_channel chan in - parse_lvm2_metadata lexbuf - and parse_lvm2_metadata lexbuf = - try - input token lexbuf - with - | Error _ as exn -> raise exn - | Parsing.Parse_error -> raise (Error "Parse error") - | exn -> raise (Error ("Exception: " ^ Printexc.to_string exn)) -} diff --git a/virt-df/virt_df_lvm2_metadata.ml b/virt-df/virt_df_lvm2_metadata.ml deleted file mode 100644 index c5e3f90..0000000 --- a/virt-df/virt_df_lvm2_metadata.ml +++ /dev/null @@ -1,65 +0,0 @@ -(* 'df' command for virtual domains. - (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - 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. - *) - -(* Part of the parser for LVM2 metadata. *) - -type metadata = metastmt list - -and metastmt = string * metavalue - -and metavalue = - | Metadata of metadata (* name { ... } *) - | String of string (* name = "..." *) - | Int of int64 - | Float of float - | List of metavalue list (* name = [...] *) - -let rec output_metadata chan md = - _output_metadata chan "" md - -and _output_metadata chan prefix = function - | [] -> () - | (name, value) :: rest -> - output_string chan prefix; - output_string chan name; - output_string chan " = "; - output_metavalue chan prefix value; - output_string chan "\n"; - _output_metadata chan prefix rest - -and output_metavalue chan prefix = function - | Metadata md -> - output_string chan "{\n"; - _output_metadata chan (prefix ^ " ") md; - output_string chan prefix; - output_string chan "}"; - | String str -> - output_char chan '"'; - output_string chan str; - output_char chan '"'; - | Int i -> - output_string chan (Int64.to_string i) - | Float f -> - output_string chan (string_of_float f) - | List [] -> () - | List [x] -> output_metavalue chan prefix x - | List (x :: xs) -> - output_metavalue chan prefix x; - output_string chan ", "; - output_metavalue chan prefix (List xs) diff --git a/virt-df/virt_df_lvm2_metadata.mli b/virt-df/virt_df_lvm2_metadata.mli deleted file mode 100644 index 778f393..0000000 --- a/virt-df/virt_df_lvm2_metadata.mli +++ /dev/null @@ -1,38 +0,0 @@ -(* 'df' command for virtual domains. - (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - 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. - *) - -(* Part of the parser for LVM2 metadata. *) - -type metadata = metastmt list - -and metastmt = string * metavalue - -and metavalue = - | Metadata of metadata (* name { ... } *) - | String of string (* name = "..." *) - | Int of int64 - | Float of float - | List of metavalue list (* name = [...] *) - -val output_metadata : out_channel -> metadata -> unit -(** This function prints out the metadata on the selected channel. - - The output format isn't particularly close to the input - format. This is just for debugging purposes. -*) diff --git a/virt-df/virt_df_lvm2_parser.mly b/virt-df/virt_df_lvm2_parser.mly deleted file mode 100644 index c4ee574..0000000 --- a/virt-df/virt_df_lvm2_parser.mly +++ /dev/null @@ -1,70 +0,0 @@ -/* 'df' command for virtual domains. -*- text -*- - (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - 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. - */ - -/* Parser for LVM2 metadata. - ocamlyacc tutorial: - http://plus.kaist.ac.kr/~shoh/ocaml/ocamllex-ocamlyacc/ocamlyacc-tutorial/ - */ - -%{ - open Virt_df_lvm2_metadata -%} - -%token LBRACE RBRACE /* { } */ -%token LSQUARE RSQUARE /* [ ] */ -%token EQ /* = */ -%token COMMA /* , */ -%token <string> STRING /* "string" */ -%token <int64> INT /* an integer */ -%token <float> FLOAT /* a float */ -%token <string> IDENT /* a naked keyword/identifier */ -%token EOF /* end of file */ - -%start input -%type <Virt_df_lvm2_metadata.metadata> input - -%% - -input : lines EOF { List.rev $1 } - ; - -lines : /* empty */ { [] } - | lines line { $2 :: $1 } - ; - -line : /* empty */ /* These dummy entries get removed after parsing. */ - { ("", String "") } - | IDENT EQ value - { ($1, $3) } - | IDENT LBRACE lines RBRACE - { ($1, Metadata (List.rev $3)) } - ; - -value : STRING { String $1 } - | INT { Int $1 } - | FLOAT { Float $1 } - | LSQUARE list RSQUARE - { List (List.rev $2) } - ; - -list : /* empty */ { [] } - | value { [$1] } - | list COMMA value - { $3 :: $1 } - ; diff --git a/virt-df/virt_df_main.ml b/virt-df/virt_df_main.ml deleted file mode 100644 index 65d1f2f..0000000 --- a/virt-df/virt_df_main.ml +++ /dev/null @@ -1,488 +0,0 @@ -(* 'df' command for virtual domains. - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - 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. - *) - -open Printf -open ExtList -open Unix - -module C = Libvirt.Connect -module D = Libvirt.Domain - -open Virt_df_gettext.Gettext -open Virt_df - -let () = - (* Command line argument parsing. *) - let set_uri = function "" -> uri := None | u -> uri := Some u in - - let version () = - printf "virt-df %s\n" (Libvirt_version.version); - - let major, minor, release = - let v, _ = Libvirt.get_version () in - v / 1_000_000, (v / 1_000) mod 1_000, v mod 1_000 in - printf "libvirt %d.%d.%d\n" major minor release; - exit 0 - in - - let test_mode filename = - test_files := filename :: !test_files - in - - let argspec = Arg.align [ - "-a", Arg.Set all, - " " ^ s_ "Show all domains (default: only active domains)"; - "--all", Arg.Set all, - " " ^ s_ "Show all domains (default: only active domains)"; - "-c", Arg.String set_uri, - "uri " ^ s_ "Connect to URI (default: Xen)"; - "--connect", Arg.String set_uri, - "uri " ^ s_ "Connect to URI (default: Xen)"; - "--debug", Arg.Set debug, - " " ^ s_ "Debug mode (default: false)"; - "-h", Arg.Set human, - " " ^ s_ "Print sizes in human-readable format"; - "--human-readable", Arg.Set human, - " " ^ s_ "Print sizes in human-readable format"; - "-i", Arg.Set inodes, - " " ^ s_ "Show inodes instead of blocks"; - "--inodes", Arg.Set inodes, - " " ^ s_ "Show inodes instead of blocks"; - "-t", Arg.String test_mode, - "dev " ^ s_ "(Test mode) Display contents of block device or file"; - "--version", Arg.Unit version, - " " ^ s_ "Display version and exit"; - ] in - - let anon_fun str = - raise (Arg.Bad (sprintf (f_ "%s: unknown parameter") str)) in - let usage_msg = s_ "virt-df : like 'df', shows disk space used in guests - -SUMMARY - virt-df [-options] - -OPTIONS" in - - Arg.parse argspec anon_fun usage_msg; - - let doms : domain list = - if !test_files = [] then ( - let xmls = - (* Connect to the hypervisor. *) - let conn = - let name = !uri in - try C.connect_readonly ?name () - with - Libvirt.Virterror err -> - prerr_endline (Libvirt.Virterror.to_string err); - (* If non-root and no explicit connection URI, print a warning. *) - if geteuid () <> 0 && name = None then ( - print_endline (s_ "NB: If you want to monitor a local Xen hypervisor, you usually need to be root"); - ); - exit 1 in - - (* Get the list of active & inactive domains. *) - let doms = - let nr_active_doms = C.num_of_domains conn in - let active_doms = - Array.to_list (C.list_domains conn nr_active_doms) in - let active_doms = - List.map (D.lookup_by_id conn) active_doms in - if not !all then - active_doms - else ( - let nr_inactive_doms = C.num_of_defined_domains conn in - let inactive_doms = - Array.to_list (C.list_defined_domains conn nr_inactive_doms) in - let inactive_doms = - List.map (D.lookup_by_name conn) inactive_doms in - active_doms @ inactive_doms - ) in - - (* Get their XML. *) - let xmls = List.map D.get_xml_desc doms in - - (* Parse the XML. *) - let xmls = List.map Xml.parse_string xmls in - - (* Return just the XML documents - everything else will be closed - * and freed including the connection to the hypervisor. - *) - xmls in - - (* Grr.. Need to use a library which has XPATH support (or cduce). *) - List.map ( - fun xml -> - let nodes, domain_attrs = - match xml with - | Xml.Element ("domain", attrs, children) -> children, attrs - | _ -> failwith (s_ "get_xml_desc didn't return <domain/>") in - - let domid = - try Some (int_of_string (List.assoc "id" domain_attrs)) - with Not_found -> None in - - let rec loop = function - | [] -> - failwith (s_ "get_xml_desc returned no <name> node in XML") - | Xml.Element ("name", _, [Xml.PCData name]) :: _ -> name - | Xml.Element ("name", _, _) :: _ -> - failwith (s_ "get_xml_desc returned strange <name> node") - | _ :: rest -> loop rest - in - let name = loop nodes in - - let devices = - let devices = - List.filter_map ( - function - | Xml.Element ("devices", _, devices) -> Some devices - | _ -> None - ) nodes in - List.concat devices in - - let rec target_dev_of = function - | [] -> None - | Xml.Element ("target", attrs, _) :: rest -> - (try Some (List.assoc "dev" attrs) - with Not_found -> target_dev_of rest) - | _ :: rest -> target_dev_of rest - in - - let rec source_file_of = function - | [] -> None - | Xml.Element ("source", attrs, _) :: rest -> - (try Some (List.assoc "file" attrs) - with Not_found -> source_file_of rest) - | _ :: rest -> source_file_of rest - in - - let rec source_dev_of = function - | [] -> None - | Xml.Element ("source", attrs, _) :: rest -> - (try Some (List.assoc "dev" attrs) - with Not_found -> source_dev_of rest) - | _ :: rest -> source_dev_of rest - in - - let disks = - List.filter_map ( - function - | Xml.Element ("disk", attrs, children) -> - let typ = - try Some (List.assoc "type" attrs) - with Not_found -> None in - let device = - try Some (List.assoc "device" attrs) - with Not_found -> None in - let source = - match source_file_of children with - | (Some _) as source -> source - | None -> source_dev_of children in - let target = target_dev_of children in - - (* We only care about devices where we have - * source and target. Ignore CD-ROM devices. - *) - (match source, target, device with - | _, _, Some "cdrom" -> None (* ignore *) - | Some source, Some target, Some device -> - (* Try to create a 'device' object for this - * device. If it fails, print a warning - * and ignore the device. - *) - (try - let dev = new block_device source in - Some { - d_type = typ; d_device = device; - d_source = source; d_target = target; - d_dev = dev; d_content = `Unknown - } - with - Unix_error (err, func, param) -> - eprintf "%s:%s: %s" func param (error_message err); - None - ) - | _ -> None (* ignore anything else *) - ) - - | _ -> None - ) devices in - - { dom_name = name; dom_id = domid; - dom_disks = disks; dom_lv_filesystems = [] } - ) xmls - ) else ( - (* In test mode (-t option) the user can pass one or more - * block devices or filenames (containing partitions/filesystems/etc) - * which we use for testing virt-df itself. We create fake domains - * from these. - *) - List.map ( - fun filename -> - { - dom_name = filename; dom_id = None; - dom_disks = [ - { - d_type = Some "disk"; d_device = "disk"; - d_source = filename; d_target = "hda"; - d_dev = new block_device filename; d_content = `Unknown; - } - ]; - dom_lv_filesystems = [] - } - ) !test_files - ) in - - (* HOF to map over disks. *) - let map_over_disks doms f = - List.map ( - fun ({ dom_disks = disks } as dom) -> - let disks = List.map f disks in - { dom with dom_disks = disks } - ) doms - in - - (* 'doms' is our list of domains and their guest block devices, and - * we've successfully opened each block device. Now probe them - * to find out what they contain. - *) - let doms = map_over_disks doms ( - fun ({ d_dev = dev } as disk) -> - (* See if it is partitioned first. *) - let parts = probe_for_partitions dev in - match parts with - | Some parts -> - { disk with d_content = `Partitions parts } - | None -> - (* Not partitioned. Does it contain a filesystem? *) - let fs = probe_for_filesystem dev in - match fs with - | Some fs -> - { disk with d_content = `Filesystem fs } - | None -> - (* Not partitioned, no filesystem, is it a PV? *) - let pv = probe_for_pv dev in - match pv with - | Some lvm_name -> - { disk with d_content = `PhysicalVolume lvm_name } - | None -> - disk (* Spare/unknown. *) - ) in - - (* Now we have either detected partitions or a filesystem on each - * physical device (or perhaps neither). See what is on those - * partitions. - *) - let doms = map_over_disks doms ( - function - | ({ d_dev = dev; d_content = `Partitions parts } as disk) -> - let ps = List.map ( - fun p -> - if p.part_status = Bootable || p.part_status = Nonbootable then ( - let fs = probe_for_filesystem p.part_dev in - match fs with - | Some fs -> - { p with part_content = `Filesystem fs } - | None -> - (* Is it a PV? *) - let pv = probe_for_pv p.part_dev in - match pv with - | Some lvm_name -> - { p with part_content = `PhysicalVolume lvm_name } - | None -> - p (* Spare/unknown. *) - ) else p - ) parts.parts in - let parts = { parts with parts = ps } in - { disk with d_content = `Partitions parts } - | disk -> disk - ) in - - (* LVM filesystem detection - * - * For each domain, look for all disks/partitions which have been - * identified as PVs and pass those back to the respective LVM - * plugin for LV detection. - * - * (Note - a two-stage process because an LV can be spread over - * several PVs, so we have to detect all PVs belonging to a - * domain first). - * - * XXX To deal with RAID (ie. md devices) we will need to loop - * around here because RAID is like LVM except that they normally - * present as block devices which can be used by LVM. - *) - (* First: LV detection. *) - let doms = List.map ( - fun ({ dom_disks = disks } as dom) -> - (* Find all physical volumes, can be disks or partitions. *) - let pvs_on_disks = List.filter_map ( - function - | { d_dev = d_dev; - d_content = `PhysicalVolume pv } -> Some (pv, d_dev) - | _ -> None - ) disks in - let pvs_on_partitions = List.map ( - function - | { d_content = `Partitions { parts = parts } } -> - List.filter_map ( - function - | { part_dev = part_dev; - part_content = `PhysicalVolume pv } -> - Some (pv, part_dev) - | _ -> None - ) parts - | _ -> [] - ) disks in - let lvs = List.concat (pvs_on_disks :: pvs_on_partitions) in - dom, lvs - ) doms in - - (* Second: filesystem on LV detection. *) - let doms = List.map ( - fun (dom, lvs) -> - (* Group the LVs by plug-in type. *) - let cmp (a,_) (b,_) = compare a b in - let lvs = List.sort ~cmp lvs in - let lvs = group_by lvs in - - let lvs = - List.map (fun (pv, devs) -> list_lvs pv.lvm_plugin_id devs) lvs in - let lvs = List.concat lvs in - - (* lvs is a list of potential LV devices. Now run them through the - * probes to see if any contain filesystems. - *) - let filesystems = - List.filter_map ( - fun ({ lv_dev = dev } as lv) -> - match probe_for_filesystem dev with - | Some fs -> Some (lv, fs) - | None -> None - ) lvs in - - { dom with dom_lv_filesystems = filesystems } - ) doms in - - (* Now print the results. - * - * Print the title. - *) - let () = - let total, used, avail = - match !inodes, !human with - | false, false -> s_ "1K-blocks", s_ "Used", s_ "Available" - | false, true -> s_ "Size", s_ "Used", s_ "Available" - | true, _ -> s_ "Inodes", s_ "IUse", s_ "IFree" in - printf "%-20s %10s %10s %10s %s\n%!" - (s_ "Filesystem") total used avail (s_ "Type") in - - let printable_size bytes = - if bytes < 1024L *^ 1024L then - sprintf "%Ld bytes" bytes - else if bytes < 1024L *^ 1024L *^ 1024L then - sprintf "%.1f MiB" (Int64.to_float (bytes /^ 1024L) /. 1024.) - else - sprintf "%.1f GiB" (Int64.to_float (bytes /^ 1024L /^ 1024L) /. 1024.) - in - - (* HOF to iterate over filesystems. *) - let iter_over_filesystems doms - (f : domain -> ?disk:disk -> ?partno:int -> device -> filesystem -> - unit) = - List.iter ( - fun ({ dom_disks = disks; dom_lv_filesystems = filesystems } as dom) -> - (* Ordinary filesystems found on disks & partitions. *) - List.iter ( - function - | ({ d_content = `Filesystem fs; d_dev = dev } as disk) -> - f dom ~disk dev fs - | ({ d_content = `Partitions partitions } as disk) -> - List.iteri ( - fun i -> - function - | { part_content = `Filesystem fs; part_dev = dev } -> - f dom ~disk ~partno:(i+1) dev fs - | _ -> () - ) partitions.parts - | _ -> () - ) disks; - (* LV filesystems. *) - List.iter (fun ({lv_dev = dev}, fs) -> f dom dev fs) filesystems - ) doms - in - - (* Print stats for each recognized filesystem. *) - let print_stats dom ?disk ?partno dev fs = - (* Printable name is like "domain:hda" or "domain:hda1". *) - let name = - let dom_name = dom.dom_name in - (* Get the disk name (eg. "hda") from the domain XML, if - * we have it, otherwise use the device name (eg. for LVM). - *) - let disk_name = - match disk with - | None -> dev#name - | Some disk -> disk.d_target - in - match partno with - | None -> - dom_name ^ ":" ^ disk_name - | Some partno -> - dom_name ^ ":" ^ disk_name ^ string_of_int partno in - printf "%-20s " name; - - if fs.fs_is_swap then ( - (* Swap partition. *) - if not !human then - printf "%10Ld %s\n" - (fs.fs_block_size *^ fs.fs_blocks_total /^ 1024L) fs.fs_name - else - printf "%10s %s\n" - (printable_size (fs.fs_block_size *^ fs.fs_blocks_total)) fs.fs_name - ) else ( - (* Ordinary filesystem. *) - if not !inodes then ( (* Block display. *) - (* 'df' doesn't count the restricted blocks. *) - let blocks_total = fs.fs_blocks_total -^ fs.fs_blocks_reserved in - let blocks_avail = fs.fs_blocks_avail -^ fs.fs_blocks_reserved in - let blocks_avail = if blocks_avail < 0L then 0L else blocks_avail in - - if not !human then ( (* Display 1K blocks. *) - printf "%10Ld %10Ld %10Ld %s\n" - (blocks_total *^ fs.fs_block_size /^ 1024L) - (fs.fs_blocks_used *^ fs.fs_block_size /^ 1024L) - (blocks_avail *^ fs.fs_block_size /^ 1024L) - fs.fs_name - ) else ( (* Human-readable blocks. *) - printf "%10s %10s %10s %s\n" - (printable_size (blocks_total *^ fs.fs_block_size)) - (printable_size (fs.fs_blocks_used *^ fs.fs_block_size)) - (printable_size (blocks_avail *^ fs.fs_block_size)) - fs.fs_name - ) - ) else ( (* Inodes display. *) - printf "%10Ld %10Ld %10Ld %s\n" - fs.fs_inodes_total fs.fs_inodes_used fs.fs_inodes_avail - fs.fs_name - ) - ) - in - iter_over_filesystems doms print_stats diff --git a/virt-df/virt_df_mbr.ml b/virt-df/virt_df_mbr.ml deleted file mode 100644 index 9516e3c..0000000 --- a/virt-df/virt_df_mbr.ml +++ /dev/null @@ -1,187 +0,0 @@ -(* 'df' command for virtual domains. - - (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - 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. - - Support for Master Boot Record partition scheme. -*) - -open Printf -open Unix -open ExtList - -open Virt_df_gettext.Gettext -open Virt_df - -let sector_size = 512 -let sector_size64 = 512L - -(* Maximum number of extended partitions possible. *) -let max_extended_partitions = 100 - -(* Device representing a single partition. It just acts as an offset - * into the underlying device. - * - * Notes: - * (1) 'start'/'size' are measured in sectors. - * (2) 'partno' is the partition number, starting at 1 - * (cf. /dev/hda1 is the first partition). - * (3) 'dev' is the underlying block device. - *) -class partition_device partno start size dev = - let devname = dev#name in - let name = sprintf "%s%d" devname partno in - let start = start *^ sector_size64 in - let size = size *^ sector_size64 in -object (self) - inherit offset_device name start size dev -end - -(** Probe the - {{:http://en.wikipedia.org/wiki/Master_boot_record}master boot record} - (if it is one) and read the partitions. - - @raise Not_found if it is not an MBR. - *) -let rec probe_mbr dev = - (* Adjust size to sectors. *) - let size = dev#size /^ sector_size64 in - - (* Read the first sector. *) - let bits = - try dev#read_bitstring 0L sector_size - with exn -> raise Not_found in - - (* Does this match a likely-looking MBR? *) - bitmatch bits with - | padding : 3568 : bitstring; (* padding to byte offset 446 *) - part0 : 128 : bitstring; (* partitions *) - part1 : 128 : bitstring; - part2 : 128 : bitstring; - part3 : 128 : bitstring; - 0x55 : 8; 0xAA : 8 -> (* MBR signature *) - - (* Parse the partition table entries. *) - let primaries = - List.mapi (parse_mbr_entry dev) [part0;part1;part2;part3] in - -(* - (* Read extended partition data. *) - let extendeds = List.map ( - function - | { part_type = 0x05 } as part -> - probe_extended_partition - max_extended_partitions fd part part.part_lba_start - | part -> [] - ) primaries in - let extendeds = List.concat extendeds in - primaries @ extendeds -*) - { parts_name = "MBR"; parts = primaries } - - | _ -> - raise Not_found (* not an MBR *) - -(* Parse a single partition table entry. See the table here: - * http://en.wikipedia.org/wiki/Master_boot_record - *) -and parse_mbr_entry dev i bits = - bitmatch bits with - | 0l : 32; 0l : 32; 0l : 32; 0l : 32 -> - { part_status = NullEntry; part_type = 0; - part_dev = null_device; part_content = `Unknown } - - | 0 : 8; first_chs : 24; - part_type : 8; last_chs : 24; - first_lba : 32 : unsigned, littleendian; - part_size : 32 : unsigned, littleendian -> - make_mbr_entry Nonbootable dev (i+1) part_type first_lba part_size - - | 0x80 : 8; first_chs : 24; - part_type : 8; last_chs : 24; - first_lba : 32 : unsigned, littleendian; - part_size : 32 : unsigned, littleendian -> - make_mbr_entry Bootable dev (i+1) part_type first_lba part_size - - | _ -> - { part_status = Malformed; part_type = 0; - part_dev = null_device; part_content = `Unknown } - -and make_mbr_entry part_status dev partno part_type first_lba part_size = - let first_lba = uint64_of_int32 first_lba in - let part_size = uint64_of_int32 part_size in - if !debug then - eprintf "make_mbr_entry: first_lba = %Lx part_size = %Lx\n%!" - first_lba part_size; - { part_status = part_status; - part_type = part_type; - part_dev = new partition_device partno first_lba part_size dev; - part_content = `Unknown } - -(* -This code worked previously, but now needs some love ... -XXX - -(* Probe an extended partition. *) -and probe_extended_partition max fd epart sect = - if max > 0 then ( - (* Offset of the first EBR. *) - let ebr_offs = sect *^ sector_size in - (* EBR Signature? *) - LargeFile.lseek fd (ebr_offs +^ 510L) SEEK_SET; - let str = String.create 2 in - if read fd str 0 2 <> 2 || str.[0] != '\x55' || str.[1] != '\xAA' then - [] (* Not EBR *) - else ( - (* Read the extended partition table entries (just 2 of them). *) - LargeFile.lseek fd (ebr_offs +^ 446L) SEEK_SET; - let str = String.create 32 in - if read fd str 0 32 <> 32 then - failwith (s_ "error reading extended partition") - else ( - (* Extract partitions from the data. *) - let part1, part2 = - match List.map (get_partition str) [ 0; 16 ] with - | [p1;p2] -> p1,p2 - | _ -> failwith (s_ "probe_extended_partition: internal error") in - (* First partition entry has offset to the start of this partition. *) - let part1 = { part1 with - part_lba_start = sect +^ part1.part_lba_start } in - (* Second partition entry is zeroes if end of list, otherwise points - * to the next partition. - *) - if part2.part_status = NullEntry then - [part1] - else - part1 :: probe_extended_partition - (max-1) fd epart (sect +^ part2.part_lba_start) - ) - ) - ) - else [] -*) - -(* Ugh, fake a UInt32 -> UInt64 conversion without sign extension, until - * we get working UInt32/UInt64 modules in extlib. - *) -and uint64_of_int32 u32 = - let i64 = Int64.of_int32 u32 in - if u32 >= 0l then i64 - else Int64.add i64 0x1_0000_0000_L - -(* Register with main code. *) -let () = partition_type_register "MBR" probe_mbr diff --git a/virt-df/virt_df_mbr.mli b/virt-df/virt_df_mbr.mli deleted file mode 100644 index d32a0f8..0000000 --- a/virt-df/virt_df_mbr.mli +++ /dev/null @@ -1,22 +0,0 @@ -(* 'df' command for virtual domains. - (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc. - http://libvirt.org/ - - 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. - *) - -(* This file is empty to stop this plug-in from exporting any - symbols to other modules by accident. -*) |