From: rjones@localhost Date: Thu, 30 Aug 2007 16:38:09 +0000 (+0100) Subject: Initial import from CVS. X-Git-Url: http://git.annexia.org/?a=commitdiff_plain;h=a8b837d5018c488a130fcbea425904817a862210;p=virt-top.git Initial import from CVS. --- a8b837d5018c488a130fcbea425904817a862210 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