From a8b837d5018c488a130fcbea425904817a862210 Mon Sep 17 00:00:00 2001 From: "rjones@localhost" Date: Thu, 30 Aug 2007 17:38:09 +0100 Subject: [PATCH 1/1] Initial import from CVS. --- .cvsignore | 11 + COPYING | 339 +++++ COPYING.LIB | 515 +++++++ MANIFEST | 53 + META.in | 5 + Make.rules | 27 + Makefile.in | 74 + README | 154 +++ TODO.libvirt | 3 + TODO.virt-top | 72 + aclocal.m4 | 147 ++ config.h.in | 85 ++ configure.ac | 104 ++ examples/.cvsignore | 8 + examples/.depend | 2 + examples/Makefile | 32 + examples/Makefile.in | 32 + examples/list_domains.ml | 47 + install-sh | 507 +++++++ libvirt/.cvsignore | 7 + libvirt/.depend | 4 + libvirt/Makefile | 44 + libvirt/Makefile.in | 44 + libvirt/libvirt.ml | 379 ++++++ libvirt/libvirt.mli | 416 ++++++ libvirt/libvirt_c.c | 1953 +++++++++++++++++++++++++++ libvirt/libvirt_version.ml | 6 + libvirt/libvirt_version.ml.in | 6 + libvirt/libvirt_version.mli | 12 + mlvirsh/.cvsignore | 8 + mlvirsh/.depend | 2 + mlvirsh/Makefile | 42 + mlvirsh/Makefile.in | 42 + mlvirsh/mlvirsh.ml | 690 ++++++++++ mlvirtmanager/.cvsignore | 8 + mlvirtmanager/.depend | 22 + mlvirtmanager/Makefile | 51 + mlvirtmanager/Makefile.in | 51 + mlvirtmanager/mlvirtmanager.ml | 19 + mlvirtmanager/mlvirtmanager_connections.ml | 313 +++++ mlvirtmanager/mlvirtmanager_connections.mli | 34 + mlvirtmanager/mlvirtmanager_domain_ops.ml | 83 ++ mlvirtmanager/mlvirtmanager_domain_ops.mli | 12 + mlvirtmanager/mlvirtmanager_helpers.ml | 82 ++ mlvirtmanager/mlvirtmanager_helpers.mli | 38 + mlvirtmanager/mlvirtmanager_mainwindow.ml | 134 ++ mlvirtmanager/mlvirtmanager_mainwindow.mli | 16 + virt-top/.cvsignore | 8 + virt-top/.depend | 8 + virt-top/Makefile | 79 ++ virt-top/Makefile.in | 79 ++ virt-top/README | 42 + virt-top/virt-top.1 | 328 +++++ virt-top/virt-top.pod | 244 ++++ virt-top/virt-top.txt | 167 +++ virt-top/virt_top.ml | 1405 +++++++++++++++++++ virt-top/virt_top_csv.ml | 29 + virt-top/virt_top_main.ml | 37 + virt-top/virt_top_xml.ml | 52 + 59 files changed, 9213 insertions(+) create mode 100644 .cvsignore create mode 100644 COPYING create mode 100644 COPYING.LIB create mode 100644 MANIFEST create mode 100644 META.in create mode 100644 Make.rules create mode 100644 Makefile.in create mode 100644 README create mode 100644 TODO.libvirt create mode 100644 TODO.virt-top create mode 100644 aclocal.m4 create mode 100644 config.h.in create mode 100644 configure.ac create mode 100644 examples/.cvsignore create mode 100644 examples/.depend create mode 100644 examples/Makefile create mode 100644 examples/Makefile.in create mode 100644 examples/list_domains.ml create mode 100755 install-sh create mode 100644 libvirt/.cvsignore create mode 100644 libvirt/.depend create mode 100644 libvirt/Makefile create mode 100644 libvirt/Makefile.in create mode 100644 libvirt/libvirt.ml create mode 100644 libvirt/libvirt.mli create mode 100644 libvirt/libvirt_c.c create mode 100644 libvirt/libvirt_version.ml create mode 100644 libvirt/libvirt_version.ml.in create mode 100644 libvirt/libvirt_version.mli create mode 100644 mlvirsh/.cvsignore create mode 100644 mlvirsh/.depend create mode 100644 mlvirsh/Makefile create mode 100644 mlvirsh/Makefile.in create mode 100644 mlvirsh/mlvirsh.ml create mode 100644 mlvirtmanager/.cvsignore create mode 100644 mlvirtmanager/.depend create mode 100644 mlvirtmanager/Makefile create mode 100644 mlvirtmanager/Makefile.in create mode 100644 mlvirtmanager/mlvirtmanager.ml create mode 100644 mlvirtmanager/mlvirtmanager_connections.ml create mode 100644 mlvirtmanager/mlvirtmanager_connections.mli create mode 100644 mlvirtmanager/mlvirtmanager_domain_ops.ml create mode 100644 mlvirtmanager/mlvirtmanager_domain_ops.mli create mode 100644 mlvirtmanager/mlvirtmanager_helpers.ml create mode 100644 mlvirtmanager/mlvirtmanager_helpers.mli create mode 100644 mlvirtmanager/mlvirtmanager_mainwindow.ml create mode 100644 mlvirtmanager/mlvirtmanager_mainwindow.mli create mode 100644 virt-top/.cvsignore create mode 100644 virt-top/.depend create mode 100644 virt-top/Makefile create mode 100644 virt-top/Makefile.in create mode 100644 virt-top/README create mode 100644 virt-top/virt-top.1 create mode 100644 virt-top/virt-top.pod create mode 100644 virt-top/virt-top.txt create mode 100644 virt-top/virt_top.ml create mode 100644 virt-top/virt_top_csv.ml create mode 100644 virt-top/virt_top_main.ml create mode 100644 virt-top/virt_top_xml.ml diff --git a/.cvsignore b/.cvsignore new file mode 100644 index 0000000..01289d4 --- /dev/null +++ b/.cvsignore @@ -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 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. + + 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.) + +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. + + 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. + + 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 + + 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. + + + Copyright (C) 19yy + + 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. + + , 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 index 0000000..ba2be48 --- /dev/null +++ b/COPYING.LIB @@ -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. + + 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. + + + + Copyright (C) + + 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. + + , 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 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 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 index 0000000..00480c3 --- /dev/null +++ b/Make.rules @@ -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 index 0000000..3ad12ac --- /dev/null +++ b/Makefile.in @@ -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 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 index 0000000..7d980fd --- /dev/null +++ b/TODO.libvirt @@ -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 index 0000000..479c5ac --- /dev/null +++ b/TODO.virt-top @@ -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 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 index 0000000..55d5ceb --- /dev/null +++ b/aclocal.m4 @@ -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 index 0000000..d8c604b --- /dev/null +++ b/config.h.in @@ -0,0 +1,85 @@ +/* config.h.in. Generated from configure.ac by autoheader. */ + +/* Define to 1 if you have the header file. */ +#undef HAVE_INTTYPES_H + +/* Define to 1 if you have the `ncurses' library (-lncurses). */ +#undef HAVE_LIBNCURSES + +/* Define to 1 if you have the `virt' library (-lvirt). */ +#undef HAVE_LIBVIRT + +/* Define to 1 if you have the header file. */ +#undef HAVE_MEMORY_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_STDINT_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_STDLIB_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_STRINGS_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_STRING_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_SYS_STAT_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_SYS_TYPES_H + +/* Define to 1 if you have the header file. */ +#undef HAVE_UNISTD_H + +/* Define to 1 if you have the `virConnectGetHostname' function. */ +#undef HAVE_VIRCONNECTGETHOSTNAME + +/* Define to 1 if you have the `virConnectGetURI' function. */ +#undef HAVE_VIRCONNECTGETURI + +/* Define to 1 if you have the `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 index 0000000..f1dc5c8 --- /dev/null +++ b/configure.ac @@ -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 index 0000000..1353c69 --- /dev/null +++ b/examples/.cvsignore @@ -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 index 0000000..bc5cec2 --- /dev/null +++ b/examples/.depend @@ -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 index 0000000..4692e36 --- /dev/null +++ b/examples/Makefile @@ -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 index 0000000..4692e36 --- /dev/null +++ b/examples/Makefile.in @@ -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 index 0000000..f752754 --- /dev/null +++ b/examples/list_domains.ml @@ -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 index 0000000..4fbbae7 --- /dev/null +++ b/install-sh @@ -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 index 0000000..beb49ff --- /dev/null +++ b/libvirt/.cvsignore @@ -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 index 0000000..5556d96 --- /dev/null +++ b/libvirt/.depend @@ -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 index 0000000..e22d9f7 --- /dev/null +++ b/libvirt/Makefile @@ -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 index 0000000..ff90d72 --- /dev/null +++ b/libvirt/Makefile.in @@ -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 index 0000000..14dca54 --- /dev/null +++ b/libvirt/libvirt.ml @@ -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 . *) + let maxcpus_of_node_info { nodes = nodes; sockets = sockets; + cores = cores; threads = threads } = + nodes * sockets * cores * threads + + (* See VIR_CPU_MAPLEN macro defined in . *) + let cpumaplen nr_cpus = + (nr_cpus + 7) / 8 + + (* See VIR_USE_CPU, VIR_UNUSE_CPU, VIR_CPU_USABLE macros defined in . *) + let use_cpu cpumap cpu = + cpumap.[cpu/8] <- + Char.chr (Char.code cpumap.[cpu/8] lor (1 lsl (cpu mod 8))) + let unuse_cpu cpumap cpu = + cpumap.[cpu/8] <- + Char.chr (Char.code cpumap.[cpu/8] land (lnot (1 lsl (cpu mod 8)))) + let cpu_usable cpumaps maplen vcpu cpu = + Char.code cpumaps.[vcpu*maplen + cpu/8] land (1 lsl (cpu mod 8)) <> 0 + + external const : [>`R] t -> ro t = "%identity" +end + +module Domain = +struct + type 'rw 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 index 0000000..66f94c7 --- /dev/null +++ b/libvirt/libvirt.mli @@ -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 [] 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 index 0000000..808dd82 --- /dev/null +++ b/libvirt/libvirt_c.c @@ -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 +#include +#include + +#include +#include + +#include +#include +#include +#include +#include +#include +#include +#include + +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 index 0000000..329d22e --- /dev/null +++ b/libvirt/libvirt_version.ml @@ -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 index 0000000..8214980 --- /dev/null +++ b/libvirt/libvirt_version.ml.in @@ -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 index 0000000..847089a --- /dev/null +++ b/libvirt/libvirt_version.mli @@ -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 index 0000000..7d561e2 --- /dev/null +++ b/mlvirsh/.cvsignore @@ -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 index 0000000..a346edd --- /dev/null +++ b/mlvirsh/.depend @@ -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 index 0000000..5160fde --- /dev/null +++ b/mlvirsh/Makefile @@ -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 index 0000000..3798962 --- /dev/null +++ b/mlvirsh/Makefile.in @@ -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 index 0000000..5b63a77 --- /dev/null +++ b/mlvirsh/mlvirsh.ml @@ -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 is a function that constructs a command. + * string string string ... <--- user types on the command line + * | | | + * arg1 arg2 arg3 ... <--- conversion functions + * | | | + * V V V + * function f <--- work function + * | + * V + * print result <--- printing function + * + * (Note that cmd function constructs and returns the above + * function, it isn't the function itself.) + * + * Example: If the function takes one parameter (an int) and + * returns a string to be printed, you would use: + * + * cmd1 print_endline f int_of_string + *) + let cmd0 print fn = function (* Command with no args. *) + | [] -> print (fn ()) + | _ -> failwith "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 index 0000000..df80d41 --- /dev/null +++ b/mlvirtmanager/.cvsignore @@ -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 index 0000000..01a1aa6 --- /dev/null +++ b/mlvirtmanager/.depend @@ -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 index 0000000..3921a15 --- /dev/null +++ b/mlvirtmanager/Makefile @@ -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 index 0000000..fe75929 --- /dev/null +++ b/mlvirtmanager/Makefile.in @@ -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 index 0000000..091c026 --- /dev/null +++ b/mlvirtmanager/mlvirtmanager.ml @@ -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 index 0000000..2fda3e9 --- /dev/null +++ b/mlvirtmanager/mlvirtmanager_connections.ml @@ -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 index 0000000..eb11be8 --- /dev/null +++ b/mlvirtmanager/mlvirtmanager_connections.mli @@ -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 index 0000000..f02cd1f --- /dev/null +++ b/mlvirtmanager/mlvirtmanager_domain_ops.ml @@ -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 index 0000000..9824b3a --- /dev/null +++ b/mlvirtmanager/mlvirtmanager_domain_ops.mli @@ -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 index 0000000..ff30253 --- /dev/null +++ b/mlvirtmanager/mlvirtmanager_helpers.ml @@ -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 index 0000000..2952636 --- /dev/null +++ b/mlvirtmanager/mlvirtmanager_helpers.mli @@ -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 index 0000000..93ee34b --- /dev/null +++ b/mlvirtmanager/mlvirtmanager_mainwindow.ml @@ -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 index 0000000..2ca9928 --- /dev/null +++ b/mlvirtmanager/mlvirtmanager_mainwindow.mli @@ -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 index 0000000..cb61894 --- /dev/null +++ b/virt-top/.cvsignore @@ -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 index 0000000..75ecf81 --- /dev/null +++ b/virt-top/.depend @@ -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 index 0000000..9c7ef0b --- /dev/null +++ b/virt-top/Makefile @@ -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 index 0000000..e1cb75f --- /dev/null +++ b/virt-top/Makefile.in @@ -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 index 0000000..c3752c6 --- /dev/null +++ b/virt-top/README @@ -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 index 0000000..7e9c5d4 --- /dev/null +++ b/virt-top/virt-top.1 @@ -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), +, +, + +.SH "AUTHORS" +.IX Header "AUTHORS" +Richard W.M. Jones +.SH "REPORTING BUGS" +.IX Header "REPORTING BUGS" +Bugs can be viewed on the Red Hat Bugzilla page: +. +.PP +If you find a bug in virt\-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 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 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 index 0000000..fe8ba91 --- /dev/null +++ b/virt-top/virt-top.pod @@ -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-like utility for showing stats of virtualized +domains. Many keys and command line options are the same as for +ordinary I. + +It uses libvirt so it is capable of showing stats across a variety of +different virtualization systems. + +=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 or I 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 (sort by %CPU used), +B (sort by memory used), +B