Initial import from CVS.
authorrjones@localhost <rjones@localhost>
Thu, 30 Aug 2007 16:38:09 +0000 (17:38 +0100)
committerrjones@localhost <rjones@localhost>
Thu, 30 Aug 2007 16:38:09 +0000 (17:38 +0100)
59 files changed:
.cvsignore [new file with mode: 0644]
COPYING [new file with mode: 0644]
COPYING.LIB [new file with mode: 0644]
MANIFEST [new file with mode: 0644]
META.in [new file with mode: 0644]
Make.rules [new file with mode: 0644]
Makefile.in [new file with mode: 0644]
README [new file with mode: 0644]
TODO.libvirt [new file with mode: 0644]
TODO.virt-top [new file with mode: 0644]
aclocal.m4 [new file with mode: 0644]
config.h.in [new file with mode: 0644]
configure.ac [new file with mode: 0644]
examples/.cvsignore [new file with mode: 0644]
examples/.depend [new file with mode: 0644]
examples/Makefile [new file with mode: 0644]
examples/Makefile.in [new file with mode: 0644]
examples/list_domains.ml [new file with mode: 0644]
install-sh [new file with mode: 0755]
libvirt/.cvsignore [new file with mode: 0644]
libvirt/.depend [new file with mode: 0644]
libvirt/Makefile [new file with mode: 0644]
libvirt/Makefile.in [new file with mode: 0644]
libvirt/libvirt.ml [new file with mode: 0644]
libvirt/libvirt.mli [new file with mode: 0644]
libvirt/libvirt_c.c [new file with mode: 0644]
libvirt/libvirt_version.ml [new file with mode: 0644]
libvirt/libvirt_version.ml.in [new file with mode: 0644]
libvirt/libvirt_version.mli [new file with mode: 0644]
mlvirsh/.cvsignore [new file with mode: 0644]
mlvirsh/.depend [new file with mode: 0644]
mlvirsh/Makefile [new file with mode: 0644]
mlvirsh/Makefile.in [new file with mode: 0644]
mlvirsh/mlvirsh.ml [new file with mode: 0644]
mlvirtmanager/.cvsignore [new file with mode: 0644]
mlvirtmanager/.depend [new file with mode: 0644]
mlvirtmanager/Makefile [new file with mode: 0644]
mlvirtmanager/Makefile.in [new file with mode: 0644]
mlvirtmanager/mlvirtmanager.ml [new file with mode: 0644]
mlvirtmanager/mlvirtmanager_connections.ml [new file with mode: 0644]
mlvirtmanager/mlvirtmanager_connections.mli [new file with mode: 0644]
mlvirtmanager/mlvirtmanager_domain_ops.ml [new file with mode: 0644]
mlvirtmanager/mlvirtmanager_domain_ops.mli [new file with mode: 0644]
mlvirtmanager/mlvirtmanager_helpers.ml [new file with mode: 0644]
mlvirtmanager/mlvirtmanager_helpers.mli [new file with mode: 0644]
mlvirtmanager/mlvirtmanager_mainwindow.ml [new file with mode: 0644]
mlvirtmanager/mlvirtmanager_mainwindow.mli [new file with mode: 0644]
virt-top/.cvsignore [new file with mode: 0644]
virt-top/.depend [new file with mode: 0644]
virt-top/Makefile [new file with mode: 0644]
virt-top/Makefile.in [new file with mode: 0644]
virt-top/README [new file with mode: 0644]
virt-top/virt-top.1 [new file with mode: 0644]
virt-top/virt-top.pod [new file with mode: 0644]
virt-top/virt-top.txt [new file with mode: 0644]
virt-top/virt_top.ml [new file with mode: 0644]
virt-top/virt_top_csv.ml [new file with mode: 0644]
virt-top/virt_top_main.ml [new file with mode: 0644]
virt-top/virt_top_xml.ml [new file with mode: 0644]

diff --git a/.cvsignore b/.cvsignore
new file mode 100644 (file)
index 0000000..01289d4
--- /dev/null
@@ -0,0 +1,11 @@
+META
+ocaml-libvirt-*.tar.gz
+html
+configure
+config.log
+config.status
+config.h
+Makefile
+autom4te.cache
+core
+core.*
\ No newline at end of file
diff --git a/COPYING b/COPYING
new file mode 100644 (file)
index 0000000..e77696a
--- /dev/null
+++ b/COPYING
@@ -0,0 +1,339 @@
+                   GNU GENERAL PUBLIC LICENSE
+                      Version 2, June 1991
+
+ Copyright (C) 1989, 1991 Free Software Foundation, Inc.
+                          675 Mass Ave, Cambridge, MA 02139, USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+                           Preamble
+
+  The licenses for most software are designed to take away your
+freedom to share and change it.  By contrast, the GNU General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users.  This
+General Public License applies to most of the Free Software
+Foundation's software and to any other program whose authors commit to
+using it.  (Some other Free Software Foundation software is covered by
+the GNU Library General Public License instead.)  You can apply it to
+your programs, too.
+
+  When we speak of free software, we are referring to freedom, not
+price.  Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+this service if you wish), that you receive source code or can get it
+if you want it, that you can change the software or use pieces of it
+in new free programs; and that you know you can do these things.
+
+  To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+  For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have.  You must make sure that they, too, receive or can get the
+source code.  And you must show them these terms so they know their
+rights.
+
+  We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+  Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software.  If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+  Finally, any free program is threatened constantly by software
+patents.  We wish to avoid the danger that redistributors of a free
+program will individually obtain patent licenses, in effect making the
+program proprietary.  To prevent this, we have made it clear that any
+patent must be licensed for everyone's free use or not licensed at all.
+
+  The precise terms and conditions for copying, distribution and
+modification follow.
+\f
+                   GNU GENERAL PUBLIC LICENSE
+   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+  0. This License applies to any program or other work which contains
+a notice placed by the copyright holder saying it may be distributed
+under the terms of this General Public License.  The "Program", below,
+refers to any such program or work, and a "work based on the Program"
+means either the Program or any derivative work under copyright law:
+that is to say, a work containing the Program or a portion of it,
+either verbatim or with modifications and/or translated into another
+language.  (Hereinafter, translation is included without limitation in
+the term "modification".)  Each licensee is addressed as "you".
+
+Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope.  The act of
+running the Program is not restricted, and the output from the Program
+is covered only if its contents constitute a work based on the
+Program (independent of having been made by running the Program).
+Whether that is true depends on what the Program does.
+
+  1. You may copy and distribute verbatim copies of the Program's
+source code as you receive it, in any medium, provided that you
+conspicuously and appropriately publish on each copy an appropriate
+copyright notice and disclaimer of warranty; keep intact all the
+notices that refer to this License and to the absence of any warranty;
+and give any other recipients of the Program a copy of this License
+along with the Program.
+
+You may charge a fee for the physical act of transferring a copy, and
+you may at your option offer warranty protection in exchange for a fee.
+
+  2. You may modify your copy or copies of the Program or any portion
+of it, thus forming a work based on the Program, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+
+    a) You must cause the modified files to carry prominent notices
+    stating that you changed the files and the date of any change.
+
+    b) You must cause any work that you distribute or publish, that in
+    whole or in part contains or is derived from the Program or any
+    part thereof, to be licensed as a whole at no charge to all third
+    parties under the terms of this License.
+
+    c) If the modified program normally reads commands interactively
+    when run, you must cause it, when started running for such
+    interactive use in the most ordinary way, to print or display an
+    announcement including an appropriate copyright notice and a
+    notice that there is no warranty (or else, saying that you provide
+    a warranty) and that users may redistribute the program under
+    these conditions, and telling the user how to view a copy of this
+    License.  (Exception: if the Program itself is interactive but
+    does not normally print such an announcement, your work based on
+    the Program is not required to print an announcement.)
+\f
+These requirements apply to the modified work as a whole.  If
+identifiable sections of that work are not derived from the Program,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works.  But when you
+distribute the same sections as part of a whole which is a work based
+on the Program, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote it.
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Program.
+
+In addition, mere aggregation of another work not based on the Program
+with the Program (or with a work based on the Program) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+  3. You may copy and distribute the Program (or a work based on it,
+under Section 2) in object code or executable form under the terms of
+Sections 1 and 2 above provided that you also do one of the following:
+
+    a) Accompany it with the complete corresponding machine-readable
+    source code, which must be distributed under the terms of Sections
+    1 and 2 above on a medium customarily used for software interchange; or,
+
+    b) Accompany it with a written offer, valid for at least three
+    years, to give any third party, for a charge no more than your
+    cost of physically performing source distribution, a complete
+    machine-readable copy of the corresponding source code, to be
+    distributed under the terms of Sections 1 and 2 above on a medium
+    customarily used for software interchange; or,
+
+    c) Accompany it with the information you received as to the offer
+    to distribute corresponding source code.  (This alternative is
+    allowed only for noncommercial distribution and only if you
+    received the program in object code or executable form with such
+    an offer, in accord with Subsection b above.)
+
+The source code for a work means the preferred form of the work for
+making modifications to it.  For an executable work, complete source
+code means all the source code for all modules it contains, plus any
+associated interface definition files, plus the scripts used to
+control compilation and installation of the executable.  However, as a
+special exception, the source code distributed need not include
+anything that is normally distributed (in either source or binary
+form) with the major components (compiler, kernel, and so on) of the
+operating system on which the executable runs, unless that component
+itself accompanies the executable.
+
+If distribution of executable or object code is made by offering
+access to copy from a designated place, then offering equivalent
+access to copy the source code from the same place counts as
+distribution of the source code, even though third parties are not
+compelled to copy the source along with the object code.
+\f
+  4. You may not copy, modify, sublicense, or distribute the Program
+except as expressly provided under this License.  Any attempt
+otherwise to copy, modify, sublicense or distribute the Program is
+void, and will automatically terminate your rights under this License.
+However, parties who have received copies, or rights, from you under
+this License will not have their licenses terminated so long as such
+parties remain in full compliance.
+
+  5. You are not required to accept this License, since you have not
+signed it.  However, nothing else grants you permission to modify or
+distribute the Program or its derivative works.  These actions are
+prohibited by law if you do not accept this License.  Therefore, by
+modifying or distributing the Program (or any work based on the
+Program), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Program or works based on it.
+
+  6. Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the
+original licensor to copy, distribute or modify the Program subject to
+these terms and conditions.  You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties to
+this License.
+
+  7. If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License.  If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Program at all.  For example, if a patent
+license would not permit royalty-free redistribution of the Program by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Program.
+
+If any portion of this section is held invalid or unenforceable under
+any particular circumstance, the balance of the section is intended to
+apply and the section as a whole is intended to apply in other
+circumstances.
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system, which is
+implemented by public license practices.  Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+\f
+  8. If the distribution and/or use of the Program is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Program under this License
+may add an explicit geographical distribution limitation excluding
+those countries, so that distribution is permitted only in or among
+countries not thus excluded.  In such case, this License incorporates
+the limitation as if written in the body of this License.
+
+  9. The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time.  Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+Each version is given a distinguishing version number.  If the Program
+specifies a version number of this License which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation.  If the Program does not specify a version number of
+this License, you may choose any version ever published by the Free Software
+Foundation.
+
+  10. If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission.  For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this.  Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+                           NO WARRANTY
+
+  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+                    END OF TERMS AND CONDITIONS
+\f
+           How to Apply These Terms to Your New Programs
+
+  If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+  To do so, attach the following notices to the program.  It is safest
+to attach them to the start of each source file to most effectively
+convey the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+    <one line to give the program's name and a brief idea of what it does.>
+    Copyright (C) 19yy  <name of author>
+
+    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.
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+    Gnomovision version 69, Copyright (C) 19yy name of author
+    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+    This is free software, and you are welcome to redistribute it
+    under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License.  Of course, the commands you use may
+be called something other than `show w' and `show c'; they could even be
+mouse-clicks or menu items--whatever suits your program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary.  Here is a sample; alter the names:
+
+  Yoyodyne, Inc., hereby disclaims all copyright interest in the program
+  `Gnomovision' (which makes passes at compilers) written by James Hacker.
+
+  <signature of Ty Coon>, 1 April 1989
+  Ty Coon, President of Vice
+
+This General Public License does not permit incorporating your program into
+proprietary programs.  If your program is a subroutine library, you may
+consider it more useful to permit linking proprietary applications with the
+library.  If this is what you want to do, use the GNU Library General
+Public License instead of this License.
diff --git a/COPYING.LIB b/COPYING.LIB
new file mode 100644 (file)
index 0000000..ba2be48
--- /dev/null
@@ -0,0 +1,515 @@
+
+                  GNU LESSER GENERAL PUBLIC LICENSE
+                       Version 2.1, February 1999
+
+ Copyright (C) 1991, 1999 Free Software Foundation, Inc.
+     51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+[This is the first released version of the Lesser GPL.  It also counts
+ as the successor of the GNU Library Public License, version 2, hence
+ the version number 2.1.]
+
+                            Preamble
+
+  The licenses for most software are designed to take away your
+freedom to share and change it.  By contrast, the GNU General Public
+Licenses are intended to guarantee your freedom to share and change
+free software--to make sure the software is free for all its users.
+
+  This license, the Lesser General Public License, applies to some
+specially designated software packages--typically libraries--of the
+Free Software Foundation and other authors who decide to use it.  You
+can use it too, but we suggest you first think carefully about whether
+this license or the ordinary General Public License is the better
+strategy to use in any particular case, based on the explanations
+below.
+
+  When we speak of free software, we are referring to freedom of use,
+not price.  Our General Public Licenses are designed to make sure that
+you have the freedom to distribute copies of free software (and charge
+for this service if you wish); that you receive source code or can get
+it if you want it; that you can change the software and use pieces of
+it in new free programs; and that you are informed that you can do
+these things.
+
+  To protect your rights, we need to make restrictions that forbid
+distributors to deny you these rights or to ask you to surrender these
+rights.  These restrictions translate to certain responsibilities for
+you if you distribute copies of the library or if you modify it.
+
+  For example, if you distribute copies of the library, whether gratis
+or for a fee, you must give the recipients all the rights that we gave
+you.  You must make sure that they, too, receive or can get the source
+code.  If you link other code with the library, you must provide
+complete object files to the recipients, so that they can relink them
+with the library after making changes to the library and recompiling
+it.  And you must show them these terms so they know their rights.
+
+  We protect your rights with a two-step method: (1) we copyright the
+library, and (2) we offer you this license, which gives you legal
+permission to copy, distribute and/or modify the library.
+
+  To protect each distributor, we want to make it very clear that
+there is no warranty for the free library.  Also, if the library is
+modified by someone else and passed on, the recipients should know
+that what they have is not the original version, so that the original
+author's reputation will not be affected by problems that might be
+introduced by others.
+^L
+  Finally, software patents pose a constant threat to the existence of
+any free program.  We wish to make sure that a company cannot
+effectively restrict the users of a free program by obtaining a
+restrictive license from a patent holder.  Therefore, we insist that
+any patent license obtained for a version of the library must be
+consistent with the full freedom of use specified in this license.
+
+  Most GNU software, including some libraries, is covered by the
+ordinary GNU General Public License.  This license, the GNU Lesser
+General Public License, applies to certain designated libraries, and
+is quite different from the ordinary General Public License.  We use
+this license for certain libraries in order to permit linking those
+libraries into non-free programs.
+
+  When a program is linked with a library, whether statically or using
+a shared library, the combination of the two is legally speaking a
+combined work, a derivative of the original library.  The ordinary
+General Public License therefore permits such linking only if the
+entire combination fits its criteria of freedom.  The Lesser General
+Public License permits more lax criteria for linking other code with
+the library.
+
+  We call this license the "Lesser" General Public License because it
+does Less to protect the user's freedom than the ordinary General
+Public License.  It also provides other free software developers Less
+of an advantage over competing non-free programs.  These disadvantages
+are the reason we use the ordinary General Public License for many
+libraries.  However, the Lesser license provides advantages in certain
+special circumstances.
+
+  For example, on rare occasions, there may be a special need to
+encourage the widest possible use of a certain library, so that it
+becomes
+a de-facto standard.  To achieve this, non-free programs must be
+allowed to use the library.  A more frequent case is that a free
+library does the same job as widely used non-free libraries.  In this
+case, there is little to gain by limiting the free library to free
+software only, so we use the Lesser General Public License.
+
+  In other cases, permission to use a particular library in non-free
+programs enables a greater number of people to use a large body of
+free software.  For example, permission to use the GNU C Library in
+non-free programs enables many more people to use the whole GNU
+operating system, as well as its variant, the GNU/Linux operating
+system.
+
+  Although the Lesser General Public License is Less protective of the
+users' freedom, it does ensure that the user of a program that is
+linked with the Library has the freedom and the wherewithal to run
+that program using a modified version of the Library.
+
+  The precise terms and conditions for copying, distribution and
+modification follow.  Pay close attention to the difference between a
+"work based on the library" and a "work that uses the library".  The
+former contains code derived from the library, whereas the latter must
+be combined with the library in order to run.
+^L
+                  GNU LESSER GENERAL PUBLIC LICENSE
+   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+  0. This License Agreement applies to any software library or other
+program which contains a notice placed by the copyright holder or
+other authorized party saying it may be distributed under the terms of
+this Lesser General Public License (also called "this License").
+Each licensee is addressed as "you".
+
+  A "library" means a collection of software functions and/or data
+prepared so as to be conveniently linked with application programs
+(which use some of those functions and data) to form executables.
+
+  The "Library", below, refers to any such software library or work
+which has been distributed under these terms.  A "work based on the
+Library" means either the Library or any derivative work under
+copyright law: that is to say, a work containing the Library or a
+portion of it, either verbatim or with modifications and/or translated
+straightforwardly into another language.  (Hereinafter, translation is
+included without limitation in the term "modification".)
+
+  "Source code" for a work means the preferred form of the work for
+making modifications to it.  For a library, complete source code means
+all the source code for all modules it contains, plus any associated
+interface definition files, plus the scripts used to control
+compilation
+and installation of the library.
+
+  Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope.  The act of
+running a program using the Library is not restricted, and output from
+such a program is covered only if its contents constitute a work based
+on the Library (independent of the use of the Library in a tool for
+writing it).  Whether that is true depends on what the Library does
+and what the program that uses the Library does.
+
+  1. You may copy and distribute verbatim copies of the Library's
+complete source code as you receive it, in any medium, provided that
+you conspicuously and appropriately publish on each copy an
+appropriate copyright notice and disclaimer of warranty; keep intact
+all the notices that refer to this License and to the absence of any
+warranty; and distribute a copy of this License along with the
+Library.
+
+  You may charge a fee for the physical act of transferring a copy,
+and you may at your option offer warranty protection in exchange for a
+fee.
+\f
+  2. You may modify your copy or copies of the Library or any portion
+of it, thus forming a work based on the Library, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+
+    a) The modified work must itself be a software library.
+
+    b) You must cause the files modified to carry prominent notices
+    stating that you changed the files and the date of any change.
+
+    c) You must cause the whole of the work to be licensed at no
+    charge to all third parties under the terms of this License.
+
+    d) If a facility in the modified Library refers to a function or a
+    table of data to be supplied by an application program that uses
+    the facility, other than as an argument passed when the facility
+    is invoked, then you must make a good faith effort to ensure that,
+    in the event an application does not supply such function or
+    table, the facility still operates, and performs whatever part of
+    its purpose remains meaningful.
+
+    (For example, a function in a library to compute square roots has
+    a purpose that is entirely well-defined independent of the
+    application.  Therefore, Subsection 2d requires that any
+    application-supplied function or table used by this function must
+    be optional: if the application does not supply it, the square
+    root function must still compute square roots.)
+
+These requirements apply to the modified work as a whole.  If
+identifiable sections of that work are not derived from the Library,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works.  But when you
+distribute the same sections as part of a whole which is a work based
+on the Library, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote
+it.
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Library.
+
+In addition, mere aggregation of another work not based on the Library
+with the Library (or with a work based on the Library) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+  3. You may opt to apply the terms of the ordinary GNU General Public
+License instead of this License to a given copy of the Library.  To do
+this, you must alter all the notices that refer to this License, so
+that they refer to the ordinary GNU General Public License, version 2,
+instead of to this License.  (If a newer version than version 2 of the
+ordinary GNU General Public License has appeared, then you can specify
+that version instead if you wish.)  Do not make any other change in
+these notices.
+^L
+  Once this change is made in a given copy, it is irreversible for
+that copy, so the ordinary GNU General Public License applies to all
+subsequent copies and derivative works made from that copy.
+
+  This option is useful when you wish to copy part of the code of
+the Library into a program that is not a library.
+
+  4. You may copy and distribute the Library (or a portion or
+derivative of it, under Section 2) in object code or executable form
+under the terms of Sections 1 and 2 above provided that you accompany
+it with the complete corresponding machine-readable source code, which
+must be distributed under the terms of Sections 1 and 2 above on a
+medium customarily used for software interchange.
+
+  If distribution of object code is made by offering access to copy
+from a designated place, then offering equivalent access to copy the
+source code from the same place satisfies the requirement to
+distribute the source code, even though third parties are not
+compelled to copy the source along with the object code.
+
+  5. A program that contains no derivative of any portion of the
+Library, but is designed to work with the Library by being compiled or
+linked with it, is called a "work that uses the Library".  Such a
+work, in isolation, is not a derivative work of the Library, and
+therefore falls outside the scope of this License.
+
+  However, linking a "work that uses the Library" with the Library
+creates an executable that is a derivative of the Library (because it
+contains portions of the Library), rather than a "work that uses the
+library".  The executable is therefore covered by this License.
+Section 6 states terms for distribution of such executables.
+
+  When a "work that uses the Library" uses material from a header file
+that is part of the Library, the object code for the work may be a
+derivative work of the Library even though the source code is not.
+Whether this is true is especially significant if the work can be
+linked without the Library, or if the work is itself a library.  The
+threshold for this to be true is not precisely defined by law.
+
+  If such an object file uses only numerical parameters, data
+structure layouts and accessors, and small macros and small inline
+functions (ten lines or less in length), then the use of the object
+file is unrestricted, regardless of whether it is legally a derivative
+work.  (Executables containing this object code plus portions of the
+Library will still fall under Section 6.)
+
+  Otherwise, if the work is a derivative of the Library, you may
+distribute the object code for the work under the terms of Section 6.
+Any executables containing that work also fall under Section 6,
+whether or not they are linked directly with the Library itself.
+^L
+  6. As an exception to the Sections above, you may also combine or
+link a "work that uses the Library" with the Library to produce a
+work containing portions of the Library, and distribute that work
+under terms of your choice, provided that the terms permit
+modification of the work for the customer's own use and reverse
+engineering for debugging such modifications.
+
+  You must give prominent notice with each copy of the work that the
+Library is used in it and that the Library and its use are covered by
+this License.  You must supply a copy of this License.  If the work
+during execution displays copyright notices, you must include the
+copyright notice for the Library among them, as well as a reference
+directing the user to the copy of this License.  Also, you must do one
+of these things:
+
+    a) Accompany the work with the complete corresponding
+    machine-readable source code for the Library including whatever
+    changes were used in the work (which must be distributed under
+    Sections 1 and 2 above); and, if the work is an executable linked
+    with the Library, with the complete machine-readable "work that
+    uses the Library", as object code and/or source code, so that the
+    user can modify the Library and then relink to produce a modified
+    executable containing the modified Library.  (It is understood
+    that the user who changes the contents of definitions files in the
+    Library will not necessarily be able to recompile the application
+    to use the modified definitions.)
+
+    b) Use a suitable shared library mechanism for linking with the
+    Library.  A suitable mechanism is one that (1) uses at run time a
+    copy of the library already present on the user's computer system,
+    rather than copying library functions into the executable, and (2)
+    will operate properly with a modified version of the library, if
+    the user installs one, as long as the modified version is
+    interface-compatible with the version that the work was made with.
+
+    c) Accompany the work with a written offer, valid for at
+    least three years, to give the same user the materials
+    specified in Subsection 6a, above, for a charge no more
+    than the cost of performing this distribution.
+
+    d) If distribution of the work is made by offering access to copy
+    from a designated place, offer equivalent access to copy the above
+    specified materials from the same place.
+
+    e) Verify that the user has already received a copy of these
+    materials or that you have already sent this user a copy.
+
+  For an executable, the required form of the "work that uses the
+Library" must include any data and utility programs needed for
+reproducing the executable from it.  However, as a special exception,
+the materials to be distributed need not include anything that is
+normally distributed (in either source or binary form) with the major
+components (compiler, kernel, and so on) of the operating system on
+which the executable runs, unless that component itself accompanies
+the executable.
+
+  It may happen that this requirement contradicts the license
+restrictions of other proprietary libraries that do not normally
+accompany the operating system.  Such a contradiction means you cannot
+use both them and the Library together in an executable that you
+distribute.
+^L
+  7. You may place library facilities that are a work based on the
+Library side-by-side in a single library together with other library
+facilities not covered by this License, and distribute such a combined
+library, provided that the separate distribution of the work based on
+the Library and of the other library facilities is otherwise
+permitted, and provided that you do these two things:
+
+    a) Accompany the combined library with a copy of the same work
+    based on the Library, uncombined with any other library
+    facilities.  This must be distributed under the terms of the
+    Sections above.
+
+    b) Give prominent notice with the combined library of the fact
+    that part of it is a work based on the Library, and explaining
+    where to find the accompanying uncombined form of the same work.
+
+  8. You may not copy, modify, sublicense, link with, or distribute
+the Library except as expressly provided under this License.  Any
+attempt otherwise to copy, modify, sublicense, link with, or
+distribute the Library is void, and will automatically terminate your
+rights under this License.  However, parties who have received copies,
+or rights, from you under this License will not have their licenses
+terminated so long as such parties remain in full compliance.
+
+  9. You are not required to accept this License, since you have not
+signed it.  However, nothing else grants you permission to modify or
+distribute the Library or its derivative works.  These actions are
+prohibited by law if you do not accept this License.  Therefore, by
+modifying or distributing the Library (or any work based on the
+Library), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Library or works based on it.
+
+  10. Each time you redistribute the Library (or any work based on the
+Library), the recipient automatically receives a license from the
+original licensor to copy, distribute, link with or modify the Library
+subject to these terms and conditions.  You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties with
+this License.
+^L
+  11. If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License.  If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Library at all.  For example, if a patent
+license would not permit royalty-free redistribution of the Library by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Library.
+
+If any portion of this section is held invalid or unenforceable under
+any particular circumstance, the balance of the section is intended to
+apply, and the section as a whole is intended to apply in other
+circumstances.
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system which is
+implemented by public license practices.  Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+
+  12. If the distribution and/or use of the Library is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Library under this License
+may add an explicit geographical distribution limitation excluding those
+countries, so that distribution is permitted only in or among
+countries not thus excluded.  In such case, this License incorporates
+the limitation as if written in the body of this License.
+
+  13. The Free Software Foundation may publish revised and/or new
+versions of the Lesser General Public License from time to time.
+Such new versions will be similar in spirit to the present version,
+but may differ in detail to address new problems or concerns.
+
+Each version is given a distinguishing version number.  If the Library
+specifies a version number of this License which applies to it and
+"any later version", you have the option of following the terms and
+conditions either of that version or of any later version published by
+the Free Software Foundation.  If the Library does not specify a
+license version number, you may choose any version ever published by
+the Free Software Foundation.
+^L
+  14. If you wish to incorporate parts of the Library into other free
+programs whose distribution conditions are incompatible with these,
+write to the author to ask for permission.  For software which is
+copyrighted by the Free Software Foundation, write to the Free
+Software Foundation; we sometimes make exceptions for this.  Our
+decision will be guided by the two goals of preserving the free status
+of all derivatives of our free software and of promoting the sharing
+and reuse of software generally.
+
+                            NO WARRANTY
+
+  15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO
+WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.
+EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR
+OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY
+KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
+LIBRARY IS WITH YOU.  SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME
+THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
+
+  16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN
+WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY
+AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU
+FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR
+CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE
+LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
+RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
+FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
+SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH
+DAMAGES.
+
+                     END OF TERMS AND CONDITIONS
+^L
+           How to Apply These Terms to Your New Libraries
+
+  If you develop a new library, and you want it to be of the greatest
+possible use to the public, we recommend making it free software that
+everyone can redistribute and change.  You can do so by permitting
+redistribution under these terms (or, alternatively, under the terms
+of the ordinary General Public License).
+
+  To apply these terms, attach the following notices to the library.
+It is safest to attach them to the start of each source file to most
+effectively convey the exclusion of warranty; and each file should
+have at least the "copyright" line and a pointer to where the full
+notice is found.
+
+
+    <one line to give the library's name and a brief idea of what it
+does.>
+    Copyright (C) <year>  <name of author>
+
+    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
+
+Also add information on how to contact you by electronic and paper
+mail.
+
+You should also get your employer (if you work as a programmer) or
+your
+school, if any, to sign a "copyright disclaimer" for the library, if
+necessary.  Here is a sample; alter the names:
+
+  Yoyodyne, Inc., hereby disclaims all copyright interest in the
+  library `Frob' (a library for tweaking knobs) written by James
+Random Hacker.
+
+  <signature of Ty Coon>, 1 April 1990
+  Ty Coon, President of Vice
+
+That's all there is to it!
+
+
diff --git a/MANIFEST b/MANIFEST
new file mode 100644 (file)
index 0000000..fde3b73
--- /dev/null
+++ b/MANIFEST
@@ -0,0 +1,53 @@
+aclocal.m4
+config.h.in
+configure.ac
+COPYING
+COPYING.LIB
+.cvsignore
+examples/.cvsignore
+examples/.depend
+examples/list_domains.ml
+examples/Makefile.in
+install-sh
+libvirt/.cvsignore
+libvirt/.depend
+libvirt/libvirt_c.c
+libvirt/libvirt.ml
+libvirt/libvirt.mli
+libvirt/libvirt_version.ml.in
+libvirt/libvirt_version.mli
+libvirt/Makefile.in
+Makefile.in
+Make.rules
+MANIFEST
+META.in
+mlvirsh/.cvsignore
+mlvirsh/.depend
+mlvirsh/Makefile.in
+mlvirsh/mlvirsh.ml
+mlvirtmanager/.cvsignore
+mlvirtmanager/.depend
+mlvirtmanager/Makefile.in
+mlvirtmanager/mlvirtmanager_connections.ml
+mlvirtmanager/mlvirtmanager_connections.mli
+mlvirtmanager/mlvirtmanager_domain_ops.ml
+mlvirtmanager/mlvirtmanager_domain_ops.mli
+mlvirtmanager/mlvirtmanager_helpers.ml
+mlvirtmanager/mlvirtmanager_helpers.mli
+mlvirtmanager/mlvirtmanager_mainwindow.ml
+mlvirtmanager/mlvirtmanager_mainwindow.mli
+mlvirtmanager/mlvirtmanager.ml
+README
+TODO.libvirt
+TODO.virt-top
+virt-top/.cvsignore
+virt-top/.depend
+virt-top/Makefile.in
+virt-top/README
+virt-top/virt-top.1
+virt-top/virt-top.pod
+virt-top/virt-top.txt
+virt-top/virt_top.ml
+virt-top/virt_top_csv.ml
+virt-top/virt_top_main.ml
+virt-top/virt_top_xml.ml
diff --git a/META.in b/META.in
new file mode 100644 (file)
index 0000000..960e07e
--- /dev/null
+++ b/META.in
@@ -0,0 +1,5 @@
+name="libvirt"
+version="@PACKAGE_VERSION@"
+description="libvirt bindings for OCaml"
+archive(byte)="mllibvirt.cma"
+archive(native)="mllibvirt.cmxa"
diff --git a/Make.rules b/Make.rules
new file mode 100644 (file)
index 0000000..00480c3
--- /dev/null
@@ -0,0 +1,27 @@
+# $Id: Make.rules,v 1.2 2007/08/08 08:34:42 rjones Exp $ -*- Makefile -*-
+# This file is included by Makefiles in subdirectories.
+
+# Common rules for building OCaml objects.
+
+.mli.cmi:
+       ocamlfind ocamlc $(OCAMLCFLAGS) $(OCAMLCINCS) $(OCAMLCPACKAGES) -c $<
+.ml.cmo:
+       ocamlfind ocamlc $(OCAMLCFLAGS) $(OCAMLCINCS) $(OCAMLCPACKAGES) -c $<
+.ml.cmx:
+       ocamlfind ocamlopt $(OCAMLOPTFLAGS) $(OCAMLOPTINCS) $(OCAMLOPTPACKAGES) -c $<
+
+# Dependencies.
+
+depend: .depend
+
+.depend: $(wildcard *.mli) $(wildcard *.ml)
+       rm -f .depend
+       ocamlfind ocamldep $(OCAMLCPACKAGES) $^ > $@
+
+ifeq ($(wildcard .depend),.depend)
+include .depend
+endif
+
+.PHONY: depend dist check-manifest dpkg doc
+
+.SUFFIXES:      .cmo .cmi .cmx .ml .mli .mll
diff --git a/Makefile.in b/Makefile.in
new file mode 100644 (file)
index 0000000..3ad12ac
--- /dev/null
@@ -0,0 +1,74 @@
+# $Id: Makefile.in,v 1.7 2007/08/23 09:36:04 rjones Exp $
+
+PACKAGE                = @PACKAGE_NAME@
+VERSION                = @PACKAGE_VERSION@
+
+INSTALL                = @INSTALL@
+
+pkg_lablgtk2   = @pkg_lablgtk2@
+pkg_curses     = @pkg_curses@
+
+OCAMLDOCFLAGS  := -html -sort
+
+SUBDIRS                := libvirt examples mlvirsh
+
+ifeq ($(pkg_lablgtk2),yes)
+SUBDIRS                += mlvirtmanager
+endif
+
+ifeq ($(pkg_curses),yes)
+SUBDIRS                += virt-top
+endif
+
+all opt depend install:
+       for d in $(SUBDIRS); do \
+         $(MAKE) -C $$d $@; \
+         if [ $$? -ne 0 ]; then exit 1; fi; \
+       done
+
+clean:
+       for d in . $(SUBDIRS); do \
+         (cd $$d; rm -f *.cmi *.cmo *.cmx *.cma *.cmxa *.o *.a *.so *.opt *~ core); \
+       done
+       rm -f examples/list_domains
+       rm -f mlvirsh/mlvirsh
+       rm -f mlvirtmanager/mlvirtmanager
+       rm -f virt-top/virt-top
+
+distclean:
+       rm -f config.h config.log config.status configure META
+       rm -rf autom4te.cache
+       rm -f Makefile
+
+# Distribution.
+
+dist:
+       $(MAKE) check-manifest
+       rm -rf $(PACKAGE)-$(VERSION)
+       mkdir $(PACKAGE)-$(VERSION)
+       tar -cf - -T MANIFEST | tar -C $(PACKAGE)-$(VERSION) -xf -
+       $(INSTALL) -m 0755 configure $(PACKAGE)-$(VERSION)/
+       tar zcf $(PACKAGE)-$(VERSION).tar.gz $(PACKAGE)-$(VERSION)
+       rm -rf $(PACKAGE)-$(VERSION)
+       ls -l $(PACKAGE)-$(VERSION).tar.gz
+
+check-manifest:
+       @for d in `find -type d -name CVS | grep -v '^\./debian/'`; \
+       do \
+       b=`dirname $$d`/; \
+       awk -F/ '$$1 != "D" {print $$2}' $$d/Entries | \
+       sed -e "s|^|$$b|" -e "s|^\./||"; \
+       done | sort > .check-manifest; \
+       sort MANIFEST > .orig-manifest; \
+       diff -u .orig-manifest .check-manifest; rv=$$?; \
+       rm -f .orig-manifest .check-manifest; \
+       exit $$rv
+
+# Developer documentation (in html/ subdirectory).
+
+doc:
+       rm -rf html
+       mkdir html
+       -cd libvirt; \
+       ocamlfind ocamldoc $(OCAMLDOCFLAGS) -d ../html \
+         libvirt.{ml,mli} libvirt_version.{ml,mli}
diff --git a/README b/README
new file mode 100644 (file)
index 0000000..800458d
--- /dev/null
+++ b/README
@@ -0,0 +1,154 @@
+$Id: README,v 1.11 2007/08/23 09:36:04 rjones Exp $
+
+ocaml-libvirt
+----------------------------------------------------------------------
+
+Copyright (C) 2007 Richard W.M. Jones, Red Hat Inc.
+http://et.redhat.com/~rjones/ocaml-libvirt/
+http://libvirt.org/
+
+This is a complete set of OCaml bindings around libvirt, exposing all
+known functionality to OCaml programs.
+
+
+Requirements
+----------------------------------------------------------------------
+
+To build the bindings and mlvirsh (required):
+
+  GNU make, gcc
+  libvirt >= 0.2.1 (from http://libvirt.org/,
+                   get the latest version if you can)
+  ocaml >= 3.08 (from http://caml.inria.fr/)
+  findlib (from http://www.ocaml-programming.de/packages/)
+  Extlib (from http://ocaml-lib.sourceforge.net/)
+
+To build the OCaml interface documentation (optional):
+
+  ocamldoc (part of OCaml itself)
+
+To build virt-top (optional):
+
+  ocaml-curses (from http://www.nongnu.org/ocaml-tmk/)
+  xml-light (from http://tech.motion-twin.com/doc/xml-light/)
+  ocaml CSV library (from http://merjis.com/developers/csv)
+
+  [Only ocaml-curses is required for building virt-top.  The other
+  packages are not required, but you will get reduced functionality].
+
+To build mlvirtmanager (optional):
+
+  GTK2 (from http://gtk.org/)
+  lablgtk2 (from http://wwwfun.kurims.kyoto-u.ac.jp/soft/lsl/lablgtk.html)
+
+To build the manpages (optional):
+
+  perldoc (part of Perl)
+
+OCaml packages are available for Fedora 7 and above (ocaml,
+ocaml-findlib, ocaml-findlib-devel, ocaml-ocamldoc, ocaml-extlib,
+ocaml-extlib-devel, ocaml-lablgtk, ocaml-lablgtk-devel, ocaml-curses,
+ocaml-xml-light, ocaml-csv).
+
+  http://www.annexia.org/tmp/ocaml/
+  http://fedoraproject.org/wiki/SIGs/OCaml
+
+Debian/Ubuntu have all the packages you require.
+
+
+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' and 'mlvirtmanager.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
+
+
+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%
+
+
+mlvirtmanager
+----------------------------------------------------------------------
+
+'mlvirtmanager' is a demonstration implementation 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
+----------------------------------------------------------------------
+
+The interface is described in 'libvirt.mli'.  The main modules are
+Libvirt.Connect, Libvirt.Domain and Libvirt.Network, corresponding
+respectively to the virConnect*, virDomain*, and virNetwork*
+functions.  For brevity I usually rename these modules like this:
+
+  module C = Libvirt.Connect
+  module D = Libvirt.Domain
+  module N = Libvirt.Network
+
+To get a connection handle, do:
+
+  let name = "xen:///"
+  let conn = C.connect ~name ()
+
+To list domains, do:
+
+  let n = C.num_of_domains conn
+  let ids = C.list_domains conn n
+  let domains = Array.map (D.lookup_by_id conn) ids
+  let () =
+    Array.iter (
+      fun dom ->
+        printf "%5d %s\n" (D.get_id dom) (D.get_name dom)
+    ) domains
+
+(See also the program list_domains.ml).
+
+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
+----------------------------------------------------------------------
+
+libvirt/               The OCaml bindings.
+examples/              Some example programs using the bindings.
+mlvirsh/               'mlvirsh' command line tool.
+mlvirtmanager/         'mlvirtmanager' graphical tool.
+virt-top/              'virt-top' tool.
diff --git a/TODO.libvirt b/TODO.libvirt
new file mode 100644 (file)
index 0000000..7d980fd
--- /dev/null
@@ -0,0 +1,3 @@
+$Id: TODO.libvirt,v 1.1 2007/08/29 15:48:06 rjones Exp $
+
+Turn VIR_ERR_NO_DOMAIN and NO_NETWORK errors into Not_found exceptions.
diff --git a/TODO.virt-top b/TODO.virt-top
new file mode 100644 (file)
index 0000000..479c5ac
--- /dev/null
@@ -0,0 +1,72 @@
+$Id: TODO.virt-top,v 1.2 2007/08/30 13:52:40 rjones Exp $
+
+This is a list of bugs & tasks for virt-top.
+----------------------------------------------------------------------
+
+*** 0 Use public CVS and bug tracker to replace this file (!)
+
+*** 1 Segfault [FIXED 0.3.2.6]
+
+I have seen this segfault once:
+https://www.redhat.com/archives/libvir-list/2007-August/msg00214.html
+
+It appeared to happen when several domains were shut down at the same
+time, but has since been unreproducible.  Suspect crazy reference
+counting in libvirt to be part of the problem.
+
+[As suspected, turned out to be the crazy reference counting in
+libvirt].
+
+*** 2 Virt-top fails silently when started as non-root [FIXED 0.3.2.5]
+
+*** 3 Irix/Solaris mode
+
+'I' (toggles between 100% = all CPUs / 100% = single CPU).
+In top this is called "Irix/Solaris mode" :-)
+
+*** 4 [jmh] Build out the stats collected by the --csv <filename.csv> option.
+
+Suggested being able to give a selection of VMs to monitor from the
+command line.  Also, being able to monitor just particular subsystems
+(-sc for CPU, -sm for memory, etc. as in collectl).
+
+*** 5 [jmh & jneedham] Monitor resources used by dom0 on behalf of the guests.
+
+So that if dom0 is throttled right down, is that affecting throughput
+of guests?  I honestly don't know if it's possible to do this, but
+I'll raise the issue upstream to see if they have any suggestions.
+
+*** 6 Per-guest / per-interface network statistics. [PARTIALLY DONE 0.3.2.6]
+
+Have a separate screen which breaks out the domain name / device name
+and gives complete interface stats.
+
+RXBY TXBY RXRQ TXRQ DOMAIN   INTERFACE
+  5M    0   48    0 debian   vif2.0
+  2M    0   20    0 oracle   vif3.1
+  1M   5K    8    2 oracle   vif3.0 
+
+*** 7 Per-guest / per-device block statistics. [PARTIALLY DONE 0.3.2.6]
+
+Have a separate screen which breaks out the domain name / device name
+and gives complete block stats.
+
+RDBY WRBY RDRQ WRRQ DOMAIN   DEVICE
+  5M    0   48    0 debian   hdb
+  2M    0   20    0 debian   hda
+  1M   5K    8    2 oracle   hda
+
+*** 8 [jneedham asked for] %WAIT
+
+I'm assuming this would mean in the context of the hypervisor, how
+long are runnable domains waiting in the runqueue for access to a free
+pCPU.  I will ask upstream whether this stat is available through Xen,
+and if so put in place the infrastructure to monitor it.
+
+*** 9 [jmh asked for] Configuration file or environment variable
+
+Thinking about maybe this is something we could controly via a
+.virt-top-init file or an environment variable ?  The same could also
+be true for other options such as the selection of subsystems and/or
+ordering/sorting ?
+
diff --git a/aclocal.m4 b/aclocal.m4
new file mode 100644 (file)
index 0000000..55d5ceb
--- /dev/null
@@ -0,0 +1,147 @@
+dnl autoconf macros for OCaml
+dnl by Olivier Andrieu
+dnl modified by Richard W.M. Jones
+dnl from a configure.in by Jean-Christophe FilliĆ¢tre,
+dnl from a first script by Georges Mariano
+dnl
+dnl defines AC_PROG_OCAML that will check the OCaml compiler
+dnl and set the following variables :
+dnl   OCAMLC        "ocamlc" if present in the path, or a failure
+dnl                 or "ocamlc.opt" if present with same version number as ocamlc
+dnl   OCAMLOPT      "ocamlopt" (or "ocamlopt.opt" if present), or "no"
+dnl   OCAMLBEST     either "byte" if no native compiler was found, 
+dnl                 or "opt" otherwise
+dnl   OCAMLDEP      "ocamldep"
+dnl   OCAMLLIB      the path to the ocaml standard library
+dnl   OCAMLVERSION  the ocaml version number
+AC_DEFUN(AC_PROG_OCAML,
+[dnl
+# checking for ocamlc
+AC_CHECK_PROG(OCAMLC,ocamlc,ocamlc,AC_MSG_ERROR(Cannot find ocamlc.))
+OCAMLVERSION=`$OCAMLC -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' `
+AC_MSG_RESULT(OCaml version is $OCAMLVERSION)
+OCAMLLIB=`$OCAMLC -where 2>/dev/null || $OCAMLC -v|tail -1|cut -d ' ' -f 4`
+AC_MSG_RESULT(OCaml library path is $OCAMLLIB)
+# checking for ocamlopt
+AC_CHECK_PROG(OCAMLOPT,ocamlopt,ocamlopt)
+OCAMLBEST=byte
+if test -z "$OCAMLOPT"; then
+       AC_MSG_WARN(Cannot find ocamlopt; bytecode compilation only.)
+else
+       TMPVERSION=`$OCAMLOPT -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' `
+       if test "$TMPVERSION" != "$OCAMLVERSION" ; then
+           AC_MSG_RESULT(versions differs from ocamlc; ocamlopt discarded.)
+           unset OCAMLOPT
+       else
+           OCAMLBEST=opt
+       fi
+fi
+# checking for ocamlc.opt
+AC_CHECK_PROG(OCAMLCDOTOPT,ocamlc.opt,ocamlc.opt)
+if test -z "$OCAMLCDOTOPT"; then
+       TMPVERSION=`$OCAMLCDOTOPT -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' `
+       if test "$TMPVERSION" != "$OCAMLVERSION" ; then
+           AC_MSG_RESULT(versions differs from ocamlc; ocamlc.opt discarded.)
+       else
+           OCAMLC=$OCAMLCDOTOPT
+       fi
+fi
+# checking for ocamlopt.opt
+if test "$OCAMLOPT" ; then
+    AC_CHECK_PROG(OCAMLOPTDOTOPT,ocamlopt.opt,ocamlopt.opt)
+    if test "$OCAMLOPTDOTOPT"; then
+       TMPVER=`$OCAMLOPTDOTOPT -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' `
+       if test "$TMPVER" != "$OCAMLVERSION" ; then
+           AC_MSG_RESULT(version differs from ocamlc; ocamlopt.opt discarded.)
+       else
+           OCAMLOPT=$OCAMLOPTDOTOPT
+       fi
+    fi
+fi
+# checking for ocamldep
+AC_CHECK_PROG(OCAMLDEP,ocamldep,ocamldep,AC_MSG_ERROR(Cannot find ocamldep.))
+
+#checking for ocamlmktop
+AC_CHECK_PROG(OCAMLMKTOP,ocamlmktop,ocamlmktop, AC_MSG_WARN(Cannot find ocamlmktop.))
+#checking for ocamlmklib
+AC_CHECK_PROG(OCAMLMKLIB,ocamlmklib,ocamlmklib, AC_MSG_WARN(Cannot find ocamlmklib.))
+# checking for ocamldoc
+AC_CHECK_PROG(OCAMLDOC,ocamldoc,ocamldoc, AC_MSG_WARN(Cannot find ocamldoc.))
+
+
+AC_SUBST(OCAMLC)
+AC_SUBST(OCAMLOPT)
+AC_SUBST(OCAMLDEP)
+AC_SUBST(OCAMLBEST)
+AC_SUBST(OCAMLVERSION)
+AC_SUBST(OCAMLLIB)
+AC_SUBST(OCAMLMKLIB)
+AC_SUBST(OCAMLDOC)
+])
+dnl
+dnl
+dnl
+dnl macro AC_PROG_OCAML_TOOLS will check OCamllex and OCamlyacc :
+dnl   OCAMLLEX      "ocamllex" or "ocamllex.opt" if present
+dnl   OCAMLYACC     "ocamlyac"
+AC_DEFUN(AC_PROG_OCAML_TOOLS,
+[dnl
+# checking for ocamllex and ocamlyacc
+AC_CHECK_PROG(OCAMLLEX,ocamllex,ocamllex)
+if test "$OCAMLLEX"; then
+    AC_CHECK_PROG(OCAMLLEXDOTOPT,ocamllex.opt,ocamllex.opt)
+    if test "$OCAMLLEXDOTOPT"; then
+       OCAMLLEX=$OCAMLLEXDOTOPT
+    fi
+else
+       AC_MSG_ERROR(Cannot find ocamllex.)
+fi
+AC_CHECK_PROG(OCAMLYACC,ocamlyacc,ocamlyacc,AC_MSG_ERROR(Cannot find ocamlyacc.))
+AC_SUBST(OCAMLLEX)
+AC_SUBST(OCAMLYACC)
+])
+dnl
+dnl
+dnl
+dnl AC_PROG_CAMLP4 checks for Camlp4
+AC_DEFUN(AC_PROG_CAMLP4,
+[dnl
+AC_REQUIRE([AC_PROG_OCAML])
+# checking for camlp4
+AC_CHECK_PROG(CAMLP4,camlp4,camlp4)
+if test "$CAMLP4"; then
+       TMPVERSION=`$CAMLP4 -v 2>&1| sed -n -e 's|.*version *\(.*\)$|\1|p'`
+       if test "$TMPVERSION" != "$OCAMLVERSION" ; then
+           AC_MSG_RESULT(versions differs from ocamlc)
+       fi
+fi
+])
+dnl
+dnl
+dnl
+dnl macro AC_PROG_FINDLIB will check for the presence of
+dnl   ocamlfind
+AC_DEFUN(AC_PROG_FINDLIB,
+[dnl
+# checking for ocamlfind
+AC_CHECK_PROG(OCAMLFIND,ocamlfind,ocamlfind,
+       AC_MSG_ERROR(ocamlfind not found))
+AC_SUBST(OCAMLFIND)
+])
+dnl
+dnl
+dnl
+dnl AC_CHECK_OCAML_PKG checks wether a findlib package is present
+dnl   defines pkg_name to "yes"
+AC_DEFUN(AC_CHECK_OCAML_PKG,
+[dnl
+AC_REQUIRE([AC_PROG_FINDLIB])
+AC_MSG_CHECKING(findlib package $1)
+if $OCAMLFIND query $1 >/dev/null 2>/dev/null; then
+AC_MSG_RESULT(found)
+eval "pkg_`echo $1 | tr - _`=yes"
+else
+AC_MSG_RESULT(not found)
+eval "pkg_`echo $1 | tr - _`=no"
+fi
+])
diff --git a/config.h.in b/config.h.in
new file mode 100644 (file)
index 0000000..d8c604b
--- /dev/null
@@ -0,0 +1,85 @@
+/* config.h.in.  Generated from configure.ac by autoheader.  */
+
+/* Define to 1 if you have the <inttypes.h> 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 <memory.h> header file. */
+#undef HAVE_MEMORY_H
+
+/* Define to 1 if you have the <stdint.h> header file. */
+#undef HAVE_STDINT_H
+
+/* Define to 1 if you have the <stdlib.h> header file. */
+#undef HAVE_STDLIB_H
+
+/* Define to 1 if you have the <strings.h> header file. */
+#undef HAVE_STRINGS_H
+
+/* Define to 1 if you have the <string.h> header file. */
+#undef HAVE_STRING_H
+
+/* Define to 1 if you have the <sys/stat.h> header file. */
+#undef HAVE_SYS_STAT_H
+
+/* Define to 1 if you have the <sys/types.h> header file. */
+#undef HAVE_SYS_TYPES_H
+
+/* Define to 1 if you have the <unistd.h> 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 `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 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
+
+/* Define to the full name of this package. */
+#undef PACKAGE_NAME
+
+/* Define to the full name and version of this package. */
+#undef PACKAGE_STRING
+
+/* Define to the one symbol short name of this package. */
+#undef PACKAGE_TARNAME
+
+/* 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
new file mode 100644 (file)
index 0000000..f1dc5c8
--- /dev/null
@@ -0,0 +1,104 @@
+dnl Process this file with autoconf to produce a configure script.
+
+AC_INIT(ocaml-libvirt,0.3.2.7)
+
+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 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 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])
+
+dnl Check for optional ncurses.
+AC_CHECK_LIB(ncurses,initscr)
+
+dnl Check for basic OCaml environment & findlib.
+AC_PROG_OCAML
+AC_PROG_FINDLIB
+
+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
+AC_CHECK_OCAML_PKG(extlib)
+if test "x$pkg_extlib" != "xyes"; then
+   AC_MSG_ERROR([Cannot find required OCaml package 'extlib'])
+fi
+
+dnl Check for optional OCaml packages.
+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_SUBST(pkg_lablgtk2)
+AC_SUBST(pkg_curses)
+AC_SUBST(pkg_gettext)
+AC_SUBST(pkg_xml_light)
+AC_SUBST(pkg_csv)
+
+dnl Check for optional perldoc (for building manual pages).
+AC_CHECK_PROG(HAVE_PERLDOC,perldoc,perldoc)
+
+dnl Summary.
+echo "------------------------------------------------------------"
+echo "Thanks for downloading" $PACKAGE_STRING
+echo "  OCaml libvirt bindings   . yes"
+echo "  example programs   . . . . yes"
+echo "  mlvirsh    . . . . . . . . yes"
+echo -n "  mlvirtmanager    . . . . . "
+if test "x$pkg_lablgtk2" = "xyes"; then
+   echo "yes"
+else
+   echo "no (needs optional lablgtk2)"
+fi
+echo -n "  virt-top     . . . . . . . "
+if test "x$pkg_curses" = "xyes"; then
+   echo "yes"
+else
+   echo "no (needs optional ocaml-curses)"
+fi
+echo "------------------------------------------------------------"
+
+dnl Produce output files.
+AC_CONFIG_HEADERS([config.h])
+AC_CONFIG_FILES([META
+       libvirt/libvirt_version.ml
+       Makefile
+       libvirt/Makefile
+       examples/Makefile
+       mlvirsh/Makefile
+       mlvirtmanager/Makefile
+       virt-top/Makefile
+       ])
+AC_OUTPUT
diff --git a/examples/.cvsignore b/examples/.cvsignore
new file mode 100644 (file)
index 0000000..1353c69
--- /dev/null
@@ -0,0 +1,8 @@
+*.cmi
+*.cmo
+*.cmx
+*.cma
+*.cmxa
+Makefile
+list_domains
+list_domains.opt
\ No newline at end of file
diff --git a/examples/.depend b/examples/.depend
new file mode 100644 (file)
index 0000000..bc5cec2
--- /dev/null
@@ -0,0 +1,2 @@
+list_domains.cmo: ../libvirt/libvirt.cmi 
+list_domains.cmx: ../libvirt/libvirt.cmx 
diff --git a/examples/Makefile b/examples/Makefile
new file mode 100644 (file)
index 0000000..4692e36
--- /dev/null
@@ -0,0 +1,32 @@
+# $Id: Makefile.in,v 1.1 2007/08/21 12:33:40 rjones Exp $
+
+OCAMLCPACKAGES := -package extlib,unix -I ../libvirt
+OCAMLCFLAGS    := -g
+OCAMLCLIBS     := -linkpkg
+
+OCAMLOPTPACKAGES := $(OCAMLCPACKAGES)
+OCAMLOPTFLAGS  :=
+OCAMLOPTLIBS   := $(OCAMLCLIBS)
+
+export LIBRARY_PATH=../libvirt
+export LD_LIBRARY_PATH=../libvirt
+
+BYTE_TARGETS   := list_domains
+OPT_TARGETS    := list_domains.opt
+
+all: $(BYTE_TARGETS)
+
+opt: $(OPT_TARGETS)
+
+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 $@ $<
+
+install:
+
+include ../Make.rules
diff --git a/examples/Makefile.in b/examples/Makefile.in
new file mode 100644 (file)
index 0000000..4692e36
--- /dev/null
@@ -0,0 +1,32 @@
+# $Id: Makefile.in,v 1.1 2007/08/21 12:33:40 rjones Exp $
+
+OCAMLCPACKAGES := -package extlib,unix -I ../libvirt
+OCAMLCFLAGS    := -g
+OCAMLCLIBS     := -linkpkg
+
+OCAMLOPTPACKAGES := $(OCAMLCPACKAGES)
+OCAMLOPTFLAGS  :=
+OCAMLOPTLIBS   := $(OCAMLCLIBS)
+
+export LIBRARY_PATH=../libvirt
+export LD_LIBRARY_PATH=../libvirt
+
+BYTE_TARGETS   := list_domains
+OPT_TARGETS    := list_domains.opt
+
+all: $(BYTE_TARGETS)
+
+opt: $(OPT_TARGETS)
+
+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 $@ $<
+
+install:
+
+include ../Make.rules
diff --git a/examples/list_domains.ml b/examples/list_domains.ml
new file mode 100644 (file)
index 0000000..f752754
--- /dev/null
@@ -0,0 +1,47 @@
+(* 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/
+   $Id: list_domains.ml,v 1.1 2007/08/06 10:16:53 rjones Exp $
+ *)
+
+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 ?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/install-sh b/install-sh
new file mode 100755 (executable)
index 0000000..4fbbae7
--- /dev/null
@@ -0,0 +1,507 @@
+#!/bin/sh
+# install - install a program, script, or datafile
+
+scriptversion=2006-10-14.15
+
+# This originates from X11R5 (mit/util/scripts/install.sh), which was
+# later released in X11R6 (xc/config/util/install.sh) with the
+# following copyright and license.
+#
+# Copyright (C) 1994 X Consortium
+#
+# Permission is hereby granted, free of charge, to any person obtaining a copy
+# of this software and associated documentation files (the "Software"), to
+# deal in the Software without restriction, including without limitation the
+# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
+# sell copies of the Software, and to permit persons to whom the Software is
+# furnished to do so, subject to the following conditions:
+#
+# The above copyright notice and this permission notice shall be included in
+# all copies or substantial portions of the Software.
+#
+# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  IN NO EVENT SHALL THE
+# X CONSORTIUM BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN
+# AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNEC-
+# TION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+#
+# Except as contained in this notice, the name of the X Consortium shall not
+# be used in advertising or otherwise to promote the sale, use or other deal-
+# ings in this Software without prior written authorization from the X Consor-
+# tium.
+#
+#
+# FSF changes to this file are in the public domain.
+#
+# Calling this script install-sh is preferred over install.sh, to prevent
+# `make' implicit rules from creating a file called install from it
+# when there is no Makefile.
+#
+# This script is compatible with the BSD install script, but was written
+# from scratch.
+
+nl='
+'
+IFS=" ""       $nl"
+
+# set DOITPROG to echo to test this script
+
+# Don't use :- since 4.3BSD and earlier shells don't like it.
+doit="${DOITPROG-}"
+if test -z "$doit"; then
+  doit_exec=exec
+else
+  doit_exec=$doit
+fi
+
+# Put in absolute file names if you don't have them in your path;
+# or use environment vars.
+
+mvprog="${MVPROG-mv}"
+cpprog="${CPPROG-cp}"
+chmodprog="${CHMODPROG-chmod}"
+chownprog="${CHOWNPROG-chown}"
+chgrpprog="${CHGRPPROG-chgrp}"
+stripprog="${STRIPPROG-strip}"
+rmprog="${RMPROG-rm}"
+mkdirprog="${MKDIRPROG-mkdir}"
+
+posix_glob=
+posix_mkdir=
+
+# Desired mode of installed file.
+mode=0755
+
+chmodcmd=$chmodprog
+chowncmd=
+chgrpcmd=
+stripcmd=
+rmcmd="$rmprog -f"
+mvcmd="$mvprog"
+src=
+dst=
+dir_arg=
+dstarg=
+no_target_directory=
+
+usage="Usage: $0 [OPTION]... [-T] SRCFILE DSTFILE
+   or: $0 [OPTION]... SRCFILES... DIRECTORY
+   or: $0 [OPTION]... -t DIRECTORY SRCFILES...
+   or: $0 [OPTION]... -d DIRECTORIES...
+
+In the 1st form, copy SRCFILE to DSTFILE.
+In the 2nd and 3rd, copy all SRCFILES to DIRECTORY.
+In the 4th, create DIRECTORIES.
+
+Options:
+-c         (ignored)
+-d         create directories instead of installing files.
+-g GROUP   $chgrpprog installed files to GROUP.
+-m MODE    $chmodprog installed files to MODE.
+-o USER    $chownprog installed files to USER.
+-s         $stripprog installed files.
+-t DIRECTORY  install into DIRECTORY.
+-T         report an error if DSTFILE is a directory.
+--help     display this help and exit.
+--version  display version info and exit.
+
+Environment variables override the default commands:
+  CHGRPPROG CHMODPROG CHOWNPROG CPPROG MKDIRPROG MVPROG RMPROG STRIPPROG
+"
+
+while test $# -ne 0; do
+  case $1 in
+    -c) shift
+        continue;;
+
+    -d) dir_arg=true
+        shift
+        continue;;
+
+    -g) chgrpcmd="$chgrpprog $2"
+        shift
+        shift
+        continue;;
+
+    --help) echo "$usage"; exit $?;;
+
+    -m) mode=$2
+        shift
+        shift
+       case $mode in
+         *' '* | *'    '* | *'
+'*       | *'*'* | *'?'* | *'['*)
+           echo "$0: invalid mode: $mode" >&2
+           exit 1;;
+       esac
+        continue;;
+
+    -o) chowncmd="$chownprog $2"
+        shift
+        shift
+        continue;;
+
+    -s) stripcmd=$stripprog
+        shift
+        continue;;
+
+    -t) dstarg=$2
+       shift
+       shift
+       continue;;
+
+    -T) no_target_directory=true
+       shift
+       continue;;
+
+    --version) echo "$0 $scriptversion"; exit $?;;
+
+    --)        shift
+       break;;
+
+    -*)        echo "$0: invalid option: $1" >&2
+       exit 1;;
+
+    *)  break;;
+  esac
+done
+
+if test $# -ne 0 && test -z "$dir_arg$dstarg"; then
+  # When -d is used, all remaining arguments are directories to create.
+  # When -t is used, the destination is already specified.
+  # Otherwise, the last argument is the destination.  Remove it from $@.
+  for arg
+  do
+    if test -n "$dstarg"; then
+      # $@ is not empty: it contains at least $arg.
+      set fnord "$@" "$dstarg"
+      shift # fnord
+    fi
+    shift # arg
+    dstarg=$arg
+  done
+fi
+
+if test $# -eq 0; then
+  if test -z "$dir_arg"; then
+    echo "$0: no input file specified." >&2
+    exit 1
+  fi
+  # It's OK to call `install-sh -d' without argument.
+  # This can happen when creating conditional directories.
+  exit 0
+fi
+
+if test -z "$dir_arg"; then
+  trap '(exit $?); exit' 1 2 13 15
+
+  # Set umask so as not to create temps with too-generous modes.
+  # However, 'strip' requires both read and write access to temps.
+  case $mode in
+    # Optimize common cases.
+    *644) cp_umask=133;;
+    *755) cp_umask=22;;
+
+    *[0-7])
+      if test -z "$stripcmd"; then
+       u_plus_rw=
+      else
+       u_plus_rw='% 200'
+      fi
+      cp_umask=`expr '(' 777 - $mode % 1000 ')' $u_plus_rw`;;
+    *)
+      if test -z "$stripcmd"; then
+       u_plus_rw=
+      else
+       u_plus_rw=,u+rw
+      fi
+      cp_umask=$mode$u_plus_rw;;
+  esac
+fi
+
+for src
+do
+  # Protect names starting with `-'.
+  case $src in
+    -*) src=./$src ;;
+  esac
+
+  if test -n "$dir_arg"; then
+    dst=$src
+    dstdir=$dst
+    test -d "$dstdir"
+    dstdir_status=$?
+  else
+
+    # Waiting for this to be detected by the "$cpprog $src $dsttmp" command
+    # might cause directories to be created, which would be especially bad
+    # if $src (and thus $dsttmp) contains '*'.
+    if test ! -f "$src" && test ! -d "$src"; then
+      echo "$0: $src does not exist." >&2
+      exit 1
+    fi
+
+    if test -z "$dstarg"; then
+      echo "$0: no destination specified." >&2
+      exit 1
+    fi
+
+    dst=$dstarg
+    # Protect names starting with `-'.
+    case $dst in
+      -*) dst=./$dst ;;
+    esac
+
+    # If destination is a directory, append the input filename; won't work
+    # if double slashes aren't ignored.
+    if test -d "$dst"; then
+      if test -n "$no_target_directory"; then
+       echo "$0: $dstarg: Is a directory" >&2
+       exit 1
+      fi
+      dstdir=$dst
+      dst=$dstdir/`basename "$src"`
+      dstdir_status=0
+    else
+      # Prefer dirname, but fall back on a substitute if dirname fails.
+      dstdir=`
+       (dirname "$dst") 2>/dev/null ||
+       expr X"$dst" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
+            X"$dst" : 'X\(//\)[^/]' \| \
+            X"$dst" : 'X\(//\)$' \| \
+            X"$dst" : 'X\(/\)' \| . 2>/dev/null ||
+       echo X"$dst" |
+           sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{
+                  s//\1/
+                  q
+                }
+                /^X\(\/\/\)[^/].*/{
+                  s//\1/
+                  q
+                }
+                /^X\(\/\/\)$/{
+                  s//\1/
+                  q
+                }
+                /^X\(\/\).*/{
+                  s//\1/
+                  q
+                }
+                s/.*/./; q'
+      `
+
+      test -d "$dstdir"
+      dstdir_status=$?
+    fi
+  fi
+
+  obsolete_mkdir_used=false
+
+  if test $dstdir_status != 0; then
+    case $posix_mkdir in
+      '')
+       # Create intermediate dirs using mode 755 as modified by the umask.
+       # This is like FreeBSD 'install' as of 1997-10-28.
+       umask=`umask`
+       case $stripcmd.$umask in
+         # Optimize common cases.
+         *[2367][2367]) mkdir_umask=$umask;;
+         .*0[02][02] | .[02][02] | .[02]) mkdir_umask=22;;
+
+         *[0-7])
+           mkdir_umask=`expr $umask + 22 \
+             - $umask % 100 % 40 + $umask % 20 \
+             - $umask % 10 % 4 + $umask % 2
+           `;;
+         *) mkdir_umask=$umask,go-w;;
+       esac
+
+       # With -d, create the new directory with the user-specified mode.
+       # Otherwise, rely on $mkdir_umask.
+       if test -n "$dir_arg"; then
+         mkdir_mode=-m$mode
+       else
+         mkdir_mode=
+       fi
+
+       posix_mkdir=false
+       case $umask in
+         *[123567][0-7][0-7])
+           # POSIX mkdir -p sets u+wx bits regardless of umask, which
+           # is incompatible with FreeBSD 'install' when (umask & 300) != 0.
+           ;;
+         *)
+           tmpdir=${TMPDIR-/tmp}/ins$RANDOM-$$
+           trap 'ret=$?; rmdir "$tmpdir/d" "$tmpdir" 2>/dev/null; exit $ret' 0
+
+           if (umask $mkdir_umask &&
+               exec $mkdirprog $mkdir_mode -p -- "$tmpdir/d") >/dev/null 2>&1
+           then
+             if test -z "$dir_arg" || {
+                  # Check for POSIX incompatibilities with -m.
+                  # HP-UX 11.23 and IRIX 6.5 mkdir -m -p sets group- or
+                  # other-writeable bit of parent directory when it shouldn't.
+                  # FreeBSD 6.1 mkdir -m -p sets mode of existing directory.
+                  ls_ld_tmpdir=`ls -ld "$tmpdir"`
+                  case $ls_ld_tmpdir in
+                    d????-?r-*) different_mode=700;;
+                    d????-?--*) different_mode=755;;
+                    *) false;;
+                  esac &&
+                  $mkdirprog -m$different_mode -p -- "$tmpdir" && {
+                    ls_ld_tmpdir_1=`ls -ld "$tmpdir"`
+                    test "$ls_ld_tmpdir" = "$ls_ld_tmpdir_1"
+                  }
+                }
+             then posix_mkdir=:
+             fi
+             rmdir "$tmpdir/d" "$tmpdir"
+           else
+             # Remove any dirs left behind by ancient mkdir implementations.
+             rmdir ./$mkdir_mode ./-p ./-- 2>/dev/null
+           fi
+           trap '' 0;;
+       esac;;
+    esac
+
+    if
+      $posix_mkdir && (
+       umask $mkdir_umask &&
+       $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir"
+      )
+    then :
+    else
+
+      # The umask is ridiculous, or mkdir does not conform to POSIX,
+      # or it failed possibly due to a race condition.  Create the
+      # directory the slow way, step by step, checking for races as we go.
+
+      case $dstdir in
+       /*) prefix=/ ;;
+       -*) prefix=./ ;;
+       *)  prefix= ;;
+      esac
+
+      case $posix_glob in
+        '')
+         if (set -f) 2>/dev/null; then
+           posix_glob=true
+         else
+           posix_glob=false
+         fi ;;
+      esac
+
+      oIFS=$IFS
+      IFS=/
+      $posix_glob && set -f
+      set fnord $dstdir
+      shift
+      $posix_glob && set +f
+      IFS=$oIFS
+
+      prefixes=
+
+      for d
+      do
+       test -z "$d" && continue
+
+       prefix=$prefix$d
+       if test -d "$prefix"; then
+         prefixes=
+       else
+         if $posix_mkdir; then
+           (umask=$mkdir_umask &&
+            $doit_exec $mkdirprog $mkdir_mode -p -- "$dstdir") && break
+           # Don't fail if two instances are running concurrently.
+           test -d "$prefix" || exit 1
+         else
+           case $prefix in
+             *\'*) qprefix=`echo "$prefix" | sed "s/'/'\\\\\\\\''/g"`;;
+             *) qprefix=$prefix;;
+           esac
+           prefixes="$prefixes '$qprefix'"
+         fi
+       fi
+       prefix=$prefix/
+      done
+
+      if test -n "$prefixes"; then
+       # Don't fail if two instances are running concurrently.
+       (umask $mkdir_umask &&
+        eval "\$doit_exec \$mkdirprog $prefixes") ||
+         test -d "$dstdir" || exit 1
+       obsolete_mkdir_used=true
+      fi
+    fi
+  fi
+
+  if test -n "$dir_arg"; then
+    { test -z "$chowncmd" || $doit $chowncmd "$dst"; } &&
+    { test -z "$chgrpcmd" || $doit $chgrpcmd "$dst"; } &&
+    { test "$obsolete_mkdir_used$chowncmd$chgrpcmd" = false ||
+      test -z "$chmodcmd" || $doit $chmodcmd $mode "$dst"; } || exit 1
+  else
+
+    # Make a couple of temp file names in the proper directory.
+    dsttmp=$dstdir/_inst.$$_
+    rmtmp=$dstdir/_rm.$$_
+
+    # Trap to clean up those temp files at exit.
+    trap 'ret=$?; rm -f "$dsttmp" "$rmtmp" && exit $ret' 0
+
+    # Copy the file name to the temp name.
+    (umask $cp_umask && $doit_exec $cpprog "$src" "$dsttmp") &&
+
+    # and set any options; do chmod last to preserve setuid bits.
+    #
+    # If any of these fail, we abort the whole thing.  If we want to
+    # ignore errors from any of these, just make sure not to ignore
+    # errors from the above "$doit $cpprog $src $dsttmp" command.
+    #
+    { test -z "$chowncmd" || $doit $chowncmd "$dsttmp"; } \
+      && { test -z "$chgrpcmd" || $doit $chgrpcmd "$dsttmp"; } \
+      && { test -z "$stripcmd" || $doit $stripcmd "$dsttmp"; } \
+      && { test -z "$chmodcmd" || $doit $chmodcmd $mode "$dsttmp"; } &&
+
+    # Now rename the file to the real destination.
+    { $doit $mvcmd -f "$dsttmp" "$dst" 2>/dev/null \
+      || {
+          # The rename failed, perhaps because mv can't rename something else
+          # to itself, or perhaps because mv is so ancient that it does not
+          # support -f.
+
+          # Now remove or move aside any old file at destination location.
+          # We try this two ways since rm can't unlink itself on some
+          # systems and the destination file might be busy for other
+          # reasons.  In this case, the final cleanup might fail but the new
+          # file should still install successfully.
+          {
+            if test -f "$dst"; then
+              $doit $rmcmd -f "$dst" 2>/dev/null \
+              || { $doit $mvcmd -f "$dst" "$rmtmp" 2>/dev/null \
+                    && { $doit $rmcmd -f "$rmtmp" 2>/dev/null; :; }; }\
+              || {
+                echo "$0: cannot unlink or rename $dst" >&2
+                (exit 1); exit 1
+              }
+            else
+              :
+            fi
+          } &&
+
+          # Now rename the file to the real destination.
+          $doit $mvcmd "$dsttmp" "$dst"
+        }
+    } || exit 1
+
+    trap '' 0
+  fi
+done
+
+# Local variables:
+# eval: (add-hook 'write-file-hooks 'time-stamp)
+# time-stamp-start: "scriptversion="
+# time-stamp-format: "%:y-%02m-%02d.%02H"
+# time-stamp-end: "$"
+# End:
diff --git a/libvirt/.cvsignore b/libvirt/.cvsignore
new file mode 100644 (file)
index 0000000..beb49ff
--- /dev/null
@@ -0,0 +1,7 @@
+*.cmi
+*.cmo
+*.cmx
+*.cma
+*.cmxa
+Makefile
+libvirt_version.ml
\ No newline at end of file
diff --git a/libvirt/.depend b/libvirt/.depend
new file mode 100644 (file)
index 0000000..5556d96
--- /dev/null
@@ -0,0 +1,4 @@
+libvirt.cmo: libvirt.cmi 
+libvirt.cmx: libvirt.cmi 
+libvirt_version.cmo: libvirt_version.cmi 
+libvirt_version.cmx: libvirt_version.cmi 
diff --git a/libvirt/Makefile b/libvirt/Makefile
new file mode 100644 (file)
index 0000000..e22d9f7
--- /dev/null
@@ -0,0 +1,44 @@
+# $Id: Makefile.in,v 1.2 2007/08/21 13:24:08 rjones Exp $
+
+CFLAGS         := -g -O2 -I/home/rjones/local/include \
+                  -I.. \
+                  -I$(shell ocamlc -where) \
+                  -Wall -Werror \
+                  -fPIC \
+                  -g
+LDFLAGS                :=  -L/home/rjones/local/lib
+
+OCAMLCPACKAGES := -package extlib,unix
+OCAMLCFLAGS    := -g
+OCAMLCLIBS     := -linkpkg
+
+OCAMLOPTPACKAGES := $(OCAMLCPACKAGES)
+OCAMLOPTFLAGS  :=
+OCAMLOPTLIBS   := $(OCAMLCLIBS)
+
+export LIBRARY_PATH=.
+export LD_LIBRARY_PATH=.
+
+BYTE_TARGETS   := libvirt.cma
+OPT_TARGETS    := libvirt.cmxa
+
+all: $(BYTE_TARGETS)
+
+opt: $(OPT_TARGETS)
+
+libvirt.cma: libvirt_c.o libvirt.cmo libvirt_version.cmo
+       ocamlmklib -o mllibvirt $^ $(LDFLAGS) -lvirt
+
+libvirt.cmxa: libvirt_c.o libvirt.cmx libvirt_version.cmx
+       ocamlmklib -o mllibvirt $^ $(LDFLAGS) -lvirt
+
+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 *.mli
+
+include ../Make.rules
diff --git a/libvirt/Makefile.in b/libvirt/Makefile.in
new file mode 100644 (file)
index 0000000..ff90d72
--- /dev/null
@@ -0,0 +1,44 @@
+# $Id: Makefile.in,v 1.2 2007/08/21 13:24:08 rjones Exp $
+
+CFLAGS         := @CFLAGS@ \
+                  -I.. \
+                  -I$(shell ocamlc -where) \
+                  -Wall -Werror \
+                  -fPIC \
+                  -g
+LDFLAGS                := @LDFLAGS@
+
+OCAMLCPACKAGES := -package extlib,unix
+OCAMLCFLAGS    := -g
+OCAMLCLIBS     := -linkpkg
+
+OCAMLOPTPACKAGES := $(OCAMLCPACKAGES)
+OCAMLOPTFLAGS  :=
+OCAMLOPTLIBS   := $(OCAMLCLIBS)
+
+export LIBRARY_PATH=.
+export LD_LIBRARY_PATH=.
+
+BYTE_TARGETS   := libvirt.cma
+OPT_TARGETS    := libvirt.cmxa
+
+all: $(BYTE_TARGETS)
+
+opt: $(OPT_TARGETS)
+
+libvirt.cma: libvirt_c.o libvirt.cmo libvirt_version.cmo
+       ocamlmklib -o mllibvirt $^ $(LDFLAGS) -lvirt
+
+libvirt.cmxa: libvirt_c.o libvirt.cmx libvirt_version.cmx
+       ocamlmklib -o mllibvirt $^ $(LDFLAGS) -lvirt
+
+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 *.mli
+
+include ../Make.rules
diff --git a/libvirt/libvirt.ml b/libvirt/libvirt.ml
new file mode 100644 (file)
index 0000000..14dca54
--- /dev/null
@@ -0,0 +1,379 @@
+(* OCaml bindings for libvirt.
+   (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
+   http://libvirt.org/
+   $Id: libvirt.ml,v 1.2 2007/08/21 13:24:08 rjones Exp $
+*)
+
+type uuid = string
+
+type xml = string
+
+external get_version : ?driver:string -> unit -> int * int = "ocaml_libvirt_get_version"
+
+let uuid_length = 16
+let uuid_string_length = 36
+
+(* http://caml.inria.fr/pub/ml-archives/caml-list/2004/07/80683af867cce6bf8fff273973f70c95.en.html *)
+type rw = [`R|`W]
+type ro = [`R]
+
+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 -> string = "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 get_node_info : [>`R] t -> node_info = "ocaml_libvirt_connect_get_node_info"
+
+  (* See VIR_NODEINFO_MAXCPUS macro defined in <libvirt.h>. *)
+  let maxcpus_of_node_info { nodes = nodes; sockets = sockets;
+                            cores = cores; threads = threads } =
+    nodes * sockets * cores * threads
+
+  (* See VIR_CPU_MAPLEN macro defined in <libvirt.h>. *)
+  let cpumaplen nr_cpus =
+    (nr_cpus + 7) / 8
+
+  (* See VIR_USE_CPU, VIR_UNUSE_CPU, VIR_CPU_USABLE macros defined in <libvirt.h>. *)
+  let use_cpu cpumap cpu =
+    cpumap.[cpu/8] <-
+      Char.chr (Char.code cpumap.[cpu/8] lor (1 lsl (cpu mod 8)))
+  let unuse_cpu cpumap cpu =
+    cpumap.[cpu/8] <-
+      Char.chr (Char.code cpumap.[cpu/8] land (lnot (1 lsl (cpu mod 8))))
+  let cpu_usable cpumaps maplen vcpu cpu =
+    Char.code cpumaps.[vcpu*maplen + cpu/8] land (1 lsl (cpu mod 8)) <> 0
+
+  external const : [>`R] t -> ro t = "%identity"
+end
+
+module Domain =
+struct
+  type 'rw dom
+  type 'rw t = 'rw dom * 'rw Connect.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 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 -> string -> unit = "ocaml_libvirt_domain_save"
+  external restore : [>`W] Connect.t -> string -> unit = "ocaml_libvirt_domain_restore"
+  external core_dump : [>`W] t -> string -> unit = "ocaml_libvirt_domain_core_dump"
+  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 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 net
+  type 'rw t = 'rw net * 'rw Connect.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 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 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 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
+
+  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"
+
+  type level =
+    | VIR_ERR_NONE
+    | VIR_ERR_WARNING
+    | VIR_ERR_ERROR
+
+  let string_of_level = function
+    | VIR_ERR_NONE -> "VIR_ERR_NONE"
+    | VIR_ERR_WARNING -> "VIR_ERR_WARNING"
+    | VIR_ERR_ERROR -> "VIR_ERR_ERROR"
+
+  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
+
+  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"
+
+  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
+
+(* Initialization. *)
+external c_init : unit -> unit = "ocaml_libvirt_init"
+let () =
+  Callback.register_exception
+    "ocaml_libvirt_virterror" (Virterror (Virterror.no_error ()));
+  c_init ()
diff --git a/libvirt/libvirt.mli b/libvirt/libvirt.mli
new file mode 100644 (file)
index 0000000..66f94c7
--- /dev/null
@@ -0,0 +1,416 @@
+(** OCaml bindings for libvirt.
+    (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
+    http://libvirt.org/
+    $Id: libvirt.mli,v 1.3 2007/08/22 10:04:07 rjones Exp $
+*)
+
+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.
+*)
+
+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. *)
+
+(* These phantom types are used to ensure the type-safety of read-only
+ * versus read-write connections.  For more information see:
+ * http://caml.inria.fr/pub/ml-archives/caml-list/2004/07/80683af867cce6bf8fff273973f70c95.en.html
+ *)
+type rw = [`R|`W]
+type ro = [`R]
+
+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
+  val get_version : [>`R] t -> int
+  val get_hostname : [>`R] t -> string
+  val get_uri : [>`R] t -> string
+  val get_max_vcpus : [>`R] t -> ?type_:string -> unit -> int
+  val list_domains : [>`R] t -> int -> int array
+  val num_of_domains : [>`R] t -> int
+  val get_capabilities : [>`R] t -> string
+  val num_of_defined_domains : [>`R] t -> int
+  val list_defined_domains : [>`R] t -> int -> string array
+  val num_of_networks : [>`R] t -> int
+  val list_networks : [>`R] t -> int -> string array
+  val num_of_defined_networks : [>`R] t -> int
+  val list_defined_networks : [>`R] t -> int -> string array
+
+    (* The name of this function is inconsistent, but the inconsistency
+     * is really in libvirt itself.
+     *)
+  val get_node_info : [>`R] t -> node_info
+
+  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.
+  *)
+
+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
+  val lookup_by_id : 'a Connect.t -> int -> 'a t
+  val lookup_by_uuid : 'a Connect.t -> uuid -> 'a t
+  val lookup_by_uuid_string : 'a Connect.t -> string -> 'a t
+  val lookup_by_name : 'a Connect.t -> string -> 'a t
+  val destroy : [>`W] t -> unit
+  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
+  val resume : [>`W] t -> unit
+  val save : [>`W] t -> string -> unit
+  val restore : [>`W] Connect.t -> string -> unit
+  val core_dump : [>`W] t -> string -> unit
+  val shutdown : [>`W] t -> unit
+  val reboot : [>`W] t -> unit
+  val get_name : [>`R] t -> string
+  val get_uuid : [>`R] t -> uuid
+  val get_uuid_string : [>`R] t -> 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
+  val get_max_memory : [>`R] t -> int64
+  val set_max_memory : [>`W] t -> int64 -> unit
+  val set_memory : [>`W] t -> int64 -> unit
+  val get_info : [>`R] t -> info
+  val get_xml_desc : [>`R] t -> xml
+  val get_scheduler_type : [>`R] t -> string * int
+  val get_scheduler_parameters : [>`R] t -> int -> sched_param array
+  val set_scheduler_parameters : [>`W] t -> sched_param array -> unit
+  val define_xml : [>`W] Connect.t -> xml -> rw t
+  val undefine : [>`W] t -> unit
+  val create : [>`W] t -> unit
+  val get_autostart : [>`R] t -> bool
+  val set_autostart : [>`W] t -> bool -> unit
+  val set_vcpus : [>`W] t -> int -> unit
+  val pin_vcpu : [>`W] t -> int -> string -> unit
+  val get_vcpus : [>`R] t -> int -> int -> int * vcpu_info array * string
+  val get_max_vcpus : [>`R] t -> int
+  val attach_device : [>`W] t -> xml -> unit
+  val detach_device : [>`W] t -> xml -> unit
+
+  val migrate : [>`W] t -> [>`W] Connect.t -> migrate_flag list ->
+    ?dname:string -> ?uri:string -> ?bandwidth:int -> unit -> rw t
+
+  val block_stats : [>`R] t -> string -> block_stats
+  val interface_stats : [>`R] t -> string -> 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.
+  *)
+
+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
+  val lookup_by_uuid : 'a Connect.t -> uuid -> 'a t
+  val lookup_by_uuid_string : 'a Connect.t -> string -> 'a t
+  val create_xml : [>`W] Connect.t -> xml -> rw t
+  val define_xml : [>`W] Connect.t -> xml -> rw t
+  val undefine : [>`W] t -> unit
+  val create : [>`W] t -> unit
+  val destroy : [>`W] t -> unit
+  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
+  val get_uuid : [>`R] t -> uuid
+  val get_uuid_string : [>`R] t -> string
+  val get_xml_desc : [>`R] t -> xml
+  val get_bridge_name : [>`R] t -> string
+  val get_autostart : [>`R] t -> bool
+  val set_autostart : [>`W] t -> bool -> unit
+
+  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.
+  *)
+
+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
+       (** See [<libvirt/virterror.h>] for meaning of these codes. *)
+
+  val string_of_code : code -> string
+
+  type level =
+    | VIR_ERR_NONE
+    | VIR_ERR_WARNING
+    | VIR_ERR_ERROR
+       (** No error, a warning or an error. *)
+
+  val string_of_level : level -> 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
+       (** Subsystem / driver which produced the error. *)
+
+  val string_of_domain : domain -> 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.
+
+    Note that functions may also raise
+    [Invalid_argument "virFoo not supported"]
+    (where virFoo is the libvirt function name) if a function is
+    not supported at either compile or runtime.  This applies to
+    any libvirt function added after version 0.2.1.
+    See also [http://libvirt.org/hvsupport.html]
+*)
+
diff --git a/libvirt/libvirt_c.c b/libvirt/libvirt_c.c
new file mode 100644 (file)
index 0000000..808dd82
--- /dev/null
@@ -0,0 +1,1953 @@
+/* OCaml bindings for libvirt.
+ * (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
+ * http://libvirt.org/
+ * $Id: libvirt_c.c,v 1.6 2007/08/30 13:16:57 rjones Exp $
+ */
+
+#include "config.h"
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#include <libvirt/libvirt.h>
+#include <libvirt/virterror.h>
+
+#include <caml/config.h>
+#include <caml/alloc.h>
+#include <caml/callback.h>
+#include <caml/custom.h>
+#include <caml/fail.h>
+#include <caml/memory.h>
+#include <caml/misc.h>
+#include <caml/mlvalues.h>
+
+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 value _raise_virterror (virConnectPtr conn, const char *fn);
+static value Val_virterror (virErrorPtr err);
+
+#define CHECK_ERROR(cond, conn, fn) \
+  do { if (cond) _raise_virterror (conn, fn); } while (0)
+
+#define NOT_SUPPORTED(fn)                      \
+  caml_invalid_argument (fn " not supported")
+
+/* 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 */
+
+#ifdef HAVE_WEAK_SYMBOLS
+#ifdef HAVE_VIRCONNECTGETHOSTNAME
+extern char *virConnectGetHostname (virConnectPtr conn)
+  __attribute__((weak));
+#endif
+#ifdef HAVE_VIRCONNECTGETURI
+extern char *virConnectGetURI (virConnectPtr conn)
+  __attribute__((weak));
+#endif
+#ifdef HAVE_VIRDOMAINBLOCKSTATS
+extern int virDomainBlockStats (virDomainPtr dom,
+                               const char *path,
+                               virDomainBlockStatsPtr stats,
+                               size_t size)
+  __attribute__((weak));
+#endif
+#ifdef HAVE_VIRDOMAINGETSCHEDULERPARAMETERS
+extern int virDomainGetSchedulerParameters (virDomainPtr domain,
+                                           virSchedParameterPtr params,
+                                           int *nparams)
+  __attribute__((weak));
+#endif
+#ifdef HAVE_VIRDOMAINGETSCHEDULERTYPE
+extern char *virDomainGetSchedulerType(virDomainPtr domain,
+                                      int *nparams)
+  __attribute__((weak));
+#endif
+#ifdef HAVE_VIRDOMAININTERFACESTATS
+extern int virDomainInterfaceStats (virDomainPtr dom,
+                                   const char *path,
+                                   virDomainInterfaceStatsPtr stats,
+                                   size_t size)
+  __attribute__((weak));
+#endif
+#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
+#ifdef HAVE_VIRDOMAINSETSCHEDULERPARAMETERS
+extern int virDomainSetSchedulerParameters (virDomainPtr domain,
+                                           virSchedParameterPtr params,
+                                           int nparams)
+  __attribute__((weak));
+#endif
+#endif /* HAVE_WEAK_SYMBOLS */
+
+/*----------------------------------------------------------------------*/
+
+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;
+  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);
+}
+
+/*----------------------------------------------------------------------*/
+
+/* 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.).
+ */
+
+/* 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)))
+
+/* 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);
+
+/* 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)))
+#define Connect_domv(rv) (Connect_val(Field((rv),1)))
+#define Connect_netv(rv) (Connect_val(Field((rv),1)))
+
+static value Val_domain (virDomainPtr dom, value connv);
+static value Val_network (virNetworkPtr net, value connv);
+
+/* 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);
+
+/*----------------------------------------------------------------------*/
+
+/* 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;
+
+  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;
+
+  conn = virConnectOpenReadOnly (name);
+  CHECK_ERROR (!conn, NULL, "virConnectOpen");
+
+  rv = Val_connect (conn);
+
+  CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_connect_close (value connv)
+{
+  CAMLparam1 (connv);
+  virConnectPtr conn = Connect_val (connv);
+  int r;
+
+  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);
+}
+
+CAMLprim value
+ocaml_libvirt_connect_get_type (value connv)
+{
+  CAMLparam1 (connv);
+  CAMLlocal1 (rv);
+  virConnectPtr conn = Connect_val (connv);
+  const char *r;
+
+  r = virConnectGetType (conn);
+  CHECK_ERROR (!r, conn, "virConnectGetType");
+
+  rv = caml_copy_string (r);
+  CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_connect_get_version (value connv)
+{
+  CAMLparam1 (connv);
+  virConnectPtr conn = Connect_val (connv);
+  unsigned long hvVer;
+  int r;
+
+  r = virConnectGetVersion (conn, &hvVer);
+  CHECK_ERROR (r == -1, conn, "virConnectGetVersion");
+
+  CAMLreturn (Val_int (hvVer));
+}
+
+CAMLprim value
+ocaml_libvirt_connect_get_hostname (value connv)
+{
+#ifdef HAVE_VIRCONNECTGETHOSTNAME
+  CAMLparam1 (connv);
+  CAMLlocal1 (rv);
+  virConnectPtr conn = Connect_val (connv);
+  char *r;
+
+  WEAK_SYMBOL_CHECK (virConnectGetHostname);
+  r = virConnectGetHostname (conn);
+  CHECK_ERROR (!r, conn, "virConnectGetHostname");
+
+  rv = caml_copy_string (r);
+  free (r);
+  CAMLreturn (rv);
+#else
+  NOT_SUPPORTED ("virConnectGetHostname");
+#endif
+}
+
+CAMLprim value
+ocaml_libvirt_connect_get_uri (value connv)
+{
+#ifdef HAVE_VIRCONNECTGETURI
+  CAMLparam1 (connv);
+  CAMLlocal1 (rv);
+  virConnectPtr conn = Connect_val (connv);
+  char *r;
+
+  WEAK_SYMBOL_CHECK (virConnectGetURI);
+  r = virConnectGetURI (conn);
+  CHECK_ERROR (!r, conn, "virConnectGetURI");
+
+  rv = caml_copy_string (r);
+  free (r);
+  CAMLreturn (rv);
+#else
+  NOT_SUPPORTED ("virConnectGetURI");
+#endif
+}
+
+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;
+
+  r = virConnectGetMaxVcpus (conn, type);
+  CHECK_ERROR (r == -1, conn, "virConnectGetMaxVcpus");
+
+  CAMLreturn (Val_int (r));
+}
+
+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;
+
+  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);
+}
+
+CAMLprim value
+ocaml_libvirt_connect_num_of_domains (value connv)
+{
+  CAMLparam1 (connv);
+  virConnectPtr conn = Connect_val (connv);
+  int r;
+
+  r = virConnectNumOfDomains (conn);
+  CHECK_ERROR (r == -1, conn, "virConnectNumOfDomains");
+
+  CAMLreturn (Val_int (r));
+}
+
+CAMLprim value
+ocaml_libvirt_connect_get_capabilities (value connv)
+{
+  CAMLparam1 (connv);
+  CAMLlocal1 (rv);
+  virConnectPtr conn = Connect_val (connv);
+  char *r;
+
+  r = virConnectGetCapabilities (conn);
+  CHECK_ERROR (!r, conn, "virConnectGetCapabilities");
+
+  rv = caml_copy_string (r);
+  free (r);
+
+  CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_connect_num_of_defined_domains (value connv)
+{
+  CAMLparam1 (connv);
+  virConnectPtr conn = Connect_val (connv);
+  int r;
+
+  r = virConnectNumOfDefinedDomains (conn);
+  CHECK_ERROR (r == -1, conn, "virConnectNumOfDefinedDomains");
+
+  CAMLreturn (Val_int (r));
+}
+
+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;
+
+  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);
+}
+
+CAMLprim value
+ocaml_libvirt_connect_num_of_networks (value connv)
+{
+  CAMLparam1 (connv);
+  virConnectPtr conn = Connect_val (connv);
+  int r;
+
+  r = virConnectNumOfNetworks (conn);
+  CHECK_ERROR (r == -1, conn, "virConnectNumOfNetworks");
+
+  CAMLreturn (Val_int (r));
+}
+
+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;
+
+  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);
+}
+
+CAMLprim value
+ocaml_libvirt_connect_num_of_defined_networks (value connv)
+{
+  CAMLparam1 (connv);
+  virConnectPtr conn = Connect_val (connv);
+  int r;
+
+  r = virConnectNumOfDefinedNetworks (conn);
+  CHECK_ERROR (r == -1, conn, "virConnectNumOfDefinedNetworks");
+
+  CAMLreturn (Val_int (r));
+}
+
+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;
+
+  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);
+}
+
+CAMLprim value
+ocaml_libvirt_connect_get_node_info (value connv)
+{
+  CAMLparam1 (connv);
+  CAMLlocal2 (rv, v);
+  virConnectPtr conn = Connect_val (connv);
+  virNodeInfo info;
+  int r;
+
+  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);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_create_linux (value connv, value xmlv)
+{
+  CAMLparam2 (connv, xmlv);
+  CAMLlocal1 (rv);
+  virConnectPtr conn = Connect_val (connv);
+  char *xml = String_val (xmlv);
+  virDomainPtr r;
+
+  r = virDomainCreateLinux (conn, xml, 0);
+  CHECK_ERROR (!r, conn, "virDomainCreateLinux");
+
+  rv = Val_domain (r, connv);
+  CAMLreturn (rv);
+}
+
+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;
+
+  r = virDomainLookupByID (conn, i);
+  CHECK_ERROR (!r, conn, "virDomainLookupByID");
+
+  rv = Val_domain (r, connv);
+  CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_lookup_by_uuid (value connv, value uuidv)
+{
+  CAMLparam2 (connv, uuidv);
+  CAMLlocal1 (rv);
+  virConnectPtr conn = Connect_val (connv);
+  char *uuid = String_val (uuidv);
+  virDomainPtr r;
+
+  r = virDomainLookupByUUID (conn, (unsigned char *) uuid);
+  CHECK_ERROR (!r, conn, "virDomainLookupByUUID");
+
+  rv = Val_domain (r, connv);
+  CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_lookup_by_uuid_string (value connv, value uuidv)
+{
+  CAMLparam2 (connv, uuidv);
+  CAMLlocal1 (rv);
+  virConnectPtr conn = Connect_val (connv);
+  char *uuid = String_val (uuidv);
+  virDomainPtr r;
+
+  r = virDomainLookupByUUIDString (conn, uuid);
+  CHECK_ERROR (!r, conn, "virDomainLookupByUUIDString");
+
+  rv = Val_domain (r, connv);
+  CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_lookup_by_name (value connv, value namev)
+{
+  CAMLparam2 (connv, namev);
+  CAMLlocal1 (rv);
+  virConnectPtr conn = Connect_val (connv);
+  char *name = String_val (namev);
+  virDomainPtr r;
+
+  r = virDomainLookupByName (conn, name);
+  CHECK_ERROR (!r, conn, "virDomainLookupByName");
+
+  rv = Val_domain (r, connv);
+  CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_destroy (value domv)
+{
+  CAMLparam1 (domv);
+  virDomainPtr dom = Domain_val (domv);
+  virConnectPtr conn = Connect_domv (domv);
+  int r;
+
+  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);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_free (value domv)
+{
+  CAMLparam1 (domv);
+  virDomainPtr dom = Domain_val (domv);
+  virConnectPtr conn = Connect_domv (domv);
+  int r;
+
+  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);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_suspend (value domv)
+{
+  CAMLparam1 (domv);
+  virDomainPtr dom = Domain_val (domv);
+  virConnectPtr conn = Connect_domv (domv);
+  int r;
+
+  r = virDomainSuspend (dom);
+  CHECK_ERROR (r == -1, conn, "virDomainSuspend");
+
+  CAMLreturn (Val_unit);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_resume (value domv)
+{
+  CAMLparam1 (domv);
+  virDomainPtr dom = Domain_val (domv);
+  virConnectPtr conn = Connect_domv (domv);
+  int r;
+
+  r = virDomainResume (dom);
+  CHECK_ERROR (r == -1, conn, "virDomainResume");
+
+  CAMLreturn (Val_unit);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_save (value domv, value pathv)
+{
+  CAMLparam2 (domv, pathv);
+  virDomainPtr dom = Domain_val (domv);
+  virConnectPtr conn = Connect_domv (domv);
+  char *path = String_val (pathv);
+  int r;
+
+  r = virDomainSave (dom, path);
+  CHECK_ERROR (r == -1, conn, "virDomainSave");
+
+  CAMLreturn (Val_unit);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_restore (value connv, value pathv)
+{
+  CAMLparam2 (connv, pathv);
+  virConnectPtr conn = Connect_val (connv);
+  char *path = String_val (pathv);
+  int r;
+
+  r = virDomainRestore (conn, path);
+  CHECK_ERROR (r == -1, conn, "virDomainRestore");
+
+  CAMLreturn (Val_unit);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_core_dump (value domv, value pathv)
+{
+  CAMLparam2 (domv, pathv);
+  virDomainPtr dom = Domain_val (domv);
+  virConnectPtr conn = Connect_domv (domv);
+  char *path = String_val (pathv);
+  int r;
+
+  r = virDomainCoreDump (dom, path, 0);
+  CHECK_ERROR (r == -1, conn, "virDomainCoreDump");
+
+  CAMLreturn (Val_unit);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_shutdown (value domv)
+{
+  CAMLparam1 (domv);
+  virDomainPtr dom = Domain_val (domv);
+  virConnectPtr conn = Connect_domv (domv);
+  int r;
+
+  r = virDomainShutdown (dom);
+  CHECK_ERROR (r == -1, conn, "virDomainShutdown");
+
+  CAMLreturn (Val_unit);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_reboot (value domv)
+{
+  CAMLparam1 (domv);
+  virDomainPtr dom = Domain_val (domv);
+  virConnectPtr conn = Connect_domv (domv);
+  int r;
+
+  r = virDomainReboot (dom, 0);
+  CHECK_ERROR (r == -1, conn, "virDomainReboot");
+
+  CAMLreturn (Val_unit);
+}
+
+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;
+
+  r = virDomainGetName (dom);
+  CHECK_ERROR (!r, conn, "virDomainGetName");
+
+  rv = caml_copy_string (r);
+  CAMLreturn (rv);
+}
+
+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;
+
+  r = virDomainGetUUID (dom, uuid);
+  CHECK_ERROR (r == -1, conn, "virDomainGetUUID");
+
+  rv = caml_copy_string ((char *) uuid);
+  CAMLreturn (rv);
+}
+
+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;
+
+  r = virDomainGetUUIDString (dom, uuid);
+  CHECK_ERROR (r == -1, conn, "virDomainGetUUIDString");
+
+  rv = caml_copy_string (uuid);
+  CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_get_id (value domv)
+{
+  CAMLparam1 (domv);
+  virDomainPtr dom = Domain_val (domv);
+  virConnectPtr conn = Connect_domv (domv);
+  unsigned int r;
+
+  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_os_type (value domv)
+{
+  CAMLparam1 (domv);
+  CAMLlocal1 (rv);
+  virDomainPtr dom = Domain_val (domv);
+  virConnectPtr conn = Connect_domv (domv);
+  char *r;
+
+  r = virDomainGetOSType (dom);
+  CHECK_ERROR (!r, conn, "virDomainGetOSType");
+
+  rv = caml_copy_string (r);
+  free (r);
+  CAMLreturn (rv);
+}
+
+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;
+
+  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;
+
+  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;
+
+  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;
+
+  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);
+}
+
+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;
+
+  r = virDomainGetXMLDesc (dom, 0);
+  CHECK_ERROR (!r, conn, "virDomainGetXMLDesc");
+
+  rv = caml_copy_string (r);
+  free (r);
+  CAMLreturn (rv);
+}
+
+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);
+  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
+}
+
+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);
+  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
+}
+
+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);
+  r = virDomainSetSchedulerParameters (dom, params, nparams);
+  CHECK_ERROR (r == -1, conn, "virDomainSetSchedulerParameters");
+
+  CAMLreturn (Val_unit);
+#else
+  NOT_SUPPORTED ("virDomainSetSchedulerParameters");
+#endif
+}
+
+CAMLprim value
+ocaml_libvirt_domain_define_xml (value connv, value xmlv)
+{
+  CAMLparam2 (connv, xmlv);
+  CAMLlocal1 (rv);
+  virConnectPtr conn = Connect_val (connv);
+  char *xml = String_val (xmlv);
+  virDomainPtr r;
+
+  r = virDomainDefineXML (conn, xml);
+  CHECK_ERROR (!r, conn, "virDomainDefineXML");
+
+  rv = Val_domain (r, connv);
+  CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_undefine (value domv)
+{
+  CAMLparam1 (domv);
+  virDomainPtr dom = Domain_val (domv);
+  virConnectPtr conn = Connect_domv (domv);
+  int r;
+
+  r = virDomainUndefine (dom);
+  CHECK_ERROR (r == -1, conn, "virDomainUndefine");
+
+  CAMLreturn (Val_unit);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_create (value domv)
+{
+  CAMLparam1 (domv);
+  virDomainPtr dom = Domain_val (domv);
+  virConnectPtr conn = Connect_domv (domv);
+  int r;
+
+  r = virDomainCreate (dom);
+  CHECK_ERROR (r == -1, conn, "virDomainCreate");
+
+  CAMLreturn (Val_unit);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_get_autostart (value domv)
+{
+  CAMLparam1 (domv);
+  virDomainPtr dom = Domain_val (domv);
+  virConnectPtr conn = Connect_domv (domv);
+  int r, autostart;
+
+  r = virDomainGetAutostart (dom, &autostart);
+  CHECK_ERROR (r == -1, conn, "virDomainGetAutostart");
+
+  CAMLreturn (autostart ? Val_true : Val_false);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_set_autostart (value domv, value autostartv)
+{
+  CAMLparam2 (domv, autostartv);
+  virDomainPtr dom = Domain_val (domv);
+  virConnectPtr conn = Connect_domv (domv);
+  int r, autostart = autostartv == Val_true ? 1 : 0;
+
+  r = virDomainSetAutostart (dom, autostart);
+  CHECK_ERROR (r == -1, conn, "virDomainSetAutostart");
+
+  CAMLreturn (Val_unit);
+}
+
+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);
+
+  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;
+
+  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);
+
+  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);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_get_max_vcpus (value domv)
+{
+  CAMLparam1 (domv);
+  virDomainPtr dom = Domain_val (domv);
+  virConnectPtr conn = Connect_domv (domv);
+  int r;
+
+  r = virDomainGetMaxVcpus (dom);
+  CHECK_ERROR (r == -1, conn, "virDomainGetMaxVcpus");
+
+  CAMLreturn (Val_int (r));
+}
+
+CAMLprim value
+ocaml_libvirt_domain_attach_device (value domv, value xmlv)
+{
+  CAMLparam2 (domv, xmlv);
+  virDomainPtr dom = Domain_val (domv);
+  virConnectPtr conn = Connect_domv (domv);
+  char *xml = String_val (xmlv);
+  int r;
+
+  r = virDomainAttachDevice (dom, xml);
+  CHECK_ERROR (r == -1, conn, "virDomainAttachDevice");
+
+  CAMLreturn (Val_unit);
+}
+
+CAMLprim value
+ocaml_libvirt_domain_detach_device (value domv, value xmlv)
+{
+  CAMLparam2 (domv, xmlv);
+  virDomainPtr dom = Domain_val (domv);
+  virConnectPtr conn = Connect_domv (domv);
+  char *xml = String_val (xmlv);
+  int r;
+
+  r = virDomainDetachDevice (dom, xml);
+  CHECK_ERROR (r == -1, conn, "virDomainDetachDevice");
+
+  CAMLreturn (Val_unit);
+}
+
+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);
+  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]);
+}
+
+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);
+  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
+}
+
+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);
+  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
+}
+
+CAMLprim value
+ocaml_libvirt_network_lookup_by_name (value connv, value namev)
+{
+  CAMLparam2 (connv, namev);
+  CAMLlocal1 (rv);
+  virConnectPtr conn = Connect_val (connv);
+  char *name = String_val (namev);
+  virNetworkPtr r;
+
+  r = virNetworkLookupByName (conn, name);
+  CHECK_ERROR (!r, conn, "virNetworkLookupByName");
+
+  rv = Val_network (r, connv);
+  CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_network_lookup_by_uuid (value connv, value uuidv)
+{
+  CAMLparam2 (connv, uuidv);
+  CAMLlocal1 (rv);
+  virConnectPtr conn = Connect_val (connv);
+  char *uuid = String_val (uuidv);
+  virNetworkPtr r;
+
+  r = virNetworkLookupByUUID (conn, (unsigned char *) uuid);
+  CHECK_ERROR (!r, conn, "virNetworkLookupByUUID");
+
+  rv = Val_network (r, connv);
+  CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_network_lookup_by_uuid_string (value connv, value uuidv)
+{
+  CAMLparam2 (connv, uuidv);
+  CAMLlocal1 (rv);
+  virConnectPtr conn = Connect_val (connv);
+  char *uuid = String_val (uuidv);
+  virNetworkPtr r;
+
+  r = virNetworkLookupByUUIDString (conn, uuid);
+  CHECK_ERROR (!r, conn, "virNetworkLookupByUUIDString");
+
+  rv = Val_network (r, connv);
+  CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_network_create_xml (value connv, value xmlv)
+{
+  CAMLparam2 (connv, xmlv);
+  CAMLlocal1 (rv);
+  virConnectPtr conn = Connect_val (connv);
+  char *xml = String_val (xmlv);
+  virNetworkPtr r;
+
+  r = virNetworkCreateXML (conn, xml);
+  CHECK_ERROR (!r, conn, "virNetworkCreateXML");
+
+  rv = Val_network (r, connv);
+  CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_network_define_xml (value connv, value xmlv)
+{
+  CAMLparam2 (connv, xmlv);
+  CAMLlocal1 (rv);
+  virConnectPtr conn = Connect_val (connv);
+  char *xml = String_val (xmlv);
+  virNetworkPtr r;
+
+  r = virNetworkDefineXML (conn, xml);
+  CHECK_ERROR (!r, conn, "virNetworkDefineXML");
+
+  rv = Val_network (r, connv);
+  CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_network_undefine (value netv)
+{
+  CAMLparam1 (netv);
+  virNetworkPtr net = Network_val (netv);
+  virConnectPtr conn = Connect_netv (netv);
+  int r;
+
+  r = virNetworkUndefine (net);
+  CHECK_ERROR (r == -1, conn, "virNetworkUndefine");
+
+  CAMLreturn (Val_unit);
+}
+
+CAMLprim value
+ocaml_libvirt_network_create (value netv)
+{
+  CAMLparam1 (netv);
+  virNetworkPtr net = Network_val (netv);
+  virConnectPtr conn = Connect_netv (netv);
+  int r;
+
+  r = virNetworkCreate (net);
+  CHECK_ERROR (r == -1, conn, "virNetworkCreate");
+
+  CAMLreturn (Val_unit);
+}
+
+CAMLprim value
+ocaml_libvirt_network_destroy (value netv)
+{
+  CAMLparam1 (netv);
+  virNetworkPtr net = Network_val (netv);
+  virConnectPtr conn = Connect_netv (netv);
+  int r;
+
+  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);
+}
+
+CAMLprim value
+ocaml_libvirt_network_free (value netv)
+{
+  CAMLparam1 (netv);
+  virNetworkPtr net = Network_val (netv);
+  virConnectPtr conn = Connect_netv (netv);
+  int r;
+
+  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);
+}
+
+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;
+
+  r = virNetworkGetName (net);
+  CHECK_ERROR (!r, conn, "virNetworkGetName");
+
+  rv = caml_copy_string (r);
+  CAMLreturn (rv);
+}
+
+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;
+
+  r = virNetworkGetUUID (net, uuid);
+  CHECK_ERROR (r == -1, conn, "virNetworkGetUUID");
+
+  rv = caml_copy_string ((char *) uuid);
+  CAMLreturn (rv);
+}
+
+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;
+
+  r = virNetworkGetUUIDString (net, uuid);
+  CHECK_ERROR (r == -1, conn, "virNetworkGetUUIDString");
+
+  rv = caml_copy_string (uuid);
+  CAMLreturn (rv);
+}
+
+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;
+
+  r = virNetworkGetXMLDesc (net, 0);
+  CHECK_ERROR (!r, conn, "virNetworkGetXMLDesc");
+
+  rv = caml_copy_string (r);
+  free (r);
+  CAMLreturn (rv);
+}
+
+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;
+
+  r = virNetworkGetBridgeName (net);
+  CHECK_ERROR (!r, conn, "virNetworkGetBridgeName");
+
+  rv = caml_copy_string (r);
+  free (r);
+  CAMLreturn (rv);
+}
+
+CAMLprim value
+ocaml_libvirt_network_get_autostart (value netv)
+{
+  CAMLparam1 (netv);
+  virNetworkPtr net = Network_val (netv);
+  virConnectPtr conn = Connect_netv (netv);
+  int r, autostart;
+
+  r = virNetworkGetAutostart (net, &autostart);
+  CHECK_ERROR (r == -1, conn, "virNetworkGetAutostart");
+
+  CAMLreturn (autostart ? Val_true : Val_false);
+}
+
+CAMLprim value
+ocaml_libvirt_network_set_autostart (value netv, value autostartv)
+{
+  CAMLparam2 (netv, autostartv);
+  virNetworkPtr net = Network_val (netv);
+  virConnectPtr conn = Connect_netv (netv);
+  int r, autostart = autostartv == Val_true ? 1 : 0;
+
+  r = virNetworkSetAutostart (net, autostart);
+  CHECK_ERROR (r == -1, conn, "virNetworkSetAutostart");
+
+  CAMLreturn (Val_unit);
+}
+
+/*----------------------------------------------------------------------*/
+
+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);
+}
+
+/*----------------------------------------------------------------------*/
+
+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 value
+_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*/
+  CAMLreturn (Val_unit);
+}
+
+static value
+Val_virterror (virErrorPtr err)
+{
+  CAMLparam0 ();
+  CAMLlocal3 (rv, connv, optv);
+
+  rv = caml_alloc (12, 0);
+  Store_field (rv, 0, Val_int (err->code));
+  Store_field (rv, 1, Val_int (err->domain));
+  Store_field (rv, 2,
+              Val_opt (err->message, (Val_ptr_t) caml_copy_string));
+  Store_field (rv, 3, Val_int (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);
+
+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
+};
+
+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);
+}
+
+/* This wraps up the raw domain handle (Domain.dom). */
+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);
+}
+
+/* This wraps up the raw network handle (Network.net). */
+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);
+}
+
+/* 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);
+}
+
+/* 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);
+}
diff --git a/libvirt/libvirt_version.ml b/libvirt/libvirt_version.ml
new file mode 100644 (file)
index 0000000..329d22e
--- /dev/null
@@ -0,0 +1,6 @@
+(* Helper module containing the version of the OCaml bindings.
+ * $Id: libvirt_version.ml.in,v 1.2 2007/08/21 12:33:40 rjones Exp $
+ *)
+
+let package = "ocaml-libvirt"
+let version = "0.3.2.4"
diff --git a/libvirt/libvirt_version.ml.in b/libvirt/libvirt_version.ml.in
new file mode 100644 (file)
index 0000000..8214980
--- /dev/null
@@ -0,0 +1,6 @@
+(* Helper module containing the version of the OCaml bindings.
+ * $Id: libvirt_version.ml.in,v 1.2 2007/08/21 12:33:40 rjones Exp $
+ *)
+
+let package = "@PACKAGE_NAME@"
+let version = "@PACKAGE_VERSION@"
diff --git a/libvirt/libvirt_version.mli b/libvirt/libvirt_version.mli
new file mode 100644 (file)
index 0000000..847089a
--- /dev/null
@@ -0,0 +1,12 @@
+(** OCaml bindings for libvirt.
+    (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
+    http://libvirt.org/
+    $Id: libvirt_version.mli,v 1.2 2007/08/21 14:36:15 rjones Exp $
+*)
+
+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/.cvsignore b/mlvirsh/.cvsignore
new file mode 100644 (file)
index 0000000..7d561e2
--- /dev/null
@@ -0,0 +1,8 @@
+*.cmi
+*.cmo
+*.cmx
+*.cma
+*.cmxa
+Makefile
+mlvirsh
+mlvirsh.opt
\ No newline at end of file
diff --git a/mlvirsh/.depend b/mlvirsh/.depend
new file mode 100644 (file)
index 0000000..a346edd
--- /dev/null
@@ -0,0 +1,2 @@
+mlvirsh.cmo: ../libvirt/libvirt.cmi 
+mlvirsh.cmx: ../libvirt/libvirt.cmx 
diff --git a/mlvirsh/Makefile b/mlvirsh/Makefile
new file mode 100644 (file)
index 0000000..5160fde
--- /dev/null
@@ -0,0 +1,42 @@
+# $Id: Makefile.in,v 1.2 2007/08/21 14:24:38 rjones Exp $
+
+INSTALL                := /usr/bin/install -c
+
+prefix         = /usr/local
+exec_prefix    = ${prefix}
+bindir         = ${exec_prefix}/bin
+
+OCAMLCPACKAGES := -package extlib,unix -I ../libvirt
+OCAMLCFLAGS    := -g
+OCAMLCLIBS     := -linkpkg
+
+OCAMLOPTPACKAGES := $(OCAMLCPACKAGES)
+OCAMLOPTFLAGS  :=
+OCAMLOPTLIBS   := $(OCAMLCLIBS)
+
+export LIBRARY_PATH=../libvirt
+export LD_LIBRARY_PATH=../libvirt
+
+BYTE_TARGETS   := mlvirsh
+OPT_TARGETS    := mlvirsh.opt
+
+all: $(BYTE_TARGETS)
+
+opt: $(OPT_TARGETS)
+
+mlvirsh: mlvirsh.cmo
+       ocamlfind ocamlc $(OCAMLCPACKAGES) $(OCAMLCFLAGS) $(OCAMLCLIBS) \
+         ../libvirt/mllibvirt.cma -o $@ $<
+
+mlvirsh.opt: mlvirsh.cmx
+       ocamlfind ocamlopt \
+         $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \
+         ../libvirt/mllibvirt.cmxa -o $@ $<
+
+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/Makefile.in b/mlvirsh/Makefile.in
new file mode 100644 (file)
index 0000000..3798962
--- /dev/null
@@ -0,0 +1,42 @@
+# $Id: Makefile.in,v 1.2 2007/08/21 14:24:38 rjones Exp $
+
+INSTALL                := @INSTALL@
+
+prefix         = @prefix@
+exec_prefix    = @exec_prefix@
+bindir         = @bindir@
+
+OCAMLCPACKAGES := -package extlib,unix -I ../libvirt
+OCAMLCFLAGS    := -g
+OCAMLCLIBS     := -linkpkg
+
+OCAMLOPTPACKAGES := $(OCAMLCPACKAGES)
+OCAMLOPTFLAGS  :=
+OCAMLOPTLIBS   := $(OCAMLCLIBS)
+
+export LIBRARY_PATH=../libvirt
+export LD_LIBRARY_PATH=../libvirt
+
+BYTE_TARGETS   := mlvirsh
+OPT_TARGETS    := mlvirsh.opt
+
+all: $(BYTE_TARGETS)
+
+opt: $(OPT_TARGETS)
+
+mlvirsh: mlvirsh.cmo
+       ocamlfind ocamlc $(OCAMLCPACKAGES) $(OCAMLCFLAGS) $(OCAMLCLIBS) \
+         ../libvirt/mllibvirt.cma -o $@ $<
+
+mlvirsh.opt: mlvirsh.cmx
+       ocamlfind ocamlopt \
+         $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \
+         ../libvirt/mllibvirt.cmxa -o $@ $<
+
+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
new file mode 100644 (file)
index 0000000..5b63a77
--- /dev/null
@@ -0,0 +1,690 @@
+(* virsh-like command line tool.
+   (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
+   http://libvirt.org/
+   $Id: mlvirsh.ml,v 1.2 2007/08/21 13:24:09 rjones Exp $
+*)
+
+open ExtString
+open Printf
+
+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 Hypervisor connection URI";
+  "-r", Arg.Set readonly, " Read-only connection";
+]
+
+let usage_msg = "\
+Synopsis:
+  " ^ program_name ^ " [options] [command]
+
+List of all commands:
+  " ^ program_name ^ " help
+
+Full description of a single command:
+  " ^ program_name ^ " help command
+
+Options:"
+
+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
+
+(* Hypervisor connection. *)
+type conn_t = No_connection | RO of Libvirt.ro C.t | RW of Libvirt.rw C.t
+let conn = ref No_connection
+
+let close_connection () =
+  match !conn with
+  | No_connection -> ()
+  | RO c ->
+      C.close c;
+      conn := No_connection
+  | RW c ->
+      C.close c;
+      conn := No_connection
+
+let do_command =
+  (* Command helper functions.
+   *
+   * Each cmd<n> is a function that constructs a command.
+   *    string string string  ...  <--- user types on the command line
+   *      |      |      |
+   *     arg1   arg2   arg3   ...  <--- conversion functions
+   *      |      |      |
+   *      V      V      V
+   *         function f            <--- work function
+   *             |
+   *             V
+   *        print result           <--- printing function
+   *
+   * (Note that cmd<n> function constructs and returns the above
+   * function, it isn't the function itself.)
+   *
+   * Example: If the function takes one parameter (an int) and
+   * returns a string to be printed, you would use:
+   *
+   *   cmd1 print_endline f int_of_string
+   *)
+  let cmd0 print fn = function         (* Command with no args. *)
+    | [] -> print (fn ())
+    | _ -> failwith "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"
+  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"
+  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"
+  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"
+  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"
+  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 "not connected to the hypervisor"
+    | RO _ -> failwith "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"
+    | 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 "flag should be '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'"
+  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 ("domain " ^ str ^ ": not found.  Additional info: " ^
+                   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 ("network " ^ str ^ ": not found.  Additional info: " ^
+                   Libvirt.Virterror.to_string err);
+  in
+  let rec parse_sched_params = function
+    | [] -> []
+    | [_] -> failwith "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 (String.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_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 -> "unknown"
+    | D.InfoRunning -> "running"
+    | D.InfoBlocked -> "blocked"
+    | D.InfoPaused -> "paused"
+    | D.InfoShutdown -> "shutdown"
+    | D.InfoShutoff -> "shutoff"
+    | D.InfoCrashed -> "crashed"
+  in
+  let string_of_vcpu_state = function
+    | D.VcpuOffline -> "offline"
+    | D.VcpuRunning -> "running"
+    | D.VcpuBlocked -> "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 =
+    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;
+  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;
+  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
+      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:    ";
+      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 "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;
+  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;
+  in
+
+  (* List of commands. *)
+  let commands = [
+    "attach-device",
+      cmd2 no_return D.attach_device
+       (arg_full_connection domain_of_string) input_file,
+      "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.";
+    "capabilities",
+      cmd0 print_endline (with_readonly_connection C.get_capabilities),
+      "Returns capabilities of hypervisor/driver.";
+    "close",
+      cmd0 no_return close_connection,
+      "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,
+      "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.";
+    "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.";
+    "detach-device",
+      cmd2 no_return D.detach_device
+       (arg_full_connection domain_of_string) input_file,
+      "Detach device from domain.";
+    "destroy",
+      cmd1 no_return D.destroy (arg_full_connection domain_of_string),
+      "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.";
+    "domid",
+      cmd1 print_int D.get_id (arg_readonly_connection domain_of_string),
+      "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.";
+    "dominfo",
+      cmd1 print_domain_info D.get_info
+       (arg_readonly_connection domain_of_string),
+      "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.";
+    "dommaxvcpus",
+      cmd1 print_int D.get_max_vcpus
+       (arg_readonly_connection domain_of_string),
+      "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.";
+    "domostype",
+      cmd1 print_endline D.get_os_type
+       (arg_readonly_connection domain_of_string),
+      "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.";
+    "domuuid",
+      cmd1 print_endline D.get_uuid_string
+       (arg_readonly_connection domain_of_string),
+      "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.";
+    "dumpxml",
+      cmd1 print_endline D.get_xml_desc
+       (arg_full_connection domain_of_string),
+      "Print the XML description of a domain.";
+    "get-autostart",
+      cmd1 print_bool D.get_autostart
+       (arg_readonly_connection domain_of_string),
+      "Print whether a domain autostarts at boot.";
+    "hostname",
+      cmd0 print_endline (with_readonly_connection C.get_hostname),
+      "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),
+      "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),
+      "List the defined but not running domains.";
+    "quit",
+      cmd0 no_return (fun () -> exit 0),
+      "Quit the interactive terminal.";
+    "maxvcpus",
+      cmd0 print_int (fun () -> C.get_max_vcpus (get_readonly_connection ()) ()),
+      "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.";
+    "net-bridgename",
+      cmd1 print_endline N.get_bridge_name
+       (arg_readonly_connection network_of_string),
+      "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.";
+    "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.";
+    "net-destroy",
+      cmd1 no_return N.destroy (arg_full_connection network_of_string),
+      "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.";
+    "net-get-autostart",
+      cmd1 print_bool N.get_autostart
+       (arg_full_connection network_of_string),
+      "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),
+      "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),
+      "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.";
+    "net-start",
+      cmd1 no_return N.create
+       (arg_full_connection network_of_string),
+      "Start a previously defined inactive network.";
+    "net-undefine",
+      cmd1 no_return N.undefine
+       (arg_full_connection network_of_string),
+      "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.";
+    "nodeinfo",
+      cmd0 print_node_info (with_readonly_connection C.get_node_info),
+      "Print node information.";
+    "reboot",
+      cmd1 no_return D.reboot (arg_full_connection domain_of_string),
+      "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.";
+    "resume",
+      cmd1 no_return D.resume (arg_full_connection domain_of_string),
+      "Resume a domain.";
+    "save",
+      cmd2 no_return D.save
+       (arg_full_connection domain_of_string) string_of_string,
+      "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.";
+    "schedparamset",
+      cmdN no_return (
+       function
+       | [] -> failwith "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
+        ),
+      "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.";
+    "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).";
+    "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).";
+    "shutdown",
+      cmd1 no_return D.shutdown
+       (arg_full_connection domain_of_string),
+      "Gracefully shutdown a domain.";
+    "start",
+      cmd1 no_return D.create
+       (arg_full_connection domain_of_string),
+      "Start a previously defined inactive domain.";
+    "suspend",
+      cmd1 no_return D.suspend
+       (arg_full_connection domain_of_string),
+      "Suspend a domain.";
+    "type",
+      cmd0 print_endline (with_readonly_connection C.get_type),
+      "Print the driver name";
+    "undefine",
+      cmd1 no_return D.undefine
+       (arg_full_connection domain_of_string),
+      "Undefine an inactive domain.";
+    "uri",
+      cmd0 print_endline (with_readonly_connection C.get_uri),
+      "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),
+      "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.";
+    "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.";
+    "version",
+      cmd0 print_version (with_readonly_connection C.get_version),
+      "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\nUse '" ^ program_name ^ " help command' for help on a command."
+
+    | 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 ("help: " ^ command ^ ": command not found");
+  in
+
+  let commands =
+    ("help",
+     cmd01 print_endline help string_of_string,
+     "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 (command ^ ": command not found");
+  in
+
+  do_command
+
+(* Interactive mode. *)
+let rec interactive_mode () =
+  let prompt =
+    match !conn with
+    | No_connection -> "mlvirsh(no connection)$ "
+    | RO _ -> "mlvirsh(ro)$ "
+    | RW _ -> "mlvirsh# " in
+  print_string prompt;
+  let command = read_line () in
+  (match String.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/mlvirtmanager/.cvsignore b/mlvirtmanager/.cvsignore
new file mode 100644 (file)
index 0000000..df80d41
--- /dev/null
@@ -0,0 +1,8 @@
+*.cmi
+*.cmo
+*.cmx
+*.cma
+*.cmxa
+Makefile
+mlvirtmanager
+mlvirtmanager.opt
\ No newline at end of file
diff --git a/mlvirtmanager/.depend b/mlvirtmanager/.depend
new file mode 100644 (file)
index 0000000..01a1aa6
--- /dev/null
@@ -0,0 +1,22 @@
+mlvirtmanager_connections.cmi: ../libvirt/libvirt.cmi 
+mlvirtmanager_domain_ops.cmi: mlvirtmanager_connections.cmi 
+mlvirtmanager_helpers.cmi: ../libvirt/libvirt.cmi 
+mlvirtmanager_mainwindow.cmi: mlvirtmanager_connections.cmi 
+mlvirtmanager_connections.cmo: mlvirtmanager_helpers.cmi \
+    ../libvirt/libvirt.cmi mlvirtmanager_connections.cmi 
+mlvirtmanager_connections.cmx: mlvirtmanager_helpers.cmx \
+    ../libvirt/libvirt.cmx mlvirtmanager_connections.cmi 
+mlvirtmanager_domain_ops.cmo: mlvirtmanager_connections.cmi \
+    ../libvirt/libvirt.cmi mlvirtmanager_domain_ops.cmi 
+mlvirtmanager_domain_ops.cmx: mlvirtmanager_connections.cmx \
+    ../libvirt/libvirt.cmx mlvirtmanager_domain_ops.cmi 
+mlvirtmanager_helpers.cmo: ../libvirt/libvirt.cmi mlvirtmanager_helpers.cmi 
+mlvirtmanager_helpers.cmx: ../libvirt/libvirt.cmx mlvirtmanager_helpers.cmi 
+mlvirtmanager_mainwindow.cmo: mlvirtmanager_connections.cmi \
+    ../libvirt/libvirt.cmi mlvirtmanager_mainwindow.cmi 
+mlvirtmanager_mainwindow.cmx: mlvirtmanager_connections.cmx \
+    ../libvirt/libvirt.cmx mlvirtmanager_mainwindow.cmi 
+mlvirtmanager.cmo: mlvirtmanager_mainwindow.cmi mlvirtmanager_domain_ops.cmi \
+    mlvirtmanager_connections.cmi 
+mlvirtmanager.cmx: mlvirtmanager_mainwindow.cmx mlvirtmanager_domain_ops.cmx \
+    mlvirtmanager_connections.cmx 
diff --git a/mlvirtmanager/Makefile b/mlvirtmanager/Makefile
new file mode 100644 (file)
index 0000000..3921a15
--- /dev/null
@@ -0,0 +1,51 @@
+# $Id: Makefile.in,v 1.2 2007/08/21 14:24:38 rjones Exp $
+
+INSTALL                := /usr/bin/install -c
+
+prefix         = /usr/local
+exec_prefix    = ${prefix}
+bindir         = ${exec_prefix}/bin
+
+OCAMLCPACKAGES := -package extlib,unix,lablgtk2 -I ../libvirt
+OCAMLCFLAGS    := -g
+OCAMLCLIBS     := -linkpkg
+
+OCAMLOPTPACKAGES := $(OCAMLCPACKAGES)
+OCAMLOPTFLAGS  :=
+OCAMLOPTLIBS   := $(OCAMLCLIBS)
+
+export LIBRARY_PATH=../libvirt
+export LD_LIBRARY_PATH=../libvirt
+
+BYTE_TARGETS   := mlvirtmanager
+OPT_TARGETS    := mlvirtmanager.opt
+
+VIRTMANAGER_OBJS := \
+       mlvirtmanager_helpers.cmo \
+       mlvirtmanager_connections.cmo \
+       mlvirtmanager_domain_ops.cmo \
+       mlvirtmanager_mainwindow.cmo \
+       mlvirtmanager.cmo
+
+VIRTMANAGER_XOBJS := $(VIRTMANAGER_OBJS:.cmo=.cmx)
+
+all: $(BYTE_TARGETS)
+
+opt: $(OPT_TARGETS)
+
+mlvirtmanager: $(VIRTMANAGER_OBJS)
+       ocamlfind ocamlc $(OCAMLCPACKAGES) $(OCAMLCFLAGS) $(OCAMLCLIBS) \
+         ../libvirt/mllibvirt.cma gtkInit.cmo -o $@ $<
+
+mlvirtmanager.opt: $(VIRTMANAGER_XOBJS)
+       ocamlfind ocamlopt \
+         $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \
+         ../libvirt/mllibvirt.cmxa gtkInit.cmx -o $@ $<
+
+install:
+       if [ -x mlvirtmanager.opt ]; then \
+         mkdir -p $(DESTDIR)$(bindir); \
+         $(INSTALL) -m 0755 mlvirtmanager.opt $(DESTDIR)$(bindir)/mlvirtmanager; \
+       fi
+
+include ../Make.rules
diff --git a/mlvirtmanager/Makefile.in b/mlvirtmanager/Makefile.in
new file mode 100644 (file)
index 0000000..fe75929
--- /dev/null
@@ -0,0 +1,51 @@
+# $Id: Makefile.in,v 1.2 2007/08/21 14:24:38 rjones Exp $
+
+INSTALL                := @INSTALL@
+
+prefix         = @prefix@
+exec_prefix    = @exec_prefix@
+bindir         = @bindir@
+
+OCAMLCPACKAGES := -package extlib,unix,lablgtk2 -I ../libvirt
+OCAMLCFLAGS    := -g
+OCAMLCLIBS     := -linkpkg
+
+OCAMLOPTPACKAGES := $(OCAMLCPACKAGES)
+OCAMLOPTFLAGS  :=
+OCAMLOPTLIBS   := $(OCAMLCLIBS)
+
+export LIBRARY_PATH=../libvirt
+export LD_LIBRARY_PATH=../libvirt
+
+BYTE_TARGETS   := mlvirtmanager
+OPT_TARGETS    := mlvirtmanager.opt
+
+VIRTMANAGER_OBJS := \
+       mlvirtmanager_helpers.cmo \
+       mlvirtmanager_connections.cmo \
+       mlvirtmanager_domain_ops.cmo \
+       mlvirtmanager_mainwindow.cmo \
+       mlvirtmanager.cmo
+
+VIRTMANAGER_XOBJS := $(VIRTMANAGER_OBJS:.cmo=.cmx)
+
+all: $(BYTE_TARGETS)
+
+opt: $(OPT_TARGETS)
+
+mlvirtmanager: $(VIRTMANAGER_OBJS)
+       ocamlfind ocamlc $(OCAMLCPACKAGES) $(OCAMLCFLAGS) $(OCAMLCLIBS) \
+         ../libvirt/mllibvirt.cma gtkInit.cmo -o $@ $<
+
+mlvirtmanager.opt: $(VIRTMANAGER_XOBJS)
+       ocamlfind ocamlopt \
+         $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \
+         ../libvirt/mllibvirt.cmxa gtkInit.cmx -o $@ $<
+
+install:
+       if [ -x mlvirtmanager.opt ]; then \
+         mkdir -p $(DESTDIR)$(bindir); \
+         $(INSTALL) -m 0755 mlvirtmanager.opt $(DESTDIR)$(bindir)/mlvirtmanager; \
+       fi
+
+include ../Make.rules
diff --git a/mlvirtmanager/mlvirtmanager.ml b/mlvirtmanager/mlvirtmanager.ml
new file mode 100644 (file)
index 0000000..091c026
--- /dev/null
@@ -0,0 +1,19 @@
+(* virt-manager-like graphical management tool.
+   (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
+   http://libvirt.org/
+   $Id: mlvirtmanager.ml,v 1.1 2007/08/06 10:16:53 rjones Exp $
+*)
+
+open Printf
+
+let () =
+  (* Build the main window and wire up the buttons to the callback functions *)
+  Mlvirtmanager_mainwindow.make
+    ~open_connection:Mlvirtmanager_connections.open_connection
+    ~start_domain:Mlvirtmanager_domain_ops.start_domain
+    ~pause_domain:Mlvirtmanager_domain_ops.pause_domain
+    ~resume_domain:Mlvirtmanager_domain_ops.resume_domain
+    ~shutdown_domain:Mlvirtmanager_domain_ops.shutdown_domain;
+
+  (* Enter the Gtk main loop. *)
+  GMain.main ()
diff --git a/mlvirtmanager/mlvirtmanager_connections.ml b/mlvirtmanager/mlvirtmanager_connections.ml
new file mode 100644 (file)
index 0000000..2fda3e9
--- /dev/null
@@ -0,0 +1,313 @@
+(* virt-manager-like graphical management tool.
+   (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
+   http://libvirt.org/
+   $Id: mlvirtmanager_connections.ml,v 1.1 2007/08/06 10:16:53 rjones Exp $
+*)
+
+open Printf
+
+module C = Libvirt.Connect
+module D = Libvirt.Domain
+module N = Libvirt.Network
+
+open Mlvirtmanager_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
+
+(* 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 last "CPU time" seen for a domain, so we can calculate CPU % usage.
+ * Hash of (connid, domid) -> cpu_time [int64].
+ *)
+let last_cpu_time = Hashtbl.create 13
+let last_time = ref (Unix.gettimeofday ())
+
+type columns = string GTree.column * string GTree.column * string GTree.column * string GTree.column * string GTree.column * int GTree.column
+
+let debug_repopulate = true
+
+(* 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 =
+  let time_passed =
+    let time_now = Unix.gettimeofday () in
+    let time_passed = time_now -. !last_time in
+    last_time := time_now;
+    time_passed in
+
+  (* 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. *)
+      let name =
+       try C.get_hostname (List.assoc conn_id conns)
+       with Not_found | Libvirt.Virterror _ ->
+         "Conn #" ^ string_of_int conn_id in
+      model#set ~row ~column:col_name_id name;
+      model#set ~row ~column:col_id conn_id;
+      (* XXX This doesn't work, why? *)
+      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
+         (* Node info & number of CPUs available. *)
+         let node_info = C.get_node_info conn 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;
+
+                 let ns_now = info.D.cpu_time in (* ns = nanoseconds *)
+                 let ns_prev =
+                   try
+                     let ns = Hashtbl.find last_cpu_time (conn_id, domid) in
+                     if ns > ns_now then 0L else ns (* Rebooted? *)
+                   with Not_found -> 0L in
+                 Hashtbl.replace last_cpu_time (conn_id, domid) ns_now;
+                 let ns_now = Int64.to_float ns_now in
+                 let ns_prev = Int64.to_float ns_prev in
+                 let ns_used = ns_now -. ns_prev in
+                 let ns_available = 1_000_000_000. *. float nr_cpus in
+                 let cpu_percent =
+                   100. *. (ns_used /. ns_available) /. time_passed in
+                 let cpu_percent = sprintf "%.1f %%" cpu_percent in
+                 model#set ~row ~column:col_cpu cpu_percent;
+
+               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 "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;
+
+  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)
+
+(* Callback function to open a connection.
+ * This should be a lot more sophisticated. XXX
+ *)
+let open_connection () =
+  let title = "Open connection to hypervisor" in
+  let name =
+    GToolbox.input_string ~title ~text:"xen:///" ~ok:"Open" "Connection:" in
+  match name with
+  | None -> ()
+  | Some name ->
+      (* If this fails, let the exception escape and be printed
+       * in the global exception handler.
+       *)
+      let conn = C.connect ~name () in
+      ignore (add_conn conn)
diff --git a/mlvirtmanager/mlvirtmanager_connections.mli b/mlvirtmanager/mlvirtmanager_connections.mli
new file mode 100644 (file)
index 0000000..eb11be8
--- /dev/null
@@ -0,0 +1,34 @@
+(* virt-manager-like graphical management tool.
+   (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
+   http://libvirt.org/
+   $Id: mlvirtmanager_connections.mli,v 1.1 2007/08/06 10:16:53 rjones Exp $
+
+   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
+
+(** This callback creates the Connect to hypervisor dialog. *)
+val open_connection : unit -> unit
diff --git a/mlvirtmanager/mlvirtmanager_domain_ops.ml b/mlvirtmanager/mlvirtmanager_domain_ops.ml
new file mode 100644 (file)
index 0000000..f02cd1f
--- /dev/null
@@ -0,0 +1,83 @@
+(* virt-manager-like graphical management tool.
+   (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
+   http://libvirt.org/
+   $Id: mlvirtmanager_domain_ops.ml,v 1.1 2007/08/06 10:16:53 rjones Exp $
+
+   Domain operations buttons.
+*)
+
+open Printf
+
+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 : Mlvirtmanager_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 conn_id.
+       * 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 conn_id = model#get ~row:parent ~column:col_id in
+           let conn =
+             List.assoc conn_id (Mlvirtmanager_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, -1)
+           ) else if domid > 0 then (  (* Active domU. *)
+             let dom = D.lookup_by_id conn domid in
+             let info = D.get_info dom in
+             Some (dom, info, domid)
+           ) else                      (* Dom0 - ignore. *)
+             None
+         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
+
+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
diff --git a/mlvirtmanager/mlvirtmanager_domain_ops.mli b/mlvirtmanager/mlvirtmanager_domain_ops.mli
new file mode 100644 (file)
index 0000000..9824b3a
--- /dev/null
@@ -0,0 +1,12 @@
+(* virt-manager-like graphical management tool.
+   (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
+   http://libvirt.org/
+   $Id: mlvirtmanager_domain_ops.mli,v 1.1 2007/08/06 10:16:53 rjones Exp $
+
+   Domain operations buttons.
+*)
+
+val start_domain : GTree.view -> GTree.tree_store -> Mlvirtmanager_connections.columns -> unit -> unit
+val pause_domain : GTree.view -> GTree.tree_store -> Mlvirtmanager_connections.columns -> unit -> unit
+val resume_domain : GTree.view -> GTree.tree_store -> Mlvirtmanager_connections.columns -> unit -> unit
+val shutdown_domain : GTree.view -> GTree.tree_store -> Mlvirtmanager_connections.columns -> unit -> unit
diff --git a/mlvirtmanager/mlvirtmanager_helpers.ml b/mlvirtmanager/mlvirtmanager_helpers.ml
new file mode 100644 (file)
index 0000000..ff30253
--- /dev/null
@@ -0,0 +1,82 @@
+(* virt-manager-like graphical management tool.
+   (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
+   http://libvirt.org/
+   $Id: mlvirtmanager_helpers.ml,v 1.1 2007/08/06 10:16:53 rjones Exp $
+*)
+
+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 -> "unknown"
+  | D.InfoRunning -> "running"
+  | D.InfoBlocked -> "blocked"
+  | D.InfoPaused -> "paused"
+  | D.InfoShutdown -> "shutdown"
+  | D.InfoShutoff -> "shutoff"
+  | D.InfoCrashed -> "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/mlvirtmanager/mlvirtmanager_helpers.mli b/mlvirtmanager/mlvirtmanager_helpers.mli
new file mode 100644 (file)
index 0000000..2952636
--- /dev/null
@@ -0,0 +1,38 @@
+(* virt-manager-like graphical management tool.
+   (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
+   http://libvirt.org/
+   $Id: mlvirtmanager_helpers.mli,v 1.1 2007/08/06 10:16:53 rjones Exp $
+
+   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/mlvirtmanager/mlvirtmanager_mainwindow.ml b/mlvirtmanager/mlvirtmanager_mainwindow.ml
new file mode 100644 (file)
index 0000000..93ee34b
--- /dev/null
@@ -0,0 +1,134 @@
+(* virt-manager-like graphical management tool.
+   (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
+   http://libvirt.org/
+   $Id: mlvirtmanager_mainwindow.ml,v 1.1 2007/08/06 10:16:53 rjones Exp $
+*)
+
+open Printf
+
+let title = "Virtual Machine Manager"
+
+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
+    ("Virtual machine manager (OCaml version) by\n" ^
+     "Richard W.M. Jones (rjones@redhat.com).\n\n" ^
+     "Copyright " ^ utf8_copyright ^ " 2007 Red Hat Inc.\n\n" ^
+     "Libvirt version: " ^ virt_version ^ "\n" ^
+     "Gtk toolkit 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)
+    | Failure msg -> msg
+    | exn -> Printexc.to_string exn
+  in
+  GtkSignal.user_handler :=
+    fun exn ->
+      let label = string_of_exn exn in
+      let title = "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 ~open_connection
+    ~start_domain ~pause_domain ~resume_domain ~shutdown_domain =
+  (* 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 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
+
+  (* File menu. *)
+  let factory = new GMenu.factory file_menu ~accel_group in
+  let open_item = factory#add_item "Open connection ..."
+    ~key:GdkKeysyms._O in
+  ignore (factory#add_separator ());
+  let quit_item = factory#add_item "Quit" ~key:GdkKeysyms._Q in
+
+  ignore (open_item#connect#activate ~callback:open_connection);
+
+  (* 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
+
+  ignore (help_about_item#connect#activate ~callback:help_about);
+
+  (* The toolbar. *)
+  let toolbar = GButton.toolbar ~packing:vbox#pack () in
+  let connect_button =
+    GButton.tool_button ~label:"Connect ..." ~stock:`CONNECT
+      ~packing:toolbar#insert () in
+  let start_button =
+    GButton.tool_button ~label:"Start" ~stock:`ADD
+      ~packing:toolbar#insert () in
+  let pause_button =
+    GButton.tool_button ~label:"Pause" ~stock:`MEDIA_PAUSE
+      ~packing:toolbar#insert () in
+  let resume_button =
+    GButton.tool_button ~label:"Resume" ~stock:`MEDIA_PLAY
+      ~packing:toolbar#insert () in
+  let shutdown_button =
+    GButton.tool_button ~label:"Shutdown" ~stock:`STOP
+      ~packing:toolbar#insert () in
+  ignore (connect_button#connect#clicked ~callback:open_connection);
+
+  (* The treeview. *)
+  let (tree, model, columns, initial_state) =
+    Mlvirtmanager_connections.make_treeview
+      ~packing:(vbox#pack ~expand:true ~fill:true) () in
+
+  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));
+
+  (* Make a timeout function which is called once per second. *)
+  let state = ref initial_state in
+  let callback () =
+    state := Mlvirtmanager_connections.repopulate tree model columns !state;
+    true
+  in
+  let timeout_id = GMain.Timeout.add ~ms:1000 ~callback in
+
+  (* Quit. *)
+  let quit _ =
+    GMain.Timeout.remove timeout_id;
+    GMain.Main.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 ()); ()));
+
+  window#add_accel_group accel_group;
+
+  (* Display the window. *)
+  window#show ()
diff --git a/mlvirtmanager/mlvirtmanager_mainwindow.mli b/mlvirtmanager/mlvirtmanager_mainwindow.mli
new file mode 100644 (file)
index 0000000..2ca9928
--- /dev/null
@@ -0,0 +1,16 @@
+(* virt-manager-like graphical management tool.
+   (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
+   http://libvirt.org/
+   $Id: mlvirtmanager_mainwindow.mli,v 1.1 2007/08/06 10:16:53 rjones Exp $
+
+   Make the main window.
+*)
+
+(** This function creates the main window.  You have to pass in
+    callback functions to wire everything up.
+*)
+val make : open_connection:(unit -> unit) ->
+  start_domain:(GTree.view -> GTree.tree_store -> Mlvirtmanager_connections.columns -> unit -> unit) ->
+  pause_domain:(GTree.view -> GTree.tree_store -> Mlvirtmanager_connections.columns -> unit -> unit) ->
+  resume_domain:(GTree.view -> GTree.tree_store -> Mlvirtmanager_connections.columns -> unit -> unit) ->
+  shutdown_domain:(GTree.view -> GTree.tree_store -> Mlvirtmanager_connections.columns -> unit -> unit) -> unit
diff --git a/virt-top/.cvsignore b/virt-top/.cvsignore
new file mode 100644 (file)
index 0000000..cb61894
--- /dev/null
@@ -0,0 +1,8 @@
+*.cmi
+*.cmo
+*.cmx
+*.cma
+*.cmxa
+Makefile
+virt-top
+virt-top.opt
\ No newline at end of file
diff --git a/virt-top/.depend b/virt-top/.depend
new file mode 100644 (file)
index 0000000..75ecf81
--- /dev/null
@@ -0,0 +1,8 @@
+virt_top_csv.cmo: virt_top.cmo ../libvirt/libvirt.cmi 
+virt_top_csv.cmx: virt_top.cmx ../libvirt/libvirt.cmx 
+virt_top_main.cmo: virt_top.cmo ../libvirt/libvirt.cmi 
+virt_top_main.cmx: virt_top.cmx ../libvirt/libvirt.cmx 
+virt_top.cmo: ../libvirt/libvirt_version.cmi ../libvirt/libvirt.cmi 
+virt_top.cmx: ../libvirt/libvirt_version.cmx ../libvirt/libvirt.cmx 
+virt_top_xml.cmo: virt_top.cmo ../libvirt/libvirt.cmi 
+virt_top_xml.cmx: virt_top.cmx ../libvirt/libvirt.cmx 
diff --git a/virt-top/Makefile b/virt-top/Makefile
new file mode 100644 (file)
index 0000000..9c7ef0b
--- /dev/null
@@ -0,0 +1,79 @@
+# $Id: Makefile.in,v 1.6 2007/08/23 11:09:19 rjones Exp $
+
+PACKAGE                := ocaml-libvirt
+VERSION                := 0.3.2.4
+
+INSTALL                := /usr/bin/install -c
+HAVE_PERLDOC   := perldoc
+
+prefix         = /usr/local
+exec_prefix    = ${prefix}
+bindir         = ${exec_prefix}/bin
+
+pkg_curses     = yes
+pkg_xml_light  = yes
+pkg_csv                = yes
+
+OCAMLCPACKAGES := -package unix,extlib,curses
+
+OBJS           := virt_top.cmo
+ifeq ($(pkg_xml_light),yes)
+OBJS           += virt_top_xml.cmo
+OCAMLCPACKAGES := $(OCAMLCPACKAGES),xml-light
+endif
+ifeq ($(pkg_csv),yes)
+OBJS           += virt_top_csv.cmo
+OCAMLCPACKAGES := $(OCAMLCPACKAGES),csv
+endif
+OBJS           += virt_top_main.cmo
+
+XOBJS          := $(OBJS:.cmo=.cmx)
+
+OCAMLCPACKAGES  += -I ../libvirt
+OCAMLCFLAGS    := -g -w s
+OCAMLCLIBS     := -linkpkg
+
+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
+
+ifeq ($(HAVE_PERLDOC),perldoc)
+BYTE_TARGETS   += virt-top.1 virt-top.txt
+endif
+
+all: $(BYTE_TARGETS)
+
+opt: $(OPT_TARGETS)
+
+virt-top: $(OBJS)
+       ocamlfind ocamlc $(OCAMLCPACKAGES) $(OCAMLCFLAGS) $(OCAMLCLIBS) \
+         ../libvirt/mllibvirt.cma -o $@ $^
+
+virt-top.opt: $(XOBJS)
+       ocamlfind ocamlopt \
+         $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \
+         ../libvirt/mllibvirt.cmxa -cclib -lncurses -o $@ $^
+
+# Manual page.
+ifeq ($(HAVE_PERLDOC),perldoc)
+virt-top.1: virt-top.pod
+       pod2man -c "Virtualization Support" --release "$(PACKAGE)-$(VERSION)" \
+               $< > $@
+
+virt-top.txt: virt-top.pod
+       pod2text $< > $@
+endif
+
+install:
+       if [ -x virt-top.opt ]; then \
+         mkdir -p $(DESTDIR)$(bindir); \
+         $(INSTALL) -m 0755 virt-top.opt $(DESTDIR)$(bindir)/virt-top; \
+       fi
+
+include ../Make.rules
diff --git a/virt-top/Makefile.in b/virt-top/Makefile.in
new file mode 100644 (file)
index 0000000..e1cb75f
--- /dev/null
@@ -0,0 +1,79 @@
+# $Id: Makefile.in,v 1.6 2007/08/23 11:09:19 rjones Exp $
+
+PACKAGE                := @PACKAGE_NAME@
+VERSION                := @PACKAGE_VERSION@
+
+INSTALL                := @INSTALL@
+HAVE_PERLDOC   := @HAVE_PERLDOC@
+
+prefix         = @prefix@
+exec_prefix    = @exec_prefix@
+bindir         = @bindir@
+
+pkg_curses     = @pkg_curses@
+pkg_xml_light  = @pkg_xml_light@
+pkg_csv                = @pkg_csv@
+
+OCAMLCPACKAGES := -package unix,extlib,curses
+
+OBJS           := virt_top.cmo
+ifeq ($(pkg_xml_light),yes)
+OBJS           += virt_top_xml.cmo
+OCAMLCPACKAGES := $(OCAMLCPACKAGES),xml-light
+endif
+ifeq ($(pkg_csv),yes)
+OBJS           += virt_top_csv.cmo
+OCAMLCPACKAGES := $(OCAMLCPACKAGES),csv
+endif
+OBJS           += virt_top_main.cmo
+
+XOBJS          := $(OBJS:.cmo=.cmx)
+
+OCAMLCPACKAGES  += -I ../libvirt
+OCAMLCFLAGS    := -g -w s
+OCAMLCLIBS     := -linkpkg
+
+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
+
+ifeq ($(HAVE_PERLDOC),perldoc)
+BYTE_TARGETS   += virt-top.1 virt-top.txt
+endif
+
+all: $(BYTE_TARGETS)
+
+opt: $(OPT_TARGETS)
+
+virt-top: $(OBJS)
+       ocamlfind ocamlc $(OCAMLCPACKAGES) $(OCAMLCFLAGS) $(OCAMLCLIBS) \
+         ../libvirt/mllibvirt.cma -o $@ $^
+
+virt-top.opt: $(XOBJS)
+       ocamlfind ocamlopt \
+         $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \
+         ../libvirt/mllibvirt.cmxa -cclib -lncurses -o $@ $^
+
+# Manual page.
+ifeq ($(HAVE_PERLDOC),perldoc)
+virt-top.1: virt-top.pod
+       pod2man -c "Virtualization Support" --release "$(PACKAGE)-$(VERSION)" \
+               $< > $@
+
+virt-top.txt: virt-top.pod
+       pod2text $< > $@
+endif
+
+install:
+       if [ -x virt-top.opt ]; then \
+         mkdir -p $(DESTDIR)$(bindir); \
+         $(INSTALL) -m 0755 virt-top.opt $(DESTDIR)$(bindir)/virt-top; \
+       fi
+
+include ../Make.rules
diff --git a/virt-top/README b/virt-top/README
new file mode 100644 (file)
index 0000000..c3752c6
--- /dev/null
@@ -0,0 +1,42 @@
+$Id: README,v 1.1 2007/08/30 13:52:40 rjones Exp $
+
+The code is structured into these files:
+
+  virt_top.ml
+
+    This is the virt-top program.
+
+    The interesting function is called 'redraw', which is responsible
+    for redrawing the display on each frame.  Another interesting
+    function is 'start_up' which handles all start-up stuff, eg.
+    command line arguments, connecting to the hypervisor, enabling
+    curses.  The function 'main_loop' runs the main loop and has
+    sub-functions to deal with keypresses, help screens and so on.
+
+  virt_top_xml.ml
+
+    Any code which needs the optional xml-light library goes
+    in here.  Mainly for parsing domain XML descriptions to get
+    the list of block devices and network interfaces.
+
+    The reason for having it in a separate file is so that we
+    don't depend on xml-light.
+
+  virt_top_csv.ml
+
+    Any code which need the optional ocaml-csv library goes
+    in here.  This implements the --csv command line option.
+
+  virt_top_main.ml
+
+    This is just a small bit of code to glue whatever modules
+    (Virt_top + Virt_top_xml? + Virt_top_csv?) together.
+
+The man-page is generated from the single file:
+
+  virt-top.pod
+
+which generates (using perldoc) the following:
+
+  virt-top.1
+  virt-top.txt
diff --git a/virt-top/virt-top.1 b/virt-top/virt-top.1
new file mode 100644 (file)
index 0000000..7e9c5d4
--- /dev/null
@@ -0,0 +1,328 @@
+.\" 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-TOP 1"
+.TH VIRT-TOP 1 "2007-08-30" "ocaml-libvirt-0.3.2.6" "Virtualization Support"
+.SH "NAME"
+virt\-top \- 'top'\-like utility for virtualization stats
+.SH "SUMMARY"
+.IX Header "SUMMARY"
+virt-top [\-options]
+.SH "DESCRIPTION"
+.IX Header "DESCRIPTION"
+virt-top is a \fItop\fR\|(1)\-like utility for showing stats of virtualized
+domains.  Many keys and command line options are the same as for
+ordinary \fItop\fR.
+.PP
+It uses libvirt so it is capable of showing stats across a variety of
+different virtualization systems.
+.SH "OPTIONS"
+.IX Header "OPTIONS"
+.IP "\fB\-1\fR" 4
+.IX Item "-1"
+Display physical CPUs by default (instead of domains).
+When virt-top is running, use the \fI1\fR key to toggle
+between physical CPUs and domains display.
+.IP "\fB\-2\fR" 4
+.IX Item "-2"
+Display network interfaces by default (instead of domains).
+When virt-top is running, use the \fI2\fR key to toggle
+between network interfaces and domains display.
+.IP "\fB\-3\fR" 4
+.IX Item "-3"
+Display block devices (virtual disks) by default (instead of domains).
+When virt-top is running, use the \fI3\fR key to toggle
+between block devices and domains display.
+.IP "\fB\-b\fR" 4
+.IX Item "-b"
+Batch mode.  In this mode keypresses are ignored.
+.IP "\fB\-c uri\fR or \fB\-\-connect uri\fR" 4
+.IX Item "-c uri or --connect uri"
+Connect to \s-1URI\s0 given.  The default is to connect to the Xen
+hypervisor.
+.IP "\fB\-d delay\fR" 4
+.IX Item "-d delay"
+Set the delay between screen updates in seconds.
+The default is 3.0 seconds.  You can change this
+while virt-top is running by pressing either \fIs\fR or \fId\fR key.
+.IP "\fB\-n iterations\fR" 4
+.IX Item "-n iterations"
+Set the number of iterations to run.  The default
+is to run continuously.
+.IP "\fB\-o sort\fR" 4
+.IX Item "-o sort"
+Set the sort order to one of:
+\&\fBcpu\fR (sort by \f(CW%CPU\fR used),
+\&\fBmem\fR (sort by memory used),
+\&\fBtime\fR (sort by total time),
+\&\fBid\fR (sort by domain \s-1ID\s0),
+\&\fBname\fR (sort by domain name),
+\&\fBnetrx\fR (sort by network received bytes),
+\&\fBnettx\fR (sort by network transmitted bytes),
+\&\fBblockrdrq\fR (sort by block device [disk] read requests),
+\&\fBblockwrrq\fR (sort by block device [disk] write requests).
+.Sp
+While virt-top is running you can change the sort
+order using keys \fIP\fR (cpu), \fIM\fR (memory),
+\&\fIT\fR (total time), \fIN\fR (domain \s-1ID\s0),
+\&\fIF\fR (interactively select the sort field).
+.IP "\fB\-s\fR" 4
+.IX Item "-s"
+Secure mode.  Currently this does nothing.
+.IP "\fB\-\-hist\-cpu secs\fR" 4
+.IX Item "--hist-cpu secs"
+Set the time in seconds between updates of the historical
+\&\f(CW%CPU\fR at the top right of the display.
+.IP "\fB\-\-csv file.csv\fR" 4
+.IX Item "--csv file.csv"
+Write the statistics to file \fIfile.csv\fR.  First a header is written
+showing the statistics being recorded in each column, then one line is
+written for each screen update.  The \s-1CSV\s0 file can be loaded directly
+by most spreadsheet programs.
+.Sp
+Currently the statistics which this records vary between releases of
+virt-top (but the column headers will stay the same, so you can use
+those to process the \s-1CSV\s0 file).
+.Sp
+Not every version of virt-top supports \s-1CSV\s0 output \- it depends how the
+program was compiled (see \fI\s-1README\s0\fR file in the source distribution
+for details).
+.IP "\fB\-\-debug filename\fR" 4
+.IX Item "--debug filename"
+Send debug and error messages to \fIfilename\fR.
+To send error messages to syslog you can do:
+.Sp
+.Vb 1
+\& virt-top --debug >(logger -t virt-top)
+.Ve
+.Sp
+See also \s-1REPORTING\s0 \s-1BUGS\s0 below.
+.IP "\fB\-\-help\fR" 4
+.IX Item "--help"
+Display usage summary.
+.SH "KEYS"
+.IX Header "KEYS"
+Note that keys are case sensitive.  For example use upper-case \fIP\fR
+(shift P) to sort by \f(CW%CPU\fR.  \fI^\fR before a key means a Ctrl key, so
+\&\fI^L\fR is Ctrl L.
+.IP "\fIspace\fR or \fI^L\fR" 4
+.IX Item "space or ^L"
+Updates the display.
+.IP "\fIq\fR" 4
+.IX Item "q"
+Quits the program.
+.IP "\fIh\fR" 4
+.IX Item "h"
+Displays help.
+.IP "\fIs\fR or \fId\fR" 4
+.IX Item "s or d"
+Change the delay between screen updates.
+.IP "\fI0\fR (number 0)" 4
+.IX Item "0 (number 0)"
+Show the normal list of domains display.
+.IP "\fI1\fR (number 1)" 4
+.IX Item "1 (number 1)"
+Toggle into showing physical CPUs.  If pressed
+again toggles back to showing domains (the normal
+display).
+.IP "\fI2\fR" 4
+.IX Item "2"
+Toggle into showing network interfaces.  If pressed
+again toggles back to showing domains.
+.IP "\fI3\fR" 4
+.IX Item "3"
+Toggle into showing block devices (virtual disks).  If pressed again
+toggles back to showing domains.
+.IP "\fIP\fR" 4
+.IX Item "P"
+Sort by \f(CW%CPU\fR.
+.IP "\fIM\fR" 4
+.IX Item "M"
+Sort by memory.
+.IP "\fIT\fR" 4
+.IX Item "T"
+Sort by total time.
+.IP "\fIN\fR" 4
+.IX Item "N"
+Sort by domain \s-1ID\s0.
+.IP "\fIF\fR" 4
+.IX Item "F"
+Select the sort field interactively (there are other
+sort fields you can choose using this key).
+.SH "SEE ALSO"
+.IX Header "SEE ALSO"
+\&\fItop\fR\|(1),
+\&\fIvirsh\fR\|(1),
+\&\fIxm\fR\|(1),
+\&\fIxentop\fR\|(1),
+<http://www.libvirt.org/>,
+<http://et.redhat.com/~rjones/>,
+<http://caml.inria.fr/>
+.SH "AUTHORS"
+.IX Header "AUTHORS"
+Richard W.M. Jones <rjones @ redhat . com>
+.SH "REPORTING BUGS"
+.IX Header "REPORTING BUGS"
+Bugs can be viewed on the Red Hat Bugzilla page:
+<https://bugzilla.redhat.com/>.
+.PP
+If you find a bug in virt\-top, please follow these steps to report it:
+.IP "1. Check for existing bug reports" 4
+.IX Item "1. Check for existing bug reports"
+Go to <https://bugzilla.redhat.com/> and search for similar bugs.
+Someone may already have reported the same bug, and they may even
+have fixed it.
+.IP "2. Capture debug and error messages" 4
+.IX Item "2. Capture debug and error messages"
+Run
+.Sp
+.Vb 1
+\& virt-top --debug virt-top.log
+.Ve
+.Sp
+and keep \fIvirt\-top.log\fR.  It contains error messages which you
+should submit with your bug report.
+.IP "3. Get version of virt-top and version of libvirt." 4
+.IX Item "3. Get version of virt-top and version of libvirt."
+In virt\-top, press the \fIh\fR (help) key, and write down the version of
+virt-top and the version of libvirt.  They are shown in the first
+line.
+.IP "4. Submit a bug report." 4
+.IX Item "4. Submit a bug report."
+Go to <https://bugzilla.redhat.com/> and enter a new bug.
+Please describe the problem in as much detail as possible.
+.Sp
+Remember to include the version numbers (step 3) and the debug
+messages file (step 2).
+.IP "5. Assign the bug to rjones @ redhat.com" 4
+.IX Item "5. Assign the bug to rjones @ redhat.com"
+Assign or reassign the bug to \fBrjones @ redhat.com\fR (without the
+spaces).  You can also send me an email with the bug number if you
+want a faster response.
diff --git a/virt-top/virt-top.pod b/virt-top/virt-top.pod
new file mode 100644 (file)
index 0000000..fe8ba91
--- /dev/null
@@ -0,0 +1,244 @@
+=head1 NAME
+
+virt-top - 'top'-like utility for virtualization stats
+
+=head1 SUMMARY
+
+virt-top [-options]
+
+=head1 DESCRIPTION
+
+virt-top is a L<top(1)>-like utility for showing stats of virtualized
+domains.  Many keys and command line options are the same as for
+ordinary I<top>.
+
+It uses libvirt so it is capable of showing stats across a variety of
+different virtualization systems.
+
+=head1 OPTIONS
+
+=over 4
+
+=item B<-1>
+
+Display physical CPUs by default (instead of domains).
+When virt-top is running, use the I<1> key to toggle
+between physical CPUs and domains display.
+
+=item B<-2>
+
+Display network interfaces by default (instead of domains).
+When virt-top is running, use the I<2> key to toggle
+between network interfaces and domains display.
+
+=item B<-3>
+
+Display block devices (virtual disks) by default (instead of domains).
+When virt-top is running, use the I<3> key to toggle
+between block devices and domains display.
+
+=item B<-b>
+
+Batch mode.  In this mode keypresses are ignored.
+
+=item B<-c uri> or B<--connect uri>
+
+Connect to URI given.  The default is to connect to the Xen
+hypervisor.
+
+=item B<-d delay>
+
+Set the delay between screen updates in seconds.
+The default is 3.0 seconds.  You can change this
+while virt-top is running by pressing either I<s> or I<d> key.
+
+=item B<-n iterations>
+
+Set the number of iterations to run.  The default
+is to run continuously.
+
+=item B<-o sort>
+
+Set the sort order to one of:
+B<cpu> (sort by %CPU used),
+B<mem> (sort by memory used),
+B<time> (sort by total time),
+B<id> (sort by domain ID),
+B<name> (sort by domain name),
+B<netrx> (sort by network received bytes),
+B<nettx> (sort by network transmitted bytes),
+B<blockrdrq> (sort by block device [disk] read requests),
+B<blockwrrq> (sort by block device [disk] write requests).
+
+While virt-top is running you can change the sort
+order using keys I<P> (cpu), I<M> (memory),
+I<T> (total time), I<N> (domain ID),
+I<F> (interactively select the sort field).
+
+=item B<-s>
+
+Secure mode.  Currently this does nothing.
+
+=item B<--hist-cpu secs>
+
+Set the time in seconds between updates of the historical
+%CPU at the top right of the display.
+
+=item B<--csv file.csv>
+
+Write the statistics to file I<file.csv>.  First a header is written
+showing the statistics being recorded in each column, then one line is
+written for each screen update.  The CSV file can be loaded directly
+by most spreadsheet programs.
+
+Currently the statistics which this records vary between releases of
+virt-top (but the column headers will stay the same, so you can use
+those to process the CSV file).
+
+Not every version of virt-top supports CSV output - it depends how the
+program was compiled (see I<README> file in the source distribution
+for details).
+
+=item B<--debug filename>
+
+Send debug and error messages to I<filename>.
+To send error messages to syslog you can do:
+
+ virt-top --debug >(logger -t virt-top)
+
+See also REPORTING BUGS below.
+
+=item B<--help>
+
+Display usage summary.
+
+=back
+
+=head1 KEYS
+
+Note that keys are case sensitive.  For example use upper-case I<P>
+(shift P) to sort by %CPU.  I<^> before a key means a Ctrl key, so
+I<^L> is Ctrl L.
+
+=over 4
+
+=item I<space> or I<^L>
+
+Updates the display.
+
+=item I<q>
+
+Quits the program.
+
+=item I<h>
+
+Displays help.
+
+=item I<s> or I<d>
+
+Change the delay between screen updates.
+
+=item I<0> (number 0)
+
+Show the normal list of domains display.
+
+=item I<1> (number 1)
+
+Toggle into showing physical CPUs.  If pressed
+again toggles back to showing domains (the normal
+display).
+
+=item I<2>
+
+Toggle into showing network interfaces.  If pressed
+again toggles back to showing domains.
+
+=item I<3>
+
+Toggle into showing block devices (virtual disks).  If pressed again
+toggles back to showing domains.
+
+=item I<P>
+
+Sort by %CPU.
+
+=item I<M>
+
+Sort by memory.
+
+=item I<T>
+
+Sort by total time.
+
+=item I<N>
+
+Sort by domain ID.
+
+=item I<F>
+
+Select the sort field interactively (there are other
+sort fields you can choose using this key).
+
+=back
+
+=head1 SEE ALSO
+
+L<top(1)>,
+L<virsh(1)>,
+L<xm(1)>,
+L<xentop(1)>,
+L<http://www.libvirt.org/>,
+L<http://et.redhat.com/~rjones/>,
+L<http://caml.inria.fr/>
+
+=head1 AUTHORS
+
+Richard W.M. Jones <rjones @ redhat . com>
+
+=head1 REPORTING BUGS
+
+Bugs can be viewed on the Red Hat Bugzilla page:
+L<https://bugzilla.redhat.com/>.
+
+If you find a bug in virt-top, please follow these steps to report it:
+
+=over 4
+
+=item 1. Check for existing bug reports
+
+Go to L<https://bugzilla.redhat.com/> and search for similar bugs.
+Someone may already have reported the same bug, and they may even
+have fixed it.
+
+=item 2. Capture debug and error messages
+
+Run
+
+ virt-top --debug virt-top.log
+
+and keep I<virt-top.log>.  It contains error messages which you
+should submit with your bug report.
+
+=item 3. Get version of virt-top and version of libvirt.
+
+In virt-top, press the I<h> (help) key, and write down the version of
+virt-top and the version of libvirt.  They are shown in the first
+line.
+
+=item 4. Submit a bug report.
+
+Go to L<https://bugzilla.redhat.com/> and enter a new bug.
+Please describe the problem in as much detail as possible.
+
+Remember to include the version numbers (step 3) and the debug
+messages file (step 2).
+
+=item 5. Assign the bug to rjones @ redhat.com
+
+Assign or reassign the bug to B<rjones @ redhat.com> (without the
+spaces).  You can also send me an email with the bug number if you
+want a faster response.
+
+=back
+
+=end
diff --git a/virt-top/virt-top.txt b/virt-top/virt-top.txt
new file mode 100644 (file)
index 0000000..ee2a426
--- /dev/null
@@ -0,0 +1,167 @@
+NAME
+    virt-top - 'top'-like utility for virtualization stats
+
+SUMMARY
+    virt-top [-options]
+
+DESCRIPTION
+    virt-top is a top(1)-like utility for showing stats of virtualized
+    domains. Many keys and command line options are the same as for ordinary
+    *top*.
+
+    It uses libvirt so it is capable of showing stats across a variety of
+    different virtualization systems.
+
+OPTIONS
+    -1  Display physical CPUs by default (instead of domains). When virt-top
+        is running, use the *1* key to toggle between physical CPUs and
+        domains display.
+
+    -2  Display network interfaces by default (instead of domains). When
+        virt-top is running, use the *2* key to toggle between network
+        interfaces and domains display.
+
+    -3  Display block devices (virtual disks) by default (instead of
+        domains). When virt-top is running, use the *3* key to toggle
+        between block devices and domains display.
+
+    -b  Batch mode. In this mode keypresses are ignored.
+
+    -c uri or --connect uri
+        Connect to URI given. The default is to connect to the Xen
+        hypervisor.
+
+    -d delay
+        Set the delay between screen updates in seconds. The default is 3.0
+        seconds. You can change this while virt-top is running by pressing
+        either *s* or *d* key.
+
+    -n iterations
+        Set the number of iterations to run. The default is to run
+        continuously.
+
+    -o sort
+        Set the sort order to one of: cpu (sort by %CPU used), mem (sort by
+        memory used), time (sort by total time), id (sort by domain ID),
+        name (sort by domain name), netrx (sort by network received bytes),
+        nettx (sort by network transmitted bytes), blockrdrq (sort by block
+        device [disk] read requests), blockwrrq (sort by block device [disk]
+        write requests).
+
+        While virt-top is running you can change the sort order using keys
+        *P* (cpu), *M* (memory), *T* (total time), *N* (domain ID), *F*
+        (interactively select the sort field).
+
+    -s  Secure mode. Currently this does nothing.
+
+    --hist-cpu secs
+        Set the time in seconds between updates of the historical %CPU at
+        the top right of the display.
+
+    --csv file.csv
+        Write the statistics to file *file.csv*. First a header is written
+        showing the statistics being recorded in each column, then one line
+        is written for each screen update. The CSV file can be loaded
+        directly by most spreadsheet programs.
+
+        Currently the statistics which this records vary between releases of
+        virt-top (but the column headers will stay the same, so you can use
+        those to process the CSV file).
+
+        Not every version of virt-top supports CSV output - it depends how
+        the program was compiled (see *README* file in the source
+        distribution for details).
+
+    --debug filename
+        Send debug and error messages to *filename*. To send error messages
+        to syslog you can do:
+
+         virt-top --debug >(logger -t virt-top)
+
+        See also REPORTING BUGS below.
+
+    --help
+        Display usage summary.
+
+KEYS
+    Note that keys are case sensitive. For example use upper-case *P* (shift
+    P) to sort by %CPU. *^* before a key means a Ctrl key, so *^L* is Ctrl
+    L.
+
+    *space* or *^L*
+        Updates the display.
+
+    *q* Quits the program.
+
+    *h* Displays help.
+
+    *s* or *d*
+        Change the delay between screen updates.
+
+    *0* (number 0)
+        Show the normal list of domains display.
+
+    *1* (number 1)
+        Toggle into showing physical CPUs. If pressed again toggles back to
+        showing domains (the normal display).
+
+    *2* Toggle into showing network interfaces. If pressed again toggles
+        back to showing domains.
+
+    *3* Toggle into showing block devices (virtual disks). If pressed again
+        toggles back to showing domains.
+
+    *P* Sort by %CPU.
+
+    *M* Sort by memory.
+
+    *T* Sort by total time.
+
+    *N* Sort by domain ID.
+
+    *F* Select the sort field interactively (there are other sort fields you
+        can choose using this key).
+
+SEE ALSO
+    top(1), virsh(1), xm(1), xentop(1), <http://www.libvirt.org/>,
+    <http://et.redhat.com/~rjones/>, <http://caml.inria.fr/>
+
+AUTHORS
+    Richard W.M. Jones <rjones @ redhat . com>
+
+REPORTING BUGS
+    Bugs can be viewed on the Red Hat Bugzilla page:
+    <https://bugzilla.redhat.com/>.
+
+    If you find a bug in virt-top, please follow these steps to report it:
+
+    1. Check for existing bug reports
+        Go to <https://bugzilla.redhat.com/> and search for similar bugs.
+        Someone may already have reported the same bug, and they may even
+        have fixed it.
+
+    2. Capture debug and error messages
+        Run
+
+         virt-top --debug virt-top.log
+
+        and keep *virt-top.log*. It contains error messages which you should
+        submit with your bug report.
+
+    3. Get version of virt-top and version of libvirt.
+        In virt-top, press the *h* (help) key, and write down the version of
+        virt-top and the version of libvirt. They are shown in the first
+        line.
+
+    4. Submit a bug report.
+        Go to <https://bugzilla.redhat.com/> and enter a new bug. Please
+        describe the problem in as much detail as possible.
+
+        Remember to include the version numbers (step 3) and the debug
+        messages file (step 2).
+
+    5. Assign the bug to rjones @ redhat.com
+        Assign or reassign the bug to rjones @ redhat.com (without the
+        spaces). You can also send me an email with the bug number if you
+        want a faster response.
+
diff --git a/virt-top/virt_top.ml b/virt-top/virt_top.ml
new file mode 100644 (file)
index 0000000..7a041b2
--- /dev/null
@@ -0,0 +1,1405 @@
+(* 'top'-like tool for libvirt domains.
+ * $Id: virt_top.ml,v 1.5 2007/08/30 13:52:40 rjones Exp $
+ *)
+
+open Printf
+open ExtList
+open Curses
+
+module C = Libvirt.Connect
+module D = Libvirt.Domain
+module N = Libvirt.Network
+
+(* Hook for XML support (see virt_top_xml.ml). *)
+let parse_device_xml : (int -> [>`R] D.t -> string list * string list) ref =
+  ref (
+    fun _ _ -> [], []
+  )
+
+(* 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"
+  )
+let csv_write : (string list -> unit) ref =
+  ref (
+    fun _ -> ()
+  )
+
+(* Int64 operators for convenience. *)
+let (+^) = Int64.add
+let (-^) = Int64.sub
+let ( *^ ) = Int64.mul
+let (/^) = Int64.div
+
+type sort_order =
+  | DomainID | DomainName | Processor | Memory | Time
+  | NetRX | NetTX | BlockRdRq | BlockWrRq
+let all_sort_fields = [
+  DomainID; DomainName; Processor; Memory; Time;
+  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"
+
+(* Current major display mode: TaskDisplay is the normal display. *)
+type display = TaskDisplay | PCPUDisplay | BlockDisplay | NetDisplay
+
+(* Settings. *)
+let quit = ref false
+let delay = ref 3000 (* milliseconds *)
+let historical_cpu_delay = ref 20 (* secs *)
+let iterations = ref (-1)
+let batch_mode = ref false
+let secure_mode = ref false
+let sort_order = ref Processor
+let display_mode = ref TaskDisplay
+let uri = ref None
+let debug_file = ref ""
+let csv_enabled = ref false
+
+(* Function to read command line arguments and go into curses mode. *)
+let start_up () =
+  (* Read command line arguments. *)
+  let rec set_delay newdelay =
+    if newdelay <= 0. then
+      failwith "-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 = function
+    | "cpu" | "processor" -> sort_order := Processor
+    | "mem" | "memory" -> sort_order := Memory
+    | "time" -> sort_order := Time
+    | "id" -> sort_order := DomainID
+    | "name" -> sort_order := DomainName
+    | "netrx" -> sort_order := NetRX | "nettx" -> sort_order := NetTX
+    | "blockrdrq" -> sort_order := BlockRdRq
+    | "blockwrrq" -> sort_order := BlockWrRq
+    | str -> failwith (str ^ ": sort order should be: cpu|mem|time|id|name|netrx|nettx|blockrdrq|blockwrrq")
+  and set_pcpu_mode () = display_mode := PCPUDisplay
+  and set_net_mode () = display_mode := NetDisplay
+  and set_block_mode () = display_mode := BlockDisplay
+  and set_csv filename =
+    (!csv_start) filename;
+    csv_enabled := true
+  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";
+    "-d", Arg.Float set_delay, "delay Delay time interval (seconds)";
+    "--debug", Arg.Set_string debug_file, "file Send debug messages to file";
+    "--hist-cpu", Arg.Set_int historical_cpu_delay, "secs Historical CPU delay";
+    "-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";
+  ] in
+  let anon_fun str = raise (Arg.Bad (str ^ ": unknown parameter")) in
+  let usage_msg = "virt-top : a 'top'-like utility for virtualization
+
+SUMMARY
+  virt-top [-options]
+
+OPTIONS" in
+  Arg.parse argspec anon_fun usage_msg;
+
+  (* Connect to the hypervisor before going into curses mode, since
+   * this is the most likely thing to fail.
+   *)
+  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 Unix.geteuid () <> 0 && name = None then (
+         print_endline "NB: If you want to monitor a local Xen hypervisor, you usually need to be root";
+       );
+       exit 1 in
+
+  (* Get the node_info.  This never changes, right?  So we get it just once. *)
+  let node_info = C.get_node_info conn in
+
+  (* Hostname and libvirt library version also don't change. *)
+  let hostname =
+    try C.get_hostname conn
+    with
+    | Invalid_argument "virConnectGetHostname not supported" -> "unknown" in
+
+  let libvirt_version =
+    let v, _ = Libvirt.get_version () in
+    v / 1_000_000, (v / 1_000) mod 1_000, v mod 1_000 in
+
+  (* Open debug file if specified.
+   * NB: Do this just before jumping into curses mode.
+   *)
+  (match !debug_file with
+   | "" -> (* No debug file specified, send stderr to /dev/null. *)
+       (try
+         let fd = Unix.openfile "/dev/null" [Unix.O_WRONLY] 0o644 in
+         Unix.dup2 fd Unix.stderr;
+         Unix.close fd
+       with
+         Unix.Unix_error _ -> ()
+       )
+   | filename -> (* Send stderr to the named file. *)
+       let fd =
+        Unix.openfile filename [Unix.O_WRONLY;Unix.O_CREAT;Unix.O_TRUNC]
+          0o644 in
+       Unix.dup2 fd Unix.stderr;
+       Unix.close fd
+  );
+
+  (* Curses voodoo (see ncurses(3)). *)
+  let stdscr =
+    initscr ();
+    cbreak ();
+    noecho ();
+    nonl ();
+    let stdscr = stdscr () in
+    intrflush stdscr false;
+    keypad stdscr true;
+    stdscr in
+
+  (* This tuple of static information is called 'state' in other parts
+   * of this program, and is passed to other functions such as redraw and
+   * main_loop.  See virt_top_main.ml.  It's not really "state" though.
+   *)
+  conn, stdscr, node_info, hostname, libvirt_version
+
+(* Show a percentage in 4 chars. *)
+let show_percent percent =
+  if percent <= 0. then " 0.0"
+  else if percent <= 9.9 then sprintf " %1.1f" percent
+  else if percent <= 99.9 then sprintf "%2.1f" percent
+  else "100 "
+
+(* Show an int64 option in 4 chars. *)
+let rec show_int64_option = function
+  | None -> "    "
+  | Some n -> show_int64 n
+(* Show an int64 in 4 chars. *)
+and show_int64 = function
+  | n when n < 0L -> "-!!!"
+  | n when n <= 9999L ->
+      sprintf "%4Ld" n
+  | n when n /^ 1024L <= 999L ->
+      sprintf "%3LdK" (n /^ 1024L)
+  | n when n /^ 1_048_576L <= 999L ->
+      sprintf "%3LdM" (n /^ 1_048_576L)
+  | n when n /^ 1_073_741_824L <= 999L ->
+      sprintf "%3LdG" (n /^ 1_073_741_824L)
+  | _ -> ">!!!"
+
+(* Format the total time (may be large!) in 9 chars. *)
+let show_time ns =
+  let secs_in_ns = 1_000_000_000L in
+  let mins_in_ns = 60_000_000_000L in
+  let hours_in_ns = 3_600_000_000_000L in
+
+  let hours = ns /^ hours_in_ns in
+  let ns = ns -^ (hours *^ hours_in_ns) in
+  let mins = ns /^ mins_in_ns in
+  let ns = ns -^ (mins *^ mins_in_ns) in
+  let secs = ns /^ secs_in_ns in
+  let ns = ns -^ (secs *^ secs_in_ns) in
+  let pennies = ns /^ 10_000_000L in
+
+  if hours < 12L then
+    sprintf "%3Ld:%02Ld.%02Ld" (hours *^ 60L +^ mins) secs pennies
+  else if hours <= 999L then
+    sprintf "%3Ld:%02Ld:%02Ld" hours mins secs
+  else (
+    let days = hours /^ 24L in
+    let hours = hours -^ (days *^ 24L) in
+    sprintf "%3Ldd%02Ld:%02Ld" days hours mins
+  )
+
+(* Show a domain state (the 'S' column). *)
+let show_state = function
+  | D.InfoNoState -> '?'
+  | D.InfoRunning -> 'R'
+  | D.InfoBlocked -> 'S'
+  | D.InfoPaused -> 'P'
+  | D.InfoShutdown -> 'D'
+  | D.InfoShutoff -> 'O'
+  | D.InfoCrashed -> 'X'
+
+(* Sum Domain.block_stats structures together.  Missing fields
+ * get forced to 0.  Empty list returns all 0.
+ *)
+let zero_block_stats =
+  { D.rd_req = 0L; rd_bytes = 0L; wr_req = 0L; wr_bytes = 0L; errs = 0L }
+let add_block_stats bs1 bs2 =
+  let add f1 f2 = if f1 >= 0L && f2 >= 0L then f1 +^ f2 else 0L in
+  { D.rd_req = add bs1.D.rd_req   bs2.D.rd_req;
+    rd_bytes = add bs1.D.rd_bytes bs2.D.rd_bytes;
+    wr_req   = add bs1.D.wr_req   bs2.D.wr_req;
+    wr_bytes = add bs1.D.wr_bytes bs2.D.wr_bytes;
+    errs     = add bs1.D.errs     bs2.D.errs }
+let sum_block_stats =
+  List.fold_left add_block_stats zero_block_stats
+
+(* Get the difference between two block_stats structures.  Missing data
+ * forces the difference to -1.
+ *)
+let diff_block_stats curr prev =
+  let sub f1 f2 = if f1 >= 0L && f2 >= 0L then f1 -^ f2 else -1L in
+  { D.rd_req = sub curr.D.rd_req   prev.D.rd_req;
+    rd_bytes = sub curr.D.rd_bytes prev.D.rd_bytes;
+    wr_req   = sub curr.D.wr_req   prev.D.wr_req;
+    wr_bytes = sub curr.D.wr_bytes prev.D.wr_bytes;
+    errs     = sub curr.D.errs     prev.D.errs }
+
+(* Sum Domain.interface_stats structures together.  Missing fields
+ * get forced to 0.  Empty list returns all 0.
+ *)
+let zero_interface_stats =
+  { D.rx_bytes = 0L; rx_packets = 0L; rx_errs = 0L; rx_drop = 0L;
+    tx_bytes = 0L; tx_packets = 0L; tx_errs = 0L; tx_drop = 0L }
+let add_interface_stats is1 is2 =
+  let add f1 f2 = if f1 >= 0L && f2 >= 0L then f1 +^ f2 else 0L in
+  { D.rx_bytes = add is1.D.rx_bytes   is2.D.rx_bytes;
+    rx_packets = add is1.D.rx_packets is2.D.rx_packets;
+    rx_errs    = add is1.D.rx_errs    is2.D.rx_errs;
+    rx_drop    = add is1.D.rx_drop    is2.D.rx_drop;
+    tx_bytes   = add is1.D.tx_bytes   is2.D.tx_bytes;
+    tx_packets = add is1.D.tx_packets is2.D.tx_packets;
+    tx_errs    = add is1.D.tx_errs    is2.D.tx_errs;
+    tx_drop    = add is1.D.tx_drop    is2.D.tx_drop }
+let sum_interface_stats =
+  List.fold_left add_interface_stats zero_interface_stats
+
+(* Get the difference between two interface_stats structures.
+ * Missing data forces the difference to -1.
+ *)
+let diff_interface_stats curr prev =
+  let sub f1 f2 = if f1 >= 0L && f2 >= 0L then f1 -^ f2 else -1L in
+  { D.rx_bytes = sub curr.D.rx_bytes   prev.D.rx_bytes;
+    rx_packets = sub curr.D.rx_packets prev.D.rx_packets;
+    rx_errs    = sub curr.D.rx_errs    prev.D.rx_errs;
+    rx_drop    = sub curr.D.rx_drop    prev.D.rx_drop;
+    tx_bytes   = sub curr.D.tx_bytes   prev.D.tx_bytes;
+    tx_packets = sub curr.D.tx_packets prev.D.tx_packets;
+    tx_errs    = sub curr.D.tx_errs    prev.D.tx_errs;
+    tx_drop    = sub curr.D.tx_drop    prev.D.tx_drop }
+
+(* Update the display and sleep for given number of seconds. *)
+let sleep n = refresh (); Unix.sleep n
+
+(* The curses getstr/getnstr functions are just weird.
+ * This helper function also enables echo temporarily.
+ *)
+let get_string maxlen =
+  echo ();
+  let str = String.create maxlen in
+  let ok = getstr str in (* Safe because binding calls getnstr. *)
+  noecho ();
+  if not ok then ""
+  else (
+    (* Chop at first '\0'. *)
+    try
+      let i = String.index str '\000' in
+      String.sub str 0 i
+    with
+      Not_found -> str (* it is full maxlen bytes *)
+  )
+
+(* Pad a string to the full width with spaces.  If too long, truncate. *)
+let pad width str =
+  let n = String.length str in
+  if n = width then str
+  else if n > width then String.sub str 0 width
+  else (* if n < width then *) str ^ String.make (width-n) ' '
+
+(* Line numbers. *)
+let top_lineno = 0
+let summary_lineno = 1 (* this takes 2 lines *)
+let message_lineno = 3
+let header_lineno = 4
+let domains_lineno = 5
+
+(* Print in the "message area". *)
+let clear_msg () = move message_lineno 0; clrtoeol ()
+let print_msg str = clear_msg (); mvaddstr message_lineno 0 str; ()
+
+(* Write CSV header row. *)
+let write_csv_header () =
+  (!csv_write) [ "Hostname"; "Time"; "Arch"; "Physical CPUs";
+                "Count"; "Running"; "Blocked"; "Paused"; "Shutdown";
+                "Shutoff"; "Crashed"; "Active"; "Inactive";
+                "%CPU"; "Total memory KB"; "Total guest memory KB";
+                "Total CPU time ns" ]
+
+(* Intermediate "domain + stats" structure that we use to collect
+ * everything we know about a domain within the redraw function.
+ *)
+type rd_domain = Inactive | Active of rd_active
+and rd_active = {
+  rd_domid : int;                      (* Domain ID. *)
+  rd_dom : [`R] D.t;                   (* Domain object. *)
+  rd_info : D.info;                    (* Domain CPU info now. *)
+  rd_block_stats : (string * D.block_stats) list;
+                                        (* Domain block stats now. *)
+  rd_interface_stats : (string * D.interface_stats) list;
+                                        (* Domain net stats now. *)
+  rd_prev_info : D.info option;                (* Domain CPU info previously. *)
+  rd_prev_block_stats : (string * D.block_stats) list;
+                                        (* Domain block stats prev. *)
+  rd_prev_interface_stats : (string * D.interface_stats) list;
+                                        (* Domain interface stats prev. *)
+  (* The following are since the last slice, or 0 if cannot be calculated: *)
+  rd_cpu_time : float;                 (* CPU time used in nanoseconds. *)
+  rd_percent_cpu : float;              (* CPU time as percent of total. *)
+  (* The following are since the last slice, or None if cannot be calc'd: *)
+  rd_block_rd_reqs : int64 option;      (* Number of block device read rqs. *)
+  rd_block_wr_reqs : int64 option;      (* Number of block device write rqs. *)
+  rd_net_rx_bytes : int64 option;      (* Number of bytes received. *)
+  rd_net_tx_bytes : int64 option;      (* Number of bytes transmitted. *)
+}
+
+(* Redraw the display. *)
+let redraw, clear_pcpu_display_data =
+  (* We cache the list of block devices and interfaces for each domain
+   * here, so we don't need to reparse the XML each time.
+   *)
+  let devices = Hashtbl.create 13 in
+
+  (* Function to get the list of block devices, network interfaces for
+   * a particular domain.  Get it from the devices cache, and if not
+   * there then parse the domain XML.
+   *)
+  let get_devices id dom =
+    try Hashtbl.find devices id
+    with Not_found ->
+      let blkdevs, netifs = (!parse_device_xml) id dom in
+      Hashtbl.replace devices id (blkdevs, netifs);
+      blkdevs, netifs
+  in
+
+  (* We save the state of domains across redraws here, which allows us
+   * to deduce %CPU usage from the running total.
+   *)
+  let last_info = Hashtbl.create 13 in
+  let last_time = ref (Unix.gettimeofday ()) in
+
+  (* Save vcpuinfo structures across redraws too (only for pCPU display). *)
+  let last_vcpu_info = Hashtbl.create 13 in
+
+  (* Keep a historical list of %CPU usages. *)
+  let historical_cpu = ref [] in
+  let historical_cpu_last_time = ref (Unix.gettimeofday ()) in
+
+  let redraw (conn, stdscr, node_info, hostname, _) =
+    clear ();
+
+    (* Get the screen/window size. *)
+    let lines, cols = get_size () in
+
+    (* Number of physical CPUs (some may be disabled). *)
+    let nr_pcpus = C.maxcpus_of_node_info node_info in
+
+    (* Get the current time. *)
+    let time = Unix.gettimeofday () in
+    let tm = Unix.localtime time in
+    let printable_time =
+      sprintf "%02d:%02d:%02d" tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec in
+    mvaddstr top_lineno 0 ("virt-top " ^ printable_time ^ " - ");
+
+    (* What's the total CPU time elapsed since we were last called? (ns) *)
+    let total_cpu_per_pcpu = 1_000_000_000. *. (time -. !last_time) in
+    (* Avoid division by zero. *)
+    let total_cpu_per_pcpu =
+      if total_cpu_per_pcpu <= 0. then 1. else total_cpu_per_pcpu in
+    let total_cpu = float node_info.C.cpus *. total_cpu_per_pcpu in
+
+    (* Basic node_info. *)
+    addstr (sprintf "%s %d/%dCPU %dMHz %LdMB "
+             node_info.C.model node_info.C.cpus nr_pcpus node_info.C.mhz
+             (node_info.C.memory /^ 1024L));
+    (* Save the cursor position for when we come to draw the
+     * historical CPU times (down in this function).
+     *)
+    let historical_cursor = getyx stdscr in
+
+    (* Get the domains.  Match up with their last_info (if any). *)
+    let doms =
+      (* Active domains. *)
+      let n = C.num_of_domains conn in
+      let ids = Array.to_list (C.list_domains conn n) in
+      let doms =
+       List.filter_map (
+         fun id ->
+           try
+             let dom = D.lookup_by_id conn id in
+             let name = D.get_name dom in
+             let blkdevs, netifs = get_devices id dom in
+
+             (* Get current CPU, block and network stats. *)
+             let info = D.get_info dom in
+             let block_stats =
+               try List.map (fun dev -> dev, D.block_stats dom dev) blkdevs
+               with
+               | Invalid_argument "virDomainBlockStats not supported"
+               | Libvirt.Virterror _ -> [] in
+             let interface_stats =
+               try List.map (fun dev -> dev, D.interface_stats dom dev) netifs
+               with
+               | Invalid_argument "virDomainInterfaceStats not supported"
+               | Libvirt.Virterror _ -> [] in
+
+             let prev_info, prev_block_stats, prev_interface_stats =
+               try
+                 let prev_info, prev_block_stats, prev_interface_stats =
+                   Hashtbl.find last_info id in
+                 Some prev_info, prev_block_stats, prev_interface_stats
+               with Not_found -> None, [], [] in
+
+             Some (name, Active {
+                     rd_domid = id; rd_dom = dom; rd_info = info;
+                     rd_block_stats = block_stats;
+                     rd_interface_stats = interface_stats;
+                     rd_prev_info = prev_info;
+                     rd_prev_block_stats = prev_block_stats;
+                     rd_prev_interface_stats = prev_interface_stats;
+                     rd_cpu_time = 0.; rd_percent_cpu = 0.;
+                     rd_block_rd_reqs = None; rd_block_wr_reqs = None;
+                     rd_net_rx_bytes = None; rd_net_tx_bytes = None;
+                   })
+           with
+             Libvirt.Virterror _ -> None (* ignore transient error *)
+       ) ids in
+
+      (* Inactive domains. *)
+      let n = C.num_of_defined_domains conn in
+      let names = Array.to_list (C.list_defined_domains conn n) in
+      let doms_inactive = List.map (fun name -> name, Inactive) names in
+
+      doms @ doms_inactive in
+
+    (* Calculate the CPU time (ns) and %CPU used by each domain. *)
+    let doms =
+      List.map (
+       function
+       (* We have previous CPU info from which to calculate it? *)
+       | name, Active ({ rd_prev_info = Some prev_info } as rd) ->
+           let cpu_time =
+             Int64.to_float (rd.rd_info.D.cpu_time -^ prev_info.D.cpu_time) in
+           let percent_cpu = 100. *. cpu_time /. total_cpu in
+           let rd = { rd with
+                        rd_cpu_time = cpu_time;
+                        rd_percent_cpu = percent_cpu } in
+           name, Active rd
+       (* For all other domains we can't calculate it, so leave as 0 *)
+       | rd -> rd
+      ) doms in
+
+    (* Calculate the number of block device read/write requests across
+     * all block devices attached to a domain.
+     *)
+    let doms =
+      List.map (
+       function
+       (* Do we have stats from the previous slice? *)
+       | name, Active ({ rd_prev_block_stats = ((_::_) as prev_block_stats) }
+                         as rd) ->
+           let block_stats = rd.rd_block_stats in (* stats now *)
+
+           (* Add all the devices together.  Throw away device names. *)
+           let prev_block_stats =
+             sum_block_stats (List.map snd prev_block_stats) in
+           let block_stats =
+             sum_block_stats (List.map snd block_stats) in
+
+           (* Calculate increase in read & write requests. *)
+           let read_reqs =
+             block_stats.D.rd_req -^ prev_block_stats.D.rd_req in
+           let write_reqs =
+             block_stats.D.wr_req -^ prev_block_stats.D.wr_req in
+
+           let rd = { rd with
+                        rd_block_rd_reqs = Some read_reqs;
+                        rd_block_wr_reqs = Some write_reqs } in
+           name, Active rd
+       (* For all other domains we can't calculate it, so leave as None. *)
+       | rd -> rd
+      ) doms in
+
+    (* Calculate the same as above for network interfaces across
+     * all network interfaces attached to a domain.
+     *)
+    let doms =
+      List.map (
+       function
+       (* Do we have stats from the previous slice? *)
+       | name, Active ({ rd_prev_interface_stats =
+                             ((_::_) as prev_interface_stats) }
+                         as rd) ->
+           let interface_stats = rd.rd_interface_stats in (* stats now *)
+
+           (* Add all the devices together.  Throw away device names. *)
+           let prev_interface_stats =
+             sum_interface_stats (List.map snd prev_interface_stats) in
+           let interface_stats =
+             sum_interface_stats (List.map snd interface_stats) in
+
+           (* Calculate increase in rx & tx bytes. *)
+           let rx_bytes =
+             interface_stats.D.rx_bytes -^ prev_interface_stats.D.rx_bytes in
+           let tx_bytes =
+             interface_stats.D.tx_bytes -^ prev_interface_stats.D.tx_bytes in
+
+           let rd = { rd with
+                        rd_net_rx_bytes = Some rx_bytes;
+                        rd_net_tx_bytes = Some tx_bytes } in
+           name, Active rd
+       (* For all other domains we can't calculate it, so leave as None. *)
+       | rd -> rd
+      ) doms in
+
+    (match !display_mode with
+     | TaskDisplay -> (*---------- Showing domains ----------*)
+        (* Sort domains on current sort_order. *)
+        let doms =
+          let cmp =
+            match !sort_order with
+            | DomainName ->
+                (fun _ -> 0) (* fallthrough to default name compare *)
+            | Processor ->
+                (function
+                 | Active rd1, Active rd2 ->
+                     compare rd2.rd_percent_cpu rd1.rd_percent_cpu
+                 | Active _, Inactive -> -1
+                 | Inactive, Active _ -> 1
+                 | Inactive, Inactive -> 0)
+            | Memory ->
+                (function
+                 | Active { rd_info = info1 }, Active { rd_info = info2 } ->
+                     compare info2.D.memory info1.D.memory
+                 | Active _, Inactive -> -1
+                 | Inactive, Active _ -> 1
+                 | Inactive, Inactive -> 0)
+            | Time ->
+                (function
+                 | Active { rd_info = info1 }, Active { rd_info = info2 } ->
+                     compare info2.D.cpu_time info1.D.cpu_time
+                 | Active _, Inactive -> -1
+                 | Inactive, Active _ -> 1
+                 | Inactive, Inactive -> 0)
+            | DomainID ->
+                (function
+                 | Active { rd_domid = id1 }, Active { rd_domid = id2 } ->
+                     compare id1 id2
+                 | Active _, Inactive -> -1
+                 | Inactive, Active _ -> 1
+                 | Inactive, Inactive -> 0)
+            | NetRX ->
+                (function
+                 | Active { rd_net_rx_bytes = r1 }, Active { rd_net_rx_bytes = r2 } ->
+                     compare r2 r1
+                 | Active _, Inactive -> -1
+                 | Inactive, Active _ -> 1
+                 | Inactive, Inactive -> 0)
+            | NetTX ->
+                (function
+                 | Active { rd_net_tx_bytes = r1 }, Active { rd_net_tx_bytes = r2 } ->
+                     compare r2 r1
+                 | Active _, Inactive -> -1
+                 | Inactive, Active _ -> 1
+                 | Inactive, Inactive -> 0)
+            | BlockRdRq ->
+                (function
+                 | Active { rd_block_rd_reqs = r1 }, Active { rd_block_rd_reqs = r2 } ->
+                     compare r2 r1
+                 | Active _, Inactive -> -1
+                 | Inactive, Active _ -> 1
+                 | Inactive, Inactive -> 0)
+            | BlockWrRq ->
+                (function
+                 | Active { rd_block_wr_reqs = r1 }, Active { rd_block_wr_reqs = r2 } ->
+                     compare r2 r1
+                 | Active _, Inactive -> -1
+                 | Inactive, Active _ -> 1
+                 | Inactive, Inactive -> 0)
+          in
+          let cmp (name1, dom1) (name2, dom2) =
+            let r = cmp (dom1, dom2) in
+            if r <> 0 then r
+            else compare name1 name2
+          in
+          List.sort ~cmp doms in
+
+        (* Print domains. *)
+        attron A.reverse;
+        mvaddstr header_lineno 0
+          (pad cols "   ID S RDRQ WRRQ RXBY TXBY %CPU %MEM    TIME   NAME");
+        attroff A.reverse;
+
+        let rec loop lineno = function
+          | [] -> ()
+          | (name, Active rd) :: doms ->
+              if lineno < lines then (
+                let state = show_state rd.rd_info.D.state in
+                let rd_req = show_int64_option rd.rd_block_rd_reqs in
+                let wr_req = show_int64_option rd.rd_block_wr_reqs in
+                let rx_bytes = show_int64_option rd.rd_net_rx_bytes in
+                let tx_bytes = show_int64_option rd.rd_net_tx_bytes in
+                let percent_cpu = show_percent rd.rd_percent_cpu in
+                let percent_mem =
+                  100L *^ rd.rd_info.D.memory /^ node_info.C.memory in
+                let percent_mem = Int64.to_float percent_mem in
+                let percent_mem = show_percent percent_mem in
+                let time = show_time rd.rd_info.D.cpu_time in
+
+                let line = sprintf "%5d %c %s %s %s %s %s %s %s %s"
+                  rd.rd_domid state rd_req wr_req rx_bytes tx_bytes
+                  percent_cpu percent_mem time name in
+                let line = pad cols line in
+                mvaddstr lineno 0 line;
+                loop (lineno+1) doms
+              )
+          | (name, Inactive) :: doms -> (* inactive domain *)
+              if lineno < lines then (
+                let line =
+                  sprintf
+                    "    -                                           (%s)"
+                    name in
+                let line = pad cols line in
+                mvaddstr lineno 0 line;
+                loop (lineno+1) doms
+              )
+        in
+        loop domains_lineno doms
+
+     | PCPUDisplay -> (*---------- Showing physical CPUs ----------*)
+        (* Get the VCPU info and VCPU->PCPU mappings for active domains.
+         * Also cull some data we don't care about.
+         *)
+        let doms = List.filter_map (
+          function
+          | (name, Active rd) ->
+              (try
+                 let domid = rd.rd_domid in
+                 let maplen = C.cpumaplen nr_pcpus in
+                 let maxinfo = rd.rd_info.D.nr_virt_cpu in
+                 let nr_vcpus, vcpu_infos, cpumaps =
+                   D.get_vcpus rd.rd_dom maxinfo maplen in
+
+                 (* Got previous vcpu_infos for this domain? *)
+                 let prev_vcpu_infos =
+                   try Some (Hashtbl.find last_vcpu_info domid)
+                   with Not_found -> None in
+                 (* Update last_vcpu_info. *)
+                 Hashtbl.replace last_vcpu_info domid vcpu_infos;
+
+                 (match prev_vcpu_infos with
+                  | Some prev_vcpu_infos
+                      when Array.length prev_vcpu_infos = Array.length vcpu_infos ->
+                      Some (domid, name, nr_vcpus, vcpu_infos, prev_vcpu_infos,
+                            cpumaps, maplen)
+                  | _ -> None (* ignore missing / unequal length prev_vcpu_infos *)
+                 );
+               with
+                 Libvirt.Virterror _ -> None(* ignore transient libvirt errs *)
+              )
+          | (_, Inactive) -> None (* ignore inactive doms *)
+        ) doms in
+        let nr_doms = List.length doms in
+
+        (* Rearrange the data into a matrix.  Major axis (down) is
+         * pCPUs.  Minor axis (right) is domains.  At each node we store:
+         *  cpu_time (on this pCPU only, nanosecs),
+         *  average? (if set, then cpu_time is an average because the
+         *     vCPU is pinned to more than one pCPU)
+         *  running? (if set, we were instantaneously running on this pCPU)
+         *)
+        let empty_node = (0L, false, false) in
+        let pcpus = Array.make_matrix nr_pcpus nr_doms empty_node in
+
+        List.iteri (
+          fun di (domid, name, nr_vcpus, vcpu_infos, prev_vcpu_infos,
+                  cpumaps, maplen) ->
+            (* Which pCPUs can this dom run on? *)
+            for v = 0 to nr_vcpus-1 do
+              let pcpu = vcpu_infos.(v).D.cpu in (* instantaneous pCPU *)
+              let nr_poss_pcpus = ref 0 in (* how many pcpus can it run on? *)
+              for p = 0 to nr_pcpus-1 do
+                (* vcpu v can reside on pcpu p *)
+                if C.cpu_usable cpumaps maplen v p then
+                  incr nr_poss_pcpus
+              done;
+              let nr_poss_pcpus = Int64.of_int !nr_poss_pcpus in
+              for p = 0 to nr_pcpus-1 do
+                (* vcpu v can reside on pcpu p *)
+                if C.cpu_usable cpumaps maplen v p then
+                  let vcpu_time_on_pcpu =
+                    vcpu_infos.(v).D.vcpu_time
+                    -^ prev_vcpu_infos.(v).D.vcpu_time in
+                  let vcpu_time_on_pcpu =
+                    vcpu_time_on_pcpu /^ nr_poss_pcpus in
+                  pcpus.(p).(di) <-
+                    (vcpu_time_on_pcpu, nr_poss_pcpus > 1L, p = pcpu)
+              done
+            done
+        ) doms;
+
+        (* Sum the CPU time used by each pCPU, for the %CPU column. *)
+        let pcpus_cpu_time = Array.map (
+          fun row ->
+            let cpu_time = ref 0L in
+            for di = 0 to Array.length row-1 do
+              let t, _, _ = row.(di) in
+              cpu_time := !cpu_time +^ t
+            done;
+            Int64.to_float !cpu_time
+        ) pcpus in
+
+        (* Display the pCPUs. *)
+        let dom_names =
+          String.concat "" (
+            List.map (
+              fun (_, name, _, _, _, _, _) ->
+                let len = String.length name in
+                let width = max (len+1) 7 in
+                pad width name
+            ) doms
+          ) in
+        attron A.reverse;
+        mvaddstr header_lineno 0 (pad cols ("PHYCPU %CPU " ^ dom_names));
+        attroff A.reverse;
+
+        Array.iteri (
+          fun p row ->
+            mvaddstr (p+domains_lineno) 0 (sprintf "%4d   " p);
+            let cpu_time = pcpus_cpu_time.(p) in (* ns used on this CPU *)
+            let percent_cpu = 100. *. cpu_time /. total_cpu_per_pcpu in
+            addstr (show_percent percent_cpu);
+            addch 32;
+
+            List.iteri (
+              fun di (domid, name, _, _, _, _, _) ->
+                let t, is_average, is_running = pcpus.(p).(di) in
+                let len = String.length name in
+                let width = max (len+1) 7 in
+                let str =
+                  if t <= 0L then ""
+                  else (
+                    let t = Int64.to_float t in
+                    let percent = 100. *. t /. total_cpu_per_pcpu in
+                    sprintf "%s%c%c " (show_percent percent)
+                      (if is_average then '=' else ' ')
+                      (if is_running then '#' else ' ')
+                  ) in
+                addstr (pad width str);
+                ()
+            ) doms
+        ) pcpus;
+
+     | NetDisplay -> (*---------- Showing network interfaces ----------*)
+        (* Only care about active domains. *)
+        let doms = List.filter_map (
+          function
+          | (name, Active rd) -> Some (name, rd)
+          | (_, Inactive) -> None
+        ) doms in
+
+        (* For each domain we have a list of network interfaces seen
+         * this slice, and seen in the previous slice, which we now
+         * match up to get a list of (domain, interface) for which
+         * we have current & previous knowledge.  (And ignore the rest).
+         *)
+        let devs =
+          List.map (
+            fun (name, rd) ->
+              List.filter_map (
+                fun (dev, stats) ->
+                  try
+                    (* Have prev slice stats for this device? *)
+                    let prev_stats =
+                      List.assoc dev rd.rd_prev_interface_stats in
+                    Some (dev, name, rd, stats, prev_stats)
+                  with Not_found -> None
+              ) rd.rd_interface_stats
+          ) doms in
+
+        (* Finally we have a list of:
+         * device name, domain name, rd_* stuff, curr stats, prev stats.
+         *)
+        let devs : (string * string * rd_active *
+                      D.interface_stats * D.interface_stats) list =
+          List.flatten devs in
+
+        (* Difference curr slice & prev slice. *)
+        let devs = List.map (
+          fun (dev, name, rd, curr, prev) ->
+            dev, name, rd, diff_interface_stats curr prev
+        ) devs in
+
+        (* Sort by current sort order, but map some of the standard
+         * sort orders into ones which makes sense here.
+         *)
+        let devs =
+          let cmp =
+            match !sort_order with
+            | DomainName ->
+                (fun _ -> 0) (* fallthrough to default name compare *)
+            | DomainID ->
+                (fun (_, { rd_domid = id1 }, _, { rd_domid = id2 }) ->
+                   compare id1 id2)
+            | Processor | Memory | Time | BlockRdRq | BlockWrRq
+                (* fallthrough to RXBY comparison. *)
+            | NetRX ->
+                (fun ({ D.rx_bytes = b1 }, _, { D.rx_bytes = b2 }, _) ->
+                   compare b2 b1)
+            | NetTX ->
+                (fun ({ D.tx_bytes = b1 }, _, { D.tx_bytes = b2 }, _) ->
+                   compare b2 b1)
+          in
+          let cmp (dev1, name1, rd1, stats1) (dev2, name2, rd2, stats2) =
+            let r = cmp (stats1, rd1, stats2, rd2) in
+            if r <> 0 then r
+            else compare (dev1, name1) (dev2, name2)
+          in
+          List.sort ~cmp devs in
+
+        (* Print the header for network devices. *)
+        attron A.reverse;
+        mvaddstr header_lineno 0
+          (pad cols "   ID S RXBY TXBY RXPK TXPK DOMAIN       INTERFACE");
+        attroff A.reverse;
+
+         (* Print domains and devices. *)
+        let rec loop lineno = function
+          | [] -> ()
+          | (dev, name, rd, stats) :: devs ->
+              if lineno < lines then (
+                let state = show_state rd.rd_info.D.state in
+                let rx_bytes =
+                  if stats.D.rx_bytes >= 0L
+                  then show_int64 stats.D.rx_bytes
+                  else "    " in
+                let tx_bytes =
+                  if stats.D.tx_bytes >= 0L
+                  then show_int64 stats.D.tx_bytes
+                  else "    " in
+                let rx_packets =
+                  if stats.D.rx_packets >= 0L
+                  then show_int64 stats.D.rx_packets
+                  else "    " in
+                let tx_packets =
+                  if stats.D.tx_packets >= 0L
+                  then show_int64 stats.D.tx_packets
+                  else "    " in
+
+                let line = sprintf "%5d %c %s %s %s %s %-12s %s"
+                  rd.rd_domid state
+                  rx_bytes tx_bytes
+                  rx_packets tx_packets
+                  (pad 12 name) dev in
+                let line = pad cols line in
+                mvaddstr lineno 0 line;
+                loop (lineno+1) devs
+              )
+        in
+        loop domains_lineno devs
+
+     | BlockDisplay -> (*---------- Showing block devices ----------*)
+        (* Only care about active domains. *)
+        let doms = List.filter_map (
+          function
+          | (name, Active rd) -> Some (name, rd)
+          | (_, Inactive) -> None
+        ) doms in
+
+        (* For each domain we have a list of block devices seen
+         * this slice, and seen in the previous slice, which we now
+         * match up to get a list of (domain, device) for which
+         * we have current & previous knowledge.  (And ignore the rest).
+         *)
+        let devs =
+          List.map (
+            fun (name, rd) ->
+              List.filter_map (
+                fun (dev, stats) ->
+                  try
+                    (* Have prev slice stats for this device? *)
+                    let prev_stats =
+                      List.assoc dev rd.rd_prev_block_stats in
+                    Some (dev, name, rd, stats, prev_stats)
+                  with Not_found -> None
+              ) rd.rd_block_stats
+          ) doms in
+
+        (* Finally we have a list of:
+         * device name, domain name, rd_* stuff, curr stats, prev stats.
+         *)
+        let devs : (string * string * rd_active *
+                      D.block_stats * D.block_stats) list =
+          List.flatten devs in
+
+        (* Difference curr slice & prev slice. *)
+        let devs = List.map (
+          fun (dev, name, rd, curr, prev) ->
+            dev, name, rd, diff_block_stats curr prev
+        ) devs in
+
+        (* Sort by current sort order, but map some of the standard
+         * sort orders into ones which makes sense here.
+         *)
+        let devs =
+          let cmp =
+            match !sort_order with
+            | DomainName ->
+                (fun _ -> 0) (* fallthrough to default name compare *)
+            | DomainID ->
+                (fun (_, { rd_domid = id1 }, _, { rd_domid = id2 }) ->
+                   compare id1 id2)
+            | Processor | Memory | Time | NetRX | NetTX
+                (* fallthrough to RDRQ comparison. *)
+            | BlockRdRq ->
+                (fun ({ D.rd_req = b1 }, _, { D.rd_req = b2 }, _) ->
+                   compare b2 b1)
+            | BlockWrRq ->
+                (fun ({ D.wr_req = b1 }, _, { D.wr_req = b2 }, _) ->
+                   compare b2 b1)
+          in
+          let cmp (dev1, name1, rd1, stats1) (dev2, name2, rd2, stats2) =
+            let r = cmp (stats1, rd1, stats2, rd2) in
+            if r <> 0 then r
+            else compare (dev1, name1) (dev2, name2)
+          in
+          List.sort ~cmp devs in
+
+        (* Print the header for block devices. *)
+        attron A.reverse;
+        mvaddstr header_lineno 0
+          (pad cols "   ID S RDBY WRBY RDRQ WRRQ DOMAIN       DEVICE");
+        attroff A.reverse;
+
+         (* Print domains and devices. *)
+        let rec loop lineno = function
+          | [] -> ()
+          | (dev, name, rd, stats) :: devs ->
+              if lineno < lines then (
+                let state = show_state rd.rd_info.D.state in
+                let rd_bytes =
+                  if stats.D.rd_bytes >= 0L
+                  then show_int64 stats.D.rd_bytes
+                  else "    " in
+                let wr_bytes =
+                  if stats.D.wr_bytes >= 0L
+                  then show_int64 stats.D.wr_bytes
+                  else "    " in
+                let rd_req =
+                  if stats.D.rd_req >= 0L
+                  then show_int64 stats.D.rd_req
+                  else "    " in
+                let wr_req =
+                  if stats.D.wr_req >= 0L
+                  then show_int64 stats.D.wr_req
+                  else "    " in
+
+                let line = sprintf "%5d %c %s %s %s %s %-12s %s"
+                  rd.rd_domid state
+                  rd_bytes wr_bytes
+                  rd_req wr_req
+                  (pad 12 name) dev in
+                let line = pad cols line in
+                mvaddstr lineno 0 line;
+                loop (lineno+1) devs
+              )
+        in
+        loop domains_lineno devs
+    );
+
+    (* Calculate and print totals. *)
+    let () =
+      let totals = List.fold_left (
+       fun (count, running, blocked, paused, shutdown, shutoff,
+            crashed, active, inactive,
+            total_cpu_time, total_memory, total_domU_memory) ->
+         function
+         | (name, Active rd) ->
+             let test state orig =
+               if rd.rd_info.D.state = state then orig+1 else orig
+             in
+             let running = test D.InfoRunning running in
+             let blocked = test D.InfoBlocked blocked in
+             let paused = test D.InfoPaused paused in
+             let shutdown = test D.InfoShutdown shutdown in
+             let shutoff = test D.InfoShutoff shutoff in
+             let crashed = test D.InfoCrashed crashed in
+
+             let total_cpu_time = total_cpu_time +. rd.rd_cpu_time in
+             let total_memory = total_memory +^ rd.rd_info.D.memory in
+             let total_domU_memory = total_domU_memory +^
+               if rd.rd_domid > 0 then rd.rd_info.D.memory else 0L in
+
+             (count+1, running, blocked, paused, shutdown, shutoff,
+              crashed, active+1, inactive,
+              total_cpu_time, total_memory, total_domU_memory)
+
+         | (name, Inactive) -> (* inactive domain *)
+             (count+1, running, blocked, paused, shutdown, shutoff,
+              crashed, active, inactive+1,
+              total_cpu_time, total_memory, total_domU_memory)
+      ) (0,0,0,0,0,0,0,0,0, 0.,0L,0L) doms in
+
+      let (count, running, blocked, paused, shutdown, shutoff,
+          crashed, active, inactive,
+          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"
+          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)"
+          percent_cpu (total_memory /^ 1024L) (total_domU_memory /^ 1024L));
+
+      (* Time to grab another historical %CPU for the list? *)
+      if time >= !historical_cpu_last_time +. float !historical_cpu_delay
+      then (
+       historical_cpu := percent_cpu :: List.take 10 !historical_cpu;
+       historical_cpu_last_time := time
+      );
+
+      (* Display historical CPU time. *)
+      let () =
+       let x, y = historical_cursor in (* Yes, it's a bug in ocaml-curses *)
+       let maxwidth = cols - x in
+       let line =
+         String.concat " "
+           (List.map (sprintf "%2.1f%%") !historical_cpu) in
+       let line = pad maxwidth line in
+       mvaddstr y x line;
+       () in
+
+      (* Write summary data to CSV file.  See also write_csv_header (). *)
+      if !csv_enabled then (
+       (!csv_write) [
+         hostname; printable_time; node_info.C.model; string_of_int nr_pcpus;
+         string_of_int count; string_of_int running; string_of_int blocked;
+         string_of_int paused; string_of_int shutdown; string_of_int shutoff;
+         string_of_int crashed; string_of_int active; string_of_int inactive;
+         sprintf "%2.1f" percent_cpu;
+         Int64.to_string total_memory; Int64.to_string total_domU_memory;
+         Int64.to_string (Int64.of_float total_cpu_time)
+       ]
+      );
+
+      ()
+    in
+
+    (* Update last_info, last_time. *)
+    last_time := time;
+    Hashtbl.clear last_info;
+    List.iter (
+      function
+      | (_, Active rd) ->
+         let info = rd.rd_info, rd.rd_block_stats, rd.rd_interface_stats in
+         Hashtbl.add last_info rd.rd_domid info
+      | _ -> ()
+    ) doms;
+
+    move message_lineno 0 (* Park cursor in message area, as with top. *)
+  in
+
+  let clear_pcpu_display_data () =
+    (* Clear out vcpu_info used by PCPUDisplay
+     * display_mode when we switch back to TaskDisplay mode.
+     *)
+    Hashtbl.clear last_vcpu_info
+  in
+
+  redraw, clear_pcpu_display_data
+
+(* Main loop. *)
+let rec main_loop state =
+  if !csv_enabled then write_csv_header ();
+
+  while not !quit do
+    redraw state;
+    refresh ();
+
+    (* Clear up unused virDomainPtr objects. *)
+    Gc.compact ();
+
+    if not !batch_mode then
+      get_key_press state
+    else (* Batch mode - just sleep, ignore keys. *)
+      Unix.sleep (!delay / 1000);
+
+    (* Max iterations? *)
+    if !iterations >= 0 then (
+      decr iterations;
+      if !iterations = 0 then quit := true
+    );
+  done
+
+and get_key_press state =
+  (* Read the next key, waiting up to !delay milliseconds. *)
+  timeout !delay;
+  let k = getch () in
+  timeout (-1); (* Reset to blocking mode. *)
+
+  if k >= 0 && k <> 32 (* ' ' *) && k <> 12 (* ^L *) && k <> Key.resize
+  then (
+    if k = Char.code 'q' then quit := true
+    else if k = Char.code 'h' then show_help state
+    else if k = Char.code 's' || k = Char.code 'd' then change_delay ()
+    else if k = Char.code 'M' then sort_order := Memory
+    else if k = Char.code 'P' then sort_order := Processor
+    else if k = Char.code 'T' then sort_order := Time
+    else if k = Char.code 'N' then sort_order := DomainID
+    else if k = Char.code 'F' then change_sort_order ()
+    else if k = Char.code '0' then set_tasks_display ()
+    else if k = Char.code '1' then toggle_pcpu_display ()
+    else if k = Char.code '2' then toggle_net_display ()
+    else if k = Char.code '3' then toggle_block_display ()
+    else unknown_command k
+  )
+
+and change_delay () =
+  print_msg (sprintf "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
+      ) else (
+       delay := int_of_float (newdelay *. 1000.); false
+      )
+    with
+      Failure "float_of_string" ->
+       print_msg "Not a valid number"; true in
+  sleep (if error then 2 else 1)
+
+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.";
+
+  attron A.reverse;
+  mvaddstr header_lineno 0 (pad cols "KEY   Sort field");
+  attroff A.reverse;
+
+  let accelerator_key = function
+    | Memory -> "(key: M)"
+    | Processor -> "(key: P)"
+    | Time -> "(key: T)"
+    | DomainID -> "(key: N)"
+    | _ -> (* all others have to be changed from here *) ""
+  in
+
+  let rec key_of_int = function
+    | i when i < 10 -> Char.chr (i + Char.code '0')
+    | i when i < 20 -> Char.chr (i + Char.code 'a')
+    | _ -> assert false
+  and int_of_key = function
+    | k when k >= 0x30 && k <= 0x39 (* '0' - '9' *) -> k - 0x30
+    | k when k >= 0x61 && k <= 0x7a (* 'a' - 'j' *) -> k - 0x61 + 10
+    | k when k >= 0x41 && k <= 0x6a (* 'A' - 'J' *) -> k - 0x41 + 10
+    | _ -> -1
+  in
+
+  (* Display possible sort fields. *)
+  let selected_index = ref 0 in
+  List.iteri (
+    fun i ord ->
+      let selected = !sort_order = ord in
+      if selected then selected_index := i;
+      mvaddstr (domains_lineno+i) 0
+       (sprintf "  %c %s %s %s"
+          (key_of_int i) (if selected then "*" else " ")
+          (printable_sort_order ord)
+          (accelerator_key ord))
+  ) all_sort_fields;
+
+  move message_lineno 0;
+  refresh ();
+  let k = getch () in
+  if k >= 0 && k <> 32 && k <> Char.code 'q' && k <> 13 then (
+    let new_order, loop =
+      (* Redraw the display. *)
+      if k = 12 (* ^L *) then None, true
+      (* Make the UP and DOWN arrow keys do something useful. *)
+      else if k = Key.up then (
+       if !selected_index > 0 then
+         Some (List.nth all_sort_fields (!selected_index-1)), true
+       else
+         None, true
+      )
+      else if k = Key.down then (
+       if !selected_index < List.length all_sort_fields - 1 then
+         Some (List.nth all_sort_fields (!selected_index+1)), true
+       else
+         None, true
+      )
+      (* Also understand the regular accelerator keys. *)
+      else if k = Char.code 'M' then
+       Some Memory, false
+      else if k = Char.code 'P' then
+       Some Processor, false
+      else if k = Char.code 'T' then
+       Some Time, false
+      else if k = Char.code 'N' then
+       Some DomainID, false
+      else (
+       (* It's one of the KEYs. *)
+       let i = int_of_key k in
+       if i >= 0 && i < List.length all_sort_fields then
+         Some (List.nth all_sort_fields i), false
+       else
+         None, true
+      ) in
+
+    (match new_order with
+     | None -> ()
+     | Some new_order ->
+        sort_order := new_order;
+        print_msg (sprintf "Sort order changed to: %s"
+                     (printable_sort_order new_order));
+        if not loop then sleep 1
+    );
+
+    if loop then change_sort_order ()
+  )
+
+(* Note: We need to clear_pcpu_display_data every time
+ * we _leave_ PCPUDisplay mode.
+ *)
+and set_tasks_display () =             (* key 0 *)
+  if !display_mode = PCPUDisplay then clear_pcpu_display_data ();
+  display_mode := TaskDisplay
+
+and toggle_pcpu_display () =           (* key 1 *)
+  display_mode :=
+    match !display_mode with
+    | TaskDisplay | NetDisplay | BlockDisplay -> PCPUDisplay
+    | PCPUDisplay -> clear_pcpu_display_data (); TaskDisplay
+
+and toggle_net_display () =            (* key 2 *)
+  display_mode :=
+    match !display_mode with
+    | PCPUDisplay -> clear_pcpu_display_data (); NetDisplay
+    | TaskDisplay | BlockDisplay -> NetDisplay
+    | NetDisplay -> TaskDisplay
+
+and toggle_block_display () =          (* key 3 *)
+  display_mode :=
+    match !display_mode with
+    | PCPUDisplay -> clear_pcpu_display_data (); BlockDisplay
+    | TaskDisplay | NetDisplay -> BlockDisplay
+    | BlockDisplay -> TaskDisplay
+
+and show_help (_, _, _, hostname,
+              (libvirt_major, libvirt_minor, libvirt_release)) =
+  clear ();
+
+  (* Get the screen/window size. *)
+  let lines, cols = get_size () in
+
+  (* Banner at the top of the screen. *)
+  let banner =
+    sprintf "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;
+  mvaddstr 0 0 banner;
+  attroff A.reverse;
+
+  (* Status. *)
+  mvaddstr 1 0
+    (sprintf "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"
+       (match !uri with None -> "default" | Some s -> s)
+       hostname);
+
+  (* Misc keys on left. *)
+  let banner = pad 38 "MAIN KEYS" in
+  attron A.reverse;
+  mvaddstr header_lineno 1 banner;
+  attroff A.reverse;
+
+  let get_lineno =
+    let lineno = ref domains_lineno in
+    fun () -> let i = !lineno in incr lineno; i
+  in
+  let key keys description =
+    let lineno = get_lineno () in
+    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";
+
+  (* Sort order. *)
+  ignore (get_lineno ());
+  let banner = pad 38 "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";
+
+  (* Display modes on right. *)
+  let banner = pad 39 "DISPLAY MODES" in
+  attron A.reverse;
+  mvaddstr header_lineno 40 banner;
+  attroff A.reverse;
+
+  let get_lineno =
+    let lineno = ref domains_lineno in
+    fun () -> let i = !lineno in incr lineno; i
+  in
+  let key keys description =
+    let lineno = get_lineno () in
+    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";
+
+  (* Update screen and wait for key press. *)
+  mvaddstr (lines-1) 0
+    "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";
+  sleep 1
diff --git a/virt-top/virt_top_csv.ml b/virt-top/virt_top_csv.ml
new file mode 100644 (file)
index 0000000..71bb79e
--- /dev/null
@@ -0,0 +1,29 @@
+(* 'top'-like tool for libvirt domains.
+ * $Id: virt_top_csv.ml,v 1.1 2007/08/23 11:09:19 rjones Exp $
+ *
+ * This file contains all code which requires CSV support.
+ *)
+
+open ExtList
+
+module C = Libvirt.Connect
+module D = Libvirt.Domain
+module N = Libvirt.Network
+
+(* Output channel, or None if CSV output not enabled. *)
+let chan = ref None ;;
+
+Virt_top.csv_start :=
+  fun filename ->
+    chan := Some (open_out filename) ;;
+
+Virt_top.csv_write :=
+  fun row ->
+    match !chan with
+    | None -> ()                       (* CSV output not enabled. *)
+    | Some chan ->
+       Csv.save_out chan [row];
+       (* Flush the output to the file immediately because we don't
+        * explicitly close this file.
+        *)
+       flush chan
diff --git a/virt-top/virt_top_main.ml b/virt-top/virt_top_main.ml
new file mode 100644 (file)
index 0000000..5841362
--- /dev/null
@@ -0,0 +1,37 @@
+(* 'top'-like tool for libvirt domains.
+ * $Id: virt_top_main.ml,v 1.2 2007/08/30 13:16:57 rjones Exp $
+ *
+ * Just contains the main function.
+ *)
+
+open Curses
+
+open Virt_top
+
+(* Note: make sure we catch any exceptions and clean up the display.
+ *
+ * Note (2): make sure all exit paths call the GC so that we can check
+ * that all allocated resources are being counted properly (by running
+ * the program under --debug ...).
+ *)
+let error =
+  let state = start_up () in
+
+  try
+    main_loop state;
+    endwin ();
+    false
+  with
+  | Libvirt.Virterror err ->
+      endwin ();
+      prerr_endline (Libvirt.Virterror.to_string err);
+      true
+  | exn ->
+      endwin ();
+      prerr_endline ("Error: " ^ Printexc.to_string exn);
+      true
+
+let () =
+  Gc.compact (); (* See note above. *)
+
+  exit (if error then 1 else 0)
diff --git a/virt-top/virt_top_xml.ml b/virt-top/virt_top_xml.ml
new file mode 100644 (file)
index 0000000..7d24b3f
--- /dev/null
@@ -0,0 +1,52 @@
+(* 'top'-like tool for libvirt domains.
+ * $Id: virt_top_xml.ml,v 1.1 2007/08/23 09:36:04 rjones Exp $
+ *
+ * This file contains all code which requires xml-light.
+ *)
+
+open ExtList
+
+module C = Libvirt.Connect
+module D = Libvirt.Domain
+module N = Libvirt.Network ;;
+
+Virt_top.parse_device_xml :=
+fun id dom ->
+  try
+    let xml = D.get_xml_desc dom in
+    let xml = Xml.parse_string xml in
+    let devices =
+      match xml with
+      | Xml.Element ("domain", _, children) ->
+         let devices =
+           List.filter_map (
+             function
+             | Xml.Element ("devices", _, devices) -> Some devices
+             | _ -> None
+           ) children in
+         List.concat devices
+      | _ ->
+         failwith "get_xml_desc didn't return <domain/>" 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 blkdevs =
+      List.filter_map (
+       function
+       | Xml.Element ("disk", _, children) -> target_dev_of children
+       | _ -> None
+      ) devices in
+    let netifs =
+      List.filter_map (
+       function
+       | Xml.Element ("interface", _, children) -> target_dev_of children
+       | _ -> None
+      ) devices in
+    blkdevs, netifs
+  with
+  | Xml.Error _
+  | Libvirt.Virterror _ -> [], [] (* ignore transient errs *)