From 1a2f10cdc0249b2a2432f7532ca0e5d4fc6c190d Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Wed, 19 Mar 2008 11:31:06 +0000 Subject: Use CAMLnoreturn to avoid compiler warning. --- libvirt/generator.pl | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/libvirt/generator.pl b/libvirt/generator.pl index 578029b..4fbace6 100755 --- a/libvirt/generator.pl +++ b/libvirt/generator.pl @@ -951,8 +951,7 @@ END #ifndef $have_name /* Symbol $c_name not found at compile time. */ not_supported ("$c_name"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol $c_name * is in runtime version of libvirt. -- cgit v1.1 From 3100a9fc683b327a154a04266bb1ec0efc349f00 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Wed, 19 Mar 2008 11:33:48 +0000 Subject: Generated file updated by previous commit. --- libvirt/libvirt_c.c | 144 ++++++++++++++++++---------------------------------- 1 file changed, 48 insertions(+), 96 deletions(-) diff --git a/libvirt/libvirt_c.c b/libvirt/libvirt_c.c index 882f016..ca7f303 100644 --- a/libvirt/libvirt_c.c +++ b/libvirt/libvirt_c.c @@ -85,8 +85,7 @@ ocaml_libvirt_connect_get_hostname (value connv) #ifndef HAVE_VIRCONNECTGETHOSTNAME /* Symbol virConnectGetHostname not found at compile time. */ not_supported ("virConnectGetHostname"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virConnectGetHostname * is in runtime version of libvirt. @@ -123,8 +122,7 @@ ocaml_libvirt_connect_get_uri (value connv) #ifndef HAVE_VIRCONNECTGETURI /* Symbol virConnectGetURI not found at compile time. */ not_supported ("virConnectGetURI"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virConnectGetURI * is in runtime version of libvirt. @@ -361,8 +359,7 @@ ocaml_libvirt_connect_num_of_storage_pools (value connv) #ifndef HAVE_VIRCONNECTNUMOFSTORAGEPOOLS /* Symbol virConnectNumOfStoragePools not found at compile time. */ not_supported ("virConnectNumOfStoragePools"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virConnectNumOfStoragePools * is in runtime version of libvirt. @@ -396,8 +393,7 @@ ocaml_libvirt_connect_list_storage_pools (value connv, value iv) #ifndef HAVE_VIRCONNECTLISTSTORAGEPOOLS /* Symbol virConnectListStoragePools not found at compile time. */ not_supported ("virConnectListStoragePools"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virConnectListStoragePools * is in runtime version of libvirt. @@ -441,8 +437,7 @@ ocaml_libvirt_connect_num_of_defined_storage_pools (value connv) #ifndef HAVE_VIRCONNECTNUMOFDEFINEDSTORAGEPOOLS /* Symbol virConnectNumOfDefinedStoragePools not found at compile time. */ not_supported ("virConnectNumOfDefinedStoragePools"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virConnectNumOfDefinedStoragePools * is in runtime version of libvirt. @@ -476,8 +471,7 @@ ocaml_libvirt_connect_list_defined_storage_pools (value connv, value iv) #ifndef HAVE_VIRCONNECTLISTDEFINEDSTORAGEPOOLS /* Symbol virConnectListDefinedStoragePools not found at compile time. */ not_supported ("virConnectListDefinedStoragePools"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virConnectListDefinedStoragePools * is in runtime version of libvirt. @@ -564,8 +558,7 @@ ocaml_libvirt_domain_create_linux_job (value connv, value strv) #ifndef HAVE_VIRDOMAINCREATELINUXJOB /* Symbol virDomainCreateLinuxJob not found at compile time. */ not_supported ("virDomainCreateLinuxJob"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virDomainCreateLinuxJob * is in runtime version of libvirt. @@ -885,8 +878,7 @@ ocaml_libvirt_domain_save_job (value domv, value strv) #ifndef HAVE_VIRDOMAINSAVEJOB /* Symbol virDomainSaveJob not found at compile time. */ not_supported ("virDomainSaveJob"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virDomainSaveJob * is in runtime version of libvirt. @@ -945,8 +937,7 @@ ocaml_libvirt_domain_restore_job (value connv, value strv) #ifndef HAVE_VIRDOMAINRESTOREJOB /* Symbol virDomainRestoreJob not found at compile time. */ not_supported ("virDomainRestoreJob"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virDomainRestoreJob * is in runtime version of libvirt. @@ -1005,8 +996,7 @@ ocaml_libvirt_domain_core_dump_job (value domv, value strv) #ifndef HAVE_VIRDOMAINCOREDUMPJOB /* Symbol virDomainCoreDumpJob not found at compile time. */ not_supported ("virDomainCoreDumpJob"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virDomainCoreDumpJob * is in runtime version of libvirt. @@ -1182,8 +1172,7 @@ ocaml_libvirt_domain_create_job (value domv) #ifndef HAVE_VIRDOMAINCREATEJOB /* Symbol virDomainCreateJob not found at compile time. */ not_supported ("virDomainCreateJob"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virDomainCreateJob * is in runtime version of libvirt. @@ -1564,8 +1553,7 @@ ocaml_libvirt_network_create_xml_job (value connv, value strv) #ifndef HAVE_VIRNETWORKCREATEXMLJOB /* Symbol virNetworkCreateXMLJob not found at compile time. */ not_supported ("virNetworkCreateXMLJob"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virNetworkCreateXMLJob * is in runtime version of libvirt. @@ -1644,8 +1632,7 @@ ocaml_libvirt_network_create_job (value netv) #ifndef HAVE_VIRNETWORKCREATEJOB /* Symbol virNetworkCreateJob not found at compile time. */ not_supported ("virNetworkCreateJob"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virNetworkCreateJob * is in runtime version of libvirt. @@ -1724,8 +1711,7 @@ ocaml_libvirt_storage_pool_free (value poolv) #ifndef HAVE_VIRSTORAGEPOOLFREE /* Symbol virStoragePoolFree not found at compile time. */ not_supported ("virStoragePoolFree"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virStoragePoolFree * is in runtime version of libvirt. @@ -1763,8 +1749,7 @@ ocaml_libvirt_storage_pool_destroy (value poolv) #ifndef HAVE_VIRSTORAGEPOOLDESTROY /* Symbol virStoragePoolDestroy not found at compile time. */ not_supported ("virStoragePoolDestroy"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virStoragePoolDestroy * is in runtime version of libvirt. @@ -1802,8 +1787,7 @@ ocaml_libvirt_storage_pool_lookup_by_name (value connv, value strv) #ifndef HAVE_VIRSTORAGEPOOLLOOKUPBYNAME /* Symbol virStoragePoolLookupByName not found at compile time. */ not_supported ("virStoragePoolLookupByName"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virStoragePoolLookupByName * is in runtime version of libvirt. @@ -1841,8 +1825,7 @@ ocaml_libvirt_storage_pool_lookup_by_uuid (value connv, value uuidv) #ifndef HAVE_VIRSTORAGEPOOLLOOKUPBYUUID /* Symbol virStoragePoolLookupByUUID not found at compile time. */ not_supported ("virStoragePoolLookupByUUID"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virStoragePoolLookupByUUID * is in runtime version of libvirt. @@ -1880,8 +1863,7 @@ ocaml_libvirt_storage_pool_lookup_by_uuid_string (value connv, value strv) #ifndef HAVE_VIRSTORAGEPOOLLOOKUPBYUUIDSTRING /* Symbol virStoragePoolLookupByUUIDString not found at compile time. */ not_supported ("virStoragePoolLookupByUUIDString"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virStoragePoolLookupByUUIDString * is in runtime version of libvirt. @@ -1919,8 +1901,7 @@ ocaml_libvirt_storage_pool_get_name (value poolv) #ifndef HAVE_VIRSTORAGEPOOLGETNAME /* Symbol virStoragePoolGetName not found at compile time. */ not_supported ("virStoragePoolGetName"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virStoragePoolGetName * is in runtime version of libvirt. @@ -1957,8 +1938,7 @@ ocaml_libvirt_storage_pool_get_xml_desc (value poolv) #ifndef HAVE_VIRSTORAGEPOOLGETXMLDESC /* Symbol virStoragePoolGetXMLDesc not found at compile time. */ not_supported ("virStoragePoolGetXMLDesc"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virStoragePoolGetXMLDesc * is in runtime version of libvirt. @@ -1996,8 +1976,7 @@ ocaml_libvirt_storage_pool_get_uuid (value poolv) #ifndef HAVE_VIRSTORAGEPOOLGETUUID /* Symbol virStoragePoolGetUUID not found at compile time. */ not_supported ("virStoragePoolGetUUID"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virStoragePoolGetUUID * is in runtime version of libvirt. @@ -2037,8 +2016,7 @@ ocaml_libvirt_storage_pool_get_uuid_string (value poolv) #ifndef HAVE_VIRSTORAGEPOOLGETUUIDSTRING /* Symbol virStoragePoolGetUUIDString not found at compile time. */ not_supported ("virStoragePoolGetUUIDString"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virStoragePoolGetUUIDString * is in runtime version of libvirt. @@ -2076,8 +2054,7 @@ ocaml_libvirt_storage_pool_create_xml (value connv, value strv) #ifndef HAVE_VIRSTORAGEPOOLCREATEXML /* Symbol virStoragePoolCreateXML not found at compile time. */ not_supported ("virStoragePoolCreateXML"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virStoragePoolCreateXML * is in runtime version of libvirt. @@ -2115,8 +2092,7 @@ ocaml_libvirt_storage_pool_define_xml (value connv, value strv) #ifndef HAVE_VIRSTORAGEPOOLDEFINEXML /* Symbol virStoragePoolDefineXML not found at compile time. */ not_supported ("virStoragePoolDefineXML"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virStoragePoolDefineXML * is in runtime version of libvirt. @@ -2154,8 +2130,7 @@ ocaml_libvirt_storage_pool_build (value poolv, value iv) #ifndef HAVE_VIRSTORAGEPOOLBUILD /* Symbol virStoragePoolBuild not found at compile time. */ not_supported ("virStoragePoolBuild"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virStoragePoolBuild * is in runtime version of libvirt. @@ -2191,8 +2166,7 @@ ocaml_libvirt_storage_pool_undefine (value poolv) #ifndef HAVE_VIRSTORAGEPOOLUNDEFINE /* Symbol virStoragePoolUndefine not found at compile time. */ not_supported ("virStoragePoolUndefine"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virStoragePoolUndefine * is in runtime version of libvirt. @@ -2227,8 +2201,7 @@ ocaml_libvirt_storage_pool_create (value poolv) #ifndef HAVE_VIRSTORAGEPOOLCREATE /* Symbol virStoragePoolCreate not found at compile time. */ not_supported ("virStoragePoolCreate"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virStoragePoolCreate * is in runtime version of libvirt. @@ -2263,8 +2236,7 @@ ocaml_libvirt_storage_pool_delete (value poolv, value iv) #ifndef HAVE_VIRSTORAGEPOOLDELETE /* Symbol virStoragePoolDelete not found at compile time. */ not_supported ("virStoragePoolDelete"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virStoragePoolDelete * is in runtime version of libvirt. @@ -2300,8 +2272,7 @@ ocaml_libvirt_storage_pool_refresh (value poolv) #ifndef HAVE_VIRSTORAGEPOOLREFRESH /* Symbol virStoragePoolRefresh not found at compile time. */ not_supported ("virStoragePoolRefresh"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virStoragePoolRefresh * is in runtime version of libvirt. @@ -2336,8 +2307,7 @@ ocaml_libvirt_storage_pool_get_autostart (value poolv) #ifndef HAVE_VIRSTORAGEPOOLGETAUTOSTART /* Symbol virStoragePoolGetAutostart not found at compile time. */ not_supported ("virStoragePoolGetAutostart"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virStoragePoolGetAutostart * is in runtime version of libvirt. @@ -2372,8 +2342,7 @@ ocaml_libvirt_storage_pool_set_autostart (value poolv, value bv) #ifndef HAVE_VIRSTORAGEPOOLSETAUTOSTART /* Symbol virStoragePoolSetAutostart not found at compile time. */ not_supported ("virStoragePoolSetAutostart"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virStoragePoolSetAutostart * is in runtime version of libvirt. @@ -2410,8 +2379,7 @@ ocaml_libvirt_storage_pool_num_of_volumes (value poolv) #ifndef HAVE_VIRSTORAGEPOOLNUMOFVOLUMES /* Symbol virStoragePoolNumOfVolumes not found at compile time. */ not_supported ("virStoragePoolNumOfVolumes"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virStoragePoolNumOfVolumes * is in runtime version of libvirt. @@ -2446,8 +2414,7 @@ ocaml_libvirt_storage_pool_list_volumes (value poolv, value iv) #ifndef HAVE_VIRSTORAGEPOOLLISTVOLUMES /* Symbol virStoragePoolListVolumes not found at compile time. */ not_supported ("virStoragePoolListVolumes"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virStoragePoolListVolumes * is in runtime version of libvirt. @@ -2492,8 +2459,7 @@ ocaml_libvirt_storage_vol_free (value volv) #ifndef HAVE_VIRSTORAGEVOLFREE /* Symbol virStorageVolFree not found at compile time. */ not_supported ("virStorageVolFree"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virStorageVolFree * is in runtime version of libvirt. @@ -2531,8 +2497,7 @@ ocaml_libvirt_storage_vol_delete (value volv, value iv) #ifndef HAVE_VIRSTORAGEVOLDELETE /* Symbol virStorageVolDelete not found at compile time. */ not_supported ("virStorageVolDelete"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virStorageVolDelete * is in runtime version of libvirt. @@ -2568,8 +2533,7 @@ ocaml_libvirt_storage_vol_lookup_by_name (value poolv, value strv) #ifndef HAVE_VIRSTORAGEVOLLOOKUPBYNAME /* Symbol virStorageVolLookupByName not found at compile time. */ not_supported ("virStorageVolLookupByName"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virStorageVolLookupByName * is in runtime version of libvirt. @@ -2609,8 +2573,7 @@ ocaml_libvirt_storage_vol_lookup_by_key (value connv, value strv) #ifndef HAVE_VIRSTORAGEVOLLOOKUPBYKEY /* Symbol virStorageVolLookupByKey not found at compile time. */ not_supported ("virStorageVolLookupByKey"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virStorageVolLookupByKey * is in runtime version of libvirt. @@ -2648,8 +2611,7 @@ ocaml_libvirt_storage_vol_lookup_by_path (value connv, value strv) #ifndef HAVE_VIRSTORAGEVOLLOOKUPBYPATH /* Symbol virStorageVolLookupByPath not found at compile time. */ not_supported ("virStorageVolLookupByPath"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virStorageVolLookupByPath * is in runtime version of libvirt. @@ -2687,8 +2649,7 @@ ocaml_libvirt_storage_vol_create_xml (value poolv, value strv) #ifndef HAVE_VIRSTORAGEVOLCREATEXML /* Symbol virStorageVolCreateXML not found at compile time. */ not_supported ("virStorageVolCreateXML"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virStorageVolCreateXML * is in runtime version of libvirt. @@ -2728,8 +2689,7 @@ ocaml_libvirt_storage_vol_get_xml_desc (value volv) #ifndef HAVE_VIRSTORAGEVOLGETXMLDESC /* Symbol virStorageVolGetXMLDesc not found at compile time. */ not_supported ("virStorageVolGetXMLDesc"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virStorageVolGetXMLDesc * is in runtime version of libvirt. @@ -2767,8 +2727,7 @@ ocaml_libvirt_storage_vol_get_path (value volv) #ifndef HAVE_VIRSTORAGEVOLGETPATH /* Symbol virStorageVolGetPath not found at compile time. */ not_supported ("virStorageVolGetPath"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virStorageVolGetPath * is in runtime version of libvirt. @@ -2806,8 +2765,7 @@ ocaml_libvirt_storage_vol_get_key (value volv) #ifndef HAVE_VIRSTORAGEVOLGETKEY /* Symbol virStorageVolGetKey not found at compile time. */ not_supported ("virStorageVolGetKey"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virStorageVolGetKey * is in runtime version of libvirt. @@ -2844,8 +2802,7 @@ ocaml_libvirt_storage_vol_get_name (value volv) #ifndef HAVE_VIRSTORAGEVOLGETNAME /* Symbol virStorageVolGetName not found at compile time. */ not_supported ("virStorageVolGetName"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virStorageVolGetName * is in runtime version of libvirt. @@ -2882,8 +2839,7 @@ ocaml_libvirt_storage_pool_lookup_by_volume (value volv) #ifndef HAVE_VIRSTORAGEPOOLLOOKUPBYVOLUME /* Symbol virStoragePoolLookupByVolume not found at compile time. */ not_supported ("virStoragePoolLookupByVolume"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virStoragePoolLookupByVolume * is in runtime version of libvirt. @@ -2922,8 +2878,7 @@ ocaml_libvirt_job_free (value jobv) #ifndef HAVE_VIRJOBFREE /* Symbol virJobFree not found at compile time. */ not_supported ("virJobFree"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virJobFree * is in runtime version of libvirt. @@ -2961,8 +2916,7 @@ ocaml_libvirt_job_cancel (value jobv) #ifndef HAVE_VIRJOBCANCEL /* Symbol virJobCancel not found at compile time. */ not_supported ("virJobCancel"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virJobCancel * is in runtime version of libvirt. @@ -2997,8 +2951,7 @@ ocaml_libvirt_job_get_network (value jobv) #ifndef HAVE_VIRJOBGETNETWORK /* Symbol virJobGetNetwork not found at compile time. */ not_supported ("virJobGetNetwork"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virJobGetNetwork * is in runtime version of libvirt. @@ -3037,8 +2990,7 @@ ocaml_libvirt_job_get_domain (value jobv) #ifndef HAVE_VIRJOBGETDOMAIN /* Symbol virJobGetDomain not found at compile time. */ not_supported ("virJobGetDomain"); - /* Suppresses a compiler warning. */ - (void) caml__frame; + CAMLnoreturn; #else /* Check that the symbol virJobGetDomain * is in runtime version of libvirt. -- cgit v1.1 From 6d1e1917a4c8ae136276c3c308d563d4940c982a Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Wed, 19 Mar 2008 11:34:00 +0000 Subject: Install the *.cmi files as well. --- libvirt/Makefile.in | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libvirt/Makefile.in b/libvirt/Makefile.in index 4b203fd..66ffc75 100644 --- a/libvirt/Makefile.in +++ b/libvirt/Makefile.in @@ -120,6 +120,7 @@ libvirt_version.cmo: libvirt_version.cmi libvirt_version.cmi: libvirt_version.mli install: - ocamlfind install libvirt ../META *.so *.a *.cmx *.cma *.cmxa *.mli + ocamlfind install libvirt \ + ../META *.so *.a *.cmx *.cma *.cmxa *.cmi *.mli include ../Make.rules -- cgit v1.1 From d84d67b71144625452b186db38abe876bf877fea Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Wed, 19 Mar 2008 11:35:11 +0000 Subject: Version 0.4.1.1 for release. --- configure.ac | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index ba9be91..427c680 100644 --- a/configure.ac +++ b/configure.ac @@ -17,7 +17,7 @@ dnl Process this file with autoconf to produce a configure script. -AC_INIT(ocaml-libvirt,0.4.1.0) +AC_INIT(ocaml-libvirt,0.4.1.1) dnl Check for basic C environment. AC_PROG_CC -- cgit v1.1 From b2a619b32d66d94779b7fef0363aecfa17cef6f7 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Fri, 28 Mar 2008 16:47:27 +0000 Subject: Basic infrastructure for using gettext to translate. --- .hgignore | 6 +++++ README | 15 ++++++++++- configure.ac | 43 +++++++++++++++++++++++++++++++ po/LINGUAS | 1 + po/Makefile.in | 79 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ po/POTFILES | 22 ++++++++++++++++ po/ja.po | 25 ++++++++++++++++++ po/virt-top.pot | 31 ++++++++++++++++++++++ 8 files changed, 221 insertions(+), 1 deletion(-) create mode 100644 po/LINGUAS create mode 100644 po/Makefile.in create mode 100644 po/POTFILES create mode 100644 po/ja.po create mode 100644 po/virt-top.pot diff --git a/.hgignore b/.hgignore index 3f4fb29..f8063da 100644 --- a/.hgignore +++ b/.hgignore @@ -35,3 +35,9 @@ virt-top/virt-top virt-df/virt-df wininstaller.nsis *.orig +mlvirsh/mlvirsh_gettext.ml +virt-ctrl/virt_ctrl_gettext.ml +virt-df/virt_df_gettext.ml +virt-top/virt_top_gettext.ml +po/*.mo +po/*.po.bak diff --git a/README b/README index 8ae896e..32686c5 100644 --- a/README +++ b/README @@ -35,7 +35,9 @@ the packages below if you want to build from source. ocaml | R | | R | R | R | >= 3.08 | | | | | | | | | - findlib | HR | R | HR | HR | n/a + findlib | HR | R | HR | HR | Note [1] + | | | | | + ocaml-gettext | R | R | R | R | Note [2] | | | | | MinGW + MSYS | | | | | R --------------+----------+---------+---------+----------+--------- @@ -69,6 +71,12 @@ the packages below if you want to build from source. O = optional (just improves functionality, but not required) n/a = not available +Note [1]: Findlib was recently ported to Windows and in future we may +require it because it will let us remove a lot of hacks from the +Makefiles. + +Note [2]: It's not clear if ocaml-gettext works on Windows. + Where to get the packages: libvirt >= 0.2.1 from http://libvirt.org/ (get the latest version available) @@ -80,6 +88,11 @@ Where to get the packages: findlib from http://www.ocaml-programming.de/packages/ or packaged in Debian, Ubuntu and Fedora as 'ocaml-findlib' + ocaml-gettext from http://www.le-gall.net/sylvain+violaine/ocaml-gettext.html + + patch for OCaml 3.10: + http://www.annexia.org/tmp/ocaml-gettext-0.2.0-20080321.patch + (This should appear in ocaml-gettext 0.3.0 shortly). + MinGW + MSYS from http://www.mingw.org/ (only needed for Windows) ocamldoc part of OCaml itself diff --git a/configure.ac b/configure.ac index 427c680..57517f8 100644 --- a/configure.ac +++ b/configure.ac @@ -193,6 +193,7 @@ if test "x$OCAMLFIND" != "x"; then AC_CHECK_OCAML_PKG(xml-light) AC_CHECK_OCAML_PKG(csv) AC_CHECK_OCAML_PKG(dbus) + AC_CHECK_OCAML_PKG(gettext) dnl Need to check which version of calendar is installed. AC_CHECK_OCAML_MODULE(calendar,pkg_calendar2,CalendarLib.Date,[+calendar]) @@ -208,6 +209,7 @@ if test "x$OCAMLFIND" != "x"; then AC_SUBST(pkg_xml_light) AC_SUBST(pkg_csv) AC_SUBST(pkg_dbus) + AC_SUBST(pkg_gettext) AC_SUBST(pkg_calendar) AC_SUBST(pkg_calendar2) else @@ -227,6 +229,7 @@ else AC_CHECK_OCAML_MODULE(xml-light,pkg_xml_light,Xml,[+xml-light]) AC_CHECK_OCAML_MODULE(csv,pkg_csv,Csv,[+csv]) AC_CHECK_OCAML_MODULE(dbus,pkg_dbus,DBus,[+dbus]) + AC_CHECK_OCAML_MODULE(gettext,pkg_gettext,Gettext,[+gettext]) dnl XXX Version check - see above. AC_CHECK_OCAML_MODULE(calendar,pkg_calendar,Calendar,[+calendar]) fi @@ -250,6 +253,9 @@ AC_CHECK_PROG(HAVE_PERLDOC,perldoc,perldoc) dnl Check for optional gdk-pixbuf-mlsource (for icons). AC_CHECK_PROG(HAVE_GDK_PIXBUF_MLSOURCE,gdk-pixbuf-mlsource,gdk-pixbuf-mlsource) +dnl Check for recommended ocaml-gettext tool. +AC_CHECK_PROG(OCAML_GETTEXT,ocaml-gettext,ocaml-gettext) + dnl Check for optional NSIS (for building a Windows installer). AC_ARG_WITH([nsis], [AS_HELP_STRING([--with-nsis], @@ -339,6 +345,42 @@ AC_SUBST(GNUTLS_DLL_PATH) AC_SUBST(GTK_DLL_PATH) AC_SUBST(GTK_PATH) +dnl Write gettext modules for the programs. +dnl http://www.le-gall.net/sylvain+violaine/documentation/ocaml-gettext/html/reference-manual/ch03s04.html +for d in mlvirsh virt-ctrl virt-df virt-top; do + f=`echo $d | tr - _`_gettext.ml + AC_MSG_NOTICE([creating $d/$f]) + rm -f $d/$f + echo "(* This file is generated automatically by ./configure. *)" > $d/$f + if test "x$pkg_gettext" != "xno"; then + # Gettext module is available, so use it. + cat <>$d/$f +module Gettext = Gettext.Program ( + struct + let textdomain = "$d" + let codeset = None + let dir = None + let dependencies = [[]] + end +) (GettextStub.Native) +EOT + else + # No gettext module is available, so fake the translation functions. + cat <>$d/$f +module Gettext = struct + external s_ : string -> string = "%identity" + external f_ : ('a -> 'b, 'c, 'd) format -> ('a -> 'b, 'c, 'd) format + = "%identity" + let sn_ : string -> string -> int -> string + = fun s p n -> if n = 1 then s else p + let fn_ : ('a -> 'b, 'c, 'd) format -> ('a -> 'b, 'c, 'd) format -> int + -> ('a -> 'b, 'c, 'd) format + = fun s p n -> if n = 1 then s else p +end +EOT + fi +done + dnl Summary. echo "------------------------------------------------------------" echo "Thanks for downloading" $PACKAGE_STRING @@ -351,6 +393,7 @@ AC_CONFIG_FILES([META libvirt/libvirt_version.ml Makefile Make.rules + po/Makefile libvirt/Makefile examples/Makefile mlvirsh/Makefile diff --git a/po/LINGUAS b/po/LINGUAS new file mode 100644 index 0000000..bef7f4a --- /dev/null +++ b/po/LINGUAS @@ -0,0 +1 @@ +ja diff --git a/po/Makefile.in b/po/Makefile.in new file mode 100644 index 0000000..9398e2f --- /dev/null +++ b/po/Makefile.in @@ -0,0 +1,79 @@ +# Makefile for po subdirectory. +# @configure_input@ +# +# Copyright (C) 2007-2008 Red Hat Inc. +# Written by 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +OCAML_GETTEXT_PACKAGE = virt-top +LINGUAS = $(shell cat LINGUAS) +SOURCES = POTFILES + +OCAML_GETTEXT = @OCAML_GETTEXT@ +OCAML_GETTEXT_EXTRACT_OPTIONS = +OCAML_GETTEXT_COMPILE_OPTIONS = +OCAML_GETTEXT_INSTALL_OPTIONS = +OCAML_GETTEXT_MERGE_OPTIONS = + +PODIR = @prefix@/share/locale + +POFILES = $(addsuffix .po,$(LINGUAS)) +MOFILES = $(addsuffix .mo,$(LINGUAS)) +POTFILE = $(OCAML_GETTEXT_PACKAGE).pot + +all: $(MOFILES) $(POTFILE) + +install: install-po + +uninstall: uninstall-po + +clean:: clean-po + +%.mo: %.po + $(OCAML_GETTEXT) --action compile $(OCAML_GETTEXT_COMPILE_OPTIONS) \ + --compile-output $@ $^ + +%.pot: $(SOURCES) $(shell cat $(SOURCES)) + $(OCAML_GETTEXT) --action extract $(OCAML_GETTEXT_EXTRACT_OPTIONS) \ + --extract-pot $@ $< + +# Also includes a fix for incorrectly escaped multi-byte sequences. +%.po: $(POTFILE) + $(OCAML_GETTEXT) --action merge $(OCAML_GETTEXT_MERGE_OPTIONS) \ + --merge-pot $(POTFILE) $@ + mv $@ $@.orig + perl -wpe 's/\\(\d{3})/pack "C*", $$1/ge' < $@.orig > $@ + +$(BUILDPO): + mkdir -p $(BUILDPO) + +.PRECIOUS: $(POTFILE) + +install-po: $(MOFILES) + $(OCAML_GETTEXT) --action install $(OCAML_GETTEXT_INSTALL_OPTIONS) \ + --install-textdomain $(OCAML_GETTEXT_PACKAGE) \ + --install-destdir $(PODIR) $(MOFILES) + +uninstall-po: + $(OCAML_GETTEXT) --action uninstall $(OCAML_GETTEXT_INSTALL_OPTIONS) \ + --uninstall-textdomain $(OCAML_GETTEXT_PACKAGE) \ + --uninstall-orgdir $(PODIR) $(MOFILES) + +clean-po: + -$(OCAML_GETTEXT) --action uninstall $(OCAML_GETTEXT_INSTALL_OPTIONS) \ + --uninstall-textdomain $(OCAML_GETTEXT_PACKAGE) \ + --uninstall-orgdir $(BUILDPO) $(MOFILES) + -$(RM) $(MOFILES) diff --git a/po/POTFILES b/po/POTFILES new file mode 100644 index 0000000..938a847 --- /dev/null +++ b/po/POTFILES @@ -0,0 +1,22 @@ +../mlvirsh/mlvirsh.ml +../virt-ctrl/mingw-gcc-wrapper.ml +../virt-ctrl/vc_connection_dlg.ml +../virt-ctrl/vc_connections.ml +../virt-ctrl/vc_dbus.ml +../virt-ctrl/vc_domain_ops.ml +../virt-ctrl/vc_helpers.ml +../virt-ctrl/vc_icons.ml +../virt-ctrl/vc_mainwindow.ml +../virt-ctrl/virt_ctrl.ml +../virt-df/virt_df_ext2.ml +../virt-df/virt_df_linux_swap.ml +../virt-df/virt_df_lvm2.ml +../virt-df/virt_df_main.ml +../virt-df/virt_df.ml +../virt-top/virt_top_calendar1.ml +../virt-top/virt_top_calendar2.ml +../virt-top/virt_top_csv.ml +../virt-top/virt_top_main.ml +../virt-top/virt_top.ml +../virt-top/virt_top_utils.ml +../virt-top/virt_top_xml.ml diff --git a/po/ja.po b/po/ja.po new file mode 100644 index 0000000..609d69d --- /dev/null +++ b/po/ja.po @@ -0,0 +1,25 @@ +msgid "" +msgstr "" +"Project-Id-Version: virt-p2v--devel\n" +"Report-Msgid-Bugs-To: rjones@redhat.com\n" +"POT-Creation-Date: 2008-03-22 15:53+0000\n" +"PO-Revision-Date: 2008-03-23 20:29+0000\n" +"Last-Translator: Naoko - \n" +"Language-Team: Japanese\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" +"Plural-Forms: nplurals=1; plural=0;\n" + +#: ../mlvirsh/mlvirsh.ml:35 +msgid "Hypervisor connection URI" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:36 +msgid "Read-only connection" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:40 +msgid "Synopsis:\n %s [options] [command]\n\nList of all commands:\n %s help\n\nFull description of a single command:\n %s help command\n\nOptions:" +msgstr "" + diff --git a/po/virt-top.pot b/po/virt-top.pot new file mode 100644 index 0000000..0a66b9e --- /dev/null +++ b/po/virt-top.pot @@ -0,0 +1,31 @@ +# SOME DESCRIPTIVE TITLE. +# Copyright (C) YEAR THE PACKAGE'S COPYRIGHT HOLDER +# This file is distributed under the same license as the PACKAGE package. +# FIRST AUTHOR , YEAR. +# +#, fuzzy +msgid "" +msgstr "" +"Project-Id-Version: PACKAGE VERSION\n" +"Report-Msgid-Bugs-To: \n" +"POT-Creation-Date: 2008-03-28 13:03+0000\n" +"PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" +"Last-Translator: FULL NAME \n" +"Language-Team: LANGUAGE \n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=CHARSET\n" +"Content-Transfer-Encoding: 8bit\n" +"Plural-Forms: nplurals=INTEGER; plural=EXPRESSION;\n" + +#: ../mlvirsh/mlvirsh.ml:35 +msgid "Hypervisor connection URI" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:36 +msgid "Read-only connection" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:40 +msgid "Synopsis:\n %s [options] [command]\n\nList of all commands:\n %s help\n\nFull description of a single command:\n %s help command\n\nOptions:" +msgstr "" + -- cgit v1.1 From 7c5ff9eee393016f8aca13fd32e32977f512a65d Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Fri, 28 Mar 2008 16:47:41 +0000 Subject: Make mlvirsh localizable. --- mlvirsh/.depend | 4 +- mlvirsh/Makefile.in | 31 ++++-- mlvirsh/mlvirsh.ml | 278 +++++++++++++++++++++++++++------------------------- 3 files changed, 167 insertions(+), 146 deletions(-) diff --git a/mlvirsh/.depend b/mlvirsh/.depend index a346edd..7dbe514 100644 --- a/mlvirsh/.depend +++ b/mlvirsh/.depend @@ -1,2 +1,2 @@ -mlvirsh.cmo: ../libvirt/libvirt.cmi -mlvirsh.cmx: ../libvirt/libvirt.cmx +mlvirsh.cmo: mlvirsh_gettext.cmo ../libvirt/libvirt.cmi +mlvirsh.cmx: mlvirsh_gettext.cmx ../libvirt/libvirt.cmx diff --git a/mlvirsh/Makefile.in b/mlvirsh/Makefile.in index 197f732..23d6e1e 100644 --- a/mlvirsh/Makefile.in +++ b/mlvirsh/Makefile.in @@ -21,6 +21,8 @@ prefix = @prefix@ exec_prefix = @exec_prefix@ bindir = @bindir@ +pkg_gettext = @pkg_gettext@ + OCAMLFIND = @OCAMLFIND@ ifneq ($(OCAMLFIND),) @@ -39,6 +41,19 @@ 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 @@ -50,23 +65,23 @@ all: $(BYTE_TARGETS) opt: $(OPT_TARGETS) ifneq ($(OCAMLFIND),) -mlvirsh: mlvirsh.cmo +mlvirsh: $(OBJS) $(OCAMLFIND) ocamlc $(OCAMLCPACKAGES) $(OCAMLCFLAGS) $(OCAMLCLIBS) \ - ../libvirt/mllibvirt.cma -o $@ $< + ../libvirt/mllibvirt.cma -o $@ $^ -mlvirsh.opt: mlvirsh.cmx +mlvirsh.opt: $(XOBJS) $(OCAMLFIND) ocamlopt \ $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \ - ../libvirt/mllibvirt.cmxa -o $@ $< + ../libvirt/mllibvirt.cmxa -o $@ $^ else -mlvirsh: mlvirsh.cmo +mlvirsh: $(OBJS) $(OCAMLC) $(OCAMLCINCS) $(OCAMLCFLAGS) $(OCAMLCLIBS) \ - ../libvirt/mllibvirt.cma -o $@ $< + ../libvirt/mllibvirt.cma -o $@ $^ -mlvirsh.opt: mlvirsh.cmx +mlvirsh.opt: $(XOBJS) $(OCAMLOPT) \ $(OCAMLOPTINCS) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \ - ../libvirt/mllibvirt.cmxa -o $@ $< + ../libvirt/mllibvirt.cmxa -o $@ $^ endif install: diff --git a/mlvirsh/mlvirsh.ml b/mlvirsh/mlvirsh.ml index 8052506..ba4860f 100644 --- a/mlvirsh/mlvirsh.ml +++ b/mlvirsh/mlvirsh.ml @@ -18,6 +18,7 @@ *) open Printf +open Mlvirsh_gettext.Gettext module C = Libvirt.Connect module D = Libvirt.Domain @@ -31,21 +32,22 @@ let name = ref "" let readonly = ref false let argspec = Arg.align [ - "-c", Arg.Set_string name, "URI Hypervisor connection URI"; - "-r", Arg.Set readonly, " Read-only connection"; + "-c", Arg.Set_string name, "URI " ^ s_ "Hypervisor connection URI"; + "-r", Arg.Set readonly, " " ^ s_ "Read-only connection"; ] -let usage_msg = "\ -Synopsis: - " ^ program_name ^ " [options] [command] +let usage_msg = + sprintf (f_ "Synopsis: + %s [options] [command] List of all commands: - " ^ program_name ^ " help + %s help Full description of a single command: - " ^ program_name ^ " help command + %s help command -Options:" +Options:") + program_name program_name program_name let add_extra_arg, get_extra_args = let extra_args = ref [] in @@ -155,35 +157,35 @@ let do_command = *) let cmd0 print fn = function (* Command with no args. *) | [] -> print (fn ()) - | _ -> failwith "incorrect number of arguments for function" + | _ -> 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 "incorrect number of arguments for function" + | _ -> 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 "incorrect number of arguments for function" + | _ -> 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 "incorrect number of arguments for function" + | _ -> 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 "incorrect number of arguments for function" + | _ -> 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 "incorrect number of arguments for function" + | _ -> 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 "incorrect number of arguments for function" + | _ -> failwith (s_ "incorrect number of arguments for function") in let cmdN print fn = (* Command with any number of args. *) fun args -> print (fn args) @@ -192,12 +194,12 @@ let do_command = (* Get the connection or fail if we don't have one. *) let rec get_full_connection () = match !conn with - | No_connection -> failwith "not connected to the hypervisor" - | RO _ -> failwith "tried to do read-write operation on read-only hypervisor connection" + | 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 "not connected to the hypervisor" + | No_connection -> failwith (s_ "not connected to the hypervisor") | RO conn -> conn | RW conn -> C.const conn (* @@ -215,13 +217,13 @@ let do_command = (* Parsing of command arguments. *) let string_of_readonly = function | "readonly" | "read-only" | "ro" -> true - | _ -> failwith "flag should be 'readonly'" + | _ -> 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 "setting should be 'on' or 'off'" + | _ -> failwith (sprintf (f_ "setting should be '%s' or '%s'") "on" "off") in let domain_of_string conn str = try @@ -237,8 +239,8 @@ let do_command = ) with Libvirt.Virterror err -> - failwith ("domain " ^ str ^ ": not found. Additional info: " ^ - Libvirt.Virterror.to_string 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 @@ -248,12 +250,12 @@ let do_command = N.lookup_by_name conn str with Libvirt.Virterror err -> - failwith ("network " ^ str ^ ": not found. Additional info: " ^ - Libvirt.Virterror.to_string 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 "expected field value pairs, but got an odd number of arguments" + | [_] -> 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)) @@ -282,18 +284,18 @@ let do_command = printf "%d.%d.%d\n" major minor release in let string_of_domain_state = function - | D.InfoNoState -> "unknown" - | D.InfoRunning -> "running" - | D.InfoBlocked -> "blocked" - | D.InfoPaused -> "paused" - | D.InfoShutdown -> "shutdown" - | D.InfoShutoff -> "shutoff" - | D.InfoCrashed -> "crashed" + | 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 -> "offline" - | D.VcpuRunning -> "running" - | D.VcpuBlocked -> "blocked" + | D.VcpuOffline -> s_ "offline" + | D.VcpuRunning -> s_ "running" + | D.VcpuBlocked -> s_ "blocked" in let print_domain_array doms = Array.iter ( @@ -319,24 +321,26 @@ let do_command = ) nets in let print_node_info info = - printf "model: %s\n" info.C.model; - printf "memory: %Ld K\n" info.C.memory; - printf "cpus: %d\n" info.C.cpus; - printf "mhz: %d\n" info.C.mhz; - printf "nodes: %d\n" info.C.nodes; - printf "sockets: %d\n" info.C.sockets; - printf "cores: %d\n" info.C.cores; - printf "threads: %d\n" info.C.threads; + 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 = - printf "state: %s\n" (string_of_domain_state info.D.state); - printf "max_mem: %Ld K\n" info.D.max_mem; - printf "memory: %Ld K\n" info.D.memory; - printf "nr_virt_cpu: %d\n" info.D.nr_virt_cpu; - printf "cpu_time: %Ld ns\n" info.D.cpu_time; + 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 ( @@ -353,12 +357,12 @@ let do_command = in let print_vcpu_info (ncpus, vcpu_infos, cpumaps, maplen, maxcpus) = for n = 0 to ncpus-1 do - printf "virtual CPU: %d\n" n; - printf " on physical CPU: %d\n" vcpu_infos.(n).D.cpu; - printf " current state: %s\n" - (string_of_vcpu_state vcpu_infos.(n).D.vcpu_state); - printf " CPU time: %Ld ns\n" vcpu_infos.(n).D.vcpu_time; - printf " CPU affinity: "; + 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; @@ -368,23 +372,23 @@ let do_command = 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 "read requests: %Ld\n" rd_req; - if rd_bytes >= 0L then printf "read bytes: %Ld\n" rd_bytes; - if wr_req >= 0L then printf "write requests: %Ld\n" wr_req; - if wr_bytes >= 0L then printf "write bytes: %Ld\n" wr_bytes; - if errs >= 0L then printf "errors: %Ld\n" 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 "rx bytes: %Ld\n" rx_bytes; - if rx_packets >= 0L then printf "rx packets: %Ld\n" rx_packets; - if rx_errs >= 0L then printf "rx errs: %Ld\n" rx_errs; - if rx_drop >= 0L then printf "rx dropped: %Ld\n" rx_drop; - if tx_bytes >= 0L then printf "tx bytes: %Ld\n" tx_bytes; - if tx_packets >= 0L then printf "tx packets: %Ld\n" tx_packets; - if tx_errs >= 0L then printf "tx errs: %Ld\n" tx_errs; - if tx_drop >= 0L then printf "tx dropped: %Ld\n" 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. *) @@ -392,17 +396,17 @@ let do_command = "attach-device", cmd2 no_return D.attach_device (arg_full_connection domain_of_string) input_file, - "Attach device to domain."; + s_ "Attach device to domain."; "autostart", cmd2 no_return D.set_autostart (arg_full_connection domain_of_string) boolean_of_string, - "Set whether a domain autostarts at boot."; + s_ "Set whether a domain autostarts at boot."; "capabilities", cmd0 print_endline (with_readonly_connection C.get_capabilities), - "Returns capabilities of hypervisor/driver."; + s_ "Returns capabilities of hypervisor/driver."; "close", cmd0 no_return close_connection, - "Close an existing hypervisor connection."; + s_ "Close an existing hypervisor connection."; "connect", cmd12 no_return (fun name readonly -> @@ -411,69 +415,69 @@ let do_command = | None | Some false -> conn := RW (C.connect ~name ()) | Some true -> conn := RO (C.connect_readonly ~name ()) ) string_of_string string_of_readonly, - "Open a new hypervisor connection."; + s_ "Open a new hypervisor connection."; "create", cmd1 no_return (fun xml -> D.create_linux (get_full_connection ()) xml) input_file, - "Create a domain from an XML file."; + s_ "Create a domain from an XML file."; "define", cmd1 no_return (fun xml -> D.define_xml (get_full_connection ()) xml) input_file, - "Define (but don't start) a domain from an XML 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, - "Detach device from domain."; + s_ "Detach device from domain."; "destroy", cmd1 no_return D.destroy (arg_full_connection domain_of_string), - "Destroy a domain."; + s_ "Destroy a domain."; "domblkstat", cmd2 print_block_stats D.block_stats (arg_readonly_connection domain_of_string) string_of_string, - "Display the block device statistics for a domain."; + s_ "Display the block device statistics for a domain."; "domid", cmd1 print_int D.get_id (arg_readonly_connection domain_of_string), - "Print the ID of a domain."; + s_ "Print the ID of a domain."; "domifstat", cmd2 print_interface_stats D.interface_stats (arg_readonly_connection domain_of_string) string_of_string, - "Display the network interface statistics for a domain."; + s_ "Display the network interface statistics for a domain."; "dominfo", cmd1 print_domain_info D.get_info (arg_readonly_connection domain_of_string), - "Print the domain info."; + s_ "Print the domain info."; "dommaxmem", cmd1 print_int64 D.get_max_memory (arg_readonly_connection domain_of_string), - "Print the max memory (in kilobytes) of a domain."; + s_ "Print the max memory (in kilobytes) of a domain."; "dommaxvcpus", cmd1 print_int D.get_max_vcpus (arg_readonly_connection domain_of_string), - "Print the max VCPUs of a domain."; + s_ "Print the max VCPUs of a domain."; "domname", cmd1 print_endline D.get_name (arg_readonly_connection domain_of_string), - "Print the name of a domain."; + s_ "Print the name of a domain."; "domostype", cmd1 print_endline D.get_os_type (arg_readonly_connection domain_of_string), - "Print the OS type of a domain."; + s_ "Print the OS type of a domain."; "domstate", cmd1 print_domain_state D.get_info (arg_readonly_connection domain_of_string), - "Print the domain state."; + s_ "Print the domain state."; "domuuid", cmd1 print_endline D.get_uuid_string (arg_readonly_connection domain_of_string), - "Print the UUID of a domain."; + s_ "Print the UUID of a domain."; "dump", cmd2 no_return D.core_dump (arg_full_connection domain_of_string) string_of_string, - "Core dump a domain to a file for analysis."; + s_ "Core dump a domain to a file for analysis."; "dumpxml", cmd1 print_endline D.get_xml_desc (arg_full_connection domain_of_string), - "Print the XML description of a domain."; + s_ "Print the XML description of a domain."; "freecell", cmd012 print_int64_array ( fun start max -> @@ -486,14 +490,14 @@ let do_command = | Some start, Some max -> C.node_get_cells_free_memory conn start max ) int_of_string int_of_string, - "Display free memory for machine, NUMA cell or range of cells"; + 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), - "Print whether a domain autostarts at boot."; + s_ "Print whether a domain autostarts at boot."; "hostname", cmd0 print_endline (with_readonly_connection C.get_hostname), - "Print the hostname."; + s_ "Print the hostname."; "list", cmd0 print_domain_array (fun () -> @@ -501,7 +505,7 @@ let do_command = let n = C.num_of_domains c in let domids = C.list_domains c n in Array.map (D.lookup_by_id c) domids), - "List the running domains."; + s_ "List the running domains."; "list-defined", cmd0 print_domain_array (fun () -> @@ -509,40 +513,40 @@ let do_command = 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), - "List the defined but not running domains."; + s_ "List the defined but not running domains."; "quit", cmd0 no_return (fun () -> exit 0), - "Quit the interactive terminal."; + s_ "Quit the interactive terminal."; "maxvcpus", cmd0 print_int (fun () -> C.get_max_vcpus (get_readonly_connection ()) ()), - "Print the max VCPUs available."; + s_ "Print the max VCPUs available."; "net-autostart", cmd2 no_return N.set_autostart (arg_full_connection network_of_string) boolean_of_string, - "Set whether a network autostarts at boot."; + s_ "Set whether a network autostarts at boot."; "net-bridgename", cmd1 print_endline N.get_bridge_name (arg_readonly_connection network_of_string), - "Print the bridge name of a network."; + s_ "Print the bridge name of a network."; "net-create", cmd1 no_return (fun xml -> N.create_xml (get_full_connection ()) xml) input_file, - "Create a network from an XML 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, - "Define (but don't start) a network from an XML 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), - "Destroy a network."; + s_ "Destroy a network."; "net-dumpxml", cmd1 print_endline N.get_xml_desc (arg_full_connection network_of_string), - "Print the XML description of a network."; + s_ "Print the XML description of a network."; "net-get-autostart", cmd1 print_bool N.get_autostart (arg_full_connection network_of_string), - "Print whether a network autostarts at boot."; + s_ "Print whether a network autostarts at boot."; "net-list", cmd0 print_network_array (fun () -> @@ -550,7 +554,7 @@ let do_command = let n = C.num_of_networks c in let nets = C.list_networks c n in Array.map (N.lookup_by_name c) nets), - "List the active networks."; + s_ "List the active networks."; "net-list-defined", cmd0 print_network_array (fun () -> @@ -558,52 +562,52 @@ let do_command = 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), - "List the defined but inactive networks."; + s_ "List the defined but inactive networks."; "net-name", cmd1 print_endline N.get_name (arg_readonly_connection network_of_string), - "Print the name of a network."; + s_ "Print the name of a network."; "net-start", cmd1 no_return N.create (arg_full_connection network_of_string), - "Start a previously defined inactive network."; + s_ "Start a previously defined inactive network."; "net-undefine", cmd1 no_return N.undefine (arg_full_connection network_of_string), - "Undefine an inactive network."; + s_ "Undefine an inactive network."; "net-uuid", cmd1 print_endline N.get_uuid_string (arg_readonly_connection network_of_string), - "Print the UUID of a network."; + s_ "Print the UUID of a network."; "nodeinfo", cmd0 print_node_info (with_readonly_connection C.get_node_info), - "Print node information."; + s_ "Print node information."; "reboot", cmd1 no_return D.reboot (arg_full_connection domain_of_string), - "Reboot a domain."; + s_ "Reboot a domain."; "restore", cmd1 no_return ( fun path -> D.restore (get_full_connection ()) path ) string_of_string, - "Restore a domain from the named file."; + s_ "Restore a domain from the named file."; "resume", cmd1 no_return D.resume (arg_full_connection domain_of_string), - "Resume a domain."; + s_ "Resume a domain."; "save", cmd2 no_return D.save (arg_full_connection domain_of_string) string_of_string, - "Save a domain to a file."; + 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), - "Get the current scheduler parameters for a domain."; + s_ "Get the current scheduler parameters for a domain."; "schedparamset", cmdN no_return ( function - | [] -> failwith "expecting domain followed by field value pairs" + | [] -> 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 @@ -611,42 +615,42 @@ let do_command = let params = Array.of_list params in D.set_scheduler_parameters dom params ), - "Set the scheduler parameters for a domain."; + 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), - "Get the scheduler type."; + s_ "Get the scheduler type."; "setmem", cmd2 no_return D.set_memory (arg_full_connection domain_of_string) Int64.of_string, - "Set the memory used by the domain (in kilobytes)."; + 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, - "Set the maximum memory used by the domain (in kilobytes)."; + s_ "Set the maximum memory used by the domain (in kilobytes)."; "shutdown", cmd1 no_return D.shutdown (arg_full_connection domain_of_string), - "Gracefully shutdown a domain."; + s_ "Gracefully shutdown a domain."; "start", cmd1 no_return D.create (arg_full_connection domain_of_string), - "Start a previously defined inactive domain."; + s_ "Start a previously defined inactive domain."; "suspend", cmd1 no_return D.suspend (arg_full_connection domain_of_string), - "Suspend a domain."; + s_ "Suspend a domain."; "type", cmd0 print_endline (with_readonly_connection C.get_type), - "Print the driver name"; + s_ "Print the driver name"; "undefine", cmd1 no_return D.undefine (arg_full_connection domain_of_string), - "Undefine an inactive domain."; + s_ "Undefine an inactive domain."; "uri", cmd0 print_endline (with_readonly_connection C.get_uri), - "Print the canonical URI."; + s_ "Print the canonical URI."; "vcpuinfo", cmd1 print_vcpu_info ( fun dom -> @@ -659,18 +663,18 @@ let do_command = let ncpus, vcpu_infos, cpumaps = D.get_vcpus dom maxinfo maplen in ncpus, vcpu_infos, cpumaps, maplen, maxcpus ) (arg_readonly_connection domain_of_string), - "Pin domain VCPU to a list of physical CPUs."; + 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, - "Pin domain VCPU to a list of physical CPUs."; + 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, - "Set the number of virtual CPUs assigned to a domain."; + s_ "Set the number of virtual CPUs assigned to a domain."; "version", cmd0 print_version (with_readonly_connection C.get_version), - "Print the driver version"; + s_ "Print the driver version"; ] in (* Command help. *) @@ -682,7 +686,9 @@ let do_command = sprintf "%-12s %s" cmd description ) commands ) ^ - "\n\nUse '" ^ program_name ^ " help command' for help on a command." + "\n\n" ^ + (sprintf (f_ "Use '%s help command' for help on a command.") + program_name) | Some command -> (* Full description of one command. *) try @@ -691,13 +697,13 @@ let do_command = sprintf "%s %s\n\n%s" program_name command description with Not_found -> - failwith ("help: " ^ command ^ ": command not found"); + failwith (sprintf (f_ "help: %s: command not found") command); in let commands = ("help", cmd01 print_endline help string_of_string, - "Print list of commands or full description of one command."; + s_ "Print list of commands or full description of one command."; ) :: commands in (* Execute a command. *) @@ -707,7 +713,7 @@ let do_command = cmd args with Not_found -> - failwith (command ^ ": command not found"); + failwith (sprintf (f_ "%s: command not found") command); in do_command @@ -716,9 +722,9 @@ let do_command = let rec interactive_mode () = let prompt = match !conn with - | No_connection -> "mlvirsh(no connection)$ " - | RO _ -> "mlvirsh(ro)$ " - | RW _ -> "mlvirsh# " in + | 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 -- cgit v1.1 From f4bba95a7a09519e8828a146dfd7cb57b7e7df73 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Fri, 28 Mar 2008 17:03:03 +0000 Subject: Internationalize virt-ctrl. --- virt-ctrl/.depend | 40 ++++++++++++++++++--------------- virt-ctrl/Makefile.in | 12 ++++++++-- virt-ctrl/vc_connection_dlg.ml | 23 ++++++++++--------- virt-ctrl/vc_connections.ml | 11 +++++----- virt-ctrl/vc_dbus.ml | 18 ++++++++++----- virt-ctrl/vc_domain_ops.ml | 1 + virt-ctrl/vc_helpers.ml | 16 ++++++++------ virt-ctrl/vc_mainwindow.ml | 50 +++++++++++++++++++++++------------------- virt-ctrl/virt_ctrl.ml | 1 + 9 files changed, 101 insertions(+), 71 deletions(-) diff --git a/virt-ctrl/.depend b/virt-ctrl/.depend index 5b01507..84ba14c 100644 --- a/virt-ctrl/.depend +++ b/virt-ctrl/.depend @@ -2,23 +2,27 @@ vc_connections.cmi: ../libvirt/libvirt.cmi vc_domain_ops.cmi: vc_connections.cmi vc_helpers.cmi: ../libvirt/libvirt.cmi vc_mainwindow.cmi: vc_domain_ops.cmi -vc_connection_dlg.cmo: vc_connections.cmi vc_connection_dlg.cmi -vc_connection_dlg.cmx: vc_connections.cmx vc_connection_dlg.cmi -vc_connections.cmo: vc_helpers.cmi ../libvirt/libvirt.cmi vc_connections.cmi -vc_connections.cmx: vc_helpers.cmx ../libvirt/libvirt.cmx vc_connections.cmi -vc_dbus.cmo: vc_connection_dlg.cmi vc_dbus.cmi -vc_dbus.cmx: vc_connection_dlg.cmx vc_dbus.cmi -vc_domain_ops.cmo: vc_connections.cmi ../libvirt/libvirt.cmi \ - vc_domain_ops.cmi -vc_domain_ops.cmx: vc_connections.cmx ../libvirt/libvirt.cmx \ - vc_domain_ops.cmi -vc_helpers.cmo: ../libvirt/libvirt.cmi vc_helpers.cmi -vc_helpers.cmx: ../libvirt/libvirt.cmx vc_helpers.cmi +vc_connection_dlg.cmo: virt_ctrl_gettext.cmo vc_connections.cmi \ + vc_connection_dlg.cmi +vc_connection_dlg.cmx: virt_ctrl_gettext.cmx vc_connections.cmx \ + vc_connection_dlg.cmi +vc_connections.cmo: virt_ctrl_gettext.cmo vc_helpers.cmi \ + ../libvirt/libvirt.cmi vc_connections.cmi +vc_connections.cmx: virt_ctrl_gettext.cmx vc_helpers.cmx \ + ../libvirt/libvirt.cmx vc_connections.cmi +vc_dbus.cmo: virt_ctrl_gettext.cmo vc_connection_dlg.cmi vc_dbus.cmi +vc_dbus.cmx: virt_ctrl_gettext.cmx vc_connection_dlg.cmx vc_dbus.cmi +vc_domain_ops.cmo: virt_ctrl_gettext.cmo vc_connections.cmi \ + ../libvirt/libvirt.cmi vc_domain_ops.cmi +vc_domain_ops.cmx: virt_ctrl_gettext.cmx vc_connections.cmx \ + ../libvirt/libvirt.cmx vc_domain_ops.cmi +vc_helpers.cmo: virt_ctrl_gettext.cmo ../libvirt/libvirt.cmi vc_helpers.cmi +vc_helpers.cmx: virt_ctrl_gettext.cmx ../libvirt/libvirt.cmx vc_helpers.cmi vc_icons.cmo: vc_connection_dlg.cmi vc_icons.cmx: vc_connection_dlg.cmx -vc_mainwindow.cmo: vc_connections.cmi vc_connection_dlg.cmi \ - ../libvirt/libvirt.cmi vc_mainwindow.cmi -vc_mainwindow.cmx: vc_connections.cmx vc_connection_dlg.cmx \ - ../libvirt/libvirt.cmx vc_mainwindow.cmi -virt_ctrl.cmo: vc_mainwindow.cmi vc_domain_ops.cmi -virt_ctrl.cmx: vc_mainwindow.cmx vc_domain_ops.cmx +vc_mainwindow.cmo: virt_ctrl_gettext.cmo vc_connections.cmi \ + vc_connection_dlg.cmi ../libvirt/libvirt.cmi vc_mainwindow.cmi +vc_mainwindow.cmx: virt_ctrl_gettext.cmx vc_connections.cmx \ + vc_connection_dlg.cmx ../libvirt/libvirt.cmx vc_mainwindow.cmi +virt_ctrl.cmo: virt_ctrl_gettext.cmo vc_mainwindow.cmi vc_domain_ops.cmi +virt_ctrl.cmx: virt_ctrl_gettext.cmx vc_mainwindow.cmx vc_domain_ops.cmx diff --git a/virt-ctrl/Makefile.in b/virt-ctrl/Makefile.in index 1b4e529..eb28630 100644 --- a/virt-ctrl/Makefile.in +++ b/virt-ctrl/Makefile.in @@ -27,10 +27,15 @@ icons = @icons@ HAVE_GDK_PIXBUF_MLSOURCE = @HAVE_GDK_PIXBUF_MLSOURCE@ pkg_dbus = @pkg_dbus@ +pkg_gettext = @pkg_gettext@ OCAMLFIND = @OCAMLFIND@ -OBJS += \ +ifneq ($(pkg_gettext),no) +OBJS := virt_ctrl_gettext.cmo +endif + +OBJS += \ vc_helpers.cmo \ vc_connections.cmo \ vc_domain_ops.cmo \ @@ -41,9 +46,12 @@ ifneq ($(OCAMLFIND),) # Good, we have ocamlfind. OCAMLCPACKAGES := -I ../libvirt -package unix,lablgtk2 ifeq ($(pkg_dbus),yes) -OCAMLCPACKAGES := $(OCAMLCPACKAGES),dbus +OCAMLCPACKAGES += -package dbus OBJS += vc_dbus.cmo endif +ifeq ($(pkg_gettext),yes) +OCAMLCPACKAGES += -package gettext-stub +endif OCAMLCFLAGS := -g OCAMLCLIBS := -linkpkg OCAMLOPTPACKAGES := $(OCAMLCPACKAGES) diff --git a/virt-ctrl/vc_connection_dlg.ml b/virt-ctrl/vc_connection_dlg.ml index 9575efc..f072a1d 100644 --- a/virt-ctrl/vc_connection_dlg.ml +++ b/virt-ctrl/vc_connection_dlg.ml @@ -17,6 +17,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) +open Virt_ctrl_gettext.Gettext + type name = string type uri = string type service = name * uri @@ -35,7 +37,7 @@ let icon_48x48_devices_computer_png = ref None (* Open connection dialog. *) let open_connection parent () = - let title = "Open connection to hypervisor" in + let title = s_ "Open connection to hypervisor" in let position = `CENTER_ON_PARENT in let dlg = GWindow.dialog ~title ~position ~parent @@ -57,7 +59,7 @@ let open_connection parent () = (* Local connections. *) let () = let frame = - GBin.frame ~label:"This machine" ~packing:vbox#pack () in + GBin.frame ~label:(s_ "This machine") ~packing:vbox#pack () in let hbox = GPack.hbox ~packing:frame#add () in hbox#set_spacing 20; ignore ( @@ -71,14 +73,14 @@ let open_connection parent () = vbox#set_spacing 5; let xen_button = - GButton.button ~label:"Xen hypervisor" + 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:"QEMU or KVM" + GButton.button ~label:(s_ "QEMU or KVM") ~packing:vbox#pack () in ignore (qemu_button#connect#clicked ~callback:(fun () -> @@ -88,7 +90,7 @@ let open_connection parent () = (* Network connections. *) let () = let frame = - GBin.frame ~label:"Local network" + GBin.frame ~label:(s_ "Local network") ~packing:(vbox#pack ~expand:true) () in let hbox = GPack.hbox ~packing:frame#add () in hbox#set_spacing 20; @@ -129,9 +131,10 @@ let open_connection parent () = let hbox = GPack.hbox ~packing:vbox#pack () in let refresh_button = - GButton.button ~label:"Refresh" ~stock:`REFRESH ~packing:hbox#pack () in + GButton.button ~label:(s_ "Refresh") + ~stock:`REFRESH ~packing:hbox#pack () in let open_button = - GButton.button ~label:"Open" ~packing:hbox#pack () in + GButton.button ~label:(s_ "Open") ~packing:hbox#pack () in ignore (refresh_button#connect#clicked ~callback:refresh); @@ -154,7 +157,7 @@ let open_connection parent () = (* Custom connections. *) let () = let frame = - GBin.frame ~label:"URI connection" ~packing:vbox#pack () in + 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 ()); @@ -164,7 +167,7 @@ let open_connection parent () = GEdit.entry ~text:"xen://localhost/" ~packing:(hbox#pack ~expand:true ~fill:true) () in let button = - GButton.button ~label:"Open" ~packing:hbox#pack () in + GButton.button ~label:(s_ "Open") ~packing:hbox#pack () in ignore (button#connect#clicked ~callback:(fun () -> @@ -176,7 +179,7 @@ let open_connection parent () = (* Just a cancel button in the action area. *) let cancel_button = - GButton.button ~label:"Cancel" + GButton.button ~label:(s_ "Cancel") ~packing:dlg#action_area#pack () in ignore (cancel_button#connect#clicked ~callback:(fun () -> diff --git a/virt-ctrl/vc_connections.ml b/virt-ctrl/vc_connections.ml index 05024c5..8f5fba0 100644 --- a/virt-ctrl/vc_connections.ml +++ b/virt-ctrl/vc_connections.ml @@ -18,6 +18,7 @@ *) open Printf +open Virt_ctrl_gettext.Gettext module C = Libvirt.Connect module D = Libvirt.Domain @@ -401,11 +402,11 @@ let make_treeview ?packing () = view_col#set_sort_order sort_order; view_col#set_sort_column_id sort_column_id in - append_visible_column "ID" col_name_id (Some (false, `ASCENDING, 0)); - append_visible_column "Name" col_domname (Some (true, `ASCENDING, 1)); - append_visible_column "Status" col_status None; - append_visible_column "CPU" col_cpu None; - append_visible_column "Memory" col_mem None; + 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 diff --git a/virt-ctrl/vc_dbus.ml b/virt-ctrl/vc_dbus.ml index 278b1fc..82b66dd 100644 --- a/virt-ctrl/vc_dbus.ml +++ b/virt-ctrl/vc_dbus.ml @@ -39,6 +39,7 @@ *) open Printf +open Virt_ctrl_gettext.Gettext open DBus let debug = true @@ -120,7 +121,7 @@ let add_service bus err msg = Hashtbl.replace services name uri | _ -> - prerr_endline "warning: unexpected message contents of Found signal" + prerr_endline (s_ "warning: unexpected message contents of Found signal") (* Process an ItemRemove message, indicating that a service has * gone away. @@ -135,7 +136,8 @@ let remove_service bus err msg = Hashtbl.remove services name | _ -> - prerr_endline "warning: unexpected message contents of ItemRemove signal" + 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 = @@ -182,7 +184,8 @@ let start_resolve_service bus err sb_path msg = () | _ -> - prerr_endline "warning: unexpected message contents of ItemNew signal" + 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. @@ -212,8 +215,10 @@ let got_message bus err sb_path msg = remove_service bus err msg | "org.freedesktop.DBus", _ -> () | interface, member -> - eprintf "warning: ignored unknown message %s from %s\n%!" - member interface + let () = + eprintf (f_ "warning: ignored unknown message %s from %s\n%!") + member interface in + () ); true @@ -230,7 +235,8 @@ let connect () = | None -> let err = Error.init () in let bus = Bus.get Bus.System err in - if Error.is_set err then failwith "error set after getting System bus"; + 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. diff --git a/virt-ctrl/vc_domain_ops.ml b/virt-ctrl/vc_domain_ops.ml index 787e71e..deace05 100644 --- a/virt-ctrl/vc_domain_ops.ml +++ b/virt-ctrl/vc_domain_ops.ml @@ -20,6 +20,7 @@ *) open Printf +open Virt_ctrl_gettext.Gettext module C = Libvirt.Connect module D = Libvirt.Domain diff --git a/virt-ctrl/vc_helpers.ml b/virt-ctrl/vc_helpers.ml index 10fe6b1..74e70cb 100644 --- a/virt-ctrl/vc_helpers.ml +++ b/virt-ctrl/vc_helpers.ml @@ -17,6 +17,8 @@ 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 @@ -47,13 +49,13 @@ let differences xs ys = d (List.sort compare xs, List.sort compare ys) let string_of_domain_state = function - | D.InfoNoState -> "unknown" - | D.InfoRunning -> "running" - | D.InfoBlocked -> "blocked" - | D.InfoPaused -> "paused" - | D.InfoShutdown -> "shutdown" - | D.InfoShutoff -> "shutoff" - | D.InfoCrashed -> "crashed" + | 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 diff --git a/virt-ctrl/vc_mainwindow.ml b/virt-ctrl/vc_mainwindow.ml index 7aa8145..c34a803 100644 --- a/virt-ctrl/vc_mainwindow.ml +++ b/virt-ctrl/vc_mainwindow.ml @@ -18,8 +18,9 @@ *) open Printf +open Virt_ctrl_gettext.Gettext -let title = "Virtual Control" +let title = s_ "Virtual Control" let utf8_copyright = "\194\169" @@ -35,18 +36,21 @@ let help_about () = GToolbox.message_box ~title ~icon - ("Virtualization control tool (virt-ctrl) by\n" ^ - "Richard W.M. Jones (rjones@redhat.com).\n\n" ^ - "Copyright " ^ utf8_copyright ^ " 2007-2008 Red Hat Inc.\n\n" ^ - "Libvirt version: " ^ virt_version ^ "\n" ^ - "Gtk toolkit version: " ^ gtk_version) + (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 -> - "Virtualisation error: " ^ (Libvirt.Virterror.to_string err) + s_ "Virtualisation error" ^ ": " ^ (Libvirt.Virterror.to_string err) | Failure msg -> msg | exn -> Printexc.to_string exn in @@ -54,7 +58,7 @@ let () = fun exn -> let label = string_of_exn exn in prerr_endline label; - let title = "Error" in + let title = s_ "Error" in let icon = GMisc.image () in icon#set_stock `DIALOG_ERROR; icon#set_icon_size `DIALOG; @@ -72,25 +76,25 @@ let make 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 "File" in - let help_menu = factory#add_submenu "Help" 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 "Open connection ..." + let open_item = factory#add_item (s_ "Open connection ...") ~key:GdkKeysyms._O in ignore (factory#add_separator ()); - let quit_item = factory#add_item "Quit" ~key:GdkKeysyms._Q in + 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 "Help" in - let help_about_item = factory#add_item "About ..." 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); @@ -111,26 +115,26 @@ let make let connect_button_menu = GMenu.menu () in let connect_button = GButton.menu_tool_button - ~label:"Connect ..." ~stock:`CONNECT + ~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:"Details" ~stock:`OPEN + 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:"Start" ~stock:`ADD + GButton.tool_button ~label:(s_ "Start") ~stock:`ADD ~packing:toolbar#insert () in let pause_button = - GButton.tool_button ~label:"Pause" ~stock:`MEDIA_PAUSE + GButton.tool_button ~label:(s_ "Pause") ~stock:`MEDIA_PAUSE ~packing:toolbar#insert () in let resume_button = - GButton.tool_button ~label:"Resume" ~stock:`MEDIA_PLAY + 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:"Shutdown" ~stock:`STOP + GButton.tool_button ~label:(s_ "Shutdown") ~stock:`STOP ~packing:toolbar#insert () in (* Set callbacks for the toolbar buttons. *) @@ -150,10 +154,10 @@ let make (* 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 "Local Xen" in - let local_qemu = factory#add_item "Local QEMU/KVM" 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 "Connect to ..." in + 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 diff --git a/virt-ctrl/virt_ctrl.ml b/virt-ctrl/virt_ctrl.ml index c7c4620..9e5053e 100644 --- a/virt-ctrl/virt_ctrl.ml +++ b/virt-ctrl/virt_ctrl.ml @@ -18,6 +18,7 @@ *) open Printf +open Virt_ctrl_gettext.Gettext let () = (* Build the main window and wire up the buttons to the callback functions *) -- cgit v1.1 From 3fbfec368e14a5a7328d921e115d642172a05171 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Fri, 28 Mar 2008 17:03:17 +0000 Subject: Update translations. Added a couple of Japanese translations for testing. --- po/ja.po | 606 +++++++++++++++++++++++++++++++++++++++++++++++++++++++- po/virt-top.pot | 606 +++++++++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 1210 insertions(+), 2 deletions(-) diff --git a/po/ja.po b/po/ja.po index 609d69d..69c97ca 100644 --- a/po/ja.po +++ b/po/ja.po @@ -3,7 +3,7 @@ msgstr "" "Project-Id-Version: virt-p2v--devel\n" "Report-Msgid-Bugs-To: rjones@redhat.com\n" "POT-Creation-Date: 2008-03-22 15:53+0000\n" -"PO-Revision-Date: 2008-03-23 20:29+0000\n" +"PO-Revision-Date: 2008-03-28 17:00+0000\n" "Last-Translator: Naoko - \n" "Language-Team: Japanese\n" "MIME-Version: 1.0\n" @@ -11,15 +11,619 @@ msgstr "" "Content-Transfer-Encoding: 8bit\n" "Plural-Forms: nplurals=1; plural=0;\n" +#: ../mlvirsh/mlvirsh.ml:716 +msgid "%s: command not found" +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:97 +msgid "About ..." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:399 +msgid "Attach device to domain." +msgstr "" + +#: ../virt-ctrl/vc_connections.ml:408 +msgid "CPU" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:365 +msgid "CPU affinity" +msgstr "" + +#: ../virt-ctrl/vc_connection_dlg.ml:182 +msgid "Cancel" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:409 +msgid "Close an existing hypervisor connection." +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:118 +msgid "Connect ..." +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:160 +msgid "Connect to ..." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:476 +msgid "Core dump a domain to a file for analysis." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:422 +msgid "Create a domain from an XML file." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:534 +msgid "Create a network from an XML file." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:426 +msgid "Define (but don't start) a domain from an XML file." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:538 +msgid "Define (but don't start) a network from an XML file." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:433 +msgid "Destroy a domain." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:541 +msgid "Destroy a network." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:430 +msgid "Detach device from domain." +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:123 +msgid "Details" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:493 +msgid "Display free memory for machine, NUMA cell or range of cells" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:437 +msgid "Display the block device statistics for a domain." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:444 +msgid "Display the network interface statistics for a domain." +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:61 +msgid "Error" +msgstr "エラー" + +#: ../virt-ctrl/vc_mainwindow.ml:79 +msgid "File" +msgstr "ファイル" + +#: ../mlvirsh/mlvirsh.ml:606 +msgid "Get the current scheduler parameters for a domain." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:623 +msgid "Get the scheduler type." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:635 +msgid "Gracefully shutdown a domain." +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:80 ../virt-ctrl/vc_mainwindow.ml:96 +msgid "Help" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:35 msgid "Hypervisor connection URI" msgstr "" +#: ../virt-ctrl/vc_connections.ml:405 +msgid "ID" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:557 +msgid "List the active networks." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:565 +msgid "List the defined but inactive networks." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:516 +msgid "List the defined but not running domains." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:508 +msgid "List the running domains." +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:158 +msgid "Local QEMU/KVM" +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:157 +msgid "Local Xen" +msgstr "" + +#: ../virt-ctrl/vc_connection_dlg.ml:93 +msgid "Local network" +msgstr "" + +#: ../virt-ctrl/vc_connections.ml:409 +msgid "Memory" +msgstr "" + +#: ../virt-ctrl/vc_connections.ml:406 +msgid "Name" +msgstr "" + +#: ../virt-ctrl/vc_connection_dlg.ml:137 ../virt-ctrl/vc_connection_dlg.ml:170 +msgid "Open" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:418 +msgid "Open a new hypervisor connection." +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:86 +msgid "Open connection ..." +msgstr "" + +#: ../virt-ctrl/vc_connection_dlg.ml:40 +msgid "Open connection to hypervisor" +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:130 +msgid "Pause" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:666 ../mlvirsh/mlvirsh.ml:670 +msgid "Pin domain VCPU to a list of physical CPUs." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:706 +msgid "Print list of commands or full description of one command." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:584 +msgid "Print node information." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:440 +msgid "Print the ID of a domain." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:464 +msgid "Print the OS type of a domain." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:472 +msgid "Print the UUID of a domain." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:581 +msgid "Print the UUID of a network." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:480 +msgid "Print the XML description of a domain." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:545 +msgid "Print the XML description of a network." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:530 +msgid "Print the bridge name of a network." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:653 +msgid "Print the canonical URI." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:448 +msgid "Print the domain info." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:468 +msgid "Print the domain state." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:646 +msgid "Print the driver name" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:677 +msgid "Print the driver version" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:500 +msgid "Print the hostname." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:522 +msgid "Print the max VCPUs available." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:456 +msgid "Print the max VCPUs of a domain." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:452 +msgid "Print the max memory (in kilobytes) of a domain." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:460 +msgid "Print the name of a domain." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:569 +msgid "Print the name of a network." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:497 +msgid "Print whether a domain autostarts at boot." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:549 +msgid "Print whether a network autostarts at boot." +msgstr "" + +#: ../virt-ctrl/vc_connection_dlg.ml:83 +msgid "QEMU or KVM" +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:89 +msgid "Quit" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:519 +msgid "Quit the interactive terminal." +msgstr "" + #: ../mlvirsh/mlvirsh.ml:36 msgid "Read-only connection" msgstr "" +#: ../mlvirsh/mlvirsh.ml:587 +msgid "Reboot a domain." +msgstr "" + +#: ../virt-ctrl/vc_connection_dlg.ml:134 +msgid "Refresh" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:592 +msgid "Restore a domain from the named file." +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:133 +msgid "Resume" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:595 +msgid "Resume a domain." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:406 +msgid "Returns capabilities of hypervisor/driver." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:599 +msgid "Save a domain to a file." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:631 +msgid "Set the maximum memory used by the domain (in kilobytes)." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:627 +msgid "Set the memory used by the domain (in kilobytes)." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:674 +msgid "Set the number of virtual CPUs assigned to a domain." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:618 +msgid "Set the scheduler parameters for a domain." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:403 +msgid "Set whether a domain autostarts at boot." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:526 +msgid "Set whether a network autostarts at boot." +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:137 +msgid "Shutdown" +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:127 +msgid "Start" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:639 +msgid "Start a previously defined inactive domain." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:573 +msgid "Start a previously defined inactive network." +msgstr "" + +#: ../virt-ctrl/vc_connections.ml:407 +msgid "Status" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:643 +msgid "Suspend a domain." +msgstr "" + #: ../mlvirsh/mlvirsh.ml:40 msgid "Synopsis:\n %s [options] [command]\n\nList of all commands:\n %s help\n\nFull description of a single command:\n %s help command\n\nOptions:" msgstr "" +#: ../virt-ctrl/vc_connection_dlg.ml:62 +msgid "This machine" +msgstr "" + +#: ../virt-ctrl/vc_connection_dlg.ml:160 +msgid "URI connection" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:650 +msgid "Undefine an inactive domain." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:577 +msgid "Undefine an inactive network." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:690 +msgid "Use '%s help command' for help on a command." +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:23 +msgid "Virtual Control" +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:53 +msgid "Virtualisation error" +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:39 +msgid "Virtualization control tool (virt-ctrl) by\nRichard W.M. Jones (rjones@redhat.com).\n\nCopyright %s 2007-2008 Red Hat Inc.\n\nLibvirt version: %s\n\nGtk toolkit version: %s" +msgstr "" + +#: ../virt-ctrl/vc_connection_dlg.ml:76 +msgid "Xen hypervisor" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:364 +msgid "\\tCPU time: %Ld ns\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:362 +msgid "\\tcurrent state: %s\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:361 +msgid "\\ton physical CPU: %d\\n" +msgstr "" + +#: ../virt-ctrl/vc_helpers.ml:54 ../mlvirsh/mlvirsh.ml:289 ../mlvirsh/mlvirsh.ml:298 +msgid "blocked" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:330 +msgid "cores: %d\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:342 +msgid "cpu_time: %Ld ns\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:326 +msgid "cpus: %d\\n" +msgstr "" + +#: ../virt-ctrl/vc_helpers.ml:58 ../mlvirsh/mlvirsh.ml:293 +msgid "crashed" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:242 +msgid "domain %s: not found. Additional info: %s" +msgstr "" + +#: ../virt-ctrl/vc_dbus.ml:239 +msgid "error set after getting System bus" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:379 +msgid "errors: %Ld\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:258 +msgid "expected field value pairs, but got an odd number of arguments" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:610 +msgid "expecting domain followed by field value pairs" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:220 +msgid "flag should be '%s'" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:700 +msgid "help: %s: command not found" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:160 ../mlvirsh/mlvirsh.ml:164 ../mlvirsh/mlvirsh.ml:168 ../mlvirsh/mlvirsh.ml:172 ../mlvirsh/mlvirsh.ml:177 ../mlvirsh/mlvirsh.ml:182 ../mlvirsh/mlvirsh.ml:188 +msgid "incorrect number of arguments for function" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:339 +msgid "max_mem: %Ld K\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:325 ../mlvirsh/mlvirsh.ml:340 +msgid "memory: %Ld K\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:327 +msgid "mhz: %d\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:727 +msgid "mlvirsh" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:725 +msgid "mlvirsh(no connection)" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:726 +msgid "mlvirsh(ro)" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:324 +msgid "model: %s\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:253 +msgid "network %s: not found. Additional info: %s" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:328 +msgid "nodes: %d\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:197 ../mlvirsh/mlvirsh.ml:202 +msgid "not connected to the hypervisor" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:341 +msgid "nr_virt_cpu: %d\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:296 +msgid "offline" +msgstr "" + +#: ../virt-ctrl/vc_helpers.ml:55 ../mlvirsh/mlvirsh.ml:290 +msgid "paused" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:376 +msgid "read bytes: %Ld\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:375 +msgid "read requests: %Ld\\n" +msgstr "" + +#: ../virt-ctrl/vc_helpers.ml:53 ../mlvirsh/mlvirsh.ml:288 ../mlvirsh/mlvirsh.ml:297 +msgid "running" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:384 +msgid "rx bytes: %Ld\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:387 +msgid "rx dropped: %Ld\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:386 +msgid "rx errs: %Ld\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:385 +msgid "rx packets: %Ld\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:226 +msgid "setting should be '%s' or '%s'" +msgstr "" + +#: ../virt-ctrl/vc_helpers.ml:56 ../mlvirsh/mlvirsh.ml:291 +msgid "shutdown" +msgstr "" + +#: ../virt-ctrl/vc_helpers.ml:57 ../mlvirsh/mlvirsh.ml:292 +msgid "shutoff" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:329 +msgid "sockets: %d\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:338 +msgid "state: %s\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:331 +msgid "threads: %d\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:198 +msgid "tried to do read-write operation on read-only hypervisor connection" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:388 +msgid "tx bytes: %Ld\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:391 +msgid "tx dropped: %Ld\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:390 +msgid "tx errs: %Ld\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:389 +msgid "tx packets: %Ld\\n" +msgstr "" + +#: ../virt-ctrl/vc_helpers.ml:52 ../mlvirsh/mlvirsh.ml:287 +msgid "unknown" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:360 +msgid "virtual CPU: %d\\n" +msgstr "" + +#: ../virt-ctrl/vc_dbus.ml:219 +msgid "warning: ignored unknown message %s from %s\\n%!" +msgstr "" + +#: ../virt-ctrl/vc_dbus.ml:124 +msgid "warning: unexpected message contents of Found signal" +msgstr "" + +#: ../virt-ctrl/vc_dbus.ml:188 +msgid "warning: unexpected message contents of ItemNew signal" +msgstr "" + +#: ../virt-ctrl/vc_dbus.ml:140 +msgid "warning: unexpected message contents of ItemRemove signal" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:378 +msgid "write bytes: %Ld\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:377 +msgid "write requests: %Ld\\n" +msgstr "" + diff --git a/po/virt-top.pot b/po/virt-top.pot index 0a66b9e..f67d15b 100644 --- a/po/virt-top.pot +++ b/po/virt-top.pot @@ -8,7 +8,7 @@ msgid "" msgstr "" "Project-Id-Version: PACKAGE VERSION\n" "Report-Msgid-Bugs-To: \n" -"POT-Creation-Date: 2008-03-28 13:03+0000\n" +"POT-Creation-Date: 2008-03-28 16:59+0000\n" "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" "Last-Translator: FULL NAME \n" "Language-Team: LANGUAGE \n" @@ -17,15 +17,619 @@ msgstr "" "Content-Transfer-Encoding: 8bit\n" "Plural-Forms: nplurals=INTEGER; plural=EXPRESSION;\n" +#: ../mlvirsh/mlvirsh.ml:716 +msgid "%s: command not found" +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:97 +msgid "About ..." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:399 +msgid "Attach device to domain." +msgstr "" + +#: ../virt-ctrl/vc_connections.ml:408 +msgid "CPU" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:365 +msgid "CPU affinity" +msgstr "" + +#: ../virt-ctrl/vc_connection_dlg.ml:182 +msgid "Cancel" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:409 +msgid "Close an existing hypervisor connection." +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:118 +msgid "Connect ..." +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:160 +msgid "Connect to ..." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:476 +msgid "Core dump a domain to a file for analysis." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:422 +msgid "Create a domain from an XML file." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:534 +msgid "Create a network from an XML file." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:426 +msgid "Define (but don't start) a domain from an XML file." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:538 +msgid "Define (but don't start) a network from an XML file." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:433 +msgid "Destroy a domain." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:541 +msgid "Destroy a network." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:430 +msgid "Detach device from domain." +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:123 +msgid "Details" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:493 +msgid "Display free memory for machine, NUMA cell or range of cells" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:437 +msgid "Display the block device statistics for a domain." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:444 +msgid "Display the network interface statistics for a domain." +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:61 +msgid "Error" +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:79 +msgid "File" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:606 +msgid "Get the current scheduler parameters for a domain." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:623 +msgid "Get the scheduler type." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:635 +msgid "Gracefully shutdown a domain." +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:96 ../virt-ctrl/vc_mainwindow.ml:80 +msgid "Help" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:35 msgid "Hypervisor connection URI" msgstr "" +#: ../virt-ctrl/vc_connections.ml:405 +msgid "ID" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:557 +msgid "List the active networks." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:565 +msgid "List the defined but inactive networks." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:516 +msgid "List the defined but not running domains." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:508 +msgid "List the running domains." +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:158 +msgid "Local QEMU/KVM" +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:157 +msgid "Local Xen" +msgstr "" + +#: ../virt-ctrl/vc_connection_dlg.ml:93 +msgid "Local network" +msgstr "" + +#: ../virt-ctrl/vc_connections.ml:409 +msgid "Memory" +msgstr "" + +#: ../virt-ctrl/vc_connections.ml:406 +msgid "Name" +msgstr "" + +#: ../virt-ctrl/vc_connection_dlg.ml:170 ../virt-ctrl/vc_connection_dlg.ml:137 +msgid "Open" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:418 +msgid "Open a new hypervisor connection." +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:86 +msgid "Open connection ..." +msgstr "" + +#: ../virt-ctrl/vc_connection_dlg.ml:40 +msgid "Open connection to hypervisor" +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:130 +msgid "Pause" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:670 ../mlvirsh/mlvirsh.ml:666 +msgid "Pin domain VCPU to a list of physical CPUs." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:706 +msgid "Print list of commands or full description of one command." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:584 +msgid "Print node information." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:440 +msgid "Print the ID of a domain." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:464 +msgid "Print the OS type of a domain." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:472 +msgid "Print the UUID of a domain." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:581 +msgid "Print the UUID of a network." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:480 +msgid "Print the XML description of a domain." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:545 +msgid "Print the XML description of a network." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:530 +msgid "Print the bridge name of a network." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:653 +msgid "Print the canonical URI." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:448 +msgid "Print the domain info." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:468 +msgid "Print the domain state." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:646 +msgid "Print the driver name" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:677 +msgid "Print the driver version" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:500 +msgid "Print the hostname." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:522 +msgid "Print the max VCPUs available." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:456 +msgid "Print the max VCPUs of a domain." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:452 +msgid "Print the max memory (in kilobytes) of a domain." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:460 +msgid "Print the name of a domain." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:569 +msgid "Print the name of a network." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:497 +msgid "Print whether a domain autostarts at boot." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:549 +msgid "Print whether a network autostarts at boot." +msgstr "" + +#: ../virt-ctrl/vc_connection_dlg.ml:83 +msgid "QEMU or KVM" +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:89 +msgid "Quit" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:519 +msgid "Quit the interactive terminal." +msgstr "" + #: ../mlvirsh/mlvirsh.ml:36 msgid "Read-only connection" msgstr "" +#: ../mlvirsh/mlvirsh.ml:587 +msgid "Reboot a domain." +msgstr "" + +#: ../virt-ctrl/vc_connection_dlg.ml:134 +msgid "Refresh" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:592 +msgid "Restore a domain from the named file." +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:133 +msgid "Resume" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:595 +msgid "Resume a domain." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:406 +msgid "Returns capabilities of hypervisor/driver." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:599 +msgid "Save a domain to a file." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:631 +msgid "Set the maximum memory used by the domain (in kilobytes)." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:627 +msgid "Set the memory used by the domain (in kilobytes)." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:674 +msgid "Set the number of virtual CPUs assigned to a domain." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:618 +msgid "Set the scheduler parameters for a domain." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:403 +msgid "Set whether a domain autostarts at boot." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:526 +msgid "Set whether a network autostarts at boot." +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:137 +msgid "Shutdown" +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:127 +msgid "Start" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:639 +msgid "Start a previously defined inactive domain." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:573 +msgid "Start a previously defined inactive network." +msgstr "" + +#: ../virt-ctrl/vc_connections.ml:407 +msgid "Status" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:643 +msgid "Suspend a domain." +msgstr "" + #: ../mlvirsh/mlvirsh.ml:40 msgid "Synopsis:\n %s [options] [command]\n\nList of all commands:\n %s help\n\nFull description of a single command:\n %s help command\n\nOptions:" msgstr "" +#: ../virt-ctrl/vc_connection_dlg.ml:62 +msgid "This machine" +msgstr "" + +#: ../virt-ctrl/vc_connection_dlg.ml:160 +msgid "URI connection" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:650 +msgid "Undefine an inactive domain." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:577 +msgid "Undefine an inactive network." +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:690 +msgid "Use '%s help command' for help on a command." +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:23 +msgid "Virtual Control" +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:53 +msgid "Virtualisation error" +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:39 +msgid "Virtualization control tool (virt-ctrl) by\nRichard W.M. Jones (rjones@redhat.com).\n\nCopyright %s 2007-2008 Red Hat Inc.\n\nLibvirt version: %s\n\nGtk toolkit version: %s" +msgstr "" + +#: ../virt-ctrl/vc_connection_dlg.ml:76 +msgid "Xen hypervisor" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:364 +msgid "\\tCPU time: %Ld ns\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:362 +msgid "\\tcurrent state: %s\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:361 +msgid "\\ton physical CPU: %d\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:298 ../mlvirsh/mlvirsh.ml:289 ../virt-ctrl/vc_helpers.ml:54 +msgid "blocked" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:330 +msgid "cores: %d\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:342 +msgid "cpu_time: %Ld ns\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:326 +msgid "cpus: %d\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:293 ../virt-ctrl/vc_helpers.ml:58 +msgid "crashed" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:242 +msgid "domain %s: not found. Additional info: %s" +msgstr "" + +#: ../virt-ctrl/vc_dbus.ml:239 +msgid "error set after getting System bus" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:379 +msgid "errors: %Ld\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:258 +msgid "expected field value pairs, but got an odd number of arguments" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:610 +msgid "expecting domain followed by field value pairs" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:220 +msgid "flag should be '%s'" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:700 +msgid "help: %s: command not found" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:188 ../mlvirsh/mlvirsh.ml:182 ../mlvirsh/mlvirsh.ml:177 ../mlvirsh/mlvirsh.ml:172 ../mlvirsh/mlvirsh.ml:168 ../mlvirsh/mlvirsh.ml:164 ../mlvirsh/mlvirsh.ml:160 +msgid "incorrect number of arguments for function" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:339 +msgid "max_mem: %Ld K\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:340 ../mlvirsh/mlvirsh.ml:325 +msgid "memory: %Ld K\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:327 +msgid "mhz: %d\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:727 +msgid "mlvirsh" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:725 +msgid "mlvirsh(no connection)" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:726 +msgid "mlvirsh(ro)" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:324 +msgid "model: %s\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:253 +msgid "network %s: not found. Additional info: %s" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:328 +msgid "nodes: %d\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:202 ../mlvirsh/mlvirsh.ml:197 +msgid "not connected to the hypervisor" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:341 +msgid "nr_virt_cpu: %d\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:296 +msgid "offline" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:290 ../virt-ctrl/vc_helpers.ml:55 +msgid "paused" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:376 +msgid "read bytes: %Ld\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:375 +msgid "read requests: %Ld\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:297 ../mlvirsh/mlvirsh.ml:288 ../virt-ctrl/vc_helpers.ml:53 +msgid "running" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:384 +msgid "rx bytes: %Ld\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:387 +msgid "rx dropped: %Ld\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:386 +msgid "rx errs: %Ld\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:385 +msgid "rx packets: %Ld\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:226 +msgid "setting should be '%s' or '%s'" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:291 ../virt-ctrl/vc_helpers.ml:56 +msgid "shutdown" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:292 ../virt-ctrl/vc_helpers.ml:57 +msgid "shutoff" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:329 +msgid "sockets: %d\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:338 +msgid "state: %s\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:331 +msgid "threads: %d\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:198 +msgid "tried to do read-write operation on read-only hypervisor connection" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:388 +msgid "tx bytes: %Ld\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:391 +msgid "tx dropped: %Ld\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:390 +msgid "tx errs: %Ld\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:389 +msgid "tx packets: %Ld\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:287 ../virt-ctrl/vc_helpers.ml:52 +msgid "unknown" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:360 +msgid "virtual CPU: %d\\n" +msgstr "" + +#: ../virt-ctrl/vc_dbus.ml:219 +msgid "warning: ignored unknown message %s from %s\\n%!" +msgstr "" + +#: ../virt-ctrl/vc_dbus.ml:124 +msgid "warning: unexpected message contents of Found signal" +msgstr "" + +#: ../virt-ctrl/vc_dbus.ml:188 +msgid "warning: unexpected message contents of ItemNew signal" +msgstr "" + +#: ../virt-ctrl/vc_dbus.ml:140 +msgid "warning: unexpected message contents of ItemRemove signal" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:378 +msgid "write bytes: %Ld\\n" +msgstr "" + +#: ../mlvirsh/mlvirsh.ml:377 +msgid "write requests: %Ld\\n" +msgstr "" + -- cgit v1.1 From f6cc606a9e87e7cf287ba3bcc8fbfb4063f0bdd7 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Fri, 28 Mar 2008 17:12:35 +0000 Subject: Should always link to program gettext package. --- virt-ctrl/Makefile.in | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/virt-ctrl/Makefile.in b/virt-ctrl/Makefile.in index eb28630..7e7c5c4 100644 --- a/virt-ctrl/Makefile.in +++ b/virt-ctrl/Makefile.in @@ -31,11 +31,8 @@ pkg_gettext = @pkg_gettext@ OCAMLFIND = @OCAMLFIND@ -ifneq ($(pkg_gettext),no) -OBJS := virt_ctrl_gettext.cmo -endif - -OBJS += \ +OBJS := \ + virt_ctrl_gettext.cmo \ vc_helpers.cmo \ vc_connections.cmo \ vc_domain_ops.cmo \ -- cgit v1.1 From e6cca10e5cf86b9bd280e371fb1195835a96bff0 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Fri, 28 Mar 2008 17:12:47 +0000 Subject: Internationalize virt-df program. --- virt-df/.depend | 18 +++++++------ virt-df/Makefile.in | 18 +++++++++---- virt-df/virt_df.ml | 63 +++++++++++++++++++++++++------------------ virt-df/virt_df_ext2.ml | 7 ++--- virt-df/virt_df_linux_swap.ml | 4 ++- virt-df/virt_df_lvm2.ml | 3 ++- 6 files changed, 69 insertions(+), 44 deletions(-) mode change 100755 => 100644 virt-df/virt_df_ext2.ml mode change 100755 => 100644 virt-df/virt_df_linux_swap.ml mode change 100755 => 100644 virt-df/virt_df_lvm2.ml diff --git a/virt-df/.depend b/virt-df/.depend index 1a7750e..69ae982 100644 --- a/virt-df/.depend +++ b/virt-df/.depend @@ -1,10 +1,12 @@ -virt_df_ext2.cmo: virt_df.cmo -virt_df_ext2.cmx: virt_df.cmx -virt_df_linux_swap.cmo: virt_df.cmo -virt_df_linux_swap.cmx: virt_df.cmx -virt_df_lvm2.cmo: virt_df.cmo -virt_df_lvm2.cmx: virt_df.cmx +virt_df_ext2.cmo: virt_df_gettext.cmo virt_df.cmo +virt_df_ext2.cmx: virt_df_gettext.cmx virt_df.cmx +virt_df_linux_swap.cmo: virt_df_gettext.cmo virt_df.cmo +virt_df_linux_swap.cmx: virt_df_gettext.cmx virt_df.cmx +virt_df_lvm2.cmo: virt_df_gettext.cmo virt_df.cmo +virt_df_lvm2.cmx: virt_df_gettext.cmx virt_df.cmx virt_df_main.cmo: virt_df.cmo virt_df_main.cmx: virt_df.cmx -virt_df.cmo: ../libvirt/libvirt_version.cmi ../libvirt/libvirt.cmi -virt_df.cmx: ../libvirt/libvirt_version.cmx ../libvirt/libvirt.cmx +virt_df.cmo: virt_df_gettext.cmo ../libvirt/libvirt_version.cmi \ + ../libvirt/libvirt.cmi +virt_df.cmx: virt_df_gettext.cmx ../libvirt/libvirt_version.cmx \ + ../libvirt/libvirt.cmx diff --git a/virt-df/Makefile.in b/virt-df/Makefile.in index 1f3af53..057c8e5 100644 --- a/virt-df/Makefile.in +++ b/virt-df/Makefile.in @@ -26,14 +26,22 @@ exec_prefix = @exec_prefix@ bindir = @bindir@ pkg_xml_light = @pkg_xml_light@ +pkg_gettext = @pkg_gettext@ OCAMLCPACKAGES := -package unix,extlib,xml-light -OBJS := virt_df.cmo \ - virt_df_ext2.cmo \ - virt_df_linux_swap.cmo \ - virt_df_lvm2.cmo \ - virt_df_main.cmo +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.cmo \ + virt_df_main.cmo + XOBJS := $(OBJS:.cmo=.cmx) OCAMLCPACKAGES += -I ../libvirt diff --git a/virt-df/virt_df.ml b/virt-df/virt_df.ml index 350d535..4fbc706 100644 --- a/virt-df/virt_df.ml +++ b/virt-df/virt_df.ml @@ -19,9 +19,10 @@ open Printf open ExtList - open Unix +open Virt_df_gettext.Gettext + module C = Libvirt.Connect module D = Libvirt.Domain module N = Libvirt.Network @@ -145,7 +146,7 @@ and probe_mbr fd = lseek fd 446 SEEK_SET; let str = String.create 64 in if read fd str 0 64 <> 64 then - failwith "error reading partition table" + failwith (s_ "error reading partition table") else ( (* Extract partitions from the data. *) let primaries = List.map (get_partition str) [ 0; 16; 32; 48 ] in @@ -178,13 +179,13 @@ and probe_extended_partition max fd epart sect = LargeFile.lseek fd (ebr_offs +^ 446L) SEEK_SET; let str = String.create 32 in if read fd str 0 32 <> 32 then - failwith "error reading extended partition" + 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 "probe_extended_partition: internal error" in + | _ -> 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 @@ -232,7 +233,7 @@ and get_partition str offs = and probe_partition target part_type fd start size = match part_type with | None -> - ProbeFailed "detection of unpartitioned devices not yet supported" + ProbeFailed (s_ "detection of unpartitioned devices not yet supported") | Some 0x05 -> ProbeIgnore (* Extended partition - ignore it. *) | Some part_type -> @@ -242,7 +243,7 @@ and probe_partition target part_type fd start size = with Not_found -> ProbeFailed - (sprintf "unsupported partition type %02x" part_type) + (sprintf (f_ "unsupported partition type %02x") part_type) and print_stats dom_name statss = List.iter ( @@ -337,19 +338,29 @@ let main () = in let argspec = Arg.align [ - "-a", Arg.Set all, " Show all domains (default: only active domains)"; - "--all", Arg.Set all, " Show all domains (default: only active domains)"; - "-c", Arg.String set_uri, "uri Connect to URI (default: Xen)"; - "--connect", Arg.String set_uri, "uri Connect to URI (default: Xen)"; - "-h", Arg.Set human, " Print sizes in human-readable format"; - "--human-readable", Arg.Set human, " Print sizes in human-readable format"; - "-i", Arg.Set inodes, " Show inodes instead of blocks"; - "--inodes", Arg.Set inodes, " Show inodes instead of blocks"; - "--version", Arg.Unit version, " Display version and exit"; + "-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)"; + "-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"; + "--version", Arg.Unit version, + " " ^ s_ "Display version and exit"; ] in - let anon_fun str = raise (Arg.Bad (str ^ ": unknown parameter")) in - let usage_msg = "virt-df : like 'df', shows disk space used in guests + 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] @@ -368,7 +379,7 @@ OPTIONS" in 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 "NB: If you want to monitor a local Xen hypervisor, you usually need to be root"; + print_endline (s_ "NB: If you want to monitor a local Xen hypervisor, you usually need to be root"); ); exit 1 in @@ -405,7 +416,7 @@ OPTIONS" in let nodes, domain_attrs = match xml with | Xml.Element ("domain", attrs, children) -> children, attrs - | _ -> failwith "get_xml_desc didn't return " in + | _ -> failwith (s_ "get_xml_desc didn't return ") in let domid = try Some (int_of_string (List.assoc "id" domain_attrs)) @@ -413,10 +424,10 @@ OPTIONS" in let rec loop = function | [] -> - failwith "get_xml_desc returned no node in XML" + failwith (s_ "get_xml_desc returned no node in XML") | Xml.Element ("name", _, [Xml.PCData name]) :: _ -> name | Xml.Element ("name", _, _) :: _ -> - failwith "get_xml_desc returned strange node" + failwith (s_ "get_xml_desc returned strange node") | _ :: rest -> loop rest in let name = loop nodes in @@ -484,11 +495,11 @@ OPTIONS" in let () = let total, used, avail = match !inodes, !human with - | false, false -> "1K-blocks", "Used", "Available" - | false, true -> "Size", "Used", "Available" - | true, _ -> "Inodes", "IUse", "IFree" in + | 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%!" - "Filesystem" total used avail "Type" in + (s_ "Filesystem") total used avail (s_ "Type") in (* Probe the devices. *) List.iter ( @@ -500,6 +511,6 @@ OPTIONS" in | { d_device = Some "cdrom" } -> () (* Ignore physical CD-ROM devices. *) | _ -> - printf "(device omitted)\n"; + print_endline (s_ "(device omitted)"); ) dom_disks ) doms diff --git a/virt-df/virt_df_ext2.ml b/virt-df/virt_df_ext2.ml old mode 100755 new mode 100644 index d2b51f3..1acd855 --- a/virt-df/virt_df_ext2.ml +++ b/virt-df/virt_df_ext2.ml @@ -21,6 +21,7 @@ open Unix open Printf +open Virt_df_gettext.Gettext (* Int64 operators for convenience. *) let (+^) = Int64.add @@ -35,10 +36,10 @@ let probe_ext2 target part_type fd start size = LargeFile.lseek fd ((start+^2L) *^ sector_size) SEEK_SET; let str = String.create 128 in if read fd str 0 128 <> 128 then - failwith "error reading ext2/ext3 magic" + failwith (s_ "error reading ext2/ext3 magic") else ( if str.[56] != '\x53' || str.[57] != '\xEF' then ( - Virt_df.ProbeFailed "partition marked EXT2/3 but no valid filesystem" + Virt_df.ProbeFailed (s_ "partition marked EXT2/3 but no valid filesystem") ) else ( (* Refer to *) let s_inodes_count = read_int32_le str 0 in @@ -78,7 +79,7 @@ let probe_ext2 target part_type fd start size = Virt_df.Filesystem { - Virt_df.fs_name = "Linux ext2/3"; + Virt_df.fs_name = s_ "Linux ext2/3"; fs_block_size = block_size; fs_blocks_total = s_blocks_count -^ overhead; fs_blocks_reserved = s_r_blocks_count; diff --git a/virt-df/virt_df_linux_swap.ml b/virt-df/virt_df_linux_swap.ml old mode 100755 new mode 100644 index 4638828..04e22b9 --- a/virt-df/virt_df_linux_swap.ml +++ b/virt-df/virt_df_linux_swap.ml @@ -20,6 +20,8 @@ Support for Linux swap partitions. *) +open Virt_df_gettext.Gettext + (* Int64 operators for convenience. *) let (+^) = Int64.add let (-^) = Int64.sub @@ -28,7 +30,7 @@ let (/^) = Int64.div let probe_swap target part_type fd start size = Virt_df.Swap { - Virt_df.swap_name = "Linux swap"; + Virt_df.swap_name = s_ "Linux swap"; swap_block_size = 4096L; (* XXX *) swap_blocks_total = size *^ 512L /^ 4096L; } diff --git a/virt-df/virt_df_lvm2.ml b/virt-df/virt_df_lvm2.ml old mode 100755 new mode 100644 index 8dc0c05..d01a5a8 --- a/virt-df/virt_df_lvm2.ml +++ b/virt-df/virt_df_lvm2.ml @@ -21,6 +21,7 @@ *) open Printf +open Virt_df_gettext.Gettext (* Int64 operators for convenience. *) let (+^) = Int64.add @@ -29,7 +30,7 @@ let ( *^ ) = Int64.mul let (/^) = Int64.div let probe_lvm2 target part_type fd start size = - Virt_df.ProbeFailed "LVM2 not supported yet" + Virt_df.ProbeFailed (s_ "LVM2 not supported yet") (* Register with main code. *) let () = -- cgit v1.1 From 4edc7905c404a3fe2caaee773630874786b21b4d Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Fri, 28 Mar 2008 17:12:53 +0000 Subject: Updated PO files. --- po/ja.po | 124 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ po/virt-top.pot | 126 +++++++++++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 249 insertions(+), 1 deletion(-) diff --git a/po/ja.po b/po/ja.po index 69c97ca..5031756 100644 --- a/po/ja.po +++ b/po/ja.po @@ -15,6 +15,18 @@ msgstr "" msgid "%s: command not found" msgstr "" +#: ../virt-df/virt_df.ml:362 +msgid "%s: unknown parameter" +msgstr "" + +#: ../virt-df/virt_df.ml:514 +msgid "(device omitted)" +msgstr "" + +#: ../virt-df/virt_df.ml:498 +msgid "1K-blocks" +msgstr "" + #: ../virt-ctrl/vc_mainwindow.ml:97 msgid "About ..." msgstr "" @@ -23,6 +35,10 @@ msgstr "" msgid "Attach device to domain." msgstr "" +#: ../virt-df/virt_df.ml:498 ../virt-df/virt_df.ml:499 +msgid "Available" +msgstr "" + #: ../virt-ctrl/vc_connections.ml:408 msgid "CPU" msgstr "" @@ -47,6 +63,10 @@ msgstr "" msgid "Connect to ..." msgstr "" +#: ../virt-df/virt_df.ml:346 ../virt-df/virt_df.ml:348 +msgid "Connect to URI (default: Xen)" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:476 msgid "Core dump a domain to a file for analysis." msgstr "" @@ -95,6 +115,10 @@ msgstr "" msgid "Display the network interface statistics for a domain." msgstr "" +#: ../virt-df/virt_df.ml:358 +msgid "Display version and exit" +msgstr "" + #: ../virt-ctrl/vc_mainwindow.ml:61 msgid "Error" msgstr "エラー" @@ -103,6 +127,10 @@ msgstr "エラー" msgid "File" msgstr "ファイル" +#: ../virt-df/virt_df.ml:502 +msgid "Filesystem" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:606 msgid "Get the current scheduler parameters for a domain." msgstr "" @@ -127,6 +155,30 @@ msgstr "" msgid "ID" msgstr "" +#: ../virt-df/virt_df.ml:500 +msgid "IFree" +msgstr "" + +#: ../virt-df/virt_df.ml:500 +msgid "IUse" +msgstr "" + +#: ../virt-df/virt_df.ml:500 +msgid "Inodes" +msgstr "" + +#: ../virt-df/virt_df_lvm2.ml:33 +msgid "LVM2 not supported yet" +msgstr "" + +#: ../virt-df/virt_df_ext2.ml:82 +msgid "Linux ext2/3" +msgstr "" + +#: ../virt-df/virt_df_linux_swap.ml:33 +msgid "Linux swap" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:557 msgid "List the active networks." msgstr "" @@ -159,6 +211,10 @@ msgstr "" msgid "Memory" msgstr "" +#: ../virt-df/virt_df.ml:382 +msgid "NB: If you want to monitor a local Xen hypervisor, you usually need to be root" +msgstr "" + #: ../virt-ctrl/vc_connections.ml:406 msgid "Name" msgstr "" @@ -195,6 +251,10 @@ msgstr "" msgid "Print node information." msgstr "" +#: ../virt-df/virt_df.ml:350 ../virt-df/virt_df.ml:352 +msgid "Print sizes in human-readable format" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:440 msgid "Print the ID of a domain." msgstr "" @@ -343,10 +403,22 @@ msgstr "" msgid "Set whether a network autostarts at boot." msgstr "" +#: ../virt-df/virt_df.ml:342 ../virt-df/virt_df.ml:344 +msgid "Show all domains (default: only active domains)" +msgstr "" + +#: ../virt-df/virt_df.ml:354 ../virt-df/virt_df.ml:356 +msgid "Show inodes instead of blocks" +msgstr "" + #: ../virt-ctrl/vc_mainwindow.ml:137 msgid "Shutdown" msgstr "" +#: ../virt-df/virt_df.ml:499 +msgid "Size" +msgstr "" + #: ../virt-ctrl/vc_mainwindow.ml:127 msgid "Start" msgstr "" @@ -375,6 +447,10 @@ msgstr "" msgid "This machine" msgstr "" +#: ../virt-df/virt_df.ml:502 +msgid "Type" +msgstr "" + #: ../virt-ctrl/vc_connection_dlg.ml:160 msgid "URI connection" msgstr "" @@ -391,6 +467,10 @@ msgstr "" msgid "Use '%s help command' for help on a command." msgstr "" +#: ../virt-df/virt_df.ml:498 ../virt-df/virt_df.ml:499 +msgid "Used" +msgstr "" + #: ../virt-ctrl/vc_mainwindow.ml:23 msgid "Virtual Control" msgstr "" @@ -439,10 +519,26 @@ msgstr "" msgid "crashed" msgstr "" +#: ../virt-df/virt_df.ml:236 +msgid "detection of unpartitioned devices not yet supported" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:242 msgid "domain %s: not found. Additional info: %s" msgstr "" +#: ../virt-df/virt_df_ext2.ml:39 +msgid "error reading ext2/ext3 magic" +msgstr "" + +#: ../virt-df/virt_df.ml:182 +msgid "error reading extended partition" +msgstr "" + +#: ../virt-df/virt_df.ml:149 +msgid "error reading partition table" +msgstr "" + #: ../virt-ctrl/vc_dbus.ml:239 msgid "error set after getting System bus" msgstr "" @@ -463,6 +559,18 @@ msgstr "" msgid "flag should be '%s'" msgstr "" +#: ../virt-df/virt_df.ml:419 +msgid "get_xml_desc didn't return " +msgstr "" + +#: ../virt-df/virt_df.ml:427 +msgid "get_xml_desc returned no node in XML" +msgstr "" + +#: ../virt-df/virt_df.ml:430 +msgid "get_xml_desc returned strange node" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:700 msgid "help: %s: command not found" msgstr "" @@ -519,10 +627,18 @@ msgstr "" msgid "offline" msgstr "" +#: ../virt-df/virt_df_ext2.ml:42 +msgid "partition marked EXT2/3 but no valid filesystem" +msgstr "" + #: ../virt-ctrl/vc_helpers.ml:55 ../mlvirsh/mlvirsh.ml:290 msgid "paused" msgstr "" +#: ../virt-df/virt_df.ml:188 +msgid "probe_extended_partition: internal error" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:376 msgid "read bytes: %Ld\\n" msgstr "" @@ -599,6 +715,14 @@ msgstr "" msgid "unknown" msgstr "" +#: ../virt-df/virt_df.ml:246 +msgid "unsupported partition type %02x" +msgstr "" + +#: ../virt-df/virt_df.ml:363 +msgid "virt-df : like 'df', shows disk space used in guests\n\nSUMMARY\n virt-df [-options]\n\nOPTIONS" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:360 msgid "virtual CPU: %d\\n" msgstr "" diff --git a/po/virt-top.pot b/po/virt-top.pot index f67d15b..9849025 100644 --- a/po/virt-top.pot +++ b/po/virt-top.pot @@ -8,7 +8,7 @@ msgid "" msgstr "" "Project-Id-Version: PACKAGE VERSION\n" "Report-Msgid-Bugs-To: \n" -"POT-Creation-Date: 2008-03-28 16:59+0000\n" +"POT-Creation-Date: 2008-03-28 17:12+0000\n" "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" "Last-Translator: FULL NAME \n" "Language-Team: LANGUAGE \n" @@ -21,6 +21,18 @@ msgstr "" msgid "%s: command not found" msgstr "" +#: ../virt-df/virt_df.ml:362 +msgid "%s: unknown parameter" +msgstr "" + +#: ../virt-df/virt_df.ml:514 +msgid "(device omitted)" +msgstr "" + +#: ../virt-df/virt_df.ml:498 +msgid "1K-blocks" +msgstr "" + #: ../virt-ctrl/vc_mainwindow.ml:97 msgid "About ..." msgstr "" @@ -29,6 +41,10 @@ msgstr "" msgid "Attach device to domain." msgstr "" +#: ../virt-df/virt_df.ml:499 ../virt-df/virt_df.ml:498 +msgid "Available" +msgstr "" + #: ../virt-ctrl/vc_connections.ml:408 msgid "CPU" msgstr "" @@ -53,6 +69,10 @@ msgstr "" msgid "Connect to ..." msgstr "" +#: ../virt-df/virt_df.ml:348 ../virt-df/virt_df.ml:346 +msgid "Connect to URI (default: Xen)" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:476 msgid "Core dump a domain to a file for analysis." msgstr "" @@ -101,6 +121,10 @@ msgstr "" msgid "Display the network interface statistics for a domain." msgstr "" +#: ../virt-df/virt_df.ml:358 +msgid "Display version and exit" +msgstr "" + #: ../virt-ctrl/vc_mainwindow.ml:61 msgid "Error" msgstr "" @@ -109,6 +133,10 @@ msgstr "" msgid "File" msgstr "" +#: ../virt-df/virt_df.ml:502 +msgid "Filesystem" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:606 msgid "Get the current scheduler parameters for a domain." msgstr "" @@ -133,6 +161,30 @@ msgstr "" msgid "ID" msgstr "" +#: ../virt-df/virt_df.ml:500 +msgid "IFree" +msgstr "" + +#: ../virt-df/virt_df.ml:500 +msgid "IUse" +msgstr "" + +#: ../virt-df/virt_df.ml:500 +msgid "Inodes" +msgstr "" + +#: ../virt-df/virt_df_lvm2.ml:33 +msgid "LVM2 not supported yet" +msgstr "" + +#: ../virt-df/virt_df_ext2.ml:82 +msgid "Linux ext2/3" +msgstr "" + +#: ../virt-df/virt_df_linux_swap.ml:33 +msgid "Linux swap" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:557 msgid "List the active networks." msgstr "" @@ -165,6 +217,10 @@ msgstr "" msgid "Memory" msgstr "" +#: ../virt-df/virt_df.ml:382 +msgid "NB: If you want to monitor a local Xen hypervisor, you usually need to be root" +msgstr "" + #: ../virt-ctrl/vc_connections.ml:406 msgid "Name" msgstr "" @@ -201,6 +257,10 @@ msgstr "" msgid "Print node information." msgstr "" +#: ../virt-df/virt_df.ml:352 ../virt-df/virt_df.ml:350 +msgid "Print sizes in human-readable format" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:440 msgid "Print the ID of a domain." msgstr "" @@ -349,10 +409,22 @@ msgstr "" msgid "Set whether a network autostarts at boot." msgstr "" +#: ../virt-df/virt_df.ml:344 ../virt-df/virt_df.ml:342 +msgid "Show all domains (default: only active domains)" +msgstr "" + +#: ../virt-df/virt_df.ml:356 ../virt-df/virt_df.ml:354 +msgid "Show inodes instead of blocks" +msgstr "" + #: ../virt-ctrl/vc_mainwindow.ml:137 msgid "Shutdown" msgstr "" +#: ../virt-df/virt_df.ml:499 +msgid "Size" +msgstr "" + #: ../virt-ctrl/vc_mainwindow.ml:127 msgid "Start" msgstr "" @@ -381,6 +453,10 @@ msgstr "" msgid "This machine" msgstr "" +#: ../virt-df/virt_df.ml:502 +msgid "Type" +msgstr "" + #: ../virt-ctrl/vc_connection_dlg.ml:160 msgid "URI connection" msgstr "" @@ -397,6 +473,10 @@ msgstr "" msgid "Use '%s help command' for help on a command." msgstr "" +#: ../virt-df/virt_df.ml:499 ../virt-df/virt_df.ml:498 +msgid "Used" +msgstr "" + #: ../virt-ctrl/vc_mainwindow.ml:23 msgid "Virtual Control" msgstr "" @@ -445,10 +525,26 @@ msgstr "" msgid "crashed" msgstr "" +#: ../virt-df/virt_df.ml:236 +msgid "detection of unpartitioned devices not yet supported" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:242 msgid "domain %s: not found. Additional info: %s" msgstr "" +#: ../virt-df/virt_df_ext2.ml:39 +msgid "error reading ext2/ext3 magic" +msgstr "" + +#: ../virt-df/virt_df.ml:182 +msgid "error reading extended partition" +msgstr "" + +#: ../virt-df/virt_df.ml:149 +msgid "error reading partition table" +msgstr "" + #: ../virt-ctrl/vc_dbus.ml:239 msgid "error set after getting System bus" msgstr "" @@ -469,6 +565,18 @@ msgstr "" msgid "flag should be '%s'" msgstr "" +#: ../virt-df/virt_df.ml:419 +msgid "get_xml_desc didn't return " +msgstr "" + +#: ../virt-df/virt_df.ml:427 +msgid "get_xml_desc returned no node in XML" +msgstr "" + +#: ../virt-df/virt_df.ml:430 +msgid "get_xml_desc returned strange node" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:700 msgid "help: %s: command not found" msgstr "" @@ -525,10 +633,18 @@ msgstr "" msgid "offline" msgstr "" +#: ../virt-df/virt_df_ext2.ml:42 +msgid "partition marked EXT2/3 but no valid filesystem" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:290 ../virt-ctrl/vc_helpers.ml:55 msgid "paused" msgstr "" +#: ../virt-df/virt_df.ml:188 +msgid "probe_extended_partition: internal error" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:376 msgid "read bytes: %Ld\\n" msgstr "" @@ -605,6 +721,14 @@ msgstr "" msgid "unknown" msgstr "" +#: ../virt-df/virt_df.ml:246 +msgid "unsupported partition type %02x" +msgstr "" + +#: ../virt-df/virt_df.ml:363 +msgid "virt-df : like 'df', shows disk space used in guests\n\nSUMMARY\n virt-df [-options]\n\nOPTIONS" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:360 msgid "virtual CPU: %d\\n" msgstr "" -- cgit v1.1 From 46d3772c9a5cf786fa4fbdb2ba29512580101f32 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Fri, 28 Mar 2008 17:30:32 +0000 Subject: Internationalize virt-top. --- virt-top/.depend | 34 ++++---- virt-top/Makefile.in | 15 ++-- virt-top/virt_top.ml | 178 ++++++++++++++++++++++++----------------- virt-top/virt_top_calendar1.ml | 4 +- virt-top/virt_top_calendar2.ml | 4 +- virt-top/virt_top_csv.ml | 2 + virt-top/virt_top_main.ml | 3 +- virt-top/virt_top_utils.ml | 2 + virt-top/virt_top_xml.ml | 4 +- 9 files changed, 147 insertions(+), 99 deletions(-) mode change 100755 => 100644 virt-top/virt_top.ml mode change 100755 => 100644 virt-top/virt_top_csv.ml mode change 100755 => 100644 virt-top/virt_top_main.ml mode change 100755 => 100644 virt-top/virt_top_utils.ml mode change 100755 => 100644 virt-top/virt_top_xml.ml diff --git a/virt-top/.depend b/virt-top/.depend index 8a8d99e..3a2985d 100644 --- a/virt-top/.depend +++ b/virt-top/.depend @@ -1,18 +1,20 @@ virt_top.cmi: ../libvirt/libvirt.cmi virt_top_utils.cmi: ../libvirt/libvirt.cmi -virt_top_calendar1.cmo: virt_top.cmi -virt_top_calendar1.cmx: virt_top.cmx -virt_top_calendar2.cmo: virt_top.cmi -virt_top_calendar2.cmx: virt_top.cmx -virt_top_csv.cmo: virt_top.cmi -virt_top_csv.cmx: virt_top.cmx -virt_top_main.cmo: virt_top.cmi ../libvirt/libvirt.cmi -virt_top_main.cmx: virt_top.cmx ../libvirt/libvirt.cmx -virt_top.cmo: virt_top_utils.cmi ../libvirt/libvirt_version.cmi \ - ../libvirt/libvirt.cmi virt_top.cmi -virt_top.cmx: virt_top_utils.cmx ../libvirt/libvirt_version.cmx \ - ../libvirt/libvirt.cmx virt_top.cmi -virt_top_utils.cmo: ../libvirt/libvirt.cmi virt_top_utils.cmi -virt_top_utils.cmx: ../libvirt/libvirt.cmx virt_top_utils.cmi -virt_top_xml.cmo: virt_top.cmi ../libvirt/libvirt.cmi -virt_top_xml.cmx: virt_top.cmx ../libvirt/libvirt.cmx +virt_top_calendar1.cmo: virt_top_gettext.cmo virt_top.cmi +virt_top_calendar1.cmx: virt_top_gettext.cmx virt_top.cmx +virt_top_calendar2.cmo: virt_top_gettext.cmo virt_top.cmi +virt_top_calendar2.cmx: virt_top_gettext.cmx virt_top.cmx +virt_top_csv.cmo: virt_top_gettext.cmo virt_top.cmi +virt_top_csv.cmx: virt_top_gettext.cmx virt_top.cmx +virt_top_main.cmo: virt_top_gettext.cmo virt_top.cmi ../libvirt/libvirt.cmi +virt_top_main.cmx: virt_top_gettext.cmx virt_top.cmx ../libvirt/libvirt.cmx +virt_top.cmo: virt_top_utils.cmi virt_top_gettext.cmo \ + ../libvirt/libvirt_version.cmi ../libvirt/libvirt.cmi virt_top.cmi +virt_top.cmx: virt_top_utils.cmx virt_top_gettext.cmx \ + ../libvirt/libvirt_version.cmx ../libvirt/libvirt.cmx virt_top.cmi +virt_top_utils.cmo: virt_top_gettext.cmo ../libvirt/libvirt.cmi \ + virt_top_utils.cmi +virt_top_utils.cmx: virt_top_gettext.cmx ../libvirt/libvirt.cmx \ + virt_top_utils.cmi +virt_top_xml.cmo: virt_top_gettext.cmo virt_top.cmi ../libvirt/libvirt.cmi +virt_top_xml.cmx: virt_top_gettext.cmx virt_top.cmx ../libvirt/libvirt.cmx diff --git a/virt-top/Makefile.in b/virt-top/Makefile.in index 31cd828..390fc1b 100755 --- a/virt-top/Makefile.in +++ b/virt-top/Makefile.in @@ -30,25 +30,30 @@ pkg_xml_light = @pkg_xml_light@ pkg_csv = @pkg_csv@ pkg_calendar = @pkg_calendar@ pkg_calendar2 = @pkg_calendar2@ +pkg_gettext = @pkg_gettext@ OCAMLCPACKAGES := -package unix,extlib,curses,str -OBJS := virt_top_utils.cmo virt_top.cmo +ifeq ($(pkg_gettext),yes) +OCAMLCPACKAGES += -package gettext-stub +endif + +OBJS := virt_top_gettext.cmo virt_top_utils.cmo virt_top.cmo ifeq ($(pkg_xml_light),yes) OBJS += virt_top_xml.cmo -OCAMLCPACKAGES := $(OCAMLCPACKAGES),xml-light +OCAMLCPACKAGES += -package xml-light endif ifeq ($(pkg_csv),yes) OBJS += virt_top_csv.cmo -OCAMLCPACKAGES := $(OCAMLCPACKAGES),csv +OCAMLCPACKAGES += -package csv endif ifeq ($(pkg_calendar),yes) OBJS += virt_top_calendar1.cmo -OCAMLCPACKAGES := $(OCAMLCPACKAGES),calendar +OCAMLCPACKAGES += -package calendar endif ifneq ($(pkg_calendar2),no) OBJS += virt_top_calendar2.cmo -OCAMLCPACKAGES := $(OCAMLCPACKAGES),calendar +OCAMLCPACKAGES += -package calendar endif OBJS += virt_top_main.cmo diff --git a/virt-top/virt_top.ml b/virt-top/virt_top.ml old mode 100755 new mode 100644 index b3e2628..a8c4839 --- a/virt-top/virt_top.ml +++ b/virt-top/virt_top.ml @@ -21,6 +21,7 @@ open Printf open ExtList open Curses +open Virt_top_gettext.Gettext open Virt_top_utils module C = Libvirt.Connect @@ -36,7 +37,7 @@ let parse_device_xml : (int -> [>`R] D.t -> string list * string list) ref = (* Hooks for CSV support (see virt_top_csv.ml). *) let csv_start : (string -> unit) ref = ref ( - fun _ -> failwith "virt-top was compiled without support for CSV files" + fun _ -> failwith (s_ "virt-top was compiled without support for CSV files") ) let csv_write : (string list -> unit) ref = ref ( @@ -47,7 +48,7 @@ let csv_write : (string list -> unit) ref = let parse_date_time : (string -> float) ref = ref ( fun _ -> - failwith "virt-top was compiled without support for dates and times" + failwith (s_ "virt-top was compiled without support for dates and times") ) (* Sort order. *) @@ -59,15 +60,15 @@ let all_sort_fields = [ NetRX; NetTX; BlockRdRq; BlockWrRq ] let printable_sort_order = function - | Processor -> "%CPU" - | Memory -> "%MEM" - | Time -> "TIME (CPU time)" - | DomainID -> "Domain ID" - | DomainName -> "Domain name" - | NetRX -> "Net RX bytes" - | NetTX -> "Net TX bytes" - | BlockRdRq -> "Block read reqs" - | BlockWrRq -> "Block write reqs" + | Processor -> s_ "%CPU" + | Memory -> s_ "%MEM" + | Time -> s_ "TIME (CPU time)" + | DomainID -> s_ "Domain ID" + | DomainName -> s_ "Domain name" + | NetRX -> s_ "Net RX bytes" + | NetTX -> s_ "Net TX bytes" + | BlockRdRq -> s_ "Block read reqs" + | BlockWrRq -> s_ "Block write reqs" let sort_order_of_cli = function | "cpu" | "processor" -> Processor | "mem" | "memory" -> Memory @@ -76,7 +77,10 @@ let sort_order_of_cli = function | "name" -> DomainName | "netrx" -> NetRX | "nettx" -> NetTX | "blockrdrq" -> BlockRdRq | "blockwrrq" -> BlockWrRq - | str -> failwith (str ^ ": sort order should be: cpu|mem|time|id|name|netrx|nettx|blockrdrq|blockwrrq") + | str -> + failwith + (sprintf (f_ "%s: sort order should be: %s") + str "cpu|mem|time|id|name|netrx|nettx|blockrdrq|blockwrrq") let cli_of_sort_order = function | Processor -> "cpu" | Memory -> "mem" @@ -96,7 +100,10 @@ let display_of_cli = function | "pcpu" -> PCPUDisplay | "block" -> BlockDisplay | "net" -> NetDisplay - | str -> failwith (str ^ ": display should be task|pcpu|block|net") + | str -> + failwith + (sprintf (f_ "%s: display should be %s") + str "task|pcpu|block|net") let cli_of_display = function | TaskDisplay -> "task" | PCPUDisplay -> "pcpu" @@ -135,7 +142,7 @@ let start_up () = (* Read command line arguments. *) let rec set_delay newdelay = if newdelay <= 0. then - failwith "-d: cannot set a negative delay"; + failwith (s_ "-d: cannot set a negative delay"); delay := int_of_float (newdelay *. 1000.) and set_uri = function "" -> uri := None | u -> uri := Some u and set_sort order = sort_order := sort_order_of_cli order @@ -150,29 +157,50 @@ let start_up () = and set_end_time time = end_time := Some ((!parse_date_time) time) in let argspec = Arg.align [ - "-1", Arg.Unit set_pcpu_mode, " Start by displaying pCPUs (default: tasks)"; - "-2", Arg.Unit set_net_mode, " Start by displaying network interfaces"; - "-3", Arg.Unit set_block_mode, " Start by displaying block devices"; - "-b", Arg.Set batch_mode, " Batch mode"; - "-c", Arg.String set_uri, "uri Connect to URI (default: Xen)"; - "--connect", Arg.String set_uri, "uri Connect to URI (default: Xen)"; - "--csv", Arg.String set_csv, "file Log statistics to CSV file"; - "--no-csv-cpu", Arg.Clear csv_cpu, " Disable CPU stats in CSV"; - "--no-csv-block", Arg.Clear csv_block, " Disable block device stats in CSV"; - "--no-csv-net", Arg.Clear csv_net, " Disable net stats in CSV"; - "-d", Arg.Float set_delay, "delay Delay time interval (seconds)"; - "--debug", Arg.Set_string debug_file, "file Send debug messages to file"; - "--end-time", Arg.String set_end_time, "time Exit at given time"; - "--hist-cpu", Arg.Set_int historical_cpu_delay, "secs Historical CPU delay"; - "--init-file", Arg.String set_init_file, "file Set name of init file"; - "--no-init-file", Arg.Unit no_init_file, " Do not read init file"; - "-n", Arg.Set_int iterations, "iterations Number of iterations to run"; - "-o", Arg.String set_sort, "sort Set sort order (cpu|mem|time|id|name)"; - "-s", Arg.Set secure_mode, " Secure (\"kiosk\") mode"; - "--script", Arg.Set script_mode, " Run from a script (no user interface)"; + "-1", Arg.Unit set_pcpu_mode, + " " ^ s_ "Start by displaying pCPUs (default: tasks)"; + "-2", Arg.Unit set_net_mode, + " " ^ s_ "Start by displaying network interfaces"; + "-3", Arg.Unit set_block_mode, + " " ^ s_ "Start by displaying block devices"; + "-b", Arg.Set batch_mode, + " " ^ s_ "Batch mode"; + "-c", Arg.String set_uri, + "uri " ^ s_ "Connect to URI (default: Xen)"; + "--connect", Arg.String set_uri, + "uri " ^ s_ "Connect to URI (default: Xen)"; + "--csv", Arg.String set_csv, + "file " ^ s_ "Log statistics to CSV file"; + "--no-csv-cpu", Arg.Clear csv_cpu, + " " ^ s_ "Disable CPU stats in CSV"; + "--no-csv-block", Arg.Clear csv_block, + " " ^ s_ "Disable block device stats in CSV"; + "--no-csv-net", Arg.Clear csv_net, + " " ^ s_ "Disable net stats in CSV"; + "-d", Arg.Float set_delay, + "delay " ^ s_ "Delay time interval (seconds)"; + "--debug", Arg.Set_string debug_file, + "file " ^ s_ "Send debug messages to file"; + "--end-time", Arg.String set_end_time, + "time " ^ s_ "Exit at given time"; + "--hist-cpu", Arg.Set_int historical_cpu_delay, + "secs " ^ s_ "Historical CPU delay"; + "--init-file", Arg.String set_init_file, + "file " ^ s_ "Set name of init file"; + "--no-init-file", Arg.Unit no_init_file, + " " ^ s_ "Do not read init file"; + "-n", Arg.Set_int iterations, + "iterations " ^ s_ "Number of iterations to run"; + "-o", Arg.String set_sort, + "sort " ^ sprintf (f_ "Set sort order (%s)") "cpu|mem|time|id|name"; + "-s", Arg.Set secure_mode, + " " ^ s_ "Secure (\"kiosk\") mode"; + "--script", Arg.Set script_mode, + " " ^ s_ "Run from a script (no user interface)"; ] in - let anon_fun str = raise (Arg.Bad (str ^ ": unknown parameter")) in - let usage_msg = "virt-top : a 'top'-like utility for virtualization + let anon_fun str = + raise (Arg.Bad (sprintf (f_ "%s: unknown parameter") str)) in + let usage_msg = s_ "virt-top : a 'top'-like utility for virtualization SUMMARY virt-top [-options] @@ -202,7 +230,7 @@ OPTIONS" in | _, "end-time", t -> set_end_time t | _, "overwrite-init-file", "false" -> no_init_file () | lineno, key, _ -> - eprintf "%s:%d: configuration item ``%s'' ignored\n%!" + eprintf (f_ "%s:%d: configuration item ``%s'' ignored\n%!") filename lineno key ) config in @@ -227,7 +255,7 @@ OPTIONS" in prerr_endline (Libvirt.Virterror.to_string err); (* If non-root and no explicit connection URI, print a warning. *) if Unix.geteuid () <> 0 && name = None then ( - print_endline "NB: If you want to monitor a local Xen hypervisor, you usually need to be root"; + print_endline (s_ "NB: If you want to monitor a local Xen hypervisor, you usually need to be root"); ); exit 1 in @@ -1113,14 +1141,14 @@ let redraw = total_cpu_time, total_memory, total_domU_memory) = totals in mvaddstr summary_lineno 0 - (sprintf "%d domains, %d active, %d running, %d sleeping, %d paused, %d inactive D:%d O:%d X:%d" + (sprintf (f_ "%d domains, %d active, %d running, %d sleeping, %d paused, %d inactive D:%d O:%d X:%d") count active running blocked paused inactive shutdown shutoff crashed); (* Total %CPU used, and memory summary. *) let percent_cpu = 100. *. total_cpu_time /. total_cpu in mvaddstr (summary_lineno+1) 0 - (sprintf "CPU: %2.1f%% Mem: %Ld MB (%Ld MB by guests)" + (sprintf (f_ "CPU: %2.1f%% Mem: %Ld MB (%Ld MB by guests)") percent_cpu (total_memory /^ 1024L) (total_domU_memory /^ 1024L)); (* Time to grab another historical %CPU for the list? *) @@ -1287,20 +1315,21 @@ and get_key_press setup = ) and change_delay () = - print_msg (sprintf "Change delay from %.1f to: " (float !delay /. 1000.)); + print_msg + (sprintf (f_ "Change delay from %.1f to: ") (float !delay /. 1000.)); let str = get_string 16 in (* Try to parse the number. *) let error = try let newdelay = float_of_string str in if newdelay <= 0. then ( - print_msg "Delay must be > 0"; true + print_msg (s_ "Delay must be > 0"); true ) else ( delay := int_of_float (newdelay *. 1000.); false ) with Failure "float_of_string" -> - print_msg "Not a valid number"; true in + print_msg (s_ "Not a valid number"); true in refresh (); sleep (if error then 2 else 1) @@ -1308,8 +1337,8 @@ and change_sort_order () = clear (); let lines, cols = get_size () in - mvaddstr top_lineno 0 "Set sort order for main display"; - mvaddstr summary_lineno 0 "Type key or use up and down cursor keys."; + mvaddstr top_lineno 0 (s_ "Set sort order for main display"); + mvaddstr summary_lineno 0 (s_ "Type key or use up and down cursor keys."); attron A.reverse; mvaddstr header_lineno 0 (pad cols "KEY Sort field"); @@ -1458,8 +1487,8 @@ and _write_init_file filename = let fp = fprintf in let nl () = fp chan "\n" in - fp chan "# .virt-toprc virt-top configuration file\n"; - fp chan "# generated on %s by %s\n" printable_date_time username; + let () = fp chan (f_ "# .virt-toprc virt-top configuration file\n") in + let () = fp chan (f_ "# generated on %s by %s\n") printable_date_time username in nl (); fp chan "display %s\n" (cli_of_display !display_mode); fp chan "delay %g\n" (float !delay /. 1000.); @@ -1473,13 +1502,13 @@ and _write_init_file filename = if !batch_mode = true then fp chan "batch true\n"; if !secure_mode = true then fp chan "secure true\n"; nl (); - fp chan "# To send debug and error messages to a file, uncomment next line\n"; + let () = fp chan (f_ "# To send debug and error messages to a file, uncomment next line\n") in fp chan "#debug virt-top.out\n"; nl (); - fp chan "# Enable CSV output to the named file\n"; + let () = fp chan (f_ "# Enable CSV output to the named file\n") in fp chan "#csv virt-top.csv\n"; nl (); - fp chan "# To protect this file from being overwritten, uncomment next line\n"; + let () = fp chan (f_ "# To protect this file from being overwritten, uncomment next line\n") in fp chan "#overwrite-init-file false\n"; close_out chan; @@ -1491,13 +1520,14 @@ and _write_init_file filename = (* Rename filename.new to filename. *) Unix.rename (filename ^ ".new") filename; - print_msg (sprintf "Wrote settings to %s" filename); + print_msg (sprintf (f_ "Wrote settings to %s") filename); refresh (); sleep 2 with - | Sys_error err -> print_msg "Error: %s"; refresh (); sleep 2 + | Sys_error err -> + print_msg (s_ "Error" ^ ": " ^ err); refresh (); sleep 2 | Unix.Unix_error (err, fn, str) -> - print_msg (sprintf "Error: %s %s %s" (Unix.error_message err) fn str); + print_msg (s_ ("Error" ^ ": " ^ Unix.error_message err ^ fn ^ str)); refresh (); sleep 2 @@ -1510,7 +1540,7 @@ and show_help (_, _, _, _, _, hostname, (* Banner at the top of the screen. *) let banner = - sprintf "virt-top %s (libvirt %d.%d.%d) by Red Hat" + sprintf (f_ "virt-top %s (libvirt %d.%d.%d) by Red Hat") Libvirt_version.version libvirt_major libvirt_minor libvirt_release in let banner = pad cols banner in attron A.reverse; @@ -1519,18 +1549,18 @@ and show_help (_, _, _, _, _, hostname, (* Status. *) mvaddstr 1 0 - (sprintf "Delay: %.1f secs; Batch: %s; Secure: %s; Sort: %s" + (sprintf (f_ "Delay: %.1f secs; Batch: %s; Secure: %s; Sort: %s") (float !delay /. 1000.) (if !batch_mode then "On" else "Off") (if !secure_mode then "On" else "Off") (printable_sort_order !sort_order)); mvaddstr 2 0 - (sprintf "Connect: %s; Hostname: %s" + (sprintf (f_ "Connect: %s; Hostname: %s") (match !uri with None -> "default" | Some s -> s) hostname); (* Misc keys on left. *) - let banner = pad 38 "MAIN KEYS" in + let banner = pad 38 (s_ "MAIN KEYS") in attron A.reverse; mvaddstr header_lineno 1 banner; attroff A.reverse; @@ -1544,26 +1574,26 @@ and show_help (_, _, _, _, _, hostname, move lineno 1; attron A.bold; addstr keys; attroff A.bold; move lineno 10; addstr description; () in - key "space ^L" "Update display"; - key "q" "Quit"; - key "d s" "Set update interval"; - key "h" "Help"; + key "space ^L" (s_ "Update display"); + key "q" (s_ "Quit"); + key "d s" (s_ "Set update interval"); + key "h" (s_ "Help"); (* Sort order. *) ignore (get_lineno ()); - let banner = pad 38 "SORTING" in + let banner = pad 38 (s_ "SORTING") in attron A.reverse; mvaddstr (get_lineno ()) 1 banner; attroff A.reverse; - key "P" "Sort by %CPU"; - key "M" "Sort by %MEM"; - key "T" "Sort by TIME"; - key "N" "Sort by ID"; - key "F" "Select sort field"; + key "P" (s_ "Sort by %CPU"); + key "M" (s_ "Sort by %MEM"); + key "T" (s_ "Sort by TIME"); + key "N" (s_ "Sort by ID"); + key "F" (s_ "Select sort field"); (* Display modes on right. *) - let banner = pad 39 "DISPLAY MODES" in + let banner = pad 39 (s_ "DISPLAY MODES") in attron A.reverse; mvaddstr header_lineno 40 banner; attroff A.reverse; @@ -1577,18 +1607,18 @@ and show_help (_, _, _, _, _, hostname, move lineno 40; attron A.bold; addstr keys; attroff A.bold; move lineno 49; addstr description; () in - key "0" "Domains display"; - key "1" "Toggle physical CPUs"; - key "2" "Toggle network interfaces"; - key "3" "Toggle block devices"; + key "0" (s_ "Domains display"); + key "1" (s_ "Toggle physical CPUs"); + key "2" (s_ "Toggle network interfaces"); + key "3" (s_ "Toggle block devices"); (* Update screen and wait for key press. *) mvaddstr (lines-1) 0 - "More help in virt-top(1) man page. Press any key to return."; + (s_ "More help in virt-top(1) man page. Press any key to return."); refresh (); ignore (getch ()) and unknown_command k = - print_msg "Unknown command - try 'h' for help"; + print_msg (s_ "Unknown command - try 'h' for help"); refresh (); sleep 1 diff --git a/virt-top/virt_top_calendar1.ml b/virt-top/virt_top_calendar1.ml index 438a791..779e62b 100755 --- a/virt-top/virt_top_calendar1.ml +++ b/virt-top/virt_top_calendar1.ml @@ -20,7 +20,9 @@ *) open Printf -open ExtString ;; +open ExtString + +open Virt_top_gettext.Gettext ;; Virt_top.parse_date_time := fun time -> diff --git a/virt-top/virt_top_calendar2.ml b/virt-top/virt_top_calendar2.ml index dd00c79..3d042e3 100755 --- a/virt-top/virt_top_calendar2.ml +++ b/virt-top/virt_top_calendar2.ml @@ -22,7 +22,9 @@ open CalendarLib open Printf -open ExtString ;; +open ExtString + +open Virt_top_gettext.Gettext ;; Virt_top.parse_date_time := fun time -> diff --git a/virt-top/virt_top_csv.ml b/virt-top/virt_top_csv.ml old mode 100755 new mode 100644 index 8f8c45d..3393e3a --- a/virt-top/virt_top_csv.ml +++ b/virt-top/virt_top_csv.ml @@ -19,6 +19,8 @@ This file contains all code which requires CSV support. *) +open Virt_top_gettext.Gettext + (* Output channel, or None if CSV output not enabled. *) let chan = ref None ;; diff --git a/virt-top/virt_top_main.ml b/virt-top/virt_top_main.ml old mode 100755 new mode 100644 index ba98e7e..4ab60ad --- a/virt-top/virt_top_main.ml +++ b/virt-top/virt_top_main.ml @@ -21,6 +21,7 @@ open Curses +open Virt_top_gettext.Gettext open Virt_top (* Note: make sure we catch any exceptions and clean up the display. @@ -43,7 +44,7 @@ let error = true | exn -> if not script_mode then endwin (); - prerr_endline ("Error: " ^ Printexc.to_string exn); + prerr_endline (s_ "Error" ^ ": " ^ Printexc.to_string exn); true let () = diff --git a/virt-top/virt_top_utils.ml b/virt-top/virt_top_utils.ml old mode 100755 new mode 100644 index 53c9bf1..c668fb9 --- a/virt-top/virt_top_utils.ml +++ b/virt-top/virt_top_utils.ml @@ -21,6 +21,8 @@ open Printf +open Virt_top_gettext.Gettext + module C = Libvirt.Connect module D = Libvirt.Domain module N = Libvirt.Network diff --git a/virt-top/virt_top_xml.ml b/virt-top/virt_top_xml.ml old mode 100755 new mode 100644 index 8bf3d8a..73a4906 --- a/virt-top/virt_top_xml.ml +++ b/virt-top/virt_top_xml.ml @@ -21,6 +21,8 @@ open ExtList +open Virt_top_gettext.Gettext + module C = Libvirt.Connect module D = Libvirt.Domain module N = Libvirt.Network ;; @@ -41,7 +43,7 @@ fun id dom -> ) children in List.concat devices | _ -> - failwith "get_xml_desc didn't return " in + failwith (s_ "get_xml_desc didn't return ") in let rec target_dev_of = function | [] -> None | Xml.Element ("target", attrs, _) :: rest -> -- cgit v1.1 From 5c18720b51f3938cea534f97fbcfcaabff10d7e1 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Fri, 28 Mar 2008 17:30:38 +0000 Subject: Updated PO files. --- po/ja.po | 278 +++++++++++++++++++++++++++++++++++++++++++++++++++++-- po/virt-top.pot | 280 ++++++++++++++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 543 insertions(+), 15 deletions(-) diff --git a/po/ja.po b/po/ja.po index 5031756..ebef7a4 100644 --- a/po/ja.po +++ b/po/ja.po @@ -11,18 +11,66 @@ msgstr "" "Content-Transfer-Encoding: 8bit\n" "Plural-Forms: nplurals=1; plural=0;\n" +#: ../virt-top/virt_top.ml:1490 +msgid "# .virt-toprc virt-top configuration file\\n" +msgstr "" + +#: ../virt-top/virt_top.ml:1508 +msgid "# Enable CSV output to the named file\\n" +msgstr "" + +#: ../virt-top/virt_top.ml:1511 +msgid "# To protect this file from being overwritten, uncomment next line\\n" +msgstr "" + +#: ../virt-top/virt_top.ml:1505 +msgid "# To send debug and error messages to a file, uncomment next line\\n" +msgstr "" + +#: ../virt-top/virt_top.ml:1491 +msgid "# generated on %s by %s\\n" +msgstr "" + +#: ../virt-top/virt_top.ml:63 +msgid "%CPU" +msgstr "" + +#: ../virt-top/virt_top.ml:64 +msgid "%MEM" +msgstr "" + +#: ../virt-top/virt_top.ml:1144 +msgid "%d domains, %d active, %d running, %d sleeping, %d paused, %d inactive D:%d O:%d X:%d" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:716 msgid "%s: command not found" msgstr "" -#: ../virt-df/virt_df.ml:362 +#: ../virt-top/virt_top.ml:105 +msgid "%s: display should be %s" +msgstr "" + +#: ../virt-top/virt_top.ml:82 +msgid "%s: sort order should be: %s" +msgstr "" + +#: ../virt-top/virt_top.ml:202 ../virt-df/virt_df.ml:362 msgid "%s: unknown parameter" msgstr "" +#: ../virt-top/virt_top.ml:233 +msgid "%s:%d: configuration item ``%s'' ignored\\n%!" +msgstr "" + #: ../virt-df/virt_df.ml:514 msgid "(device omitted)" msgstr "" +#: ../virt-top/virt_top.ml:145 +msgid "-d: cannot set a negative delay" +msgstr "" + #: ../virt-df/virt_df.ml:498 msgid "1K-blocks" msgstr "" @@ -39,6 +87,18 @@ msgstr "" msgid "Available" msgstr "" +#: ../virt-top/virt_top.ml:167 +msgid "Batch mode" +msgstr "" + +#: ../virt-top/virt_top.ml:70 +msgid "Block read reqs" +msgstr "" + +#: ../virt-top/virt_top.ml:71 +msgid "Block write reqs" +msgstr "" + #: ../virt-ctrl/vc_connections.ml:408 msgid "CPU" msgstr "" @@ -47,10 +107,18 @@ msgstr "" msgid "CPU affinity" msgstr "" +#: ../virt-top/virt_top.ml:1151 +msgid "CPU: %2.1f%% Mem: %Ld MB (%Ld MB by guests)" +msgstr "" + #: ../virt-ctrl/vc_connection_dlg.ml:182 msgid "Cancel" msgstr "" +#: ../virt-top/virt_top.ml:1319 +msgid "Change delay from %.1f to: " +msgstr "" + #: ../mlvirsh/mlvirsh.ml:409 msgid "Close an existing hypervisor connection." msgstr "" @@ -63,10 +131,14 @@ msgstr "" msgid "Connect to ..." msgstr "" -#: ../virt-df/virt_df.ml:346 ../virt-df/virt_df.ml:348 +#: ../virt-top/virt_top.ml:169 ../virt-top/virt_top.ml:171 ../virt-df/virt_df.ml:346 ../virt-df/virt_df.ml:348 msgid "Connect to URI (default: Xen)" msgstr "" +#: ../virt-top/virt_top.ml:1558 +msgid "Connect: %s; Hostname: %s" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:476 msgid "Core dump a domain to a file for analysis." msgstr "" @@ -79,6 +151,10 @@ msgstr "" msgid "Create a network from an XML file." msgstr "" +#: ../virt-top/virt_top.ml:1596 +msgid "DISPLAY MODES" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:426 msgid "Define (but don't start) a domain from an XML file." msgstr "" @@ -87,6 +163,18 @@ msgstr "" msgid "Define (but don't start) a network from an XML file." msgstr "" +#: ../virt-top/virt_top.ml:1326 +msgid "Delay must be > 0" +msgstr "" + +#: ../virt-top/virt_top.ml:181 +msgid "Delay time interval (seconds)" +msgstr "" + +#: ../virt-top/virt_top.ml:1552 +msgid "Delay: %.1f secs; Batch: %s; Secure: %s; Sort: %s" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:433 msgid "Destroy a domain." msgstr "" @@ -103,6 +191,18 @@ msgstr "" msgid "Details" msgstr "" +#: ../virt-top/virt_top.ml:175 +msgid "Disable CPU stats in CSV" +msgstr "" + +#: ../virt-top/virt_top.ml:177 +msgid "Disable block device stats in CSV" +msgstr "" + +#: ../virt-top/virt_top.ml:179 +msgid "Disable net stats in CSV" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:493 msgid "Display free memory for machine, NUMA cell or range of cells" msgstr "" @@ -119,10 +219,30 @@ msgstr "" msgid "Display version and exit" msgstr "" -#: ../virt-ctrl/vc_mainwindow.ml:61 +#: ../virt-top/virt_top.ml:191 +msgid "Do not read init file" +msgstr "" + +#: ../virt-top/virt_top.ml:66 +msgid "Domain ID" +msgstr "" + +#: ../virt-top/virt_top.ml:67 +msgid "Domain name" +msgstr "" + +#: ../virt-top/virt_top.ml:1610 +msgid "Domains display" +msgstr "" + +#: ../virt-top/virt_top.ml:1528 ../virt-top/virt_top_main.ml:47 ../virt-ctrl/vc_mainwindow.ml:61 msgid "Error" msgstr "エラー" +#: ../virt-top/virt_top.ml:185 +msgid "Exit at given time" +msgstr "" + #: ../virt-ctrl/vc_mainwindow.ml:79 msgid "File" msgstr "ファイル" @@ -143,10 +263,14 @@ msgstr "" msgid "Gracefully shutdown a domain." msgstr "" -#: ../virt-ctrl/vc_mainwindow.ml:80 ../virt-ctrl/vc_mainwindow.ml:96 +#: ../virt-top/virt_top.ml:1580 ../virt-ctrl/vc_mainwindow.ml:80 ../virt-ctrl/vc_mainwindow.ml:96 msgid "Help" msgstr "" +#: ../virt-top/virt_top.ml:187 +msgid "Historical CPU delay" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:35 msgid "Hypervisor connection URI" msgstr "" @@ -207,11 +331,23 @@ msgstr "" msgid "Local network" msgstr "" +#: ../virt-top/virt_top.ml:173 +msgid "Log statistics to CSV file" +msgstr "" + +#: ../virt-top/virt_top.ml:1563 +msgid "MAIN KEYS" +msgstr "" + #: ../virt-ctrl/vc_connections.ml:409 msgid "Memory" msgstr "" -#: ../virt-df/virt_df.ml:382 +#: ../virt-top/virt_top.ml:1617 +msgid "More help in virt-top(1) man page. Press any key to return." +msgstr "" + +#: ../virt-top/virt_top.ml:258 ../virt-df/virt_df.ml:382 msgid "NB: If you want to monitor a local Xen hypervisor, you usually need to be root" msgstr "" @@ -219,6 +355,22 @@ msgstr "" msgid "Name" msgstr "" +#: ../virt-top/virt_top.ml:68 +msgid "Net RX bytes" +msgstr "" + +#: ../virt-top/virt_top.ml:69 +msgid "Net TX bytes" +msgstr "" + +#: ../virt-top/virt_top.ml:1332 +msgid "Not a valid number" +msgstr "" + +#: ../virt-top/virt_top.ml:193 +msgid "Number of iterations to run" +msgstr "" + #: ../virt-ctrl/vc_connection_dlg.ml:137 ../virt-ctrl/vc_connection_dlg.ml:170 msgid "Open" msgstr "" @@ -339,7 +491,7 @@ msgstr "" msgid "QEMU or KVM" msgstr "" -#: ../virt-ctrl/vc_mainwindow.ml:89 +#: ../virt-top/virt_top.ml:1578 ../virt-ctrl/vc_mainwindow.ml:89 msgid "Quit" msgstr "" @@ -375,10 +527,42 @@ msgstr "" msgid "Returns capabilities of hypervisor/driver." msgstr "" +#: ../virt-top/virt_top.ml:199 +msgid "Run from a script (no user interface)" +msgstr "" + +#: ../virt-top/virt_top.ml:1584 +msgid "SORTING" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:599 msgid "Save a domain to a file." msgstr "" +#: ../virt-top/virt_top.ml:197 +msgid "Secure (\\\"kiosk\\\") mode" +msgstr "" + +#: ../virt-top/virt_top.ml:1593 +msgid "Select sort field" +msgstr "" + +#: ../virt-top/virt_top.ml:183 +msgid "Send debug messages to file" +msgstr "" + +#: ../virt-top/virt_top.ml:189 +msgid "Set name of init file" +msgstr "" + +#: ../virt-top/virt_top.ml:195 +msgid "Set sort order (%s)" +msgstr "" + +#: ../virt-top/virt_top.ml:1340 +msgid "Set sort order for main display" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:631 msgid "Set the maximum memory used by the domain (in kilobytes)." msgstr "" @@ -395,6 +579,10 @@ msgstr "" msgid "Set the scheduler parameters for a domain." msgstr "" +#: ../virt-top/virt_top.ml:1579 +msgid "Set update interval" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:403 msgid "Set whether a domain autostarts at boot." msgstr "" @@ -419,6 +607,22 @@ msgstr "" msgid "Size" msgstr "" +#: ../virt-top/virt_top.ml:1589 +msgid "Sort by %CPU" +msgstr "" + +#: ../virt-top/virt_top.ml:1590 +msgid "Sort by %MEM" +msgstr "" + +#: ../virt-top/virt_top.ml:1592 +msgid "Sort by ID" +msgstr "" + +#: ../virt-top/virt_top.ml:1591 +msgid "Sort by TIME" +msgstr "" + #: ../virt-ctrl/vc_mainwindow.ml:127 msgid "Start" msgstr "" @@ -431,6 +635,18 @@ msgstr "" msgid "Start a previously defined inactive network." msgstr "" +#: ../virt-top/virt_top.ml:165 +msgid "Start by displaying block devices" +msgstr "" + +#: ../virt-top/virt_top.ml:163 +msgid "Start by displaying network interfaces" +msgstr "" + +#: ../virt-top/virt_top.ml:161 +msgid "Start by displaying pCPUs (default: tasks)" +msgstr "" + #: ../virt-ctrl/vc_connections.ml:407 msgid "Status" msgstr "" @@ -443,14 +659,34 @@ msgstr "" msgid "Synopsis:\n %s [options] [command]\n\nList of all commands:\n %s help\n\nFull description of a single command:\n %s help command\n\nOptions:" msgstr "" +#: ../virt-top/virt_top.ml:65 +msgid "TIME (CPU time)" +msgstr "" + #: ../virt-ctrl/vc_connection_dlg.ml:62 msgid "This machine" msgstr "" +#: ../virt-top/virt_top.ml:1613 +msgid "Toggle block devices" +msgstr "" + +#: ../virt-top/virt_top.ml:1612 +msgid "Toggle network interfaces" +msgstr "" + +#: ../virt-top/virt_top.ml:1611 +msgid "Toggle physical CPUs" +msgstr "" + #: ../virt-df/virt_df.ml:502 msgid "Type" msgstr "" +#: ../virt-top/virt_top.ml:1341 +msgid "Type key or use up and down cursor keys." +msgstr "" + #: ../virt-ctrl/vc_connection_dlg.ml:160 msgid "URI connection" msgstr "" @@ -463,6 +699,14 @@ msgstr "" msgid "Undefine an inactive network." msgstr "" +#: ../virt-top/virt_top.ml:1622 +msgid "Unknown command - try 'h' for help" +msgstr "" + +#: ../virt-top/virt_top.ml:1577 +msgid "Update display" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:690 msgid "Use '%s help command' for help on a command." msgstr "" @@ -483,6 +727,10 @@ msgstr "" msgid "Virtualization control tool (virt-ctrl) by\nRichard W.M. Jones (rjones@redhat.com).\n\nCopyright %s 2007-2008 Red Hat Inc.\n\nLibvirt version: %s\n\nGtk toolkit version: %s" msgstr "" +#: ../virt-top/virt_top.ml:1523 +msgid "Wrote settings to %s" +msgstr "" + #: ../virt-ctrl/vc_connection_dlg.ml:76 msgid "Xen hypervisor" msgstr "" @@ -559,7 +807,7 @@ msgstr "" msgid "flag should be '%s'" msgstr "" -#: ../virt-df/virt_df.ml:419 +#: ../virt-top/virt_top_xml.ml:46 ../virt-df/virt_df.ml:419 msgid "get_xml_desc didn't return " msgstr "" @@ -723,6 +971,22 @@ msgstr "" msgid "virt-df : like 'df', shows disk space used in guests\n\nSUMMARY\n virt-df [-options]\n\nOPTIONS" msgstr "" +#: ../virt-top/virt_top.ml:1543 +msgid "virt-top %s (libvirt %d.%d.%d) by Red Hat" +msgstr "" + +#: ../virt-top/virt_top.ml:203 +msgid "virt-top : a 'top'-like utility for virtualization\n\nSUMMARY\n virt-top [-options]\n\nOPTIONS" +msgstr "" + +#: ../virt-top/virt_top.ml:40 +msgid "virt-top was compiled without support for CSV files" +msgstr "" + +#: ../virt-top/virt_top.ml:51 +msgid "virt-top was compiled without support for dates and times" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:360 msgid "virtual CPU: %d\\n" msgstr "" diff --git a/po/virt-top.pot b/po/virt-top.pot index 9849025..68806b4 100644 --- a/po/virt-top.pot +++ b/po/virt-top.pot @@ -8,7 +8,7 @@ msgid "" msgstr "" "Project-Id-Version: PACKAGE VERSION\n" "Report-Msgid-Bugs-To: \n" -"POT-Creation-Date: 2008-03-28 17:12+0000\n" +"POT-Creation-Date: 2008-03-28 17:30+0000\n" "PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" "Last-Translator: FULL NAME \n" "Language-Team: LANGUAGE \n" @@ -17,18 +17,66 @@ msgstr "" "Content-Transfer-Encoding: 8bit\n" "Plural-Forms: nplurals=INTEGER; plural=EXPRESSION;\n" +#: ../virt-top/virt_top.ml:1490 +msgid "# .virt-toprc virt-top configuration file\\n" +msgstr "" + +#: ../virt-top/virt_top.ml:1508 +msgid "# Enable CSV output to the named file\\n" +msgstr "" + +#: ../virt-top/virt_top.ml:1511 +msgid "# To protect this file from being overwritten, uncomment next line\\n" +msgstr "" + +#: ../virt-top/virt_top.ml:1505 +msgid "# To send debug and error messages to a file, uncomment next line\\n" +msgstr "" + +#: ../virt-top/virt_top.ml:1491 +msgid "# generated on %s by %s\\n" +msgstr "" + +#: ../virt-top/virt_top.ml:63 +msgid "%CPU" +msgstr "" + +#: ../virt-top/virt_top.ml:64 +msgid "%MEM" +msgstr "" + +#: ../virt-top/virt_top.ml:1144 +msgid "%d domains, %d active, %d running, %d sleeping, %d paused, %d inactive D:%d O:%d X:%d" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:716 msgid "%s: command not found" msgstr "" -#: ../virt-df/virt_df.ml:362 +#: ../virt-top/virt_top.ml:105 +msgid "%s: display should be %s" +msgstr "" + +#: ../virt-top/virt_top.ml:82 +msgid "%s: sort order should be: %s" +msgstr "" + +#: ../virt-df/virt_df.ml:362 ../virt-top/virt_top.ml:202 msgid "%s: unknown parameter" msgstr "" +#: ../virt-top/virt_top.ml:233 +msgid "%s:%d: configuration item ``%s'' ignored\\n%!" +msgstr "" + #: ../virt-df/virt_df.ml:514 msgid "(device omitted)" msgstr "" +#: ../virt-top/virt_top.ml:145 +msgid "-d: cannot set a negative delay" +msgstr "" + #: ../virt-df/virt_df.ml:498 msgid "1K-blocks" msgstr "" @@ -45,6 +93,18 @@ msgstr "" msgid "Available" msgstr "" +#: ../virt-top/virt_top.ml:167 +msgid "Batch mode" +msgstr "" + +#: ../virt-top/virt_top.ml:70 +msgid "Block read reqs" +msgstr "" + +#: ../virt-top/virt_top.ml:71 +msgid "Block write reqs" +msgstr "" + #: ../virt-ctrl/vc_connections.ml:408 msgid "CPU" msgstr "" @@ -53,10 +113,18 @@ msgstr "" msgid "CPU affinity" msgstr "" +#: ../virt-top/virt_top.ml:1151 +msgid "CPU: %2.1f%% Mem: %Ld MB (%Ld MB by guests)" +msgstr "" + #: ../virt-ctrl/vc_connection_dlg.ml:182 msgid "Cancel" msgstr "" +#: ../virt-top/virt_top.ml:1319 +msgid "Change delay from %.1f to: " +msgstr "" + #: ../mlvirsh/mlvirsh.ml:409 msgid "Close an existing hypervisor connection." msgstr "" @@ -69,10 +137,14 @@ msgstr "" msgid "Connect to ..." msgstr "" -#: ../virt-df/virt_df.ml:348 ../virt-df/virt_df.ml:346 +#: ../virt-df/virt_df.ml:348 ../virt-df/virt_df.ml:346 ../virt-top/virt_top.ml:171 ../virt-top/virt_top.ml:169 msgid "Connect to URI (default: Xen)" msgstr "" +#: ../virt-top/virt_top.ml:1558 +msgid "Connect: %s; Hostname: %s" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:476 msgid "Core dump a domain to a file for analysis." msgstr "" @@ -85,6 +157,10 @@ msgstr "" msgid "Create a network from an XML file." msgstr "" +#: ../virt-top/virt_top.ml:1596 +msgid "DISPLAY MODES" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:426 msgid "Define (but don't start) a domain from an XML file." msgstr "" @@ -93,6 +169,18 @@ msgstr "" msgid "Define (but don't start) a network from an XML file." msgstr "" +#: ../virt-top/virt_top.ml:1326 +msgid "Delay must be > 0" +msgstr "" + +#: ../virt-top/virt_top.ml:181 +msgid "Delay time interval (seconds)" +msgstr "" + +#: ../virt-top/virt_top.ml:1552 +msgid "Delay: %.1f secs; Batch: %s; Secure: %s; Sort: %s" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:433 msgid "Destroy a domain." msgstr "" @@ -109,6 +197,18 @@ msgstr "" msgid "Details" msgstr "" +#: ../virt-top/virt_top.ml:175 +msgid "Disable CPU stats in CSV" +msgstr "" + +#: ../virt-top/virt_top.ml:177 +msgid "Disable block device stats in CSV" +msgstr "" + +#: ../virt-top/virt_top.ml:179 +msgid "Disable net stats in CSV" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:493 msgid "Display free memory for machine, NUMA cell or range of cells" msgstr "" @@ -125,10 +225,30 @@ msgstr "" msgid "Display version and exit" msgstr "" -#: ../virt-ctrl/vc_mainwindow.ml:61 +#: ../virt-top/virt_top.ml:191 +msgid "Do not read init file" +msgstr "" + +#: ../virt-top/virt_top.ml:66 +msgid "Domain ID" +msgstr "" + +#: ../virt-top/virt_top.ml:67 +msgid "Domain name" +msgstr "" + +#: ../virt-top/virt_top.ml:1610 +msgid "Domains display" +msgstr "" + +#: ../virt-ctrl/vc_mainwindow.ml:61 ../virt-top/virt_top_main.ml:47 ../virt-top/virt_top.ml:1528 msgid "Error" msgstr "" +#: ../virt-top/virt_top.ml:185 +msgid "Exit at given time" +msgstr "" + #: ../virt-ctrl/vc_mainwindow.ml:79 msgid "File" msgstr "" @@ -149,10 +269,14 @@ msgstr "" msgid "Gracefully shutdown a domain." msgstr "" -#: ../virt-ctrl/vc_mainwindow.ml:96 ../virt-ctrl/vc_mainwindow.ml:80 +#: ../virt-ctrl/vc_mainwindow.ml:96 ../virt-ctrl/vc_mainwindow.ml:80 ../virt-top/virt_top.ml:1580 msgid "Help" msgstr "" +#: ../virt-top/virt_top.ml:187 +msgid "Historical CPU delay" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:35 msgid "Hypervisor connection URI" msgstr "" @@ -213,11 +337,23 @@ msgstr "" msgid "Local network" msgstr "" +#: ../virt-top/virt_top.ml:173 +msgid "Log statistics to CSV file" +msgstr "" + +#: ../virt-top/virt_top.ml:1563 +msgid "MAIN KEYS" +msgstr "" + #: ../virt-ctrl/vc_connections.ml:409 msgid "Memory" msgstr "" -#: ../virt-df/virt_df.ml:382 +#: ../virt-top/virt_top.ml:1617 +msgid "More help in virt-top(1) man page. Press any key to return." +msgstr "" + +#: ../virt-df/virt_df.ml:382 ../virt-top/virt_top.ml:258 msgid "NB: If you want to monitor a local Xen hypervisor, you usually need to be root" msgstr "" @@ -225,6 +361,22 @@ msgstr "" msgid "Name" msgstr "" +#: ../virt-top/virt_top.ml:68 +msgid "Net RX bytes" +msgstr "" + +#: ../virt-top/virt_top.ml:69 +msgid "Net TX bytes" +msgstr "" + +#: ../virt-top/virt_top.ml:1332 +msgid "Not a valid number" +msgstr "" + +#: ../virt-top/virt_top.ml:193 +msgid "Number of iterations to run" +msgstr "" + #: ../virt-ctrl/vc_connection_dlg.ml:170 ../virt-ctrl/vc_connection_dlg.ml:137 msgid "Open" msgstr "" @@ -345,7 +497,7 @@ msgstr "" msgid "QEMU or KVM" msgstr "" -#: ../virt-ctrl/vc_mainwindow.ml:89 +#: ../virt-ctrl/vc_mainwindow.ml:89 ../virt-top/virt_top.ml:1578 msgid "Quit" msgstr "" @@ -381,10 +533,42 @@ msgstr "" msgid "Returns capabilities of hypervisor/driver." msgstr "" +#: ../virt-top/virt_top.ml:199 +msgid "Run from a script (no user interface)" +msgstr "" + +#: ../virt-top/virt_top.ml:1584 +msgid "SORTING" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:599 msgid "Save a domain to a file." msgstr "" +#: ../virt-top/virt_top.ml:197 +msgid "Secure (\\\"kiosk\\\") mode" +msgstr "" + +#: ../virt-top/virt_top.ml:1593 +msgid "Select sort field" +msgstr "" + +#: ../virt-top/virt_top.ml:183 +msgid "Send debug messages to file" +msgstr "" + +#: ../virt-top/virt_top.ml:189 +msgid "Set name of init file" +msgstr "" + +#: ../virt-top/virt_top.ml:195 +msgid "Set sort order (%s)" +msgstr "" + +#: ../virt-top/virt_top.ml:1340 +msgid "Set sort order for main display" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:631 msgid "Set the maximum memory used by the domain (in kilobytes)." msgstr "" @@ -401,6 +585,10 @@ msgstr "" msgid "Set the scheduler parameters for a domain." msgstr "" +#: ../virt-top/virt_top.ml:1579 +msgid "Set update interval" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:403 msgid "Set whether a domain autostarts at boot." msgstr "" @@ -425,6 +613,22 @@ msgstr "" msgid "Size" msgstr "" +#: ../virt-top/virt_top.ml:1589 +msgid "Sort by %CPU" +msgstr "" + +#: ../virt-top/virt_top.ml:1590 +msgid "Sort by %MEM" +msgstr "" + +#: ../virt-top/virt_top.ml:1592 +msgid "Sort by ID" +msgstr "" + +#: ../virt-top/virt_top.ml:1591 +msgid "Sort by TIME" +msgstr "" + #: ../virt-ctrl/vc_mainwindow.ml:127 msgid "Start" msgstr "" @@ -437,6 +641,18 @@ msgstr "" msgid "Start a previously defined inactive network." msgstr "" +#: ../virt-top/virt_top.ml:165 +msgid "Start by displaying block devices" +msgstr "" + +#: ../virt-top/virt_top.ml:163 +msgid "Start by displaying network interfaces" +msgstr "" + +#: ../virt-top/virt_top.ml:161 +msgid "Start by displaying pCPUs (default: tasks)" +msgstr "" + #: ../virt-ctrl/vc_connections.ml:407 msgid "Status" msgstr "" @@ -449,14 +665,34 @@ msgstr "" msgid "Synopsis:\n %s [options] [command]\n\nList of all commands:\n %s help\n\nFull description of a single command:\n %s help command\n\nOptions:" msgstr "" +#: ../virt-top/virt_top.ml:65 +msgid "TIME (CPU time)" +msgstr "" + #: ../virt-ctrl/vc_connection_dlg.ml:62 msgid "This machine" msgstr "" +#: ../virt-top/virt_top.ml:1613 +msgid "Toggle block devices" +msgstr "" + +#: ../virt-top/virt_top.ml:1612 +msgid "Toggle network interfaces" +msgstr "" + +#: ../virt-top/virt_top.ml:1611 +msgid "Toggle physical CPUs" +msgstr "" + #: ../virt-df/virt_df.ml:502 msgid "Type" msgstr "" +#: ../virt-top/virt_top.ml:1341 +msgid "Type key or use up and down cursor keys." +msgstr "" + #: ../virt-ctrl/vc_connection_dlg.ml:160 msgid "URI connection" msgstr "" @@ -469,6 +705,14 @@ msgstr "" msgid "Undefine an inactive network." msgstr "" +#: ../virt-top/virt_top.ml:1622 +msgid "Unknown command - try 'h' for help" +msgstr "" + +#: ../virt-top/virt_top.ml:1577 +msgid "Update display" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:690 msgid "Use '%s help command' for help on a command." msgstr "" @@ -489,6 +733,10 @@ msgstr "" msgid "Virtualization control tool (virt-ctrl) by\nRichard W.M. Jones (rjones@redhat.com).\n\nCopyright %s 2007-2008 Red Hat Inc.\n\nLibvirt version: %s\n\nGtk toolkit version: %s" msgstr "" +#: ../virt-top/virt_top.ml:1523 +msgid "Wrote settings to %s" +msgstr "" + #: ../virt-ctrl/vc_connection_dlg.ml:76 msgid "Xen hypervisor" msgstr "" @@ -565,7 +813,7 @@ msgstr "" msgid "flag should be '%s'" msgstr "" -#: ../virt-df/virt_df.ml:419 +#: ../virt-df/virt_df.ml:419 ../virt-top/virt_top_xml.ml:46 msgid "get_xml_desc didn't return " msgstr "" @@ -729,6 +977,22 @@ msgstr "" msgid "virt-df : like 'df', shows disk space used in guests\n\nSUMMARY\n virt-df [-options]\n\nOPTIONS" msgstr "" +#: ../virt-top/virt_top.ml:1543 +msgid "virt-top %s (libvirt %d.%d.%d) by Red Hat" +msgstr "" + +#: ../virt-top/virt_top.ml:203 +msgid "virt-top : a 'top'-like utility for virtualization\n\nSUMMARY\n virt-top [-options]\n\nOPTIONS" +msgstr "" + +#: ../virt-top/virt_top.ml:40 +msgid "virt-top was compiled without support for CSV files" +msgstr "" + +#: ../virt-top/virt_top.ml:51 +msgid "virt-top was compiled without support for dates and times" +msgstr "" + #: ../mlvirsh/mlvirsh.ml:360 msgid "virtual CPU: %d\\n" msgstr "" -- cgit v1.1 From e4450db8fa0bdf31f3bf50062295b801a6a803ab Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Mon, 14 Apr 2008 17:46:15 +0100 Subject: Allow extra OCAMLDEPFLAGS to be passed, eg to make syntax extensions possible. --- Make.rules.in | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Make.rules.in b/Make.rules.in index 6a56728..b22fdf6 100644 --- a/Make.rules.in +++ b/Make.rules.in @@ -47,11 +47,11 @@ depend: .depend ifneq ($(OCAMLFIND),) .depend: $(wildcard *.mli) $(wildcard *.ml) rm -f .depend - $(OCAMLFIND) ocamldep $(OCAMLCPACKAGES) $^ > $@ + $(OCAMLFIND) ocamldep $(OCAMLCPACKAGES) $(OCAMLDEPFLAGS) $^ > $@ else .depend: $(wildcard *.mli) $(wildcard *.ml) rm -f .depend - $(OCAMLDEP) $(OCAMLCINCS) $^ > $@ + $(OCAMLDEP) $(OCAMLCINCS) $(OCAMLDEPFLAGS) $^ > $@ endif ifeq ($(wildcard .depend),.depend) -- cgit v1.1 From db2c06435d37a99a9ca04f111736cab8690393b8 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Mon, 14 Apr 2008 17:46:47 +0100 Subject: Check for pa_bitmatch extension (now required by virt-df). --- configure.ac | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index 57517f8..09d5505 100644 --- a/configure.ac +++ b/configure.ac @@ -194,6 +194,7 @@ if test "x$OCAMLFIND" != "x"; then AC_CHECK_OCAML_PKG(csv) AC_CHECK_OCAML_PKG(dbus) AC_CHECK_OCAML_PKG(gettext) + AC_CHECK_OCAML_PKG(bitmatch) dnl Need to check which version of calendar is installed. AC_CHECK_OCAML_MODULE(calendar,pkg_calendar2,CalendarLib.Date,[+calendar]) @@ -230,6 +231,7 @@ else AC_CHECK_OCAML_MODULE(csv,pkg_csv,Csv,[+csv]) AC_CHECK_OCAML_MODULE(dbus,pkg_dbus,DBus,[+dbus]) AC_CHECK_OCAML_MODULE(gettext,pkg_gettext,Gettext,[+gettext]) + AC_CHECK_OCAML_MODULE(bitmatch,pkg_bitmatch,Bitmatch,[+bitmatch]) dnl XXX Version check - see above. AC_CHECK_OCAML_MODULE(calendar,pkg_calendar,Calendar,[+calendar]) fi @@ -242,7 +244,9 @@ fi if test "x$pkg_extlib" != "xno" -a "x$pkg_curses" != "xno"; then subdirs="$subdirs virt-top" fi -if test "x$pkg_extlib" != "xno" -a "x$pkg_xml_light" != "xno"; then +if test "x$pkg_extlib" != "xno" \ + -a "x$pkg_xml_light" != "xno" \ + -a "x$pkg_bitmatch" != "xno"; then subdirs="$subdirs virt-df" fi AC_SUBST(subdirs) -- cgit v1.1 From 9c96bc8ba014fe5d9bdf84234015446e745ee2b8 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Mon, 14 Apr 2008 17:47:09 +0100 Subject: Add new column for virt-df requirements. --- README | 92 ++++++++++++++++++++++++++++++++++-------------------------------- 1 file changed, 48 insertions(+), 44 deletions(-) diff --git a/README b/README index 32686c5..7fb9726 100644 --- a/README +++ b/README @@ -21,50 +21,52 @@ the packages below if you want to build from source. W h a t y o u w a n t t o b u i l d - |Bindings, |Docs, |virt-top |virt-ctrl |Windows - |examples, |manpages | | |version - |mlvirsh | | | | - --------------+----------+---------+---------+----------+--------- - GNU make | R | R | R | R | R - | | | | | - gcc | R | | R | R | R - | | | | | - libvirt | R | | R | R | R - | >= 0.2.1 | | | | - | | | | | - ocaml | R | | R | R | R - | >= 3.08 | | | | - | | | | | - findlib | HR | R | HR | HR | Note [1] - | | | | | - ocaml-gettext | R | R | R | R | Note [2] - | | | | | - MinGW + MSYS | | | | | R - --------------+----------+---------+---------+----------+--------- - ocamldoc | | R | | | O - | | | | | - perldoc | | O | | | - --------------+----------+---------+---------+----------+--------- - ocaml-curses | | | R | | - | | | | | - Extlib | | | R | | - | | | | | - xml-light | | | O | | - | | | | | - ocaml-calendar| | | O | | - | | | | | - ocaml CSV | | | O | | - --------------+----------+---------+---------+----------+--------- - GTK2 | | | | R | O - | | | | | - lablgtk2 | | | | R | O - | | | | >= 2.10.0| - ocaml-dbus | | | | O | - | | | | >= 0.06 | - gnome-icon-theme | | | O | - --------------+----------+---------+---------+----------+--------- - NSIS | | | | | O - --------------+----------+---------+---------+----------+--------- + |Bindings, |Docs, |virt-top |virt-ctrl |virt-df |Windows + |examples, |manpages | | | |version + |mlvirsh | | | | | + --------------+----------+---------+---------+----------+----------+------ + GNU make | R | R | R | R | R | R + | | | | | | + gcc | R | | R | R | R | R + | | | | | | + libvirt | R | | R | R | R | R + | >= 0.2.1 | | | | | + | | | | | | + ocaml | R | | R | R | R | R + | >= 3.08 | | | | >= 3.10 | + | | | | | | + findlib | HR | R | HR | HR | HR | Note [1] + | | | | | | + ocaml-gettext | O | O | O | O | O | Note [2] + | | | | | | + MinGW + MSYS | | | | | | R + --------------+----------+---------+---------+----------+----------+------ + ocamldoc | | R | | | | O + | | | | | | + perldoc | | O | | | | + --------------+----------+---------+---------+----------+----------+------ + ocaml-curses | | | R | | | + | | | | | | + Extlib | | | R | | R | + | | | | | | + xml-light | | | O | | R | + | | | | | | + ocaml-calendar| | | O | | | + | | | | | | + ocaml CSV | | | O | | | + | | | | | | + bitmatch | | | | | R | + --------------+----------+---------+---------+----------+----------+------ + GTK2 | | | | R | | O + | | | | | | + lablgtk2 | | | | R | | O + | | | | >= 2.10.0| | + ocaml-dbus | | | | O | | + | | | | >= 0.06 | | + gnome-icon-theme | | | O | | + --------------+----------+---------+---------+----------+----------+------ + NSIS | | | | | | O + --------------+----------+---------+---------+----------+----------+------ R = required HR = highly recommended (use if possible) @@ -122,6 +124,8 @@ Where to get the packages: or packaged in Debian, Ubuntu as 'libcalendar-ocaml-dev' or packaged in Fedora as 'ocaml-calendar-devel' + bitmatch from http://et.redhat.com/~rjones/bitmatch/ + GTK2 from http://gtk.org/ or packaged in Debian, Ubuntu and Fedora -- cgit v1.1 From 69a06d25bf078f994b3e17a4da1af765bb40ea1f Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Mon, 14 Apr 2008 17:48:00 +0100 Subject: pa_bitmatch package added. xml-light is now optional. MBR code now in its own file. --- virt-df/Makefile.in | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/virt-df/Makefile.in b/virt-df/Makefile.in index 057c8e5..4a56d2d 100644 --- a/virt-df/Makefile.in +++ b/virt-df/Makefile.in @@ -25,10 +25,10 @@ prefix = @prefix@ exec_prefix = @exec_prefix@ bindir = @bindir@ -pkg_xml_light = @pkg_xml_light@ pkg_gettext = @pkg_gettext@ -OCAMLCPACKAGES := -package unix,extlib,xml-light +#OCAMLCPACKAGES := -package unix,extlib,xml-light,bitmatch +OCAMLCPACKAGES := -package unix,extlib,xml-light -I +bitmatch ifneq ($(pkg_gettext),no) OCAMLCPACKAGES += -package gettext-stub @@ -40,17 +40,24 @@ OBJS := \ virt_df_ext2.cmo \ virt_df_linux_swap.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 -OCAMLCLIBS := -linkpkg +OCAMLCFLAGS := -g -w s $(SYNTAX) +#OCAMLCLIBS := -linkpkg +OCAMLCLIBS := -linkpkg bitmatch.cma OCAMLOPTPACKAGES := $(OCAMLCPACKAGES) -OCAMLOPTFLAGS := -w s -OCAMLOPTLIBS := $(OCAMLCLIBS) +OCAMLOPTFLAGS := -w s $(SYNTAX) +#OCAMLOPTLIBS := $(OCAMLCLIBS) +OCAMLOPTLIBS := -linkpkg bitmatch.cmxa + +OCAMLDEPFLAGS := $(SYNTAX) export LIBRARY_PATH=../libvirt export LD_LIBRARY_PATH=../libvirt -- cgit v1.1 From f31c12ec325dd0f4f77e278c243d89da4ea228b8 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Mon, 14 Apr 2008 17:48:16 +0100 Subject: Updated deps. --- virt-df/.depend | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/virt-df/.depend b/virt-df/.depend index 69ae982..5aa8cb7 100644 --- a/virt-df/.depend +++ b/virt-df/.depend @@ -1,11 +1,19 @@ -virt_df_ext2.cmo: virt_df_gettext.cmo virt_df.cmo -virt_df_ext2.cmx: virt_df_gettext.cmx virt_df.cmx -virt_df_linux_swap.cmo: virt_df_gettext.cmo virt_df.cmo -virt_df_linux_swap.cmx: virt_df_gettext.cmx virt_df.cmx +virt_df_ext2.cmo: virt_df_gettext.cmo virt_df.cmo \ + /usr/lib64/ocaml/bitmatch/bitmatch.cmi +virt_df_ext2.cmx: virt_df_gettext.cmx virt_df.cmx \ + /usr/lib64/ocaml/bitmatch/bitmatch.cmi +virt_df_linux_swap.cmo: virt_df_gettext.cmo virt_df.cmo \ + /usr/lib64/ocaml/bitmatch/bitmatch.cmi +virt_df_linux_swap.cmx: virt_df_gettext.cmx virt_df.cmx \ + /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_lvm2.cmo: virt_df_gettext.cmo virt_df.cmo virt_df_lvm2.cmx: virt_df_gettext.cmx virt_df.cmx virt_df_main.cmo: virt_df.cmo virt_df_main.cmx: virt_df.cmx +virt_df_mbr.cmo: virt_df_gettext.cmo virt_df.cmo \ + /usr/lib64/ocaml/bitmatch/bitmatch.cmi +virt_df_mbr.cmx: virt_df_gettext.cmx virt_df.cmx \ + /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df.cmo: virt_df_gettext.cmo ../libvirt/libvirt_version.cmi \ ../libvirt/libvirt.cmi virt_df.cmx: virt_df_gettext.cmx ../libvirt/libvirt_version.cmx \ -- cgit v1.1 From e6050cae9eee80791c3bb26f34c61f7dc89b142f Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Mon, 14 Apr 2008 17:48:49 +0100 Subject: Complete rewrite of virt-df: - Uses pa_bitmatch for robust parsing of disk structures. - Completely modularized. --- virt-df/virt_df.ml | 941 ++++++++++++++++++++++++------------------ virt-df/virt_df_ext2.ml | 164 +++++--- virt-df/virt_df_linux_swap.ml | 46 ++- virt-df/virt_df_lvm2.ml | 15 +- virt-df/virt_df_main.ml | 3 + virt-df/virt_df_mbr.ml | 195 +++++++++ 6 files changed, 874 insertions(+), 490 deletions(-) mode change 100755 => 100644 virt-df/virt_df_main.ml create mode 100644 virt-df/virt_df_mbr.ml diff --git a/virt-df/virt_df.ml b/virt-df/virt_df.ml index 4fbc706..b972837 100644 --- a/virt-df/virt_df.ml +++ b/virt-df/virt_df.ml @@ -25,51 +25,163 @@ open Virt_df_gettext.Gettext module C = Libvirt.Connect module D = Libvirt.Domain -module N = Libvirt.Network -(* Int64 operators for convenience. - * For sanity we do all int operations as int64's. - *) -let (+^) = Int64.add -let (-^) = Int64.sub -let ( *^ ) = Int64.mul -let (/^) = Int64.div +(* If set to true, then emit lots of debugging information. *) +let debug = true -let uri = ref None -let inodes = ref false -let human = ref false -let all = ref false +(* Int32 infix operators for convenience. *) +let ( +* ) = Int32.add +let ( -* ) = Int32.sub +let ( ** ) = Int32.mul +let ( /* ) = Int32.div -(* Maximum number of extended partitions possible. *) -let max_extended_partitions = 100 +(* Int64 infix operators for convenience. *) +let ( +^ ) = Int64.add +let ( -^ ) = Int64.sub +let ( *^ ) = Int64.mul +let ( /^ ) = Int64.div + +(* State of command line arguments. *) +let uri = ref None (* Hypervisor/libvirt URI. *) +let inodes = ref false (* Display inodes. *) +let human = ref false (* Display human-readable. *) +let all = ref false (* Show all/active domains. *) +let test_files = ref [] (* Used for test mode only. *) + +(*----------------------------------------------------------------------*) +(* The "domain/device model" that we currently understand looks + * like this: + * + * domains + * | + * \--- host partitions / disk image files + * || + * guest block devices + * | + * +--> guest partitions (eg. using MBR) + * | | + * \-(1)->+--- filesystems (eg. ext3) + * | + * \--- PVs for LVM + * ||| + * VGs and LVs + * + * (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. LVM) 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. + *) -let sector_size = 512L +(* 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 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 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 + +(* Domains and candidate guest block devices. *) -(* Parse out the device XML to get the names of disks. *) type domain = { dom_name : string; (* Domain name. *) dom_id : int option; (* Domain ID (if running). *) dom_disks : disk list; (* Domain disks. *) } and disk = { + (* From the XML ... *) d_type : string option; (* The *) - d_device : string option; (* The *) - d_source : string option; (* The *) - d_target : string option; (* The *) -} + d_device : string; (* The (eg "disk") *) + d_source : string; (* The *) + d_target : string; (* The (eg "hda") *) -type partition = { + (* 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 unit (* 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 type. *) - part_lba_start : int64; (* LBA start sector. *) - part_len : int64; (* Length in sectors. *) + 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 - -type filesystem_stats = { - fs_name : string; +and partition_content = + [ `Unknown (* Not probed or unknown. *) + | `Filesystem of filesystem (* Filesystem. *) + | `PhysicalVolume of unit (* 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. *) @@ -78,250 +190,80 @@ type filesystem_stats = { fs_inodes_avail : int64; (* Inodes free (available). *) fs_inodes_used : int64; (* Inodes in use. *) } -and swap_stats = { - swap_name : string; - swap_block_size : int64; (* Block size (bytes). *) - swap_blocks_total : int64; (* Total blocks. *) -} -and fs_probe_t = (* Return type of the probe_partition.*) - | Filesystem of filesystem_stats - | Swap of swap_stats - | ProbeFailed of string (* Probe failed for some reason. *) - | ProbeIgnore (* This filesystem should be ignored. *) - -(* Register a filesystem type. *) -let filesystems = Hashtbl.create 13 -let fs_register part_types probe_fn = - List.iter - (fun part_type -> Hashtbl.replace filesystems part_type probe_fn) - part_types - -(* Probe the devices and display. - * - dom_name is the domain name - * - target will be something like "hda" - * - source will be the name of a file or disk partition on the local machine - *) -let rec probe_device dom_name target source = - let fd = openfile source [ O_RDONLY ] 0 in - let size = (LargeFile.fstat fd).LargeFile.st_size in - let size = size /^ sector_size in (* Size in sectors. *) - - (*print_device dom_name target source size;*) - - let partitions = probe_mbr fd in - - if partitions <> [] then ( - let stats = - List.mapi ( - fun i part -> - if part.part_status = Bootable || - part.part_status = Nonbootable then ( - let pnum = i+1 in - let target = target ^ string_of_int pnum in - Some (target, - probe_partition target (Some part.part_type) - fd part.part_lba_start part.part_len) - ) - else - None - ) partitions in - let stats = List.filter_map (fun x -> x) stats in - print_stats dom_name stats - ) else (* Not an MBR, assume it's a single partition. *) - print_stats dom_name [target, probe_partition target None fd 0L size]; - - close fd - -(* Probe the master boot record (if it is one) and read the partitions. - * Returns [] if this is not an MBR. - * http://en.wikipedia.org/wiki/Master_boot_record - *) -and probe_mbr fd = - lseek fd 510 SEEK_SET; - let str = String.create 2 in - if read fd str 0 2 <> 2 || str.[0] != '\x55' || str.[1] != '\xAA' then - [] (* Not MBR *) - else ( - (* Read the partition table. *) - lseek fd 446 SEEK_SET; - let str = String.create 64 in - if read fd str 0 64 <> 64 then - failwith (s_ "error reading partition table") - else ( - (* Extract partitions from the data. *) - let primaries = List.map (get_partition str) [ 0; 16; 32; 48 ] in - (* XXX validate partition extents compared to disk. *) - (* 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 - ) - ) - -(* 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 [] - -(* Get the partition data from str.[offs] - str.[offs+15] *) -and get_partition str offs = - let part_type = Char.code str.[offs+4] in - let part_lba_start = read_int32_le str (offs+8) in - let part_len = read_int32_le str (offs+12) in - - let part_status = - if part_type = 0 && part_lba_start = 0L && part_len = 0L then - NullEntry - else ( - let part_status = Char.code str.[offs] in - match part_status with - | 0x80 -> Bootable | 0 -> Nonbootable | _ -> Malformed - ) in - - { part_status = part_status; - part_type = part_type; - part_lba_start = part_lba_start; - part_len = part_len } - -(* Probe a single partition, which we assume contains either a - * filesystem or is a PV. - * - target will be something like "hda" or "hda1" - * - part_type will be the partition type if known, or None - * - fd is a file descriptor opened on the device - * - start & size are where we think the start and size of the - * partition is within the file descriptor (in SECTORS) - *) -and probe_partition target part_type fd start size = - match part_type with - | None -> - ProbeFailed (s_ "detection of unpartitioned devices not yet supported") - | Some 0x05 -> - ProbeIgnore (* Extended partition - ignore it. *) - | Some part_type -> - try - let probe_fn = Hashtbl.find filesystems part_type in - probe_fn target part_type fd start size - with - Not_found -> - ProbeFailed - (sprintf (f_ "unsupported partition type %02x") part_type) - -and print_stats dom_name statss = - List.iter ( - fun (target, fs_probe_t) -> - let dom_target = dom_name ^ ":" ^ target in - printf "%-20s " dom_target; - - match fs_probe_t with - (* Swap partition. *) - | Swap { swap_name = swap_name; - swap_block_size = block_size; - swap_blocks_total = blocks_total } -> - if not !human then - printf "%10Ld %s\n" - (block_size *^ blocks_total /^ 1024L) swap_name - else - printf "%10s %s\n" - (printable_size (block_size *^ blocks_total)) swap_name - (* Ordinary filesystem. *) - | Filesystem stats -> - if not !inodes then ( (* Block display. *) - (* 'df' doesn't count the restricted blocks. *) - let blocks_total = - stats.fs_blocks_total -^ stats.fs_blocks_reserved in - let blocks_avail = - stats.fs_blocks_avail -^ stats.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 *^ stats.fs_block_size /^ 1024L) - (stats.fs_blocks_used *^ stats.fs_block_size /^ 1024L) - (blocks_avail *^ stats.fs_block_size /^ 1024L) - stats.fs_name - ) else ( (* Human-readable blocks. *) - printf "%10s %10s %10s %s\n" - (printable_size (blocks_total *^ stats.fs_block_size)) - (printable_size (stats.fs_blocks_used *^ stats.fs_block_size)) - (printable_size (blocks_avail *^ stats.fs_block_size)) - stats.fs_name - ) - ) else ( (* Inodes display. *) - printf "%10Ld %10Ld %10Ld %s\n" - stats.fs_inodes_total stats.fs_inodes_used stats.fs_inodes_avail - stats.fs_name - ) - - (* Unsupported filesystem or other failure. *) - | ProbeFailed reason -> - printf " %s\n" reason - - | ProbeIgnore -> () - ) statss - -(* Target is something like "hda" and size is the size in sectors. *) -and print_device dom_name target source size = - printf "%s /dev/%s (%s) %s\n" - dom_name target (printable_size (size *^ sector_size)) source - -and 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.) - -and read_int32_le str offs = - Int64.of_int (Char.code str.[offs]) +^ - 256L *^ Int64.of_int (Char.code str.[offs+1]) +^ - 65536L *^ Int64.of_int (Char.code str.[offs+2]) +^ - 16777216L *^ Int64.of_int (Char.code str.[offs+3]) - -and read_int16_le str offs = - Int64.of_int (Char.code str.[offs]) +^ - 256L *^ Int64.of_int (Char.code str.[offs+1]) +(* 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]" + +(* 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 filesystems. Returns [Some fs] or [None]. *) +let probe_for_filesystems 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 = + lvm_types := (lvm_name, probe_fn) :: !lvm_types +*) + +(*----------------------------------------------------------------------*) let main () = (* Command line argument parsing. *) @@ -337,6 +279,10 @@ let main () = 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)"; @@ -354,6 +300,8 @@ let main () = " " ^ 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 @@ -369,127 +317,230 @@ OPTIONS" in Arg.parse argspec anon_fun usage_msg; - 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 - let doms : domain list = - (* 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 ") 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 node in XML") - | Xml.Element ("name", _, [Xml.PCData name]) :: _ -> name - | Xml.Element ("name", _, _) :: _ -> - failwith (s_ "get_xml_desc returned strange node") - | _ :: rest -> loop rest - in - let name = loop nodes in - - let devices = + 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 ") 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 node in XML") + | Xml.Element ("name", _, [Xml.PCData name]) :: _ -> name + | Xml.Element ("name", _, _) :: _ -> + failwith (s_ "get_xml_desc returned strange 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 ("devices", _, devices) -> Some devices + | 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 - ) 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 - - Some { - d_type = typ; d_device = device; - d_source = source; d_target = target - } - | _ -> None - ) devices in - - { dom_name = name; dom_id = domid; dom_disks = disks } - ) xmls in + ) devices in + + { dom_name = name; dom_id = domid; dom_disks = disks } + ) 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; + } + ] + } + ) !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_filesystems dev in + match fs with + | Some fs -> + { disk with d_content = `Filesystem fs } + | None -> + (* Not partitioned, no filesystem, so it's spare. *) + disk + ) 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_filesystems p.part_dev in + match fs with + | Some fs -> + { p with part_content = `Filesystem fs } + | None -> + p + ) else p + ) parts.parts in + let parts = { parts with parts = ps } in + { disk with d_content = `Partitions parts } + | disk -> disk + ) in + + (* XXX LVM stuff here. *) + + (* Print the title. *) let () = @@ -501,16 +552,108 @@ OPTIONS" in printf "%-20s %10s %10s %10s %s\n%!" (s_ "Filesystem") total used avail (s_ "Type") in - (* Probe the devices. *) - List.iter ( - fun { dom_name = dom_name; dom_disks = dom_disks } -> - List.iter ( - function - | { d_source = Some source; d_target = Some target } -> - probe_device dom_name target source - | { d_device = Some "cdrom" } -> - () (* Ignore physical CD-ROM devices. *) - | _ -> - print_endline (s_ "(device omitted)"); - ) dom_disks - ) doms + 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 = + List.iter ( + fun ({ dom_disks = disks } as dom) -> + List.iter ( + function + | ({ d_content = `Filesystem fs } as disk) -> + f dom disk None fs + | ({ d_content = `Partitions partitions } as disk) -> + List.iteri ( + fun i -> + function + | ({ part_content = `Filesystem fs } as part) -> + f dom disk (Some (part, i)) fs + | _ -> () + ) partitions.parts + | _ -> () + ) disks + ) doms + in + + (* Print stats for each recognized filesystem. *) + let print_stats dom disk part fs = + (* Printable name is like "domain:hda" or "domain:hda1". *) + let name = + let dom_name = dom.dom_name in + let d_target = disk.d_target in + match part with + | None -> + dom_name ^ ":" ^ d_target + | Some (_, pnum) -> + dom_name ^ ":" ^ d_target ^ string_of_int pnum 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 + +(* +(* Probe a single partition, which we assume contains either a + * filesystem or is a PV. + * - target will be something like "hda" or "hda1" + * - part_type will be the partition type if known, or None + * - fd is a file descriptor opened on the device + * - start & size are where we think the start and size of the + * partition is within the file descriptor (in SECTORS) + *) +and probe_partition target part_type fd start size = + match part_type with + | None -> + ProbeFailed (s_ "detection of unpartitioned devices not yet supported") + | Some 0x05 -> + ProbeIgnore (* Extended partition - ignore it. *) + | Some part_type -> + try + let probe_fn = Hashtbl.find filesystems part_type in + probe_fn target part_type fd start size + with + Not_found -> + ProbeFailed + (sprintf (f_ "unsupported partition type %02x") part_type) +*) diff --git a/virt-df/virt_df_ext2.ml b/virt-df/virt_df_ext2.ml index 1acd855..0ea8a25 100644 --- a/virt-df/virt_df_ext2.ml +++ b/virt-df/virt_df_ext2.ml @@ -21,46 +21,82 @@ open Unix open Printf + open Virt_df_gettext.Gettext +open Virt_df + +let superblock_offset = 1024L + +let probe_ext2 (dev : device) = + (* 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 *) -(* Int64 operators for convenience. *) -let (+^) = Int64.add -let (-^) = Int64.sub -let ( *^ ) = Int64.mul -let (/^) = Int64.div - -let sector_size = Virt_df.sector_size -let read_int32_le = Virt_df.read_int32_le - -let probe_ext2 target part_type fd start size = - LargeFile.lseek fd ((start+^2L) *^ sector_size) SEEK_SET; - let str = String.create 128 in - if read fd str 0 128 <> 128 then - failwith (s_ "error reading ext2/ext3 magic") - else ( - if str.[56] != '\x53' || str.[57] != '\xEF' then ( - Virt_df.ProbeFailed (s_ "partition marked EXT2/3 but no valid filesystem") - ) else ( - (* Refer to *) - let s_inodes_count = read_int32_le str 0 in - let s_blocks_count = read_int32_le str 4 in - let s_r_blocks_count = read_int32_le str 8 in - let s_free_blocks_count = read_int32_le str 12 in - let s_free_inodes_count = read_int32_le str 16 in - let s_first_data_block = read_int32_le str 20 in - let s_log_block_size = read_int32_le str 24 in - (*let s_log_frag_size = read_int32_le str 28 in*) - let s_blocks_per_group = read_int32_le str 32 in - - (* Work out the block size in bytes. *) - let s_log_block_size = Int64.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 = - (s_blocks_count -^ s_first_data_block -^ 1L) - /^ s_blocks_per_group +^ 1L in + (* 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. *) @@ -71,30 +107,32 @@ let probe_ext2 target part_type fd start size = /^ s_desc_per_block *) - (* Calculate the block overhead (used by superblocks, inodes, etc.) - * See fs/ext2/super.c. - *) - let overhead = s_first_data_block in - let overhead = (* XXX *) overhead in - - - Virt_df.Filesystem { - Virt_df.fs_name = s_ "Linux ext2/3"; - fs_block_size = block_size; - fs_blocks_total = s_blocks_count -^ overhead; - fs_blocks_reserved = s_r_blocks_count; - fs_blocks_avail = s_free_blocks_count; - fs_blocks_used = s_blocks_count -^ overhead -^ s_free_blocks_count; - fs_inodes_total = s_inodes_count; - fs_inodes_reserved = 0L; (* XXX? *) - fs_inodes_avail = s_free_inodes_count; - fs_inodes_used = s_inodes_count (*-^ 0L*) -^ s_free_inodes_count; - } - ) - ) + (* 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 () = - Virt_df.fs_register - [ 0x83 ] (* Partition type. *) - probe_ext2 +let () = filesystem_type_register "ext2" probe_ext2 diff --git a/virt-df/virt_df_linux_swap.ml b/virt-df/virt_df_linux_swap.ml index 04e22b9..ad56149 100644 --- a/virt-df/virt_df_linux_swap.ml +++ b/virt-df/virt_df_linux_swap.ml @@ -21,22 +21,34 @@ *) open Virt_df_gettext.Gettext - -(* Int64 operators for convenience. *) -let (+^) = Int64.add -let (-^) = Int64.sub -let ( *^ ) = Int64.mul -let (/^) = Int64.div - -let probe_swap target part_type fd start size = - Virt_df.Swap { - Virt_df.swap_name = s_ "Linux swap"; - swap_block_size = 4096L; (* XXX *) - swap_blocks_total = size *^ 512L /^ 4096L; - } +open Virt_df + +let probe_swap (dev : device) = + (* 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 () = - Virt_df.fs_register - [ 0x82 ] (* Partition type. *) - probe_swap +let () = filesystem_type_register "linux_swap" probe_swap diff --git a/virt-df/virt_df_lvm2.ml b/virt-df/virt_df_lvm2.ml index d01a5a8..a79ec7f 100644 --- a/virt-df/virt_df_lvm2.ml +++ b/virt-df/virt_df_lvm2.ml @@ -22,18 +22,11 @@ open Printf open Virt_df_gettext.Gettext +open Virt_df -(* Int64 operators for convenience. *) -let (+^) = Int64.add -let (-^) = Int64.sub -let ( *^ ) = Int64.mul -let (/^) = Int64.div - -let probe_lvm2 target part_type fd start size = - Virt_df.ProbeFailed (s_ "LVM2 not supported yet") +let probe_lvm2 (dev : device) = + raise Not_found (* Register with main code. *) let () = - Virt_df.fs_register - [ 0x8e ] (* Partition type. *) - probe_lvm2 + filesystem_type_register "LVM2" probe_lvm2 diff --git a/virt-df/virt_df_main.ml b/virt-df/virt_df_main.ml old mode 100755 new mode 100644 index bc4096b..1359b28 --- a/virt-df/virt_df_main.ml +++ b/virt-df/virt_df_main.ml @@ -17,4 +17,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) +(* We just need this so that the filesystem modules get a chance to + * register themselves before we run the main program. + *) let () = Virt_df.main () diff --git a/virt-df/virt_df_mbr.ml b/virt-df/virt_df_mbr.ml new file mode 100644 index 0000000..b9a6cb7 --- /dev/null +++ b/virt-df/virt_df_mbr.ml @@ -0,0 +1,195 @@ +(* '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 dev partno start size = + 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 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 partition boundaries (%Ld/%d/%Ld)" + name offset len size + ); + dev#read (start+^offset) len +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 : device) = + (* 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 + eprintf "first_lba = %Lx\n" first_lba; + eprintf "part_size = %Lx\n" part_size; + { part_status = part_status; + part_type = part_type; + part_dev = new partition_device dev partno first_lba part_size; + 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 -- cgit v1.1 From fabdbe4e169e123774ab1bf665cdf4a4e9536296 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Mon, 14 Apr 2008 17:50:02 +0100 Subject: =?UTF-8?q?Added=20Polish=20translation=20(thanks:=20Piotr=20Dr?= =?UTF-8?q?=C4=85g)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- po/LINGUAS | 1 + po/pl.po | 1018 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 1019 insertions(+) create mode 100644 po/pl.po diff --git a/po/LINGUAS b/po/LINGUAS index bef7f4a..ffff11a 100644 --- a/po/LINGUAS +++ b/po/LINGUAS @@ -1 +1,2 @@ ja +pl diff --git a/po/pl.po b/po/pl.po new file mode 100644 index 0000000..a1474af --- /dev/null +++ b/po/pl.po @@ -0,0 +1,1018 @@ +# translation of pl.po to Polish +# Piotr Drąg , 2008. +# +msgid "" +msgstr "" +"Project-Id-Version: pl\n" +"Report-Msgid-Bugs-To: \n" +"POT-Creation-Date: 2008-03-28 17:30+0000\n" +"PO-Revision-Date: 2008-04-12 21:09+0200\n" +"Last-Translator: Piotr Drąg \n" +"Language-Team: Polish \n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" + +#: ../virt-top/virt_top.ml:1490 +msgid "# .virt-toprc virt-top configuration file\\n" +msgstr "# plik konfiguracji virt-top .virt-toprc\\n" + +#: ../virt-top/virt_top.ml:1508 +msgid "# Enable CSV output to the named file\\n" +msgstr "# Włącz wyjście CSV do pliku named\\n" + +#: ../virt-top/virt_top.ml:1511 +msgid "# To protect this file from being overwritten, uncomment next line\\n" +msgstr "# Aby ochronić ten plik przed zastąpieniem, usuń komentarz z następnego wiersza\\n" + +#: ../virt-top/virt_top.ml:1505 +msgid "# To send debug and error messages to a file, uncomment next line\\n" +msgstr "# Aby wysłać komunikaty debugowania i błędów do pliku, usuń komentarz z następnego wiersza\\n" + +#: ../virt-top/virt_top.ml:1491 +msgid "# generated on %s by %s\\n" +msgstr "# utworzone %s przez %s\\n" + +#: ../virt-top/virt_top.ml:63 +msgid "%CPU" +msgstr "%CPU" + +#: ../virt-top/virt_top.ml:64 +msgid "%MEM" +msgstr "%MEM" + +#: ../virt-top/virt_top.ml:1144 +msgid "%d domains, %d active, %d running, %d sleeping, %d paused, %d inactive D:%d O:%d X:%d" +msgstr "%d domeny, %d aktywne, %d uruchomionych, %d uśpionych, %d wstrzymanych, %d nieaktywnych D:%d O:%d X:%d" + +#: ../mlvirsh/mlvirsh.ml:716 +msgid "%s: command not found" +msgstr "%s: nie znaleziono polecenia" + +#: ../virt-top/virt_top.ml:105 +msgid "%s: display should be %s" +msgstr "%s: ekran powinien być %s" + +#: ../virt-top/virt_top.ml:82 +msgid "%s: sort order should be: %s" +msgstr "%s: porządek sortowania powinien być: %s" + +#: ../virt-df/virt_df.ml:362 ../virt-top/virt_top.ml:202 +msgid "%s: unknown parameter" +msgstr "%s: nieznany parametr" + +#: ../virt-top/virt_top.ml:233 +msgid "%s:%d: configuration item ``%s'' ignored\\n%!" +msgstr "%s:%d: zignorowano element konfiguracji ``%s''\\n%!" + +#: ../virt-df/virt_df.ml:514 +msgid "(device omitted)" +msgstr "(pominięto urządzenie)" + +#: ../virt-top/virt_top.ml:145 +msgid "-d: cannot set a negative delay" +msgstr "-d: nie można ustawić negatywnego opóźnienia" + +#: ../virt-df/virt_df.ml:498 +msgid "1K-blocks" +msgstr "Bloki 1K" + +#: ../virt-ctrl/vc_mainwindow.ml:97 +msgid "About ..." +msgstr "Informacje o..." + +#: ../mlvirsh/mlvirsh.ml:399 +msgid "Attach device to domain." +msgstr "Podłącz urządzenie do domeny." + +#: ../virt-df/virt_df.ml:499 ../virt-df/virt_df.ml:498 +msgid "Available" +msgstr "Dostępne" + +#: ../virt-top/virt_top.ml:167 +msgid "Batch mode" +msgstr "Tryb wsadowy" + +#: ../virt-top/virt_top.ml:70 +msgid "Block read reqs" +msgstr "Wymagania odczytania blokowego" + +#: ../virt-top/virt_top.ml:71 +msgid "Block write reqs" +msgstr "Wymagania zapisania blokowego" + +#: ../virt-ctrl/vc_connections.ml:408 +msgid "CPU" +msgstr "Procesor" + +#: ../mlvirsh/mlvirsh.ml:365 +msgid "CPU affinity" +msgstr "Dopasowanie procesora" + +#: ../virt-top/virt_top.ml:1151 +msgid "CPU: %2.1f%% Mem: %Ld MB (%Ld MB by guests)" +msgstr "Procesor: %2.1f%% Pamięć: %Ld MB (%Ld MB przez gości)" + +#: ../virt-ctrl/vc_connection_dlg.ml:182 +msgid "Cancel" +msgstr "Anuluj" + +#: ../virt-top/virt_top.ml:1319 +msgid "Change delay from %.1f to: " +msgstr "Zmień opóźnienie z %.1f na: " + +#: ../mlvirsh/mlvirsh.ml:409 +msgid "Close an existing hypervisor connection." +msgstr "Zamknij istniejące połączenie nadzorcy." + +#: ../virt-ctrl/vc_mainwindow.ml:118 +msgid "Connect ..." +msgstr "Połącz się..." + +#: ../virt-ctrl/vc_mainwindow.ml:160 +msgid "Connect to ..." +msgstr "Połącz się z..." + +#: ../virt-df/virt_df.ml:348 ../virt-df/virt_df.ml:346 ../virt-top/virt_top.ml:171 ../virt-top/virt_top.ml:169 +msgid "Connect to URI (default: Xen)" +msgstr "Połącz się z URI (domyślnie: Xen)" + +#: ../virt-top/virt_top.ml:1558 +msgid "Connect: %s; Hostname: %s" +msgstr "Połącz się: %s; nazwa hosta: %s" + +#: ../mlvirsh/mlvirsh.ml:476 +msgid "Core dump a domain to a file for analysis." +msgstr "Zrzut core domeny do pliku do analizy." + +#: ../mlvirsh/mlvirsh.ml:422 +msgid "Create a domain from an XML file." +msgstr "Utwórz domenę z pliku XML." + +#: ../mlvirsh/mlvirsh.ml:534 +msgid "Create a network from an XML file." +msgstr "Utwórz sieć z pliku XML." + +#: ../virt-top/virt_top.ml:1596 +msgid "DISPLAY MODES" +msgstr "TRYBY WYŚWIETLANIA" + +#: ../mlvirsh/mlvirsh.ml:426 +msgid "Define (but don't start) a domain from an XML file." +msgstr "Określ (ale nie uruchamiaj) domenę z pliku XML." + +#: ../mlvirsh/mlvirsh.ml:538 +msgid "Define (but don't start) a network from an XML file." +msgstr "Określ (ale nie uruchamiaj) sieć z pliku XML." + +#: ../virt-top/virt_top.ml:1326 +msgid "Delay must be > 0" +msgstr "Opóźnienie musi być > 0" + +#: ../virt-top/virt_top.ml:181 +msgid "Delay time interval (seconds)" +msgstr "Czas między opóźnieniami (sekundy)" + +#: ../virt-top/virt_top.ml:1552 +msgid "Delay: %.1f secs; Batch: %s; Secure: %s; Sort: %s" +msgstr "Opóźnienie: %.1f sekundy; wsadowo: %s; bezpieczeństwo: %s; sortowanie: %s" + +#: ../mlvirsh/mlvirsh.ml:433 +msgid "Destroy a domain." +msgstr "Zniszcz domenę." + +#: ../mlvirsh/mlvirsh.ml:541 +msgid "Destroy a network." +msgstr "Zniszcz sieć." + +#: ../mlvirsh/mlvirsh.ml:430 +msgid "Detach device from domain." +msgstr "Odłącz urządzenie z domeny." + +#: ../virt-ctrl/vc_mainwindow.ml:123 +msgid "Details" +msgstr "Szczegóły" + +#: ../virt-top/virt_top.ml:175 +msgid "Disable CPU stats in CSV" +msgstr "Wyłącz statystyki procesora w CSV" + +#: ../virt-top/virt_top.ml:177 +msgid "Disable block device stats in CSV" +msgstr "Wyłącz statystyki urządzenia blokowego w CSV" + +#: ../virt-top/virt_top.ml:179 +msgid "Disable net stats in CSV" +msgstr "Wyłącz statystyki sieci w CSV" + +#: ../mlvirsh/mlvirsh.ml:493 +msgid "Display free memory for machine, NUMA cell or range of cells" +msgstr "Wyświetl wolną pamięć dla komputera, komórkę NUMA lub zakres komórek" + +#: ../mlvirsh/mlvirsh.ml:437 +msgid "Display the block device statistics for a domain." +msgstr "Wyświetl statystyki urządzenia blokowego dla domeny." + +#: ../mlvirsh/mlvirsh.ml:444 +msgid "Display the network interface statistics for a domain." +msgstr "Wyświetl statystyki interfejsu sieciowego dla domeny." + +#: ../virt-df/virt_df.ml:358 +msgid "Display version and exit" +msgstr "Wyświetl wersję i zakończ" + +#: ../virt-top/virt_top.ml:191 +msgid "Do not read init file" +msgstr "Nie odczytuj pliku init" + +#: ../virt-top/virt_top.ml:66 +msgid "Domain ID" +msgstr "Identyfikator domeny" + +#: ../virt-top/virt_top.ml:67 +msgid "Domain name" +msgstr "Nazwa domeny" + +#: ../virt-top/virt_top.ml:1610 +msgid "Domains display" +msgstr "Ekran domen" + +#: ../virt-ctrl/vc_mainwindow.ml:61 ../virt-top/virt_top_main.ml:47 ../virt-top/virt_top.ml:1528 +msgid "Error" +msgstr "Błąd" + +#: ../virt-top/virt_top.ml:185 +msgid "Exit at given time" +msgstr "Zakończ o podanym czasie" + +#: ../virt-ctrl/vc_mainwindow.ml:79 +msgid "File" +msgstr "Plik" + +#: ../virt-df/virt_df.ml:502 +msgid "Filesystem" +msgstr "System plików" + +#: ../mlvirsh/mlvirsh.ml:606 +msgid "Get the current scheduler parameters for a domain." +msgstr "Uzyskaj obecne parametry planisty dla domeny." + +#: ../mlvirsh/mlvirsh.ml:623 +msgid "Get the scheduler type." +msgstr "Uzyskaj typ planisty." + +#: ../mlvirsh/mlvirsh.ml:635 +msgid "Gracefully shutdown a domain." +msgstr "Wyłącz domenę." + +#: ../virt-ctrl/vc_mainwindow.ml:96 ../virt-ctrl/vc_mainwindow.ml:80 ../virt-top/virt_top.ml:1580 +msgid "Help" +msgstr "Pomoc" + +#: ../virt-top/virt_top.ml:187 +msgid "Historical CPU delay" +msgstr "Historyczne opóźnienie procsora" + +#: ../mlvirsh/mlvirsh.ml:35 +msgid "Hypervisor connection URI" +msgstr "URI połączenia nadzorcy" + +#: ../virt-ctrl/vc_connections.ml:405 +msgid "ID" +msgstr "Identyfikator" + +#: ../virt-df/virt_df.ml:500 +msgid "IFree" +msgstr "IWolne" + +#: ../virt-df/virt_df.ml:500 +msgid "IUse" +msgstr "IUżyte" + +#: ../virt-df/virt_df.ml:500 +msgid "Inodes" +msgstr "Iwęzły" + +#: ../virt-df/virt_df_lvm2.ml:33 +msgid "LVM2 not supported yet" +msgstr "LVM2 nie jest jeszcze obsługiwane" + +#: ../virt-df/virt_df_ext2.ml:82 +msgid "Linux ext2/3" +msgstr "Linuksowe ext2/3" + +#: ../virt-df/virt_df_linux_swap.ml:33 +msgid "Linux swap" +msgstr "Linuksowa przestrzeń wymiany" + +#: ../mlvirsh/mlvirsh.ml:557 +msgid "List the active networks." +msgstr "Wyświetl listę aktywnych sieci." + +#: ../mlvirsh/mlvirsh.ml:565 +msgid "List the defined but inactive networks." +msgstr "Wyświetl listę określonych, ale nieaktywnych sieci." + +#: ../mlvirsh/mlvirsh.ml:516 +msgid "List the defined but not running domains." +msgstr "Wyświetl listę określonych, ale nie uruchomionych domen." + +#: ../mlvirsh/mlvirsh.ml:508 +msgid "List the running domains." +msgstr "Wyświetl listę uruchomionych domen." + +#: ../virt-ctrl/vc_mainwindow.ml:158 +msgid "Local QEMU/KVM" +msgstr "Lokalny QEMU/KVM" + +#: ../virt-ctrl/vc_mainwindow.ml:157 +msgid "Local Xen" +msgstr "Lokalny Xen" + +#: ../virt-ctrl/vc_connection_dlg.ml:93 +msgid "Local network" +msgstr "Lokalna sieć" + +#: ../virt-top/virt_top.ml:173 +msgid "Log statistics to CSV file" +msgstr "Zapisz statystyki do pliku CSV" + +#: ../virt-top/virt_top.ml:1563 +msgid "MAIN KEYS" +msgstr "GŁÓWNE KLUCZE" + +#: ../virt-ctrl/vc_connections.ml:409 +msgid "Memory" +msgstr "Pamięć" + +#: ../virt-top/virt_top.ml:1617 +msgid "More help in virt-top(1) man page. Press any key to return." +msgstr "Więcej pomocy na stronie podręcznika virt-top(1). Naciśnij dowolny klawisz, aby kontynuować." + +#: ../virt-df/virt_df.ml:382 ../virt-top/virt_top.ml:258 +msgid "NB: If you want to monitor a local Xen hypervisor, you usually need to be root" +msgstr "NB: jeśli chcesz monitorować lokalnego nadzorcę Xena, zwykle musisz być rootem" + +#: ../virt-ctrl/vc_connections.ml:406 +msgid "Name" +msgstr "Nazwa" + +#: ../virt-top/virt_top.ml:68 +msgid "Net RX bytes" +msgstr "Sieciowe bajty RX" + +#: ../virt-top/virt_top.ml:69 +msgid "Net TX bytes" +msgstr "Sieciowe bajty TX" + +#: ../virt-top/virt_top.ml:1332 +msgid "Not a valid number" +msgstr "Nie jest prawidłowym numerem" + +#: ../virt-top/virt_top.ml:193 +msgid "Number of iterations to run" +msgstr "Liczba iteracji do uruchomienia" + +#: ../virt-ctrl/vc_connection_dlg.ml:170 ../virt-ctrl/vc_connection_dlg.ml:137 +msgid "Open" +msgstr "Otwórz" + +#: ../mlvirsh/mlvirsh.ml:418 +msgid "Open a new hypervisor connection." +msgstr "Otwórz nowe połączenie nadzorcy." + +#: ../virt-ctrl/vc_mainwindow.ml:86 +msgid "Open connection ..." +msgstr "Otwórz połączenie..." + +#: ../virt-ctrl/vc_connection_dlg.ml:40 +msgid "Open connection to hypervisor" +msgstr "Otwórz połączenie do nadzorcy" + +#: ../virt-ctrl/vc_mainwindow.ml:130 +msgid "Pause" +msgstr "Wstrzymaj" + +#: ../mlvirsh/mlvirsh.ml:670 ../mlvirsh/mlvirsh.ml:666 +msgid "Pin domain VCPU to a list of physical CPUs." +msgstr "Przypnij wirtualny procesor do listy fizycznych procesorów." + +#: ../mlvirsh/mlvirsh.ml:706 +msgid "Print list of commands or full description of one command." +msgstr "Wyświetl listę poleceń lub pełny opis jednego polecenia." + +#: ../mlvirsh/mlvirsh.ml:584 +msgid "Print node information." +msgstr "Wyświetl informacje o węźle." + +#: ../virt-df/virt_df.ml:352 ../virt-df/virt_df.ml:350 +msgid "Print sizes in human-readable format" +msgstr "Wyświetl rozmiary w formacie czytelnym dla człowieka" + +#: ../mlvirsh/mlvirsh.ml:440 +msgid "Print the ID of a domain." +msgstr "Wyświetl identyfikator domeny." + +#: ../mlvirsh/mlvirsh.ml:464 +msgid "Print the OS type of a domain." +msgstr "Wyświetl typ systemu operacyjnego domeny." + +#: ../mlvirsh/mlvirsh.ml:472 +msgid "Print the UUID of a domain." +msgstr "Wyświetl UUID domeny." + +#: ../mlvirsh/mlvirsh.ml:581 +msgid "Print the UUID of a network." +msgstr "Wyświetl UUID sieci." + +#: ../mlvirsh/mlvirsh.ml:480 +msgid "Print the XML description of a domain." +msgstr "Wyświetl opis XML domeny." + +#: ../mlvirsh/mlvirsh.ml:545 +msgid "Print the XML description of a network." +msgstr "Wyświetl opis XML sieci." + +#: ../mlvirsh/mlvirsh.ml:530 +msgid "Print the bridge name of a network." +msgstr "Wyświetl nazwę mostka sieci." + +#: ../mlvirsh/mlvirsh.ml:653 +msgid "Print the canonical URI." +msgstr "Wyświetl kanoniczne URI." + +#: ../mlvirsh/mlvirsh.ml:448 +msgid "Print the domain info." +msgstr "Wyświetl informacje o domenie." + +#: ../mlvirsh/mlvirsh.ml:468 +msgid "Print the domain state." +msgstr "Wyświetl stan domeny." + +#: ../mlvirsh/mlvirsh.ml:646 +msgid "Print the driver name" +msgstr "Wyświetl nazwę sterownika" + +#: ../mlvirsh/mlvirsh.ml:677 +msgid "Print the driver version" +msgstr "Wyświetl wersję sterownika" + +#: ../mlvirsh/mlvirsh.ml:500 +msgid "Print the hostname." +msgstr "Wyświetl nazwę hosta." + +#: ../mlvirsh/mlvirsh.ml:522 +msgid "Print the max VCPUs available." +msgstr "Wyświetl maksymalną ilość dostępnych wirtualnych procesorów." + +#: ../mlvirsh/mlvirsh.ml:456 +msgid "Print the max VCPUs of a domain." +msgstr "Wyświetl maksymalną ilość wirtualnych procesorów domeny." + +#: ../mlvirsh/mlvirsh.ml:452 +msgid "Print the max memory (in kilobytes) of a domain." +msgstr "Wyświetl maksymalną pamięć (w kilobitach) domeny." + +#: ../mlvirsh/mlvirsh.ml:460 +msgid "Print the name of a domain." +msgstr "Wyświetl nazwę domeny." + +#: ../mlvirsh/mlvirsh.ml:569 +msgid "Print the name of a network." +msgstr "Wyświetl nazwę sieci." + +#: ../mlvirsh/mlvirsh.ml:497 +msgid "Print whether a domain autostarts at boot." +msgstr "Wyświetl, czy domena powinna być automatycznie uruchamiania po starcie." + +#: ../mlvirsh/mlvirsh.ml:549 +msgid "Print whether a network autostarts at boot." +msgstr "Wyświetl, czy sieć powinna być automatycznie uruchamiania po starcie." + +#: ../virt-ctrl/vc_connection_dlg.ml:83 +msgid "QEMU or KVM" +msgstr "QEMU lub KVM" + +#: ../virt-ctrl/vc_mainwindow.ml:89 ../virt-top/virt_top.ml:1578 +msgid "Quit" +msgstr "Zakończ" + +#: ../mlvirsh/mlvirsh.ml:519 +msgid "Quit the interactive terminal." +msgstr "Zakończ interaktywny terminal." + +#: ../mlvirsh/mlvirsh.ml:36 +msgid "Read-only connection" +msgstr "Połączenie tylko do odczytu" + +#: ../mlvirsh/mlvirsh.ml:587 +msgid "Reboot a domain." +msgstr "Ponownie uruchom domenę." + +#: ../virt-ctrl/vc_connection_dlg.ml:134 +msgid "Refresh" +msgstr "Odśwież" + +#: ../mlvirsh/mlvirsh.ml:592 +msgid "Restore a domain from the named file." +msgstr "Przywróć domenę z pliku named." + +#: ../virt-ctrl/vc_mainwindow.ml:133 +msgid "Resume" +msgstr "Wznów" + +#: ../mlvirsh/mlvirsh.ml:595 +msgid "Resume a domain." +msgstr "Wznów domenę." + +#: ../mlvirsh/mlvirsh.ml:406 +msgid "Returns capabilities of hypervisor/driver." +msgstr "Zwraca możliwości nadzorcy/sterownika." + +#: ../virt-top/virt_top.ml:199 +msgid "Run from a script (no user interface)" +msgstr "Uruchom ze skryptu (brak interfejsu użytkownika)" + +#: ../virt-top/virt_top.ml:1584 +msgid "SORTING" +msgstr "SORTOWANIE" + +#: ../mlvirsh/mlvirsh.ml:599 +msgid "Save a domain to a file." +msgstr "Zapisz domenę do pliku." + +#: ../virt-top/virt_top.ml:197 +msgid "Secure (\\\"kiosk\\\") mode" +msgstr "Tryb bezpieczny (\\\"kiosk\\\")" + +#: ../virt-top/virt_top.ml:1593 +msgid "Select sort field" +msgstr "Wybierz pole sortowania" + +#: ../virt-top/virt_top.ml:183 +msgid "Send debug messages to file" +msgstr "Wyślij komunikaty debugowania do pliku" + +#: ../virt-top/virt_top.ml:189 +msgid "Set name of init file" +msgstr "Ustaw nazwę pliku init" + +#: ../virt-top/virt_top.ml:195 +msgid "Set sort order (%s)" +msgstr "Ustaw porządek sortowania (%s)" + +#: ../virt-top/virt_top.ml:1340 +msgid "Set sort order for main display" +msgstr "Ustaw porządek sortowania dla głównego ekranu" + +#: ../mlvirsh/mlvirsh.ml:631 +msgid "Set the maximum memory used by the domain (in kilobytes)." +msgstr "Ustaw maksymalną pamięć używaną przez domenę (w kilobajtach)." + +#: ../mlvirsh/mlvirsh.ml:627 +msgid "Set the memory used by the domain (in kilobytes)." +msgstr "Ustaw pamięć używaną przez domenę (w kilobajtach)." + +#: ../mlvirsh/mlvirsh.ml:674 +msgid "Set the number of virtual CPUs assigned to a domain." +msgstr "Ustaw liczbę wirtualnych procesorów powiązanych z domeną." + +#: ../mlvirsh/mlvirsh.ml:618 +msgid "Set the scheduler parameters for a domain." +msgstr "Ustaw parametry planisty domeny." + +#: ../virt-top/virt_top.ml:1579 +msgid "Set update interval" +msgstr "Ustaw czas między aktualizacjami" + +#: ../mlvirsh/mlvirsh.ml:403 +msgid "Set whether a domain autostarts at boot." +msgstr "Ustaw, czy automatycznie uruchamiać domenę po starcie." + +#: ../mlvirsh/mlvirsh.ml:526 +msgid "Set whether a network autostarts at boot." +msgstr "Ustaw, czy automatycznie uruchamiać sieć po starcie." + +#: ../virt-df/virt_df.ml:344 ../virt-df/virt_df.ml:342 +msgid "Show all domains (default: only active domains)" +msgstr "Wyświetl wszystkie domeny (domyślnie: tylko aktywne domeny)" + +#: ../virt-df/virt_df.ml:356 ../virt-df/virt_df.ml:354 +msgid "Show inodes instead of blocks" +msgstr "Wyświetl i-węzły zamiast bloków" + +#: ../virt-ctrl/vc_mainwindow.ml:137 +msgid "Shutdown" +msgstr "Wyłącz" + +#: ../virt-df/virt_df.ml:499 +msgid "Size" +msgstr "Rozmiar" + +#: ../virt-top/virt_top.ml:1589 +msgid "Sort by %CPU" +msgstr "Uporządkuj według %CPU" + +#: ../virt-top/virt_top.ml:1590 +msgid "Sort by %MEM" +msgstr "Uporządkuj według %MEM" + +#: ../virt-top/virt_top.ml:1592 +msgid "Sort by ID" +msgstr "Uporządkuj według identyfikatorów" + +#: ../virt-top/virt_top.ml:1591 +msgid "Sort by TIME" +msgstr "Uporządkuj według TIME" + +#: ../virt-ctrl/vc_mainwindow.ml:127 +msgid "Start" +msgstr "Uruchom" + +#: ../mlvirsh/mlvirsh.ml:639 +msgid "Start a previously defined inactive domain." +msgstr "Uruchom poprzednio określoną nieaktywną domenę." + +#: ../mlvirsh/mlvirsh.ml:573 +msgid "Start a previously defined inactive network." +msgstr "Uruchom poprzednio określoną nieaktywną sieć." + +#: ../virt-top/virt_top.ml:165 +msgid "Start by displaying block devices" +msgstr "Uruchom przez wyświetlenie urządzeń blokowych" + +#: ../virt-top/virt_top.ml:163 +msgid "Start by displaying network interfaces" +msgstr "Uruchom przez wyświetlenie interfejsów sieciowych" + +#: ../virt-top/virt_top.ml:161 +msgid "Start by displaying pCPUs (default: tasks)" +msgstr "Uruchom przez wyświetlanie fizycznych procesorów (domyślnie: zadania)" + +#: ../virt-ctrl/vc_connections.ml:407 +msgid "Status" +msgstr "Stan" + +#: ../mlvirsh/mlvirsh.ml:643 +msgid "Suspend a domain." +msgstr "Uśpij domenę." + +#: ../mlvirsh/mlvirsh.ml:40 +msgid "Synopsis:\n %s [options] [command]\n\nList of all commands:\n %s help\n\nFull description of a single command:\n %s help command\n\nOptions:" +msgstr "Podsumowanie:\n %s [opcje] [polecenie]\n\nWyświetl listę wszystkich poleceń:\n %s help\n\nPełny opis jednego polecenia:\n %s help polecenie\n\nOpcje:" + +#: ../virt-top/virt_top.ml:65 +msgid "TIME (CPU time)" +msgstr "TIME (czas procesora)" + +#: ../virt-ctrl/vc_connection_dlg.ml:62 +msgid "This machine" +msgstr "Ten komputer" + +#: ../virt-top/virt_top.ml:1613 +msgid "Toggle block devices" +msgstr "Przełącz urządzenia blokowe" + +#: ../virt-top/virt_top.ml:1612 +msgid "Toggle network interfaces" +msgstr "Przełącz interfejsy sieciowe" + +#: ../virt-top/virt_top.ml:1611 +msgid "Toggle physical CPUs" +msgstr "Przełącz fizyczne procesory" + +#: ../virt-df/virt_df.ml:502 +msgid "Type" +msgstr "Podaj" + +#: ../virt-top/virt_top.ml:1341 +msgid "Type key or use up and down cursor keys." +msgstr "Podaj klucz lub użyj klawiszy kursora w górę i w dół." + +#: ../virt-ctrl/vc_connection_dlg.ml:160 +msgid "URI connection" +msgstr "Połączenie URI" + +#: ../mlvirsh/mlvirsh.ml:650 +msgid "Undefine an inactive domain." +msgstr "Usuń określenie nieaktywnej domeny." + +#: ../mlvirsh/mlvirsh.ml:577 +msgid "Undefine an inactive network." +msgstr "Usuń określenie nieaktywnej sieci." + +#: ../virt-top/virt_top.ml:1622 +msgid "Unknown command - try 'h' for help" +msgstr "Nieznane polecenie - wypróbuj \"h\", aby uzyskać pomoc" + +#: ../virt-top/virt_top.ml:1577 +msgid "Update display" +msgstr "Zaktualizuj ekran" + +#: ../mlvirsh/mlvirsh.ml:690 +msgid "Use '%s help command' for help on a command." +msgstr "Użyj \"%s help polecenie\", aby uzyskać pomoc o poleceniu." + +#: ../virt-df/virt_df.ml:499 ../virt-df/virt_df.ml:498 +msgid "Used" +msgstr "Użyte" + +#: ../virt-ctrl/vc_mainwindow.ml:23 +msgid "Virtual Control" +msgstr "Kontrola wirtualna" + +#: ../virt-ctrl/vc_mainwindow.ml:53 +msgid "Virtualisation error" +msgstr "Błąd wirtualizacji" + +#: ../virt-ctrl/vc_mainwindow.ml:39 +msgid "Virtualization control tool (virt-ctrl) by\nRichard W.M. Jones (rjones@redhat.com).\n\nCopyright %s 2007-2008 Red Hat Inc.\n\nLibvirt version: %s\n\nGtk toolkit version: %s" +msgstr "Narzędzie kontroli wirtualizacji (virt-ctrl) by\nRichard W.M. Jones (rjones@redhat.com).\n\nCopyright %s 2007-2008 Red Hat Inc.\n\nWersja libvirt: %s\n\nWersja zestawu narzędzi GTK: %s" + +#: ../virt-top/virt_top.ml:1523 +msgid "Wrote settings to %s" +msgstr "Zapisano ustawienia do %s" + +#: ../virt-ctrl/vc_connection_dlg.ml:76 +msgid "Xen hypervisor" +msgstr "Nadzorca Xen" + +#: ../mlvirsh/mlvirsh.ml:364 +msgid "\\tCPU time: %Ld ns\\n" +msgstr "\\tCzas procesora: %Ld ns\\n" + +#: ../mlvirsh/mlvirsh.ml:362 +msgid "\\tcurrent state: %s\\n" +msgstr "\\tobecny stan: %s\\n" + +#: ../mlvirsh/mlvirsh.ml:361 +msgid "\\ton physical CPU: %d\\n" +msgstr "\\tna fizycznym procesorze: %d\\n" + +#: ../mlvirsh/mlvirsh.ml:298 ../mlvirsh/mlvirsh.ml:289 ../virt-ctrl/vc_helpers.ml:54 +msgid "blocked" +msgstr "zablokowano" + +#: ../mlvirsh/mlvirsh.ml:330 +msgid "cores: %d\\n" +msgstr "rdzenie: %d\\n" + +#: ../mlvirsh/mlvirsh.ml:342 +msgid "cpu_time: %Ld ns\\n" +msgstr "cpu_time: %Ld ns\\n" + +#: ../mlvirsh/mlvirsh.ml:326 +msgid "cpus: %d\\n" +msgstr "procesory: %d\\n" + +#: ../mlvirsh/mlvirsh.ml:293 ../virt-ctrl/vc_helpers.ml:58 +msgid "crashed" +msgstr "zawiesił się" + +#: ../virt-df/virt_df.ml:236 +msgid "detection of unpartitioned devices not yet supported" +msgstr "wykrywanie niespartycjonowanych urządzeń nie jest jeszcze obsługiwane" + +#: ../mlvirsh/mlvirsh.ml:242 +msgid "domain %s: not found. Additional info: %s" +msgstr "domena %s: nie znaleziono. Dodatkowe informacje: %s" + +#: ../virt-df/virt_df_ext2.ml:39 +msgid "error reading ext2/ext3 magic" +msgstr "błąd podczas odczytywanie magii ext2/ext3" + +#: ../virt-df/virt_df.ml:182 +msgid "error reading extended partition" +msgstr "błąd podczas odczytywania partycji rozszerzonej" + +#: ../virt-df/virt_df.ml:149 +msgid "error reading partition table" +msgstr "błąd podczas odczytywania tablicy partycji" + +#: ../virt-ctrl/vc_dbus.ml:239 +msgid "error set after getting System bus" +msgstr "błąd podczas ustawiania po otrzymaniu magistrali systemowej" + +#: ../mlvirsh/mlvirsh.ml:379 +msgid "errors: %Ld\\n" +msgstr "błędy: %Ld\\n" + +#: ../mlvirsh/mlvirsh.ml:258 +msgid "expected field value pairs, but got an odd number of arguments" +msgstr "oczekiwano pary wartości pól, ale otrzymano nieparzystą liczbę argumentów" + +#: ../mlvirsh/mlvirsh.ml:610 +msgid "expecting domain followed by field value pairs" +msgstr "oczekiwano domenę poprzedzoną parami wartości pól" + +#: ../mlvirsh/mlvirsh.ml:220 +msgid "flag should be '%s'" +msgstr "flaga powinna być \"%s\"" + +#: ../virt-df/virt_df.ml:419 ../virt-top/virt_top_xml.ml:46 +msgid "get_xml_desc didn't return " +msgstr "get_xml_desc nie zwróciło " + +#: ../virt-df/virt_df.ml:427 +msgid "get_xml_desc returned no node in XML" +msgstr "get_xml_desc nie zwróciło węzła w XML-u" + +#: ../virt-df/virt_df.ml:430 +msgid "get_xml_desc returned strange node" +msgstr "get_xml_desc zwróciło dziwny węzeł " + +#: ../mlvirsh/mlvirsh.ml:700 +msgid "help: %s: command not found" +msgstr "help: %s: nie znaleziono polecenia" + +#: ../mlvirsh/mlvirsh.ml:188 ../mlvirsh/mlvirsh.ml:182 ../mlvirsh/mlvirsh.ml:177 ../mlvirsh/mlvirsh.ml:172 ../mlvirsh/mlvirsh.ml:168 ../mlvirsh/mlvirsh.ml:164 ../mlvirsh/mlvirsh.ml:160 +msgid "incorrect number of arguments for function" +msgstr "niepoprawna liczba argumentów dla funkcji" + +#: ../mlvirsh/mlvirsh.ml:339 +msgid "max_mem: %Ld K\\n" +msgstr "max_mem: %Ld K\\n" + +#: ../mlvirsh/mlvirsh.ml:340 ../mlvirsh/mlvirsh.ml:325 +msgid "memory: %Ld K\\n" +msgstr "pamięć: %Ld K\\n" + +#: ../mlvirsh/mlvirsh.ml:327 +msgid "mhz: %d\\n" +msgstr "MHz: %d\\n" + +#: ../mlvirsh/mlvirsh.ml:727 +msgid "mlvirsh" +msgstr "mlvirsh" + +#: ../mlvirsh/mlvirsh.ml:725 +msgid "mlvirsh(no connection)" +msgstr "mlvirsh (brak połączenia)" + +#: ../mlvirsh/mlvirsh.ml:726 +msgid "mlvirsh(ro)" +msgstr "mlvirsh (tylko do odczytu)" + +#: ../mlvirsh/mlvirsh.ml:324 +msgid "model: %s\\n" +msgstr "model: %s\\n" + +#: ../mlvirsh/mlvirsh.ml:253 +msgid "network %s: not found. Additional info: %s" +msgstr "sieć %s: nie znaleziono. Dodatkowe informacje: %s" + +#: ../mlvirsh/mlvirsh.ml:328 +msgid "nodes: %d\\n" +msgstr "węzły: %d\\n" + +#: ../mlvirsh/mlvirsh.ml:202 ../mlvirsh/mlvirsh.ml:197 +msgid "not connected to the hypervisor" +msgstr "nie połączono z nadzorcą" + +#: ../mlvirsh/mlvirsh.ml:341 +msgid "nr_virt_cpu: %d\\n" +msgstr "nr_virt_cpu: %d\\n" + +#: ../mlvirsh/mlvirsh.ml:296 +msgid "offline" +msgstr "offline" + +#: ../virt-df/virt_df_ext2.ml:42 +msgid "partition marked EXT2/3 but no valid filesystem" +msgstr "partycja jest oznaczona jako ext2/3, ale nie jest prawidłowym system plików" + +#: ../mlvirsh/mlvirsh.ml:290 ../virt-ctrl/vc_helpers.ml:55 +msgid "paused" +msgstr "wstrzymano" + +#: ../virt-df/virt_df.ml:188 +msgid "probe_extended_partition: internal error" +msgstr "probe_extended_partition: wewnętrzny błąd" + +#: ../mlvirsh/mlvirsh.ml:376 +msgid "read bytes: %Ld\\n" +msgstr "odczytaj bajty: %Ld\\n" + +#: ../mlvirsh/mlvirsh.ml:375 +msgid "read requests: %Ld\\n" +msgstr "odczytaj żądania: %Ld\\n" + +#: ../mlvirsh/mlvirsh.ml:297 ../mlvirsh/mlvirsh.ml:288 ../virt-ctrl/vc_helpers.ml:53 +msgid "running" +msgstr "uruchomione" + +#: ../mlvirsh/mlvirsh.ml:384 +msgid "rx bytes: %Ld\\n" +msgstr "bajty RX: %Ld\\n" + +#: ../mlvirsh/mlvirsh.ml:387 +msgid "rx dropped: %Ld\\n" +msgstr "opuszczono RX: %Ld\\n" + +#: ../mlvirsh/mlvirsh.ml:386 +msgid "rx errs: %Ld\\n" +msgstr "błędy RX: %Ld\\n" + +#: ../mlvirsh/mlvirsh.ml:385 +msgid "rx packets: %Ld\\n" +msgstr "pakiety RX: %Ld\\n" + +#: ../mlvirsh/mlvirsh.ml:226 +msgid "setting should be '%s' or '%s'" +msgstr "ustawienie powinno być \"%s\" lub \"%s\"" + +#: ../mlvirsh/mlvirsh.ml:291 ../virt-ctrl/vc_helpers.ml:56 +msgid "shutdown" +msgstr "wyłącz" + +#: ../mlvirsh/mlvirsh.ml:292 ../virt-ctrl/vc_helpers.ml:57 +msgid "shutoff" +msgstr "wyłącz" + +#: ../mlvirsh/mlvirsh.ml:329 +msgid "sockets: %d\\n" +msgstr "gniazda: %d\\n" + +#: ../mlvirsh/mlvirsh.ml:338 +msgid "state: %s\\n" +msgstr "stan: %s\\n" + +#: ../mlvirsh/mlvirsh.ml:331 +msgid "threads: %d\\n" +msgstr "wątki: %d\\n" + +#: ../mlvirsh/mlvirsh.ml:198 +msgid "tried to do read-write operation on read-only hypervisor connection" +msgstr "spróbowano wykonać operację odczytu/zapisu na połączeniu nadzorcy tylko do odczytu" + +#: ../mlvirsh/mlvirsh.ml:388 +msgid "tx bytes: %Ld\\n" +msgstr "bajty TX: %Ld\\n" + +#: ../mlvirsh/mlvirsh.ml:391 +msgid "tx dropped: %Ld\\n" +msgstr "opuszczono TX: %Ld\\n" + +#: ../mlvirsh/mlvirsh.ml:390 +msgid "tx errs: %Ld\\n" +msgstr "błędy TX: %Ld\\n" + +#: ../mlvirsh/mlvirsh.ml:389 +msgid "tx packets: %Ld\\n" +msgstr "pakiety TX: %Ld\\n" + +#: ../mlvirsh/mlvirsh.ml:287 ../virt-ctrl/vc_helpers.ml:52 +msgid "unknown" +msgstr "nieznane" + +#: ../virt-df/virt_df.ml:246 +msgid "unsupported partition type %02x" +msgstr "nieobsługiwany typ partycji %02x" + +#: ../virt-df/virt_df.ml:363 +msgid "virt-df : like 'df', shows disk space used in guests\n\nSUMMARY\n virt-df [-options]\n\nOPTIONS" +msgstr "virt-df: podobne do \"df\", pokazuje użytą przestrzeń na dysku w gościach\n\nPODSUMOWANIE\n virt-df [-opcje]\n\nOPCJE" + +#: ../virt-top/virt_top.ml:1543 +msgid "virt-top %s (libvirt %d.%d.%d) by Red Hat" +msgstr "virt-top %s (libvirt %d.%d.%d) od Red Hata" + +#: ../virt-top/virt_top.ml:203 +msgid "virt-top : a 'top'-like utility for virtualization\n\nSUMMARY\n virt-top [-options]\n\nOPTIONS" +msgstr "virt-top: narzędzie podobne do \"top\" dla wirtualizacji\n\nPODSUMOWANIE\n virt-top [-opcje]\n\nOPCJE" + +#: ../virt-top/virt_top.ml:40 +msgid "virt-top was compiled without support for CSV files" +msgstr "virt-top został skompilowany bez obsługi plików CSV" + +#: ../virt-top/virt_top.ml:51 +msgid "virt-top was compiled without support for dates and times" +msgstr "virt-top został skompilowany bez obsługi dat i czasu" + +#: ../mlvirsh/mlvirsh.ml:360 +msgid "virtual CPU: %d\\n" +msgstr "wirtualny procesor: %d\\n" + +#: ../virt-ctrl/vc_dbus.ml:219 +msgid "warning: ignored unknown message %s from %s\\n%!" +msgstr "ostrzeżenie: zignorowano nieznany komunikat %s z %s\\n%!" + +#: ../virt-ctrl/vc_dbus.ml:124 +msgid "warning: unexpected message contents of Found signal" +msgstr "ostrzeżenie: nieoczekiwana zawartość komunikatu sygnału \"Found\"" + +#: ../virt-ctrl/vc_dbus.ml:188 +msgid "warning: unexpected message contents of ItemNew signal" +msgstr "ostrzeżenie: nieoczekiwana zawartość komunikatu sygnału \"ItemNew\"" + +#: ../virt-ctrl/vc_dbus.ml:140 +msgid "warning: unexpected message contents of ItemRemove signal" +msgstr "ostrzeżenie: nieoczekiwana zawartość komunikatu sygnału \"ItemRemove\"" + +#: ../mlvirsh/mlvirsh.ml:378 +msgid "write bytes: %Ld\\n" +msgstr "bajty zapisu: %Ld\\n" + +#: ../mlvirsh/mlvirsh.ml:377 +msgid "write requests: %Ld\\n" +msgstr "żądania zapisu: %Ld\\n" -- cgit v1.1 From 748302caa93af2c412bcd30dad5787a5a24e9af5 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Tue, 15 Apr 2008 11:00:29 +0100 Subject: Move main code to virt_df_main.ml and provide explicit interface virt_df.mli --- virt-df/.depend | 20 +-- virt-df/virt_df.ml | 466 +----------------------------------------------- virt-df/virt_df.mli | 181 +++++++++++++++++++ virt-df/virt_df_main.ml | 381 ++++++++++++++++++++++++++++++++++++++- 4 files changed, 575 insertions(+), 473 deletions(-) create mode 100644 virt-df/virt_df.mli diff --git a/virt-df/.depend b/virt-df/.depend index 5aa8cb7..aad2cf0 100644 --- a/virt-df/.depend +++ b/virt-df/.depend @@ -1,20 +1,20 @@ -virt_df_ext2.cmo: virt_df_gettext.cmo virt_df.cmo \ +virt_df_ext2.cmo: virt_df_gettext.cmo virt_df.cmi \ /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_ext2.cmx: virt_df_gettext.cmx virt_df.cmx \ /usr/lib64/ocaml/bitmatch/bitmatch.cmi -virt_df_linux_swap.cmo: virt_df_gettext.cmo virt_df.cmo \ +virt_df_linux_swap.cmo: virt_df_gettext.cmo virt_df.cmi \ /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_linux_swap.cmx: virt_df_gettext.cmx virt_df.cmx \ /usr/lib64/ocaml/bitmatch/bitmatch.cmi -virt_df_lvm2.cmo: virt_df_gettext.cmo virt_df.cmo +virt_df_lvm2.cmo: virt_df_gettext.cmo virt_df.cmi virt_df_lvm2.cmx: virt_df_gettext.cmx virt_df.cmx -virt_df_main.cmo: virt_df.cmo -virt_df_main.cmx: virt_df.cmx -virt_df_mbr.cmo: virt_df_gettext.cmo virt_df.cmo \ +virt_df_main.cmo: virt_df_gettext.cmo virt_df.cmi \ + ../libvirt/libvirt_version.cmi ../libvirt/libvirt.cmi +virt_df_main.cmx: virt_df_gettext.cmx virt_df.cmx \ + ../libvirt/libvirt_version.cmx ../libvirt/libvirt.cmx +virt_df_mbr.cmo: virt_df_gettext.cmo virt_df.cmi \ /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_mbr.cmx: virt_df_gettext.cmx virt_df.cmx \ /usr/lib64/ocaml/bitmatch/bitmatch.cmi -virt_df.cmo: virt_df_gettext.cmo ../libvirt/libvirt_version.cmi \ - ../libvirt/libvirt.cmi -virt_df.cmx: virt_df_gettext.cmx ../libvirt/libvirt_version.cmx \ - ../libvirt/libvirt.cmx +virt_df.cmo: virt_df_gettext.cmo virt_df.cmi +virt_df.cmx: virt_df_gettext.cmx virt_df.cmi diff --git a/virt-df/virt_df.ml b/virt-df/virt_df.ml index b972837..c61f6df 100644 --- a/virt-df/virt_df.ml +++ b/virt-df/virt_df.ml @@ -23,79 +23,24 @@ open Unix open Virt_df_gettext.Gettext -module C = Libvirt.Connect -module D = Libvirt.Domain +let debug = true (* If true emit lots of debugging information. *) -(* If set to true, then emit lots of debugging information. *) -let debug = true - -(* Int32 infix operators for convenience. *) let ( +* ) = Int32.add let ( -* ) = Int32.sub let ( ** ) = Int32.mul let ( /* ) = Int32.div -(* Int64 infix operators for convenience. *) let ( +^ ) = Int64.add let ( -^ ) = Int64.sub let ( *^ ) = Int64.mul let ( /^ ) = Int64.div -(* State of command line arguments. *) -let uri = ref None (* Hypervisor/libvirt URI. *) -let inodes = ref false (* Display inodes. *) -let human = ref false (* Display human-readable. *) -let all = ref false (* Show all/active domains. *) -let test_files = ref [] (* Used for test mode only. *) - -(*----------------------------------------------------------------------*) -(* The "domain/device model" that we currently understand looks - * like this: - * - * domains - * | - * \--- host partitions / disk image files - * || - * guest block devices - * | - * +--> guest partitions (eg. using MBR) - * | | - * \-(1)->+--- filesystems (eg. ext3) - * | - * \--- PVs for LVM - * ||| - * VGs and LVs - * - * (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. LVM) 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. - *) +let uri = ref None +let inodes = ref false +let human = ref false +let all = ref false +let test_files = ref [] -(* 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 virtual device = object (self) method virtual read : int64 -> int -> string @@ -123,7 +68,7 @@ object (self) method name = filename end -(* A null device. Any attempt to read generates an error. *) +(* The null device. Any attempt to read generates an error. *) let null_device : device = object inherit device @@ -132,8 +77,6 @@ object method name = "null" end -(* Domains and candidate guest block devices. *) - type domain = { dom_name : string; (* Domain name. *) dom_id : int option; (* Domain ID (if running). *) @@ -262,398 +205,3 @@ let lvm_types = ref [] let lvm_type_register (lvm_name : string) probe_fn = lvm_types := (lvm_name, probe_fn) :: !lvm_types *) - -(*----------------------------------------------------------------------*) - -let main () = - (* 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)"; - "-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 ") 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 node in XML") - | Xml.Element ("name", _, [Xml.PCData name]) :: _ -> name - | Xml.Element ("name", _, _) :: _ -> - failwith (s_ "get_xml_desc returned strange 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 } - ) 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; - } - ] - } - ) !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_filesystems dev in - match fs with - | Some fs -> - { disk with d_content = `Filesystem fs } - | None -> - (* Not partitioned, no filesystem, so it's spare. *) - disk - ) 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_filesystems p.part_dev in - match fs with - | Some fs -> - { p with part_content = `Filesystem fs } - | None -> - p - ) else p - ) parts.parts in - let parts = { parts with parts = ps } in - { disk with d_content = `Partitions parts } - | disk -> disk - ) in - - (* XXX LVM stuff here. *) - - - - (* 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 = - List.iter ( - fun ({ dom_disks = disks } as dom) -> - List.iter ( - function - | ({ d_content = `Filesystem fs } as disk) -> - f dom disk None fs - | ({ d_content = `Partitions partitions } as disk) -> - List.iteri ( - fun i -> - function - | ({ part_content = `Filesystem fs } as part) -> - f dom disk (Some (part, i)) fs - | _ -> () - ) partitions.parts - | _ -> () - ) disks - ) doms - in - - (* Print stats for each recognized filesystem. *) - let print_stats dom disk part fs = - (* Printable name is like "domain:hda" or "domain:hda1". *) - let name = - let dom_name = dom.dom_name in - let d_target = disk.d_target in - match part with - | None -> - dom_name ^ ":" ^ d_target - | Some (_, pnum) -> - dom_name ^ ":" ^ d_target ^ string_of_int pnum 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 - -(* -(* Probe a single partition, which we assume contains either a - * filesystem or is a PV. - * - target will be something like "hda" or "hda1" - * - part_type will be the partition type if known, or None - * - fd is a file descriptor opened on the device - * - start & size are where we think the start and size of the - * partition is within the file descriptor (in SECTORS) - *) -and probe_partition target part_type fd start size = - match part_type with - | None -> - ProbeFailed (s_ "detection of unpartitioned devices not yet supported") - | Some 0x05 -> - ProbeIgnore (* Extended partition - ignore it. *) - | Some part_type -> - try - let probe_fn = Hashtbl.find filesystems part_type in - probe_fn target part_type fd start size - with - Not_found -> - ProbeFailed - (sprintf (f_ "unsupported partition type %02x") part_type) -*) diff --git a/virt-df/virt_df.mli b/virt-df/virt_df.mli new file mode 100644 index 0000000..1b3f6ca --- /dev/null +++ b/virt-df/virt_df.mli @@ -0,0 +1,181 @@ +(** '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 debug : bool +(** If true, emit logs of debugging information to stderr. *) + +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 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. LVM) 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. *) + +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. *) +} +and disk = { + d_type : string option; (** The *) + d_device : string; (** The (eg "disk") *) + d_source : string; (** The *) + d_target : string; (** The (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 unit (** 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 unit (** 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. *) +} + +val string_of_partition : partition -> string +val string_of_filesystem : filesystem -> string +(** Convert a partition or filesystem struct to a string (for debugging). *) + +val partition_type_register : string -> (device -> partitions) -> unit +(** Register a partition probing plugin. *) + +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 plugin. *) + +val probe_for_filesystems : device -> filesystem option +(** Do a filesystem probe on a device. Returns [Some filesystem] or [None]. *) diff --git a/virt-df/virt_df_main.ml b/virt-df/virt_df_main.ml index 1359b28..9504785 100644 --- a/virt-df/virt_df_main.ml +++ b/virt-df/virt_df_main.ml @@ -17,7 +17,380 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) -(* We just need this so that the filesystem modules get a chance to - * register themselves before we run the main program. - *) -let () = Virt_df.main () +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)"; + "-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 ") 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 node in XML") + | Xml.Element ("name", _, [Xml.PCData name]) :: _ -> name + | Xml.Element ("name", _, _) :: _ -> + failwith (s_ "get_xml_desc returned strange 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 } + ) 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; + } + ] + } + ) !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_filesystems dev in + match fs with + | Some fs -> + { disk with d_content = `Filesystem fs } + | None -> + (* Not partitioned, no filesystem, so it's spare. *) + disk + ) 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_filesystems p.part_dev in + match fs with + | Some fs -> + { p with part_content = `Filesystem fs } + | None -> + p + ) else p + ) parts.parts in + let parts = { parts with parts = ps } in + { disk with d_content = `Partitions parts } + | disk -> disk + ) in + + (* XXX LVM stuff here. *) + + + + (* 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 = + List.iter ( + fun ({ dom_disks = disks } as dom) -> + List.iter ( + function + | ({ d_content = `Filesystem fs } as disk) -> + f dom disk None fs + | ({ d_content = `Partitions partitions } as disk) -> + List.iteri ( + fun i -> + function + | ({ part_content = `Filesystem fs } as part) -> + f dom disk (Some (part, i)) fs + | _ -> () + ) partitions.parts + | _ -> () + ) disks + ) doms + in + + (* Print stats for each recognized filesystem. *) + let print_stats dom disk part fs = + (* Printable name is like "domain:hda" or "domain:hda1". *) + let name = + let dom_name = dom.dom_name in + let d_target = disk.d_target in + match part with + | None -> + dom_name ^ ":" ^ d_target + | Some (_, pnum) -> + dom_name ^ ":" ^ d_target ^ string_of_int pnum 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 -- cgit v1.1 From 0019c13c600d34f12778e849246711bb20ba4ee2 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Tue, 15 Apr 2008 11:26:46 +0100 Subject: Don't need the ': device' typecasts any more. --- virt-df/virt_df_ext2.ml | 2 +- virt-df/virt_df_linux_swap.ml | 2 +- virt-df/virt_df_lvm2.ml | 30 +++++++++++++++++++++++++++--- virt-df/virt_df_mbr.ml | 2 +- 4 files changed, 30 insertions(+), 6 deletions(-) diff --git a/virt-df/virt_df_ext2.ml b/virt-df/virt_df_ext2.ml index 0ea8a25..2d1d1b8 100644 --- a/virt-df/virt_df_ext2.ml +++ b/virt-df/virt_df_ext2.ml @@ -27,7 +27,7 @@ open Virt_df let superblock_offset = 1024L -let probe_ext2 (dev : device) = +let probe_ext2 dev = (* Load the superblock. *) let bits = dev#read_bitstring superblock_offset 1024 in diff --git a/virt-df/virt_df_linux_swap.ml b/virt-df/virt_df_linux_swap.ml index ad56149..afd671f 100644 --- a/virt-df/virt_df_linux_swap.ml +++ b/virt-df/virt_df_linux_swap.ml @@ -23,7 +23,7 @@ open Virt_df_gettext.Gettext open Virt_df -let probe_swap (dev : device) = +let probe_swap dev = (* Load the "superblock" (ie. first 0x1000 bytes). *) let bits = dev#read_bitstring 0L 0x1000 in diff --git a/virt-df/virt_df_lvm2.ml b/virt-df/virt_df_lvm2.ml index a79ec7f..4247dc3 100644 --- a/virt-df/virt_df_lvm2.ml +++ b/virt-df/virt_df_lvm2.ml @@ -24,9 +24,33 @@ open Printf open Virt_df_gettext.Gettext open Virt_df -let probe_lvm2 (dev : device) = - raise Not_found +let sector_size = 512 +let sector_size64 = 512L + +let pv_label_offset = sector_size64 + +let rec probe_pv dev = + try ignore (read_pv_label dev); true + with _ -> false + +and read_pv_label dev = + (* Load the second sector. *) + let bits = dev#read_bitstring pv_label_offset sector_size in + + bitmatch bits with + | labelone : 8*8 : bitstring; (* "LABELONE" *) + padding : 16*8 : bitstring; + lvm2_ver : 8*8 : bitstring; (* "LVM2 001" *) + uuid : 32*8 : bitstring (* UUID *) + when Bitmatch.string_of_bitstring labelone = "LABELONE" && + Bitmatch.string_of_bitstring lvm2_ver = "LVM2 001" -> + uuid + | _ -> + invalid_arg (sprintf "read_pv_label: %s: not an LVM2 physical volume" + dev#name) + +let list_lvs devs = [] (* Register with main code. *) let () = - filesystem_type_register "LVM2" probe_lvm2 + lvm_type_register "LVM2" probe_pv list_lvs diff --git a/virt-df/virt_df_mbr.ml b/virt-df/virt_df_mbr.ml index b9a6cb7..b56189c 100644 --- a/virt-df/virt_df_mbr.ml +++ b/virt-df/virt_df_mbr.ml @@ -66,7 +66,7 @@ end @raise Not_found if it is not an MBR. *) -let rec probe_mbr (dev : device) = +let rec probe_mbr dev = (* Adjust size to sectors. *) let size = dev#size /^ sector_size64 in -- cgit v1.1 From 40c683ea4c9d921a6fe23c2639125261b92da472 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Tue, 15 Apr 2008 11:44:41 +0100 Subject: Add PV detection framework. --- virt-df/virt_df.ml | 31 +++++++++++++++++++++++-------- virt-df/virt_df.mli | 26 +++++++++++++++++++------- virt-df/virt_df_main.ml | 25 +++++++++++++++++++------ 3 files changed, 61 insertions(+), 21 deletions(-) diff --git a/virt-df/virt_df.ml b/virt-df/virt_df.ml index c61f6df..b992e1b 100644 --- a/virt-df/virt_df.ml +++ b/virt-df/virt_df.ml @@ -97,7 +97,7 @@ and disk_content = [ `Unknown (* Not probed or unknown. *) | `Partitions of partitions (* Contains partitions. *) | `Filesystem of filesystem (* Contains a filesystem directly. *) - | `PhysicalVolume of unit (* Contains an LVM PV. *) + | `PhysicalVolume of string (* Contains an LVM PV. *) ] (* Partitions. *) @@ -116,7 +116,7 @@ and partition_status = Bootable | Nonbootable | Malformed | NullEntry and partition_content = [ `Unknown (* Not probed or unknown. *) | `Filesystem of filesystem (* Filesystem. *) - | `PhysicalVolume of unit (* Contains an LVM PV. *) + | `PhysicalVolume of string (* Contains an LVM PV. *) ] (* Filesystems (also swap devices). *) @@ -180,8 +180,8 @@ 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 filesystems. Returns [Some fs] or [None]. *) -let probe_for_filesystems dev = +(* 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 @@ -200,8 +200,23 @@ let probe_for_filesystems dev = r (* Register a volume management type. *) -(* let lvm_types = ref [] -let lvm_type_register (lvm_name : string) probe_fn = - lvm_types := (lvm_name, probe_fn) :: !lvm_types -*) +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 -> + if probe_fn dev then Some lvm_name else 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_name -> + eprintf "%s contains a %s PV\n%!" dev#name lvm_name + ); + r diff --git a/virt-df/virt_df.mli b/virt-df/virt_df.mli index 1b3f6ca..db98af2 100644 --- a/virt-df/virt_df.mli +++ b/virt-df/virt_df.mli @@ -17,9 +17,9 @@ 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. - *) +(** This module (Virt_df) contains functions and values which are + used throughout the plug-ins and main code. +*) val debug : bool (** If true, emit logs of debugging information to stderr. *) @@ -71,7 +71,7 @@ v} of the physical devices, partitions and filesystems potentially available to the guest. - Volume management schemes (eg. LVM) register themselves here + 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. @@ -131,7 +131,7 @@ and disk = { and disk_content = [ `Filesystem of filesystem (** Contains a direct filesystem. *) | `Partitions of partitions (** Contains partitions. *) - | `PhysicalVolume of unit (** Contains an LVM PV. *) + | `PhysicalVolume of string (** Contains an LVM PV. *) | `Unknown (** Not probed or unknown. *) ] and partitions = { @@ -147,7 +147,7 @@ and partition = { and partition_status = Bootable | Nonbootable | Malformed | NullEntry and partition_content = [ `Filesystem of filesystem (** Filesystem. *) - | `PhysicalVolume of unit (** Contains an LVM PV. *) + | `PhysicalVolume of string (** Contains an LVM PV. *) | `Unknown (** Not probed or unknown. *) ] and filesystem = { @@ -177,5 +177,17 @@ val probe_for_partitions : device -> partitions option val filesystem_type_register : string -> (device -> filesystem) -> unit (** Register a filesystem probing plugin. *) -val probe_for_filesystems : device -> filesystem option +val probe_for_filesystem : device -> filesystem option (** Do a filesystem probe on a device. Returns [Some filesystem] or [None]. *) + +val lvm_type_register : + string -> (device -> bool) -> (device list -> device 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 -> string option +(** Do a PV probe on a device. Returns [Some lvm_name] or [None]. *) diff --git a/virt-df/virt_df_main.ml b/virt-df/virt_df_main.ml index 9504785..c989d76 100644 --- a/virt-df/virt_df_main.ml +++ b/virt-df/virt_df_main.ml @@ -268,13 +268,18 @@ OPTIONS" in { disk with d_content = `Partitions parts } | None -> (* Not partitioned. Does it contain a filesystem? *) - let fs = probe_for_filesystems dev in + let fs = probe_for_filesystem dev in match fs with | Some fs -> { disk with d_content = `Filesystem fs } | None -> - (* Not partitioned, no filesystem, so it's spare. *) - disk + (* 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 @@ -287,12 +292,18 @@ OPTIONS" in let ps = List.map ( fun p -> if p.part_status = Bootable || p.part_status = Nonbootable then ( - let fs = probe_for_filesystems p.part_dev in + let fs = probe_for_filesystem p.part_dev in match fs with | Some fs -> { p with part_content = `Filesystem fs } | None -> - p + (* 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 @@ -300,7 +311,9 @@ OPTIONS" in | disk -> disk ) in - (* XXX LVM stuff here. *) + (* XXX LVM filesystem detection ... *) + + -- cgit v1.1 From bb0788a39d9b8675db60a61ecd2baebfdfb5ca10 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Tue, 15 Apr 2008 11:44:54 +0100 Subject: LVM2 PV detection. --- virt-df/virt_df_lvm2.ml | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/virt-df/virt_df_lvm2.ml b/virt-df/virt_df_lvm2.ml index 4247dc3..9355597 100644 --- a/virt-df/virt_df_lvm2.ml +++ b/virt-df/virt_df_lvm2.ml @@ -29,6 +29,7 @@ let sector_size64 = 512L let pv_label_offset = sector_size64 +(* Probe to see if it's an LVM2 PV. Look for the "LABELONE" label. *) let rec probe_pv dev = try ignore (read_pv_label dev); true with _ -> false @@ -37,6 +38,8 @@ and read_pv_label dev = (* Load the second sector. *) let bits = dev#read_bitstring pv_label_offset sector_size in + Bitmatch.hexdump_bitstring stdout bits; + bitmatch bits with | labelone : 8*8 : bitstring; (* "LABELONE" *) padding : 16*8 : bitstring; @@ -49,6 +52,11 @@ and read_pv_label dev = invalid_arg (sprintf "read_pv_label: %s: not an LVM2 physical volume" dev#name) +(* 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 list_lvs devs = [] (* Register with main code. *) -- cgit v1.1 From 0c2134a62abc82f2b558e648cdaea22b098d4bc9 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Tue, 15 Apr 2008 11:44:59 +0100 Subject: Update deps. --- virt-df/.depend | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/virt-df/.depend b/virt-df/.depend index aad2cf0..9bf7fd7 100644 --- a/virt-df/.depend +++ b/virt-df/.depend @@ -6,8 +6,10 @@ virt_df_linux_swap.cmo: virt_df_gettext.cmo virt_df.cmi \ /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_linux_swap.cmx: virt_df_gettext.cmx virt_df.cmx \ /usr/lib64/ocaml/bitmatch/bitmatch.cmi -virt_df_lvm2.cmo: virt_df_gettext.cmo virt_df.cmi -virt_df_lvm2.cmx: virt_df_gettext.cmx virt_df.cmx +virt_df_lvm2.cmo: virt_df_gettext.cmo virt_df.cmi \ + /usr/lib64/ocaml/bitmatch/bitmatch.cmi +virt_df_lvm2.cmx: virt_df_gettext.cmx virt_df.cmx \ + /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_main.cmo: virt_df_gettext.cmo virt_df.cmi \ ../libvirt/libvirt_version.cmi ../libvirt/libvirt.cmi virt_df_main.cmx: virt_df_gettext.cmx virt_df.cmx \ -- cgit v1.1 From be71668a1a4b6c87da3e82458ca97a199a24aa32 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Tue, 15 Apr 2008 12:57:58 +0100 Subject: Infrastructure to detect filesystems on LVs. --- virt-df/virt_df.ml | 24 +++++++++++++ virt-df/virt_df.mli | 17 +++++++-- virt-df/virt_df_main.ml | 96 ++++++++++++++++++++++++++++++++++++++++--------- 3 files changed, 119 insertions(+), 18 deletions(-) diff --git a/virt-df/virt_df.ml b/virt-df/virt_df.ml index b992e1b..1cd0617 100644 --- a/virt-df/virt_df.ml +++ b/virt-df/virt_df.ml @@ -81,6 +81,7 @@ type domain = { dom_name : string; (* Domain name. *) dom_id : int option; (* Domain ID (if running). *) dom_disks : disk list; (* Domain disks. *) + dom_lv_filesystems : filesystem list; (* Domain LV filesystems. *) } and disk = { (* From the XML ... *) @@ -220,3 +221,26 @@ let probe_for_pv dev = eprintf "%s contains a %s PV\n%!" dev#name lvm_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' diff --git a/virt-df/virt_df.mli b/virt-df/virt_df.mli index db98af2..4a9368c 100644 --- a/virt-df/virt_df.mli +++ b/virt-df/virt_df.mli @@ -119,6 +119,7 @@ type domain = { dom_name : string; (** Domain name. *) dom_id : int option; (** Domain ID (if running). *) dom_disks : disk list; (** Domain disks. *) + dom_lv_filesystems : filesystem list; (** Domain LV filesystems. *) } and disk = { d_type : string option; (** The *) @@ -168,14 +169,16 @@ val string_of_partition : partition -> string val string_of_filesystem : filesystem -> string (** Convert a partition or filesystem struct to a string (for debugging). *) +(** {2 Plug-in registration functions} *) + val partition_type_register : string -> (device -> partitions) -> unit -(** Register a partition probing plugin. *) +(** 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 plugin. *) +(** 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]. *) @@ -191,3 +194,13 @@ val lvm_type_register : val probe_for_pv : device -> string option (** Do a PV probe on a device. Returns [Some lvm_name] or [None]. *) + +val list_lvs : string -> device list -> device list +(** Construct LV devices from a list of PVs. The first argument + is the [lvm_name] which all PVs should belong to. +*) + +(** {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. *) diff --git a/virt-df/virt_df_main.ml b/virt-df/virt_df_main.ml index c989d76..82fe920 100644 --- a/virt-df/virt_df_main.ml +++ b/virt-df/virt_df_main.ml @@ -223,7 +223,8 @@ OPTIONS" in | _ -> None ) devices in - { dom_name = name; dom_id = domid; dom_disks = disks } + { 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 @@ -241,7 +242,8 @@ OPTIONS" in d_source = filename; d_target = "hda"; d_dev = new block_device filename; d_content = `Unknown; } - ] + ]; + dom_lv_filesystems = [] } ) !test_files ) in @@ -311,13 +313,66 @@ OPTIONS" in | disk -> disk ) in - (* XXX LVM filesystem detection ... *) - - - + (* 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). + *) + (* 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 lvm_name } -> Some (lvm_name, 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 lvm_name } -> + Some (lvm_name, 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:string),_) ((b:string),_) = compare a b in + let lvs = List.sort ~cmp lvs in + let lvs = group_by lvs in + + let lvs = + List.map (fun (lvm_name, devs) -> list_lvs lvm_name 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 probe_for_filesystem lvs in + { dom with dom_lv_filesystems = filesystems } + ) doms in - (* Print the title. *) + (* Now print the results. + * + * Print the title. + *) let () = let total, used, avail = match !inodes, !human with @@ -337,37 +392,46 @@ OPTIONS" in in (* HOF to iterate over filesystems. *) - let iter_over_filesystems doms f = + let iter_over_filesystems doms + (f : domain -> ?disk:disk -> ?part:(partition * int) -> filesystem -> + unit) = List.iter ( - fun ({ dom_disks = disks } as dom) -> + fun ({ dom_disks = disks; dom_lv_filesystems = filesystems } as dom) -> + (* Ordinary filesystems found on disks & partitions. *) List.iter ( function | ({ d_content = `Filesystem fs } as disk) -> - f dom disk None fs + f dom ~disk fs | ({ d_content = `Partitions partitions } as disk) -> List.iteri ( fun i -> function | ({ part_content = `Filesystem fs } as part) -> - f dom disk (Some (part, i)) fs + f dom ~disk ~part:(part, i) fs | _ -> () ) partitions.parts | _ -> () - ) disks + ) disks; + (* LV filesystems. *) + List.iter (fun fs -> f dom fs) filesystems ) doms in (* Print stats for each recognized filesystem. *) - let print_stats dom disk part fs = + let print_stats dom ?disk ?part fs = (* Printable name is like "domain:hda" or "domain:hda1". *) let name = let dom_name = dom.dom_name in - let d_target = disk.d_target in + let disk_name = + match disk with + | None -> "???" (* XXX keep LV dev around *) + | Some disk -> disk.d_target + in match part with | None -> - dom_name ^ ":" ^ d_target + dom_name ^ ":" ^ disk_name | Some (_, pnum) -> - dom_name ^ ":" ^ d_target ^ string_of_int pnum in + dom_name ^ ":" ^ disk_name ^ string_of_int pnum in printf "%-20s " name; if fs.fs_is_swap then ( -- cgit v1.1 From 2f24ddc7c65beb0df82f208bf7410ea09102f7a8 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Tue, 15 Apr 2008 13:51:57 +0100 Subject: Refactor the types so we have distinct PV & LV types. --- virt-df/virt_df.ml | 24 +++++++++++++++++++----- virt-df/virt_df.mli | 26 +++++++++++++++++--------- virt-df/virt_df_lvm2.ml | 16 ++++++++++------ virt-df/virt_df_main.ml | 16 ++++++++++------ 4 files changed, 56 insertions(+), 26 deletions(-) diff --git a/virt-df/virt_df.ml b/virt-df/virt_df.ml index 1cd0617..f8f34ab 100644 --- a/virt-df/virt_df.ml +++ b/virt-df/virt_df.ml @@ -98,7 +98,7 @@ and disk_content = [ `Unknown (* Not probed or unknown. *) | `Partitions of partitions (* Contains partitions. *) | `Filesystem of filesystem (* Contains a filesystem directly. *) - | `PhysicalVolume of string (* Contains an LVM PV. *) + | `PhysicalVolume of pv (* Contains an LVM PV. *) ] (* Partitions. *) @@ -117,7 +117,7 @@ and partition_status = Bootable | Nonbootable | Malformed | NullEntry and partition_content = [ `Unknown (* Not probed or unknown. *) | `Filesystem of filesystem (* Filesystem. *) - | `PhysicalVolume of string (* Contains an LVM PV. *) + | `PhysicalVolume of pv (* Contains an LVM PV. *) ] (* Filesystems (also swap devices). *) @@ -135,6 +135,19 @@ and filesystem = { 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 } = @@ -211,14 +224,15 @@ let probe_for_pv dev = let rec loop = function | [] -> None | (lvm_name, (probe_fn, _)) :: rest -> - if probe_fn dev then Some lvm_name else loop 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_name -> - eprintf "%s contains a %s PV\n%!" dev#name lvm_name + | Some { lvm_plugin_id = name } -> + eprintf "%s contains a %s PV\n%!" dev#name name ); r diff --git a/virt-df/virt_df.mli b/virt-df/virt_df.mli index 4a9368c..b36d003 100644 --- a/virt-df/virt_df.mli +++ b/virt-df/virt_df.mli @@ -132,7 +132,7 @@ and disk = { and disk_content = [ `Filesystem of filesystem (** Contains a direct filesystem. *) | `Partitions of partitions (** Contains partitions. *) - | `PhysicalVolume of string (** Contains an LVM PV. *) + | `PhysicalVolume of pv (** Contains an LVM PV. *) | `Unknown (** Not probed or unknown. *) ] and partitions = { @@ -148,7 +148,7 @@ and partition = { and partition_status = Bootable | Nonbootable | Malformed | NullEntry and partition_content = [ `Filesystem of filesystem (** Filesystem. *) - | `PhysicalVolume of string (** Contains an LVM PV. *) + | `PhysicalVolume of pv (** Contains an LVM PV. *) | `Unknown (** Not probed or unknown. *) ] and filesystem = { @@ -164,6 +164,16 @@ and filesystem = { 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 @@ -184,7 +194,7 @@ val probe_for_filesystem : device -> filesystem option (** Do a filesystem probe on a device. Returns [Some filesystem] or [None]. *) val lvm_type_register : - string -> (device -> bool) -> (device list -> device list) -> unit + 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. @@ -192,13 +202,11 @@ val lvm_type_register : devices (PVs) and construct a list of LV devices. *) -val probe_for_pv : device -> string option -(** Do a PV probe on a device. Returns [Some lvm_name] or [None]. *) +val probe_for_pv : device -> pv option +(** Do a PV probe on a device. Returns [Some pv] or [None]. *) -val list_lvs : string -> device list -> device list -(** Construct LV devices from a list of PVs. The first argument - is the [lvm_name] which all PVs should belong to. -*) +val list_lvs : lvm_plugin_id -> device list -> lv list +(** Construct LV devices from a list of PVs. *) (** {2 Utility functions} *) diff --git a/virt-df/virt_df_lvm2.ml b/virt-df/virt_df_lvm2.ml index 9355597..dc97656 100644 --- a/virt-df/virt_df_lvm2.ml +++ b/virt-df/virt_df_lvm2.ml @@ -24,21 +24,25 @@ open Printf open Virt_df_gettext.Gettext open Virt_df +let plugin_name = "LVM2" + let sector_size = 512 let sector_size64 = 512L let pv_label_offset = sector_size64 (* Probe to see if it's an LVM2 PV. Look for the "LABELONE" label. *) -let rec probe_pv dev = - try ignore (read_pv_label dev); true - with _ -> false +let rec probe_pv lvm_plugin_id dev = + try + let uuid = read_pv_label dev in + { lvm_plugin_id = lvm_plugin_id; pv_uuid = uuid } + with _ -> raise Not_found and read_pv_label dev = (* Load the second sector. *) let bits = dev#read_bitstring pv_label_offset sector_size in - Bitmatch.hexdump_bitstring stdout bits; + (*Bitmatch.hexdump_bitstring stdout bits;*) bitmatch bits with | labelone : 8*8 : bitstring; (* "LABELONE" *) @@ -47,7 +51,7 @@ and read_pv_label dev = uuid : 32*8 : bitstring (* UUID *) when Bitmatch.string_of_bitstring labelone = "LABELONE" && Bitmatch.string_of_bitstring lvm2_ver = "LVM2 001" -> - uuid + Bitmatch.string_of_bitstring uuid | _ -> invalid_arg (sprintf "read_pv_label: %s: not an LVM2 physical volume" dev#name) @@ -61,4 +65,4 @@ let list_lvs devs = [] (* Register with main code. *) let () = - lvm_type_register "LVM2" probe_pv list_lvs + lvm_type_register plugin_name probe_pv list_lvs diff --git a/virt-df/virt_df_main.ml b/virt-df/virt_df_main.ml index 82fe920..9cfde39 100644 --- a/virt-df/virt_df_main.ml +++ b/virt-df/virt_df_main.ml @@ -330,7 +330,7 @@ OPTIONS" in let pvs_on_disks = List.filter_map ( function | { d_dev = d_dev; - d_content = `PhysicalVolume lvm_name } -> Some (lvm_name, d_dev) + d_content = `PhysicalVolume pv } -> Some (pv, d_dev) | _ -> None ) disks in let pvs_on_partitions = List.map ( @@ -339,8 +339,8 @@ OPTIONS" in List.filter_map ( function | { part_dev = part_dev; - part_content = `PhysicalVolume lvm_name } -> - Some (lvm_name, part_dev) + part_content = `PhysicalVolume pv } -> + Some (pv, part_dev) | _ -> None ) parts | _ -> [] @@ -353,18 +353,22 @@ OPTIONS" in let doms = List.map ( fun (dom, lvs) -> (* Group the LVs by plug-in type. *) - let cmp ((a:string),_) ((b:string),_) = compare a b in + 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 (lvm_name, devs) -> list_lvs lvm_name devs) lvs in + 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 probe_for_filesystem lvs in + let filesystems = + List.filter_map ( + fun { lv_dev = dev } -> probe_for_filesystem dev + ) lvs in { dom with dom_lv_filesystems = filesystems } ) doms in -- cgit v1.1 From bf03017c3a390f75130d810bed403008abcbe7f4 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Tue, 15 Apr 2008 15:08:34 +0100 Subject: Read out metadata offset & length from PV header. --- virt-df/virt_df_lvm2.ml | 54 ++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 42 insertions(+), 12 deletions(-) diff --git a/virt-df/virt_df_lvm2.ml b/virt-df/virt_df_lvm2.ml index dc97656..abc247e 100644 --- a/virt-df/virt_df_lvm2.ml +++ b/virt-df/virt_df_lvm2.ml @@ -29,29 +29,58 @@ let plugin_name = "LVM2" let sector_size = 512 let sector_size64 = 512L -let pv_label_offset = sector_size64 - (* Probe to see if it's an LVM2 PV. Look for the "LABELONE" label. *) let rec probe_pv lvm_plugin_id dev = try - let uuid = read_pv_label dev in + let uuid, metadata_offset, metadata_length = read_pv_label dev in + if debug then + eprintf "LVM2 detected UUID %s md offset 0x%lx len %ld\n%!" + uuid metadata_offset metadata_length; { lvm_plugin_id = lvm_plugin_id; pv_uuid = uuid } with _ -> raise Not_found and read_pv_label dev = - (* Load the second sector. *) - let bits = dev#read_bitstring pv_label_offset sector_size in + (* 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.hexdump_bitstring stdout bits; bitmatch bits with - | labelone : 8*8 : bitstring; (* "LABELONE" *) - padding : 16*8 : bitstring; + | 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 *) + 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" -> - Bitmatch.string_of_bitstring uuid + Bitmatch.string_of_bitstring lvm2_ver = "LVM2 001" -> + let metadata_offset = metadata_offset +* 0x1000_l in + + (* Check the metadata offset & length look reasonable for this + * device. Otherwise maybe it's a newer or older header which + * we don't really understand properly. + *) + let () = + let size = + if dev#size <= Int64.of_int32 Int32.max_int then Int64.to_int32 dev#size + else Int32.max_int in + if metadata_offset < 0x1200_l || metadata_offset >= size + || metadata_length < 0_l || metadata_offset+*metadata_length >= size + then + invalid_arg "read_pv_label: bad metadata offset or length" in + + Bitmatch.string_of_bitstring uuid, metadata_offset, metadata_length + + | _ -> invalid_arg (sprintf "read_pv_label: %s: not an LVM2 physical volume" dev#name) @@ -61,7 +90,8 @@ and read_pv_label dev = * (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 list_lvs devs = [] +let list_lvs devs = + [] (* Register with main code. *) let () = -- cgit v1.1 From c0e4c9e257316408d4097b5d75a85617d97c6c35 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Tue, 15 Apr 2008 15:08:52 +0100 Subject: Added a documentation note about RAID devices. --- virt-df/virt_df_main.ml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/virt-df/virt_df_main.ml b/virt-df/virt_df_main.ml index 9cfde39..e6ae53e 100644 --- a/virt-df/virt_df_main.ml +++ b/virt-df/virt_df_main.ml @@ -322,6 +322,10 @@ OPTIONS" in * (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 ( -- cgit v1.1 From b25ac692bd7107b56850de8fa25123791dfdf73e Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Tue, 15 Apr 2008 15:27:06 +0100 Subject: Read out the actual metadata. --- virt-df/virt_df_lvm2.ml | 55 +++++++++++++++++++++++++++++-------------------- 1 file changed, 33 insertions(+), 22 deletions(-) diff --git a/virt-df/virt_df_lvm2.ml b/virt-df/virt_df_lvm2.ml index abc247e..afcab66 100644 --- a/virt-df/virt_df_lvm2.ml +++ b/virt-df/virt_df_lvm2.ml @@ -32,12 +32,13 @@ let sector_size64 = 512L (* Probe to see if it's an LVM2 PV. Look for the "LABELONE" label. *) let rec probe_pv lvm_plugin_id dev = try - let uuid, metadata_offset, metadata_length = read_pv_label dev in + let uuid, _ = read_pv_label dev in if debug then - eprintf "LVM2 detected UUID %s md offset 0x%lx len %ld\n%!" - uuid metadata_offset metadata_length; + eprintf "LVM2 detected PV UUID %s\n%!" uuid; { lvm_plugin_id = lvm_plugin_id; pv_uuid = uuid } - with _ -> raise Not_found + 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 @@ -47,7 +48,7 @@ and read_pv_label dev = *) let bits = dev#read_bitstring 0L (9 * sector_size) in - Bitmatch.hexdump_bitstring stdout bits; + (*Bitmatch.hexdump_bitstring stdout bits;*) bitmatch bits with | sector0 : sector_size*8 : bitstring; (* sector 0 *) @@ -64,26 +65,36 @@ and read_pv_label dev = when Bitmatch.string_of_bitstring labelone = "LABELONE" && Bitmatch.string_of_bitstring lvm2_ver = "LVM2 001" -> let metadata_offset = metadata_offset +* 0x1000_l in + let metadata = read_metadata dev metadata_offset metadata_length in + (*prerr_endline metadata;*) + let uuid = Bitmatch.string_of_bitstring uuid in - (* Check the metadata offset & length look reasonable for this - * device. Otherwise maybe it's a newer or older header which - * we don't really understand properly. - *) - let () = - let size = - if dev#size <= Int64.of_int32 Int32.max_int then Int64.to_int32 dev#size - else Int32.max_int in - if metadata_offset < 0x1200_l || metadata_offset >= size - || metadata_length < 0_l || metadata_offset+*metadata_length >= size - then - invalid_arg "read_pv_label: bad metadata offset or length" in - - Bitmatch.string_of_bitstring uuid, metadata_offset, metadata_length - + uuid, metadata | _ -> - invalid_arg (sprintf "read_pv_label: %s: not an LVM2 physical volume" - dev#name) + 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 -- cgit v1.1 From 479659599edaaf6cd9385ce00750407d61baf0f0 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Tue, 15 Apr 2008 15:33:08 +0100 Subject: Cosmetic fixes and comments. --- virt-df/virt_df_lvm2.ml | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/virt-df/virt_df_lvm2.ml b/virt-df/virt_df_lvm2.ml index afcab66..16d8e89 100644 --- a/virt-df/virt_df_lvm2.ml +++ b/virt-df/virt_df_lvm2.ml @@ -29,7 +29,7 @@ let plugin_name = "LVM2" let sector_size = 512 let sector_size64 = 512L -(* Probe to see if it's an LVM2 PV. Look for the "LABELONE" label. *) +(* 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 @@ -77,7 +77,7 @@ and read_pv_label dev = and read_metadata dev offset32 len32 = if debug then - eprintf "metadata: offset 0x%lx len %ld bytes\n" offset32 len32; + eprintf "metadata: offset 0x%lx len %ld bytes\n%!" offset32 len32; (* Check the offset and length are sensible. *) let offset64 = @@ -102,6 +102,8 @@ and read_metadata dev offset32 len32 = * what is on these LVs - that will be done in the main code. *) let list_lvs devs = + (* Read the UUID and metadata (again) from each device. *) + let uuidmetas = List.map read_pv_label devs in [] (* Register with main code. *) -- cgit v1.1 From b9320ec4678a8a7bb88a8b8aa72805b79ce48daf Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Tue, 15 Apr 2008 15:33:30 +0100 Subject: Empty *.mli files to stop those modules from exporting symbols. --- virt-df/.depend | 16 ++++++++-------- virt-df/virt_df_ext2.mli | 22 ++++++++++++++++++++++ virt-df/virt_df_linux_swap.mli | 22 ++++++++++++++++++++++ virt-df/virt_df_lvm2.mli | 22 ++++++++++++++++++++++ virt-df/virt_df_mbr.mli | 22 ++++++++++++++++++++++ 5 files changed, 96 insertions(+), 8 deletions(-) create mode 100644 virt-df/virt_df_ext2.mli create mode 100644 virt-df/virt_df_linux_swap.mli create mode 100644 virt-df/virt_df_lvm2.mli create mode 100644 virt-df/virt_df_mbr.mli diff --git a/virt-df/.depend b/virt-df/.depend index 9bf7fd7..d253040 100644 --- a/virt-df/.depend +++ b/virt-df/.depend @@ -1,22 +1,22 @@ virt_df_ext2.cmo: virt_df_gettext.cmo virt_df.cmi \ - /usr/lib64/ocaml/bitmatch/bitmatch.cmi + /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_ext2.cmi virt_df_ext2.cmx: virt_df_gettext.cmx virt_df.cmx \ - /usr/lib64/ocaml/bitmatch/bitmatch.cmi + /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_ext2.cmi virt_df_linux_swap.cmo: virt_df_gettext.cmo virt_df.cmi \ - /usr/lib64/ocaml/bitmatch/bitmatch.cmi + /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_linux_swap.cmi virt_df_linux_swap.cmx: virt_df_gettext.cmx virt_df.cmx \ - /usr/lib64/ocaml/bitmatch/bitmatch.cmi + /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_linux_swap.cmi virt_df_lvm2.cmo: virt_df_gettext.cmo virt_df.cmi \ - /usr/lib64/ocaml/bitmatch/bitmatch.cmi + /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_lvm2.cmi virt_df_lvm2.cmx: virt_df_gettext.cmx virt_df.cmx \ - /usr/lib64/ocaml/bitmatch/bitmatch.cmi + /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_lvm2.cmi virt_df_main.cmo: virt_df_gettext.cmo virt_df.cmi \ ../libvirt/libvirt_version.cmi ../libvirt/libvirt.cmi virt_df_main.cmx: virt_df_gettext.cmx virt_df.cmx \ ../libvirt/libvirt_version.cmx ../libvirt/libvirt.cmx virt_df_mbr.cmo: virt_df_gettext.cmo virt_df.cmi \ - /usr/lib64/ocaml/bitmatch/bitmatch.cmi + /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_mbr.cmi virt_df_mbr.cmx: virt_df_gettext.cmx virt_df.cmx \ - /usr/lib64/ocaml/bitmatch/bitmatch.cmi + /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_mbr.cmi virt_df.cmo: virt_df_gettext.cmo virt_df.cmi virt_df.cmx: virt_df_gettext.cmx virt_df.cmi diff --git a/virt-df/virt_df_ext2.mli b/virt-df/virt_df_ext2.mli new file mode 100644 index 0000000..d32a0f8 --- /dev/null +++ b/virt-df/virt_df_ext2.mli @@ -0,0 +1,22 @@ +(* '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.mli b/virt-df/virt_df_linux_swap.mli new file mode 100644 index 0000000..d32a0f8 --- /dev/null +++ b/virt-df/virt_df_linux_swap.mli @@ -0,0 +1,22 @@ +(* '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.mli b/virt-df/virt_df_lvm2.mli new file mode 100644 index 0000000..d32a0f8 --- /dev/null +++ b/virt-df/virt_df_lvm2.mli @@ -0,0 +1,22 @@ +(* '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_mbr.mli b/virt-df/virt_df_mbr.mli new file mode 100644 index 0000000..d32a0f8 --- /dev/null +++ b/virt-df/virt_df_mbr.mli @@ -0,0 +1,22 @@ +(* '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. +*) -- cgit v1.1 From 81294675f6a5058a3381871f1dc99c806922d77c Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Tue, 15 Apr 2008 18:30:49 +0100 Subject: Metadata parser. --- .hgignore | 3 + Make.rules.in | 7 +- virt-df/.depend | 17 +++- virt-df/Makefile.in | 8 ++ virt-df/virt_df_lvm2.ml | 40 ++++++++- virt-df/virt_df_lvm2_lexer.mll | 165 ++++++++++++++++++++++++++++++++++++++ virt-df/virt_df_lvm2_metadata.ml | 65 +++++++++++++++ virt-df/virt_df_lvm2_metadata.mli | 38 +++++++++ virt-df/virt_df_lvm2_parser.mly | 70 ++++++++++++++++ 9 files changed, 404 insertions(+), 9 deletions(-) create mode 100644 virt-df/virt_df_lvm2_lexer.mll create mode 100644 virt-df/virt_df_lvm2_metadata.ml create mode 100644 virt-df/virt_df_lvm2_metadata.mli create mode 100644 virt-df/virt_df_lvm2_parser.mly diff --git a/.hgignore b/.hgignore index f8063da..f78c6f6 100644 --- a/.hgignore +++ b/.hgignore @@ -41,3 +41,6 @@ virt-df/virt_df_gettext.ml virt-top/virt_top_gettext.ml po/*.mo po/*.po.bak +virt-df/virt_df_lvm2_lexer.ml +virt-df/virt_df_lvm2_parser.ml +virt-df/virt_df_lvm2_parser.mli \ No newline at end of file diff --git a/Make.rules.in b/Make.rules.in index b22fdf6..a25d485 100644 --- a/Make.rules.in +++ b/Make.rules.in @@ -40,6 +40,11 @@ else $(OCAMLOPT) $(OCAMLOPTFLAGS) $(OCAMLOPTINCS) -c $< endif +%.ml %.mli: %.mly + ocamlyacc $< +.mll.ml: + ocamllex $< + # Dependencies. depend: .depend @@ -60,4 +65,4 @@ endif .PHONY: depend dist check-manifest dpkg doc -.SUFFIXES: .cmo .cmi .cmx .ml .mli .mll +.SUFFIXES: .cmo .cmi .cmx .ml .mli .mll .mly diff --git a/virt-df/.depend b/virt-df/.depend index d253040..e7cd81e 100644 --- a/virt-df/.depend +++ b/virt-df/.depend @@ -1,3 +1,4 @@ +virt_df_lvm2_parser.cmi: virt_df_lvm2_metadata.cmi virt_df_ext2.cmo: virt_df_gettext.cmo virt_df.cmi \ /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_ext2.cmi virt_df_ext2.cmx: virt_df_gettext.cmx virt_df.cmx \ @@ -6,10 +7,18 @@ virt_df_linux_swap.cmo: virt_df_gettext.cmo virt_df.cmi \ /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_linux_swap.cmi virt_df_linux_swap.cmx: virt_df_gettext.cmx virt_df.cmx \ /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_linux_swap.cmi -virt_df_lvm2.cmo: virt_df_gettext.cmo virt_df.cmi \ - /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_lvm2.cmi -virt_df_lvm2.cmx: virt_df_gettext.cmx virt_df.cmx \ - /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_lvm2.cmi +virt_df_lvm2_lexer.cmo: virt_df_lvm2_parser.cmi virt_df.cmi +virt_df_lvm2_lexer.cmx: virt_df_lvm2_parser.cmx virt_df.cmx +virt_df_lvm2_metadata.cmo: virt_df_lvm2_metadata.cmi +virt_df_lvm2_metadata.cmx: virt_df_lvm2_metadata.cmi +virt_df_lvm2.cmo: virt_df_lvm2_metadata.cmi virt_df_lvm2_lexer.cmo \ + virt_df_gettext.cmo virt_df.cmi /usr/lib64/ocaml/bitmatch/bitmatch.cmi \ + virt_df_lvm2.cmi +virt_df_lvm2.cmx: virt_df_lvm2_metadata.cmx virt_df_lvm2_lexer.cmx \ + virt_df_gettext.cmx virt_df.cmx /usr/lib64/ocaml/bitmatch/bitmatch.cmi \ + virt_df_lvm2.cmi +virt_df_lvm2_parser.cmo: virt_df_lvm2_metadata.cmi virt_df_lvm2_parser.cmi +virt_df_lvm2_parser.cmx: virt_df_lvm2_metadata.cmx virt_df_lvm2_parser.cmi virt_df_main.cmo: virt_df_gettext.cmo virt_df.cmi \ ../libvirt/libvirt_version.cmi ../libvirt/libvirt.cmi virt_df_main.cmx: virt_df_gettext.cmx virt_df.cmx \ diff --git a/virt-df/Makefile.in b/virt-df/Makefile.in index 4a56d2d..4fb088c 100644 --- a/virt-df/Makefile.in +++ b/virt-df/Makefile.in @@ -39,6 +39,9 @@ OBJS := \ 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 @@ -82,6 +85,11 @@ virt-df.opt: $(XOBJS) $(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 diff --git a/virt-df/virt_df_lvm2.ml b/virt-df/virt_df_lvm2.ml index 16d8e89..fcf1fd2 100644 --- a/virt-df/virt_df_lvm2.ml +++ b/virt-df/virt_df_lvm2.ml @@ -24,6 +24,8 @@ open Printf open Virt_df_gettext.Gettext open Virt_df +open Virt_df_lvm2_metadata + let plugin_name = "LVM2" let sector_size = 512 @@ -64,9 +66,16 @@ and read_pv_label dev = 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 - (*prerr_endline metadata;*) + let uuid = Bitmatch.string_of_bitstring uuid in uuid, metadata @@ -101,11 +110,34 @@ and read_metadata dev offset32 len32 = * (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 list_lvs devs = - (* Read the UUID and metadata (again) from each device. *) - let uuidmetas = List.map read_pv_label devs in +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 read_pv_label devs in + + (* Parse the metadata using the external lexer/parser. *) + let pvs = List.map ( + fun (uuid, metadata) -> + eprintf "parsing: %s\n<<<<\n" metadata; + uuid, Virt_df_lvm2_lexer.parse_lvm2_metadata_from_string metadata + ) pvs in + + (* Print the parsed metadata. *) + List.iter ( + fun (uuid, metadata) -> + eprintf "metadata for UUID %s:\n" uuid; + output_metadata stderr metadata + ) pvs; + [] + + + + + + (* Register with main code. *) let () = lvm_type_register plugin_name probe_pv list_lvs diff --git a/virt-df/virt_df_lvm2_lexer.mll b/virt-df/virt_df_lvm2_lexer.mll new file mode 100644 index 0000000..2dbe7e5 --- /dev/null +++ b/virt-df/virt_df_lvm2_lexer.mll @@ -0,0 +1,165 @@ +(* '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 new file mode 100644 index 0000000..d293577 --- /dev/null +++ b/virt-df/virt_df_lvm2_metadata.ml @@ -0,0 +1,65 @@ +(* '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. + *) + +(* 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 "}\n"; + | 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 new file mode 100644 index 0000000..b7e821b --- /dev/null +++ b/virt-df/virt_df_lvm2_metadata.mli @@ -0,0 +1,38 @@ +(* '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. + *) + +(* 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 new file mode 100644 index 0000000..9f47ced --- /dev/null +++ b/virt-df/virt_df_lvm2_parser.mly @@ -0,0 +1,70 @@ +/* '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" */ +%token INT /* an integer */ +%token FLOAT /* a float */ +%token IDENT /* a naked keyword/identifier */ +%token EOF /* end of file */ + +%start input +%type input + +%% + +input : lines EOF { List.rev $1 } + ; + +lines : /* empty */ { prerr_endline "empty line"; [] } + | lines line { prerr_endline "input 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 } + ; -- cgit v1.1 From 4268ee74b7237c3e8bc1d78b92b6e3669cbec6da Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Tue, 15 Apr 2008 20:49:30 +0100 Subject: Added developer documentation. --- virt-df/README | 68 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 67 insertions(+), 1 deletion(-) diff --git a/virt-df/README b/virt-df/README index 0623030..c3ba4fe 100644 --- a/virt-df/README +++ b/virt-df/README @@ -1,2 +1,68 @@ +$Id$ + +For user documentation: + Please see the manual page (virt-df.pod or virt-df.txt in this -directory). \ No newline at end of file +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). + + - virt_df_mbr.ml / virt_df_mbr.mli + + Master Boot Record (MS-DOS) disk partitioning. + + - 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. -- cgit v1.1 From 5e15e5798813ee7d1f459685e669fcc22c870ec2 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Tue, 15 Apr 2008 20:51:46 +0100 Subject: Removed text-mode annotation. --- virt-df/virt_df_lvm2_metadata.ml | 2 +- virt-df/virt_df_lvm2_metadata.mli | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/virt-df/virt_df_lvm2_metadata.ml b/virt-df/virt_df_lvm2_metadata.ml index d293577..2929cb0 100644 --- a/virt-df/virt_df_lvm2_metadata.ml +++ b/virt-df/virt_df_lvm2_metadata.ml @@ -1,4 +1,4 @@ -(* 'df' command for virtual domains. -*- text -*- +(* 'df' command for virtual domains. (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc. http://libvirt.org/ diff --git a/virt-df/virt_df_lvm2_metadata.mli b/virt-df/virt_df_lvm2_metadata.mli index b7e821b..778f393 100644 --- a/virt-df/virt_df_lvm2_metadata.mli +++ b/virt-df/virt_df_lvm2_metadata.mli @@ -1,4 +1,4 @@ -(* 'df' command for virtual domains. -*- text -*- +(* 'df' command for virtual domains. (C) Copyright 2007-2008 Richard W.M. Jones, Red Hat Inc. http://libvirt.org/ -- cgit v1.1 From eb57a2de474de79b12bacf61a7e9ed94d3b82429 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Tue, 15 Apr 2008 22:30:27 +0100 Subject: Removed some debugging prints. --- virt-df/virt_df_lvm2_parser.mly | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/virt-df/virt_df_lvm2_parser.mly b/virt-df/virt_df_lvm2_parser.mly index 9f47ced..c4ee574 100644 --- a/virt-df/virt_df_lvm2_parser.mly +++ b/virt-df/virt_df_lvm2_parser.mly @@ -44,8 +44,8 @@ input : lines EOF { List.rev $1 } ; -lines : /* empty */ { prerr_endline "empty line"; [] } - | lines line { prerr_endline "input line"; $2 :: $1 } +lines : /* empty */ { [] } + | lines line { $2 :: $1 } ; line : /* empty */ /* These dummy entries get removed after parsing. */ -- cgit v1.1 From 3ae5297d795db6e8da8c9b02a7e85a808a93388e Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Tue, 15 Apr 2008 22:30:45 +0100 Subject: Redundant newline. --- virt-df/virt_df_lvm2_metadata.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/virt-df/virt_df_lvm2_metadata.ml b/virt-df/virt_df_lvm2_metadata.ml index 2929cb0..c5e3f90 100644 --- a/virt-df/virt_df_lvm2_metadata.ml +++ b/virt-df/virt_df_lvm2_metadata.ml @@ -48,7 +48,7 @@ and output_metavalue chan prefix = function output_string chan "{\n"; _output_metadata chan (prefix ^ " ") md; output_string chan prefix; - output_string chan "}\n"; + output_string chan "}"; | String str -> output_char chan '"'; output_string chan str; -- cgit v1.1 From b06f8da33e1e87a64ec785e248e47e47fee9073f Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Tue, 15 Apr 2008 22:31:08 +0100 Subject: Added range library function. --- virt-df/virt_df.ml | 4 ++++ virt-df/virt_df.mli | 5 +++++ 2 files changed, 9 insertions(+) diff --git a/virt-df/virt_df.ml b/virt-df/virt_df.ml index f8f34ab..63bb090 100644 --- a/virt-df/virt_df.ml +++ b/virt-df/virt_df.ml @@ -258,3 +258,7 @@ let group_by ?(cmp = Pervasives.compare) 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 index b36d003..d40c934 100644 --- a/virt-df/virt_df.mli +++ b/virt-df/virt_df.mli @@ -212,3 +212,8 @@ val list_lvs : lvm_plugin_id -> device list -> lv list 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. +*) -- cgit v1.1 From 291265b7171d332d2969e07ac189d876e3d7f26d Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Tue, 15 Apr 2008 22:31:24 +0100 Subject: Almost complete VG & LV metadata parsing. --- virt-df/virt_df_lvm2.ml | 140 ++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 130 insertions(+), 10 deletions(-) diff --git a/virt-df/virt_df_lvm2.ml b/virt-df/virt_df_lvm2.ml index fcf1fd2..af58f97 100644 --- a/virt-df/virt_df_lvm2.ml +++ b/virt-df/virt_df_lvm2.ml @@ -21,6 +21,8 @@ *) open Printf +open ExtList + open Virt_df_gettext.Gettext open Virt_df @@ -114,29 +116,147 @@ 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 read_pv_label devs in + 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) -> - eprintf "parsing: %s\n<<<<\n" metadata; - uuid, Virt_df_lvm2_lexer.parse_lvm2_metadata_from_string metadata + fun (uuid, (metadata, dev)) -> + uuid, (Virt_df_lvm2_lexer.parse_lvm2_metadata_from_string metadata, + dev) ) pvs in - (* Print the parsed metadata. *) + (* Print the parsed metadata. List.iter ( - fun (uuid, metadata) -> + fun (uuid, (metadata, dev)) -> eprintf "metadata for UUID %s:\n" uuid; 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 in + 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)) -> + let lvs = + try + let extent_size = get_int "extent_size" vgmeta 0 (256*1024) in + 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 + if segtype <> "striped" then raise Not_found; + let stripe_count = + get_int "stripe_count" segmeta 0 1024 in + (* let stripes = in *) + + (start_extent, extent_count, stripe_count) + ) segments in + + Some (lvname, (lvmeta, 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, lvs)) + ) vgs in + + (* Print the LVs. *) + if debug then + List.iter ( + fun (vgname, (pvuuids, vgmeta, lvs)) -> + let lvnames = List.map fst lvs in + eprintf "VG %s contains LVs: %s\n%!" vgname (String.concat ", " lvnames) + ) vgs; - + [] (* Register with main code. *) let () = -- cgit v1.1 From 027b0d92ed236fa24f211e053e81189cddffe7d7 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Wed, 16 Apr 2008 08:15:56 +0100 Subject: Make debug selectable at runtime. --- virt-df/virt_df.ml | 15 +++++++-------- virt-df/virt_df.mli | 4 +--- virt-df/virt_df_lvm2.ml | 10 +++++----- virt-df/virt_df_main.ml | 2 ++ virt-df/virt_df_mbr.ml | 5 +++-- 5 files changed, 18 insertions(+), 18 deletions(-) diff --git a/virt-df/virt_df.ml b/virt-df/virt_df.ml index 63bb090..5fd4d80 100644 --- a/virt-df/virt_df.ml +++ b/virt-df/virt_df.ml @@ -23,8 +23,6 @@ open Unix open Virt_df_gettext.Gettext -let debug = true (* If true emit lots of debugging information. *) - let ( +* ) = Int32.add let ( -* ) = Int32.sub let ( ** ) = Int32.mul @@ -35,6 +33,7 @@ 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 @@ -171,7 +170,7 @@ let partition_type_register (parts_name : string) probe_fn = (* 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; + if !debug then eprintf "probing for partitions on %s ...\n%!" dev#name; let rec loop = function | [] -> None | (parts_name, probe_fn) :: rest -> @@ -179,7 +178,7 @@ let probe_for_partitions dev = with Not_found -> loop rest in let r = loop !partition_types in - if debug then ( + if !debug then ( match r with | None -> eprintf "no partitions found on %s\n%!" dev#name | Some { parts_name = name; parts = parts } -> @@ -196,7 +195,7 @@ let filesystem_type_register (fs_name : string) probe_fn = (* 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; + if !debug then eprintf "probing for a filesystem on %s ...\n%!" dev#name; let rec loop = function | [] -> None | (fs_name, probe_fn) :: rest -> @@ -204,7 +203,7 @@ let probe_for_filesystem dev = with Not_found -> loop rest in let r = loop !filesystem_types in - if debug then ( + if !debug then ( match r with | None -> eprintf "no filesystem found on %s\n%!" dev#name | Some fs -> @@ -220,7 +219,7 @@ let lvm_type_register (lvm_name : string) probe_fn list_lvs_fn = (* 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; + if !debug then eprintf "probing if %s is a PV ...\n%!" dev#name; let rec loop = function | [] -> None | (lvm_name, (probe_fn, _)) :: rest -> @@ -228,7 +227,7 @@ let probe_for_pv dev = with Not_found -> loop rest in let r = loop !lvm_types in - if debug then ( + if !debug then ( match r with | None -> eprintf "no PV found on %s\n%!" dev#name | Some { lvm_plugin_id = name } -> diff --git a/virt-df/virt_df.mli b/virt-df/virt_df.mli index d40c934..f3d20a7 100644 --- a/virt-df/virt_df.mli +++ b/virt-df/virt_df.mli @@ -21,9 +21,6 @@ used throughout the plug-ins and main code. *) -val debug : bool -(** If true, emit logs of debugging information to stderr. *) - val ( +* ) : int32 -> int32 -> int32 val ( -* ) : int32 -> int32 -> int32 val ( ** ) : int32 -> int32 -> int32 @@ -34,6 +31,7 @@ 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. *) diff --git a/virt-df/virt_df_lvm2.ml b/virt-df/virt_df_lvm2.ml index af58f97..314586e 100644 --- a/virt-df/virt_df_lvm2.ml +++ b/virt-df/virt_df_lvm2.ml @@ -37,11 +37,11 @@ let sector_size64 = 512L let rec probe_pv lvm_plugin_id dev = try let uuid, _ = read_pv_label dev in - if debug then + 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); + if !debug then prerr_endline (Printexc.to_string exn); raise Not_found and read_pv_label dev = @@ -87,7 +87,7 @@ and read_pv_label dev = (sprintf "LVM2: read_pv_label: %s: not an LVM2 physical volume" dev#name) and read_metadata dev offset32 len32 = - if debug then + if !debug then eprintf "metadata: offset 0x%lx len %ld bytes\n%!" offset32 len32; (* Check the offset and length are sensible. *) @@ -166,7 +166,7 @@ let rec list_lvs devs = vgname, (pvuuids, vgmeta)) vgs in (* Print the VGs. *) - if debug then + if !debug then List.iter ( fun (vgname, (pvuuids, vgmeta)) -> eprintf "VG %s is on PVs: %s\n%!" vgname (String.concat "," pvuuids) @@ -249,7 +249,7 @@ let rec list_lvs devs = ) vgs in (* Print the LVs. *) - if debug then + if !debug then List.iter ( fun (vgname, (pvuuids, vgmeta, lvs)) -> let lvnames = List.map fst lvs in diff --git a/virt-df/virt_df_main.ml b/virt-df/virt_df_main.ml index e6ae53e..1e1db45 100644 --- a/virt-df/virt_df_main.ml +++ b/virt-df/virt_df_main.ml @@ -54,6 +54,8 @@ let () = "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, diff --git a/virt-df/virt_df_mbr.ml b/virt-df/virt_df_mbr.ml index b56189c..75e0661 100644 --- a/virt-df/virt_df_mbr.ml +++ b/virt-df/virt_df_mbr.ml @@ -133,8 +133,9 @@ and parse_mbr_entry dev i bits = 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 - eprintf "first_lba = %Lx\n" first_lba; - eprintf "part_size = %Lx\n" part_size; + 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 dev partno first_lba part_size; -- cgit v1.1 From 617ee3553ff13690643b42a084daaadd989b45c9 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Wed, 16 Apr 2008 12:07:17 +0100 Subject: Minor clarifications to developer docs. --- virt-df/README | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/virt-df/README b/virt-df/README index c3ba4fe..65acef9 100644 --- a/virt-df/README +++ b/virt-df/README @@ -44,11 +44,11 @@ plug-ins at time of writing are: - virt_df_linux_swap.ml / virt_df_linux_swap.mli - Linux swap (new style). + Linux swap (new style) plug-in. - virt_df_mbr.ml / virt_df_mbr.mli - Master Boot Record (MS-DOS) disk partitioning. + Master Boot Record (MS-DOS) disk partitioning plug-in. - virt_df_lvm2* -- cgit v1.1 From 0dc5575b79e4d5e003966eaaeb4d0a6a6e8802ed Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Wed, 16 Apr 2008 12:08:27 +0100 Subject: Added offset_device, canonical_uuid function, pass LV device with LV filesystems --- virt-df/virt_df.ml | 32 +++++++++++++++++++++++++++++++- virt-df/virt_df.mli | 26 +++++++++++++++++++++++--- virt-df/virt_df_main.ml | 33 +++++++++++++++++++-------------- 3 files changed, 73 insertions(+), 18 deletions(-) diff --git a/virt-df/virt_df.ml b/virt-df/virt_df.ml index 5fd4d80..c02c8e3 100644 --- a/virt-df/virt_df.ml +++ b/virt-df/virt_df.ml @@ -67,6 +67,21 @@ object (self) 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 @@ -80,7 +95,8 @@ type domain = { dom_name : string; (* Domain name. *) dom_id : int option; (* Domain ID (if running). *) dom_disks : disk list; (* Domain disks. *) - dom_lv_filesystems : filesystem list; (* Domain LV filesystems. *) + dom_lv_filesystems : + (lv * filesystem) list; (* Domain LV filesystems. *) } and disk = { (* From the XML ... *) @@ -163,6 +179,20 @@ 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 = diff --git a/virt-df/virt_df.mli b/virt-df/virt_df.mli index f3d20a7..f35e0db 100644 --- a/virt-df/virt_df.mli +++ b/virt-df/virt_df.mli @@ -100,8 +100,7 @@ class virtual device : Note the very rare use of OOP in OCaml! *) -class block_device : - string -> +class block_device : string -> object method name : string method read : int64 -> int -> string @@ -110,6 +109,23 @@ class block_device : 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. *) @@ -117,7 +133,8 @@ type domain = { dom_name : string; (** Domain name. *) dom_id : int option; (** Domain ID (if running). *) dom_disks : disk list; (** Domain disks. *) - dom_lv_filesystems : filesystem list; (** Domain LV filesystems. *) + dom_lv_filesystems : + (lv * filesystem) list; (** Domain LV filesystems. *) } and disk = { d_type : string option; (** The *) @@ -177,6 +194,9 @@ 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 diff --git a/virt-df/virt_df_main.ml b/virt-df/virt_df_main.ml index 1e1db45..4a1110d 100644 --- a/virt-df/virt_df_main.ml +++ b/virt-df/virt_df_main.ml @@ -364,8 +364,7 @@ OPTIONS" in let lvs = group_by lvs in let lvs = - List.map (fun (pv, devs) -> list_lvs pv.lvm_plugin_id devs) - lvs in + 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 @@ -373,7 +372,10 @@ OPTIONS" in *) let filesystems = List.filter_map ( - fun { lv_dev = dev } -> probe_for_filesystem dev + 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 } @@ -403,45 +405,48 @@ OPTIONS" in (* HOF to iterate over filesystems. *) let iter_over_filesystems doms - (f : domain -> ?disk:disk -> ?part:(partition * int) -> filesystem -> + (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 } as disk) -> - f dom ~disk fs + | ({ 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 } as part) -> - f dom ~disk ~part:(part, i) fs + | { part_content = `Filesystem fs; part_dev = dev } -> + f dom ~disk ~partno:(i+1) dev fs | _ -> () ) partitions.parts | _ -> () ) disks; (* LV filesystems. *) - List.iter (fun fs -> f dom fs) 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 ?part fs = + 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 -> "???" (* XXX keep LV dev around *) + | None -> dev#name | Some disk -> disk.d_target in - match part with + match partno with | None -> dom_name ^ ":" ^ disk_name - | Some (_, pnum) -> - dom_name ^ ":" ^ disk_name ^ string_of_int pnum in + | Some partno -> + dom_name ^ ":" ^ disk_name ^ string_of_int partno in printf "%-20s " name; if fs.fs_is_swap then ( -- cgit v1.1 From e9fa5a983e2e4c92676022a5912eaa4458ffd4c9 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Wed, 16 Apr 2008 12:08:41 +0100 Subject: Use offset_device --- virt-df/virt_df_mbr.ml | 15 +++------------ 1 file changed, 3 insertions(+), 12 deletions(-) diff --git a/virt-df/virt_df_mbr.ml b/virt-df/virt_df_mbr.ml index 75e0661..9516e3c 100644 --- a/virt-df/virt_df_mbr.ml +++ b/virt-df/virt_df_mbr.ml @@ -42,22 +42,13 @@ let max_extended_partitions = 100 * (cf. /dev/hda1 is the first partition). * (3) 'dev' is the underlying block device. *) -class partition_device dev partno start size = +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 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 partition boundaries (%Ld/%d/%Ld)" - name offset len size - ); - dev#read (start+^offset) len + inherit offset_device name start size dev end (** Probe the @@ -138,7 +129,7 @@ and make_mbr_entry part_status dev partno part_type first_lba part_size = first_lba part_size; { part_status = part_status; part_type = part_type; - part_dev = new partition_device dev partno first_lba part_size; + part_dev = new partition_device partno first_lba part_size dev; part_content = `Unknown } (* -- cgit v1.1 From 81593022de32f72e6dd7430519009cb70659eab6 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Wed, 16 Apr 2008 12:08:54 +0100 Subject: LVM2 parsing complete and working. --- virt-df/virt_df_lvm2.ml | 207 +++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 188 insertions(+), 19 deletions(-) diff --git a/virt-df/virt_df_lvm2.ml b/virt-df/virt_df_lvm2.ml index 314586e..6a8f573 100644 --- a/virt-df/virt_df_lvm2.ml +++ b/virt-df/virt_df_lvm2.ml @@ -33,6 +33,63 @@ 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 @@ -107,6 +164,7 @@ and read_metadata dev offset32 len32 = *) 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 @@ -129,13 +187,13 @@ let rec list_lvs devs = dev) ) pvs in - (* Print the parsed metadata. - List.iter ( - fun (uuid, (metadata, dev)) -> - eprintf "metadata for UUID %s:\n" uuid; - output_metadata stderr metadata - ) pvs; - *) + (* 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 @@ -191,18 +249,76 @@ let rec list_lvs devs = and get_meta field meta = match List.assoc field meta with | Metadata md -> md - | _ -> raise Not_found in + | _ -> 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)) -> + fun (vgname, (pvuuids, vgmeta, pvdevs, extent_size)) -> let lvs = try - let extent_size = get_int "extent_size" vgmeta 0 (256*1024) in let lvs = get_meta "logical_volumes" vgmeta in let lvs = List.filter_map ( function @@ -225,15 +341,29 @@ let rec list_lvs devs = 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 = in *) + let stripes = get_stripes "stripes" segmeta in + + if List.length stripes <> stripe_count then + raise Not_found; - (start_extent, extent_count, stripe_count) + (* 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, (lvmeta, segments)) + Some (lvname, segments) with (* Something went wrong with segments - omit this LV. *) Not_found -> None) @@ -245,19 +375,58 @@ let rec list_lvs devs = Not_found -> (* Something went wrong - assume no LVs found. *) [] in - (vgname, (pvuuids, vgmeta, lvs)) + (vgname, (pvuuids, vgmeta, pvdevs, extent_size, lvs)) ) vgs in (* Print the LVs. *) - if !debug then + if !debug then ( List.iter ( - fun (vgname, (pvuuids, vgmeta, lvs)) -> - let lvnames = List.map fst lvs in - eprintf "VG %s contains LVs: %s\n%!" vgname (String.concat ", " lvnames) + 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 -- cgit v1.1 From 4cb0481ebc30cdb05d1a0e8672e5dda8cd2352c2 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Wed, 16 Apr 2008 12:58:00 +0100 Subject: Fix alignment in -t option --- virt-df/virt_df_main.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/virt-df/virt_df_main.ml b/virt-df/virt_df_main.ml index 4a1110d..65d1f2f 100644 --- a/virt-df/virt_df_main.ml +++ b/virt-df/virt_df_main.ml @@ -65,7 +65,7 @@ let () = "--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"; + "dev " ^ s_ "(Test mode) Display contents of block device or file"; "--version", Arg.Unit version, " " ^ s_ "Display version and exit"; ] in -- cgit v1.1 From de3eddf0801b9a36a786e7579733e81ff509f339 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Wed, 16 Apr 2008 12:58:06 +0100 Subject: Update manpage. --- virt-df/virt-df.1 | 21 +++++++++++++-------- virt-df/virt-df.pod | 21 ++++++++++++++------- virt-df/virt-df.txt | 19 ++++++++++++------- 3 files changed, 39 insertions(+), 22 deletions(-) diff --git a/virt-df/virt-df.1 b/virt-df/virt-df.1 index ff7e92d..93c4ad7 100644 --- a/virt-df/virt-df.1 +++ b/virt-df/virt-df.1 @@ -129,7 +129,7 @@ .\" ======================================================================== .\" .IX Title "VIRT-DF 1" -.TH VIRT-DF 1 "2008-03-04" "ocaml-libvirt-0.4.0.3" "Virtualization Support" +.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" @@ -156,6 +156,10 @@ Show all domains. The default is show only running (active) domains. .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). @@ -165,6 +169,11 @@ 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. @@ -202,12 +211,8 @@ 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 is probably not secure against malicious guests. In -particular a malicious guest can set up a disk in such a way that disk -structures with loops can cause virt-df to spin forever. We are -preparing a parsing library which can fix these sorts of problems. -.PP -In the meantime, do not run virt-df on untrusted guests. +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), @@ -254,7 +259,7 @@ have fixed it. Run .Sp .Vb 1 -\& virt-df > virt-df.log 2>&1 +\& virt-df --debug > virt-df.log 2>&1 .Ve .Sp and keep \fIvirt\-df.log\fR. It contains error messages which you should diff --git a/virt-df/virt-df.pod b/virt-df/virt-df.pod index 84b1d97..ffde02b 100644 --- a/virt-df/virt-df.pod +++ b/virt-df/virt-df.pod @@ -32,6 +32,11 @@ Show all domains. The default is show only running (active) domains. 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). @@ -44,6 +49,12 @@ Display inode information. 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. @@ -85,12 +96,8 @@ source code at least]. =head1 SECURITY -The current code is probably not secure against malicious guests. In -particular a malicious guest can set up a disk in such a way that disk -structures with loops can cause virt-df to spin forever. We are -preparing a parsing library which can fix these sorts of problems. - -In the meantime, do not run virt-df on untrusted guests. +The current code tries hard to be secure against malicious guests, for +example guests which set up malicious disk partitions. =head1 SEE ALSO @@ -144,7 +151,7 @@ have fixed it. Run - virt-df > virt-df.log 2>&1 + virt-df --debug > virt-df.log 2>&1 and keep I. It contains error messages which you should submit with your bug report. diff --git a/virt-df/virt-df.txt b/virt-df/virt-df.txt index fcddafb..aa02a8f 100644 --- a/virt-df/virt-df.txt +++ b/virt-df/virt-df.txt @@ -23,6 +23,10 @@ OPTIONS 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). @@ -32,6 +36,11 @@ OPTIONS --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. @@ -68,12 +77,8 @@ SHORTCOMINGS least]. SECURITY - The current code is probably not secure against malicious guests. In - particular a malicious guest can set up a disk in such a way that disk - structures with loops can cause virt-df to spin forever. We are - preparing a parsing library which can fix these sorts of problems. - - In the meantime, do not run virt-df on untrusted guests. + 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), , @@ -115,7 +120,7 @@ REPORTING BUGS 2. Capture debug and error messages Run - virt-df > virt-df.log 2>&1 + 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. -- cgit v1.1 From 0bdb08c61ec66a16a81c2778a2a76cac77b08fda Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Wed, 16 Apr 2008 13:38:04 +0100 Subject: Updated MANIFEST. --- MANIFEST | 24 ++++++++++++++++++++---- 1 file changed, 20 insertions(+), 4 deletions(-) diff --git a/MANIFEST b/MANIFEST index 331d75b..cc62080 100644 --- a/MANIFEST +++ b/MANIFEST @@ -31,6 +31,15 @@ META.in mlvirsh/.depend mlvirsh/Makefile.in mlvirsh/mlvirsh.ml +po/ja.po +po/LINGUAS +po/Makefile.in +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 @@ -49,20 +58,27 @@ virt-ctrl/vc_icons.ml virt-ctrl/vc_mainwindow.ml virt-ctrl/vc_mainwindow.mli virt-ctrl/virt_ctrl.ml -README -TODO.libvirt -TODO.virt-top 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/README +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 -- cgit v1.1 From 02f1c03c9f81e25353aae4900ce19e194b507f71 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Wed, 16 Apr 2008 13:51:14 +0100 Subject: Removed virt-ctrl, virt-df, ocaml-libvirt - now in separate repositories. --- MANIFEST | 62 +- examples/Makefile.in | 90 -- examples/list_domains.ml | 46 - examples/node_info.ml | 48 - libvirt/Makefile.in | 126 -- libvirt/README | 49 - libvirt/generator.pl | 1018 ------------- libvirt/libvirt.ml | 522 ------- libvirt/libvirt.mli | 994 ------------ libvirt/libvirt_c.c | 3017 ------------------------------------- libvirt/libvirt_c_epilogue.c | 548 ------- libvirt/libvirt_c_oneoffs.c | 822 ---------- libvirt/libvirt_c_prologue.c | 191 --- libvirt/libvirt_version.ml.in | 21 - libvirt/libvirt_version.mli | 25 - mlvirsh/Makefile.in | 93 -- mlvirsh/mlvirsh.ml | 770 ---------- virt-ctrl/Makefile.in | 136 -- virt-ctrl/mingw-gcc-wrapper.ml | 70 - virt-ctrl/rebuild-icons.sh | 44 - virt-ctrl/vc_connection_dlg.ml | 203 --- virt-ctrl/vc_connection_dlg.mli | 43 - virt-ctrl/vc_connections.ml | 477 ------ virt-ctrl/vc_connections.mli | 102 -- virt-ctrl/vc_dbus.ml | 317 ---- virt-ctrl/vc_dbus.mli | 22 - virt-ctrl/vc_domain_ops.ml | 109 -- virt-ctrl/vc_domain_ops.mli | 35 - virt-ctrl/vc_helpers.ml | 97 -- virt-ctrl/vc_helpers.mli | 51 - virt-ctrl/vc_icons.ml | 270 ---- virt-ctrl/vc_mainwindow.ml | 202 --- virt-ctrl/vc_mainwindow.mli | 31 - virt-ctrl/virt_ctrl.ml | 36 - virt-df/Makefile.in | 109 -- virt-df/README | 68 - virt-df/virt-df.1 | 285 ---- virt-df/virt-df.pod | 181 --- virt-df/virt-df.txt | 144 -- virt-df/virt_df.ml | 293 ---- virt-df/virt_df.mli | 237 --- virt-df/virt_df_ext2.ml | 138 -- virt-df/virt_df_ext2.mli | 22 - virt-df/virt_df_linux_swap.ml | 54 - virt-df/virt_df_linux_swap.mli | 22 - virt-df/virt_df_lvm2.ml | 432 ------ virt-df/virt_df_lvm2.mli | 22 - virt-df/virt_df_lvm2_lexer.mll | 165 -- virt-df/virt_df_lvm2_metadata.ml | 65 - virt-df/virt_df_lvm2_metadata.mli | 38 - virt-df/virt_df_lvm2_parser.mly | 70 - virt-df/virt_df_main.ml | 488 ------ virt-df/virt_df_mbr.ml | 187 --- virt-df/virt_df_mbr.mli | 22 - 54 files changed, 1 insertion(+), 13728 deletions(-) delete mode 100644 examples/Makefile.in delete mode 100644 examples/list_domains.ml delete mode 100644 examples/node_info.ml delete mode 100644 libvirt/Makefile.in delete mode 100644 libvirt/README delete mode 100755 libvirt/generator.pl delete mode 100644 libvirt/libvirt.ml delete mode 100644 libvirt/libvirt.mli delete mode 100644 libvirt/libvirt_c.c delete mode 100644 libvirt/libvirt_c_epilogue.c delete mode 100644 libvirt/libvirt_c_oneoffs.c delete mode 100644 libvirt/libvirt_c_prologue.c delete mode 100755 libvirt/libvirt_version.ml.in delete mode 100755 libvirt/libvirt_version.mli delete mode 100644 mlvirsh/Makefile.in delete mode 100644 mlvirsh/mlvirsh.ml delete mode 100644 virt-ctrl/Makefile.in delete mode 100755 virt-ctrl/mingw-gcc-wrapper.ml delete mode 100755 virt-ctrl/rebuild-icons.sh delete mode 100644 virt-ctrl/vc_connection_dlg.ml delete mode 100644 virt-ctrl/vc_connection_dlg.mli delete mode 100644 virt-ctrl/vc_connections.ml delete mode 100644 virt-ctrl/vc_connections.mli delete mode 100644 virt-ctrl/vc_dbus.ml delete mode 100644 virt-ctrl/vc_dbus.mli delete mode 100644 virt-ctrl/vc_domain_ops.ml delete mode 100644 virt-ctrl/vc_domain_ops.mli delete mode 100644 virt-ctrl/vc_helpers.ml delete mode 100644 virt-ctrl/vc_helpers.mli delete mode 100644 virt-ctrl/vc_icons.ml delete mode 100644 virt-ctrl/vc_mainwindow.ml delete mode 100644 virt-ctrl/vc_mainwindow.mli delete mode 100644 virt-ctrl/virt_ctrl.ml delete mode 100644 virt-df/Makefile.in delete mode 100644 virt-df/README delete mode 100644 virt-df/virt-df.1 delete mode 100644 virt-df/virt-df.pod delete mode 100644 virt-df/virt-df.txt delete mode 100644 virt-df/virt_df.ml delete mode 100644 virt-df/virt_df.mli delete mode 100644 virt-df/virt_df_ext2.ml delete mode 100644 virt-df/virt_df_ext2.mli delete mode 100644 virt-df/virt_df_linux_swap.ml delete mode 100644 virt-df/virt_df_linux_swap.mli delete mode 100644 virt-df/virt_df_lvm2.ml delete mode 100644 virt-df/virt_df_lvm2.mli delete mode 100644 virt-df/virt_df_lvm2_lexer.mll delete mode 100644 virt-df/virt_df_lvm2_metadata.ml delete mode 100644 virt-df/virt_df_lvm2_metadata.mli delete mode 100644 virt-df/virt_df_lvm2_parser.mly delete mode 100644 virt-df/virt_df_main.ml delete mode 100644 virt-df/virt_df_mbr.ml delete mode 100644 virt-df/virt_df_mbr.mli diff --git a/MANIFEST b/MANIFEST index cc62080..ba611aa 100644 --- a/MANIFEST +++ b/MANIFEST @@ -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 -#include -#include - -#include -#include - -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#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 < 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 . *) - let maxcpus_of_node_info { nodes = nodes; sockets = sockets; - cores = cores; threads = threads } = - nodes * sockets * cores * threads - - (* See VIR_CPU_MAPLEN macro defined in . *) - let cpumaplen nr_cpus = - (nr_cpus + 7) / 8 - - (* See VIR_USE_CPU, VIR_UNUSE_CPU, VIR_CPU_USABLE macros defined in . *) - 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 = -# 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 [] 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 -#include -#include - -#include -#include - -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#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 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 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), -, -, -, - -.SH "AUTHORS" -.IX Header "AUTHORS" -Richard W.M. Jones -.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: -. -.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 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 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-like utility for showing the actual disk usage -of guests. Many command line options are the same as for ordinary -I. - -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 [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, -L, -L, -L, -L, -L, -L - -=head1 AUTHORS - -Richard W.M. Jones - -=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. - -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 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. 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 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 (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), , - , , - - -AUTHORS - Richard W.M. Jones - -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: - . - - If you find a bug in virt-df, please follow these steps to report it: - - 1. Check for existing bug reports - Go to 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 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 *) - d_device : string; (* The (eg "disk") *) - d_source : string; (* The *) - d_target : string; (* The (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 *) - d_device : string; (** The (eg "disk") *) - d_source : string; (** The *) - d_target : string; (** The (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" */ -%token INT /* an integer */ -%token FLOAT /* a float */ -%token IDENT /* a naked keyword/identifier */ -%token EOF /* end of file */ - -%start input -%type 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 ") 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 node in XML") - | Xml.Element ("name", _, [Xml.PCData name]) :: _ -> name - | Xml.Element ("name", _, _) :: _ -> - failwith (s_ "get_xml_desc returned strange 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. -*) -- cgit v1.1 From e86f4987469c26213c6693b35cde3b48a4732524 Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Wed, 16 Apr 2008 14:11:41 +0100 Subject: *** THIS REPO IS JUST FOR VIRT-TOP NOW *** - See http://hg.et.redhat.com/applications/virt/ for bindings and the other applications. --- Makefile.in | 75 +------------- README | 246 ++------------------------------------------- TODO.libvirt | 1 - config.h.in | 200 ------------------------------------- configure.ac | 277 ++++++++------------------------------------------- examples/.depend | 4 - libvirt/.depend | 4 - mlvirsh/.depend | 2 - virt-ctrl/.depend | 28 ------ virt-df/.depend | 31 ------ virt-top/.depend | 22 ++-- virt-top/Makefile.in | 11 +- 12 files changed, 66 insertions(+), 835 deletions(-) delete mode 100755 TODO.libvirt delete mode 100644 examples/.depend delete mode 100644 libvirt/.depend delete mode 100644 mlvirsh/.depend delete mode 100644 virt-ctrl/.depend delete mode 100644 virt-df/.depend diff --git a/Makefile.in b/Makefile.in index 52776e0..83fc0cb 100644 --- a/Makefile.in +++ b/Makefile.in @@ -1,4 +1,4 @@ -# ocaml-libvirt +# virt-top # Copyright (C) 2007 Red Hat Inc., Richard W.M. Jones # # This library is free software; you can redistribute it and/or @@ -22,10 +22,7 @@ INSTALL = @INSTALL@ MAKENSIS = @MAKENSIS@ -OCAMLDOC = @OCAMLDOC@ -OCAMLDOCFLAGS := -html -sort - -SUBDIRS = @subdirs@ +SUBDIRS = virt-top all opt depend install: for d in $(SUBDIRS); do \ @@ -37,36 +34,13 @@ clean: for d in . $(SUBDIRS); do \ (cd $$d; rm -f *.cmi *.cmo *.cmx *.cma *.cmxa *.o *.a *.so *.opt *~ *.dll *.exe core); \ done - rm -f examples/list_domains - rm -f examples/node_info - rm -f mlvirsh/mlvirsh - rm -f virt-ctrl/virt-ctrl rm -f virt-top/virt-top - rm -f virt-df/virt-df distclean: clean rm -f config.h config.log config.status configure rm -rf autom4te.cache - rm -f META - rm -f libvirt/libvirt_version.ml rm -f Makefile - rm -f libvirt/Makefile - rm -f examples/Makefile - rm -f mlvirsh/Makefile - rm -f virt-ctrl/Makefile rm -f virt-top/Makefile - rm -f virt-df/Makefile - -# Developer documentation (in html/ subdirectory). - -ifneq ($(OCAMLDOC),) -doc: - rm -rf html - mkdir html - -cd libvirt; \ - $(OCAMLDOC) $(OCAMLDOCFLAGS) -d ../html \ - libvirt.{ml,mli} libvirt_version.{ml,mli} -endif # Windows installer (requires NSIS). @@ -82,14 +56,6 @@ $(WININSTALLER): wininstaller.nsis all opt ls -l $@ endif -# Update configure and rerun. - -configure: force - autoreconf - CFLAGS=-g \ - ./configure \ - --enable-debug=yes --with-libvirt=/home/rjones/local - # Distribution. dist: @@ -109,42 +75,5 @@ check-manifest: rm -f .orig-manifest .check-manifest; \ exit $$rv -# Do a release (update the website). - -release: configure - $(MAKE) release_stage_2 - -release_stage_2: clean all opt doc dist - $(MAKE) release_stage_3 - -WEBSITE = ../redhat/websites - -release_stage_3: - rm -f $(WEBSITE)/ocaml-libvirt/html/*.{html,css} - cp html/*.{html,css} $(WEBSITE)/ocaml-libvirt/html/ - cp README $(WEBSITE)/ocaml-libvirt/README.txt - cp ChangeLog $(WEBSITE)/ocaml-libvirt/ChangeLog.txt -# cp virt-top/virt-top.txt $(WEBSITE)/virt-top/ -# cp ChangeLog $(WEBSITE)/virt-top/ChangeLog.txt - -# Upload to main website. - -upload: - cd $(WEBSITE)/ocaml-libvirt && \ - scp ChangeLog.txt index.html README.txt Screenshot*.png \ - libvirt.org:/data/www/libvirt.org/ocaml && \ - scp css/*.css \ - libvirt.org:/data/www/libvirt.org/ocaml/css/ && \ - scp html/*.html html/*.css \ - libvirt.org:/data/www/libvirt.org/ocaml/html/ - scp $(PACKAGE)-$(VERSION).tar.gz libvirt.org:/data/ftp/libvirt/ocaml/ - -# Upload Windows binary installer to main website. - -winupload: - scp $(WININSTALLER) libvirt.org:/data/ftp/libvirt/ocaml/ - -force: - .PHONY: all opt depend install clean distclean configure dist check-manifest \ release release_stage_2 release_stage_3 force \ No newline at end of file diff --git a/README b/README index 7fb9726..fc20808 100644 --- a/README +++ b/README @@ -1,147 +1,17 @@ -ocaml-libvirt +virt-top ---------------------------------------------------------------------- Copyright (C) 2007-2008 Richard W.M. Jones, Red Hat Inc. +http://et.redhat.com/~rjones/virt-top/ http://libvirt.org/ocaml/ http://libvirt.org/ -This is a complete set of OCaml bindings around libvirt, exposing all -known functionality to OCaml programs. +virt-top is a top-like utility for showing stats of virtualized +domains. Many keys and command line options are the same as for +ordinary top. - -Requirements ----------------------------------------------------------------------- - -PLEASE NOTE: The list of requirements looks long but you DO NOT NEED -all of these packages, so pay careful attention to what is required -('R') and what is optional ('O'). - -ALSO NOTE: Binaries are available for many platforms. You only need -the packages below if you want to build from source. - - W h a t y o u w a n t t o b u i l d - - |Bindings, |Docs, |virt-top |virt-ctrl |virt-df |Windows - |examples, |manpages | | | |version - |mlvirsh | | | | | - --------------+----------+---------+---------+----------+----------+------ - GNU make | R | R | R | R | R | R - | | | | | | - gcc | R | | R | R | R | R - | | | | | | - libvirt | R | | R | R | R | R - | >= 0.2.1 | | | | | - | | | | | | - ocaml | R | | R | R | R | R - | >= 3.08 | | | | >= 3.10 | - | | | | | | - findlib | HR | R | HR | HR | HR | Note [1] - | | | | | | - ocaml-gettext | O | O | O | O | O | Note [2] - | | | | | | - MinGW + MSYS | | | | | | R - --------------+----------+---------+---------+----------+----------+------ - ocamldoc | | R | | | | O - | | | | | | - perldoc | | O | | | | - --------------+----------+---------+---------+----------+----------+------ - ocaml-curses | | | R | | | - | | | | | | - Extlib | | | R | | R | - | | | | | | - xml-light | | | O | | R | - | | | | | | - ocaml-calendar| | | O | | | - | | | | | | - ocaml CSV | | | O | | | - | | | | | | - bitmatch | | | | | R | - --------------+----------+---------+---------+----------+----------+------ - GTK2 | | | | R | | O - | | | | | | - lablgtk2 | | | | R | | O - | | | | >= 2.10.0| | - ocaml-dbus | | | | O | | - | | | | >= 0.06 | | - gnome-icon-theme | | | O | | - --------------+----------+---------+---------+----------+----------+------ - NSIS | | | | | | O - --------------+----------+---------+---------+----------+----------+------ - - R = required - HR = highly recommended (use if possible) - O = optional (just improves functionality, but not required) - n/a = not available - -Note [1]: Findlib was recently ported to Windows and in future we may -require it because it will let us remove a lot of hacks from the -Makefiles. - -Note [2]: It's not clear if ocaml-gettext works on Windows. - -Where to get the packages: - - libvirt >= 0.2.1 from http://libvirt.org/ (get the latest version available) - or packaged in Debian, Ubuntu and Fedora - - ocaml >= 3.08 from http://caml.inria.fr/ - or packaged in Debian, Ubuntu and Fedora - - findlib from http://www.ocaml-programming.de/packages/ - or packaged in Debian, Ubuntu and Fedora as 'ocaml-findlib' - - ocaml-gettext from http://www.le-gall.net/sylvain+violaine/ocaml-gettext.html - + patch for OCaml 3.10: - http://www.annexia.org/tmp/ocaml-gettext-0.2.0-20080321.patch - (This should appear in ocaml-gettext 0.3.0 shortly). - - MinGW + MSYS from http://www.mingw.org/ (only needed for Windows) - - ocamldoc part of OCaml itself - or part of the ocaml package in Debian, Ubuntu - or packaged in Fedora as 'ocaml-ocamldoc' - - perldoc part of Perl - or packaged in Debian, Ubuntu and Fedora - - ocaml-curses from http://www.nongnu.org/ocaml-tmk/ - or packaged in Debian, Ubuntu as 'libcurses-ocaml-dev' - or packaged in Fedora as 'ocaml-curses-devel' - - Extlib from http://ocaml-lib.sourceforge.net/ - or packaged in Debian, Unbuntu as 'libextlib-ocaml-dev' - or packaged in Fedora as 'ocaml-extlib-devel' - - xml-light from http://tech.motion-twin.com/doc/xml-light/ - or packaged in Debian, Ubuntu as 'libxml-light-ocaml-dev' - or packaged in Fedora as 'ocaml-xml-light-devel' - - ocaml CSV from http://merjis.com/developers/csv - or packaged in Debian, Ubuntu as 'libcsv-ocaml-dev' - or packaged in Fedora as 'ocaml-csv-devel' - - ocaml-calendar from http://www.lri.fr/~signoles/prog.en.html - or packaged in Debian, Ubuntu as 'libcalendar-ocaml-dev' - or packaged in Fedora as 'ocaml-calendar-devel' - - bitmatch from http://et.redhat.com/~rjones/bitmatch/ - - GTK2 from http://gtk.org/ - or packaged in Debian, Ubuntu and Fedora - - lablgtk2 >= 2.10.0 - from http://wwwfun.kurims.kyoto-u.ac.jp/soft/lsl/lablgtk.html - or packaged in Debian, Ubuntu as 'liblablgtk2-ocaml-dev' - or packaged in Fedora 9 as 'ocaml-lablgtk-devel' - - gnome-icon-theme part of GNOME - - ocaml-dbus >= 0.06 - from http://tab.snarc.org/projects/ocaml_dbus/ - or packaged in Fedora 9 as 'ocaml-dbus-devel' - (not yet available for Debian or Ubuntu AFAIK) - - NSIS from http://nsis.sf.net +It uses libvirt so it capable of showing stats across a variety of +different virtualization systems. Building @@ -149,103 +19,7 @@ Building ./configure # Checks that you have all the required bits. - make all # Builds the bytecode version of libs/programs. - make opt # Builds the native code version of libs/programs. - - make install # Install in OCaml directory, and the binaries - # in $prefix/bin. - - make doc # Build HTML documentation in html/ subdirectory. - -Then have a look at the programs 'mlvirsh.opt', 'virt-top.opt' -and 'virt-ctrl.opt'. - -Note: If you want to run the programs without first installing, you -may need to set your $LD_LIBRARY_PATH environment variable so it -contains the build directory. eg: - - LD_LIBRARY_PATH=libvirt/ mlvirsh/mlvirsh.opt - - -Windows ----------------------------------------------------------------------- - -I have built libvirt (the bindings), examples, mlvirsh and virt-ctrl -on Windows using the MinGW port of OCaml. It's quite likely that it -will also work under VC++, but I have not tested this. - -You should make sure that your $PATH (environment variable) contains -the names of the directories containing all required DLLs, in -particular you will require: - - libvirt-*.dll (from libvirt) - libgnutls-*.dll (from GnuTLS) - libgcrypt-*.dll - libgpg-error-*.dll - libtasn1-*.dll - libxdr.dll (from libxdr) - libxml2-*.dll (from libxml2) - and, a multitude of DLLs from GTK if you want to run virt-ctrl - -You can use a tool such as Dependency Walker to find/check the -locations of dependent libraries. - -To build the Windows installer, you will need NSIS. Then do: - - ./configure --with-nsis=/c/Progra~1/NSIS - make all opt - make wininstaller - -This should build a Windows binary installer called -ocaml-libvirt-$VERSION.exe which includes the bindings, all required -DLLs and all programs that can be built under Windows. - - -mlvirsh ----------------------------------------------------------------------- - -'mlvirsh' is an almost complete reimplementation of virsh, which is -mostly command compatible (there are a very few commands missing, and -some commands have a slightly different syntax, but broadly speaking -they are equivalent programs except that one is written in C and the -other in OCaml). - -At the time of writing: - - wc -c wc -l - - virsh 126,056 4,641 - mlvirsh 19,427 598 - - % size 15% 13% - - -virt-ctrl ----------------------------------------------------------------------- - -'virt-ctrl' (originally called 'mlvirtmanager') is a reimplementation -of virt-manager in OCaml. It is not feature-complete by any means, -but does allow you to show the running domains and start and stop -defined domains. The main functionality _missing_ is the ability to -define new virtual machines, change the resources allocated to -domains, or show the machine console. - - -Programming ----------------------------------------------------------------------- - -For documentation on these bindings, read libvirt.mli and/or 'make -doc' and browse the HTML documentation in the html/ subdirectory. - -For documentation on libvirt itself, see http://libvirt.org/html/ - - -Subdirectories ----------------------------------------------------------------------- + make all # Builds the bytecode version of the program. + make opt # Builds the native code version of the program. -libvirt/ The OCaml bindings. -examples/ Some example programs using the bindings. -mlvirsh/ 'mlvirsh' command line tool. -virt-ctrl/ 'virt-ctrl' graphical tool. -virt-top/ 'virt-top' tool. -virt-df/ 'virt-df' tool. +Then have a look at the program 'virt-top/virt-top.opt'. diff --git a/TODO.libvirt b/TODO.libvirt deleted file mode 100755 index d87b8b8..0000000 --- a/TODO.libvirt +++ /dev/null @@ -1 +0,0 @@ -Turn VIR_ERR_NO_DOMAIN and NO_NETWORK errors into Not_found exceptions. diff --git a/config.h.in b/config.h.in index ab90ff8..989ed53 100644 --- a/config.h.in +++ b/config.h.in @@ -1,196 +1,5 @@ /* config.h.in. Generated from configure.ac by autoheader. */ -/* Define to 1 if you have the header file. */ -#undef HAVE_INTTYPES_H - -/* Define to 1 if you have the `ncurses' library (-lncurses). */ -#undef HAVE_LIBNCURSES - -/* Define to 1 if you have the `virt' library (-lvirt). */ -#undef HAVE_LIBVIRT - -/* Define to 1 if you have the header file. */ -#undef HAVE_MEMORY_H - -/* Define to 1 if you have the header file. */ -#undef HAVE_STDINT_H - -/* Define to 1 if you have the header file. */ -#undef HAVE_STDLIB_H - -/* Define to 1 if you have the header file. */ -#undef HAVE_STRINGS_H - -/* Define to 1 if you have the header file. */ -#undef HAVE_STRING_H - -/* Define to 1 if you have the header file. */ -#undef HAVE_SYS_STAT_H - -/* Define to 1 if you have the header file. */ -#undef HAVE_SYS_TYPES_H - -/* Define to 1 if you have the header file. */ -#undef HAVE_UNISTD_H - -/* Define to 1 if you have the `virConnectGetHostname' function. */ -#undef HAVE_VIRCONNECTGETHOSTNAME - -/* Define to 1 if you have the `virConnectGetURI' function. */ -#undef HAVE_VIRCONNECTGETURI - -/* Define to 1 if you have the `virConnectListDefinedStoragePools' function. - */ -#undef HAVE_VIRCONNECTLISTDEFINEDSTORAGEPOOLS - -/* Define to 1 if you have the `virConnectListStoragePools' function. */ -#undef HAVE_VIRCONNECTLISTSTORAGEPOOLS - -/* Define to 1 if you have the `virConnectNumOfDefinedStoragePools' function. - */ -#undef HAVE_VIRCONNECTNUMOFDEFINEDSTORAGEPOOLS - -/* Define to 1 if you have the `virConnectNumOfStoragePools' function. */ -#undef HAVE_VIRCONNECTNUMOFSTORAGEPOOLS - -/* Define to 1 if you have the `virDomainBlockStats' function. */ -#undef HAVE_VIRDOMAINBLOCKSTATS - -/* Define to 1 if you have the `virDomainGetSchedulerParameters' function. */ -#undef HAVE_VIRDOMAINGETSCHEDULERPARAMETERS - -/* Define to 1 if you have the `virDomainGetSchedulerType' function. */ -#undef HAVE_VIRDOMAINGETSCHEDULERTYPE - -/* Define to 1 if you have the `virDomainInterfaceStats' function. */ -#undef HAVE_VIRDOMAININTERFACESTATS - -/* Define to 1 if you have the `virDomainMigrate' function. */ -#undef HAVE_VIRDOMAINMIGRATE - -/* Define to 1 if you have the `virDomainSetSchedulerParameters' function. */ -#undef HAVE_VIRDOMAINSETSCHEDULERPARAMETERS - -/* Define to 1 if the system has the type `virJobPtr'. */ -#undef HAVE_VIRJOBPTR - -/* Define to 1 if you have the `virNodeGetCellsFreeMemory' function. */ -#undef HAVE_VIRNODEGETCELLSFREEMEMORY - -/* Define to 1 if you have the `virNodeGetFreeMemory' function. */ -#undef HAVE_VIRNODEGETFREEMEMORY - -/* Define to 1 if you have the `virStoragePoolBuild' function. */ -#undef HAVE_VIRSTORAGEPOOLBUILD - -/* Define to 1 if you have the `virStoragePoolCreate' function. */ -#undef HAVE_VIRSTORAGEPOOLCREATE - -/* Define to 1 if you have the `virStoragePoolCreateXML' function. */ -#undef HAVE_VIRSTORAGEPOOLCREATEXML - -/* Define to 1 if you have the `virStoragePoolDefineXML' function. */ -#undef HAVE_VIRSTORAGEPOOLDEFINEXML - -/* Define to 1 if you have the `virStoragePoolDelete' function. */ -#undef HAVE_VIRSTORAGEPOOLDELETE - -/* Define to 1 if you have the `virStoragePoolDestroy' function. */ -#undef HAVE_VIRSTORAGEPOOLDESTROY - -/* Define to 1 if you have the `virStoragePoolFree' function. */ -#undef HAVE_VIRSTORAGEPOOLFREE - -/* Define to 1 if you have the `virStoragePoolGetAutostart' function. */ -#undef HAVE_VIRSTORAGEPOOLGETAUTOSTART - -/* Define to 1 if you have the `virStoragePoolGetConnect' function. */ -#undef HAVE_VIRSTORAGEPOOLGETCONNECT - -/* Define to 1 if you have the `virStoragePoolGetInfo' function. */ -#undef HAVE_VIRSTORAGEPOOLGETINFO - -/* Define to 1 if you have the `virStoragePoolGetName' function. */ -#undef HAVE_VIRSTORAGEPOOLGETNAME - -/* Define to 1 if you have the `virStoragePoolGetUUID' function. */ -#undef HAVE_VIRSTORAGEPOOLGETUUID - -/* Define to 1 if you have the `virStoragePoolGetUUIDString' function. */ -#undef HAVE_VIRSTORAGEPOOLGETUUIDSTRING - -/* Define to 1 if you have the `virStoragePoolGetXMLDesc' function. */ -#undef HAVE_VIRSTORAGEPOOLGETXMLDESC - -/* Define to 1 if you have the `virStoragePoolListVolumes' function. */ -#undef HAVE_VIRSTORAGEPOOLLISTVOLUMES - -/* Define to 1 if you have the `virStoragePoolLookupByName' function. */ -#undef HAVE_VIRSTORAGEPOOLLOOKUPBYNAME - -/* Define to 1 if you have the `virStoragePoolLookupByUUID' function. */ -#undef HAVE_VIRSTORAGEPOOLLOOKUPBYUUID - -/* Define to 1 if you have the `virStoragePoolLookupByUUIDString' function. */ -#undef HAVE_VIRSTORAGEPOOLLOOKUPBYUUIDSTRING - -/* Define to 1 if you have the `virStoragePoolLookupByVolume' function. */ -#undef HAVE_VIRSTORAGEPOOLLOOKUPBYVOLUME - -/* Define to 1 if you have the `virStoragePoolNumOfVolumes' function. */ -#undef HAVE_VIRSTORAGEPOOLNUMOFVOLUMES - -/* Define to 1 if the system has the type `virStoragePoolPtr'. */ -#undef HAVE_VIRSTORAGEPOOLPTR - -/* Define to 1 if you have the `virStoragePoolRefresh' function. */ -#undef HAVE_VIRSTORAGEPOOLREFRESH - -/* Define to 1 if you have the `virStoragePoolSetAutostart' function. */ -#undef HAVE_VIRSTORAGEPOOLSETAUTOSTART - -/* Define to 1 if you have the `virStoragePoolUndefine' function. */ -#undef HAVE_VIRSTORAGEPOOLUNDEFINE - -/* Define to 1 if you have the `virStorageVolCreateXML' function. */ -#undef HAVE_VIRSTORAGEVOLCREATEXML - -/* Define to 1 if you have the `virStorageVolDelete' function. */ -#undef HAVE_VIRSTORAGEVOLDELETE - -/* Define to 1 if you have the `virStorageVolFree' function. */ -#undef HAVE_VIRSTORAGEVOLFREE - -/* Define to 1 if you have the `virStorageVolGetInfo' function. */ -#undef HAVE_VIRSTORAGEVOLGETINFO - -/* Define to 1 if you have the `virStorageVolGetKey' function. */ -#undef HAVE_VIRSTORAGEVOLGETKEY - -/* Define to 1 if you have the `virStorageVolGetName' function. */ -#undef HAVE_VIRSTORAGEVOLGETNAME - -/* Define to 1 if you have the `virStorageVolGetPath' function. */ -#undef HAVE_VIRSTORAGEVOLGETPATH - -/* Define to 1 if you have the `virStorageVolGetXMLDesc' function. */ -#undef HAVE_VIRSTORAGEVOLGETXMLDESC - -/* Define to 1 if you have the `virStorageVolLookupByKey' function. */ -#undef HAVE_VIRSTORAGEVOLLOOKUPBYKEY - -/* Define to 1 if you have the `virStorageVolLookupByName' function. */ -#undef HAVE_VIRSTORAGEVOLLOOKUPBYNAME - -/* Define to 1 if you have the `virStorageVolLookupByPath' function. */ -#undef HAVE_VIRSTORAGEVOLLOOKUPBYPATH - -/* Define to 1 if the system has the type `virStorageVolPtr'. */ -#undef HAVE_VIRSTORAGEVOLPTR - -/* Define to 1 if your C compiler doesn't accept -c and -o together. */ -#undef NO_MINUS_C_MINUS_O - /* Define to the address where bug reports for this package should be sent. */ #undef PACKAGE_BUGREPORT @@ -205,12 +14,3 @@ /* Define to the version of this package. */ #undef PACKAGE_VERSION - -/* Define to 1 if the C compiler supports function prototypes. */ -#undef PROTOTYPES - -/* Define to 1 if you have the ANSI C header files. */ -#undef STDC_HEADERS - -/* Define like PROTOTYPES; this can be used by system headers. */ -#undef __PROTOTYPES diff --git a/configure.ac b/configure.ac index 09d5505..14314f3 100644 --- a/configure.ac +++ b/configure.ac @@ -1,4 +1,4 @@ -# ocaml-libvirt +# virt-top # Copyright (C) 2007-2008 Red Hat Inc., Richard W.M. Jones # # This library is free software; you can redistribute it and/or @@ -17,250 +17,67 @@ dnl Process this file with autoconf to produce a configure script. -AC_INIT(ocaml-libvirt,0.4.1.1) - -dnl Check for basic C environment. -AC_PROG_CC -AC_PROG_INSTALL -AC_PROG_CPP - -AC_C_PROTOTYPES -test "x$U" != "x" && AC_MSG_ERROR(Compiler not ANSI compliant) - -AC_PROG_CC_C_O - -dnl Select some C flags based on the host type. -AC_CANONICAL_HOST - -DEBUG="-g" -WARNINGS="-Wall -Werror" -CFLAGS_FPIC="-fPIC" -WIN32=no -case "$host" in - *-*-mingw*) - WARNINGS="$WARNINGS -Wno-unused" - CFLAGS_FPIC="" - WIN32=yes -esac -AC_SUBST(DEBUG) -AC_SUBST(WARNINGS) -AC_SUBST(CFLAGS_FPIC) -AC_SUBST(WIN32) - -dnl Check for libvirt development environment. -AC_ARG_WITH(libvirt, - AC_HELP_STRING([--with-libvirt=PATH],[Set path to installed libvirt]), - [if test "x$withval" != "x"; then - CFLAGS="$CFLAGS -I$withval/include" - LDFLAGS="$LDFLAGS -L$withval/lib" - fi - ]) -AC_CHECK_LIB(virt,virConnectOpen, - [], - AC_MSG_ERROR([You must install libvirt library])) -AC_CHECK_HEADER([libvirt/libvirt.h], - [], - AC_MSG_ERROR([You must install libvirt development package])) - -dnl We also use -AC_CHECK_HEADER([libvirt/virterror.h], - [], - AC_MSG_ERROR([You must install libvirt development package])) - -dnl Check for libvirt >= 0.2.1 (our minimum supported version). -dnl See: http://libvirt.org/hvsupport.html -AC_CHECK_FUNC(virConnectGetCapabilities, - [], - AC_MSG_ERROR([You must have libvirt >= 0.2.1])) - -dnl Check for optional libvirt functions added since 0.2.1. -dnl See: http://libvirt.org/hvsupport.html -AC_CHECK_FUNCS([virConnectGetHostname \ - virConnectGetURI \ - virDomainBlockStats \ - virDomainGetSchedulerParameters \ - virDomainGetSchedulerType \ - virDomainInterfaceStats \ - virDomainMigrate \ - virDomainSetSchedulerParameters \ - virNodeGetFreeMemory \ - virNodeGetCellsFreeMemory \ - virStoragePoolGetConnect \ - virConnectNumOfStoragePools \ - virConnectListStoragePools \ - virConnectNumOfDefinedStoragePools \ - virConnectListDefinedStoragePools \ - virStoragePoolLookupByName \ - virStoragePoolLookupByUUID \ - virStoragePoolLookupByUUIDString \ - virStoragePoolLookupByVolume \ - virStoragePoolCreateXML \ - virStoragePoolDefineXML \ - virStoragePoolBuild \ - virStoragePoolUndefine \ - virStoragePoolCreate \ - virStoragePoolDestroy \ - virStoragePoolDelete \ - virStoragePoolFree \ - virStoragePoolRefresh \ - virStoragePoolGetName \ - virStoragePoolGetUUID \ - virStoragePoolGetUUIDString \ - virStoragePoolGetInfo \ - virStoragePoolGetXMLDesc \ - virStoragePoolGetAutostart \ - virStoragePoolSetAutostart \ - virStoragePoolNumOfVolumes \ - virStoragePoolListVolumes \ - virStorageVolLookupByName \ - virStorageVolLookupByKey \ - virStorageVolLookupByPath \ - virStorageVolGetName \ - virStorageVolGetKey \ - virStorageVolCreateXML \ - virStorageVolDelete \ - virStorageVolFree \ - virStorageVolGetInfo \ - virStorageVolGetXMLDesc \ - virStorageVolGetPath \ -]) - -# This jobs API was never published and is due to get overhauled -# in the near future: -# virJobGetInfo -# virJobGetDomain -# virJobGetNetwork -# virJobCancel -# virJobFree -# virDomainCreateLinuxJob -# virDomainSaveJob -# virDomainRestoreJob -# virDomainCoreDumpJob -# virDomainCreateJob -# virNetworkCreateXMLJob -# virNetworkCreateJob - -dnl Check for optional types added since 0.2.1. -AC_CHECK_TYPES([virJobPtr, virStoragePoolPtr, virStorageVolPtr],,, - [#include ]) - -dnl Check for optional ncurses. -AC_CHECK_LIB(ncurses,initscr) - -dnl Check for optional GNOME icons (from gnome-icon-theme package). -AC_ARG_WITH(icons, - AC_HELP_STRING([--with-icons=PATH], - [Set path to installed icons @<:@default=/usr/share/icons@:>@]), - [],[with_icons=/usr/share/icons]) -icons="" -if test "x$with_icons" != "xno"; then - for size in 16 24 32 48; do - for f in devices/computer.png; do - fname="${with_icons}/gnome/${size}x${size}/${f}" - AC_MSG_CHECKING([checking for icon $fname]) - if test -f "$fname"; then - AC_MSG_RESULT([yes]) - icons="$size $f $fname $icons" - else - AC_MSG_RESULT([no]) - fi - done - done -fi -AC_SUBST(with_icons) -AC_SUBST(icons) +AC_INIT(virt-top,1.0.0) dnl Check for basic OCaml environment & findlib. -dnl Note that findlib is not necessary, but things will work better -dnl if it is present. AC_PROG_OCAML AC_PROG_FINDLIB -if test "x$OCAMLFIND" != "x"; then - dnl Use ocamlfind to find the required packages ... - - dnl Check for required OCaml packages. - AC_CHECK_OCAML_PKG(unix) - if test "x$pkg_unix" != "xyes"; then - AC_MSG_ERROR([Cannot find required OCaml package 'unix']) - fi - - dnl Check for optional OCaml packages. - AC_CHECK_OCAML_PKG(extlib) - AC_CHECK_OCAML_PKG(lablgtk2) - AC_CHECK_OCAML_PKG(curses) - AC_CHECK_OCAML_PKG(gettext) - AC_CHECK_OCAML_PKG(xml-light) - AC_CHECK_OCAML_PKG(csv) - AC_CHECK_OCAML_PKG(dbus) - AC_CHECK_OCAML_PKG(gettext) - AC_CHECK_OCAML_PKG(bitmatch) - - dnl Need to check which version of calendar is installed. - AC_CHECK_OCAML_MODULE(calendar,pkg_calendar2,CalendarLib.Date,[+calendar]) - if test "x$pkg_calendar2" = "xno"; then - AC_CHECK_OCAML_PKG(calendar) - fi +if test "x$OCAMLFIND" = "x"; then + AC_MSG_ERROR([OCaml findlib is required]) +fi - AC_SUBST(pkg_unix) - AC_SUBST(pkg_extlib) - AC_SUBST(pkg_lablgtk2) - AC_SUBST(pkg_curses) - AC_SUBST(pkg_gettext) - AC_SUBST(pkg_xml_light) - AC_SUBST(pkg_csv) - AC_SUBST(pkg_dbus) - AC_SUBST(pkg_gettext) - AC_SUBST(pkg_calendar) - AC_SUBST(pkg_calendar2) -else - dnl Use a basic module test if there is no findlib ... +dnl Use ocamlfind to find the required packages ... - dnl Check for required OCaml modules. - AC_CHECK_OCAML_MODULE(unix,pkg_unix,Unix,[.]) - if test "x$pkg_unix" = "xno"; then - AC_MSG_ERROR([Cannot find required OCaml package 'unix']) - fi +dnl Check for required OCaml packages. +AC_CHECK_OCAML_PKG(unix) +if test "x$pkg_unix" != "xyes"; then + AC_MSG_ERROR([Cannot find required OCaml package 'unix']) +fi - dnl Check for optional OCaml modules. - AC_CHECK_OCAML_MODULE(extlib,pkg_extlib,ExtString,[+extlib]) - AC_CHECK_OCAML_MODULE(lablgtk2,pkg_lablgtk2,GMain,[+lablgtk2]) - AC_CHECK_OCAML_MODULE(curses,pkg_curses,Curses,[+curses]) - AC_CHECK_OCAML_MODULE(gettext,pkg_gettext,Gettext,[+gettext]) dnl XXX - AC_CHECK_OCAML_MODULE(xml-light,pkg_xml_light,Xml,[+xml-light]) - AC_CHECK_OCAML_MODULE(csv,pkg_csv,Csv,[+csv]) - AC_CHECK_OCAML_MODULE(dbus,pkg_dbus,DBus,[+dbus]) - AC_CHECK_OCAML_MODULE(gettext,pkg_gettext,Gettext,[+gettext]) - AC_CHECK_OCAML_MODULE(bitmatch,pkg_bitmatch,Bitmatch,[+bitmatch]) - dnl XXX Version check - see above. - AC_CHECK_OCAML_MODULE(calendar,pkg_calendar,Calendar,[+calendar]) +AC_CHECK_OCAML_PKG(extlib) +if test "x$pkg_extlib" != "xyes"; then + AC_MSG_ERROR([Cannot find required OCaml package 'extlib']) fi -dnl Which subpackages (== subdirs) will we build? -subdirs="libvirt examples mlvirsh" -if test "x$pkg_lablgtk2" != "xno"; then - subdirs="$subdirs virt-ctrl" +AC_CHECK_OCAML_PKG(libvirt) +if test "x$pkg_libvirt" != "xyes"; then + AC_MSG_ERROR([Cannot find required OCaml package 'libvirt']) fi -if test "x$pkg_extlib" != "xno" -a "x$pkg_curses" != "xno"; then - subdirs="$subdirs virt-top" + +AC_CHECK_OCAML_PKG(curses) +if test "x$pkg_curses" != "xyes"; then + AC_MSG_ERROR([Cannot find required OCaml package 'curses']) fi -if test "x$pkg_extlib" != "xno" \ - -a "x$pkg_xml_light" != "xno" \ - -a "x$pkg_bitmatch" != "xno"; then - subdirs="$subdirs virt-df" + +dnl Check for optional OCaml packages. +AC_CHECK_OCAML_PKG(gettext) +AC_CHECK_OCAML_PKG(xml-light) +AC_CHECK_OCAML_PKG(csv) + +dnl Need to check which version of calendar is installed. +AC_CHECK_OCAML_MODULE(calendar,pkg_calendar2,CalendarLib.Date,[+calendar]) +if test "x$pkg_calendar2" = "xno"; then + AC_CHECK_OCAML_PKG(calendar) fi -AC_SUBST(subdirs) + +AC_SUBST(pkg_unix) +AC_SUBST(pkg_extlib) +AC_SUBST(pkg_curses) +AC_SUBST(pkg_gettext) +AC_SUBST(pkg_xml_light) +AC_SUBST(pkg_csv) +AC_SUBST(pkg_calendar) +AC_SUBST(pkg_calendar2) dnl Check for optional perldoc (for building manual pages). AC_CHECK_PROG(HAVE_PERLDOC,perldoc,perldoc) -dnl Check for optional gdk-pixbuf-mlsource (for icons). -AC_CHECK_PROG(HAVE_GDK_PIXBUF_MLSOURCE,gdk-pixbuf-mlsource,gdk-pixbuf-mlsource) - dnl Check for recommended ocaml-gettext tool. AC_CHECK_PROG(OCAML_GETTEXT,ocaml-gettext,ocaml-gettext) dnl Check for optional NSIS (for building a Windows installer). +dnl XXX NSIS support is probably broken at the moment XXX AC_ARG_WITH([nsis], [AS_HELP_STRING([--with-nsis], [use NSIS to build a Windows installer])], @@ -351,7 +168,7 @@ AC_SUBST(GTK_PATH) dnl Write gettext modules for the programs. dnl http://www.le-gall.net/sylvain+violaine/documentation/ocaml-gettext/html/reference-manual/ch03s04.html -for d in mlvirsh virt-ctrl virt-df virt-top; do +for d in virt-top; do f=`echo $d | tr - _`_gettext.ml AC_MSG_NOTICE([creating $d/$f]) rm -f $d/$f @@ -388,22 +205,14 @@ done dnl Summary. echo "------------------------------------------------------------" echo "Thanks for downloading" $PACKAGE_STRING -echo " subpackages to build : $subdirs" echo "------------------------------------------------------------" dnl Produce output files. AC_CONFIG_HEADERS([config.h]) -AC_CONFIG_FILES([META - libvirt/libvirt_version.ml - Makefile +AC_CONFIG_FILES([Makefile Make.rules po/Makefile - libvirt/Makefile - examples/Makefile - mlvirsh/Makefile - virt-ctrl/Makefile virt-top/Makefile - virt-df/Makefile ]) if test "x$MAKENSIS" != "x"; then AC_CONFIG_FILES([wininstaller.nsis]) diff --git a/examples/.depend b/examples/.depend deleted file mode 100644 index 334ba5d..0000000 --- a/examples/.depend +++ /dev/null @@ -1,4 +0,0 @@ -list_domains.cmo: ../libvirt/libvirt.cmi -list_domains.cmx: ../libvirt/libvirt.cmx -node_info.cmo: ../libvirt/libvirt.cmi -node_info.cmx: ../libvirt/libvirt.cmx diff --git a/libvirt/.depend b/libvirt/.depend deleted file mode 100644 index 5556d96..0000000 --- a/libvirt/.depend +++ /dev/null @@ -1,4 +0,0 @@ -libvirt.cmo: libvirt.cmi -libvirt.cmx: libvirt.cmi -libvirt_version.cmo: libvirt_version.cmi -libvirt_version.cmx: libvirt_version.cmi diff --git a/mlvirsh/.depend b/mlvirsh/.depend deleted file mode 100644 index 7dbe514..0000000 --- a/mlvirsh/.depend +++ /dev/null @@ -1,2 +0,0 @@ -mlvirsh.cmo: mlvirsh_gettext.cmo ../libvirt/libvirt.cmi -mlvirsh.cmx: mlvirsh_gettext.cmx ../libvirt/libvirt.cmx diff --git a/virt-ctrl/.depend b/virt-ctrl/.depend deleted file mode 100644 index 84ba14c..0000000 --- a/virt-ctrl/.depend +++ /dev/null @@ -1,28 +0,0 @@ -vc_connections.cmi: ../libvirt/libvirt.cmi -vc_domain_ops.cmi: vc_connections.cmi -vc_helpers.cmi: ../libvirt/libvirt.cmi -vc_mainwindow.cmi: vc_domain_ops.cmi -vc_connection_dlg.cmo: virt_ctrl_gettext.cmo vc_connections.cmi \ - vc_connection_dlg.cmi -vc_connection_dlg.cmx: virt_ctrl_gettext.cmx vc_connections.cmx \ - vc_connection_dlg.cmi -vc_connections.cmo: virt_ctrl_gettext.cmo vc_helpers.cmi \ - ../libvirt/libvirt.cmi vc_connections.cmi -vc_connections.cmx: virt_ctrl_gettext.cmx vc_helpers.cmx \ - ../libvirt/libvirt.cmx vc_connections.cmi -vc_dbus.cmo: virt_ctrl_gettext.cmo vc_connection_dlg.cmi vc_dbus.cmi -vc_dbus.cmx: virt_ctrl_gettext.cmx vc_connection_dlg.cmx vc_dbus.cmi -vc_domain_ops.cmo: virt_ctrl_gettext.cmo vc_connections.cmi \ - ../libvirt/libvirt.cmi vc_domain_ops.cmi -vc_domain_ops.cmx: virt_ctrl_gettext.cmx vc_connections.cmx \ - ../libvirt/libvirt.cmx vc_domain_ops.cmi -vc_helpers.cmo: virt_ctrl_gettext.cmo ../libvirt/libvirt.cmi vc_helpers.cmi -vc_helpers.cmx: virt_ctrl_gettext.cmx ../libvirt/libvirt.cmx vc_helpers.cmi -vc_icons.cmo: vc_connection_dlg.cmi -vc_icons.cmx: vc_connection_dlg.cmx -vc_mainwindow.cmo: virt_ctrl_gettext.cmo vc_connections.cmi \ - vc_connection_dlg.cmi ../libvirt/libvirt.cmi vc_mainwindow.cmi -vc_mainwindow.cmx: virt_ctrl_gettext.cmx vc_connections.cmx \ - vc_connection_dlg.cmx ../libvirt/libvirt.cmx vc_mainwindow.cmi -virt_ctrl.cmo: virt_ctrl_gettext.cmo vc_mainwindow.cmi vc_domain_ops.cmi -virt_ctrl.cmx: virt_ctrl_gettext.cmx vc_mainwindow.cmx vc_domain_ops.cmx diff --git a/virt-df/.depend b/virt-df/.depend deleted file mode 100644 index e7cd81e..0000000 --- a/virt-df/.depend +++ /dev/null @@ -1,31 +0,0 @@ -virt_df_lvm2_parser.cmi: virt_df_lvm2_metadata.cmi -virt_df_ext2.cmo: virt_df_gettext.cmo virt_df.cmi \ - /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_ext2.cmi -virt_df_ext2.cmx: virt_df_gettext.cmx virt_df.cmx \ - /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_ext2.cmi -virt_df_linux_swap.cmo: virt_df_gettext.cmo virt_df.cmi \ - /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_linux_swap.cmi -virt_df_linux_swap.cmx: virt_df_gettext.cmx virt_df.cmx \ - /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_linux_swap.cmi -virt_df_lvm2_lexer.cmo: virt_df_lvm2_parser.cmi virt_df.cmi -virt_df_lvm2_lexer.cmx: virt_df_lvm2_parser.cmx virt_df.cmx -virt_df_lvm2_metadata.cmo: virt_df_lvm2_metadata.cmi -virt_df_lvm2_metadata.cmx: virt_df_lvm2_metadata.cmi -virt_df_lvm2.cmo: virt_df_lvm2_metadata.cmi virt_df_lvm2_lexer.cmo \ - virt_df_gettext.cmo virt_df.cmi /usr/lib64/ocaml/bitmatch/bitmatch.cmi \ - virt_df_lvm2.cmi -virt_df_lvm2.cmx: virt_df_lvm2_metadata.cmx virt_df_lvm2_lexer.cmx \ - virt_df_gettext.cmx virt_df.cmx /usr/lib64/ocaml/bitmatch/bitmatch.cmi \ - virt_df_lvm2.cmi -virt_df_lvm2_parser.cmo: virt_df_lvm2_metadata.cmi virt_df_lvm2_parser.cmi -virt_df_lvm2_parser.cmx: virt_df_lvm2_metadata.cmx virt_df_lvm2_parser.cmi -virt_df_main.cmo: virt_df_gettext.cmo virt_df.cmi \ - ../libvirt/libvirt_version.cmi ../libvirt/libvirt.cmi -virt_df_main.cmx: virt_df_gettext.cmx virt_df.cmx \ - ../libvirt/libvirt_version.cmx ../libvirt/libvirt.cmx -virt_df_mbr.cmo: virt_df_gettext.cmo virt_df.cmi \ - /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_mbr.cmi -virt_df_mbr.cmx: virt_df_gettext.cmx virt_df.cmx \ - /usr/lib64/ocaml/bitmatch/bitmatch.cmi virt_df_mbr.cmi -virt_df.cmo: virt_df_gettext.cmo virt_df.cmi -virt_df.cmx: virt_df_gettext.cmx virt_df.cmi diff --git a/virt-top/.depend b/virt-top/.depend index 3a2985d..15e5c48 100644 --- a/virt-top/.depend +++ b/virt-top/.depend @@ -1,20 +1,14 @@ -virt_top.cmi: ../libvirt/libvirt.cmi -virt_top_utils.cmi: ../libvirt/libvirt.cmi virt_top_calendar1.cmo: virt_top_gettext.cmo virt_top.cmi virt_top_calendar1.cmx: virt_top_gettext.cmx virt_top.cmx virt_top_calendar2.cmo: virt_top_gettext.cmo virt_top.cmi virt_top_calendar2.cmx: virt_top_gettext.cmx virt_top.cmx virt_top_csv.cmo: virt_top_gettext.cmo virt_top.cmi virt_top_csv.cmx: virt_top_gettext.cmx virt_top.cmx -virt_top_main.cmo: virt_top_gettext.cmo virt_top.cmi ../libvirt/libvirt.cmi -virt_top_main.cmx: virt_top_gettext.cmx virt_top.cmx ../libvirt/libvirt.cmx -virt_top.cmo: virt_top_utils.cmi virt_top_gettext.cmo \ - ../libvirt/libvirt_version.cmi ../libvirt/libvirt.cmi virt_top.cmi -virt_top.cmx: virt_top_utils.cmx virt_top_gettext.cmx \ - ../libvirt/libvirt_version.cmx ../libvirt/libvirt.cmx virt_top.cmi -virt_top_utils.cmo: virt_top_gettext.cmo ../libvirt/libvirt.cmi \ - virt_top_utils.cmi -virt_top_utils.cmx: virt_top_gettext.cmx ../libvirt/libvirt.cmx \ - virt_top_utils.cmi -virt_top_xml.cmo: virt_top_gettext.cmo virt_top.cmi ../libvirt/libvirt.cmi -virt_top_xml.cmx: virt_top_gettext.cmx virt_top.cmx ../libvirt/libvirt.cmx +virt_top_main.cmo: virt_top_gettext.cmo virt_top.cmi +virt_top_main.cmx: virt_top_gettext.cmx virt_top.cmx +virt_top.cmo: virt_top_utils.cmi virt_top_gettext.cmo virt_top.cmi +virt_top.cmx: virt_top_utils.cmx virt_top_gettext.cmx virt_top.cmi +virt_top_utils.cmo: virt_top_gettext.cmo virt_top_utils.cmi +virt_top_utils.cmx: virt_top_gettext.cmx virt_top_utils.cmi +virt_top_xml.cmo: virt_top_gettext.cmo virt_top.cmi +virt_top_xml.cmx: virt_top_gettext.cmx virt_top.cmx diff --git a/virt-top/Makefile.in b/virt-top/Makefile.in index 390fc1b..e471f93 100755 --- a/virt-top/Makefile.in +++ b/virt-top/Makefile.in @@ -32,7 +32,7 @@ pkg_calendar = @pkg_calendar@ pkg_calendar2 = @pkg_calendar2@ pkg_gettext = @pkg_gettext@ -OCAMLCPACKAGES := -package unix,extlib,curses,str +OCAMLCPACKAGES := -package unix,extlib,curses,str,libvirt ifeq ($(pkg_gettext),yes) OCAMLCPACKAGES += -package gettext-stub @@ -59,7 +59,6 @@ OBJS += virt_top_main.cmo XOBJS := $(OBJS:.cmo=.cmx) -OCAMLCPACKAGES += -I ../libvirt OCAMLCFLAGS := -g -w s OCAMLCLIBS := -linkpkg @@ -67,9 +66,6 @@ OCAMLOPTPACKAGES := $(OCAMLCPACKAGES) OCAMLOPTFLAGS := -w s OCAMLOPTLIBS := $(OCAMLCLIBS) -export LIBRARY_PATH=../libvirt -export LD_LIBRARY_PATH=../libvirt - BYTE_TARGETS := virt-top OPT_TARGETS := virt-top.opt @@ -82,13 +78,12 @@ all: $(BYTE_TARGETS) opt: $(OPT_TARGETS) virt-top: $(OBJS) - ocamlfind ocamlc $(OCAMLCPACKAGES) $(OCAMLCFLAGS) $(OCAMLCLIBS) \ - ../libvirt/mllibvirt.cma -o $@ $^ + ocamlfind ocamlc $(OCAMLCPACKAGES) $(OCAMLCFLAGS) $(OCAMLCLIBS) -o $@ $^ virt-top.opt: $(XOBJS) ocamlfind ocamlopt \ $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \ - ../libvirt/mllibvirt.cmxa -cclib -lncurses -o $@ $^ + -cclib -lncurses -o $@ $^ # Manual page. ifeq ($(HAVE_PERLDOC),perldoc) -- cgit v1.1 From 90b69a9eb1f598d032da9eaff68e6c0aeb23e10d Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Wed, 16 Apr 2008 14:12:12 +0100 Subject: Remove META file. --- META.in | 5 ----- 1 file changed, 5 deletions(-) delete mode 100755 META.in diff --git a/META.in b/META.in deleted file mode 100755 index 960e07e..0000000 --- a/META.in +++ /dev/null @@ -1,5 +0,0 @@ -name="libvirt" -version="@PACKAGE_VERSION@" -description="libvirt bindings for OCaml" -archive(byte)="mllibvirt.cma" -archive(native)="mllibvirt.cmxa" -- cgit v1.1 From f5f45d38269842b591a89ccaf2e6af7879d57aab Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Wed, 16 Apr 2008 14:14:07 +0100 Subject: Readded AC_PROG_INSTALL. --- configure.ac | 2 ++ 1 file changed, 2 insertions(+) diff --git a/configure.ac b/configure.ac index 14314f3..fd9e10c 100644 --- a/configure.ac +++ b/configure.ac @@ -19,6 +19,8 @@ dnl Process this file with autoconf to produce a configure script. AC_INIT(virt-top,1.0.0) +AC_PROG_INSTALL + dnl Check for basic OCaml environment & findlib. AC_PROG_OCAML AC_PROG_FINDLIB -- cgit v1.1