--- /dev/null
+repo: 782d85c848856fca5de6cfe7c895a6793ec71dcc
+node: b95c318ded7ca1eb3ff556c472f51ff0bd6c649f
--- /dev/null
+\.cmi$
+\.cmo$
+\.cmx$
+\.so$
+\.o$
+\.cma$
+\.cmxa$
+\.a$
+\.annot$
+\/META$
--- /dev/null
+This is a partial list of people who have contributed code to this repository,
+sorted alphabetically.
+
+Anil Madhavapeddy <anil@xensource.com>
+Christian Limpach <Christian.Limpach@citrix.com>
+David Scott <dave.scott@eu.citrix.com>
+Ewan Mellor <ewan.mellor@eu.citrix.com>
+Ian Campbell <ian.campbell@citrix.com>
+Jonathan Davies <jonathan.davies@citrix.com>
+Jonathan Knowles <jonathan.knowles@citrix.com>
+Jonathan Ludlam <Jonathan.Ludlam@eu.citrix.com>
+Magnus Therning <magnus.therning@eu.citrix.com>
+Richard Sharp <richard.sharp@eu.citrix.com>
+Thomas Gazagnaire <thomas.gazagnaire@citrix.com>
+Tim Deegan <Tim.Deegan@citrix.com>
+Vincent Hanquez <vincent@xensource.com>
--- /dev/null
+This repository is distributed under the terms of the GNU Lesser General
+Public License version 2.1 (included below).
+
+As a special exception to the GNU Lesser General Public License, you
+may link, statically or dynamically, a "work that uses the Library"
+with a publicly distributed version of the Library to produce an
+executable file containing portions of the Library, and distribute
+that executable file under terms of your choice, without any of the
+additional requirements listed in clause 6 of the GNU Lesser General
+Public License. By "a publicly distributed version of the Library",
+we mean either the unmodified Library as distributed, or a
+modified version of the Library that is distributed under the
+conditions defined in clause 3 of the GNU Library General Public
+License. This exception does not however invalidate any other reasons
+why the executable file might be covered by the GNU Lesser General
+Public License.
+
+------------
+
+GNU LESSER GENERAL PUBLIC LICENSE
+Version 2.1, February 1999
+
+
+Copyright (C) 1991, 1999 Free Software Foundation, Inc.
+59 Temple Place, Suite 330, Boston, MA 02111-1307 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.
+
+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.
+
+
+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.
+
+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.
+
+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.
+
+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.
+
+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.
+
+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
+How to Apply These Terms to Your New Libraries
+If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License).
+
+To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found.
+
+
+one line to give the library's name and an idea of what it does.
+Copyright (C) year name of author
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the GNU Lesser General Public
+License as published by the Free Software Foundation; either
+version 2.1 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+Also add information on how to contact you by electronic and paper mail.
+
+You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names:
+
+
+Yoyodyne, Inc., hereby disclaims all copyright interest in
+the library `Frob' (a library for tweaking knobs) written
+by James Random Hacker.
+
+signature of Ty Coon, 1 April 1990
+Ty Coon, President of Vice
+
+That's all there is to it!
--- /dev/null
+NO_DEFAULT_BUILD := yes
+ifdef B_BASE
+include $(B_BASE)/common.mk
+else
+MY_OUTPUT_DIR ?= $(CURDIR)/output
+MY_OBJ_DIR ?= $(CURDIR)/obj
+
+%/.dirstamp:
+ @mkdir -p $*
+ @touch $@
+endif
+
+all:
+ $(MAKE) -C uuid
+ $(MAKE) -C camldm
+ $(MAKE) -C stdext
+ $(MAKE) -C cdrom
+ $(MAKE) -C log
+ $(MAKE) -C sha1
+ $(MAKE) -C xml-light2
+
+allxen:
+ $(MAKE) -C mmap
+ $(MAKE) -C xc
+ $(MAKE) -C xb
+ $(MAKE) -C xs
+ $(MAKE) -C xsrpc
+ $(MAKE) -C eventchn
+
+install:
+ $(MAKE) -C uuid install
+ $(MAKE) -C camldm install
+ $(MAKE) -C stdext install
+ $(MAKE) -C cdrom install
+ $(MAKE) -C log install
+ $(MAKE) -C sha1 install
+ $(MAKE) -C xml-light2 install
+
+installxen:
+ $(MAKE) -C mmap install
+ $(MAKE) -C xc install
+ $(MAKE) -C xb install
+ $(MAKE) -C xs install
+ $(MAKE) -C xsrpc install
+ $(MAKE) -C eventchn install
+
+uninstall:
+ $(MAKE) -C uuid uninstall
+ $(MAKE) -C camldm uninstall
+ $(MAKE) -C stdext uninstall
+ $(MAKE) -C cdrom uninstall
+ $(MAKE) -C log uninstall
+ $(MAKE) -C sha1 uninstall
+ $(MAKE) -C xml-light2 uninstall
+
+uninstallxen:
+ $(MAKE) -C eventchn uninstall
+ $(MAKE) -C xsrpc uninstall
+ $(MAKE) -C xs uninstall
+ $(MAKE) -C xb uninstall
+ $(MAKE) -C xc uninstall
+ $(MAKE) -C mmap uninstall
+
+OUTPUT_API_PKG := $(MY_OUTPUT_DIR)/api-libs.tar.gz
+
+$(OUTPUT_API_PKG): DESTDIR=$(MY_OBJ_DIR)/staging/
+$(OUTPUT_API_PKG): PREFIX=$(shell ocamlfind printconf path)
+$(OUTPUT_API_PKG): $(MY_OBJ_DIR)/.dirstamp $(MY_OUTPUT_DIR)/.dirstamp
+ rm -rf $(DESTDIR)
+ mkdir -p $(DESTDIR)$(PREFIX)
+ $(MAKE) clean
+ $(MAKE) all
+ $(MAKE) DESTDIR=$(MY_OBJ_DIR)/staging install
+ tar -C $(DESTDIR) -zcf $@ .
+
+OUTPUT_XAPI_PKG := $(MY_OUTPUT_DIR)/xapi-libs.tar.gz
+
+$(OUTPUT_XAPI_PKG): DESTDIR=$(MY_OBJ_DIR)/staging/
+$(OUTPUT_XAPI_PKG): PREFIX=$(shell ocamlfind printconf path)
+$(OUTPUT_XAPI_PKG): $(MY_OBJ_DIR)/.dirstamp $(MY_OUTPUT_DIR)/.dirstamp
+ rm -rf $(DESTDIR)
+ mkdir -p $(DESTDIR)$(PREFIX)
+ $(MAKE) cleanxen
+ $(MAKE) allxen
+ $(MAKE) DESTDIR=$(MY_OBJ_DIR)/staging installxen
+ tar -C $(DESTDIR) -zcf $@ .
+
+.PHONY: api-libs
+api-libs: $(OUTPUT_API_PKG)
+ @ :
+
+.PHONY: xapi-libs
+xapi-libs: $(OUTPUT_XAPI_PKG)
+ @ :
+
+.PHONY: clean
+clean:
+ make -C uuid clean
+ make -C camldm clean
+ make -C stdext clean
+ make -C cdrom clean
+ make -C log clean
+ make -C sha1 clean
+ make -C xml-light2 clean
+ rm -f $(OUTPUT_API_PKG)
+
+cleanxen:
+ $(MAKE) -C mmap clean
+ $(MAKE) -C xc clean
+ $(MAKE) -C xb clean
+ $(MAKE) -C xs clean
+ $(MAKE) -C xsrpc clean
+ $(MAKE) -C eventchn clean
+ rm -f $(OUTPUT_XAPI_PKG)
--- /dev/null
+version = "@VERSION@"
+description = "device-mapper ocaml interface"
+archive(byte) = "camldm.cma"
+archive(native) = "camldm.cmxa"
--- /dev/null
+
+CC = gcc
+CFLAGS = -Wall -fPIC -O2 -I/opt/xensource/lib/ocaml
+OCAMLC = ocamlc -g
+OCAMLOPT = ocamlopt
+
+LDFLAGS = -cclib -L./
+
+DESTDIR ?= /
+VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0)
+OCAMLOPTFLAGS = -g -dtypes
+
+OCAMLABI := $(shell ocamlc -version)
+OCAMLLIBDIR := $(shell ocamlc -where)
+OCAMLDESTDIR ?= $(OCAMLLIBDIR)
+
+OBJS = camldm
+INTF = $(foreach obj, $(OBJS),$(obj).cmi)
+LIBS = camldm.cma camldm.cmxa
+
+all: $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+camldm.cmxa: libcamldm_stubs.a $(foreach obj,$(OBJS),$(obj).cmx)
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -a -o $@ -cclib -lcamldm_stubs -cclib -ldevmapper $(foreach obj,$(OBJS),$(obj).cmx)
+
+camldm.cma: $(foreach obj,$(OBJS),$(obj).cmo)
+ $(OCAMLC) -a -dllib dllcamldm_stubs.so -cclib -lcamldm_stubs -cclib -ldevmapper -o $@ $(foreach obj,$(OBJS),$(obj).cmo)
+
+camldm_stubs.a: camldm_stubs.o
+ ocamlmklib -o camldm_stubs -ldevmapper $+
+
+libcamldm_stubs.a: camldm_stubs.o
+ ar rcs $@ $+
+ ocamlmklib -o camldm_stubs -ldevmapper $+
+
+%.cmo: %.ml
+ $(OCAMLC) -c -o $@ $<
+
+%.cmi: %.mli
+ $(OCAMLC) -c -o $@ $<
+
+%.cmx: %.ml
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -c -o $@ $<
+
+%.o: %.c
+ $(CC) $(CFLAGS) -c -o $@ $<
+
+META: META.in
+ sed 's/@VERSION@/$(VERSION)/g' < $< > $@
+
+.PHONY: install
+install: $(LIBS) META
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore camldm META $(INTF) $(LIBS) *.a *.so *.cmx
+
+.PHONY: uninstall
+uninstall:
+ ocamlfind remove camldm
+
+clean:
+ rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS)
--- /dev/null
+type dev = {
+ device : string;
+ offset : int64;
+}
+
+type stripety = {
+ chunk_size : int64;
+ dests : dev array;
+}
+
+type mapty =
+ | Linear of dev (* Device, offset *)
+ | Striped of stripety
+
+type mapping = {
+ start : int64;
+ len : int64;
+ map : mapty;
+}
+
+type status = {
+ exists : bool;
+ suspended : bool;
+ live_table : bool;
+ inactive_table : bool;
+ open_count : int32;
+ event_nr : int32;
+ major : int32;
+ minor : int32;
+ read_only : bool;
+ targets : (int64 * int64 * string * string) list
+}
+
+external _create : string -> (int64 * int64 * string * string) array -> unit = "camldm_create"
+external _table : string -> status = "camldm_table"
+external _mknods : string -> unit = "camldm_mknods"
+external _remove : string -> unit = "camldm_remove"
+external _mknod : string -> int -> int -> int -> unit = "camldm_mknod"
+
+(* Helper to convert from our type to the string*string
+ * type expected by libdevmapper *)
+let convert_mapty m =
+ let array_concat sep a = String.concat sep (Array.to_list a) in
+ match m with
+ | Linear dev ->
+ "linear",Printf.sprintf "%s %Ld" dev.device dev.offset
+ | Striped st ->
+ "striped",
+ Printf.sprintf "%d %Ld %s" (Array.length st.dests) st.chunk_size
+ (array_concat " "
+ (Array.map (fun dev ->
+ Printf.sprintf "%s %Ld" dev.device dev.offset) st.dests))
+
+let create dev map =
+ let newmap = Array.map (fun m ->
+ let (ty,params) = convert_mapty m.map in
+ (m.start, m.len, ty, params)) map in
+ _create dev newmap
+
+let remove = _remove
+let table = _table
+let mknods = _mknods
+let mknod = _mknod
+
--- /dev/null
+type dev = { device : string; offset : int64; }
+type stripety = { chunk_size : int64; dests : dev array; }
+type mapty = Linear of dev | Striped of stripety
+type mapping = { start : int64; len : int64; map : mapty; }
+type status = {
+ exists : bool;
+ suspended : bool;
+ live_table : bool;
+ inactive_table : bool;
+ open_count : int32;
+ event_nr : int32;
+ major : int32;
+ minor : int32;
+ read_only : bool;
+ targets : (int64 * int64 * string * string) list;
+}
+val convert_mapty : mapty -> string * string
+val create : string -> mapping array -> unit
+val remove : string -> unit
+val table : string -> status
+val mknods : string -> unit
+val mknod : string -> int -> int -> int -> unit
--- /dev/null
+#include <libdevmapper.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/custom.h>
+#include <caml/fail.h>
+#include <stdio.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+#include <unistd.h>
+
+/* map is an array of 4-tuples
+ * (start : int64, size : int64, type : string, params : string)
+ * format of params depends upon the type
+ */
+void camldm_create(value name, value map)
+{
+ CAMLparam2(name,map);
+
+ struct dm_task *dmt;
+ int i;
+ uint64_t start, size;
+ char *ty,*params;
+
+ if(!(dmt = dm_task_create(DM_DEVICE_CREATE)))
+ caml_failwith("Failed to create task!");
+
+ if(!dm_task_set_name(dmt, String_val(name)))
+ goto out;
+
+ for(i=0; i<Wosize_val(map); i++) {
+ start=Int64_val(Field(Field(map,i),0));
+ size=Int64_val(Field(Field(map,i),1));
+ ty=String_val(Field(Field(map,i),2));
+ params=String_val(Field(Field(map,i),3));
+
+ printf("%" PRIu64 " %" PRIu64 " %s %s\n", start, size, ty, params);
+
+ if(!dm_task_add_target(dmt, start, size, ty, params))
+ goto out;
+ }
+
+ if(!dm_task_run(dmt))
+ goto out;
+
+ goto win;
+
+ out:
+ dm_task_destroy(dmt);
+ caml_failwith("Failed!");
+
+ win:
+ CAMLreturn0;
+}
+
+
+void camldm_mknods(value dev)
+{
+ CAMLparam1 (dev);
+
+ if(caml_string_length(dev)==0) {
+ dm_mknodes(NULL);
+ } else {
+ dm_mknodes(String_val(dev));
+ }
+
+ CAMLreturn0;
+}
+
+value camldm_table(value dev)
+{
+ CAMLparam1 (dev);
+ CAMLlocal4 (result,r,tuple,tmp);
+
+ struct dm_task *dmt;
+ struct dm_info info;
+
+ void *next = NULL;
+ uint64_t start, length;
+ char *target_type = NULL;
+ char *params = NULL;
+
+ if(!(dmt = dm_task_create(DM_DEVICE_TABLE)))
+ caml_failwith("Could not create dm_task");
+
+ if(!dm_task_set_name(dmt, String_val(dev))) {
+ dm_task_destroy(dmt);
+ caml_failwith("Could not set device");
+ }
+
+ if(!dm_task_run(dmt)) {
+ dm_task_destroy(dmt);
+ caml_failwith("Failed to run task");
+ }
+
+ if (!dm_task_get_info(dmt, &info) || !info.exists) {
+ dm_task_destroy(dmt);
+ caml_failwith("Failed to get info");
+ }
+
+ result=caml_alloc_tuple(10);
+
+ Store_field(result,0,Val_bool(info.exists));
+ Store_field(result,1,Val_bool(info.suspended));
+ Store_field(result,2,Val_bool(info.live_table));
+ Store_field(result,3,Val_bool(info.inactive_table));
+ Store_field(result,4,caml_copy_int32(info.open_count));
+ Store_field(result,5,caml_copy_int32(info.event_nr));
+ Store_field(result,6,caml_copy_int32(info.major));
+ Store_field(result,7,caml_copy_int32(info.minor));
+ Store_field(result,8,Val_bool(info.read_only));
+
+ tmp=Val_int(0);
+
+ do {
+ next = dm_get_next_target(dmt, next, &start, &length, &target_type, ¶ms);
+ dm_task_get_info(dmt, &info);
+
+ tuple=caml_alloc_tuple(4);
+ Store_field(tuple,0,caml_copy_int64(start));
+ Store_field(tuple,1,caml_copy_int64(length));
+ Store_field(tuple,2,caml_copy_string(target_type));
+ Store_field(tuple,3,caml_copy_string(params));
+
+ r=caml_alloc(2,0);
+ Store_field(r, 0, tuple);
+ Store_field(r, 1, tmp);
+
+ tmp=r;
+
+ printf("params=%s\n",params);
+ } while(next);
+
+ Store_field(result,9,tmp);
+
+ CAMLreturn(result);
+}
+
+void _simple(int task, const char *name)
+{
+ struct dm_task *dmt;
+
+ if (!(dmt = dm_task_create(task)))
+ caml_failwith("Failed to create task");
+
+ if(!dm_task_set_name(dmt, name)) {
+ dm_task_destroy(dmt);
+ caml_failwith("Could not set device");
+ }
+
+ if(!dm_task_run(dmt)) {
+ dm_task_destroy(dmt);
+ caml_failwith("Failed to run task");
+ }
+
+ dm_task_destroy(dmt);
+}
+
+void camldm_remove(value device)
+{
+ CAMLparam1(device);
+ _simple(DM_DEVICE_REMOVE,String_val(device));
+ CAMLreturn0;
+}
+
+void camldm_mknod(value path, value mode, value major, value minor)
+{
+ CAMLparam4(path, mode, major, minor);
+ mknod(String_val(path),S_IFBLK | Int_val(mode), makedev(Int_val(major),Int_val(minor)));
+ CAMLreturn0;
+}
--- /dev/null
+open Camldm
+
+let _ =
+ let name = Sys.argv.(1) in
+ let start = Int64.of_string Sys.argv.(2) in
+ let len = Int64.of_string Sys.argv.(3) in
+ let dev = Sys.argv.(4) in
+ let offset = Int64.of_string Sys.argv.(5) in
+ let dev2 = Sys.argv.(6) in
+ let offset2 = Int64.of_string Sys.argv.(7) in
+
+ let buf = String.create 512 in
+
+ Camldm.create name [| { start=start;
+ len=len;
+ map = Striped {chunk_size=8L;
+ dests=[| {device=dev;offset=offset};
+ {device=dev2;offset=offset2} |] } } |];
+
+ let s = Camldm.table name in
+ let (major,minor) = s.major,s.minor in
+ let nod = "/tmp/foobar" in
+ Camldm.mknod nod 0o644 (Int32.to_int major) (Int32.to_int minor);
+ let ifd = Unix.openfile nod [Unix.O_RDONLY] 0o000 in
+ Printf.printf "Status:\nexists: %b\nsuspended: %b\nlive_table: %b\ninactive_table: %b\n" s.exists s.suspended s.live_table s.inactive_table;
+ Printf.printf "open_count: %ld\nevent_nr: %ld\nmajor: %ld\nminor: %ld\n"
+ s.open_count s.event_nr s.major s.minor;
+ Printf.printf "read_only: %b\n" s.read_only;
+ Printf.printf "\nTable:\n";
+ List.iter (fun (s,l,t,p) -> Printf.printf " %Ld %Ld %s %s\n" s l t p) s.targets;
+ let input = Unix.read ifd buf 0 10 in
+ Printf.printf "input=%d\n" input;
+ for i=0 to 2 do
+ Printf.printf "%d " (int_of_char buf.[i])
+ done;
+ let name=Printf.sprintf "/sys/block/dm-%ld/dev" minor in
+ Printf.printf "Got minor=%ld - looking for: %s\n" minor name;
+ let fd = Unix.openfile name [Unix.O_RDONLY] 0o000 in
+ let input = Unix.read fd buf 0 10 in
+ Printf.printf "input=%d\n" input;
+ for i=0 to 2 do
+ Printf.printf "%d " (int_of_char buf.[i])
+ done;
+ Printf.printf "\n";
+ Unix.close fd
+
+
+ (*List.iter (fun (a,b,c,d,e,f) -> Printf.printf "%d %d %Ld %Ld %s %s" a b c d e f) l; *)
+(* Camldm.remove name*)
+
+
--- /dev/null
+version = "@VERSION@"
+description = "Cdrom extension"
+archive(byte) = "cdrom.cma"
+archive(native) = "cdrom.cmxa"
--- /dev/null
+CC = gcc
+CFLAGS = -Wall -fPIC -O2 -I/opt/xensource/lib/ocaml
+OCAMLC = ocamlc -g
+OCAMLOPT = ocamlopt
+
+LDFLAGS = -cclib -L./
+
+DESTDIR ?= /
+VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0)
+OCAMLOPTFLAGS = -g -dtypes
+
+OCAMLABI := $(shell ocamlc -version)
+OCAMLLIBDIR := $(shell ocamlc -where)
+OCAMLDESTDIR ?= $(OCAMLLIBDIR)
+
+OBJS = cdrom
+INTF = $(foreach obj, $(OBJS),$(obj).cmi)
+LIBS = cdrom.cma cdrom.cmxa
+
+all: $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+cdrom.cmxa: libcdrom_stubs.a $(foreach obj,$(OBJS),$(obj).cmx)
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -a -o $@ -cclib -lcdrom_stubs $(foreach obj,$(OBJS),$(obj).cmx)
+
+cdrom.cma: $(foreach obj,$(OBJS),$(obj).cmo)
+ $(OCAMLC) -a -dllib dllcdrom_stubs.so -cclib -lcdrom_stubs -o $@ $(foreach obj,$(OBJS),$(obj).cmo)
+
+cdrom_stubs.a: cdrom_stubs.o
+ ocamlmklib -o cdrom_stubs $+
+
+libcdrom_stubs.a: cdrom_stubs.o
+ ar rcs $@ $+
+ ocamlmklib -o cdrom_stubs $+
+
+%.cmo: %.ml
+ $(OCAMLC) -c -o $@ $<
+
+%.cmi: %.mli
+ $(OCAMLC) -c -o $@ $<
+
+%.cmx: %.ml
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -c -o $@ $<
+
+%.o: %.c
+ $(CC) $(CFLAGS) -c -o $@ $<
+
+META: META.in
+ sed 's/@VERSION@/$(VERSION)/g' < $< > $@
+
+.PHONY: install
+install: $(LIBS) META
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore cdrom META $(INTF) $(LIBS) *.a *.so *.cmx
+
+.PHONY: uninstall
+uninstall:
+ ocamlfind remove cdrom
+
+clean:
+ rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS)
+
--- /dev/null
+
+type cdrom_drive_status =
+ | NO_INFO
+ | NO_DISC
+ | TRAY_OPEN
+ | DRIVE_NOT_READY
+ | DISC_OK
+
+let string_of_cdrom_drive_status = function
+ | NO_INFO -> "NO_INFO"
+ | NO_DISC -> "NO_DISC"
+ | TRAY_OPEN -> "TRAY_OPEN"
+ | DRIVE_NOT_READY -> "DRIVE_NOT_READY"
+ | DISC_OK -> "DISC_OK"
+
+type cdrom_disc_status =
+ | DISC_NO_INFO
+ | DISC_NO_DISC
+ | AUDIO
+ | DATA_1
+ | DATA_2
+ | XA_2_1
+ | XA_2_2
+ | MIXED
+
+let string_of_cdrom_disc_status = function
+ | DISC_NO_INFO -> "DISC_NO_INFO"
+ | DISC_NO_DISC -> "DISC_NO_DISC"
+ | AUDIO -> "AUDIO"
+ | DATA_1 -> "DATA_1"
+ | DATA_2 -> "DATA_2"
+ | XA_2_1 -> "XA_2_1"
+ | XA_2_2 -> "XA_2_2"
+ | MIXED -> "MIXED"
+
+external _query_cdrom_drive_status : Unix.file_descr -> cdrom_drive_status = "stub_CDROM_DRIVE_STATUS"
+external _query_cdrom_disc_status : Unix.file_descr -> cdrom_disc_status = "stub_CDROM_DISC_STATUS"
+external _query_cdrom_mcn : Unix.file_descr -> string = "stub_CDROM_GET_MCN"
+
+let with_cdrom (name: string) f =
+ let fd = Unix.openfile name [ Unix.O_RDONLY; Unix.O_NONBLOCK ] 0 in
+ try
+ let result = f fd in
+ Unix.close fd;
+ result
+ with e ->
+ Unix.close fd;
+ raise e
+
+let query_cdrom_status (name: string) : (cdrom_drive_status * cdrom_disc_status) =
+ with_cdrom name (fun fd ->
+ let status = _query_cdrom_drive_status fd in
+ let disc = _query_cdrom_disc_status fd in
+ status, disc
+ )
+
+let query_cdrom_drive_status (name: string) : cdrom_drive_status =
+ with_cdrom name _query_cdrom_drive_status
+
+let query_cdrom_mcn (name: string) : string = with_cdrom name _query_cdrom_mcn
+
--- /dev/null
+type cdrom_drive_status =
+ | NO_INFO
+ | NO_DISC
+ | TRAY_OPEN
+ | DRIVE_NOT_READY
+ | DISC_OK
+
+val string_of_cdrom_drive_status : cdrom_drive_status -> string
+
+type cdrom_disc_status =
+ | DISC_NO_INFO
+ | DISC_NO_DISC
+ | AUDIO
+ | DATA_1
+ | DATA_2
+ | XA_2_1
+ | XA_2_2
+ | MIXED
+
+val string_of_cdrom_disc_status : cdrom_disc_status -> string
+
+external _query_cdrom_drive_status : Unix.file_descr -> cdrom_drive_status
+ = "stub_CDROM_DRIVE_STATUS"
+external _query_cdrom_disc_status : Unix.file_descr -> cdrom_disc_status
+ = "stub_CDROM_DISC_STATUS"
+external _query_cdrom_mcn : Unix.file_descr -> string = "stub_CDROM_GET_MCN"
+
+val with_cdrom : string -> (Unix.file_descr -> 'a) -> 'a
+val query_cdrom_status : string -> cdrom_drive_status * cdrom_disc_status
+val query_cdrom_drive_status : string -> cdrom_drive_status
+val query_cdrom_mcn : string -> string
--- /dev/null
+/* Query CDROM info */
+#include <string.h>
+#include <errno.h>
+#include <stdio.h>
+#include <sys/ioctl.h>
+#include <linux/cdrom.h>
+
+static int CDROM_DRIVE_STATUS_list[] = {
+ CDS_NO_INFO,
+ CDS_NO_DISC,
+ CDS_TRAY_OPEN,
+ CDS_DRIVE_NOT_READY,
+ CDS_DISC_OK,
+};
+
+static int CDROM_DISC_STATUS_list[] = {
+ CDS_NO_INFO,
+ CDS_NO_DISC,
+
+ CDS_AUDIO,
+ CDS_DATA_1,
+ CDS_DATA_2,
+ CDS_XA_2_1,
+ CDS_XA_2_2,
+ CDS_MIXED,
+};
+
+#define make_ioctl_stub(X) \
+CAMLprim value stub_##X (value fd) \
+{ \
+ CAMLparam1 (fd); \
+ int result = -1; \
+ int i; \
+ int ok = 0; \
+ int c_fd = Int_val(fd); \
+ int c_res = ioctl(c_fd, X); \
+ \
+ if (c_res < 0) failwith_errno(); \
+ \
+ for (i = 0; i < sizeof(X##_list); i++){ \
+ if (X##_list[i] == c_res){ \
+ result = i; \
+ ok = 1; \
+ break; \
+ } \
+ } \
+ if (result < 0) caml_failwith("Failed to understand result of " #X " ioctl"); \
+ CAMLreturn(Val_int(result)); \
+}
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/custom.h>
+#include <caml/fail.h>
+#include <caml/callback.h>
+
+static void failwith_errno(void)
+{
+ char buf[256];
+ char buf2[280];
+ memset(buf, '\0', sizeof(buf));
+ strerror_r(errno, buf, sizeof(buf));
+ snprintf(buf2, sizeof(buf2), "errno: %d msg: %s", errno, buf);
+ caml_failwith(buf2);
+}
+
+make_ioctl_stub(CDROM_DRIVE_STATUS);
+make_ioctl_stub(CDROM_DISC_STATUS);
+
+CAMLprim value stub_CDROM_GET_MCN (value fd)
+{
+ CAMLparam1 (fd);
+ CAMLlocal1 (result);
+ struct cdrom_mcn mcn;
+ char *mcnptr;
+
+ int c_fd = Int_val(fd);
+ int c_res = ioctl(c_fd, CDROM_GET_MCN, &mcn);
+ if (c_res < 0) failwith_errno();
+
+ mcnptr = (char *) mcn.medium_catalog_number;
+ result = caml_copy_string(mcnptr);
+
+ CAMLreturn(result);
+}
--- /dev/null
+version = "@VERSION@"
+description = "Eventchn interface extension"
+archive(byte) = "eventchn.cma"
+archive(native) = "eventchn.cmxa"
--- /dev/null
+CC = gcc
+CFLAGS = -Wall -fPIC -O2 -I/opt/xensource/lib/ocaml -I$(XEN_ROOT)/usr/include
+OCAMLC = ocamlc -g
+OCAMLOPT = ocamlopt
+
+LDFLAGS = -cclib -L./
+
+DESTDIR ?= /
+VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0)
+OCAMLOPTFLAGS = -g -dtypes
+
+OCAMLABI := $(shell ocamlc -version)
+OCAMLLIBDIR := $(shell ocamlc -where)
+OCAMLDESTDIR ?= $(OCAMLLIBDIR)
+
+OBJS = eventchn
+INTF = $(foreach obj, $(OBJS),$(obj).cmi)
+LIBS = eventchn.cma eventchn.cmxa
+
+all: $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+eventchn.cmxa: libeventchn_stubs.a $(foreach obj,$(OBJS),$(obj).cmx)
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -a -o $@ -cclib -leventchn_stubs $(foreach obj,$(OBJS),$(obj).cmx)
+
+eventchn.cma: $(foreach obj,$(OBJS),$(obj).cmo)
+ $(OCAMLC) -a -dllib dlleventchn_stubs.so -cclib -leventchn_stubs -o $@ $(foreach obj,$(OBJS),$(obj).cmo)
+
+eventchn_stubs.a: eventchn_stubs.o
+ ocamlmklib -o eventchn_stubs $+
+
+libeventchn_stubs.a: eventchn_stubs.o
+ ar rcs $@ $+
+ ocamlmklib -o eventchn_stubs $+
+
+%.cmo: %.ml
+ $(OCAMLC) -c -o $@ $<
+
+%.cmi: %.mli
+ $(OCAMLC) -c -o $@ $<
+
+%.cmx: %.ml
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -c -o $@ $<
+
+%.o: %.c
+ $(CC) $(CFLAGS) -c -o $@ $<
+
+META: META.in
+ sed 's/@VERSION@/$(VERSION)/g' < $< > $@
+
+.PHONY: install
+install: $(LIBS) META
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore eventchn META $(INTF) $(LIBS) *.a *.so *.cmx
+
+.PHONY: uninstall
+uninstall:
+ ocamlfind remove eventchn
+
+clean:
+ rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS)
+
--- /dev/null
+(*
+ * Copyright (c) 2006-2007 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ *
+ * All rights reserved.
+ *)
+
+exception Error of string
+
+external init: unit -> Unix.file_descr = "stub_eventchn_init"
+external notify: Unix.file_descr -> int -> unit = "stub_eventchn_notify"
+external bind_interdomain: Unix.file_descr -> int -> int -> int = "stub_eventchn_bind_interdomain"
+external bind_virq: Unix.file_descr -> int = "stub_eventchn_bind_virq"
+external unbind: Unix.file_descr -> int -> unit = "stub_eventchn_unbind"
+external read_port: Unix.file_descr -> int = "stub_eventchn_read_port"
+external write_port: Unix.file_descr -> int -> unit = "stub_eventchn_write_port"
+
+let _ = Callback.register_exception "eventchn.error" (Error "register_callback")
--- /dev/null
+exception Error of string
+external init : unit -> Unix.file_descr = "stub_eventchn_init"
+external notify : Unix.file_descr -> int -> unit = "stub_eventchn_notify"
+external bind_interdomain : Unix.file_descr -> int -> int -> int
+ = "stub_eventchn_bind_interdomain"
+external bind_virq : Unix.file_descr -> int = "stub_eventchn_bind_virq"
+external unbind : Unix.file_descr -> int -> unit = "stub_eventchn_unbind"
+external read_port : Unix.file_descr -> int = "stub_eventchn_read_port"
+external write_port : Unix.file_descr -> int -> unit
+ = "stub_eventchn_write_port"
--- /dev/null
+/*
+ * Copyright (c) 2006-2007 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ *
+ * All rights reserved.
+ */
+
+#ifdef WITH_INJECTION_CAPABILITY
+#include "../fake/marshall.h"
+#include "../fake/using.h"
+
+#include <sys/types.h>
+#include <sys/socket.h>
+#include <sys/un.h>
+
+static int fake_eventchn_open(void)
+{
+ struct sockaddr_un remote;
+ char *s;
+ int fd, len;
+
+ s = getenv("XIU");
+ if (!s)
+ return -1;
+ snprintf(remote.sun_path, 256, "%s-ev", s);
+ remote.sun_family = AF_UNIX;
+ len = strlen(remote.sun_path) + sizeof(remote.sun_family);
+
+ fd = socket(AF_UNIX, SOCK_STREAM, 0);
+ if (fd == -1)
+ return -1;
+ if (connect(fd, (struct sockaddr *)&remote, len) != 0)
+ return -1;
+
+ return fd;
+}
+
+static int fake_eventchn_ioctl(int handle, int cmd, void *arg)
+{
+ switch (cmd) {
+ case IOCTL_EVTCHN_NOTIFY:
+ marshall_command(handle, "ioctl,notify,%d\n",
+ ((struct ioctl_evtchn_notify *) arg)->port);
+ return unmarshall_return(handle);
+ case IOCTL_EVTCHN_BIND_INTERDOMAIN:
+ marshall_command(handle, "ioctl,bind_interdomain,%d,%d\n",
+ ((struct ioctl_evtchn_bind_interdomain *) arg)->remote_domain,
+ ((struct ioctl_evtchn_bind_interdomain *) arg)->remote_port);
+ return unmarshall_return(handle);
+ case IOCTL_EVTCHN_BIND_VIRQ:
+ marshall_command(handle, "ioctl,bind_virq,%d\n",
+ ((struct ioctl_evtchn_bind_virq *) arg)->virq);
+ return unmarshall_return(handle);
+ case IOCTL_EVTCHN_UNBIND:
+ marshall_command(handle, "ioctl,unbind,%d\n",
+ ((struct ioctl_evtchn_unbind *) arg)->port);
+ return unmarshall_return(handle);
+ default:
+ return -EINVAL;
+ }
+}
+
+static int fake_eventchn_read_port(int handle, evtchn_port_t *port)
+{
+ int ret;
+
+ marshall_command(handle, "read\n");
+ ret = unmarshall_int(handle);
+ *port = ret;
+ return unmarshall_return(handle);
+}
+
+static int fake_eventchn_write_port(int handle, evtchn_port_t port)
+{
+ marshall_command(handle, "write,%d\n", port);
+ return unmarshall_return(handle);
+}
+
+#define pre_eventchn_open() if (using_injection()) return fake_eventchn_open();
+#define pre_eventchn_ioctl(h,c,a) if (using_injection()) return fake_eventchn_ioctl(h,c,a);
+#define pre_eventchn_read_port(h,p) if (using_injection()) return fake_eventchn_read_port(h,p);
+#define pre_eventchn_write_port(h,p) if (using_injection()) return fake_eventchn_write_port(h,p);
+#else
+#define pre_eventchn_open() do {} while(0);
+#define pre_eventchn_ioctl(h,c,a) do {} while(0);
+#define pre_eventchn_read_port(h,p) do {} while(0);
+#define pre_eventchn_write_port(h,p) do {} while(0);
+#endif
--- /dev/null
+/*
+ * Copyright (c) 2006-2007 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ *
+ * All rights reserved.
+ */
+
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+#include <unistd.h>
+#include <errno.h>
+#include <stdint.h>
+
+#include <sys/ioctl.h>
+
+#define __XEN_TOOLS__
+
+#include <xen/sysctl.h>
+
+#if XEN_SYSCTL_INTERFACE_VERSION < 4
+#include <xen/linux/evtchn.h>
+#else
+#include <xen/xen.h>
+#include <xen/sys/evtchn.h>
+#endif
+
+#include <xenctrl.h>
+
+#define CAML_NAME_SPACE
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/custom.h>
+#include <caml/callback.h>
+#include <caml/fail.h>
+
+#define EVENTCHN_PATH "/dev/xen/eventchn"
+#define EVENTCHN_MAJOR 10
+#define EVENTCHN_MINOR 63
+
+#define WITH_INJECTION_CAPABILITY
+#include "eventchn_injection.c"
+
+static int do_ioctl(int handle, int cmd, void *arg)
+{
+ pre_eventchn_ioctl(handle, cmd, arg);
+ return ioctl(handle, cmd, arg);
+}
+
+static int do_read_port(int handle, evtchn_port_t *port)
+{
+ pre_eventchn_read_port(handle, port);
+ return (read(handle, port, sizeof(evtchn_port_t)) != sizeof(evtchn_port_t));
+}
+
+static int do_write_port(int handle, evtchn_port_t port)
+{
+ pre_eventchn_write_port(handle, port);
+ return (write(handle, &port, sizeof(evtchn_port_t)) != sizeof(evtchn_port_t));
+}
+
+int eventchn_do_open(void)
+{
+ int fd;
+
+ pre_eventchn_open();
+
+ fd = open(EVENTCHN_PATH, O_RDWR);
+ if (fd == -1 && errno == ENOENT) {
+ mkdir("/dev/xen", 0640);
+ mknod(EVENTCHN_PATH, S_IFCHR | 0640, makedev(10, 63));
+ fd = open(EVENTCHN_PATH, O_RDWR);
+ }
+ return fd;
+}
+
+CAMLprim value stub_eventchn_init(value unit)
+{
+ CAMLparam1(unit);
+ int fd = eventchn_do_open();
+ if (fd == -1)
+ caml_failwith("open failed");
+ CAMLreturn(Val_int(fd));
+}
+
+CAMLprim value stub_eventchn_notify(value fd, value port)
+{
+ CAMLparam2(fd, port);
+ struct ioctl_evtchn_notify notify;
+ int rc;
+
+ notify.port = Int_val(port);
+ rc = do_ioctl(Int_val(fd), IOCTL_EVTCHN_NOTIFY, ¬ify);
+ if (rc == -1)
+ caml_failwith("ioctl notify failed");
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_eventchn_bind_interdomain(value fd, value domid,
+ value remote_port)
+{
+ CAMLparam3(fd, domid, remote_port);
+ CAMLlocal1(port);
+ struct ioctl_evtchn_bind_interdomain bind;
+ int rc;
+
+ bind.remote_domain = Int_val(domid);
+ bind.remote_port = Int_val(remote_port);
+ rc = do_ioctl(Int_val(fd), IOCTL_EVTCHN_BIND_INTERDOMAIN, &bind);
+ if (rc == -1)
+ caml_failwith("ioctl bind_interdomain failed");
+ port = Val_int(rc);
+
+ CAMLreturn(port);
+}
+
+CAMLprim value stub_eventchn_bind_virq(value fd)
+{
+ CAMLparam1(fd);
+ CAMLlocal1(port);
+ struct ioctl_evtchn_bind_virq bind;
+ int rc;
+
+ bind.virq = VIRQ_DOM_EXC;
+ rc = do_ioctl(Int_val(fd), IOCTL_EVTCHN_BIND_VIRQ, &bind);
+ if (rc == -1)
+ caml_failwith("ioctl bind_virq failed");
+ port = Val_int(rc);
+
+ CAMLreturn(port);
+}
+
+CAMLprim value stub_eventchn_unbind(value fd, value port)
+{
+ CAMLparam2(fd, port);
+ struct ioctl_evtchn_unbind unbind;
+ int rc;
+
+ unbind.port = Int_val(port);
+ rc = do_ioctl(Int_val(fd), IOCTL_EVTCHN_UNBIND, &unbind);
+ if (rc == -1)
+ caml_failwith("ioctl unbind failed");
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_eventchn_read_port(value fd)
+{
+ CAMLparam1(fd);
+ CAMLlocal1(result);
+ evtchn_port_t port;
+
+ if (do_read_port(Int_val(fd), &port))
+ caml_failwith("read port failed");
+ result = Val_int(port);
+
+ CAMLreturn(result);
+}
+
+CAMLprim value stub_eventchn_write_port(value fd, value _port)
+{
+ CAMLparam2(fd, _port);
+ evtchn_port_t port;
+
+ port = Int_val(_port);
+ if (do_write_port(Int_val(fd), port))
+ caml_failwith("write port failed");
+ CAMLreturn(Val_unit);
+}
--- /dev/null
+/*
+ * Copyright (c) 2007 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ */
+
+#ifndef FAKE_MARSHALL_H
+#define FAKE_MARSHALL_H
+
+#include <string.h>
+#include <stdarg.h>
+#include <stdio.h>
+
+static int marshall_command(int handle, const char *fmt, ...)
+{
+ va_list ap;
+ char buf[256];
+ int ret;
+
+ va_start(ap, fmt);
+ ret = vsnprintf(buf, 256, fmt, ap);
+ va_end(ap);
+
+ if (ret > 255)
+ return -1;
+ write(handle, buf, ret);
+ return 0;
+}
+
+static char ** string_split(const char *s, const char c)
+{
+ int found, i;
+ char **ret;
+ char *end;
+
+ for (found = i = 0; s[i]; i++)
+ if (s[i] == c) found++;
+ ret = calloc(found + 2, sizeof(char *));
+ if (!ret)
+ return NULL;
+ for (i = 0; i < found + 1; i++) {
+ end = strchr(s, c);
+ if (!end) {
+ ret[i] = strdup(s);
+ break;
+ }
+
+ ret[i] = strndup(s, end - s);
+ s = end + 1;
+ }
+ return ret;
+}
+
+static void string_split_free(char **ss)
+{
+ int i;
+ for (i = 0; ss[i] != NULL; i++)
+ free(ss[i]);
+ free(ss);
+}
+
+static int get_line(int handle, char *buf)
+{
+ int offset = 0;
+ memset(buf, '\0', 256);
+ while (1) {
+ int r = read(handle, buf + offset, 1);
+ if (r == -1 || r == 0) break;
+ if (buf[offset] == '\n')
+ break;
+ else {
+ if (offset >= 255)
+ break;
+ else
+ offset += 1;
+ }
+ }
+ return offset;
+}
+
+
+static int64_t unmarshall_int64(int handle)
+{
+ char buf[256];
+ int negative;
+ int64_t ret;
+
+ ret = get_line(handle, buf);
+ if (ret == 0)
+ return -EBADF;
+ negative = (buf[0] == '-');
+ ret = atoll(buf + (negative ? 1 : 0));
+ return (negative ? -ret : ret);
+}
+
+static int unmarshall_int(int handle)
+{
+ return (uint32_t) unmarshall_int64(handle);
+}
+
+static int parse_uuid(char *s, int uuid[])
+{
+ #define UUID_FMT "%02x%02x%02x%02x%02x%02x%02x%02x%02x%02x%02x%02x%02x%02x%02x%02x"
+ sscanf(s, UUID_FMT, uuid + 0, uuid + 1, uuid + 2, uuid + 3,
+ uuid + 4, uuid + 5, uuid + 6, uuid + 7,
+ uuid + 8, uuid + 9, uuid + 10, uuid + 11,
+ uuid + 12, uuid + 13, uuid + 14, uuid + 15);
+ return 0;
+}
+
+static char **unmarshall_multiple(int handle)
+{
+ char buf[256];
+ int ret;
+
+ ret = get_line(handle, buf);
+ if (ret == 0)
+ return NULL;
+ return string_split(buf, ',');
+}
+
+static int unmarshall_return(int handle)
+{
+ int ret;
+ ret = unmarshall_int(handle);
+ if (ret < 0)
+ errno = -ret;
+ return ret;
+}
+
+#endif /* !FAKE_MARSHALL_H */
--- /dev/null
+/*
+ * Copyright (c) 2007 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ *
+ * All rights reserved.
+ */
+#ifndef FAKE_USING_H
+#define FAKE_USING_H
+
+static int using_injection(void)
+{
+ return (getenv("XIU") != NULL);
+}
+
+#endif /* !FAKE_USING_H */
--- /dev/null
+version = "@VERSION@"
+description = "Log - logging library"
+archive(byte) = "log.cma"
+archive(native) = "log.cmxa"
--- /dev/null
+CC = gcc
+CFLAGS = -Wall -fPIC -O2 -I/opt/xensource/lib/ocaml
+OCAMLC = ocamlc
+OCAMLOPT = ocamlopt
+
+LDFLAGS = -cclib -L./
+
+DESTDIR ?= /
+VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0)
+OCAMLCFLAGS = -g -dtypes -thread -I ../stdext
+OCAMLOPTFLAGS = -g -dtypes -thread -I ../stdext
+
+
+OCAMLABI := $(shell ocamlc -version)
+OCAMLLIBDIR := $(shell ocamlc -where)
+OCAMLDESTDIR ?= $(OCAMLLIBDIR)
+
+OBJS = syslog log logs
+INTF = log.cmi logs.cmi syslog.cmi
+LIBS = log.cma log.cmxa
+
+all: $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+log.cmxa: libsyslog_stubs.a $(foreach obj,$(OBJS),$(obj).cmx)
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -a -o $@ -cclib -lsyslog_stubs $(foreach obj,$(OBJS),$(obj).cmx)
+
+log.cma: $(foreach obj,$(OBJS),$(obj).cmo)
+ $(OCAMLC) -a -dllib dllsyslog_stubs.so -cclib -lsyslog_stubs -o $@ $(foreach obj,$(OBJS),$(obj).cmo)
+
+syslog_stubs.a: syslog_stubs.o
+ ocamlmklib -o syslog_stubs $+
+
+libsyslog_stubs.a: syslog_stubs.o
+ ar rcs $@ $+
+ ocamlmklib -o syslog_stubs $+
+
+%.cmo: %.ml
+ $(OCAMLC) -c $(OCAMLCFLAGS) -o $@ $<
+
+%.cmi: %.mli
+ $(OCAMLC) -c $(OCAMLCFLAGS) -o $@ $<
+
+%.cmx: %.ml
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -c -o $@ $<
+
+%.o: %.c
+ $(CC) $(CFLAGS) -c -o $@ $<
+
+logs.mli : logs.ml
+ $(OCAMLC) -i $(OCAMLCFLAGS) $< > $@
+
+syslog.mli : syslog.ml
+ $(OCAMLC) -i $< > $@
+
+META: META.in
+ sed 's/@VERSION@/$(VERSION)/g' < $< > $@
+
+#dependency:
+log.cmo: syslog.cmo log.cmi
+log.cmx: syslog.cmx log.cmi
+logs.cmo: log.cmi
+logs.cmx: log.cmx
+
+.PHONY: install
+install: $(LIBS) META
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore log META $(INTF) $(LIBS) *.a *.so *.cmx
+
+.PHONY: uninstall
+uninstall:
+ ocamlfind remove log
+
+clean:
+ rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS)
--- /dev/null
+(*
+ * Copyright (C) 2006 XenSource LTD
+ * Author: Vincent Hanquez <vincent@xensource.com>
+ *)
+
+open Printf
+open Threadext
+
+exception Unknown_level of string
+
+type stream_type = Stderr | Stdout | File of string
+
+type stream_log = {
+ ty : stream_type;
+ channel : out_channel option ref;
+ mutex : Mutex.t;
+}
+
+type level = Debug | Info | Warn | Error
+
+type output =
+ | Stream of stream_log
+ | String of string list ref
+ | Syslog of string
+ | Nil
+
+let int_of_level l =
+ match l with Debug -> 0 | Info -> 1 | Warn -> 2 | Error -> 3
+
+let string_of_level l =
+ match l with Debug -> "debug" | Info -> "info"
+ | Warn -> "warn" | Error -> "error"
+
+let level_of_string s =
+ match s with
+ | "debug" -> Debug
+ | "info" -> Info
+ | "warn" -> Warn
+ | "error" -> Error
+ | _ -> raise (Unknown_level s)
+
+let mkdir_safe dir perm =
+ try Unix.mkdir dir perm with _ -> ()
+
+let mkdir_rec dir perm =
+ let rec p_mkdir dir =
+ let p_name = Filename.dirname dir in
+ if p_name = "/" || p_name = "." then
+ ()
+ else (
+ p_mkdir p_name;
+ mkdir_safe dir perm
+ ) in
+ p_mkdir dir
+
+type t = { output: output; mutable level: level; }
+
+let make output level = { output = output; level = level; }
+
+let make_stream ty channel =
+ Stream {ty=ty; channel=ref channel; mutex=Mutex.create ()}
+
+(** open a syslog logger *)
+let opensyslog k level =
+ make (Syslog k) level
+
+(** open a stderr logger *)
+let openerr level =
+ if (Unix.stat "/dev/stderr").Unix.st_kind <> Unix.S_CHR then
+ failwith "/dev/stderr is not a valid character device";
+ make (make_stream Stderr (Some (open_out "/dev/stderr"))) level
+
+let openout level =
+ if (Unix.stat "/dev/stdout").Unix.st_kind <> Unix.S_CHR then
+ failwith "/dev/stdout is not a valid character device";
+ make (make_stream Stdout (Some (open_out "/dev/stdout"))) level
+
+
+(** open a stream logger - returning the channel. *)
+(* This needs to be separated from 'openfile' so we can reopen later *)
+let doopenfile filename =
+ if Filename.is_relative filename then
+ None
+ else (
+ try
+ mkdir_rec (Filename.dirname filename) 0o700;
+ Some (open_out_gen [ Open_append; Open_creat ] 0o600 filename)
+ with _ -> None
+ )
+
+(** open a stream logger - returning the output type *)
+let openfile filename level =
+ make (make_stream (File filename) (doopenfile filename)) level
+
+(** open a nil logger *)
+let opennil () =
+ make Nil Error
+
+(** open a string logger *)
+let openstring level =
+ make (String (ref [""])) level
+
+(** try to reopen a logger *)
+let reopen t =
+ match t.output with
+ | Nil -> t
+ | Syslog k -> Syslog.close (); opensyslog k t.level
+ | Stream s -> Mutex.execute s.mutex
+ (fun () ->
+ match (s.ty,!(s.channel)) with
+ | (File filename, Some c) -> close_out c; s.channel := (try doopenfile filename with _ -> None); t
+ | _ -> t)
+ | String _ -> t
+
+(** close a logger *)
+let close t =
+ match t.output with
+ | Nil -> ()
+ | Syslog k -> Syslog.close ();
+ | Stream s ->
+ Mutex.execute s.mutex (fun () ->
+ match !(s.channel) with
+ | Some c -> close_out c; s.channel := None
+ | None -> ())
+ | String _ -> ()
+
+(** create a string representating the parameters of the logger *)
+let string_of_logger t =
+ match t.output with
+ | Nil -> "nil"
+ | Syslog k -> sprintf "syslog:%s" k
+ | String _ -> "string"
+ | Stream s ->
+ begin
+ match s.ty with
+ | File f -> sprintf "file:%s" f
+ | Stderr -> "stderr"
+ | Stdout -> "stdout"
+ end
+
+(** parse a string to a logger *)
+let logger_of_string s : t =
+ match s with
+ | "nil" -> opennil ()
+ | "stderr" -> openerr Debug
+ | "stdout" -> openout Debug
+ | "string" -> openstring Debug
+ | _ ->
+ let split_in_2 s =
+ try
+ let i = String.index s ':' in
+ String.sub s 0 (i),
+ String.sub s (i + 1) (String.length s - i - 1)
+ with _ ->
+ failwith "logger format error: expecting string:string"
+ in
+ let k, s = split_in_2 s in
+ match k with
+ | "syslog" -> opensyslog s Debug
+ | "file" -> openfile s Debug
+ | _ -> failwith "unknown logger type"
+
+let validate s =
+ match s with
+ | "nil" -> ()
+ | "stderr" -> ()
+ | "stdout" -> ()
+ | "string" -> ()
+ | _ ->
+ let split_in_2 s =
+ try
+ let i = String.index s ':' in
+ String.sub s 0 (i),
+ String.sub s (i + 1) (String.length s - i - 1)
+ with _ ->
+ failwith "logger format error: expecting string:string"
+ in
+ let k, s = split_in_2 s in
+ match k with
+ | "syslog" -> ()
+ | "file" -> (
+ try
+ let st = Unix.stat s in
+ if st.Unix.st_kind <> Unix.S_REG then
+ failwith "logger file is a directory";
+ ()
+ with Unix.Unix_error (Unix.ENOENT, _, _) -> ()
+ )
+ | _ -> failwith "unknown logger"
+
+(** change a logger level to level *)
+let set t level = t.level <- level
+
+let gettimestring () =
+ let time = Unix.gettimeofday () in
+ let tm = Unix.localtime time in
+ let msec = time -. (floor time) in
+ sprintf "%d%.2d%.2d %.2d:%.2d:%.2d.%.3d|" (1900 + tm.Unix.tm_year)
+ (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
+ tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
+ (int_of_float (1000.0 *. msec))
+
+(*let extra_hook = ref (fun x -> x)*)
+
+let filesize = ref 0
+let mutex = Mutex.create ()
+
+let output t ?(key="") ?(extra="") priority (message: string) =
+ let construct_string withtime =
+ (*let key = if key = "" then [] else [ key ] in
+ let extra = if extra = "" then [] else [ extra ] in
+ let items =
+ (if withtime then [ gettimestring () ] else [])
+ @ [ sprintf "%5s" (string_of_level priority) ] @ extra @ key @ [ message ] in
+(* let items = !extra_hook items in*)
+ String.concat " " items*)
+ Printf.sprintf "[%s%.5s|%s] %s"
+ (if withtime then gettimestring () else "") (string_of_level priority) extra message
+ in
+ (* Keep track of how much we write out to streams, so that we can *)
+ (* log-rotate at appropriate times *)
+ let write_to_stream stream =
+ let string = (construct_string true) in
+ Mutex.execute mutex
+ (fun () -> filesize := !filesize + (String.length string));
+ fprintf stream "%s\n%!" string;
+ in
+
+ if String.length message > 0 then
+ match t.output with
+ | Syslog k ->
+ let sys_prio = match priority with
+ | Debug -> Syslog.Debug
+ | Info -> Syslog.Info
+ | Warn -> Syslog.Warning
+ | Error -> Syslog.Err in
+ Syslog.log Syslog.Daemon sys_prio ((construct_string false) ^ "\n")
+ | Stream s -> Mutex.execute s.mutex
+ (fun () ->
+ match !(s.channel) with
+ | Some c -> write_to_stream c
+ | None -> ())
+ | Nil -> ()
+ | String s -> (s := (construct_string true)::!s)
+
+let log t level (fmt: ('a, unit, string, unit) format4): 'a =
+ let b = (int_of_level t.level) <= (int_of_level level) in
+ (* ksprintf is the preferred name for kprintf, but the former
+ * is not available in OCaml 3.08.3 *)
+ Printf.kprintf (if b then output t level else (fun _ -> ())) fmt
+
+let debug t (fmt: ('a , unit, string, unit) format4) = log t Debug fmt
+let info t (fmt: ('a , unit, string, unit) format4) = log t Info fmt
+let warn t (fmt: ('a , unit, string, unit) format4) = log t Warn fmt
+let error t (fmt: ('a , unit, string, unit) format4) = log t Error fmt
--- /dev/null
+exception Unknown_level of string
+type level = Debug | Info | Warn | Error
+
+type stream_type = Stderr | Stdout | File of string
+type stream_log = {
+ ty : stream_type;
+ channel : out_channel option ref;
+ mutex : Mutex.t;
+}
+type output =
+ Stream of stream_log
+ | String of string list ref
+ | Syslog of string
+ | Nil
+val int_of_level : level -> int
+val string_of_level : level -> string
+val level_of_string : string -> level
+val mkdir_safe : string -> Unix.file_perm -> unit
+val mkdir_rec : string -> Unix.file_perm -> unit
+type t = { output : output; mutable level : level; }
+val make : output -> level -> t
+val opensyslog : string -> level -> t
+val openerr : level -> t
+val openout : level -> t
+val openfile : string -> level -> t
+val opennil : unit -> t
+val openstring : level -> t
+val reopen : t -> t
+val close : t -> unit
+val string_of_logger : t -> string
+val logger_of_string : string -> t
+val validate : string -> unit
+val set : t -> level -> unit
+val gettimestring : unit -> string
+val filesize : int ref
+val mutex : Mutex.t
+val output : t -> ?key:string -> ?extra:string -> level -> string -> unit
+val log : t -> level -> ('a, unit, string, unit) format4 -> 'a
+val debug : t -> ('a, unit, string, unit) format4 -> 'a
+val info : t -> ('a, unit, string, unit) format4 -> 'a
+val warn : t -> ('a, unit, string, unit) format4 -> 'a
+val error : t -> ('a, unit, string, unit) format4 -> 'a
--- /dev/null
+(*
+ * Copyright (C) 2006-2007 XenSource LTD
+ * Author: Vincent Hanquez <vincent@xensource.com>
+ *)
+
+type keylogger =
+{
+ mutable debug: string list;
+ mutable info: string list;
+ mutable warn: string list;
+ mutable error: string list;
+ no_default: bool;
+}
+
+(* map all logger strings into a logger *)
+let __all_loggers = Hashtbl.create 10
+
+(* default logger that everything that doesn't have a key in __lop_mapping get send *)
+let __default_logger = { debug = []; info = []; warn = []; error = []; no_default = false }
+
+(*
+ * This describe the mapping between a name to a keylogger.
+ * a keylogger contains a list of logger string per level of debugging.
+ * Example: "xenops", debug -> [ "stderr"; "/var/log/xensource.log" ]
+ * "xapi", error -> []
+ * "xapi", debug -> [ "/var/log/xensource.log" ]
+ * "xenops", info -> [ "syslog" ]
+ *)
+let __log_mapping = Hashtbl.create 32
+
+let get_or_open logstring =
+ if Hashtbl.mem __all_loggers logstring then
+ Hashtbl.find __all_loggers logstring
+ else
+ let t = Log.logger_of_string logstring in
+ Hashtbl.add __all_loggers logstring t;
+ t
+
+(** create a mapping entry for the key "name".
+ * all log level of key "name" default to "logger" logger.
+ * a sensible default is put "nil" as a logger and reopen a specific level to
+ * the logger you want to.
+ *)
+let add key logger =
+ let kl = {
+ debug = logger;
+ info = logger;
+ warn = logger;
+ error = logger;
+ no_default = false;
+ } in
+ Hashtbl.add __log_mapping key kl
+
+let get_by_level keylog level =
+ match level with
+ | Log.Debug -> keylog.debug
+ | Log.Info -> keylog.info
+ | Log.Warn -> keylog.warn
+ | Log.Error -> keylog.error
+
+let set_by_level keylog level logger =
+ match level with
+ | Log.Debug -> keylog.debug <- logger
+ | Log.Info -> keylog.info <- logger
+ | Log.Warn -> keylog.warn <- logger
+ | Log.Error -> keylog.error <- logger
+
+(** set a specific key|level to the logger "logger" *)
+let set key level logger =
+ if not (Hashtbl.mem __log_mapping key) then
+ add key [];
+
+ let keylog = Hashtbl.find __log_mapping key in
+ set_by_level keylog level logger
+
+(** set default logger *)
+let set_default level logger =
+ set_by_level __default_logger level logger
+
+(** append a logger to the list *)
+let append key level logger =
+ if not (Hashtbl.mem __log_mapping key) then
+ add key [];
+ let keylog = Hashtbl.find __log_mapping key in
+ let loggers = get_by_level keylog level in
+ set_by_level keylog level (loggers @ [ logger ])
+
+(** append a logger to the default list *)
+let append_default level logger =
+ let loggers = get_by_level __default_logger level in
+ set_by_level __default_logger level (loggers @ [ logger ])
+
+(** reopen all logger open *)
+let reopen () =
+ Hashtbl.iter (fun k v ->
+ Hashtbl.replace __all_loggers k (Log.reopen v)) __all_loggers
+
+(** reclaim close all logger open that are not use by any other keys *)
+let reclaim () =
+ let list_sort_uniq l =
+ let oldprev = ref "" and prev = ref "" in
+ List.fold_left (fun a k ->
+ oldprev := !prev;
+ prev := k;
+ if k = !oldprev then a else k :: a) []
+ (List.sort compare l)
+ in
+ let flatten_keylogger v =
+ list_sort_uniq (v.debug @ v.info @ v.warn @ v.error) in
+ let oldkeys = Hashtbl.fold (fun k v a -> k :: a) __all_loggers [] in
+ let usedkeys = Hashtbl.fold (fun k v a ->
+ (flatten_keylogger v) @ a)
+ __log_mapping (flatten_keylogger __default_logger) in
+ let usedkeys = list_sort_uniq usedkeys in
+
+ List.iter (fun k ->
+ if not (List.mem k usedkeys) then (
+ begin try
+ Log.close (Hashtbl.find __all_loggers k)
+ with
+ Not_found -> ()
+ end;
+ Hashtbl.remove __all_loggers k
+ )) oldkeys
+
+(** clear a specific key|level *)
+let clear key level =
+ try
+ let keylog = Hashtbl.find __log_mapping key in
+ set_by_level keylog level [];
+ reclaim ()
+ with Not_found ->
+ ()
+
+(** clear a specific default level *)
+let clear_default level =
+ set_default level [];
+ reclaim ()
+
+(** reset all the loggers to the specified logger *)
+let reset_all logger =
+ Hashtbl.clear __log_mapping;
+ set_default Log.Debug logger;
+ set_default Log.Warn logger;
+ set_default Log.Error logger;
+ set_default Log.Info logger;
+ reclaim ()
+
+(** log a fmt message to the key|level logger specified in the log mapping.
+ * if the logger doesn't exist, assume nil logger.
+ *)
+let log key level ?(extra="") (fmt: ('a, unit, string, unit) format4): 'a =
+ let keylog =
+ if Hashtbl.mem __log_mapping key then
+ let keylog = Hashtbl.find __log_mapping key in
+ if keylog.no_default = false &&
+ get_by_level keylog level = [] then
+ __default_logger
+ else
+ keylog
+ else
+ __default_logger in
+ let loggers = get_by_level keylog level in
+ match loggers with
+ | [] -> Printf.kprintf ignore fmt
+ | _ ->
+ let l = List.fold_left (fun acc logger ->
+ try get_or_open logger :: acc
+ with _ -> acc
+ ) [] loggers in
+ let l = List.rev l in
+
+ (* ksprintf is the preferred name for kprintf, but the former
+ * is not available in OCaml 3.08.3 *)
+ Printf.kprintf (fun s ->
+ List.iter (fun t -> Log.output t ~key ~extra level s) l) fmt
+
+(* define some convenience functions *)
+let debug t ?extra (fmt: ('a , unit, string, unit) format4) =
+ log t Log.Debug ?extra fmt
+let info t ?extra (fmt: ('a , unit, string, unit) format4) =
+ log t Log.Info ?extra fmt
+let warn t ?extra (fmt: ('a , unit, string, unit) format4) =
+ log t Log.Warn ?extra fmt
+let error t ?extra (fmt: ('a , unit, string, unit) format4) =
+ log t Log.Error ?extra fmt
--- /dev/null
+(*
+ * Copyright (C) 2006 XenSource Ltd.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ *)
+
+type level = Emerg | Alert | Crit | Err | Warning | Notice | Info | Debug
+type options = Cons | Ndelay | Nowait | Odelay | Perror | Pid
+type facility = Auth | Authpriv | Cron | Daemon | Ftp | Kern
+ | Local0 | Local1 | Local2 | Local3
+ | Local4 | Local5 | Local6 | Local7
+ | Lpr | Mail | News | Syslog | User | Uucp
+
+(* external init : string -> options list -> facility -> unit = "stub_openlog" *)
+external log : facility -> level -> string -> unit = "stub_syslog"
+external close : unit -> unit = "stub_closelog"
--- /dev/null
+/*
+ * Copyright (C) 2006 XenSource Ltd.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ */
+
+#include <syslog.h>
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/custom.h>
+
+static int __syslog_level_table[] = {
+ LOG_EMERG, LOG_ALERT, LOG_CRIT, LOG_ERR, LOG_WARNING,
+ LOG_NOTICE, LOG_INFO, LOG_DEBUG
+};
+
+static int __syslog_options_table[] = {
+ LOG_CONS, LOG_NDELAY, LOG_NOWAIT, LOG_ODELAY, LOG_PERROR, LOG_PID
+};
+
+static int __syslog_facility_table[] = {
+ LOG_AUTH, LOG_AUTHPRIV, LOG_CRON, LOG_DAEMON, LOG_FTP, LOG_KERN,
+ LOG_LOCAL0, LOG_LOCAL1, LOG_LOCAL2, LOG_LOCAL3,
+ LOG_LOCAL4, LOG_LOCAL5, LOG_LOCAL6, LOG_LOCAL7,
+ LOG_LPR | LOG_MAIL | LOG_NEWS | LOG_SYSLOG | LOG_USER | LOG_UUCP
+};
+
+/* According to the openlog manpage the 'openlog' call may take a reference
+ to the 'ident' string and keep it long-term. This means we cannot just pass in
+ an ocaml string which is under the control of the GC. Since we aren't actually
+ calling this function we can just comment it out for the time-being. */
+/*
+value stub_openlog(value ident, value option, value facility)
+{
+ CAMLparam3(ident, option, facility);
+ int c_option;
+ int c_facility;
+
+ c_option = caml_convert_flag_list(option, __syslog_options_table);
+ c_facility = __syslog_facility_table[Int_val(facility)];
+ openlog(String_val(ident), c_option, c_facility);
+ CAMLreturn(Val_unit);
+}
+*/
+
+value stub_syslog(value facility, value level, value msg)
+{
+ CAMLparam3(facility, level, msg);
+ int c_facility;
+
+ c_facility = __syslog_facility_table[Int_val(facility)]
+ | __syslog_level_table[Int_val(level)];
+ syslog(c_facility, "%s", String_val(msg));
+ CAMLreturn(Val_unit);
+}
+
+value stub_closelog(value unit)
+{
+ CAMLparam1(unit);
+ closelog();
+ CAMLreturn(Val_unit);
+}
--- /dev/null
+version = "@VERSION@"
+description = "Mmap interface extension"
+archive(byte) = "mmap.cma"
+archive(native) = "mmap.cmxa"
--- /dev/null
+CC = gcc
+CFLAGS = -Wall -fPIC -O2 -I/opt/xensource/lib/ocaml
+OCAMLC = ocamlc -g
+OCAMLOPT = ocamlopt
+
+LDFLAGS = -cclib -L./
+
+DESTDIR ?= /
+VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0)
+OCAMLOPTFLAGS = -g -dtypes
+
+OCAMLABI := $(shell ocamlc -version)
+OCAMLLIBDIR := $(shell ocamlc -where)
+OCAMLDESTDIR ?= $(OCAMLLIBDIR)
+
+OBJS = mmap
+INTF = $(foreach obj, $(OBJS),$(obj).cmi)
+LIBS = mmap.cma mmap.cmxa
+
+all: $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+mmap.cmxa: libmmap_stubs.a $(foreach obj,$(OBJS),$(obj).cmx)
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -a -o $@ -cclib -lmmap_stubs $(foreach obj,$(OBJS),$(obj).cmx)
+
+mmap.cma: $(foreach obj,$(OBJS),$(obj).cmo)
+ $(OCAMLC) -a -dllib dllmmap_stubs.so -cclib -lmmap_stubs -o $@ $(foreach obj,$(OBJS),$(obj).cmo)
+
+mmap_stubs.a: mmap_stubs.o
+ ocamlmklib -o mmap_stubs $+
+
+libmmap_stubs.a: mmap_stubs.o
+ ar rcs $@ $+
+ ocamlmklib -o mmap_stubs $+
+
+%.cmo: %.ml
+ $(OCAMLC) -c -o $@ $<
+
+%.cmi: %.mli
+ $(OCAMLC) -c -o $@ $<
+
+%.cmx: %.ml
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -c -o $@ $<
+
+%.o: %.c
+ $(CC) $(CFLAGS) -c -o $@ $<
+
+META: META.in
+ sed 's/@VERSION@/$(VERSION)/g' < $< > $@
+
+.PHONY: install
+install: $(LIBS) META
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore mmap META $(INTF) $(LIBS) *.a *.so *.cmx
+
+.PHONY: uninstall
+uninstall:
+ ocamlfind remove mmap
+
+clean:
+ rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS)
+
--- /dev/null
+(*
+ * Copyright (c) 2006 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ *
+ * All rights reserved.
+ *)
+
+type mmap_interface
+
+type mmap_prot_flag = RDONLY | WRONLY | RDWR
+type mmap_map_flag = SHARED | PRIVATE
+
+(* mmap: fd -> prot_flag -> map_flag -> length -> offset -> interface *)
+external mmap: Unix.file_descr -> mmap_prot_flag -> mmap_map_flag
+ -> int -> int -> mmap_interface = "stub_mmap_init"
+external unmap: mmap_interface -> unit = "stub_mmap_final"
+(* read: interface -> start -> length -> data *)
+external read: mmap_interface -> int -> int -> string = "stub_mmap_read"
+(* write: interface -> data -> start -> length -> unit *)
+external write: mmap_interface -> string -> int -> int -> unit = "stub_mmap_write"
+(* getpagesize: unit -> size of page *)
+external getpagesize: unit -> int = "stub_mmap_getpagesize"
--- /dev/null
+type mmap_interface
+type mmap_prot_flag = RDONLY | WRONLY | RDWR
+type mmap_map_flag = SHARED | PRIVATE
+
+external mmap : Unix.file_descr -> mmap_prot_flag -> mmap_map_flag -> int -> int
+ -> mmap_interface = "stub_mmap_init"
+external unmap : mmap_interface -> unit = "stub_mmap_final"
+external read : mmap_interface -> int -> int -> string = "stub_mmap_read"
+external write : mmap_interface -> string -> int -> int -> unit
+ = "stub_mmap_write"
+
+external getpagesize : unit -> int = "stub_mmap_getpagesize"
--- /dev/null
+/**
+ * Copyright (c) 2006 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ *
+ * All rights reserved.
+ */
+
+#include <unistd.h>
+#include <stdlib.h>
+#include <sys/mman.h>
+#include <string.h>
+#include <errno.h>
+#include "mmap_stubs.h"
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/custom.h>
+#include <caml/fail.h>
+#include <caml/callback.h>
+
+#define GET_C_STRUCT(a) ((struct mmap_interface *) a)
+
+static int mmap_interface_init(struct mmap_interface *intf,
+ int fd, int pflag, int mflag,
+ int len, int offset)
+{
+ intf->len = len;
+ intf->addr = mmap(NULL, len, pflag, mflag, fd, offset);
+ return (intf->addr == MAP_FAILED) ? errno : 0;
+}
+
+CAMLprim value stub_mmap_init(value fd, value pflag, value mflag,
+ value len, value offset)
+{
+ CAMLparam5(fd, pflag, mflag, len, offset);
+ CAMLlocal1(result);
+ int c_pflag, c_mflag;
+
+ switch (Int_val(pflag)) {
+ case 0: c_pflag = PROT_READ; break;
+ case 1: c_pflag = PROT_WRITE; break;
+ case 2: c_pflag = PROT_READ|PROT_WRITE; break;
+ default: caml_invalid_argument("protectiontype");
+ }
+
+ switch (Int_val(mflag)) {
+ case 0: c_mflag = MAP_SHARED; break;
+ case 1: c_mflag = MAP_PRIVATE; break;
+ default: caml_invalid_argument("maptype");
+ }
+
+ result = caml_alloc(sizeof(struct mmap_interface), Abstract_tag);
+
+ if (mmap_interface_init(GET_C_STRUCT(result), Int_val(fd),
+ c_pflag, c_mflag,
+ Int_val(len), Int_val(offset)))
+ caml_failwith("mmap");
+ CAMLreturn(result);
+}
+
+CAMLprim value stub_mmap_final(value interface)
+{
+ CAMLparam1(interface);
+ struct mmap_interface *intf;
+
+ intf = GET_C_STRUCT(interface);
+ if (intf->addr != MAP_FAILED)
+ munmap(intf->addr, intf->len);
+ intf->addr = MAP_FAILED;
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_mmap_read(value interface, value start, value len)
+{
+ CAMLparam3(interface, start, len);
+ CAMLlocal1(data);
+ struct mmap_interface *intf;
+ int c_start;
+ int c_len;
+
+ c_start = Int_val(start);
+ c_len = Int_val(len);
+ intf = GET_C_STRUCT(interface);
+
+ if (c_start > intf->len)
+ caml_invalid_argument("start invalid");
+ if (c_start + c_len > intf->len)
+ caml_invalid_argument("len invalid");
+
+ data = caml_alloc_string(c_len);
+ memcpy((char *) data, intf->addr + c_start, c_len);
+
+ CAMLreturn(data);
+}
+
+CAMLprim value stub_mmap_write(value interface, value data,
+ value start, value len)
+{
+ CAMLparam4(interface, data, start, len);
+ struct mmap_interface *intf;
+ int c_start;
+ int c_len;
+
+ c_start = Int_val(start);
+ c_len = Int_val(len);
+ intf = GET_C_STRUCT(interface);
+
+ if (c_start > intf->len)
+ caml_invalid_argument("start invalid");
+ if (c_start + c_len > intf->len)
+ caml_invalid_argument("len invalid");
+
+ memcpy(intf->addr + c_start, (char *) data, c_len);
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_mmap_getpagesize(value unit)
+{
+ CAMLparam1(unit);
+ CAMLlocal1(data);
+
+ data = Val_int(getpagesize());
+ CAMLreturn(data);
+}
--- /dev/null
+/**
+ * Copyright (c) 2006 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ *
+ * All rights reserved.
+ */
+
+#ifndef C_MMAP_H
+#define C_MMAP_H
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/custom.h>
+#include <caml/fail.h>
+#include <caml/callback.h>
+
+struct mmap_interface
+{
+ void *addr;
+ int len;
+};
+
+#endif
--- /dev/null
+#!/bin/sh
+
+set -e
+make clean; make cleanxen;
+make uninstall; make uninstallxen;
+make all && make install && make allxen && make installxen
--- /dev/null
+version = "@VERSION@"
+description = "Sha1 hash functions"
+archive(byte) = "sha1.cma"
+archive(native) = "sha1.cmxa"
--- /dev/null
+CC = gcc
+CFLAGS = -Wall -fPIC -O2 -I/opt/xensource/lib/ocaml -I$(XEN_ROOT)/usr/include -I../mmap -I./
+OCAMLC = ocamlc -g
+OCAMLOPT = ocamlopt
+OCAMLOPTFLAGS = -g -dtypes -I ./
+
+LDFLAGS = -cclib -L./
+
+DESTDIR ?= /
+VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0)
+
+OCAMLABI := $(shell ocamlc -version)
+OCAMLLIBDIR := $(shell ocamlc -where)
+OCAMLDESTDIR ?= $(OCAMLLIBDIR)
+
+OBJS = sha1
+INTF = sha1.cmi
+LIBS = sha1.cma sha1.cmxa
+
+PROGRAMS =
+
+all: $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+sha1.cmxa: libsha1_stubs.a $(foreach obj,$(OBJS),$(obj).cmx)
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -a -o $@ -cclib -lsha1_stubs $(foreach obj,$(OBJS),$(obj).cmx)
+
+sha1.cma: $(foreach obj,$(OBJS),$(obj).cmo)
+ $(OCAMLC) -a -dllib dllsha1_stubs.so -cclib -lsha1_stubs -o $@ $(foreach obj,$(OBJS),$(obj).cmo)
+
+sha1_stubs.a: sha1_stubs.o
+ ocamlmklib -o sha1_stubs $+
+
+libsha1_stubs.a: sha1_stubs.o
+ ar rcs $@ $+
+ ocamlmklib -o sha1_stubs $+
+
+%.cmo: %.ml
+ $(OCAMLC) -c -o $@ $<
+
+%.cmi: %.mli
+ $(OCAMLC) -c -o $@ $<
+
+%.mli: %.ml
+ $(OCAMLC) -i $< > $@
+
+%.cmx: %.ml
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -c -o $@ $<
+
+%.o: %.c
+ $(CC) $(CFLAGS) -c -o $@ $<
+
+META: META.in
+ sed 's/@VERSION@/$(VERSION)/g' < $< > $@
+
+.PHONY: install
+install: $(LIBS) META
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore sha1 META $(INTF) $(LIBS) *.a *.so *.cmx
+
+.PHONY: uninstall
+uninstall:
+ ocamlfind remove sha1
+
+clean:
+ rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS) $(INTF)
+
--- /dev/null
+(*
+ * Copyright (C) 2007 XenSource Ltd.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ *)
+
+type ctx
+type t
+
+external init: unit -> ctx = "stub_sha1_init"
+external update: ctx -> string -> int -> int -> unit = "stub_sha1_update"
+external finalize: ctx -> t = "stub_sha1_finalize"
+external to_hex: t -> string = "stub_sha1_to_hex"
--- /dev/null
+/* Copyright (c) 2007 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com> */
+
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+
+#include <byteswap.h>
+
+#ifdef WORDS_BIGENDIAN
+#define be16_to_cpu(x) (x)
+#define be32_to_cpu(x) (x)
+#define be64_to_cpu(x) (x)
+#define le16_to_cpu(x) bswap_16(x)
+#define le32_to_cpu(x) bswap_32(x)
+#define le64_to_cpu(x) bswap_64(x)
+#else
+#define be16_to_cpu(x) bswap_16(x)
+#define be32_to_cpu(x) bswap_32(x)
+#define be64_to_cpu(x) bswap_64(x)
+#define le16_to_cpu(x) (x)
+#define le32_to_cpu(x) (x)
+#define le64_to_cpu(x) (x)
+#endif
+
+struct sha1_ctx
+{
+ unsigned int state[5];
+ unsigned char buf[64];
+ unsigned long long count;
+};
+
+typedef struct { unsigned int digest[5]; } sha1_digest;
+
+static void sha1_init(struct sha1_ctx *ctx)
+{
+ memset(ctx, 0, sizeof(*ctx));
+
+ /* initialize H */
+ ctx->state[0] = 0x67452301;
+ ctx->state[1] = 0xEFCDAB89;
+ ctx->state[2] = 0x98BADCFE;
+ ctx->state[3] = 0x10325476;
+ ctx->state[4] = 0xC3D2E1F0;
+}
+
+#define rol(value, bits) (((value) << (bits)) | ((value) >> (32 - (bits))))
+
+/* (R0+R1), R2, R3, R4 are the different operations used in SHA1 */
+#define blk0(i) (block[i] = be32_to_cpu(((unsigned int*)buffer)[i]))
+#define blk(i) (block[i] = rol(block[i-3]^block[i-8]^block[i-14]^block[i-16],1))
+
+#define R0(v,w,x,y,z,i) z+=((w&(x^y))^y) +blk0(i)+0x5A827999+rol(v,5);w=rol(w,30);
+#define R1(v,w,x,y,z,i) z+=((w&(x^y))^y) +blk (i)+0x5A827999+rol(v,5);w=rol(w,30);
+#define R2(v,w,x,y,z,i) z+=( w^x ^y) +blk (i)+0x6ED9EBA1+rol(v,5);w=rol(w,30);
+#define R3(v,w,x,y,z,i) z+=(((w|x)&y)|(w&x))+blk (i)+0x8F1BBCDC+rol(v,5);w=rol(w,30);
+#define R4(v,w,x,y,z,i) z+=( w^x ^y) +blk (i)+0xCA62C1D6+rol(v,5);w=rol(w,30);
+
+
+static void sha1_transform(unsigned int state[5], unsigned char buffer[64])
+{
+ unsigned int block[80];
+ unsigned int i, a, b, c, d, e;
+
+ a = state[0];
+ b = state[1];
+ c = state[2];
+ d = state[3];
+ e = state[4];
+
+ for (i = 0; i < 15; i += 5) {
+ R0(a, b, c, d, e, 0 + i);
+ R0(e, a, b, c, d, 1 + i);
+ R0(d, e, a, b, c, 2 + i);
+ R0(c, d, e, a, b, 3 + i);
+ R0(b, c, d, e, a, 4 + i);
+ }
+
+ R0(a, b, c, d, e, 15);
+ R1(e, a, b, c, d, 16);
+ R1(d, e, a, b, c, 17);
+ R1(c, d, e, a, b, 18);
+ R1(b, c, d, e, a, 19);
+
+ for (i = 20; i < 40; i += 5) {
+ R2(a, b, c, d, e, 0 + i);
+ R2(e, a, b, c, d, 1 + i);
+ R2(d, e, a, b, c, 2 + i);
+ R2(c, d, e, a, b, 3 + i);
+ R2(b, c, d, e, a, 4 + i);
+ }
+ for (; i < 60; i += 5) {
+ R3(a, b, c, d, e, 0 + i);
+ R3(e, a, b, c, d, 1 + i);
+ R3(d, e, a, b, c, 2 + i);
+ R3(c, d, e, a, b, 3 + i);
+ R3(b, c, d, e, a, 4 + i);
+ }
+ for (; i < 80; i += 5) {
+ R4(a, b, c, d, e, 0 + i);
+ R4(e, a, b, c, d, 1 + i);
+ R4(d, e, a, b, c, 2 + i);
+ R4(c, d, e, a, b, 3 + i);
+ R4(b, c, d, e, a, 4 + i);
+ }
+
+ state[0] += a;
+ state[1] += b;
+ state[2] += c;
+ state[3] += d;
+ state[4] += e;
+}
+
+static void sha1_update(struct sha1_ctx *ctx, unsigned char *data, int len)
+{
+ unsigned int i, j;
+ j = ctx->count & 63;
+ ctx->count += len;
+
+ if ((j + len) > 63) {
+ i = 64 - j;
+ memcpy(&ctx->buf[j], data, i);
+ sha1_transform(ctx->state, ctx->buf);
+ for ( ; i + 63 < len; i += 64) {
+ sha1_transform(ctx->state, &data[i]);
+ }
+ j = 0;
+ } else
+ i = 0;
+ memcpy(&ctx->buf[j], &data[i], len - i);
+}
+
+static void sha1_finalize(struct sha1_ctx *ctx, sha1_digest *digest)
+{
+ int i;
+ unsigned long long finalcount = be64_to_cpu(ctx->count << 3);
+
+ sha1_update(ctx, (unsigned char *)"\200", 1);
+ while ((ctx->count & 63) != 56)
+ sha1_update(ctx, (unsigned char *) "", 1);
+
+ sha1_update(ctx, (unsigned char *) &finalcount, 8);
+ for (i = 0; i < 5; i++)
+ digest->digest[i] = be32_to_cpu(ctx->state[i]);
+}
+
+static inline void sha1_to_hex(sha1_digest *digest, char *out)
+{
+ char *p;
+ int i;
+ for (p = out, i = 0; i < 20; i++, p += 2)
+ snprintf(p, 3, "%02x", ((unsigned char *) digest->digest)[i]);
+}
+
+#define CAML_NAME_SPACE
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include <caml/fail.h>
+
+#define GET_CTX_STRUCT(a) ((struct sha1_ctx *) a)
+
+CAMLprim value stub_sha1_init(value unit)
+{
+ CAMLparam1(unit);
+ CAMLlocal1(result);
+
+ result = caml_alloc(sizeof(struct sha1_ctx), Abstract_tag);
+ sha1_init(GET_CTX_STRUCT(result));
+
+ CAMLreturn(result);
+}
+
+CAMLprim value stub_sha1_update(value ctx, value data, value ofs, value len)
+{
+ CAMLparam4(ctx, data, ofs, len);
+ sha1_update(GET_CTX_STRUCT(ctx), (unsigned char *) data + Int_val(ofs),
+ Int_val(len));
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_sha1_finalize(value ctx)
+{
+ CAMLparam1(ctx);
+ CAMLlocal1(t);
+
+ t = caml_alloc(sizeof(sha1_digest), Abstract_tag);
+ sha1_finalize(GET_CTX_STRUCT(ctx), (sha1_digest *) t);
+
+ CAMLreturn(t);
+}
+
+CAMLprim value stub_sha1_to_hex(value t)
+{
+ CAMLparam1(t);
+ CAMLlocal1(result);
+
+ result = caml_alloc_string(40);
+ sha1_to_hex((sha1_digest *) t, String_val(result));
+
+ CAMLreturn(result);
+}
+
+/*
+ * Local variables:
+ * indent-tabs-mode: t
+ * c-basic-offset: 8
+ * tab-width: 8
+ * End:
+ */
--- /dev/null
+(* Copyright (C) 2007 XenSource Ltd.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ *)
+let channel chan len =
+ let ctx = Sha1.init ()
+ and buf = String.create 4096 in
+
+ let left = ref len and eof = ref false in
+ while (!left == -1 || !left > 0) && not !eof
+ do
+ let len = if !left < 0 then 4096 else (min !left 4096) in
+ let readed = Pervasives.input chan buf 0 len in
+ if readed = 0 then
+ eof := true
+ else (
+ Sha1.update ctx buf 0 readed;
+ if !left <> -1 then left := !left - readed
+ )
+ done;
+ if !left > 0 && !eof then
+ raise End_of_file;
+ Sha1.finalize ctx
+
+let _ =
+ let name = Sys.argv.(1) in
+ let chan = open_in_bin name in
+ let digest = channel chan (-1) in
+ close_in chan;
+ Printf.printf "%s\n" (Sha1.to_hex digest)
--- /dev/null
+Just do:
+
+ $ make
+
+then from root:
+
+ # make install
--- /dev/null
+version = "@VERSION@"
+description = "Stdext - Common stdlib extensions"
+requires = "unix,uuid"
+archive(byte) = "stdext.cma"
+archive(native) = "stdext.cmxa"
--- /dev/null
+CC = gcc
+CFLAGS = -Wall -fPIC -O2 -I/opt/xensource/lib/ocaml
+OCAMLC = ocamlc -g
+OCAMLOPT = ocamlopt
+
+LDFLAGS = -cclib -L./
+
+DESTDIR ?= /
+VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0)
+OCAMLOPTFLAGS = -g -dtypes
+
+OCAMLABI := $(shell ocamlc -version)
+OCAMLLIBDIR := $(shell ocamlc -where)
+OCAMLDESTDIR ?= $(OCAMLLIBDIR)
+
+OCAML_TEST_INC = -I $(shell ocamlfind query oUnit)
+OCAML_TEST_LIB = $(shell ocamlfind query oUnit)/oUnit.cmxa
+
+STDEXT_OBJS = filenameext stringext arrayext hashtblext listext pervasiveext threadext ring qring fring opt unixext range bigbuffer vIO trie
+INTF = $(foreach obj, $(STDEXT_OBJS),$(obj).cmi)
+LIBS = stdext.cma stdext.cmxa
+
+all: $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+stdext.cmxa: libstdext_stubs.a $(foreach obj,$(STDEXT_OBJS),$(obj).cmx)
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -a -o $@ -cclib -lstdext_stubs $(foreach obj,$(STDEXT_OBJS),$(obj).cmx)
+
+stdext.cma: $(foreach obj,$(STDEXT_OBJS),$(obj).cmo)
+ $(OCAMLC) -a -dllib dllstdext_stubs.so -cclib -lstdext_stubs -o $@ $(foreach obj,$(STDEXT_OBJS),$(obj).cmo)
+
+stdext_stubs.a: unixext_stubs.o
+ ocamlmklib -o stdext_stubs $+
+
+libstdext_stubs.a: unixext_stubs.o
+ ar rcs $@ $+
+ ocamlmklib -o stdext_stubs $+
+
+querycd: querycd.cmo
+ ocamlfind ocamlc -custom -thread -package "threads,unix,stdext" querycd.cmo -o querycd -linkpkg -linkall
+#camlc unix.cma stdext.cma querycd.cmo -o querycd
+
+## OBJS
+threadext.cmo: threadext.ml
+ $(OCAMLC) -thread -c -o $@ $<
+
+%.cmo: %.ml
+ $(OCAMLC) -c -I ../uuid -o $@ $<
+
+threadext.cmi: threadext.mli
+ $(OCAMLC) -thread -c -o $@ $<
+
+%.cmi: %.mli
+ $(OCAMLC) -c -I ../uuid -o $@ $<
+
+threadext.cmx: threadext.ml
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -thread -c -o $@ $<
+
+%.cmx: %.ml
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -I ../uuid -c -o $@ $<
+
+%.o: %.c
+ $(CC) $(CFLAGS) -c -o $@ $<
+
+META: META.in
+ sed 's/@VERSION@/$(VERSION)/g' < $< > $@
+
+.PHONY: install
+install: $(LIBS) META
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore stdext META $(INTF) $(LIBS) *.a *.so *.cmx
+
+.PHONY: uninstall
+uninstall:
+ ocamlfind remove stdext
+
+clean:
+ rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS)
+
+#dependency:
+
+unixext.cmo : filenameext.ml
+unixext.cmx : filenameext.ml
--- /dev/null
+module Array = struct include Array
+
+(* Useful for vector addition. *)
+let map2 f a b =
+ let len = length a in
+ if len <> length b then invalid_arg "map2";
+ init len (fun i -> f a.(i) b.(i))
+
+(* Useful for vector dot product. *)
+let fold_left2 f x a b =
+ let len = length a in
+ if len <> length b then invalid_arg "fold_left2";
+ let r = ref x in
+ for i = 0 to len - 1 do
+ r := f !r a.(i) b.(i)
+ done;
+ !r
+
+(* Useful for vector dot product. *)
+let fold_right2 f a b x =
+ let len = length a in
+ if len <> length b then invalid_arg "fold_right2";
+ let r = ref x in
+ for i = len - 1 downto 0 do
+ r := f a.(i) b.(i) !r
+ done;
+ !r
+
+let inner fold_left2 base f l1 l2 g =
+ fold_left2 (fun accu e1 e2 -> g accu (f e1 e2)) base l1 l2
+end
+
--- /dev/null
+module Array :
+ sig
+ external length : 'a array -> int = "%array_length"
+ external get : 'a array -> int -> 'a = "%array_safe_get"
+ external set : 'a array -> int -> 'a -> unit = "%array_safe_set"
+ external make : int -> 'a -> 'a array = "caml_make_vect"
+ external create : int -> 'a -> 'a array = "caml_make_vect"
+ val init : int -> (int -> 'a) -> 'a array
+ val make_matrix : int -> int -> 'a -> 'a array array
+ val create_matrix : int -> int -> 'a -> 'a array array
+ val append : 'a array -> 'a array -> 'a array
+ val concat : 'a array list -> 'a array
+ val sub : 'a array -> int -> int -> 'a array
+ val copy : 'a array -> 'a array
+ val fill : 'a array -> int -> int -> 'a -> unit
+ val blit : 'a array -> int -> 'a array -> int -> int -> unit
+ val to_list : 'a array -> 'a list
+ val of_list : 'a list -> 'a array
+ val iter : ('a -> unit) -> 'a array -> unit
+ val map : ('a -> 'b) -> 'a array -> 'b array
+ val iteri : (int -> 'a -> unit) -> 'a array -> unit
+ val mapi : (int -> 'a -> 'b) -> 'a array -> 'b array
+ val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a
+ val fold_right : ('a -> 'b -> 'b) -> 'a array -> 'b -> 'b
+ val sort : ('a -> 'a -> int) -> 'a array -> unit
+ val stable_sort : ('a -> 'a -> int) -> 'a array -> unit
+ val fast_sort : ('a -> 'a -> int) -> 'a array -> unit
+ external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get"
+ external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set"
+
+ (** Map a function over a pair of arrays simultaneously. *)
+ val map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
+
+
+ (** Fold a function over a pair of arrays simultaneously. *)
+ val fold_left2 :
+ ('a -> 'b -> 'c -> 'a) -> 'a -> 'b array -> 'c array -> 'a
+
+ (** Fold a function over a pair of arrays simultaneously. *)
+ val fold_right2 :
+ ('a -> 'b -> 'c -> 'c) -> 'a array -> 'b array -> 'c -> 'c
+
+ (** Compute the inner product of two arrays. *)
+ val inner :
+ (('a -> 'b -> 'c -> 'd) -> 'e -> 'f -> 'g -> 'h) ->
+ 'e -> ('b -> 'c -> 'i) -> 'f -> 'g -> ('a -> 'i -> 'd) -> 'h
+ end
--- /dev/null
+(*
+ * Copyright (C) 2007 XenSource Ltd.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ *)
+
+type t = {
+ mutable cells: string option array;
+ mutable index: int64;
+}
+
+let cell_size = 4096
+let default_array_len = 16
+
+let make () = { cells = Array.make default_array_len None; index = 0L }
+
+let length bigbuf = bigbuf.index
+
+let rec append_substring bigbuf s offset len =
+ let array_offset = Int64.to_int (Int64.div bigbuf.index (Int64.of_int cell_size)) in
+ let cell_offset = Int64.to_int (Int64.rem bigbuf.index (Int64.of_int cell_size)) in
+
+ if Array.length bigbuf.cells <= array_offset then (
+ (* we need to reallocate the array *)
+ bigbuf.cells <- Array.append bigbuf.cells (Array.make default_array_len None)
+ );
+
+ let buf = match bigbuf.cells.(array_offset) with
+ | None ->
+ let newbuf = String.create cell_size in
+ bigbuf.cells.(array_offset) <- Some newbuf;
+ newbuf
+ | Some buf ->
+ buf
+ in
+ if len + cell_offset <= cell_size then (
+ String.blit s offset buf cell_offset len;
+ bigbuf.index <- Int64.add bigbuf.index (Int64.of_int len);
+ ) else (
+ let rlen = cell_size - cell_offset in
+ String.blit s offset buf cell_offset rlen;
+ bigbuf.index <- Int64.add bigbuf.index (Int64.of_int rlen);
+ append_substring bigbuf s (offset + rlen) (len - rlen)
+ );
+ ()
+
+let to_fct bigbuf f =
+ let array_offset = Int64.to_int (Int64.div bigbuf.index (Int64.of_int cell_size)) in
+ let cell_offset = Int64.to_int (Int64.rem bigbuf.index (Int64.of_int cell_size)) in
+
+ (* copy all complete cells *)
+ for i = 0 to array_offset - 1
+ do
+ match bigbuf.cells.(i) with
+ | None -> (* ?!?!? *) ()
+ | Some cell -> f cell
+ done;
+
+ (* copy last cell *)
+ begin match bigbuf.cells.(array_offset) with
+ | None -> (* ?!?!?! *) ()
+ | Some cell -> f (String.sub cell 0 cell_offset)
+ end;
+ ()
+
+let to_string bigbuf =
+ if bigbuf.index > (Int64.of_int Sys.max_string_length) then
+ failwith "cannot allocate string big enough";
+
+ let dest = String.create (Int64.to_int bigbuf.index) in
+ let destoff = ref 0 in
+ to_fct bigbuf (fun s ->
+ let len = String.length s in
+ String.blit s 0 dest !destoff len;
+ destoff := !destoff + len
+ );
+ dest
+
+let to_stream bigbuf outchan =
+ to_fct bigbuf (fun s -> output_string outchan s)
--- /dev/null
+type t
+val make : unit -> t
+val length : t -> int64
+val append_substring : t -> string -> int -> int -> unit
+val to_fct : t -> (string -> unit) -> unit
+val to_string : t -> string
+val to_stream : t -> out_channel -> unit
--- /dev/null
+
+(** Makes a new file in the same directory as 'otherfile' *)
+let temp_file_in_dir otherfile =
+ let base_dir = Filename.dirname otherfile in
+ let rec keep_trying () =
+ try
+ let uuid = Uuid.to_string (Uuid.make_uuid ()) in
+ let newfile = base_dir ^ "/" ^ uuid in
+ Unix.close (Unix.openfile newfile [Unix.O_CREAT; Unix.O_TRUNC; Unix.O_EXCL] 0o600);
+ newfile
+ with
+ Unix.Unix_error (Unix.EEXIST, _, _) -> keep_trying ()
+ in
+ keep_trying ()
+
+
+
--- /dev/null
+val temp_file_in_dir : string -> string
--- /dev/null
+(*
+ * Copyright (c) 2006-2008 Citrix Systems Ltd.
+ * Authors Vincent Hanquez <vincent@xensource.com>
+ * Thomas Gazagnaire <thomas.gazagnaire@citrix.com>
+ * All rights reserved.
+ *)
+
+type t = { size: int; mutable current: int; data: (float,Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t ; }
+
+(** create a ring structure with @size record. records inited to @initval *)
+let make size init =
+ let ring =
+ { size = size; current = size - 1; data = Bigarray.Array1.create Bigarray.float32 Bigarray.c_layout size; }
+ in
+ for i = 0 to Bigarray.Array1.dim ring.data - 1 do
+ Bigarray.Array1.set ring.data i init
+ done;
+ ring
+
+(** length of the ring *)
+let length ring = ring.size
+
+(** push into the ring one element *)
+let push ring e =
+ ring.current <- ring.current + 1;
+ if ring.current = ring.size then
+ ring.current <- 0;
+ Bigarray.Array1.set ring.data ring.current e
+
+(** get the @ith old element from the ring *)
+let peek ring i =
+ if i >= ring.size then
+ raise (Invalid_argument "peek: index");
+ let index =
+ let offset = ring.current - i in
+ if offset >= 0 then offset else ring.size + offset in
+ Bigarray.Array1.get ring.data index
+
+(** get the top element of the ring *)
+let top ring = Bigarray.Array1.get ring.data ring.current
+
+(** iterate over nb element of the ring, starting from the top *)
+let iter_nb ring f nb =
+ if nb > ring.size then
+ raise (Invalid_argument "iter_nb: nb");
+ (* FIXME: OPTIMIZE ME with 2 Array.iter ? *)
+ for i = 0 to nb - 1
+ do
+ f (peek ring i)
+ done
+
+(** iter directly on all element without using the index *)
+let iter f a =
+ for i=0 to Bigarray.Array1.dim a - 1 do
+ f (Bigarray.Array1.get a i)
+ done
+
+let raw_iter ring f =
+ iter f ring.data
+
+(** iterate over all element of the ring, starting from the top *)
+let iter ring f = iter_nb ring f (ring.size)
+
+(** get array of latest #nb value *)
+let get_nb ring nb =
+ if nb > ring.size then
+ raise (Invalid_argument "get_nb: nb");
+ let a = Array.create nb (top ring) in
+ for i = 1 to nb - 1
+ do
+ (* FIXME: OPTIMIZE ME with 2 Array.blit *)
+ a.(i) <- peek ring i
+ done;
+ a
+
+let get ring = get_nb ring (ring.size)
--- /dev/null
+type t = {
+ size : int;
+ mutable current : int;
+ data : (float, Bigarray.float32_elt, Bigarray.c_layout) Bigarray.Array1.t;
+}
+val make : int -> float -> t
+val length : t -> int
+val push : t -> float -> unit
+val peek : t -> int -> float
+val top : t -> float
+val iter_nb : t -> (float -> 'a) -> int -> unit
+val raw_iter : t -> (float -> 'a) -> unit
+val iter : t -> (float -> 'a) -> unit
+val get_nb : t -> int -> float array
+val get : t -> float array
--- /dev/null
+module Hashtbl = struct include Hashtbl
+
+let to_list tbl =
+ Hashtbl.fold (fun k v acc -> (k, v) :: acc) tbl []
+
+let fold_keys tbl =
+ Hashtbl.fold (fun k v acc -> k :: acc) tbl []
+
+let fold_values tbl =
+ Hashtbl.fold (fun k v acc -> v :: acc) tbl []
+
+let add_empty tbl k v =
+ if not (Hashtbl.mem tbl k) then
+ Hashtbl.add tbl k v
+
+let add_list tbl l =
+ List.iter (fun (k, v) -> Hashtbl.add tbl k v) l
+
+let of_list l =
+ let tbl = Hashtbl.create (List.length l) in
+ add_list tbl l;
+ tbl
+end
--- /dev/null
+module Hashtbl :
+ sig
+ type ('a, 'b) t = ('a, 'b) Hashtbl.t
+ val create : int -> ('a, 'b) t
+ val clear : ('a, 'b) t -> unit
+ val add : ('a, 'b) t -> 'a -> 'b -> unit
+ val copy : ('a, 'b) t -> ('a, 'b) t
+ val find : ('a, 'b) t -> 'a -> 'b
+ val find_all : ('a, 'b) t -> 'a -> 'b list
+ val mem : ('a, 'b) t -> 'a -> bool
+ val remove : ('a, 'b) t -> 'a -> unit
+ val replace : ('a, 'b) t -> 'a -> 'b -> unit
+ val iter : ('a -> 'b -> unit) -> ('a, 'b) t -> unit
+ val fold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c
+ val length : ('a, 'b) t -> int
+ module type HashedType =
+ sig type t val equal : t -> t -> bool val hash : t -> int end
+ module type S =
+ sig
+ type key
+ type 'a t
+ val create : int -> 'a t
+ val clear : 'a t -> unit
+ val copy : 'a t -> 'a t
+ val add : 'a t -> key -> 'a -> unit
+ val remove : 'a t -> key -> unit
+ val find : 'a t -> key -> 'a
+ val find_all : 'a t -> key -> 'a list
+ val replace : 'a t -> key -> 'a -> unit
+ val mem : 'a t -> key -> bool
+ val iter : (key -> 'a -> unit) -> 'a t -> unit
+ val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+ val length : 'a t -> int
+ end
+ module Make :
+ functor (H : HashedType) ->
+ sig
+ type key = H.t
+ type 'a t = 'a Hashtbl.Make(H).t
+ val create : int -> 'a t
+ val clear : 'a t -> unit
+ val copy : 'a t -> 'a t
+ val add : 'a t -> key -> 'a -> unit
+ val remove : 'a t -> key -> unit
+ val find : 'a t -> key -> 'a
+ val find_all : 'a t -> key -> 'a list
+ val replace : 'a t -> key -> 'a -> unit
+ val mem : 'a t -> key -> bool
+ val iter : (key -> 'a -> unit) -> 'a t -> unit
+ val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+ val length : 'a t -> int
+ end
+ val hash : 'a -> int
+ external hash_param : int -> int -> 'a -> int = "caml_hash_univ_param"
+ "noalloc"
+ val to_list : ('a, 'b) Hashtbl.t -> ('a * 'b) list
+ val fold_keys : ('a, 'b) Hashtbl.t -> 'a list
+ val fold_values : ('a, 'b) Hashtbl.t -> 'b list
+ val add_empty : ('a, 'b) Hashtbl.t -> 'a -> 'b -> unit
+ val add_list : ('a, 'b) Hashtbl.t -> ('a * 'b) list -> unit
+ val of_list : ('a * 'b) list -> ('a, 'b) Hashtbl.t
+ end
--- /dev/null
+module List = struct include List
+
+(** Turn a list into a set *)
+let rec setify = function
+ | [] -> []
+ | (x::xs) -> if mem x xs then setify xs else x::(setify xs)
+
+let subset s1 s2 = List.fold_left (&&) true (List.map (fun s->List.mem s s2) s1)
+let set_equiv s1 s2 = (subset s1 s2) && (subset s2 s1)
+
+let iteri f list = ignore (fold_left (fun i x -> f i x; i+1) 0 list)
+
+let rec inv_assoc k = function
+ | [] -> raise Not_found
+ | (v, k') :: _ when k = k' -> v
+ | _ :: t -> inv_assoc k t
+
+(* Tail-recursive map. *)
+let map_tr f l = rev (rev_map f l)
+
+let count pred l =
+ fold_left (fun count e -> count + if pred e then 1 else 0) 0 l
+
+let position pred l =
+ let aux (i, is) e = i + 1, if pred e then i :: is else is in
+ snd (fold_left aux (0, []) l)
+
+let mapi f l =
+ let rec aux n = function
+ | h :: t -> let h = f n h in h :: aux (n + 1) t
+ | [] -> [] in
+ aux 0 l
+
+let rev_mapi f l =
+ let rec aux n accu = function
+ | h :: t -> aux (n + 1) (f n h :: accu) t
+ | [] -> accu in
+ aux 0 [] l
+
+let mapi_tr f l = rev (rev_mapi f l)
+
+let rec chop i l = match i, l with
+ | 0, l -> [], l
+ | i, h :: t -> (fun (fr, ba) -> h :: fr, ba) (chop (i - 1) t)
+ | _ -> invalid_arg "chop"
+
+let rev_chop i l =
+ let rec aux i fr ba = match i, fr, ba with
+ | 0, fr, ba -> (fr, ba)
+ | i, fr, h :: t -> aux (i - 1) (h :: fr) t
+ | _ -> invalid_arg "rev_chop" in
+ aux i [] l
+
+let chop_tr i l =
+ (fun (fr, ba) -> rev fr, ba) (rev_chop i l)
+
+let rec dice m l = match chop m l with
+ | l, [] -> [l]
+ | l1, l2 -> l1 :: dice m l2
+
+let sub i j l =
+ fst (chop_tr (j - i) (snd (rev_chop i l)))
+
+let remove i l = match rev_chop i l with
+ | rfr, _ :: t -> rev_append rfr t
+ | _ -> invalid_arg "remove"
+
+let extract i l = match rev_chop i l with
+ | rfr, h :: t -> h, rev_append rfr t
+ | _ -> invalid_arg "extract"
+
+let insert i e l = match rev_chop i l with
+ rfr, ba -> rev_append rfr (e :: ba)
+
+let replace i e l = match rev_chop i l with
+ | rfr, _ :: t -> rev_append rfr (e :: t)
+ | _ -> invalid_arg "replace"
+
+let morph i f l = match rev_chop i l with
+ | rfr, h :: t -> rev_append rfr (f h :: t)
+ | _ -> invalid_arg "morph"
+
+let rec between e = function
+ | [] -> []
+ | [h] -> [h]
+ | h :: t -> h :: e :: between e t
+
+
+let between_tr e l =
+ let rec aux accu e = function
+ | [] -> rev accu
+ | [h] -> rev (h :: accu)
+ | h :: t -> aux (e :: h :: accu) e t in
+ aux [] e l
+
+let randomize l =
+ let extract_rand l = extract (Random.int (length l)) l in
+ let rec aux accu = function
+ | [] -> accu
+ | l -> (fun (h, t) -> aux (h :: accu) t) (extract_rand l) in
+ aux [] l
+
+let rec distribute e = function
+ | (h :: t) as l ->
+ (e :: l) :: (map (fun x -> h :: x) (distribute e t))
+ | [] -> [ [ e ] ]
+
+let rec permute = function
+ | e :: rest -> flatten (map (distribute e) (permute rest))
+ | [] -> [ [] ]
+
+let rec aux_rle_eq eq l2 x n = function
+ | [] -> rev ((x, n) :: l2)
+ | h :: t when eq x h -> aux_rle_eq eq l2 x (n + 1) t
+ | h :: t -> aux_rle_eq eq ((x, n) :: l2) h 1 t
+
+let rle_eq eq l =
+ match l with [] -> [] | h :: t -> aux_rle_eq eq [] h 1 t
+
+let rle l = rle_eq ( = ) l
+
+let unrle l =
+ let rec aux2 accu i c = match i with
+ | 0 -> accu
+ | i when i>0 -> aux2 (c :: accu) (i - 1) c
+ | _ -> invalid_arg "unrle" in
+ let rec aux accu = function
+ | [] -> rev accu
+ | (i, c) :: t -> aux (aux2 accu i c) t in
+ aux [] l
+
+let inner fold_left2 base f l1 l2 g =
+ fold_left2 (fun accu e1 e2 -> g accu (f e1 e2)) base l1 l2
+
+let filter_map f list =
+ List.fold_right
+ begin
+ fun element list -> match (f element) with
+ | Some x -> x :: list
+ | None -> list
+ end
+ list []
+
+let rec is_sorted compare list =
+ match list with
+ | x :: y :: list ->
+ if compare x y <= 0
+ then is_sorted compare (y :: list)
+ else false
+ | _ ->
+ true
+
+let intersect xs ys = List.filter (fun x -> List.mem x ys) xs
+
+let set_difference a b = List.filter (fun x -> not(List.mem x b)) a
+
+let assoc_default k l d =
+ if List.mem_assoc k l then List.assoc k l else d
+end
--- /dev/null
+module List :
+ sig
+ val setify : 'a list -> 'a list
+ val subset : 'a list -> 'a list -> bool
+ val set_equiv : 'a list -> 'a list -> bool
+ val length : 'a list -> int
+ val hd : 'a list -> 'a
+ val tl : 'a list -> 'a list
+ val nth : 'a list -> int -> 'a
+ val rev : 'a list -> 'a list
+ val append : 'a list -> 'a list -> 'a list
+ val rev_append : 'a list -> 'a list -> 'a list
+ val concat : 'a list list -> 'a list
+ val flatten : 'a list list -> 'a list
+ val iter : ('a -> unit) -> 'a list -> unit
+ val map : ('a -> 'b) -> 'a list -> 'b list
+ val rev_map : ('a -> 'b) -> 'a list -> 'b list
+ val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a
+ val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b
+ val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit
+ val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
+ val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
+ val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a
+ val fold_right2 :
+ ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c
+ val for_all : ('a -> bool) -> 'a list -> bool
+ val exists : ('a -> bool) -> 'a list -> bool
+ val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
+ val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
+ val mem : 'a -> 'a list -> bool
+ val memq : 'a -> 'a list -> bool
+ val find : ('a -> bool) -> 'a list -> 'a
+ val filter : ('a -> bool) -> 'a list -> 'a list
+ val find_all : ('a -> bool) -> 'a list -> 'a list
+ val partition : ('a -> bool) -> 'a list -> 'a list * 'a list
+ val assoc : 'a -> ('a * 'b) list -> 'b
+ val assq : 'a -> ('a * 'b) list -> 'b
+ val mem_assoc : 'a -> ('a * 'b) list -> bool
+ val mem_assq : 'a -> ('a * 'b) list -> bool
+ val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list
+ val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list
+ val split : ('a * 'b) list -> 'a list * 'b list
+ val combine : 'a list -> 'b list -> ('a * 'b) list
+ val sort : ('a -> 'a -> int) -> 'a list -> 'a list
+ val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list
+ val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list
+ val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list
+
+ (** Perform a lookup on an association list of (value, key) pairs. *)
+ val inv_assoc : 'a -> ('b * 'a) list -> 'b
+
+ (** A tail-recursive map. *)
+ val map_tr : ('a -> 'b) -> 'a list -> 'b list
+
+ (** Count the number of list elements matching the given predicate. *)
+ val count : ('a -> bool) -> 'a list -> int
+
+ (** Find the indices of all elements matching the given predicate. *)
+ val position : ('a -> bool) -> 'a list -> int list
+
+ (** Map the given function over a list, supplying the integer index as well
+ as the element value. *)
+ val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list
+
+ val iteri : (int -> 'a -> unit) -> 'a list -> unit
+
+ (** Map the given function over a list in reverse order. *)
+ val rev_mapi : (int -> 'a -> 'b) -> 'a list -> 'b list
+
+ (** Tail-recursive [mapi]. *)
+ val mapi_tr : (int -> 'a -> 'b) -> 'a list -> 'b list
+
+ (** Split a list at the given index to give a pair of lists. *)
+ val chop : int -> 'a list -> 'a list * 'a list
+
+ (** Split a list at the given index to give a pair of lists, the first in
+ reverse order. *)
+ val rev_chop : int -> 'a list -> 'a list * 'a list
+
+ (** Tail-recursive [chop]. *)
+ val chop_tr : int -> 'a list -> 'a list * 'a list
+
+ (** Split a list into lists with the given number of elements. *)
+ val dice : int -> 'a list -> 'a list list
+
+ (** Extract the sub-list between the given indices. *)
+ val sub : int -> int -> 'a list -> 'a list
+
+ (** Remove the element at the given index. *)
+ val remove : int -> 'a list -> 'a list
+
+ (** Extract the element at the given index, returning the element and the
+ list without that element. *)
+ val extract : int -> 'a list -> 'a * 'a list
+
+ (** Insert the given element at the given index. *)
+ val insert : int -> 'a -> 'a list -> 'a list
+
+ (** Replace the element at the given index with the given value. *)
+ val replace : int -> 'a -> 'a list -> 'a list
+
+ (** Apply the given function to the element at the given index. *)
+ val morph : int -> ('a -> 'a) -> 'a list -> 'a list
+
+ (** Insert the element [e] between every pair of adjacent elements in the
+ given list. *)
+ val between : 'a -> 'a list -> 'a list
+
+ (** Tail-recursive [between]. *)
+ val between_tr : 'a -> 'a list -> 'a list
+
+ (** Generate a random permutation of the given list. *)
+ val randomize : 'a list -> 'a list
+
+ (** Distribute the given element over the given list, returning a list of
+ lists with the new element in each position. *)
+ val distribute : 'a -> 'a list -> 'a list list
+
+ (** Generate all permutations of the given list. *)
+ val permute : 'a list -> 'a list list
+
+ (** Run-length encode the given list using the given equality function. *)
+ val rle_eq : ('a -> 'a -> bool) -> 'a list -> ('a * int) list
+
+ (** Run-length encode the given list using built-in equality. *)
+ val rle : 'a list -> ('a * int) list
+
+ (** Decode a run-length encoded list. *)
+ val unrle : (int * 'a) list -> 'a list
+
+ (** Compute the inner product of two lists. *)
+ val inner :
+ (('a -> 'b -> 'c -> 'd) -> 'e -> 'f -> 'g -> 'h) ->
+ 'e -> ('b -> 'c -> 'i) -> 'f -> 'g -> ('a -> 'i -> 'd) -> 'h
+
+ (** Applies a function f that generates optional values, to each
+ of the items in a list A [a1; ...; am], generating a new list
+ of non-optional values B [b1; ...; bn], with m >= n. For each
+ value a in list A, list B contains a corresponding value b if
+ and only if the application of (f a) results in Some b. *)
+ val filter_map : ('a -> 'b option) -> 'a list -> 'b list
+
+ (** Returns true if and only if the given list is in sorted order
+ according to the given comparison function. *)
+ val is_sorted : ('a -> 'a -> int) -> 'a list -> bool
+
+ (** Returns the intersection of two lists. *)
+ val intersect : 'a list -> 'a list -> 'a list
+
+ (** Returns the set difference of two lists *)
+ val set_difference : 'a list -> 'a list -> 'a list
+
+ (** Act as List.assoc, but return the given default value if the key
+ is not in the list. *)
+ val assoc_default : 'a -> ('a * 'b) list -> 'b -> 'b
+
+ end
--- /dev/null
+let iter f = function
+ | Some x -> f x
+ | None -> ()
+
+let map f = function
+ | Some x -> Some(f x)
+ | None -> None
+
+let default d = function
+ | Some x -> x
+ | None -> d
+
+let unbox = function
+ | Some x -> x
+ | None -> raise Not_found
+
+let is_boxed = function
+ | Some _ -> true
+ | None -> false
+
+let to_list = function
+ | Some x -> [x]
+ | None -> []
+
+let fold_left f accu = function
+ | Some x -> f accu x
+ | None -> accu
+
+let fold_right f opt accu =
+ match opt with
+ | Some x -> f x accu
+ | None -> accu
--- /dev/null
+val iter : ('a -> unit) -> 'a option -> unit
+val map : ('a -> 'b) -> 'a option -> 'b option
+val default : 'a -> 'a option -> 'a
+val unbox : 'a option -> 'a
+val is_boxed : 'a option -> bool
+val to_list : 'a option -> 'a list
+val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b option -> 'a
+val fold_right : ('a -> 'b -> 'b) -> 'a option -> 'b -> 'b
--- /dev/null
+(** apply the clean_f function after fct function has been called.
+ * Even if fct raises an exception, clean_f is applied
+ *)
+
+let exnhook = ref None
+
+let finally fct clean_f =
+ let result = try
+ fct ();
+ with
+ exn ->
+ (match !exnhook with None -> () | Some f -> f exn);
+ clean_f (); raise exn in
+ clean_f ();
+ result
+
+let maybe_with_default d f v =
+ match v with None -> d | Some x -> f x
+
+(** if v is not none, apply f on it and return some value else return none. *)
+let may f v = maybe_with_default None (fun x -> Some (f x)) v
+
+(** default value to d if v is none. *)
+let default d v = maybe_with_default d (fun x -> x) v
+
+(** apply f on v if not none *)
+let maybe f v = maybe_with_default () f v
+
+(** if bool is false then we intercept and quiten any exception *)
+let reraise_if bool fct =
+ try fct () with exn -> if bool then raise exn else ()
+
+(** execute fct ignoring exceptions *)
+let ignore_exn fct = try fct () with _ -> ()
+
+(* non polymorphic ignore function *)
+let ignore_int v = let (_: int) = v in ()
+let ignore_int64 v = let (_: int64) = v in ()
+let ignore_int32 v = let (_: int32) = v in ()
+let ignore_string v = let (_: string) = v in ()
+let ignore_float v = let (_: float) = v in ()
+let ignore_bool v = let (_: bool) = v in ()
--- /dev/null
+val exnhook : (exn -> unit) option ref
+val finally : (unit -> 'a) -> (unit -> 'b) -> 'a
+val maybe_with_default : 'b -> ('a -> 'b) -> 'a option -> 'b
+val may : ('a -> 'b) -> 'a option -> 'b option
+val default : 'a -> 'a option -> 'a
+val maybe : ('a -> unit) -> 'a option -> unit
+val reraise_if : bool -> (unit -> unit) -> unit
+val ignore_exn : (unit -> unit) -> unit
+val ignore_int : int -> unit
+val ignore_int32 : int32 -> unit
+val ignore_int64 : int64 -> unit
+val ignore_string : string -> unit
+val ignore_float : float -> unit
+val ignore_bool : bool -> unit
--- /dev/null
+(*
+ * Copyright 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * efficient circular string queue
+ *)
+type t = {
+ sz: int;
+ data: string;
+ mutable prod: int;
+ mutable cons: int;
+ mutable pwrap: bool;
+}
+
+exception Data_limit
+exception Full
+
+let make sz = { sz = sz; data = String.create sz; prod = 0; cons = 0; pwrap = false }
+
+let to_consume ring =
+ if ring.pwrap then
+ ring.sz - (ring.cons - ring.prod)
+ else
+ ring.prod - ring.cons
+
+let to_fill ring =
+ if ring.pwrap then
+ ring.cons - ring.prod
+ else
+ ring.cons + (ring.sz - ring.prod)
+
+let is_full ring = ring.pwrap && ring.prod = ring.cons
+let is_empty ring = not ring.pwrap && ring.prod = ring.cons
+
+let adv_cons ring i =
+ ring.cons <- ring.cons + i;
+ if ring.cons >= ring.sz then (
+ ring.cons <- ring.cons - ring.sz;
+ ring.pwrap <- false;
+ )
+
+let adv_prod ring i =
+ ring.prod <- ring.prod + i;
+ if ring.prod >= ring.sz then (
+ ring.prod <- ring.prod - ring.sz;
+ ring.pwrap <- true;
+ )
+
+let consume ring sz =
+ let max = to_consume ring in
+ let sz =
+ if sz > 0 then
+ if sz > max then max else sz
+ else
+ if max + sz > 0 then max + sz else 0
+ in
+ let out = String.create sz in
+ if ring.pwrap then (
+ let left_end = ring.sz - ring.cons in
+ if sz > left_end then (
+ String.blit ring.data ring.cons out 0 left_end;
+ String.blit ring.data 0 out left_end (sz - left_end);
+ ) else
+ String.blit ring.data ring.cons out 0 sz;
+ ) else
+ String.blit ring.data ring.cons out 0 sz;
+ adv_cons ring sz;
+ out
+
+let consume_all ring = consume ring (max_int)
+
+let skip ring n =
+ let max = to_consume ring in
+ let n = if n > max then max else n in
+ adv_cons ring n
+
+let feed_data ring data =
+ let len = String.length data in
+ let max = to_fill ring in
+ if len > max then
+ raise Data_limit;
+ if ring.prod + len > ring.sz then (
+ let firstblitsz = ring.sz - ring.prod in
+ String.blit data 0 ring.data ring.prod firstblitsz;
+ String.blit data firstblitsz ring.data 0 (len - firstblitsz);
+ ) else
+ String.blit data 0 ring.data ring.prod len;
+ adv_prod ring len;
+ ()
+
+(* read and search directly to the qring.
+ * since we have give a continuous buffer, we limit our read length to the
+ * maximum continous length instead of the full length of the qring left.
+ * after the read, piggyback into the new data.
+ *)
+let read_search ring fread fsearch len =
+ let prod = ring.prod in
+ let maxlen =
+ if ring.pwrap
+ then ring.cons - ring.prod
+ else ring.sz - ring.prod
+ in
+ if maxlen = 0 then
+ raise Full;
+ let len = if maxlen < len then maxlen else len in
+ let n = fread ring.data prod len in
+ if n > 0 then (
+ adv_prod ring n;
+ fsearch ring.data prod n
+ );
+ n
+
+let search ring c =
+ let search_from_to f t =
+ let found = ref false in
+ let i = ref f in
+ while not !found && !i < t
+ do
+ if ring.data.[!i] = c then
+ found := true
+ else
+ incr i
+ done;
+ if not !found then
+ raise Not_found;
+ !i - f
+ in
+ if is_empty ring then
+ raise Not_found;
+ if ring.pwrap then (
+ try search_from_to ring.cons ring.sz
+ with Not_found -> search_from_to 0 ring.prod
+ ) else
+ search_from_to ring.cons ring.prod
--- /dev/null
+type t = {
+ sz: int;
+ data: string;
+ mutable prod: int;
+ mutable cons: int;
+ mutable pwrap: bool;
+}
+
+exception Data_limit
+exception Full
+
+val make : int -> t
+
+val to_consume : t -> int
+val to_fill : t -> int
+
+val is_full : t -> bool
+val is_empty : t -> bool
+
+val consume : t -> int -> string
+val consume_all : t -> string
+val skip : t -> int -> unit
+
+val feed_data : t -> string -> unit
+val read_search : t -> (string -> int -> int -> int)
+ -> (string -> int -> int -> unit) -> int
+ -> int
+val search : t -> char -> int
--- /dev/null
+type t = { l : int; u : int }
+
+let make l u =
+ if l <= u then { l = l; u = u } else invalid_arg "Range.make"
+
+let get r = r.l, r.u
+
+let mem i r = r.l <= i && i < r.u
+
+let rec fold_left_aux f accu l u =
+ if l < u then
+ fold_left_aux f (f accu l) (l + 1) u
+ else accu
+
+let fold_left f accu r = fold_left_aux f accu r.l r.u
+
+let rec fold_right_aux f l u accu =
+ if l < u then
+ let u = u - 1 in
+ fold_right_aux f l u (f u accu)
+ else
+ accu
+
+let fold_right f r accu = fold_right_aux f r.l r.u accu
+
+let string_of_range r =
+ "[" ^ string_of_int r.l ^ ", " ^ string_of_int r.u ^ ")"
+
+let to_list r =
+ fold_right (fun x y -> x :: y) r []
+
--- /dev/null
+type t
+
+(** Make a range. *)
+val make : int -> int -> t
+
+(** Extract the start and end of the given range. *)
+val get : t -> int * int
+
+(** Test the given int for membership in the given range. *)
+val mem : int -> t -> bool
+
+(** Fold over a range, starting at the smallest int. *)
+val fold_left : ('a -> int -> 'a) -> 'a -> t -> 'a
+
+(** Fold over a range, starting at the largest int. *)
+val fold_right : (int -> 'a -> 'a) -> t -> 'a -> 'a
+
+(** Convert a range to a list of ascending integers *)
+val to_list : t -> int list
+
--- /dev/null
+(*
+ * Copyright (c) 2006 XenSource Ltd.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ *
+ * All rights reserved.
+ *)
+
+type 'a t = { size: int; mutable current: int; data: 'a array; }
+
+(** create a ring structure with @size record. records inited to @initval *)
+let make size initval =
+ { size = size; current = size - 1; data = Array.create size initval; }
+
+(** length of the ring *)
+let length ring = ring.size
+
+(** push into the ring one element *)
+let push ring e =
+ ring.current <- ring.current + 1;
+ if ring.current = ring.size then
+ ring.current <- 0;
+ ring.data.(ring.current) <- e
+
+(** get the @ith old element from the ring *)
+let peek ring i =
+ if i >= ring.size then
+ raise (Invalid_argument "peek: index");
+ let index =
+ let offset = ring.current - i in
+ if offset >= 0 then offset else ring.size + offset in
+ ring.data.(index)
+
+(** get the top element of the ring *)
+let top ring = ring.data.(ring.current)
+
+(** iterate over nb element of the ring, starting from the top *)
+let iter_nb ring f nb =
+ if nb > ring.size then
+ raise (Invalid_argument "iter_nb: nb");
+ (* FIXME: OPTIMIZE ME with 2 Array.iter ? *)
+ for i = 0 to nb - 1
+ do
+ f (peek ring i)
+ done
+
+(** iter directly on all element without using the index *)
+let raw_iter ring f =
+ Array.iter f ring.data
+
+(** iterate over all element of the ring, starting from the top *)
+let iter ring f = iter_nb ring f (ring.size)
+
+(** get array of latest #nb value *)
+let get_nb ring nb =
+ if nb > ring.size then
+ raise (Invalid_argument "get_nb: nb");
+ let a = Array.create nb (top ring) in
+ for i = 1 to nb - 1
+ do
+ (* FIXME: OPTIMIZE ME with 2 Array.blit *)
+ a.(i) <- peek ring i
+ done;
+ a
+
+let get ring = get_nb ring (ring.size)
--- /dev/null
+type 'a t = { size : int; mutable current : int; data : 'a array; }
+val make : int -> 'a -> 'a t
+val length : 'a t -> int
+val push : 'a t -> 'a -> unit
+val peek : 'a t -> int -> 'a
+val top : 'a t -> 'a
+val iter_nb : 'a t -> ('a -> 'b) -> int -> unit
+val raw_iter : 'a t -> ('a -> unit) -> unit
+val iter : 'a t -> ('a -> 'b) -> unit
+val get_nb : 'a t -> int -> 'a array
+val get : 'a t -> 'a array
--- /dev/null
+module String = struct include String
+
+let of_char c = String.make 1 c
+
+let init n f =
+ let string = make n (f 0) in
+ for i=1 to n-1 do
+ string.[i] <- f i;
+ done;
+ string
+
+let map f string =
+ init (length string) (fun i -> f string.[i])
+
+let rev_map f string =
+ let n = length string in
+ init n (fun i -> f string.[n - i - 1])
+
+let rev_iter f string =
+ for i = length string - 1 downto 0 do
+ f (string.[i])
+ done
+
+let fold_left f accu string =
+ let accu = ref accu in
+ for i = 0 to length string - 1 do
+ accu := f !accu string.[i]
+ done;
+ !accu
+
+let iteri f string =
+ for i = 0 to length string - 1 do
+ f i string.[i]
+ done
+
+let fold_right f string accu =
+ let accu = ref accu in
+ for i = length string - 1 downto 0 do
+ accu := f string.[i] !accu
+ done;
+ !accu
+
+let explode string =
+ fold_right (fun h t -> h :: t) string []
+
+let implode list =
+ concat "" (List.map of_char list)
+
+(** True if string 'x' ends with suffix 'suffix' *)
+let endswith suffix x =
+ let x_l = String.length x and suffix_l = String.length suffix in
+ suffix_l <= x_l && String.sub x (x_l - suffix_l) suffix_l = suffix
+
+(** True if string 'x' starts with prefix 'prefix' *)
+let startswith prefix x =
+ let x_l = String.length x and prefix_l = String.length prefix in
+ prefix_l <= x_l && String.sub x 0 prefix_l = prefix
+
+(** Returns true for whitespace characters, false otherwise *)
+let isspace = function
+ | ' ' | '\n' | '\r' | '\t' -> true
+ | _ -> false
+
+(** Removes all the characters from the ends of a string for which the predicate is true *)
+let strip predicate string =
+ let rec remove = function
+ | [] -> []
+ | c :: cs -> if predicate c then remove cs else c :: cs in
+ implode (List.rev (remove (List.rev (remove (explode string)))))
+
+let escaped ?rules string = match rules with
+ | None -> String.escaped string
+ | Some rules ->
+ let aux h t = (try List.assoc h rules
+ with Not_found -> of_char h) :: t in
+ concat "" (fold_right aux string [])
+
+(** Take a predicate and a string, return a list of strings separated by
+runs of characters where the predicate was true *)
+let split_f p str =
+ let not_p = fun x -> not (p x) in
+ let rec split_one p acc = function
+ | [] -> List.rev acc, []
+ | c :: cs -> if p c then split_one p (c :: acc) cs else List.rev acc, c :: cs in
+
+ let rec alternate acc drop chars =
+ if chars = [] then acc else
+ begin
+ let a, b = split_one (if drop then p else not_p) [] chars in
+ alternate (if drop then acc else a :: acc) (not drop) b
+ end in
+ List.rev (List.map implode (alternate [] true (explode str)))
+
+let rec split ?limit:(limit=(-1)) c s =
+ let i = try String.index s c with Not_found -> -1 in
+ let nlimit = if limit = -1 || limit = 0 then limit else limit - 1 in
+ if i = -1 || nlimit = 0 then
+ [ s ]
+ else
+ let a = String.sub s 0 i
+ and b = String.sub s (i + 1) (String.length s - i - 1) in
+ a :: (split ~limit: nlimit c b)
+
+let rtrim s =
+ let n = String.length s in
+ if String.get s (n - 1) = '\n' then
+ String.sub s 0 (n - 1)
+ else
+ s
+
+(** has_substr str sub returns true if sub is a substring of str. Simple, naive, slow. *)
+let has_substr str sub =
+ if String.length sub > String.length str then false else
+ begin
+ let result=ref false in
+ for start = 0 to (String.length str) - (String.length sub) do
+ if String.sub str start (String.length sub) = sub then result := true
+ done;
+ !result
+ end
+
+(** find all occurences of needle in haystack and return all their respective index *)
+let find_all needle haystack =
+ let m = String.length needle and n = String.length haystack in
+
+ if m > n then
+ []
+ else (
+ let i = ref 0 and found = ref [] in
+ while !i < (n - m + 1)
+ do
+ if (String.sub haystack !i m) = needle then (
+ found := !i :: !found;
+ i := !i + m
+ ) else (
+ incr i
+ )
+ done;
+ List.rev !found
+ )
+
+(* replace all @f substring in @s by @t *)
+let replace f t s =
+ let indexes = find_all f s in
+ let n = List.length indexes in
+ if n > 0 then (
+ let len_f = String.length f and len_t = String.length t in
+ let new_len = String.length s + (n * len_t) - (n * len_f) in
+ let new_s = String.make new_len '\000' in
+ let orig_offset = ref 0 and dest_offset = ref 0 in
+ List.iter (fun h ->
+ let len = h - !orig_offset in
+ String.blit s !orig_offset new_s !dest_offset len;
+ String.blit t 0 new_s (!dest_offset + len) len_t;
+ orig_offset := !orig_offset + len + len_f;
+ dest_offset := !dest_offset + len + len_t;
+ ) indexes;
+ String.blit s !orig_offset new_s !dest_offset (String.length s - !orig_offset);
+ new_s
+ ) else
+ s
+
+let filter_chars s valid =
+ let badchars = ref false in
+ let buf = Buffer.create 0 in
+ for i = 0 to String.length s - 1
+ do
+ if !badchars then (
+ if valid s.[i] then
+ Buffer.add_char buf s.[i]
+ ) else (
+ if not (valid s.[i]) then (
+ Buffer.add_substring buf s 0 i;
+ badchars := true
+ )
+ )
+ done;
+ if !badchars then Buffer.contents buf else s
+
+let map_unlikely s f =
+ let changed = ref false in
+ let m = ref 0 in
+ let buf = Buffer.create 0 in
+ for i = 0 to String.length s - 1
+ do
+ match f s.[i] with
+ | None -> ()
+ | Some n ->
+ changed := true;
+ Buffer.add_substring buf s !m (i - !m);
+ Buffer.add_string buf n;
+ m := i + 1
+ done;
+ if !changed then (
+ Buffer.add_substring buf s !m (String.length s - !m);
+ Buffer.contents buf
+ ) else
+ s
+
+let sub_to_end s start =
+ let length = String.length s in
+ String.sub s start (length - start)
+
+end
--- /dev/null
+module String :
+ sig
+ external length : string -> int = "%string_length"
+ external get : string -> int -> char = "%string_safe_get"
+ external set : string -> int -> char -> unit = "%string_safe_set"
+ external create : int -> string = "caml_create_string"
+ val make : int -> char -> string
+ val copy : string -> string
+ val sub : string -> int -> int -> string
+ val fill : string -> int -> int -> char -> unit
+ val blit : string -> int -> string -> int -> int -> unit
+ val concat : string -> string list -> string
+ val iter : (char -> unit) -> string -> unit
+ val index : string -> char -> int
+ val rindex : string -> char -> int
+ val index_from : string -> int -> char -> int
+ val rindex_from : string -> int -> char -> int
+ val contains : string -> char -> bool
+ val contains_from : string -> int -> char -> bool
+ val rcontains_from : string -> int -> char -> bool
+ val uppercase : string -> string
+ val lowercase : string -> string
+ val capitalize : string -> string
+ val uncapitalize : string -> string
+ type t = string
+ val compare : t -> t -> int
+ external unsafe_get : string -> int -> char = "%string_unsafe_get"
+ external unsafe_set : string -> int -> char -> unit
+ = "%string_unsafe_set"
+ external unsafe_blit : string -> int -> string -> int -> int -> unit
+ = "caml_blit_string" "noalloc"
+ external unsafe_fill : string -> int -> int -> char -> unit
+ = "caml_fill_string" "noalloc"
+ val of_char : char -> string
+
+ (** Make a string of the given length with characters generated by the
+ given function. *)
+ val init : int -> (int -> char) -> string
+
+ (** Map a string to a string. *)
+ val map : (char -> char) -> string -> string
+
+ (** Map a string to a string, applying the given function in reverse
+ order. *)
+ val rev_map : (char -> char) -> string -> string
+
+ (** Iterate over the characters in a string in reverse order. *)
+ val rev_iter : (char -> 'a) -> string -> unit
+
+ (** Fold over the characters in a string. *)
+ val fold_left : ('a -> char -> 'a) -> 'a -> string -> 'a
+
+ (** Iterate over the characters with the character index in argument *)
+ val iteri : (int -> char -> 'a) -> string -> unit
+
+ (** Iterate over the characters in a string in reverse order. *)
+ val fold_right : (char -> 'a -> 'a) -> string -> 'a -> 'a
+
+ (** Split a string into a list of characters. *)
+ val explode : string -> char list
+
+ (** Concatenate a list of characters into a string. *)
+ val implode : char list -> string
+
+ (** True if string 'x' ends with suffix 'suffix' *)
+ val endswith : string -> string -> bool
+
+ (** True if string 'x' starts with prefix 'prefix' *)
+ val startswith : string -> string -> bool
+
+ (** True if the character is whitespace *)
+ val isspace : char -> bool
+
+ (** Removes all the characters from the ends of a string for which the predicate is true *)
+ val strip : (char -> bool) -> string -> string
+
+ (** Backward-compatible string escaping, defaulting to the built-in
+ OCaml string escaping but allowing an arbitrary mapping from characters
+ to strings. *)
+ val escaped : ?rules:(char * string) list -> string -> string
+
+ (** Take a predicate and a string, return a list of strings separated by
+ runs of characters where the predicate was true *)
+ val split_f : (char -> bool) -> string -> string list
+
+ (** split a string on a single char *)
+ val split : ?limit:int -> char -> string -> string list
+
+ (** FIXME document me|remove me if similar to strip *)
+ val rtrim : string -> string
+
+ (** True if sub is a substr of str *)
+ val has_substr : string -> string -> bool
+
+(** find all occurences of needle in haystack and return all their respective index *)
+ val find_all : string -> string -> int list
+
+ (** replace all @f substring in @s by @t *)
+ val replace : string -> string -> string -> string
+
+ (** filter chars from a string *)
+ val filter_chars : string -> (char -> bool) -> string
+
+ (** map a string trying to fill the buffer by chunk *)
+ val map_unlikely : string -> (char -> string option) -> string
+
+ (** a substring from the specified position to the end of the string *)
+ val sub_to_end : string -> int -> string
+ end
--- /dev/null
+(*
+ * Copyright (C) 2006 XenSource Ltd.
+ * Author: Vincent Hanquez <vincent@xensource.com>
+ * Author: Anil Madhavapeddy <anil@xensource.com>
+ *)
+
+module Mutex = struct
+ include Mutex
+ (** execute the function f with the mutex hold *)
+ let execute lock f =
+ Mutex.lock lock;
+ let r = begin try f () with exn -> Mutex.unlock lock; raise exn end; in
+ Mutex.unlock lock;
+ r
+end
+
+(** create thread loops which periodically applies a function *)
+module Thread_loop
+ : functor (Tr : sig type t val delay : unit -> float end) ->
+ sig
+ val start : Tr.t -> (unit -> unit) -> unit
+ val stop : Tr.t -> unit
+ val update : Tr.t -> (unit -> unit) -> unit
+ end
+ = functor (Tr: sig type t val delay : unit -> float end) -> struct
+
+ exception Done_loop
+ let ref_table : ((Tr.t,(Mutex.t * Thread.t * bool ref)) Hashtbl.t) =
+ Hashtbl.create 1
+
+ (** Create a thread which periodically applies a function to the
+ reference specified, and exits cleanly when removed *)
+ let start xref fn =
+ let mut = Mutex.create () in
+ let exit_var = ref false in
+ (* create thread which periodically applies the function *)
+ let tid = Thread.create (fun () ->
+ try while true do
+ Thread.delay (Tr.delay ());
+ Mutex.execute mut (fun () ->
+ if !exit_var then
+ raise Done_loop;
+ let () = fn () in ()
+ );
+ done; with Done_loop -> ();
+ ) () in
+ (* create thread to manage the reference table and clean it up
+ safely once the delay thread is removed *)
+ let _ = Thread.create (fun () ->
+ Hashtbl.add ref_table xref (mut,tid,exit_var);
+ Thread.join tid;
+ List.iter (fun (_,t,_) ->
+ if tid = t then Hashtbl.remove ref_table xref
+ ) (Hashtbl.find_all ref_table xref)
+ ) () in ()
+
+ (** Remove a reference from the thread table *)
+ let stop xref =
+ try let mut,_,exit_ref = Hashtbl.find ref_table xref in
+ Mutex.execute mut (fun () -> exit_ref := true)
+ with Not_found -> ()
+
+ (** Replace a thread with another one *)
+ let update xref fn =
+ stop xref;
+ start xref fn
+end
+
+(** Parallel List.iter. Remembers all exceptions and returns an association list mapping input x to an exception.
+ Applications of x which succeed will be missing from the returned list. *)
+let thread_iter_all_exns f xs =
+ let exns = ref [] in
+ let m = Mutex.create () in
+ List.iter
+ Thread.join
+ (List.map
+ (fun x ->
+ Thread.create
+ (fun () ->
+ try
+ f x
+ with e -> Mutex.execute m (fun () -> exns := (x, e) :: !exns)
+ )
+ ()
+ ) xs);
+ !exns
+
+(** Parallel List.iter. Remembers one exception (at random) and throws it in the
+ error case. *)
+let thread_iter f xs = match thread_iter_all_exns f xs with
+ | [] -> ()
+ | (_, e) :: _ -> raise e
+
+module Delay = struct
+ (* Concrete type is the ends of a pipe *)
+ type t = {
+ (* A pipe is used to wake up a thread blocked in wait: *)
+ mutable pipe_out: Unix.file_descr option;
+ mutable pipe_in: Unix.file_descr option;
+ (* Indicates that a signal arrived before a wait: *)
+ mutable signalled: bool;
+ m: Mutex.t
+ }
+
+ let make () =
+ { pipe_out = None;
+ pipe_in = None;
+ signalled = false;
+ m = Mutex.create () }
+
+ exception Pre_signalled
+
+ let wait (x: t) (seconds: float) =
+ let to_close = ref [ ] in
+ let close' fd =
+ if List.mem fd !to_close then Unix.close fd;
+ to_close := List.filter (fun x -> fd <> x) !to_close in
+ Pervasiveext.finally
+ (fun () ->
+ try
+ let pipe_out = Mutex.execute x.m
+ (fun () ->
+ if x.signalled then begin
+ x.signalled <- false;
+ raise Pre_signalled;
+ end;
+ let pipe_out, pipe_in = Unix.pipe () in
+ (* these will be unconditionally closed on exit *)
+ to_close := [ pipe_out; pipe_in ];
+ x.pipe_out <- Some pipe_out;
+ x.pipe_in <- Some pipe_in;
+ x.signalled <- false;
+ pipe_out) in
+ let r, _, _ = Unix.select [ pipe_out ] [] [] seconds in
+ (* flush the single byte from the pipe *)
+ if r <> [] then ignore(Unix.read pipe_out (String.create 1) 0 1);
+ (* return true if we waited the full length of time, false if we were woken *)
+ r = []
+ with Pre_signalled -> false
+ )
+ (fun () ->
+ Mutex.execute x.m
+ (fun () ->
+ x.pipe_out <- None;
+ x.pipe_in <- None;
+ List.iter close' !to_close)
+ )
+
+ let signal (x: t) =
+ Mutex.execute x.m
+ (fun () ->
+ match x.pipe_in with
+ | Some fd -> ignore(Unix.write fd "X" 0 1)
+ | None -> x.signalled <- true (* If the wait hasn't happened yet then store up the signal *)
+ )
+end
--- /dev/null
+module Mutex :
+ sig
+ type t = Mutex.t
+ val create : unit -> t
+ val lock : t -> unit
+ val try_lock : t -> bool
+ val unlock : t -> unit
+ val execute : Mutex.t -> (unit -> 'a) -> 'a
+ end
+module Thread_loop :
+ functor (Tr : sig type t val delay : unit -> float end) ->
+ sig
+ val start : Tr.t -> (unit -> unit) -> unit
+ val stop : Tr.t -> unit
+ val update : Tr.t -> (unit -> unit) -> unit
+ end
+val thread_iter_all_exns: ('a -> unit) -> 'a list -> ('a * exn) list
+val thread_iter: ('a -> unit) -> 'a list -> unit
+
+module Delay :
+ sig
+ type t
+ val make : unit -> t
+ (** Blocks the calling thread for a given period of time with the option of
+ returning early if someone calls 'signal'. Returns true if the full time
+ period elapsed and false if signalled. Note that multple 'signals' are
+ coalesced; 'signals' sent before 'wait' is called are not lost. *)
+ val wait : t -> float -> bool
+ (** Sends a signal to a waiting thread. See 'wait' *)
+ val signal : t -> unit
+ end
--- /dev/null
+module Node =
+struct
+ type ('a,'b) t = {
+ key: 'a;
+ value: 'b option;
+ children: ('a,'b) t list;
+ }
+
+ let create key value = {
+ key = key;
+ value = Some value;
+ children = [];
+ }
+
+ let empty key = {
+ key = key;
+ value = None;
+ children = []
+ }
+
+ let get_key node = node.key
+ let get_value node =
+ match node.value with
+ | None -> raise Not_found
+ | Some value -> value
+
+ let get_children node = node.children
+
+ let set_value node value =
+ { node with value = Some value }
+ let set_children node children =
+ { node with children = children }
+
+ let add_child node child =
+ { node with children = child :: node.children }
+end
+
+type ('a,'b) t = ('a,'b) Node.t list
+
+let mem_node nodes key =
+ List.exists (fun n -> n.Node.key = key) nodes
+
+let find_node nodes key =
+ List.find (fun n -> n.Node.key = key) nodes
+
+let replace_node nodes key node =
+ let rec aux = function
+ | [] -> []
+ | h :: tl when h.Node.key = key -> node :: tl
+ | h :: tl -> h :: aux tl
+ in
+ aux nodes
+
+let remove_node nodes key =
+ let rec aux = function
+ | [] -> raise Not_found
+ | h :: tl when h.Node.key = key -> tl
+ | h :: tl -> h :: aux tl
+ in
+ aux nodes
+
+let create () = []
+
+let rec iter f tree =
+ let rec aux node =
+ f node.Node.key node.Node.value;
+ iter f node.Node.children
+ in
+ List.iter aux tree
+
+let rec map f tree =
+ let rec aux node =
+ let value =
+ match node.Node.value with
+ | None -> None
+ | Some value -> f value
+ in
+ { node with Node.value = value; Node.children = map f node.Node.children }
+ in
+ List.filter (fun n -> n.Node.value <> None || n.Node.children <> []) (List.map aux tree)
+
+let rec fold f tree acc =
+ let rec aux accu node =
+ fold f node.Node.children (f node.Node.key node.Node.value accu)
+ in
+ List.fold_left aux acc tree
+
+(* return a sub-trie *)
+let rec sub_node tree = function
+ | [] -> raise Not_found
+ | h::t ->
+ if mem_node tree h
+ then begin
+ let node = find_node tree h in
+ if t = []
+ then node
+ else sub_node node.Node.children t
+ end else
+ raise Not_found
+
+let sub tree path =
+ try (sub_node tree path).Node.children
+ with Not_found -> []
+
+let find tree path =
+ Node.get_value (sub_node tree path)
+
+(* return false if the node doesn't exists or if it is not associated to any value *)
+let rec mem tree = function
+ | [] -> false
+ | h::t ->
+ mem_node tree h
+ && (let node = find_node tree h in
+ if t = []
+ then node.Node.value <> None
+ else mem node.Node.children t)
+
+(* Iterate over the longest valid prefix *)
+let rec iter_path f tree = function
+ | [] -> ()
+ | h::l ->
+ if mem_node tree h
+ then begin
+ let node = find_node tree h in
+ f node.Node.key node.Node.value;
+ iter_path f node.Node.children l
+ end
+
+let rec set_node node path value =
+ if path = []
+ then Node.set_value node value
+ else begin
+ let children = set node.Node.children path value in
+ Node.set_children node children
+ end
+
+and set tree path value =
+ match path with
+ | [] -> raise Not_found
+ | h::t ->
+ if mem_node tree h
+ then begin
+ let node = find_node tree h in
+ replace_node tree h (set_node node t value)
+ end else begin
+ let node = Node.empty h in
+ set_node node t value :: tree
+ end
+
+let rec unset tree = function
+ | [] -> tree
+ | h::t ->
+ if mem_node tree h
+ then begin
+ let node = find_node tree h in
+ let children = unset node.Node.children t in
+ let new_node =
+ if t = []
+ then Node.set_children (Node.empty h) children
+ else Node.set_children node children
+ in
+ if children = [] && new_node.Node.value = None
+ then remove_node tree h
+ else replace_node tree h new_node
+ end else
+ raise Not_found
+
--- /dev/null
+(** Basic Implementation of polymorphic tries (ie. prefix trees) *)
+
+type ('a, 'b) t
+(** The type of tries. ['a list] is the type of keys, ['b] the type of values.
+ Internally, a trie is represented as a labeled tree, where node contains values
+ of type ['a * 'b option]. *)
+
+val create : unit -> ('a,'b) t
+(** Creates an empty trie. *)
+
+val mem : ('a,'b) t -> 'a list -> bool
+(** [mem t k] returns true if a value is associated with the key [k] in the trie [t].
+ Otherwise, it returns false. *)
+
+val find : ('a, 'b) t -> 'a list -> 'b
+(** [find t k] returns the value associated with the key [k] in the trie [t].
+ Returns [Not_found] if no values are associated with [k] in [t]. *)
+
+val set : ('a, 'b) t -> 'a list -> 'b -> ('a, 'b) t
+(** [set t k v] associates the value [v] with the key [k] in the trie [t]. *)
+
+val unset : ('a, 'b) t -> 'a list -> ('a, 'b) t
+(** [unset k v] removes the association of value [v] with the key [k] in the trie [t].
+ Moreover, it automatically clean the trie, ie. it removes recursively
+ every nodes of [t] containing no values and having no chil. *)
+
+val iter : ('a -> 'b option -> unit) -> ('a, 'b) t -> unit
+(** [iter f t] applies the function [f] to every node of the trie [t].
+ As nodes of the trie [t] do not necessary contains a value, the second argument of
+ [f] is an option type. *)
+
+val iter_path : ('a -> 'b option -> unit) -> ('a, 'b) t -> 'a list -> unit
+(** [iter_path f t p] iterates [f] over nodes associated with the path [p] in the trie [t].
+ If [p] is not a valid path of [t], it iterates on the longest valid prefix of [p]. *)
+
+val fold : ('a -> 'b option -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c
+(** [fold f t x] fold [f] over every nodes of [t], with [x] as initial value. *)
+
+val map : ('b -> 'c option) -> ('a,'b) t -> ('a,'c) t
+(** [map f t] maps [f] over every values stored in [t]. The return value of [f] is of type 'c option
+ as one may wants to remove value associated to a key. This function is not tail-recursive. *)
+
+val sub : ('a, 'b) t -> 'a list -> ('a,'b) t
+(** [sub t p] returns the sub-trie associated with the path [p] in the trie [t].
+ If [p] is not a valid path of [t], it returns an empty trie. *)
--- /dev/null
+open Pervasiveext
+
+exception Unix_error of int
+
+external _exit : int -> unit = "unix_exit"
+
+(** remove a file, but doesn't raise an exception if the file is already removed *)
+let unlink_safe file =
+ try Unix.unlink file with (* Unix.Unix_error (Unix.ENOENT, _ , _)*) _ -> ()
+
+(** create a directory but doesn't raise an exception if the directory already exist *)
+let mkdir_safe dir perm =
+ try Unix.mkdir dir perm with Unix.Unix_error (Unix.EEXIST, _, _) -> ()
+
+(** create a directory, and create parent if doesn't exist *)
+let mkdir_rec dir perm =
+ let rec p_mkdir dir =
+ let p_name = Filename.dirname dir in
+ if p_name <> "/" && p_name <> "."
+ then p_mkdir p_name;
+ mkdir_safe dir perm in
+ p_mkdir dir
+
+(** write a pidfile file *)
+let pidfile_write filename =
+ let fd = Unix.openfile filename
+ [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; ]
+ 0o640 in
+ finally
+ (fun () ->
+ let pid = Unix.getpid () in
+ let buf = string_of_int pid ^ "\n" in
+ let len = String.length buf in
+ if Unix.write fd buf 0 len <> len
+ then failwith "pidfile_write failed";
+ )
+ (fun () -> Unix.close fd)
+
+(** read a pidfile file, return either Some pid or None *)
+let pidfile_read filename =
+ let fd = Unix.openfile filename [ Unix.O_RDONLY ] 0o640 in
+ finally
+ (fun () ->
+ try
+ let buf = String.create 80 in
+ let rd = Unix.read fd buf 0 (String.length buf) in
+ if rd = 0 then
+ failwith "pidfile_read failed";
+ Scanf.sscanf (String.sub buf 0 rd) "%d" (fun i -> Some i)
+ with exn -> None)
+ (fun () -> Unix.close fd)
+
+(** daemonize a process *)
+(* !! Must call this before spawning any threads !! *)
+let daemonize () =
+ match Unix.fork () with
+ | 0 ->
+ if Unix.setsid () == -1 then
+ failwith "Unix.setsid failed";
+
+ begin match Unix.fork () with
+ | 0 ->
+ let nullfd = Unix.openfile "/dev/null" [ Unix.O_WRONLY ] 0 in
+ begin try
+ Unix.close Unix.stdin;
+ Unix.dup2 nullfd Unix.stdout;
+ Unix.dup2 nullfd Unix.stderr;
+ with exn -> Unix.close nullfd; raise exn
+ end;
+ Unix.close nullfd
+ | _ -> exit 0
+ end
+ | _ -> exit 0
+
+(** Run a function over every line in a file *)
+let readfile_line fn fname =
+ let fin = open_in fname in
+ try
+ while true do
+ let line = input_line fin in
+ fn line
+ done;
+ close_in fin;
+ with
+ | End_of_file -> close_in fin
+ | exn -> close_in fin; raise exn
+
+(** open a file, and make sure the close is always done *)
+let with_file file mode perms f =
+ let fd = Unix.openfile file mode perms in
+ let r =
+ try f fd
+ with exn -> Unix.close fd; raise exn
+ in
+ Unix.close fd;
+ r
+
+let with_directory dir f =
+ let dh = Unix.opendir dir in
+ let r =
+ try f dh
+ with exn -> Unix.closedir dh; raise exn
+ in
+ Unix.closedir dh;
+ r
+
+(** Read whole file from specified fd *)
+let read_whole_file size_hint block_size fd =
+ let filebuf = Buffer.create size_hint in
+ let blockbuf = String.create block_size in
+ let rec do_read() =
+ let nread = Unix.read fd blockbuf 0 block_size in
+ if nread=0 then
+ Buffer.contents filebuf
+ else
+ begin
+ Buffer.add_substring filebuf blockbuf 0 nread;
+ do_read()
+ end in
+ do_read()
+
+(** Read whole file into string *)
+let read_whole_file_to_string fname =
+ with_file fname [ Unix.O_RDONLY ] 0o0 (read_whole_file 1024 1024)
+
+(** Opens a temp file, applies the fd to the function, when the function completes, renames the file
+ as required. *)
+let atomic_write_to_file fname f =
+ let tmp = Filenameext.temp_file_in_dir fname in
+ Pervasiveext.finally
+ (fun () ->
+ let fd = Unix.openfile tmp [Unix.O_WRONLY; Unix.O_CREAT] 0o644 in
+ let result = Pervasiveext.finally
+ (fun () -> f fd)
+ (fun () -> Unix.close fd) in
+ Unix.rename tmp fname; (* Nb this only happens if an exception wasn't raised in the application of f *)
+ result)
+ (fun () -> unlink_safe tmp)
+
+
+(** Atomically write a string to a file *)
+let write_string_to_file fname s =
+ atomic_write_to_file fname (fun fd ->
+ let len = String.length s in
+ let written = Unix.write fd s 0 len in
+ if written <> len then (failwith "Short write occured!"))
+
+
+let execv_get_output cmd args =
+ let (pipe_exit, pipe_entrance) = Unix.pipe () in
+ let r = try Unix.set_close_on_exec pipe_exit; true with _ -> false in
+ match Unix.fork () with
+ | 0 ->
+ Unix.dup2 pipe_entrance Unix.stdout;
+ Unix.close pipe_entrance;
+ if not r then
+ Unix.close pipe_exit;
+ begin try Unix.execv cmd args with _ -> exit 127 end
+ | pid ->
+ Unix.close pipe_entrance;
+ pid, pipe_exit
+
+(** Copy all data from an in_channel to an out_channel,
+ * returning the total number of bytes *)
+let copy_file ?limit ifd ofd =
+ let buffer = String.make 65536 '\000' in
+ let buffer_len = Int64.of_int (String.length buffer) in
+ let finished = ref false in
+ let total_bytes = ref 0L in
+ let limit = ref limit in
+ while not(!finished) do
+ let requested = min (Opt.default buffer_len !limit) buffer_len in
+ let num = Unix.read ifd buffer 0 (Int64.to_int requested) in
+ let num64 = Int64.of_int num in
+
+ limit := Opt.map (fun x -> Int64.sub x num64) !limit;
+ Unix.write ofd buffer 0 num;
+ total_bytes := Int64.add !total_bytes num64;
+ finished := num = 0 || !limit = Some 0L;
+ done;
+ !total_bytes
+
+let file_exists file_path =
+ try Unix.access file_path [Unix.F_OK]; true
+ with _ -> false
+
+let touch_file file_path =
+ let fd = Unix.openfile file_path
+ [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_NOCTTY; Unix.O_NONBLOCK] 0o666 in
+ Unix.close fd;
+ Unix.utimes file_path 0.0 0.0
+
+let is_empty_file file_path =
+ try
+ let stats = Unix.stat file_path in
+ stats.Unix.st_size = 0
+ with Unix.Unix_error (Unix.ENOENT, _, _) ->
+ false
+
+let delete_empty_file file_path =
+ if is_empty_file file_path
+ then (Sys.remove file_path; true)
+ else (false)
+
+(** Create a new file descriptor, connect it to host:port and return it *)
+exception Host_not_found of string
+let open_connection_fd host port =
+ let s = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
+ try
+ let he =
+ try
+ Unix.gethostbyname host
+ with
+ Not_found -> raise (Host_not_found host) in
+ if Array.length he.Unix.h_addr_list = 0
+ then failwith (Printf.sprintf "Couldn't resolve hostname: %s" host);
+ let ip = he.Unix.h_addr_list.(0) in
+ let addr = Unix.ADDR_INET(ip, port) in
+ Unix.connect s addr;
+ s
+ with e -> Unix.close s; raise e
+
+
+let open_connection_unix_fd filename =
+ let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
+ try
+ let addr = Unix.ADDR_UNIX(filename) in
+ Unix.connect s addr;
+ s
+ with e -> Unix.close s; raise e
+
+type endpoint = { fd: Unix.file_descr; mutable buffer: string; mutable buffer_len: int }
+
+let make_endpoint fd = {
+ fd = fd;
+ buffer = String.make 4096 '\000';
+ buffer_len = 0
+}
+
+exception Process_still_alive
+
+let kill_and_wait ?(signal = Sys.sigterm) ?(timeout=10.) pid =
+ let proc_entry_exists pid =
+ try Unix.access (Printf.sprintf "/proc/%d" pid) [ Unix.F_OK ]; true
+ with _ -> false
+ in
+ if pid > 0 && proc_entry_exists pid then (
+ let loop_time_waiting = 0.03 in
+ let left = ref timeout in
+ let readcmdline pid =
+ try read_whole_file_to_string (Printf.sprintf "/proc/%d/cmdline" pid)
+ with _ -> ""
+ in
+ let reference = readcmdline pid and quit = ref false in
+ Unix.kill pid signal;
+
+ (* We cannot do a waitpid here, since we might not be parent of
+ the process, so instead we are waiting for the /proc/%d to go
+ away. Also we verify that the cmdline stay the same if it's still here
+ to prevent the very very unlikely event that the pid get reused before
+ we notice it's gone *)
+ while proc_entry_exists pid && not !quit && !left > 0.
+ do
+ let cmdline = readcmdline pid in
+ if cmdline = reference then (
+ (* still up, let's sleep a bit *)
+ ignore (Unix.select [] [] [] loop_time_waiting);
+ left := !left -. loop_time_waiting
+ ) else (
+ (* not the same, it's gone ! *)
+ quit := true
+ )
+ done;
+ if !left <= 0. then
+ raise Process_still_alive;
+ )
+
+let proxy (a: Unix.file_descr) (b: Unix.file_descr) =
+ let a' = make_endpoint a and b' = make_endpoint b in
+ Unix.set_nonblock a;
+ Unix.set_nonblock b;
+
+ let can_read x =
+ x.buffer_len < (String.length x.buffer - 1) in
+ let can_write x =
+ x.buffer_len > 0 in
+ let write_from x fd =
+ let written = Unix.single_write fd x.buffer 0 x.buffer_len in
+ String.blit x.buffer written x.buffer 0 (x.buffer_len - written);
+ x.buffer_len <- x.buffer_len - written in
+ let read_into x =
+ let read = Unix.read x.fd x.buffer x.buffer_len (String.length x.buffer - x.buffer_len) in
+ if read = 0 then raise End_of_file;
+ x.buffer_len <- x.buffer_len + read in
+
+ try
+ while true do
+ let r = (if can_read a' then [ a ] else []) @ (if can_read b' then [ b ] else []) in
+ let w = (if can_write a' then [ b ] else []) @ (if can_write b' then [ a ] else []) in
+
+ let r, w, _ = Unix.select r w [] (-1.0) in
+ (* Do the writing before the reading *)
+ List.iter (fun fd -> if a = fd then write_from b' a else write_from a' b) w;
+ List.iter (fun fd -> if a = fd then read_into a' else read_into b') r
+ done
+ with _ ->
+ (try Unix.clear_nonblock a with _ -> ());
+ (try Unix.clear_nonblock b with _ -> ());
+ (try Unix.close a with _ -> ());
+ (try Unix.close b with _ -> ())
+
+let rec really_read fd string off n =
+ if n=0 then () else
+ let m = Unix.read fd string off n in
+ if m = 0 then raise End_of_file;
+ really_read fd string (off+m) (n-m)
+
+let really_read_string fd length =
+ let buf = String.make length '\000' in
+ really_read fd buf 0 length;
+ buf
+
+let really_write fd string off n =
+ let written = ref 0 in
+ while !written < n
+ do
+ let wr = Unix.write fd string (off + !written) (n - !written) in
+ written := wr + !written
+ done
+
+(* Ideally, really_write would be implemented with optional arguments ?(off=0) ?(len=String.length string) *)
+let really_write_string fd string =
+ really_write fd string 0 (String.length string)
+
+(* --------------------------------------------------------------------------------------- *)
+(* Functions to read and write to/from a file descriptor with a given latest response time *)
+
+exception Timeout
+
+(* Write as many bytes to a file descriptor as possible from data before a given clock time. *)
+(* Raises Timeout exception if the number of bytes written is less than the specified length. *)
+(* Writes into the file descriptor at the current cursor position. *)
+let time_limited_write filedesc length data target_response_time =
+ let total_bytes_to_write = length in
+ let bytes_written = ref 0 in
+ let now = ref (Unix.gettimeofday()) in
+ while !bytes_written < total_bytes_to_write && !now < target_response_time do
+ let remaining_time = target_response_time -. !now in
+ let (_, ready_to_write, _) = Unix.select [] [filedesc] [] remaining_time in (* Note: there is a possibility that the storage could go away after the select and before the write, so the write would block. *)
+ if List.mem filedesc ready_to_write then begin
+ let bytes_to_write = total_bytes_to_write - !bytes_written in
+ let bytes = (try Unix.write filedesc data !bytes_written bytes_to_write with Unix.Unix_error(Unix.EAGAIN,_,_) | Unix.Unix_error(Unix.EWOULDBLOCK,_,_) -> 0) in (* write from buffer=data from offset=bytes_written, length=bytes_to_write *)
+ bytes_written := bytes + !bytes_written;
+ end;
+ now := Unix.gettimeofday()
+ done;
+ if !bytes_written = total_bytes_to_write then () else (* we ran out of time *) raise Timeout
+
+(* Read as many bytes to a file descriptor as possible before a given clock time. *)
+(* Raises Timeout exception if the number of bytes read is less than the desired number. *)
+(* Reads from the file descriptor at the current cursor position. *)
+let time_limited_read filedesc length target_response_time =
+ let total_bytes_to_read = length in
+ let bytes_read = ref 0 in
+ let buf = String.make total_bytes_to_read '\000' in
+ let now = ref (Unix.gettimeofday()) in
+ while !bytes_read < total_bytes_to_read && !now < target_response_time do
+ let remaining_time = target_response_time -. !now in
+ let (ready_to_read, _, _) = Unix.select [filedesc] [] [] remaining_time in
+ if List.mem filedesc ready_to_read then begin
+ let bytes_to_read = total_bytes_to_read - !bytes_read in
+ let bytes = (try Unix.read filedesc buf !bytes_read bytes_to_read with Unix.Unix_error(Unix.EAGAIN,_,_) | Unix.Unix_error(Unix.EWOULDBLOCK,_,_) -> 0) in (* read into buffer=buf from offset=bytes_read, length=bytes_to_read *)
+ if bytes = 0 then raise End_of_file (* End of file has been reached *)
+ else bytes_read := bytes + !bytes_read
+ end;
+ now := Unix.gettimeofday()
+ done;
+ if !bytes_read = total_bytes_to_read then buf else (* we ran out of time *) raise Timeout
+
+(* --------------------------------------------------------------------------------------- *)
+
+(* Read a given number of bytes of data from the fd, or stop at EOF, whichever comes first. *)
+(* A negative ~max_bytes indicates that all the data should be read from the fd until EOF. This is the default. *)
+let read_data_in_chunks (f : string -> int -> unit) ?(block_size = 1024) ?(max_bytes = -1) from_fd =
+ let buf = String.make block_size '\000' in
+ let rec do_read acc =
+ let remaining_bytes = max_bytes - acc in
+ if remaining_bytes = 0 then acc (* we've read the amount requested *)
+ else begin
+ let bytes_to_read = (if max_bytes < 0 || remaining_bytes > block_size then block_size else remaining_bytes) in
+ let bytes_read = Unix.read from_fd buf 0 bytes_to_read in
+ if bytes_read = 0 then acc (* we reached EOF *)
+ else begin
+ f (String.sub buf 0 bytes_read) bytes_read;
+ do_read (acc + bytes_read)
+ end
+ end in
+ do_read 0
+
+let spawnvp ?(pid_callback=(fun _ -> ())) cmd args =
+ match Unix.fork () with
+ | 0 ->
+ Unix.execvp cmd args
+ | pid ->
+ begin try pid_callback pid with _ -> () end;
+ snd (Unix.waitpid [] pid)
+
+let double_fork f =
+ match Unix.fork () with
+ | 0 ->
+ begin match Unix.fork () with
+ (* NB: use _exit (calls C lib _exit directly) to avoid
+ calling at_exit handlers and flushing output channels
+ which wouild cause intermittent deadlocks if we
+ forked from a threaded program *)
+ | 0 -> (try f () with _ -> ()); _exit 0
+ | _ -> _exit 0
+ end
+ | pid -> ignore(Unix.waitpid [] pid)
+
+external set_tcp_nodelay : Unix.file_descr -> bool -> unit = "stub_unixext_set_tcp_nodelay"
+
+external fsync : Unix.file_descr -> unit = "stub_unixext_fsync"
+
+external get_max_fd : unit -> int = "stub_unixext_get_max_fd"
+
+let int_of_file_descr (x: Unix.file_descr) : int = Obj.magic x
+let file_descr_of_int (x: int) : Unix.file_descr = Obj.magic x
+
+(** Forcibly closes all open file descriptors except those explicitly passed in as arguments.
+ Useful to avoid accidentally passing a file descriptor opened in another thread to a
+ process being concurrently fork()ed (there's a race between open/set_close_on_exec).
+ NB this assumes that 'type Unix.file_descr = int'
+*)
+let close_all_fds_except (fds: Unix.file_descr list) =
+ (* get at the file descriptor within *)
+ let fds' = List.map int_of_file_descr fds in
+ let close' (x: int) =
+ try Unix.close(file_descr_of_int x) with _ -> () in
+
+ let highest_to_keep = List.fold_left max (-1) fds' in
+ (* close all the fds higher than the one we want to keep *)
+ for i = highest_to_keep + 1 to get_max_fd () do close' i done;
+ (* close all the rest *)
+ for i = 0 to highest_to_keep - 1 do
+ if not(List.mem i fds') then close' i
+ done
+
+exception Process_output_error of string
+let get_process_output ?(handler) cmd : string =
+ let inchan = Unix.open_process_in cmd in
+
+ let buffer = Buffer.create 1024
+ and buf = String.make 1024 '\000' in
+
+ let rec read_until_eof () =
+ let rd = input inchan buf 0 1024 in
+ if rd = 0 then
+ ()
+ else (
+ Buffer.add_substring buffer buf 0 rd;
+ read_until_eof ()
+ ) in
+ (* Make sure an exception doesn't prevent us from waiting for the child process *)
+ (try read_until_eof () with _ -> ());
+ match (Unix.close_process_in inchan), handler with
+ | Unix.WEXITED 0, _ -> Buffer.contents buffer
+ | Unix.WEXITED n, Some handler -> handler cmd n
+ | _ -> raise (Process_output_error cmd)
+
+(** Remove "." and ".." from paths (NB doesn't attempt to resolve symlinks) *)
+let resolve_dot_and_dotdot (path: string) : string =
+ let of_string (x: string): string list =
+ let rec rev_split path =
+ let basename = Filename.basename path
+ and dirname = Filename.dirname path in
+ let rest = if Filename.dirname dirname = dirname then [] else rev_split dirname in
+ basename :: rest in
+ let abs_path path =
+ if Filename.is_relative path
+ then Filename.concat "/" path (* no notion of a cwd *)
+ else path in
+ rev_split (abs_path x) in
+
+ let to_string (x: string list) = List.fold_left Filename.concat "/" (List.rev x) in
+
+ (* Process all "." and ".." references *)
+ let rec remove_dots (n: int) (x: string list) =
+ match x, n with
+ | [], _ -> []
+ | "." :: rest, _ -> remove_dots n rest (* throw away ".", don't count as parent for ".." *)
+ | ".." :: rest, _ -> remove_dots (n + 1) rest (* note the number of ".." *)
+ | x :: rest, 0 -> x :: (remove_dots 0 rest)
+ | x :: rest, n -> remove_dots (n - 1) rest (* munch *) in
+ to_string (remove_dots 0 (of_string path))
+
+(** Seek to an absolute offset within a file descriptor *)
+let seek_to fd pos =
+ Unix.lseek fd pos Unix.SEEK_SET
+
+(** Seek to an offset within a file descriptor, relative to the current cursor position *)
+let seek_rel fd diff =
+ Unix.lseek fd diff Unix.SEEK_CUR
+
+(** Return the current cursor position within a file descriptor *)
+let current_cursor_pos fd =
+ (* 'seek' to the current position, exploiting the return value from Unix.lseek as the new cursor position *)
+ Unix.lseek fd 0 Unix.SEEK_CUR
+
+type statfs_t = {
+ statfs_type: int64;
+ statfs_bsize: int;
+ statfs_blocks: int64;
+ statfs_bfree: int64;
+ statfs_bavail: int64;
+ statfs_files: int64;
+ statfs_ffree: int64;
+ statfs_namelen: int;
+}
+
+external statfs: string -> statfs_t = "stub_unixext_statfs"
+
+module Fdset = struct
+ type t
+ external of_list : Unix.file_descr list -> t = "stub_fdset_of_list"
+ external is_set : t -> Unix.file_descr -> bool = "stub_fdset_is_set"
+ external is_set_and_clear : t -> Unix.file_descr -> bool = "stub_fdset_is_set_and_clear"
+ external is_empty : t -> bool = "stub_fdset_is_empty"
+ external set : t -> Unix.file_descr -> unit = "stub_fdset_set"
+ external clear : t -> Unix.file_descr -> unit = "stub_fdset_clear"
+ external _select : t -> t -> t -> float -> t * t * t = "stub_fdset_select"
+ external _select_ro : t -> float -> t = "stub_fdset_select_ro"
+ external _select_wo : t -> float -> t = "stub_fdset_select_wo"
+ let select r w e t = _select r w e t
+ let select_ro r t = _select_ro r t
+ let select_wo w t = _select_wo w t
+end
+
+let _ = Callback.register_exception "unixext.unix_error" (Unix_error (0))
+
+(* HTTP helpers *)
+module Http =
+struct
+ exception Parse_error
+ exception Unknown_file of string
+ exception File_already_exists of string
+
+ let http_response_code x =
+ match Stringext.String.split ' ' x with
+ | _:: code:: _ -> int_of_string code
+ | _ -> raise Parse_error
+
+ let rec read_rest_of_headers ic =
+ let hdrs = ["content-length"; "cookie"; "connection"; "transfer-encoding"; "authorization"; "location"] in
+
+ let strip_cr r =
+ if String.length r = 0 || r.[String.length r - 1] <> '\r' then
+ raise Parse_error
+ else
+ String.sub r 0 ((String.length r)-1) in
+
+ try
+ let line = input_line ic in
+ let r = strip_cr line in
+ if r = "" then
+ []
+ else begin
+ let hdr = List.find (fun s -> Stringext.String.startswith (s^": ") (String.lowercase r)) hdrs in
+ let value = Stringext.String.sub_to_end r (String.length hdr + 2) in
+ (hdr,value) :: read_rest_of_headers ic
+ end
+ with
+ | Not_found -> read_rest_of_headers ic
+ | _ -> []
+
+ let rec get ~open_tcp ~uri ~filename ~server =
+
+ (* Check if the filename is valid *)
+ if filename <> "" && Sys.file_exists filename then
+ raise (File_already_exists filename);
+ let fd =
+ if filename = "" then
+ Unix.dup Unix.stdout
+ else
+ Unix.openfile filename [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_EXCL ] 0o600 in
+
+ let ic, oc = open_tcp ~server in
+ (* Send a GET request to the HTTP server *)
+ Printf.fprintf oc "GET %s HTTP/1.0\r\n\r\n" uri;
+ flush oc;
+ (* Get the result header immediately *)
+ let result_line = input_line ic in
+
+ match http_response_code result_line with
+ | 200 ->
+ (* Copy from channel to the file descriptor *)
+ let finished = ref false in
+ while not !finished do
+ finished := input_line ic = "\r";
+ done;
+
+ let buffer = String.make 65536 '\000' in
+
+ let finished = ref false in
+ while not(!finished) do
+ let num = input ic buffer 0 (String.length buffer) in
+ really_write fd buffer 0 num;
+ finished := num = 0;
+ done;
+
+ Unix.close fd;
+ (try close_in ic with _ -> ()); (* Nb. Unix.close_connection only requires the in_channel *)
+
+ | 302 ->
+ let headers = read_rest_of_headers ic in
+ let new_loc = List.assoc "location" headers in
+ (try close_in ic with _ -> ()); (* Nb. Unix.close_connection only requires the in_channel *)
+ get ~open_tcp ~uri ~filename ~server:new_loc
+
+ | _ -> failwith "Unhandled response code"
+
+ let rec put ~open_tcp ~uri ~filename ~server =
+
+ (* Check if the filename is valid *)
+ if not (Sys.file_exists filename) then
+ raise (Unknown_file filename);
+ let fd = Unix.openfile filename [ Unix.O_RDONLY ] 0 in
+
+ let ic, oc = open_tcp ~server in
+ (* Send a PUT request to the HTTP server *)
+ Printf.fprintf oc "PUT %s HTTP/1.0\r\n\r\n" uri;
+ flush oc;
+ (* Get the result header immediately *)
+ let resultline = input_line ic in
+
+ match http_response_code resultline with
+ | 200 ->
+ let oc_fd = Unix.descr_of_out_channel oc in
+ let bytes = copy_file fd oc_fd in
+ Unix.close fd;
+ Unix.shutdown oc_fd Unix.SHUTDOWN_SEND;
+
+ | 302 ->
+ let headers = read_rest_of_headers ic in
+ let newloc = List.assoc "location" headers in
+ put ~open_tcp ~uri ~filename ~server:newloc
+
+ | _ -> failwith "Unhandled response code"
+end
+
+let http_get = Http.get
+let http_put = Http.put
--- /dev/null
+external _exit : int -> unit = "unix_exit"
+val unlink_safe : string -> unit
+val mkdir_safe : string -> Unix.file_perm -> unit
+val mkdir_rec : string -> Unix.file_perm -> unit
+val pidfile_write : string -> unit
+val pidfile_read : string -> int option
+val daemonize : unit -> unit
+val with_file : string -> Unix.open_flag list -> Unix.file_perm -> (Unix.file_descr -> 'a) -> 'a
+val with_directory : string -> (Unix.dir_handle -> 'a) -> 'a
+val readfile_line : (string -> 'a) -> string -> unit
+val read_whole_file : int -> int -> Unix.file_descr -> string
+val read_whole_file_to_string : string -> string
+val atomic_write_to_file : string -> (Unix.file_descr -> 'a) -> 'a
+val write_string_to_file : string -> string -> unit
+val execv_get_output : string -> string array -> int * Unix.file_descr
+val copy_file : ?limit:int64 -> Unix.file_descr -> Unix.file_descr -> int64
+
+(** Returns true if and only if a file exists at the given path. *)
+val file_exists : string -> bool
+
+(** Sets both the access and modification times of the file *)
+(** at the given path to the current time. Creates an empty *)
+(** file at the given path if no such file already exists. *)
+val touch_file : string -> unit
+
+(** Returns true if and only if an empty file exists at the given path. *)
+val is_empty_file : string -> bool
+
+(** Safely deletes a file at the given path if (and only if) the *)
+(** file exists and is empty. Returns true if a file was deleted. *)
+val delete_empty_file : string -> bool
+
+exception Host_not_found of string
+val open_connection_fd : string -> int -> Unix.file_descr
+val open_connection_unix_fd : string -> Unix.file_descr
+type endpoint = {
+ fd : Unix.file_descr;
+ mutable buffer : string;
+ mutable buffer_len : int;
+}
+exception Process_still_alive
+val kill_and_wait : ?signal:int -> ?timeout:float -> int -> unit
+val make_endpoint : Unix.file_descr -> endpoint
+val proxy : Unix.file_descr -> Unix.file_descr -> unit
+val really_read : Unix.file_descr -> string -> int -> int -> unit
+val really_read_string : Unix.file_descr -> int -> string
+val really_write : Unix.file_descr -> string -> int -> int -> unit
+val really_write_string : Unix.file_descr -> string -> unit
+exception Timeout
+val time_limited_write : Unix.file_descr -> int -> string -> float -> unit
+val time_limited_read : Unix.file_descr -> int -> float -> string
+val read_data_in_chunks : (string -> int -> unit) -> ?block_size:int -> ?max_bytes:int -> Unix.file_descr -> int
+val spawnvp :
+ ?pid_callback:(int -> unit) ->
+ string -> string array -> Unix.process_status
+val double_fork : (unit -> unit) -> unit
+external set_tcp_nodelay : Unix.file_descr -> bool -> unit
+ = "stub_unixext_set_tcp_nodelay"
+external fsync : Unix.file_descr -> unit = "stub_unixext_fsync"
+external get_max_fd : unit -> int = "stub_unixext_get_max_fd"
+val int_of_file_descr : Unix.file_descr -> int
+val file_descr_of_int : int -> Unix.file_descr
+val close_all_fds_except : Unix.file_descr list -> unit
+val get_process_output : ?handler:(string -> int -> string) -> string -> string
+val resolve_dot_and_dotdot : string -> string
+
+val seek_to : Unix.file_descr -> int -> int
+val seek_rel : Unix.file_descr -> int -> int
+val current_cursor_pos : Unix.file_descr -> int
+
+type statfs_t = {
+ statfs_type: int64;
+ statfs_bsize: int;
+ statfs_blocks: int64;
+ statfs_bfree: int64;
+ statfs_bavail: int64;
+ statfs_files: int64;
+ statfs_ffree: int64;
+ statfs_namelen: int;
+}
+
+val statfs: string -> statfs_t
+
+module Fdset : sig
+ type t
+ external of_list : Unix.file_descr list -> t = "stub_fdset_of_list"
+ external is_set : t -> Unix.file_descr -> bool = "stub_fdset_is_set"
+ external is_set_and_clear : t -> Unix.file_descr -> bool = "stub_fdset_is_set_and_clear"
+ external is_empty : t -> bool = "stub_fdset_is_empty"
+ external set : t -> Unix.file_descr -> unit = "stub_fdset_set"
+ external clear : t -> Unix.file_descr -> unit = "stub_fdset_clear"
+
+ val select : t -> t -> t -> float -> t * t * t
+ val select_ro : t -> float -> t
+ val select_wo : t -> float -> t
+end
+
+(** Download a file via an HTTP GET *)
+val http_get: open_tcp:(server:string -> (in_channel * out_channel)) -> uri:string -> filename:string -> server:string -> unit
+(** Upload a file via an HTTP PUT *)
+val http_put: open_tcp:(server:string -> (in_channel * out_channel)) -> uri:string -> filename:string -> server:string -> unit
--- /dev/null
+#include <sys/types.h>
+#include <sys/socket.h>
+#include <errno.h>
+#include <netinet/tcp.h>
+#include <netinet/in.h>
+#include <string.h>
+#include <unistd.h> /* needed for _SC_OPEN_MAX */
+#include <stdio.h> /* snprintf */
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/signals.h>
+#include <caml/custom.h>
+#include <caml/fail.h>
+#include <caml/callback.h>
+
+static void failwith_errno(void)
+{
+ char buf[256];
+ char buf2[280];
+ memset(buf, '\0', sizeof(buf));
+ strerror_r(errno, buf, sizeof(buf));
+ snprintf(buf2, sizeof(buf2), "errno: %d msg: %s", errno, buf);
+ caml_failwith(buf2);
+}
+
+/* Set the TCP_NODELAY flag on a Unix.file_descr */
+CAMLprim value stub_unixext_set_tcp_nodelay (value fd, value bool)
+{
+ CAMLparam2 (fd, bool);
+ int c_fd = Int_val(fd);
+ int opt = (Bool_val(bool)) ? 1 : 0;
+ if (setsockopt(c_fd, IPPROTO_TCP, TCP_NODELAY, (void *)&opt, sizeof(opt)) != 0){
+ failwith_errno();
+ }
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_unixext_fsync (value fd)
+{
+ CAMLparam1(fd);
+ int c_fd = Int_val(fd);
+ if (fsync(c_fd) != 0) failwith_errno();
+ CAMLreturn(Val_unit);
+}
+
+
+CAMLprim value stub_unixext_get_max_fd (value unit)
+{
+ CAMLparam1 (unit);
+ long maxfd;
+ maxfd = sysconf(_SC_OPEN_MAX);
+ CAMLreturn(Val_int(maxfd));
+}
+
+#include <sys/vfs.h>
+
+CAMLprim value stub_unixext_statfs(value path)
+{
+ CAMLparam1(path);
+ CAMLlocal1(statinfo);
+ struct statfs info;
+
+ if (statfs(String_val(path), &info))
+ failwith_errno();
+
+ statinfo = caml_alloc_tuple(8);
+ Store_field(statinfo, 0, caml_copy_int64(info.f_type));
+ Store_field(statinfo, 1, Val_int(info.f_bsize));
+ Store_field(statinfo, 2, caml_copy_int64(info.f_blocks));
+ Store_field(statinfo, 3, caml_copy_int64(info.f_bfree));
+ Store_field(statinfo, 4, caml_copy_int64(info.f_bavail));
+ Store_field(statinfo, 5, caml_copy_int64(info.f_files));
+ Store_field(statinfo, 6, caml_copy_int64(info.f_ffree));
+ Store_field(statinfo, 7, Val_int(info.f_namelen));
+
+ CAMLreturn(statinfo);
+}
+
+#define FDSET_OF_VALUE(v) (&(((struct fdset_t *) v)->fds))
+#define MAXFD_OF_VALUE(v) (((struct fdset_t *) v)->max)
+struct fdset_t { fd_set fds; int max; };
+
+CAMLprim value stub_fdset_of_list(value l)
+{
+ CAMLparam1(l);
+ CAMLlocal1(set);
+
+ set = caml_alloc(sizeof(struct fdset_t), Abstract_tag);
+ FD_ZERO(FDSET_OF_VALUE(set));
+ MAXFD_OF_VALUE(set) = -1;
+ while (l != Val_int(0)) {
+ int fd;
+ fd = Int_val(Field(l, 0));
+ FD_SET(fd, FDSET_OF_VALUE(set));
+ if (fd > MAXFD_OF_VALUE(set))
+ MAXFD_OF_VALUE(set) = fd;
+ l = Field(l, 1);
+ }
+ CAMLreturn(set);
+}
+
+CAMLprim value stub_fdset_is_set(value set, value fd)
+{
+ CAMLparam2(set, fd);
+ CAMLreturn(Val_bool(FD_ISSET(Int_val(fd), FDSET_OF_VALUE(set))));
+}
+
+CAMLprim value stub_fdset_set(value set, value fd)
+{
+ CAMLparam2(set, fd);
+ FD_SET(Int_val(fd), FDSET_OF_VALUE(set));
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_fdset_clear(value set, value fd)
+{
+ CAMLparam2(set, fd);
+ FD_CLR(Int_val(fd), FDSET_OF_VALUE(set));
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_fdset_is_set_and_clear(value set, value fd)
+{
+ CAMLparam2(set, fd);
+ int r, c_fd;
+ fd_set *c_set;
+
+ c_fd = Int_val(fd);
+ c_set = FDSET_OF_VALUE(set);
+ r = FD_ISSET(c_fd, c_set);
+ if (r)
+ FD_CLR(c_fd, c_set);
+ CAMLreturn(Val_bool(r));
+}
+
+void unixext_error(int code)
+{
+ static value *exn = NULL;
+
+ if (!exn) {
+ exn = caml_named_value("unixext.unix_error");
+ if (!exn)
+ caml_invalid_argument("unixext.unix_error not initialiazed");
+ }
+ caml_raise_with_arg(*exn, Val_int(code));
+}
+
+CAMLprim value stub_fdset_select(value rset, value wset, value eset, value t)
+{
+ CAMLparam4(rset, wset, eset, t);
+ CAMLlocal4(ret, nrset, nwset, neset);
+ fd_set r, w, e;
+ int maxfd;
+ double tm;
+ struct timeval tv;
+ struct timeval *tvp;
+ int v;
+
+ memcpy(&r, FDSET_OF_VALUE(rset), sizeof(fd_set));
+ memcpy(&w, FDSET_OF_VALUE(wset), sizeof(fd_set));
+ memcpy(&e, FDSET_OF_VALUE(eset), sizeof(fd_set));
+
+ maxfd = (MAXFD_OF_VALUE(rset) > MAXFD_OF_VALUE(wset))
+ ? MAXFD_OF_VALUE(rset)
+ : MAXFD_OF_VALUE(wset);
+ maxfd = (maxfd > MAXFD_OF_VALUE(eset)) ? maxfd : MAXFD_OF_VALUE(eset);
+
+ tm = Double_val(t);
+ if (tm < 0.0)
+ tvp = NULL;
+ else {
+ tv.tv_sec = (int) tm;
+ tv.tv_usec = (int) (1e6 * (tm - tv.tv_sec));
+ tvp = &tv;
+ }
+
+ caml_enter_blocking_section();
+ v = select(maxfd + 1, &r, &w, &e, tvp);
+ caml_leave_blocking_section();
+ if (v == -1)
+ unixext_error(errno);
+
+ nrset = caml_alloc(sizeof(struct fdset_t), Abstract_tag);
+ nwset = caml_alloc(sizeof(struct fdset_t), Abstract_tag);
+ neset = caml_alloc(sizeof(struct fdset_t), Abstract_tag);
+
+ memcpy(FDSET_OF_VALUE(nrset), &r, sizeof(fd_set));
+ memcpy(FDSET_OF_VALUE(nwset), &w, sizeof(fd_set));
+ memcpy(FDSET_OF_VALUE(neset), &e, sizeof(fd_set));
+
+ ret = caml_alloc_small(3, 0);
+ Field(ret, 0) = nrset;
+ Field(ret, 1) = nwset;
+ Field(ret, 2) = neset;
+
+ CAMLreturn(ret);
+}
+
+CAMLprim value stub_fdset_select_ro(value rset, value t)
+{
+ CAMLparam2(rset, t);
+ CAMLlocal1(ret);
+ fd_set r;
+ int maxfd;
+ double tm;
+ struct timeval tv;
+ struct timeval *tvp;
+ int v;
+
+ memcpy(&r, FDSET_OF_VALUE(rset), sizeof(fd_set));
+ maxfd = MAXFD_OF_VALUE(rset);
+
+ tm = Double_val(t);
+ if (tm < 0.0)
+ tvp = NULL;
+ else {
+ tv.tv_sec = (int) tm;
+ tv.tv_usec = (int) (1e6 * (tm - tv.tv_sec));
+ tvp = &tv;
+ }
+
+ caml_enter_blocking_section();
+ v = select(maxfd + 1, &r, NULL, NULL, tvp);
+ caml_leave_blocking_section();
+ if (v == -1)
+ unixext_error(errno);
+
+ ret = caml_alloc(sizeof(struct fdset_t), Abstract_tag);
+ memcpy(FDSET_OF_VALUE(ret), &r, sizeof(fd_set));
+
+ CAMLreturn(ret);
+}
+
+CAMLprim value stub_fdset_select_wo(value wset, value t)
+{
+ CAMLparam2(wset, t);
+ CAMLlocal1(ret);
+ fd_set w;
+ int maxfd;
+ double tm;
+ struct timeval tv;
+ struct timeval *tvp;
+ int v;
+
+ memcpy(&w, FDSET_OF_VALUE(wset), sizeof(fd_set));
+ maxfd = MAXFD_OF_VALUE(wset);
+
+ tm = Double_val(t);
+ if (tm < 0.0)
+ tvp = NULL;
+ else {
+ tv.tv_sec = (int) tm;
+ tv.tv_usec = (int) (1e6 * (tm - tv.tv_sec));
+ tvp = &tv;
+ }
+
+ caml_enter_blocking_section();
+ v = select(maxfd + 1, NULL, &w, NULL, tvp);
+ caml_leave_blocking_section();
+ if (v == -1)
+ unixext_error(errno);
+
+ ret = caml_alloc(sizeof(struct fdset_t), Abstract_tag);
+ memcpy(FDSET_OF_VALUE(ret), &w, sizeof(fd_set));
+
+ CAMLreturn(ret);
+}
+
+CAMLprim value stub_fdset_is_empty(value set)
+{
+ CAMLparam1(set);
+ fd_set x;
+ int ret;
+ FD_ZERO(&x);
+ ret = memcmp(&x, FDSET_OF_VALUE(set), sizeof(fd_set));
+
+ CAMLreturn(Bool_val(ret == 0));
+}
--- /dev/null
+(*
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ *)
+
+exception End_of_file
+exception Timeout
+
+type t = {
+ read: string -> int -> int -> int;
+ write: string -> int -> int -> int;
+ input_line: (?timeout: float option -> unit -> string) option;
+ flush: unit -> unit;
+ close: unit -> unit;
+ is_raw: bool;
+ selectable: Unix.file_descr option;
+}
+
+let do_rw_io f buf index len =
+ let left = ref len in
+ let index = ref index in
+ let end_of_file = ref false in
+ while !left > 0 && not !end_of_file
+ do
+ let ret = f buf !index !left in
+ if ret = 0 then
+ end_of_file := true
+ else if ret > 0 then (
+ left := !left - ret;
+ index := !index + ret;
+ )
+ done;
+ len - !left
+
+let do_rw_io_timeout fd is_write f buf index len timeout =
+ let fdset = Unixext.Fdset.of_list [ fd ] in
+ let select = if is_write then Unixext.Fdset.select_wo else Unixext.Fdset.select_ro in
+
+ let left = ref len in
+ let index = ref index in
+ let end_of_file = ref false in
+ while !left > 0 && not !end_of_file
+ do
+ let set = select fdset timeout in
+ if Unixext.Fdset.is_empty set then
+ raise Timeout;
+ let ret = f buf !index !left in
+ if ret = 0 then
+ end_of_file := true
+ else if ret > 0 then (
+ left := !left - ret;
+ index := !index + ret;
+ )
+ done;
+ len - !left
+
+let read ?(timeout=None) con buf index len =
+ match timeout, con.selectable with
+ | _, None | None, Some _ -> do_rw_io con.read buf index len
+ | Some timeout, Some fd -> do_rw_io_timeout fd false con.read buf index len timeout
+
+let write ?(timeout=None) con buf index len =
+ match timeout, con.selectable with
+ | _, None | None, Some _ -> do_rw_io con.write buf index len
+ | Some timeout, Some fd -> do_rw_io_timeout fd true con.write buf index len timeout
+
+let read_string ?timeout con len =
+ let s = String.create len in
+ let ret = read ?timeout con s 0 len in
+ if ret < len then
+ raise End_of_file;
+ s
+
+let write_string ?timeout con s =
+ let len = String.length s in
+ if write ?timeout con s 0 len < len then
+ raise End_of_file;
+ ()
+
+let input_line ?timeout con =
+ match con.input_line with
+ | None ->
+ let buffer = Buffer.create 80 in
+ let newline = ref false in
+ while not !newline
+ do
+ let s = " " in
+ let ret = read ?timeout con s 0 1 in
+ if ret = 0 then
+ raise End_of_file;
+ if s.[0] = '\n' then newline := true else Buffer.add_char buffer s.[0]
+ done;
+ Buffer.contents buffer
+ | Some f ->
+ f ?timeout ()
+
+let flush con = con.flush ()
+let close con = con.close ()
--- /dev/null
+exception End_of_file
+exception Timeout
+
+type t = {
+ read : string -> int -> int -> int;
+ write : string -> int -> int -> int;
+ input_line : (?timeout: float option -> unit -> string) option;
+ flush : unit -> unit;
+ close : unit -> unit;
+ is_raw : bool;
+ selectable : Unix.file_descr option;
+}
+
+val read : ?timeout: float option -> t -> string -> int -> int -> int
+val write : ?timeout: float option -> t -> string -> int -> int -> int
+val read_string : ?timeout: float option -> t -> int -> string
+val write_string : ?timeout: float option -> t -> string -> unit
+val input_line : ?timeout: float option -> t -> string
+val flush : t -> unit
+val close : t -> unit
--- /dev/null
+OCAMLC = ocamlfind ocamlc -g -package "unix,stdext,xc,xb,xs,mmap"
+OCAMLOPT = ocamlfind ocamlopt -package "unix,stdext,xc,xb,xs,mmap"
+
+
+all: copy_file close_all_fds_except unlink watch_bug dotdot
+
+copy_file: copy_file.cmo
+ $(OCAMLC) -linkpkg -custom -o $@ $<
+
+close_all_fds_except: close_all_fds_except.cmx
+ $(OCAMLOPT) -linkpkg -o $@ $<
+
+unlink: unlink.cmo
+ $(OCAMLC) -linkpkg -custom -o $@ $<
+
+watch_bug: watch_bug.cmo
+ $(OCAMLC) -linkpkg -custom -o $@ $<
+
+dotdot: dotdot.cmo
+ $(OCAMLC) -linkpkg -custom -o $@ $<
+
+clean:
+ rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot copy_file
+
+%.cmo: %.ml
+ $(OCAMLC) -c -o $@ $<
+%.cmx: %.ml
+ $(OCAMLOPT) -c -o $@ $<
+
--- /dev/null
+
+(** Test the close_all_fds_except *)
+
+let set_difference a b = List.filter (fun x -> not(List.mem x b)) a
+
+let list_of_option_array x = List.concat (List.map (function Some x -> [ x ] | None -> []) (Array.to_list x))
+
+let compare (fds: Unix.file_descr list) =
+ let pid = Unix.getpid () in
+ let dir = Printf.sprintf "/proc/%d/fd" pid in
+ let string_of ints = String.concat "; " (List.map string_of_int (List.sort compare ints)) in
+ let open_fds = List.map int_of_string (Array.to_list (Sys.readdir dir)) in
+ Printf.printf "actually open = [ %s ]\n" (string_of open_fds);
+ let fds' = List.map (fun x -> (Obj.magic x: int)) fds in
+ Printf.printf "should be open = [ %s ] (NB spurious extra Sys.readdir fd)\n" (string_of fds');
+ (* fds' are the ones we think should be open. open_fds are the ones which actually are *)
+ let should_be_open = set_difference fds' open_fds in
+ let should_be_closed = set_difference open_fds fds' in
+ List.iter (Printf.printf "FD %d should be open but is in fact closed.\n") should_be_open;
+ (* NB there is always one extra fd corresponding to the open directory handle *)
+ let fatal = if List.length should_be_closed = 1 then "Non-fatal:" else "FATAL:" in
+ List.iter (Printf.printf "%s FD %d should be closed but is in fact open.\n" fatal) should_be_closed;
+ if should_be_open <> [] || List.length should_be_closed <> 1
+ then failwith "Test failed"
+
+let _ =
+ let cycles = ref 10 in
+ Arg.parse
+ [ "-cycles", Arg.Set_int cycles, Printf.sprintf "number of iterations (default %d)" !cycles;
+ ]
+ (fun x -> Printf.printf "Ignoring unknown argument: %s" x)
+ "Test the close_all_fds_except code";
+
+ let inouterr = [ Unix.stdout; Unix.stderr; Unix.stdin ] in
+
+ for i = 1 to !cycles do
+ compare inouterr;
+
+ let dev_null () = Unix.openfile "/dev/null" [ Unix.O_WRONLY ] 0o0 in
+ let fds = Array.init (Random.int 100) (fun _ -> Some (dev_null ())) in
+ (* fds is now an array of file descriptor options *)
+ compare (inouterr @ (list_of_option_array fds));
+
+ (* close some of the fds *)
+ let fds = Array.map (function
+ | Some x -> if Random.bool () then (Unix.close x; None) else Some x
+ | None -> None) fds in
+ compare (inouterr @ (list_of_option_array fds));
+
+ (* choose some of the fds to keep *)
+ let chosen = List.filter (fun _ -> Random.bool ()) (list_of_option_array fds) in
+ Unixext.close_all_fds_except (inouterr @ chosen);
+ compare (inouterr @ chosen);
+ List.iter Unix.close chosen;
+ compare inouterr;
+ done;
+ print_endline "All tests passed"
+
+
+
+
--- /dev/null
+
+(** Test the copy_file function *)
+
+let with_openfile filename mode perms f =
+ let fd = Unix.openfile filename mode perms in
+ Pervasiveext.finally (fun () -> f fd) (fun () -> Unix.close fd)
+
+let _ =
+
+ let limit = ref None
+ and src = ref None
+ and dest = ref None in
+
+ Arg.parse
+ [ "-limit", Arg.String (fun x -> limit := Some (Int64.of_string x)),
+ "copy the first N bytes" ]
+ (fun x -> match !src, !dest with
+ | None, None -> src := Some x
+ | Some _, None -> dest := Some x
+ | _, _ -> Printf.printf "Ignoring unknown argument: %s" x)
+ "Copy a file from A to B";
+
+ let limit = !limit in
+ match !src, !dest with
+ | Some a, Some b ->
+ with_openfile a [ Unix.O_RDONLY ] 0o0
+ (fun ifd ->
+ with_openfile b [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_EXCL ] 0o600
+ (fun ofd ->
+ Unixext.copy_file ?limit ifd ofd
+ )
+ )
+ | _, _ -> failwith "Missing source and destination file arguments"
+
+
+
--- /dev/null
+(* test the "." and ".." removal code *)
+
+let table = [
+ "/tmp/../../../.././././../", "/";
+ "/tmp/foo/bar/../../", "/tmp";
+ "/tmp/foo/bar/.././..", "/tmp";
+ "/tmp/foo/bar/./././../../", "/tmp";
+ "/tmp/foo/bar/../../../", "/"
+]
+
+let _ =
+ List.iter (fun (input, output) ->
+ let output' = Unixext.resolve_dot_and_dotdot input in
+ if output <> output'
+ then failwith (Printf.sprintf "input = [%s] output = [%s] expected = [%s]" input output' output)
+ ) table
--- /dev/null
+
+(** Test the Unixext.safe_unlink function *)
+
+open Unixext
+
+let _ =
+
+ let src = ref None in
+
+ Arg.parse
+ [ ]
+ (fun x -> match !src with
+ | None -> src := Some x
+ | _ -> Printf.printf "Ignoring unknown argument: %s" x)
+ "Unlink a file which may not exist, suppressing the ENOENT error";
+
+ match !src with
+ | Some a -> Unixext.unlink_safe a
+ | None -> failwith "Missing filename"
+
+
+
--- /dev/null
+
+
+
+let _ =
+ let path = "/test" in
+
+ let xs = Xs.daemon_open () in
+
+ xs.Xs.rm path;
+
+ let counter = ref 0 in
+ let callback (path, _) =
+ let condition = try ignore (xs.Xs.read path); true with _ -> false in
+ Printf.printf "watch: fired on %s; condition is %b\n" path condition; flush stdout;
+ if !counter = 0 then begin
+ Printf.printf "got the initial watch. Writing to watched path in callback\n"; flush stdout;
+ xs.Xs.write path "gotcha";
+ (* To make sure we trigger the bug, do lots of other xenstore operations --
+ these cause any incoming watch event to be queued where we never read it again. *)
+ Printf.printf "now doing lots of xenstore reads in callback\n";
+ for i = 0 to 1000 do
+ ignore (xs.Xs.read path);
+ done;
+ Printf.printf "callback existing. The condition is now true, we should not block\n"; flush stdout;
+ end;
+ incr counter;
+ condition in
+
+ try
+ Xs.monitor_paths xs [ path, "X" ] 10. callback;
+ Printf.printf "test passed.\n";
+ with Xs.Timeout ->
+ Printf.printf "test failed.\n";
+ exit 1
+
--- /dev/null
+version = "@VERSION@"
+description = "Uuid - universal identifer"
+archive(byte) = "uuid.cma"
+archive(native) = "uuid.cmxa"
--- /dev/null
+CC = gcc
+CFLAGS = -Wall -fPIC -O2 -I/opt/xensource/lib/ocaml
+OCAMLC = ocamlc -g
+OCAMLOPT = ocamlopt
+
+LDFLAGS = -cclib -L./
+
+DESTDIR ?= /
+VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0)
+OCAMLOPTFLAGS = -g -dtypes
+
+OCAMLABI := $(shell ocamlc -version)
+OCAMLLIBDIR := $(shell ocamlc -where)
+OCAMLDESTDIR ?= $(OCAMLLIBDIR)
+
+OBJS = uuid
+INTF = $(foreach obj, $(OBJS),$(obj).cmi)
+LIBS = uuid.cma uuid.cmxa
+
+all: $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+uuid.cmxa: $(foreach obj,$(OBJS),$(obj).cmx)
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -a -o $@ $(foreach obj,$(OBJS),$(obj).cmx)
+
+uuid.cma: $(foreach obj,$(OBJS),$(obj).cmo)
+ $(OCAMLC) -a -o $@ $(foreach obj,$(OBJS),$(obj).cmo)
+
+%.cmo: %.ml
+ $(OCAMLC) -c -o $@ $<
+
+%.cmi: %.mli
+ $(OCAMLC) -c -o $@ $<
+
+%.cmx: %.ml
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -c -o $@ $<
+
+%.o: %.c
+ $(CC) $(CFLAGS) -c -o $@ $<
+
+META: META.in
+ sed 's/@VERSION@/$(VERSION)/g' < $< > $@
+
+.PHONY: install
+install: $(LIBS) META
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore uuid META $(INTF) $(LIBS) *.a *.cmx
+
+.PHONY: uninstall
+uninstall:
+ ocamlfind remove uuid
+
+clean:
+ rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS)
+
--- /dev/null
+(** Type-safe UUIDs. *)
+
+(** Internally, a UUID is simply a string. *)
+type 'a t = string
+
+type cookie = string
+
+let of_string s = s
+let to_string s = s
+
+let null = ""
+
+(* deprecated: we don't need to duplicate the uuid prefix/suffix *)
+let uuid_of_string = of_string
+let string_of_uuid = to_string
+
+let string_of_cookie s = s
+
+let cookie_of_string s = s
+
+(** FIXME: using /dev/random is too slow but using /dev/urandom is too
+ deterministic. *)
+let dev_random = "/dev/urandom"
+
+let read_random n =
+ let ic = open_in_bin dev_random in
+ try
+ let result = Array.init n (fun _ -> input_byte ic) in
+ close_in ic;
+ result
+ with e ->
+ close_in ic;
+ raise e
+
+let uuid_of_int_array uuid =
+ Printf.sprintf "%02x%02x%02x%02x-%02x%02x-%02x%02x-%02x%02x-%02x%02x%02x%02x%02x%02x"
+ uuid.(0) uuid.(1) uuid.(2) uuid.(3) uuid.(4) uuid.(5)
+ uuid.(6) uuid.(7) uuid.(8) uuid.(9) uuid.(10) uuid.(11)
+ uuid.(12) uuid.(13) uuid.(14) uuid.(15)
+
+(** Return a new random UUID *)
+let make_uuid() = uuid_of_int_array (read_random 16)
+
+(** Return a new random, big UUID (hopefully big and random enough to be
+ unguessable) *)
+let make_cookie() =
+ let bytes = Array.to_list (read_random 64) in
+ String.concat "" (List.map (Printf.sprintf "%1x") bytes)
+(*
+ let hexencode x =
+ let nibble x =
+ char_of_int (if x < 10
+ then int_of_char '0' + x
+ else int_of_char 'a' + (x - 10)) in
+ let result = String.make (String.length x * 2) ' ' in
+ for i = 0 to String.length x - 1 do
+ let byte = int_of_char x.[i] in
+ result.[i * 2 + 0] <- nibble((byte lsr 4) land 15);
+ result.[i * 2 + 1] <- nibble((byte lsr 0) land 15);
+ done;
+ result in
+ let n = 64 in
+ hexencode (String.concat "" (List.map (fun x -> String.make 1 (char_of_int x)) (Array.to_list (read_n_random_bytes n))))
+*)
+
+let int_array_of_uuid s =
+ try
+ let l = ref [] in
+ Scanf.sscanf s "%02x%02x%02x%02x-%02x%02x-%02x%02x-%02x%02x-%02x%02x%02x%02x%02x%02x"
+ (fun a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 ->
+ l := [ a0; a1; a2; a3; a4; a5; a6; a7; a8; a9;
+ a10; a11; a12; a13; a14; a15; ]);
+ Array.of_list !l
+ with _ -> invalid_arg "Uuid.int_array_of_uuid"
--- /dev/null
+(** Type-safe UUIDs.
+ Probably need to refactor this; UUIDs are used in two places:
+ 1. to uniquely name things across the cluster
+ 2. as secure session IDs
+ There is the additional constraint that current Xen tools use
+ a particular format of UUID (the 16 byte variety generated by fresh ())
+*)
+
+(** A 128-bit UUID referencing a value of type 'a. *)
+type 'a t
+
+(** A 512-bit UUID. *)
+type cookie
+
+(** Create a fresh (unique!) UUID *)
+val make_uuid : unit -> 'a t
+
+(** Create a fresh secure (bigger and hopefully unguessable) UUID *)
+val make_cookie : unit -> cookie
+
+(** Create a type-safe UUID. *)
+val of_string : string -> 'a t
+
+(** Marshal a UUID to a (type-unsafe) string. *)
+val to_string : 'a t -> string
+
+val null : 'a t
+
+(* deprecated alias for previous one *)
+val uuid_of_string : string -> 'a t
+val string_of_uuid : 'a t -> string
+
+val cookie_of_string : string -> cookie
+
+val string_of_cookie : cookie -> string
+
+val uuid_of_int_array : int array -> 'a t
+
+val int_array_of_uuid : 'a t -> int array
--- /dev/null
+version = "@VERSION@"
+description = "XenBus Interface"
+archive(byte) = "xb.cma"
+archive(native) = "xb.cmxa"
--- /dev/null
+CC = gcc
+CFLAGS = -Wall -fPIC -O2 -I/opt/xensource/lib/ocaml -I$(XEN_ROOT)/usr/include -I../mmap
+OCAMLC = ocamlc -g -I ../mmap
+OCAMLOPT = ocamlopt
+OCAMLOPTFLAGS = -g -dtypes -I ../mmap
+
+LDFLAGS = -cclib -L./
+
+DESTDIR ?= /
+VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0)
+
+OCAMLABI := $(shell ocamlc -version)
+OCAMLLIBDIR := $(shell ocamlc -where)
+OCAMLDESTDIR ?= $(OCAMLLIBDIR)
+
+PREINTF = op.cmi partial.cmi packet.cmi
+PREOBJS = op partial packet xs_ring
+PRELIBS = $(foreach obj, $(PREOBJS),$(obj).cmo) $(foreach obj,$(PREOJBS),$(obj).cmx)
+OBJS = op partial packet xs_ring xb
+INTF = op.cmi packet.cmi xb.cmi
+LIBS = xb.cma xb.cmxa
+
+all: $(PREINTF) $(PRELIBS) $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+xb.cmxa: libxb_stubs.a $(foreach obj,$(OBJS),$(obj).cmx)
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -a -o $@ -cclib -lxb_stubs $(foreach obj,$(OBJS),$(obj).cmx)
+
+xb.cma: $(foreach obj,$(OBJS),$(obj).cmo)
+ $(OCAMLC) -a -dllib dllxb_stubs.so -cclib -lxb_stubs -o $@ $(foreach obj,$(OBJS),$(obj).cmo)
+
+xb_stubs.a: xs_ring_stubs.o xb_stubs.o
+ ocamlmklib -o xb_stubs $+
+
+libxb_stubs.a: xs_ring_stubs.o xb_stubs.o
+ ar rcs $@ $+
+ ocamlmklib -o xb_stubs $+
+
+%.cmo: %.ml
+ $(OCAMLC) -c -o $@ $<
+
+%.cmi: %.mli
+ $(OCAMLC) -c -o $@ $<
+
+%.mli: %.ml
+ $(OCAMLC) -i $< > $@
+
+%.cmx: %.ml
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -c -o $@ $<
+
+%.o: %.c
+ $(CC) $(CFLAGS) -c -o $@ $<
+
+META: META.in
+ sed 's/@VERSION@/$(VERSION)/g' < $< > $@
+
+.PHONY: install
+install: $(LIBS) META
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore xb META $(INTF) $(LIBS) *.a *.so *.cmx
+
+.PHONY: uninstall
+uninstall:
+ ocamlfind remove xb
+
+clean:
+ rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS)
+
--- /dev/null
+(*
+ * Copyright (c) 2006 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ *
+ *)
+
+type operation = Debug | Directory | Read | Getperms |
+ Watch | Unwatch | Transaction_start |
+ Transaction_end | Introduce | Release |
+ Getdomainpath | Write | Mkdir | Rm |
+ Setperms | Watchevent | Error | Isintroduced |
+ Resume | Set_target
+ | Restrict
+
+(* There are two sets of XB operations: the one coming from open-source and *)
+(* the one coming from our private patch queue. These operations *)
+(* in two differents arrays for make easier the forward compatibility *)
+let operation_c_mapping =
+ [| Debug; Directory; Read; Getperms;
+ Watch; Unwatch; Transaction_start;
+ Transaction_end; Introduce; Release;
+ Getdomainpath; Write; Mkdir; Rm;
+ Setperms; Watchevent; Error; Isintroduced;
+ Resume; Set_target |]
+let size = Array.length operation_c_mapping
+
+(* [offset_pq] has to be the same as in <xen/io/xs_wire.h> *)
+external get_internal_offset: unit -> int = "stub_get_internal_offset"
+let offset_pq = get_internal_offset ()
+
+let operation_c_mapping_pq =
+ [| Restrict |]
+let size_pq = Array.length operation_c_mapping_pq
+
+let array_search el a =
+ let len = Array.length a in
+ let rec search i =
+ if i > len then raise Not_found;
+ if a.(i) = el then i else search (i + 1) in
+ search 0
+
+let of_cval i =
+ if i >= 0 && i < size
+ then operation_c_mapping.(i)
+ else if i >= offset_pq && i < offset_pq + size_pq
+ then operation_c_mapping_pq.(i-offset_pq)
+ else raise Not_found
+
+let to_cval op =
+ try
+ array_search op operation_c_mapping
+ with _ -> offset_pq + array_search op operation_c_mapping_pq
+
+let to_string ty =
+ match ty with
+ | Debug -> "DEBUG"
+ | Directory -> "DIRECTORY"
+ | Read -> "READ"
+ | Getperms -> "GET_PERMS"
+ | Watch -> "WATCH"
+ | Unwatch -> "UNWATCH"
+ | Transaction_start -> "TRANSACTION_START"
+ | Transaction_end -> "TRANSACTION_END"
+ | Introduce -> "INTRODUCE"
+ | Release -> "RELEASE"
+ | Getdomainpath -> "GET_DOMAIN_PATH"
+ | Write -> "WRITE"
+ | Mkdir -> "MKDIR"
+ | Rm -> "RM"
+ | Setperms -> "SET_PERMS"
+ | Watchevent -> "WATCH_EVENT"
+ | Error -> "ERROR"
+ | Isintroduced -> "IS_INTRODUCED"
+ | Resume -> "RESUME"
+ | Set_target -> "SET_TARGET"
+ | Restrict -> "RESTRICT"
--- /dev/null
+(*
+ * Copyright (c) 2006 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ *
+ * All rights reserved.
+ *)
+
+type t =
+{
+ tid: int;
+ rid: int;
+ ty: Op.operation;
+ data: string;
+}
+
+exception Error of string
+exception DataError of string
+
+external string_of_header: int -> int -> int -> int -> string = "stub_string_of_header"
+
+let create tid rid ty data = { tid = tid; rid = rid; ty = ty; data = data; }
+
+let of_partialpkt ppkt =
+ create ppkt.Partial.tid ppkt.Partial.rid ppkt.Partial.ty (Buffer.contents ppkt.Partial.buf)
+
+let to_string pkt =
+ let header = string_of_header pkt.tid pkt.rid (Op.to_cval pkt.ty) (String.length pkt.data) in
+ header ^ pkt.data
+
+let unpack pkt =
+ pkt.tid, pkt.rid, pkt.ty, pkt.data
+
+let get_tid pkt = pkt.tid
+let get_ty pkt = pkt.ty
+let get_data pkt =
+ let l = String.length pkt.data in
+ if l > 0 && pkt.data.[l - 1] = '\000' then
+ String.sub pkt.data 0 (l - 1)
+ else
+ pkt.data
+let get_rid pkt = pkt.rid
\ No newline at end of file
--- /dev/null
+(*
+ * Copyright (c) 2006 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ *
+ * All rights reserved.
+ *)
+
+type pkt =
+{
+ tid: int;
+ rid: int;
+ ty: Op.operation;
+ len: int;
+ buf: Buffer.t;
+}
+
+external header_size: unit -> int = "stub_header_size"
+external header_of_string_internal: string -> int * int * int * int
+ = "stub_header_of_string"
+
+let of_string s =
+ let tid, rid, opint, dlen = header_of_string_internal s in
+ {
+ tid = tid;
+ rid = rid;
+ ty = (Op.of_cval opint);
+ len = dlen;
+ buf = Buffer.create dlen;
+ }
+
+let append pkt s sz =
+ Buffer.add_string pkt.buf (String.sub s 0 sz)
+
+let to_complete pkt =
+ pkt.len - (Buffer.length pkt.buf)
--- /dev/null
+(*
+ * Copyright (c) 2006 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ *
+ * All rights reserved.
+ *)
+
+module Op = struct include Op end
+module Packet = struct include Packet end
+
+exception End_of_file
+exception Eagain
+exception Noent
+exception Invalid
+
+type backend_mmap =
+{
+ mmap: Mmap.mmap_interface; (* mmaped interface = xs_ring *)
+ eventchn_notify: unit -> unit; (* function to notify through eventchn *)
+ mutable work_again: bool;
+}
+
+type backend_fd =
+{
+ fd: Unix.file_descr;
+}
+
+type backend = Fd of backend_fd | Mmap of backend_mmap
+
+type partial_buf = HaveHdr of Partial.pkt | NoHdr of int * string
+
+type t =
+{
+ backend: backend;
+ pkt_in: Packet.t Queue.t;
+ pkt_out: Packet.t Queue.t;
+ mutable partial_in: partial_buf;
+ mutable partial_out: string;
+}
+
+let init_partial_in () = NoHdr
+ (Partial.header_size (), String.make (Partial.header_size()) '\000')
+
+let queue con pkt = Queue.push pkt con.pkt_out
+
+let read_fd back con s len =
+ let rd = Unix.read back.fd s 0 len in
+ if rd = 0 then
+ raise End_of_file;
+ rd
+
+let read_mmap back con s len =
+ let rd = Xs_ring.read back.mmap s len in
+ back.work_again <- (rd > 0);
+ if rd > 0 then
+ back.eventchn_notify ();
+ rd
+
+let read con s len =
+ match con.backend with
+ | Fd backfd -> read_fd backfd con s len
+ | Mmap backmmap -> read_mmap backmmap con s len
+
+let write_fd back con s len =
+ Unix.write back.fd s 0 len
+
+let write_mmap back con s len =
+ let ws = Xs_ring.write back.mmap s len in
+ if ws > 0 then
+ back.eventchn_notify ();
+ ws
+
+let write con s len =
+ match con.backend with
+ | Fd backfd -> write_fd backfd con s len
+ | Mmap backmmap -> write_mmap backmmap con s len
+
+let output con =
+ (* get the output string from a string_of(packet) or partial_out *)
+ let s = if String.length con.partial_out > 0 then
+ con.partial_out
+ else if Queue.length con.pkt_out > 0 then
+ Packet.to_string (Queue.pop con.pkt_out)
+ else
+ "" in
+ (* send data from s, and save the unsent data to partial_out *)
+ if s <> "" then (
+ let len = String.length s in
+ let sz = write con s len in
+ let left = String.sub s sz (len - sz) in
+ con.partial_out <- left
+ );
+ (* after sending one packet, partial is empty *)
+ con.partial_out = ""
+
+let input con =
+ let newpacket = ref false in
+ let to_read =
+ match con.partial_in with
+ | HaveHdr partial_pkt -> Partial.to_complete partial_pkt
+ | NoHdr (i, buf) -> i in
+
+ (* try to get more data from input stream *)
+ let s = String.make to_read '\000' in
+ let sz = if to_read > 0 then read con s to_read else 0 in
+
+ (
+ match con.partial_in with
+ | HaveHdr partial_pkt ->
+ (* we complete the data *)
+ if sz > 0 then
+ Partial.append partial_pkt s sz;
+ if Partial.to_complete partial_pkt = 0 then (
+ let pkt = Packet.of_partialpkt partial_pkt in
+ con.partial_in <- init_partial_in ();
+ Queue.push pkt con.pkt_in;
+ newpacket := true
+ )
+ | NoHdr (i, buf) ->
+ (* we complete the partial header *)
+ if sz > 0 then
+ String.blit s 0 buf (Partial.header_size () - i) sz;
+ con.partial_in <- if sz = i then
+ HaveHdr (Partial.of_string buf) else NoHdr (i - sz, buf)
+ );
+ !newpacket
+
+let newcon backend = {
+ backend = backend;
+ pkt_in = Queue.create ();
+ pkt_out = Queue.create ();
+ partial_in = init_partial_in ();
+ partial_out = "";
+ }
+
+let open_fd fd = newcon (Fd { fd = fd; })
+
+let open_mmap mmap notifyfct =
+ newcon (Mmap {
+ mmap = mmap;
+ eventchn_notify = notifyfct;
+ work_again = false; })
+
+let close con =
+ match con.backend with
+ | Fd backend -> Unix.close backend.fd
+ | Mmap backend -> Mmap.unmap backend.mmap
+
+let is_fd con =
+ match con.backend with
+ | Fd _ -> true
+ | Mmap _ -> false
+
+let is_mmap con = not (is_fd con)
+
+let output_len con = Queue.length con.pkt_out
+let has_new_output con = Queue.length con.pkt_out > 0
+let has_old_output con = String.length con.partial_out > 0
+
+let has_output con = has_new_output con || has_old_output con
+
+let peek_output con = Queue.peek con.pkt_out
+
+let input_len con = Queue.length con.pkt_in
+let has_in_packet con = Queue.length con.pkt_in > 0
+let get_in_packet con = Queue.pop con.pkt_in
+let has_more_input con =
+ match con.backend with
+ | Fd _ -> false
+ | Mmap backend -> backend.work_again
+
+let is_selectable con =
+ match con.backend with
+ | Fd _ -> true
+ | Mmap _ -> false
+
+let get_fd con =
+ match con.backend with
+ | Fd backend -> backend.fd
+ | Mmap _ -> raise (Failure "get_fd")
--- /dev/null
+module Op:
+sig
+ type operation = Op.operation =
+ | Debug
+ | Directory
+ | Read
+ | Getperms
+ | Watch
+ | Unwatch
+ | Transaction_start
+ | Transaction_end
+ | Introduce
+ | Release
+ | Getdomainpath
+ | Write
+ | Mkdir
+ | Rm
+ | Setperms
+ | Watchevent
+ | Error
+ | Isintroduced
+ | Resume
+ | Set_target
+ | Restrict
+ val to_string : operation -> string
+end
+
+module Packet:
+sig
+ type t
+
+ exception Error of string
+ exception DataError of string
+
+ val create : int -> int -> Op.operation -> string -> t
+ val unpack : t -> int * int * Op.operation * string
+
+ val get_tid : t -> int
+ val get_ty : t -> Op.operation
+ val get_data : t -> string
+ val get_rid: t -> int
+end
+
+exception End_of_file
+exception Eagain
+exception Noent
+exception Invalid
+
+type t
+
+(** queue a packet into the output queue for later sending *)
+val queue : t -> Packet.t -> unit
+
+(** process the output queue, return if a packet has been totally sent *)
+val output : t -> bool
+
+(** process the input queue, return if a packet has been totally received *)
+val input : t -> bool
+
+(** create new connection using a fd interface *)
+val open_fd : Unix.file_descr -> t
+(** create new connection using a mmap intf and a function to notify eventchn *)
+val open_mmap : Mmap.mmap_interface -> (unit -> unit) -> t
+
+(* close a connection *)
+val close : t -> unit
+
+val is_fd : t -> bool
+val is_mmap : t -> bool
+
+val output_len : t -> int
+val has_new_output : t -> bool
+val has_old_output : t -> bool
+val has_output : t -> bool
+val peek_output : t -> Packet.t
+
+val input_len : t -> int
+val has_in_packet : t -> bool
+val get_in_packet : t -> Packet.t
+val has_more_input : t -> bool
+
+val is_selectable : t -> bool
+val get_fd : t -> Unix.file_descr
--- /dev/null
+/*
+ * Copyright (c) 2006 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ *
+ * All rights reserved.
+ */
+
+#include <unistd.h>
+#include <stdlib.h>
+#include <sys/mman.h>
+#include <string.h>
+#include <errno.h>
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/custom.h>
+#include <caml/fail.h>
+#include <caml/callback.h>
+
+#define __XEN_TOOLS__
+
+#include <xenctrl.h>
+#define u32 uint32_t
+#include <xen/io/xs_wire.h>
+
+CAMLprim value stub_get_internal_offset(void)
+{
+ CAMLparam0();
+ CAMLreturn(Val_int(XS_RESTRICT));
+}
+
+CAMLprim value stub_header_size(void)
+{
+ CAMLparam0();
+ CAMLreturn(Val_int(sizeof(struct xsd_sockmsg)));
+}
+
+CAMLprim value stub_header_of_string(value s)
+{
+ CAMLparam1(s);
+ CAMLlocal1(ret);
+ struct xsd_sockmsg *hdr;
+
+ if (caml_string_length(s) != sizeof(struct xsd_sockmsg))
+ caml_failwith("xb header incomplete");
+ ret = caml_alloc_tuple(4);
+ hdr = (struct xsd_sockmsg *) String_val(s);
+ Store_field(ret, 0, Val_int(hdr->tx_id));
+ Store_field(ret, 1, Val_int(hdr->req_id));
+ Store_field(ret, 2, Val_int(hdr->type));
+ Store_field(ret, 3, Val_int(hdr->len));
+ CAMLreturn(ret);
+}
+
+CAMLprim value stub_string_of_header(value tid, value rid, value ty, value len)
+{
+ CAMLparam4(tid, rid, ty, len);
+ CAMLlocal1(ret);
+ struct xsd_sockmsg xsd = {
+ .type = Int_val(ty),
+ .tx_id = Int_val(tid),
+ .req_id = Int_val(rid),
+ .len = Int_val(len),
+ };
+
+ ret = caml_alloc_string(sizeof(struct xsd_sockmsg));
+ memcpy(String_val(ret), &xsd, sizeof(struct xsd_sockmsg));
+
+ CAMLreturn(ret);
+}
--- /dev/null
+(*
+ * Copyright (c) 2006 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ *
+ * All rights reserved.
+ *)
+
+external read: Mmap.mmap_interface -> string -> int -> int = "ml_interface_read"
+external write: Mmap.mmap_interface -> string -> int -> int = "ml_interface_write"
--- /dev/null
+/*
+ * Copyright (c) 2006 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ *
+ * All rights reserved.
+ */
+
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+#include <unistd.h>
+#include <errno.h>
+#include <string.h>
+
+#define __XEN_TOOLS__
+
+#include <xenctrl.h>
+#define u32 uint32_t
+#include <xen/io/xs_wire.h>
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/custom.h>
+#include <caml/fail.h>
+#include <caml/callback.h>
+
+#include "mmap_stubs.h"
+
+#define GET_C_STRUCT(a) ((struct mmap_interface *) a)
+
+#ifndef xen_mb
+#define xen_mb() mb()
+#endif
+
+static int xs_ring_read(struct mmap_interface *interface,
+ char *buffer, int len)
+{
+ struct xenstore_domain_interface *intf = interface->addr;
+ XENSTORE_RING_IDX cons, prod;
+ int to_read;
+
+ cons = intf->req_cons;
+ prod = intf->req_prod;
+ xen_mb();
+ if (prod == cons)
+ return 0;
+ if (MASK_XENSTORE_IDX(prod) > MASK_XENSTORE_IDX(cons))
+ to_read = prod - cons;
+ else
+ to_read = XENSTORE_RING_SIZE - MASK_XENSTORE_IDX(cons);
+ if (to_read < len)
+ len = to_read;
+ memcpy(buffer, intf->req + MASK_XENSTORE_IDX(cons), len);
+ xen_mb();
+ intf->req_cons += len;
+ return len;
+}
+
+static int xs_ring_write(struct mmap_interface *interface,
+ char *buffer, int len)
+{
+ struct xenstore_domain_interface *intf = interface->addr;
+ XENSTORE_RING_IDX cons, prod;
+ int can_write;
+
+ cons = intf->rsp_cons;
+ prod = intf->rsp_prod;
+ xen_mb();
+ if ( (prod - cons) >= XENSTORE_RING_SIZE )
+ return 0;
+ if (MASK_XENSTORE_IDX(prod) >= MASK_XENSTORE_IDX(cons))
+ can_write = XENSTORE_RING_SIZE - MASK_XENSTORE_IDX(prod);
+ else
+ can_write = MASK_XENSTORE_IDX(cons) - MASK_XENSTORE_IDX(prod);
+ if (can_write < len)
+ len = can_write;
+ memcpy(intf->rsp + MASK_XENSTORE_IDX(prod), buffer, len);
+ xen_mb();
+ intf->rsp_prod += len;
+ return len;
+}
+
+CAMLprim value ml_interface_read(value interface, value buffer, value len)
+{
+ CAMLparam3(interface, buffer, len);
+ CAMLlocal1(result);
+ int res;
+
+ res = xs_ring_read(GET_C_STRUCT(interface),
+ String_val(buffer), Int_val(len));
+ if (res == -1)
+ caml_failwith("huh");
+ result = Val_int(res);
+ CAMLreturn(result);
+}
+
+CAMLprim value ml_interface_write(value interface, value buffer, value len)
+{
+ CAMLparam3(interface, buffer, len);
+ CAMLlocal1(result);
+ int res;
+
+ res = xs_ring_write(GET_C_STRUCT(interface),
+ String_val(buffer), Int_val(len));
+ result = Val_int(res);
+ CAMLreturn(result);
+}
--- /dev/null
+version = "@VERSION@"
+description = "Xen Control Interface"
+archive(byte) = "xc.cma"
+archive(native) = "xc.cmxa"
--- /dev/null
+CC = gcc
+CFLAGS = -Wall -fPIC -O2 -I/opt/xensource/lib/ocaml -I$(XEN_ROOT)/usr/include -I../mmap -I./
+OCAMLC = ocamlc -g -I ../mmap -I ../uuid
+OCAMLOPT = ocamlopt
+OCAMLOPTFLAGS = -g -dtypes -I ../mmap -I ../uuid
+
+LDFLAGS = -cclib -L./
+
+DESTDIR ?= /
+VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0)
+
+OCAMLABI := $(shell ocamlc -version)
+OCAMLLIBDIR := $(shell ocamlc -where)
+OCAMLDESTDIR ?= $(OCAMLLIBDIR)
+
+OBJS = xc
+INTF = xc.cmi
+LIBS = xc.cma xc.cmxa
+
+all: $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+xc.cmxa: libxc_stubs.a $(foreach obj,$(OBJS),$(obj).cmx)
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -a -o $@ -cclib -lxc_stubs $(foreach obj,$(OBJS),$(obj).cmx)
+
+xc.cma: $(foreach obj,$(OBJS),$(obj).cmo)
+ $(OCAMLC) -a -dllib dllxc_stubs.so -cclib -lxc_stubs -o $@ $(foreach obj,$(OBJS),$(obj).cmo)
+
+xc_stubs.a: xc_lib.o xc_stubs.o
+ ocamlmklib -o xc_stubs $+
+
+libxc_stubs.a: xc_lib.o xc_stubs.o
+ ar rcs $@ $+
+ ocamlmklib -o xc_stubs $+
+
+%.cmo: %.ml
+ $(OCAMLC) -c -o $@ $<
+
+%.cmi: %.mli
+ $(OCAMLC) -c -o $@ $<
+
+%.cmx: %.ml
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -c -o $@ $<
+
+%.o: %.c
+ $(CC) $(CFLAGS) -c -o $@ $<
+
+META: META.in
+ sed 's/@VERSION@/$(VERSION)/g' < $< > $@
+
+.PHONY: install
+install: $(LIBS) META
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore xc META $(INTF) $(LIBS) *.a *.so *.cmx
+
+.PHONY: uninstall
+uninstall:
+ ocamlfind remove xc
+
+clean:
+ rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS) $(INTF)
+
--- /dev/null
+/*
+ * Copyright (c) 2006 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ */
+
+#define __XEN_TOOLS__
+
+#include <xen/xen.h>
+#include <xen/memory.h>
+#include <xen/sysctl.h>
+#include <xen/domctl.h>
+#include <xen/sched.h>
+#include <xen/sysctl.h>
+#if XEN_SYSCTL_INTERFACE_VERSION < 4
+#include <xen/linux/privcmd.h>
+#else
+#include <xen/sys/privcmd.h>
+#endif
+#include <xen/version.h>
+#include <xen/foreign/x86_32.h>
+#include <xen/foreign/x86_64.h>
+#include <xen/hvm/params.h>
+#include "xc_e820.h"
+
+#ifndef XEN_DOMCTL_get_runstate_info
+#warning "runstate info is missing"
+typedef struct {
+ int32_t state;
+ uint32_t missed_changes;
+ uint64_t state_entry_time;
+ uint64_t time[6];
+} xen_domctl_runstate_info_t;
+#endif
+
+typedef xen_domctl_getdomaininfo_t xc_domaininfo_t;
+typedef xen_domctl_getvcpuinfo_t xc_vcpuinfo_t;
+typedef xen_sysctl_physinfo_t xc_physinfo_t;
+typedef xen_domctl_runstate_info_t xc_runstate_info_t;
+
+struct xc_core_header {
+ unsigned int xch_magic;
+ unsigned int xch_nr_vcpus;
+ unsigned int xch_nr_pages;
+ unsigned int xch_ctxt_offset;
+ unsigned int xch_index_offset;
+ unsigned int xch_pages_offset;
+};
+
+typedef union {
+#if defined(__i386__) || defined(__x86_64__)
+ vcpu_guest_context_x86_64_t x64;
+ vcpu_guest_context_x86_32_t x32;
+#endif
+ vcpu_guest_context_t c;
+} vcpu_guest_context_any_t;
+
+char * xc_error_get(void);
+void xc_error_clear(void);
+
+int xc_using_injection(void);
+
+int xc_interface_open(void);
+int xc_interface_close(int handle);
+
+int xc_domain_create(int handle, unsigned int ssidref,
+ xen_domain_handle_t dhandle,
+ unsigned int flags, unsigned int *pdomid);
+int xc_domain_pause(int handle, unsigned int domid);
+int xc_domain_unpause(int handle, unsigned int domid);
+int xc_domain_resume_fast(int handle, unsigned int domid);
+int xc_domain_destroy(int handle, unsigned int domid);
+int xc_domain_shutdown(int handle, int domid, int reason);
+
+int xc_vcpu_setaffinity(int handle, unsigned int domid, int vcpu,
+ uint64_t cpumap);
+int xc_vcpu_getaffinity(int handle, unsigned int domid, int vcpu,
+ uint64_t *cpumap);
+
+int xc_domain_getinfolist(int handle, unsigned int first_domain,
+ unsigned int max_domains, xc_domaininfo_t *info);
+int xc_domain_getinfo(int handle, unsigned int first_domain,
+ xc_domaininfo_t *info);
+
+int xc_domain_setmaxmem(int handle, unsigned int domid, unsigned int max_memkb);
+int xc_domain_set_memmap_limit(int handle, unsigned int domid,
+ unsigned long map_limitkb);
+
+int xc_domain_set_time_offset(int handle, unsigned int domid, int time_offset);
+
+int xc_domain_memory_increase_reservation(int handle, unsigned int domid,
+ unsigned long nr_extents,
+ unsigned int extent_order,
+ unsigned int address_bits,
+ xen_pfn_t *extent_start);
+int xc_domain_memory_decrease_reservation(int handle, unsigned int domid,
+ unsigned long nr_extents,
+ unsigned int extent_order,
+ unsigned int address_bits,
+ xen_pfn_t *extent_start);
+int xc_domain_memory_populate_physmap(int handle, unsigned int domid,
+ unsigned long nr_extents,
+ unsigned int extent_order,
+ unsigned int address_bits,
+ xen_pfn_t *extent_start);
+int xc_domain_setvmxassist(int handle, unsigned int domid, int use_vmxassist);
+int xc_domain_max_vcpus(int handle, unsigned int domid, unsigned int max);
+int xc_domain_sethandle(int handle, unsigned int domid,
+ xen_domain_handle_t dhandle);
+int xc_vcpu_getinfo(int handle, unsigned int domid, unsigned int vcpu,
+ xc_vcpuinfo_t *info);
+int xc_get_runstate_info(int handle, unsigned int domid,
+ xc_runstate_info_t *info);
+int xc_domain_ioport_permission(int handle, unsigned int domid,
+ unsigned int first_port, unsigned int nr_ports,
+ unsigned int allow_access);
+int xc_vcpu_setcontext(int handle, unsigned int domid,
+ unsigned int vcpu, vcpu_guest_context_any_t *ctxt);
+int xc_vcpu_getcontext(int handle, unsigned int domid,
+ unsigned int vcpu, vcpu_guest_context_any_t *ctxt);
+int xc_domain_irq_permission(int handle, unsigned int domid,
+ unsigned char pirq, unsigned char allow_access);
+int xc_domain_iomem_permission(int handle, unsigned int domid,
+ unsigned long first_mfn, unsigned long nr_mfns,
+ unsigned char allow_access);
+long long xc_domain_get_cpu_usage(int handle, unsigned int domid,
+ unsigned int vcpu);
+void *xc_map_foreign_range(int handle, unsigned int domid,
+ int size, int prot, unsigned long mfn);
+int xc_map_foreign_ranges(int handle, unsigned int domid,
+ privcmd_mmap_entry_t *entries, int nr);
+int xc_readconsolering(int handle, char **pbuffer,
+ unsigned int *pnr_chars, int clear);
+int xc_send_debug_keys(int handle, char *keys);
+int xc_physinfo(int handle, xc_physinfo_t *put_info);
+int xc_pcpu_info(int handle, int max_cpus, uint64_t *info, int *nr_cpus);
+int xc_sched_id(int handle, int *sched_id);
+int xc_version(int handle, int cmd, void *arg);
+int xc_evtchn_alloc_unbound(int handle, unsigned int domid,
+ unsigned int remote_domid);
+int xc_evtchn_reset(int handle, unsigned int domid);
+
+int xc_sched_credit_domain_set(int handle, unsigned int domid,
+ struct xen_domctl_sched_credit *sdom);
+int xc_sched_credit_domain_get(int handle, unsigned int domid,
+ struct xen_domctl_sched_credit *sdom);
+int xc_shadow_allocation_get(int handle, unsigned int domid,
+ uint32_t *mb);
+int xc_shadow_allocation_set(int handle, unsigned int domid,
+ uint32_t mb);
+int xc_domain_get_pfn_list(int handle, unsigned int domid,
+ xen_pfn_t *pfn_array, unsigned long max_pfns);
+int xc_hvm_check_pvdriver(int handle, unsigned int domid);
+
+int xc_domain_assign_device(int handle, unsigned int domid,
+ int domain, int bus, int slot, int func);
+int xc_domain_deassign_device(int handle, unsigned int domid,
+ int domain, int bus, int slot, int func);
+int xc_domain_test_assign_device(int handle, unsigned int domid,
+ int domain, int bus, int slot, int func);
+int xc_domain_watchdog(int handle, int id, uint32_t timeout);
+int xc_domain_set_machine_address_size(int xc, uint32_t domid, unsigned int width);
+int xc_domain_get_machine_address_size(int xc, uint32_t domid);
+int xc_domain_get_address_size(int handle, uint32_t domid);
+
+int xc_domain_cpuid_set(int xc, unsigned int domid, int hvm,
+ uint32_t input, uint32_t oinput,
+ char *config[4], char *config_out[4]);
+int xc_domain_cpuid_apply(int xc, unsigned int domid, int hvm);
+int xc_cpuid_check(uint32_t input, uint32_t optsubinput,
+ char *config[4], char *config_out[4]);
+int xc_domain_send_s3resume(int handle, unsigned int domid);
+
+int xc_domain_suppress_spurious_page_faults(int xc, uint32_t domid);
+
+#if XEN_SYSCTL_INTERFACE_VERSION >= 6
+#define SAFEDIV(a, b) (((b) >= 0) ? (a) / (b) : (a))
+#define COMPAT_FIELD_physinfo_get_nr_cpus(p) (p).nr_cpus
+#define COMPAT_FIELD_physinfo_get_sockets_per_node(p) \
+ SAFEDIV((p).nr_cpus, ((p).threads_per_core * (p).cores_per_socket * (p).nr_nodes))
+#else
+#define COMPAT_FIELD_physinfo_get_nr_cpus(p) \
+ ((p).threads_per_core * (p).sockets_per_node * \
+ (p).cores_per_socket * (p).threads_per_core)
+#define COMPAT_FIELD_physinfo_get_sockets_per_node(p) (p).sockets_per_node
+#endif
+
+#if __XEN_LATEST_INTERFACE_VERSION__ >= 0x00030209
+#define COMPAT_FIELD_ADDRESS_BITS mem_flags
+#else
+#define COMPAT_FIELD_ADDRESS_BITS address_bits
+#endif
--- /dev/null
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ *)
+
+(** *)
+type domid = int
+
+(* ** xenctrl.h ** *)
+
+type vcpuinfo =
+{
+ online: bool;
+ blocked: bool;
+ running: bool;
+ cputime: int64;
+ cpumap: int32;
+}
+
+type runstateinfo = {
+ state : int32;
+ missed_changes: int32;
+ state_entry_time : int64;
+ time0 : int64;
+ time1 : int64;
+ time2 : int64;
+ time3 : int64;
+ time4 : int64;
+ time5 : int64;
+}
+
+type domaininfo =
+{
+ domid : domid;
+ dying : bool;
+ shutdown : bool;
+ paused : bool;
+ blocked : bool;
+ running : bool;
+ hvm_guest : bool;
+ shutdown_code : int;
+ total_memory_pages: nativeint;
+ max_memory_pages : nativeint;
+ shared_info_frame : int64;
+ cpu_time : int64;
+ nr_online_vcpus : int;
+ max_vcpu_id : int;
+ ssidref : int32;
+ handle : int array;
+}
+
+type sched_control =
+{
+ weight : int;
+ cap : int;
+}
+
+type physinfo =
+{
+ nr_cpus : int;
+ threads_per_core : int;
+ cores_per_socket : int;
+ sockets_per_node : int;
+ nr_nodes : int;
+ cpu_khz : int;
+ total_pages : nativeint;
+ free_pages : nativeint;
+ scrub_pages : nativeint;
+ (* XXX hw_cap *)
+}
+
+type version =
+{
+ major : int;
+ minor : int;
+ extra : string;
+}
+
+
+type compile_info =
+{
+ compiler : string;
+ compile_by : string;
+ compile_domain : string;
+ compile_date : string;
+}
+
+type shutdown_reason = Poweroff | Reboot | Suspend | Crash | Halt
+
+type domain_create_flag = CDF_HVM | CDF_HAP
+
+exception Error of string
+
+type handle
+
+(* this is only use by coredumping *)
+external sizeof_core_header: unit -> int
+ = "stub_sizeof_core_header"
+external sizeof_vcpu_guest_context: unit -> int
+ = "stub_sizeof_vcpu_guest_context"
+external sizeof_xen_pfn: unit -> int = "stub_sizeof_xen_pfn"
+(* end of use *)
+
+external interface_open: unit -> handle = "stub_xc_interface_open"
+external interface_close: handle -> unit = "stub_xc_interface_close"
+
+external using_injection: unit -> bool = "stub_xc_using_injection"
+
+let with_intf f =
+ let xc = interface_open () in
+ let r = try f xc with exn -> interface_close xc; raise exn in
+ interface_close xc;
+ r
+
+external _domain_create: handle -> int32 -> domain_create_flag list -> int array -> domid
+ = "stub_xc_domain_create"
+
+let domain_create handle n flags uuid =
+ _domain_create handle n flags (Uuid.int_array_of_uuid uuid)
+
+external _domain_sethandle: handle -> domid -> int array -> unit
+ = "stub_xc_domain_sethandle"
+
+let domain_sethandle handle n uuid =
+ _domain_sethandle handle n (Uuid.int_array_of_uuid uuid)
+
+external domain_setvmxassist: handle -> domid -> bool -> unit
+ = "stub_xc_domain_setvmxassist"
+
+external domain_max_vcpus: handle -> domid -> int -> unit
+ = "stub_xc_domain_max_vcpus"
+
+external domain_pause: handle -> domid -> unit = "stub_xc_domain_pause"
+external domain_unpause: handle -> domid -> unit = "stub_xc_domain_unpause"
+external domain_resume_fast: handle -> domid -> unit = "stub_xc_domain_resume_fast"
+external domain_destroy: handle -> domid -> unit = "stub_xc_domain_destroy"
+
+external domain_shutdown: handle -> domid -> shutdown_reason -> unit
+ = "stub_xc_domain_shutdown"
+
+external _domain_getinfolist: handle -> domid -> int -> domaininfo list
+ = "stub_xc_domain_getinfolist"
+
+let domain_getinfolist handle first_domain =
+ let nb = 2 in
+ let last_domid l = (List.hd l).domid + 1 in
+ let rec __getlist from =
+ let l = _domain_getinfolist handle from nb in
+ (if List.length l = nb then __getlist (last_domid l) else []) @ l
+ in
+ List.rev (__getlist first_domain)
+
+external domain_getinfo: handle -> domid -> domaininfo= "stub_xc_domain_getinfo"
+
+external domain_get_vcpuinfo: handle -> int -> int -> vcpuinfo
+ = "stub_xc_vcpu_getinfo"
+external domain_get_runstate_info : handle -> int -> runstateinfo
+ = "stub_xc_get_runstate_info"
+
+external domain_ioport_permission: handle -> domid -> int -> int -> bool -> unit
+ = "stub_xc_domain_ioport_permission"
+external domain_iomem_permission: handle -> domid -> nativeint -> nativeint -> bool -> unit
+ = "stub_xc_domain_iomem_permission"
+external domain_irq_permission: handle -> domid -> int -> bool -> unit
+ = "stub_xc_domain_irq_permission"
+
+external vcpu_affinity_set: handle -> domid -> int -> int64 -> unit
+ = "stub_xc_vcpu_setaffinity"
+external vcpu_affinity_get: handle -> domid -> int -> int64
+ = "stub_xc_vcpu_getaffinity"
+
+external vcpu_context_get: handle -> domid -> int -> string
+ = "stub_xc_vcpu_context_get"
+
+external sched_id: handle -> int = "stub_xc_sched_id"
+
+external sched_credit_domain_set: handle -> domid -> sched_control -> unit
+ = "stub_sched_credit_domain_set"
+external sched_credit_domain_get: handle -> domid -> sched_control
+ = "stub_sched_credit_domain_get"
+
+external shadow_allocation_set: handle -> domid -> int -> unit
+ = "stub_shadow_allocation_set"
+external shadow_allocation_get: handle -> domid -> int
+ = "stub_shadow_allocation_get"
+
+external evtchn_alloc_unbound: handle -> domid -> domid -> int
+ = "stub_xc_evtchn_alloc_unbound"
+external evtchn_reset: handle -> domid -> unit = "stub_xc_evtchn_reset"
+
+external readconsolering: handle -> string = "stub_xc_readconsolering"
+
+external send_debug_keys: handle -> string -> unit = "stub_xc_send_debug_keys"
+external physinfo: handle -> physinfo = "stub_xc_physinfo"
+external pcpu_info: handle -> int -> int64 array = "stub_xc_pcpu_info"
+
+external domain_setmaxmem: handle -> domid -> int64 -> unit
+ = "stub_xc_domain_setmaxmem"
+external domain_set_memmap_limit: handle -> domid -> int64 -> unit
+ = "stub_xc_domain_set_memmap_limit"
+external domain_memory_increase_reservation: handle -> domid -> int64 -> unit
+ = "stub_xc_domain_memory_increase_reservation"
+
+external domain_set_machine_address_size: handle -> domid -> int -> unit
+ = "stub_xc_domain_set_machine_address_size"
+external domain_get_machine_address_size: handle -> domid -> int
+ = "stub_xc_domain_get_machine_address_size"
+
+external domain_cpuid_set: handle -> domid -> bool -> (int64 * (int64 option))
+ -> string option array
+ -> string option array
+ = "stub_xc_domain_cpuid_set"
+external domain_cpuid_apply: handle -> domid -> bool -> unit
+ = "stub_xc_domain_cpuid_apply"
+external cpuid_check: (int64 * (int64 option)) -> string option array -> (bool * string option array)
+ = "stub_xc_cpuid_check"
+
+external map_foreign_range: handle -> domid -> int
+ -> nativeint -> Mmap.mmap_interface
+ = "stub_map_foreign_range"
+
+external domain_get_pfn_list: handle -> domid -> nativeint -> nativeint array
+ = "stub_xc_domain_get_pfn_list"
+
+external domain_assign_device: handle -> domid -> (int * int * int * int) -> unit
+ = "stub_xc_domain_assign_device"
+external domain_deassign_device: handle -> domid -> (int * int * int * int) -> unit
+ = "stub_xc_domain_deassign_device"
+external domain_test_assign_device: handle -> domid -> (int * int * int * int) -> bool
+ = "stub_xc_domain_test_assign_device"
+
+external domain_suppress_spurious_page_faults: handle -> domid -> unit
+ = "stub_xc_domain_suppress_spurious_page_faults"
+
+external domain_get_acpi_s_state: handle -> domid -> int = "stub_xc_domain_get_acpi_s_state"
+
+external domain_send_s3resume: handle -> domid -> unit = "stub_xc_domain_send_s3resume"
+
+(** check if some hvm domain got pv driver or not *)
+external hvm_check_pvdriver: handle -> domid -> bool
+ = "stub_xc_hvm_check_pvdriver"
+
+external version: handle -> version = "stub_xc_version_version"
+external version_compile_info: handle -> compile_info
+ = "stub_xc_version_compile_info"
+external version_changeset: handle -> string = "stub_xc_version_changeset"
+external version_capabilities: handle -> string =
+ "stub_xc_version_capabilities"
+
+external watchdog : handle -> int -> int32 -> int
+ = "stub_xc_watchdog"
+
+(* core dump structure *)
+type core_magic = Magic_hvm | Magic_pv
+
+type core_header = {
+ xch_magic: core_magic;
+ xch_nr_vcpus: int;
+ xch_nr_pages: nativeint;
+ xch_index_offset: int64;
+ xch_ctxt_offset: int64;
+ xch_pages_offset: int64;
+}
+
+external marshall_core_header: core_header -> string = "stub_marshall_core_header"
+
+(* coredump *)
+let coredump xch domid fd =
+ let dump s =
+ let wd = Unix.write fd s 0 (String.length s) in
+ if wd <> String.length s then
+ failwith "error while writing";
+ in
+
+ let info = domain_getinfo xch domid in
+
+ let nrpages = info.total_memory_pages in
+ let ctxt = Array.make info.max_vcpu_id None in
+ let nr_vcpus = ref 0 in
+ for i = 0 to info.max_vcpu_id - 1
+ do
+ ctxt.(i) <- try
+ let v = vcpu_context_get xch domid i in
+ incr nr_vcpus;
+ Some v
+ with _ -> None
+ done;
+
+ (* FIXME page offset if not rounded to sup *)
+ let page_offset =
+ Int64.add
+ (Int64.of_int (sizeof_core_header () +
+ (sizeof_vcpu_guest_context () * !nr_vcpus)))
+ (Int64.of_nativeint (
+ Nativeint.mul
+ (Nativeint.of_int (sizeof_xen_pfn ()))
+ nrpages)
+ )
+ in
+
+ let header = {
+ xch_magic = if info.hvm_guest then Magic_hvm else Magic_pv;
+ xch_nr_vcpus = !nr_vcpus;
+ xch_nr_pages = nrpages;
+ xch_ctxt_offset = Int64.of_int (sizeof_core_header ());
+ xch_index_offset = Int64.of_int (sizeof_core_header ()
+ + sizeof_vcpu_guest_context ());
+ xch_pages_offset = page_offset;
+ } in
+
+ dump (marshall_core_header header);
+ for i = 0 to info.max_vcpu_id - 1
+ do
+ match ctxt.(i) with
+ | None -> ()
+ | Some ctxt_i -> dump ctxt_i
+ done;
+ let pfns = domain_get_pfn_list xch domid nrpages in
+ if Array.length pfns <> Nativeint.to_int nrpages then
+ failwith "could not get the page frame list";
+
+ let page_size = Mmap.getpagesize () in
+ for i = 0 to Nativeint.to_int nrpages - 1
+ do
+ let page = map_foreign_range xch domid page_size pfns.(i) in
+ let data = Mmap.read page 0 page_size in
+ Mmap.unmap page;
+ dump data
+ done
+
+(* ** Misc ** *)
+
+(**
+ Convert the given number of pages to an amount in KiB, rounded up.
+ *)
+external pages_to_kib : int64 -> int64 = "stub_pages_to_kib"
+let pages_to_mib pages = Int64.div (pages_to_kib pages) 1024L
+
+let _ = Callback.register_exception "xc.error" (Error "register_callback")
--- /dev/null
+type domid = int
+type vcpuinfo = {
+ online : bool;
+ blocked : bool;
+ running : bool;
+ cputime : int64;
+ cpumap : int32;
+}
+type runstateinfo = {
+ state : int32;
+ missed_changes: int32;
+ state_entry_time : int64;
+ time0 : int64;
+ time1 : int64;
+ time2 : int64;
+ time3 : int64;
+ time4 : int64;
+ time5 : int64;
+}
+type domaininfo = {
+ domid : domid;
+ dying : bool;
+ shutdown : bool;
+ paused : bool;
+ blocked : bool;
+ running : bool;
+ hvm_guest : bool;
+ shutdown_code : int;
+ total_memory_pages : nativeint;
+ max_memory_pages : nativeint;
+ shared_info_frame : int64;
+ cpu_time : int64;
+ nr_online_vcpus : int;
+ max_vcpu_id : int;
+ ssidref : int32;
+ handle : int array;
+}
+type sched_control = { weight : int; cap : int; }
+type physinfo = {
+ nr_cpus : int;
+ threads_per_core : int;
+ cores_per_socket : int;
+ sockets_per_node : int;
+ nr_nodes : int;
+ cpu_khz : int;
+ total_pages : nativeint;
+ free_pages : nativeint;
+ scrub_pages : nativeint;
+}
+type version = { major : int; minor : int; extra : string; }
+type compile_info = {
+ compiler : string;
+ compile_by : string;
+ compile_domain : string;
+ compile_date : string;
+}
+type shutdown_reason = Poweroff | Reboot | Suspend | Crash | Halt
+
+type domain_create_flag = CDF_HVM | CDF_HAP
+
+exception Error of string
+type handle
+external sizeof_core_header : unit -> int = "stub_sizeof_core_header"
+external sizeof_vcpu_guest_context : unit -> int
+ = "stub_sizeof_vcpu_guest_context"
+external sizeof_xen_pfn : unit -> int = "stub_sizeof_xen_pfn"
+external interface_open : unit -> handle = "stub_xc_interface_open"
+external using_injection : unit -> bool = "stub_xc_using_injection"
+external interface_close : handle -> unit = "stub_xc_interface_close"
+val with_intf : (handle -> 'a) -> 'a
+external _domain_create : handle -> int32 -> domain_create_flag list -> int array -> domid
+ = "stub_xc_domain_create"
+val domain_create : handle -> int32 -> domain_create_flag list -> 'a Uuid.t -> domid
+external _domain_sethandle : handle -> domid -> int array -> unit
+ = "stub_xc_domain_sethandle"
+val domain_sethandle : handle -> domid -> 'a Uuid.t -> unit
+external domain_setvmxassist: handle -> domid -> bool -> unit
+ = "stub_xc_domain_setvmxassist"
+external domain_max_vcpus : handle -> domid -> int -> unit
+ = "stub_xc_domain_max_vcpus"
+external domain_pause : handle -> domid -> unit = "stub_xc_domain_pause"
+external domain_unpause : handle -> domid -> unit = "stub_xc_domain_unpause"
+external domain_resume_fast : handle -> domid -> unit
+ = "stub_xc_domain_resume_fast"
+external domain_destroy : handle -> domid -> unit = "stub_xc_domain_destroy"
+external domain_shutdown : handle -> domid -> shutdown_reason -> unit
+ = "stub_xc_domain_shutdown"
+external _domain_getinfolist : handle -> domid -> int -> domaininfo list
+ = "stub_xc_domain_getinfolist"
+val domain_getinfolist : handle -> domid -> domaininfo list
+external domain_getinfo : handle -> domid -> domaininfo
+ = "stub_xc_domain_getinfo"
+external domain_get_vcpuinfo : handle -> int -> int -> vcpuinfo
+ = "stub_xc_vcpu_getinfo"
+external domain_get_runstate_info : handle -> int -> runstateinfo
+ = "stub_xc_get_runstate_info"
+external domain_ioport_permission: handle -> domid -> int -> int -> bool -> unit
+ = "stub_xc_domain_ioport_permission"
+external domain_iomem_permission: handle -> domid -> nativeint -> nativeint -> bool -> unit
+ = "stub_xc_domain_iomem_permission"
+external domain_irq_permission: handle -> domid -> int -> bool -> unit
+ = "stub_xc_domain_irq_permission"
+external vcpu_affinity_set : handle -> domid -> int -> int64 -> unit
+ = "stub_xc_vcpu_setaffinity"
+external vcpu_affinity_get : handle -> domid -> int -> int64
+ = "stub_xc_vcpu_getaffinity"
+external vcpu_context_get : handle -> domid -> int -> string
+ = "stub_xc_vcpu_context_get"
+external sched_id : handle -> int = "stub_xc_sched_id"
+external sched_credit_domain_set : handle -> domid -> sched_control -> unit
+ = "stub_sched_credit_domain_set"
+external sched_credit_domain_get : handle -> domid -> sched_control
+ = "stub_sched_credit_domain_get"
+external shadow_allocation_set : handle -> domid -> int -> unit
+ = "stub_shadow_allocation_set"
+external shadow_allocation_get : handle -> domid -> int
+ = "stub_shadow_allocation_get"
+external evtchn_alloc_unbound : handle -> domid -> domid -> int
+ = "stub_xc_evtchn_alloc_unbound"
+external evtchn_reset : handle -> domid -> unit = "stub_xc_evtchn_reset"
+external readconsolering : handle -> string = "stub_xc_readconsolering"
+external send_debug_keys : handle -> string -> unit = "stub_xc_send_debug_keys"
+external physinfo : handle -> physinfo = "stub_xc_physinfo"
+external pcpu_info: handle -> int -> int64 array = "stub_xc_pcpu_info"
+external domain_setmaxmem : handle -> domid -> int64 -> unit
+ = "stub_xc_domain_setmaxmem"
+external domain_set_memmap_limit : handle -> domid -> int64 -> unit
+ = "stub_xc_domain_set_memmap_limit"
+external domain_memory_increase_reservation :
+ handle -> domid -> int64 -> unit
+ = "stub_xc_domain_memory_increase_reservation"
+external map_foreign_range :
+ handle -> domid -> int -> nativeint -> Mmap.mmap_interface
+ = "stub_map_foreign_range"
+external domain_get_pfn_list :
+ handle -> domid -> nativeint -> nativeint array
+ = "stub_xc_domain_get_pfn_list"
+
+external domain_assign_device: handle -> domid -> (int * int * int * int) -> unit
+ = "stub_xc_domain_assign_device"
+external domain_deassign_device: handle -> domid -> (int * int * int * int) -> unit
+ = "stub_xc_domain_deassign_device"
+external domain_test_assign_device: handle -> domid -> (int * int * int * int) -> bool
+ = "stub_xc_domain_test_assign_device"
+
+external domain_get_acpi_s_state: handle -> domid -> int = "stub_xc_domain_get_acpi_s_state"
+external domain_send_s3resume: handle -> domid -> unit
+ = "stub_xc_domain_send_s3resume"
+
+external hvm_check_pvdriver : handle -> domid -> bool
+ = "stub_xc_hvm_check_pvdriver"
+external version : handle -> version = "stub_xc_version_version"
+external version_compile_info : handle -> compile_info
+ = "stub_xc_version_compile_info"
+external version_changeset : handle -> string = "stub_xc_version_changeset"
+external version_capabilities : handle -> string
+ = "stub_xc_version_capabilities"
+type core_magic = Magic_hvm | Magic_pv
+type core_header = {
+ xch_magic : core_magic;
+ xch_nr_vcpus : int;
+ xch_nr_pages : nativeint;
+ xch_index_offset : int64;
+ xch_ctxt_offset : int64;
+ xch_pages_offset : int64;
+}
+external marshall_core_header : core_header -> string
+ = "stub_marshall_core_header"
+val coredump : handle -> domid -> Unix.file_descr -> unit
+external pages_to_kib : int64 -> int64 = "stub_pages_to_kib"
+val pages_to_mib : int64 -> int64
+external watchdog : handle -> int -> int32 -> int
+ = "stub_xc_watchdog"
+
+external domain_set_machine_address_size: handle -> domid -> int -> unit
+ = "stub_xc_domain_set_machine_address_size"
+external domain_get_machine_address_size: handle -> domid -> int
+ = "stub_xc_domain_get_machine_address_size"
+
+external domain_suppress_spurious_page_faults: handle -> domid -> unit
+ = "stub_xc_domain_suppress_spurious_page_faults"
+
+external domain_cpuid_set: handle -> domid -> bool -> (int64 * (int64 option))
+ -> string option array
+ -> string option array
+ = "stub_xc_domain_cpuid_set"
+external domain_cpuid_apply: handle -> domid -> bool -> unit
+ = "stub_xc_domain_cpuid_apply"
+external cpuid_check: (int64 * (int64 option)) -> string option array -> (bool * string option array)
+ = "stub_xc_cpuid_check"
+
--- /dev/null
+#ifndef __LIBXC_CPUFEATURE_H
+#define __LIBXC_CPUFEATURE_H
+
+/* Intel-defined CPU features, CPUID level 0x00000001 (edx), word 0 */
+#define X86_FEATURE_FPU (0*32+ 0) /* Onboard FPU */
+#define X86_FEATURE_VME (0*32+ 1) /* Virtual Mode Extensions */
+#define X86_FEATURE_DE (0*32+ 2) /* Debugging Extensions */
+#define X86_FEATURE_PSE (0*32+ 3) /* Page Size Extensions */
+#define X86_FEATURE_TSC (0*32+ 4) /* Time Stamp Counter */
+#define X86_FEATURE_MSR (0*32+ 5) /* Model-Specific Registers, RDMSR, WRMSR */
+#define X86_FEATURE_PAE (0*32+ 6) /* Physical Address Extensions */
+#define X86_FEATURE_MCE (0*32+ 7) /* Machine Check Architecture */
+#define X86_FEATURE_CX8 (0*32+ 8) /* CMPXCHG8 instruction */
+#define X86_FEATURE_APIC (0*32+ 9) /* Onboard APIC */
+#define X86_FEATURE_SEP (0*32+11) /* SYSENTER/SYSEXIT */
+#define X86_FEATURE_MTRR (0*32+12) /* Memory Type Range Registers */
+#define X86_FEATURE_PGE (0*32+13) /* Page Global Enable */
+#define X86_FEATURE_MCA (0*32+14) /* Machine Check Architecture */
+#define X86_FEATURE_CMOV (0*32+15) /* CMOV instruction (FCMOVCC and FCOMI too if FPU present) */
+#define X86_FEATURE_PAT (0*32+16) /* Page Attribute Table */
+#define X86_FEATURE_PSE36 (0*32+17) /* 36-bit PSEs */
+#define X86_FEATURE_PN (0*32+18) /* Processor serial number */
+#define X86_FEATURE_CLFLSH (0*32+19) /* Supports the CLFLUSH instruction */
+#define X86_FEATURE_DS (0*32+21) /* Debug Store */
+#define X86_FEATURE_ACPI (0*32+22) /* ACPI via MSR */
+#define X86_FEATURE_MMX (0*32+23) /* Multimedia Extensions */
+#define X86_FEATURE_FXSR (0*32+24) /* FXSAVE and FXRSTOR instructions (fast save and restore */
+ /* of FPU context), and CR4.OSFXSR available */
+#define X86_FEATURE_XMM (0*32+25) /* Streaming SIMD Extensions */
+#define X86_FEATURE_XMM2 (0*32+26) /* Streaming SIMD Extensions-2 */
+#define X86_FEATURE_SELFSNOOP (0*32+27) /* CPU self snoop */
+#define X86_FEATURE_HT (0*32+28) /* Hyper-Threading */
+#define X86_FEATURE_ACC (0*32+29) /* Automatic clock control */
+#define X86_FEATURE_IA64 (0*32+30) /* IA-64 processor */
+#define X86_FEATURE_PBE (0*32+31) /* Pending Break Enable */
+
+/* AMD-defined CPU features, CPUID level 0x80000001, word 1 */
+/* Don't duplicate feature flags which are redundant with Intel! */
+#define X86_FEATURE_SYSCALL (1*32+11) /* SYSCALL/SYSRET */
+#define X86_FEATURE_MP (1*32+19) /* MP Capable. */
+#define X86_FEATURE_NX (1*32+20) /* Execute Disable */
+#define X86_FEATURE_MMXEXT (1*32+22) /* AMD MMX extensions */
+#define X86_FEATURE_FFXSR (1*32+25) /* FFXSR instruction optimizations */
+#define X86_FEATURE_PAGE1GB (1*32+26) /* 1Gb large page support */
+#define X86_FEATURE_RDTSCP (1*32+27) /* RDTSCP */
+#define X86_FEATURE_LM (1*32+29) /* Long Mode (x86-64) */
+#define X86_FEATURE_3DNOWEXT (1*32+30) /* AMD 3DNow! extensions */
+#define X86_FEATURE_3DNOW (1*32+31) /* 3DNow! */
+
+/* Transmeta-defined CPU features, CPUID level 0x80860001, word 2 */
+#define X86_FEATURE_RECOVERY (2*32+ 0) /* CPU in recovery mode */
+#define X86_FEATURE_LONGRUN (2*32+ 1) /* Longrun power control */
+#define X86_FEATURE_LRTI (2*32+ 3) /* LongRun table interface */
+
+/* Other features, Linux-defined mapping, word 3 */
+/* This range is used for feature bits which conflict or are synthesized */
+#define X86_FEATURE_CXMMX (3*32+ 0) /* Cyrix MMX extensions */
+#define X86_FEATURE_K6_MTRR (3*32+ 1) /* AMD K6 nonstandard MTRRs */
+#define X86_FEATURE_CYRIX_ARR (3*32+ 2) /* Cyrix ARRs (= MTRRs) */
+#define X86_FEATURE_CENTAUR_MCR (3*32+ 3) /* Centaur MCRs (= MTRRs) */
+/* cpu types for specific tunings: */
+#define X86_FEATURE_K8 (3*32+ 4) /* Opteron, Athlon64 */
+#define X86_FEATURE_K7 (3*32+ 5) /* Athlon */
+#define X86_FEATURE_P3 (3*32+ 6) /* P3 */
+#define X86_FEATURE_P4 (3*32+ 7) /* P4 */
+#define X86_FEATURE_CONSTANT_TSC (3*32+ 8) /* TSC ticks at a constant rate */
+
+/* Intel-defined CPU features, CPUID level 0x00000001 (ecx), word 4 */
+#define X86_FEATURE_XMM3 (4*32+ 0) /* Streaming SIMD Extensions-3 */
+#define X86_FEATURE_DTES64 (4*32+ 2) /* 64-bit Debug Store */
+#define X86_FEATURE_MWAIT (4*32+ 3) /* Monitor/Mwait support */
+#define X86_FEATURE_DSCPL (4*32+ 4) /* CPL Qualified Debug Store */
+#define X86_FEATURE_VMXE (4*32+ 5) /* Virtual Machine Extensions */
+#define X86_FEATURE_SMXE (4*32+ 6) /* Safer Mode Extensions */
+#define X86_FEATURE_EST (4*32+ 7) /* Enhanced SpeedStep */
+#define X86_FEATURE_TM2 (4*32+ 8) /* Thermal Monitor 2 */
+#define X86_FEATURE_SSSE3 (4*32+ 9) /* Supplemental Streaming SIMD Extensions-3 */
+#define X86_FEATURE_CID (4*32+10) /* Context ID */
+#define X86_FEATURE_CX16 (4*32+13) /* CMPXCHG16B */
+#define X86_FEATURE_XTPR (4*32+14) /* Send Task Priority Messages */
+#define X86_FEATURE_PDCM (4*32+15) /* Perf/Debug Capability MSR */
+#define X86_FEATURE_DCA (4*32+18) /* Direct Cache Access */
+#define X86_FEATURE_SSE4_1 (4*32+19) /* Streaming SIMD Extensions 4.1 */
+#define X86_FEATURE_SSE4_2 (4*32+20) /* Streaming SIMD Extensions 4.2 */
+#define X86_FEATURE_POPCNT (4*32+23) /* POPCNT instruction */
+
+/* VIA/Cyrix/Centaur-defined CPU features, CPUID level 0xC0000001, word 5 */
+#define X86_FEATURE_XSTORE (5*32+ 2) /* on-CPU RNG present (xstore insn) */
+#define X86_FEATURE_XSTORE_EN (5*32+ 3) /* on-CPU RNG enabled */
+#define X86_FEATURE_XCRYPT (5*32+ 6) /* on-CPU crypto (xcrypt insn) */
+#define X86_FEATURE_XCRYPT_EN (5*32+ 7) /* on-CPU crypto enabled */
+#define X86_FEATURE_ACE2 (5*32+ 8) /* Advanced Cryptography Engine v2 */
+#define X86_FEATURE_ACE2_EN (5*32+ 9) /* ACE v2 enabled */
+#define X86_FEATURE_PHE (5*32+ 10) /* PadLock Hash Engine */
+#define X86_FEATURE_PHE_EN (5*32+ 11) /* PHE enabled */
+#define X86_FEATURE_PMM (5*32+ 12) /* PadLock Montgomery Multiplier */
+#define X86_FEATURE_PMM_EN (5*32+ 13) /* PMM enabled */
+
+/* More extended AMD flags: CPUID level 0x80000001, ecx, word 6 */
+#define X86_FEATURE_LAHF_LM (6*32+ 0) /* LAHF/SAHF in long mode */
+#define X86_FEATURE_CMP_LEGACY (6*32+ 1) /* If yes HyperThreading not valid */
+#define X86_FEATURE_SVME (6*32+ 2) /* Secure Virtual Machine */
+#define X86_FEATURE_EXTAPICSPACE (6*32+ 3) /* Extended APIC space */
+#define X86_FEATURE_ALTMOVCR (6*32+ 4) /* LOCK MOV CR accesses CR+8 */
+#define X86_FEATURE_ABM (6*32+ 5) /* Advanced Bit Manipulation */
+#define X86_FEATURE_SSE4A (6*32+ 6) /* AMD Streaming SIMD Extensions-4a */
+#define X86_FEATURE_MISALIGNSSE (6*32+ 7) /* Misaligned SSE Access */
+#define X86_FEATURE_3DNOWPF (6*32+ 8) /* 3DNow! Prefetch */
+#define X86_FEATURE_OSVW (6*32+ 9) /* OS Visible Workaround */
+#define X86_FEATURE_IBS (6*32+ 10) /* Instruction Based Sampling */
+#define X86_FEATURE_SSE5 (6*32+ 11) /* AMD Streaming SIMD Extensions-5 */
+#define X86_FEATURE_SKINIT (6*32+ 12) /* SKINIT, STGI/CLGI, DEV */
+#define X86_FEATURE_WDT (6*32+ 13) /* Watchdog Timer */
+
+#endif /* __LIBXC_CPUFEATURE_H */
--- /dev/null
+#ifndef XC_CPUID_H
+#define XC_CPUID_H
+
+#ifdef XEN_DOMCTL_set_cpuid
+
+#include "xc_cpufeature.h"
+
+#define bitmaskof(idx) (1u << ((idx) & 31))
+#define clear_bit(idx, dst) ((dst) &= ~(1u << ((idx) & 31)))
+#define set_bit(idx, dst) ((dst) |= (1u << ((idx) & 31)))
+
+#define DEF_MAX_BASE 0x00000004u
+#define DEF_MAX_EXT 0x80000008u
+
+static void xc_cpuid(uint32_t eax, uint32_t ecx, uint32_t regs[4])
+{
+ unsigned int realecx = (ecx == XEN_CPUID_INPUT_UNUSED) ? 0 : ecx;
+ asm (
+#ifdef __i386__
+ "push %%ebx; cpuid; mov %%ebx,%1; pop %%ebx"
+#else
+ "push %%rbx; cpuid; mov %%ebx,%1; pop %%rbx"
+#endif
+ : "=a" (regs[0]), "=r" (regs[1]), "=c" (regs[2]), "=d" (regs[3])
+ : "0" (eax), "2" (realecx));
+}
+
+enum { CPU_BRAND_INTEL, CPU_BRAND_AMD, CPU_BRAND_UNKNOWN };
+
+static int xc_cpuid_brand_get(void)
+{
+ uint32_t regs[4];
+ char str[13];
+ uint32_t *istr = (uint32_t *) str;
+
+ xc_cpuid(0, 0, regs);
+ istr[0] = regs[1];
+ istr[1] = regs[3];
+ istr[2] = regs[2];
+ str[12] = '\0';
+ if (strcmp(str, "AuthenticAMD") == 0) {
+ return CPU_BRAND_AMD;
+ } else if (strcmp(str, "GenuineIntel") == 0) {
+ return CPU_BRAND_INTEL;
+ } else
+ return CPU_BRAND_UNKNOWN;
+}
+
+static int hypervisor_is_64bit(int xc)
+{
+ xen_capabilities_info_t xen_caps;
+ return ((xc_version(xc, XENVER_capabilities, &xen_caps) == 0) &&
+ (strstr(xen_caps, "x86_64") != NULL));
+}
+
+static void do_hvm_cpuid_policy(int xc, int domid, uint32_t input, uint32_t regs[4])
+{
+ unsigned long is_pae;
+ int brand;
+
+ /* pae ? */
+ xc_get_hvm_param(xc, domid, HVM_PARAM_PAE_ENABLED, &is_pae);
+ is_pae = !!is_pae;
+
+ switch (input) {
+ case 0x00000000:
+ if (regs[0] > DEF_MAX_BASE)
+ regs[0] = DEF_MAX_BASE;
+ break;
+ case 0x00000001:
+ regs[2] &= (bitmaskof(X86_FEATURE_XMM3) |
+ bitmaskof(X86_FEATURE_SSSE3) |
+ bitmaskof(X86_FEATURE_CX16) |
+ bitmaskof(X86_FEATURE_SSE4_1) |
+ bitmaskof(X86_FEATURE_SSE4_2) |
+ bitmaskof(X86_FEATURE_POPCNT));
+
+ regs[3] &= (bitmaskof(X86_FEATURE_FPU) |
+ bitmaskof(X86_FEATURE_VME) |
+ bitmaskof(X86_FEATURE_DE) |
+ bitmaskof(X86_FEATURE_PSE) |
+ bitmaskof(X86_FEATURE_TSC) |
+ bitmaskof(X86_FEATURE_MSR) |
+ bitmaskof(X86_FEATURE_PAE) |
+ bitmaskof(X86_FEATURE_MCE) |
+ bitmaskof(X86_FEATURE_CX8) |
+ bitmaskof(X86_FEATURE_APIC) |
+ bitmaskof(X86_FEATURE_SEP) |
+ bitmaskof(X86_FEATURE_MTRR) |
+ bitmaskof(X86_FEATURE_PGE) |
+ bitmaskof(X86_FEATURE_MCA) |
+ bitmaskof(X86_FEATURE_CMOV) |
+ bitmaskof(X86_FEATURE_PAT) |
+ bitmaskof(X86_FEATURE_CLFLSH) |
+ bitmaskof(X86_FEATURE_MMX) |
+ bitmaskof(X86_FEATURE_FXSR) |
+ bitmaskof(X86_FEATURE_XMM) |
+ bitmaskof(X86_FEATURE_XMM2));
+ /* We always support MTRR MSRs. */
+ regs[3] |= bitmaskof(X86_FEATURE_MTRR);
+
+ if (!is_pae)
+ clear_bit(X86_FEATURE_PAE, regs[3]);
+ break;
+ case 0x80000000:
+ if (regs[0] > DEF_MAX_EXT)
+ regs[0] = DEF_MAX_EXT;
+ break;
+ case 0x80000001:
+ if (!is_pae)
+ clear_bit(X86_FEATURE_NX, regs[3]);
+ break;
+ case 0x80000008:
+ regs[0] &= 0x0000ffffu;
+ regs[1] = regs[2] = regs[3] = 0;
+ break;
+ case 0x00000002: /* Intel cache info (dumped by AMD policy) */
+ case 0x00000004: /* Intel cache info (dumped by AMD policy) */
+ case 0x80000002: /* Processor name string */
+ case 0x80000003: /* ... continued */
+ case 0x80000004: /* ... continued */
+ case 0x80000005: /* AMD L1 cache/TLB info (dumped by Intel policy) */
+ case 0x80000006: /* AMD L2/3 cache/TLB info ; Intel L2 cache features */
+ break;
+ default:
+ regs[0] = regs[1] = regs[2] = regs[3] = 0;
+ break;
+ }
+
+ brand = xc_cpuid_brand_get();
+ if (brand == CPU_BRAND_AMD) {
+ switch (input) {
+ case 0x00000001:
+ /* Mask Intel-only features. */
+ regs[2] &= ~(bitmaskof(X86_FEATURE_SSSE3) |
+ bitmaskof(X86_FEATURE_SSE4_1) |
+ bitmaskof(X86_FEATURE_SSE4_2));
+ break;
+
+ case 0x00000002:
+ case 0x00000004:
+ regs[0] = regs[1] = regs[2] = 0;
+ break;
+
+ case 0x80000001: {
+ int is_64bit = hypervisor_is_64bit(xc) && is_pae;
+
+ if (!is_pae)
+ clear_bit(X86_FEATURE_PAE, regs[3]);
+ clear_bit(X86_FEATURE_PSE36, regs[3]);
+
+ /* Filter all other features according to a whitelist. */
+ regs[2] &= ((is_64bit ? bitmaskof(X86_FEATURE_LAHF_LM) : 0) |
+ bitmaskof(X86_FEATURE_ALTMOVCR) |
+ bitmaskof(X86_FEATURE_ABM) |
+ bitmaskof(X86_FEATURE_SSE4A) |
+ bitmaskof(X86_FEATURE_MISALIGNSSE) |
+ bitmaskof(X86_FEATURE_3DNOWPF));
+ regs[3] &= (0x0183f3ff | /* features shared with 0x00000001:EDX */
+ (is_pae ? bitmaskof(X86_FEATURE_NX) : 0) |
+ (is_64bit ? bitmaskof(X86_FEATURE_LM) : 0) |
+ bitmaskof(X86_FEATURE_SYSCALL) |
+ bitmaskof(X86_FEATURE_MP) |
+ bitmaskof(X86_FEATURE_MMXEXT) |
+ bitmaskof(X86_FEATURE_FFXSR) |
+ bitmaskof(X86_FEATURE_3DNOW) |
+ bitmaskof(X86_FEATURE_3DNOWEXT));
+ break;
+ }
+ }
+ } else if (brand == CPU_BRAND_INTEL) {
+ switch (input) {
+ case 0x00000001:
+ /* Mask AMD-only features. */
+ regs[2] &= ~(bitmaskof(X86_FEATURE_POPCNT));
+ break;
+
+ case 0x00000004:
+ regs[0] &= 0x3FF;
+ regs[3] &= 0x3FF;
+ break;
+
+ case 0x80000001:
+ {
+ int is_64bit = hypervisor_is_64bit(xc) && is_pae;
+
+ /* Only a few features are advertised in Intel's 0x80000001. */
+ regs[2] &= (is_64bit ? bitmaskof(X86_FEATURE_LAHF_LM) : 0);
+ regs[3] &= ((is_pae ? bitmaskof(X86_FEATURE_NX) : 0) |
+ (is_64bit ? bitmaskof(X86_FEATURE_LM) : 0) |
+ (is_64bit ? bitmaskof(X86_FEATURE_SYSCALL) : 0));
+ break;
+ }
+ case 0x80000005:
+ {
+ regs[0] = regs[1] = regs[2] = 0;
+ break;
+ }
+ }
+ }
+}
+
+static void do_pv_cpuid_policy(int xc, int domid, uint32_t input, uint32_t regs[4])
+{
+ int brand;
+ int guest_64_bits, xen_64_bits;
+ int ret;
+
+ ret = xc_domain_get_address_size(xc, domid);
+ if (ret < 0)
+ return;
+ guest_64_bits = (ret == 64);
+ xen_64_bits = hypervisor_is_64bit(xc);
+ brand = xc_cpuid_brand_get();
+
+ if ((input & 0x7fffffff) == 1) {
+ clear_bit(X86_FEATURE_VME, regs[3]);
+ clear_bit(X86_FEATURE_PSE, regs[3]);
+ clear_bit(X86_FEATURE_PGE, regs[3]);
+ clear_bit(X86_FEATURE_MCE, regs[3]);
+ clear_bit(X86_FEATURE_MCA, regs[3]);
+ clear_bit(X86_FEATURE_MTRR, regs[3]);
+ clear_bit(X86_FEATURE_PSE36, regs[3]);
+ }
+
+ switch (input) {
+ case 1:
+ if (!xen_64_bits || brand == CPU_BRAND_AMD)
+ clear_bit(X86_FEATURE_SEP, regs[3]);
+ clear_bit(X86_FEATURE_DS, regs[3]);
+ clear_bit(X86_FEATURE_ACC, regs[3]);
+ clear_bit(X86_FEATURE_PBE, regs[3]);
+
+ clear_bit(X86_FEATURE_DTES64, regs[2]);
+ clear_bit(X86_FEATURE_MWAIT, regs[2]);
+ clear_bit(X86_FEATURE_DSCPL, regs[2]);
+ clear_bit(X86_FEATURE_VMXE, regs[2]);
+ clear_bit(X86_FEATURE_SMXE, regs[2]);
+ clear_bit(X86_FEATURE_EST, regs[2]);
+ clear_bit(X86_FEATURE_TM2, regs[2]);
+ if (!guest_64_bits)
+ clear_bit(X86_FEATURE_CX16, regs[2]);
+ clear_bit(X86_FEATURE_XTPR, regs[2]);
+ clear_bit(X86_FEATURE_PDCM, regs[2]);
+ clear_bit(X86_FEATURE_DCA, regs[2]);
+ break;
+ case 0x80000001:
+ if (!guest_64_bits) {
+ clear_bit(X86_FEATURE_LM, regs[3]);
+ clear_bit(X86_FEATURE_LAHF_LM, regs[2]);
+ if (brand != CPU_BRAND_AMD)
+ clear_bit(X86_FEATURE_SYSCALL, regs[3]);
+ } else
+ set_bit(X86_FEATURE_SYSCALL, regs[3]);
+ clear_bit(X86_FEATURE_PAGE1GB, regs[3]);
+ clear_bit(X86_FEATURE_RDTSCP, regs[3]);
+
+ clear_bit(X86_FEATURE_SVME, regs[2]);
+ clear_bit(X86_FEATURE_OSVW, regs[2]);
+ clear_bit(X86_FEATURE_IBS, regs[2]);
+ clear_bit(X86_FEATURE_SKINIT, regs[2]);
+ clear_bit(X86_FEATURE_WDT, regs[2]);
+ break;
+ case 5: /* MONITOR/MWAIT */
+ case 0xa: /* Architectural Performance Monitor Features */
+ case 0x8000000a: /* SVM revision and features */
+ case 0x8000001b: /* Instruction Based Sampling */
+ regs[0] = regs[1] = regs[2] = regs[3] = 0;
+ break;
+ }
+}
+
+static void do_cpuid_policy(int xc, int domid, int hvm, uint32_t input, uint32_t regs[4])
+{
+ if (hvm)
+ do_hvm_cpuid_policy(xc, domid, input, regs);
+ else
+ do_pv_cpuid_policy(xc, domid, input, regs);
+}
+
+#endif
+
+#endif
--- /dev/null
+#ifndef __XC_E820_H__
+#define __XC_E820_H__
+
+#include <xen/hvm/e820.h>
+
+/*
+ * PC BIOS standard E820 types and structure.
+ */
+#define E820_RAM 1
+#define E820_RESERVED 2
+#define E820_ACPI 3
+#define E820_NVS 4
+
+struct e820entry {
+ uint64_t addr;
+ uint64_t size;
+ uint32_t type;
+} __attribute__((packed));
+
+#endif /* __XC_E820_H__ */
--- /dev/null
+/*
+ * Copyright (c) 2006-2007 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ */
+
+#include <stdint.h>
+#include <unistd.h>
+#include <string.h>
+#include <fcntl.h>
+#include <stdio.h>
+#include <errno.h>
+#include <sys/ioctl.h>
+#include <sys/mman.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <stdlib.h>
+#include <stdarg.h>
+
+#include "xc.h"
+
+#define PAGE_SHIFT 12
+#define PAGE_SIZE (1UL << PAGE_SHIFT)
+#define PAGE_MASK (~(PAGE_SIZE-1))
+
+#define MIN(a, b) (((a) < (b)) ? (a) : (b))
+
+#define DECLARE_DOMCTL(_cmd, _domain) \
+ struct xen_domctl domctl = { \
+ .cmd = _cmd, \
+ .domain = _domain, \
+ .interface_version = XEN_DOMCTL_INTERFACE_VERSION, \
+ }
+
+#define DECLARE_SYSCTL(_cmd) \
+ struct xen_sysctl sysctl = { \
+ .cmd = _cmd, \
+ .interface_version = XEN_SYSCTL_INTERFACE_VERSION, \
+ }
+
+#define DECLARE_HYPERCALL2(_cmd, _arg0, _arg1) \
+ privcmd_hypercall_t hypercall = { \
+ .op = _cmd, \
+ .arg[0] = (unsigned long) _arg0,\
+ .arg[1] = (unsigned long) _arg1,\
+ }
+#define DECLARE_HYPERCALL0(_cmd) DECLARE_HYPERCALL2(_cmd, 0, 0);
+#define DECLARE_HYPERCALL1(_cmd, _arg0) DECLARE_HYPERCALL2(_cmd, _arg0, 0);
+
+/*---- Errors handlings ----*/
+#ifndef WITHOUT_GOOD_ERROR
+#define ERROR_STRLEN 256
+
+static char __error_str[ERROR_STRLEN];
+
+char * xc_error_get(void)
+{
+ return __error_str;
+}
+
+static void xc_error_set(const char *fmt, ...)
+{
+ va_list ap;
+ char __errordup[ERROR_STRLEN];
+
+ va_start(ap, fmt);
+ vsnprintf(__errordup, ERROR_STRLEN, fmt, ap);
+ va_end(ap);
+ memcpy(__error_str, __errordup, ERROR_STRLEN);
+}
+
+static void xc_error_dom_set(unsigned int domid, const char *fmt, ...)
+{
+ va_list ap;
+ char __errordup[ERROR_STRLEN];
+ int i;
+
+ i = snprintf(__errordup, ERROR_STRLEN, "domain %u - ", domid);
+ va_start(ap, fmt);
+ i += vsnprintf(__errordup + i, ERROR_STRLEN - i, fmt, ap);
+ va_end(ap);
+ snprintf(__errordup + i, ERROR_STRLEN - i,
+ " failed: %s", xc_error_get());
+ memcpy(__error_str, __errordup, ERROR_STRLEN);
+}
+
+void xc_error_clear(void)
+{
+ memset(__error_str, '\0', ERROR_STRLEN);
+}
+#else
+char * xc_error_get(void)
+{
+ return "";
+}
+#define xc_error_set(fmt, ...) do {} while (0)
+#define xc_error_dom_set(id, fmt, ...) do {} while (0)
+#define xc_error_clear() do {} while (0)
+#endif
+
+#define xc_error_hypercall(_h, _r) \
+ xc_error_set("hypercall %lld fail: %d: %s (ret %d)", _h.op, errno, errno ? strerror(errno) : strerror(-_r), _r)
+
+#define WITH_INJECTION_CAPABILITY
+#include "xc_lib_injection.c"
+
+int xc_using_injection(void)
+{
+ return using_injection ();
+}
+
+/*---- Trivia ----*/
+int xc_interface_open(void)
+{
+ int fd, ret;
+
+ pre_interface_open();
+
+ fd = open("/proc/xen/privcmd", O_RDWR);
+ if (fd == -1) {
+ xc_error_set("open /proc/xen/privcmd failed: %s",
+ strerror(errno));
+ return -1;
+ }
+
+ ret = fcntl(fd, F_GETFD);
+ if (ret < 0) {
+ xc_error_set("cannot get handle flags: %s",
+ strerror(errno));
+ goto out;
+ }
+
+ ret = fcntl(fd, F_SETFD, ret | FD_CLOEXEC);
+ if (ret < 0) {
+ xc_error_set("cannot set handle flags: %s",
+ strerror(errno));
+ goto out;
+ }
+
+ return fd;
+out:
+ close(fd);
+ return -1;
+}
+
+int xc_interface_close(int handle)
+{
+ int ret;
+
+ pre_interface_close(handle);
+
+ ret = close(handle);
+ if (ret != 0)
+ xc_error_set("close xc failed: %s", strerror(errno));
+ return ret;
+}
+
+/*---- Low private operations ----*/
+static int do_xen_hypercall(int handle, privcmd_hypercall_t *hypercall)
+{
+ pre_xen_hypercall(handle, hypercall);
+ return ioctl(handle, IOCTL_PRIVCMD_HYPERCALL, (unsigned long) hypercall);
+}
+
+static int do_domctl(int handle, struct xen_domctl *domctl)
+{
+ int ret;
+ DECLARE_HYPERCALL1(__HYPERVISOR_domctl, domctl);
+
+ if (mlock(domctl, sizeof(*domctl)) != 0) {
+ xc_error_set("mlock failed: %s", strerror(errno));
+ return -1;
+ }
+
+ ret = do_xen_hypercall(handle, &hypercall);
+ if (ret < 0)
+ xc_error_hypercall(hypercall, ret);
+
+ munlock(domctl, sizeof(*domctl));
+ return ret;
+}
+
+static int do_sysctl(int handle, struct xen_sysctl *sysctl)
+{
+ int ret;
+ DECLARE_HYPERCALL1(__HYPERVISOR_sysctl, sysctl);
+
+ if (mlock(sysctl, sizeof(*sysctl)) != 0) {
+ xc_error_set("mlock failed: %s", strerror(errno));
+ return -1;
+ }
+
+ ret = do_xen_hypercall(handle, &hypercall);
+ if (ret < 0)
+ xc_error_hypercall(hypercall, ret);
+
+ munlock(sysctl, sizeof(*sysctl));
+ return ret;
+}
+
+static int do_evtchnctl(int handle, int cmd, void *arg, size_t arg_size)
+{
+ DECLARE_HYPERCALL2(__HYPERVISOR_event_channel_op, cmd, arg);
+ int ret;
+
+ if (mlock(arg, arg_size) != 0) {
+ xc_error_set("mlock failed: %s", strerror(errno));
+ return -1;
+ }
+
+ ret = do_xen_hypercall(handle, &hypercall);
+ if (ret < 0)
+ xc_error_hypercall(hypercall, ret);
+ munlock(arg, arg_size);
+ return ret;
+}
+
+static int do_memctl_reservation(int handle, int cmd,
+ struct xen_memory_reservation *reservation)
+{
+ int ret;
+ DECLARE_HYPERCALL2(__HYPERVISOR_memory_op, cmd, reservation);
+ xen_pfn_t *extent_start;
+
+ if (cmd != XENMEM_increase_reservation &&
+ cmd != XENMEM_decrease_reservation &&
+ cmd != XENMEM_populate_physmap) {
+ xc_error_set("do_memctl_reservation: unknown cmd %d", cmd);
+ return -EINVAL;
+ }
+
+ if (mlock(reservation, sizeof(*reservation)) == -1) {
+ xc_error_set("mlock failed: %s", strerror(errno));
+ return -ENOMEM;
+ }
+ get_xen_guest_handle(extent_start, reservation->extent_start);
+ if (extent_start && mlock(extent_start, reservation->nr_extents
+ * sizeof(xen_pfn_t)) == -1) {
+ xc_error_set("mlock failed: %s", strerror(errno));
+ munlock(reservation, sizeof(*reservation));
+ return -3;
+ }
+
+ ret = do_xen_hypercall(handle, &hypercall);
+ if (ret)
+ xc_error_hypercall(hypercall, ret);
+ munlock(extent_start, reservation->nr_extents * sizeof(xen_pfn_t));
+ get_xen_guest_handle(extent_start, reservation->extent_start);
+ munlock(reservation, sizeof(*reservation));
+ return ret;
+}
+
+static int do_ioctl(int handle, int cmd, void *arg)
+{
+ pre_ioctl(handle, cmd, arg);
+ return ioctl(handle, cmd, arg);
+}
+
+static void * do_mmap(void *start, size_t length, int prot, int flags,
+ int fd, off_t offset)
+{
+ pre_mmap(start, length, prot, flags, fd, offset);
+ return mmap(start, length, prot, flags, fd, offset);
+}
+
+int xc_get_hvm_param(int handle, unsigned int domid,
+ int param, unsigned long *value)
+{
+ struct xen_hvm_param arg = {
+ .domid = domid,
+ .index = param,
+ };
+ DECLARE_HYPERCALL2(__HYPERVISOR_hvm_op, HVMOP_get_param,
+ (unsigned long) &arg);
+ int ret;
+
+ if (mlock(&arg, sizeof(arg)) == -1) {
+ xc_error_set("mlock failed: %s", strerror(errno));
+ return -1;
+ }
+
+ ret = do_xen_hypercall(handle, &hypercall);
+ if (ret)
+ xc_error_hypercall(hypercall, ret);
+ *value = arg.value;
+ munlock(&arg, sizeof(arg));
+ return ret;
+}
+
+static int xc_set_hvm_param(int handle, unsigned int domid,
+ int param, unsigned long value)
+{
+ struct xen_hvm_param arg = {
+ .domid = domid,
+ .index = param,
+ .value = value,
+ };
+ DECLARE_HYPERCALL2(__HYPERVISOR_hvm_op, HVMOP_set_param, (unsigned long) &arg);
+ int ret;
+
+ if (mlock(&arg, sizeof(arg)) == -1) {
+ xc_error_set("mlock failed: %s", strerror(errno));
+ return -1;
+ }
+
+ ret = do_xen_hypercall(handle, &hypercall);
+ if (ret)
+ xc_error_hypercall(hypercall, ret);
+ munlock(&arg, sizeof(arg));
+ return ret;
+}
+
+/*---- XC API ----*/
+int xc_domain_create(int handle, unsigned int ssidref,
+ xen_domain_handle_t dhandle,
+ unsigned int flags, unsigned int *pdomid)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_createdomain, *pdomid);
+ domctl.u.createdomain.ssidref = ssidref;
+ domctl.u.createdomain.flags = flags;
+ memcpy(domctl.u.createdomain.handle, dhandle, sizeof(xen_domain_handle_t));
+
+ ret = do_domctl(handle, &domctl);
+ if (ret != 0) {
+ xc_error_set("creating domain failed: %s", xc_error_get());
+ return ret;
+ }
+ *pdomid = domctl.domain;
+ return 0;
+}
+
+int xc_domain_pause(int handle, unsigned int domid)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_pausedomain, domid);
+
+ ret = do_domctl(handle, &domctl);
+ if (ret != 0)
+ xc_error_dom_set(domid, "pause");
+ return ret;
+}
+
+int xc_domain_unpause(int handle, unsigned int domid)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_unpausedomain, domid);
+
+ ret = do_domctl(handle, &domctl);
+ if (ret != 0)
+ xc_error_dom_set(domid, "unpause");
+ return ret;
+}
+
+/* return 1 if hvm domain got pv driver, 0 if not. -1 is error occurs */
+int xc_hvm_check_pvdriver(int handle, unsigned int domid)
+{
+ int ret;
+ unsigned long irq = 0;
+ xc_domaininfo_t info;
+
+ ret = xc_domain_getinfolist(handle, domid, 1, &info);
+ if (ret != 1) {
+ xc_error_set("domain getinfo failed: %s", strerror(errno));
+ xc_error_dom_set(domid, "hvm_check_pvdriver");
+ return -1;
+ }
+
+ if (!info.flags & XEN_DOMINF_hvm_guest) {
+ xc_error_set("domain is not hvm");
+ xc_error_dom_set(domid, "hvm_check_pvdriver");
+ return -1;
+ }
+ xc_get_hvm_param(handle, domid, HVM_PARAM_CALLBACK_IRQ, &irq);
+ return irq;
+}
+
+static int modify_returncode_register(int handle, unsigned int domid)
+{
+ int ret;
+ xc_domaininfo_t info;
+ xen_capabilities_info_t caps;
+ vcpu_guest_context_any_t context;
+
+ ret = xc_domain_getinfolist(handle, domid, 1, &info);
+ if (ret != 1) {
+ xc_error_set("domain getinfo failed: %s", strerror(errno));
+ return -1;
+ }
+
+ /* HVM guests without PV drivers do not have a return code to modify */
+ if (info.flags & XEN_DOMINF_hvm_guest) {
+ unsigned long irq = 0;
+ xc_get_hvm_param(handle, domid, HVM_PARAM_CALLBACK_IRQ, &irq);
+ if (!irq)
+ return 0;
+ }
+
+ ret = xc_version(handle, XENVER_capabilities, &caps);
+ if (ret) {
+ xc_error_set("could not get Xen capabilities");
+ return ret;
+ }
+
+ ret = xc_vcpu_getcontext(handle, domid, 0, &context);
+ if (ret) {
+ xc_error_set("could not get vcpu 0 context");
+ return ret;
+ }
+
+ if (!(info.flags & XEN_DOMINF_hvm_guest))
+ context.c.user_regs.eax = 1;
+ else if (strstr(caps, "x86_64"))
+ context.x64.user_regs.eax = 1;
+ else
+ context.x32.user_regs.eax = 1;
+
+ ret = xc_vcpu_setcontext(handle, domid, 0, &context);
+ if (ret) {
+ xc_error_set("could not set vcpu 0 context");
+ return ret;
+ }
+ return 0;
+}
+
+int xc_domain_resume_fast(int handle, unsigned int domid)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_resumedomain, domid);
+
+ ret = modify_returncode_register(handle, domid);
+ if (ret != 0) {
+ xc_error_dom_set(domid, "resume_fast");
+ return ret;
+ }
+
+ ret = do_domctl(handle, &domctl);
+ if (ret != 0)
+ xc_error_dom_set(domid, "resume_fast");
+ return ret;
+}
+
+int xc_domain_destroy(int handle, unsigned int domid)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_destroydomain, domid);
+
+ do {
+ ret = do_domctl(handle, &domctl);
+ } while (ret && (errno == EAGAIN));
+ if (ret != 0)
+ xc_error_dom_set(domid, "destroy");
+ return ret;
+}
+
+int xc_domain_shutdown(int handle, int domid, int reason)
+{
+ sched_remote_shutdown_t arg = {
+ .domain_id = domid,
+ .reason = reason,
+ };
+ DECLARE_HYPERCALL2(__HYPERVISOR_sched_op, SCHEDOP_remote_shutdown, &arg);
+ int ret;
+
+ if (mlock(&arg, sizeof(arg)) != 0) {
+ xc_error_set("mlock failed: %s", strerror(errno));
+ xc_error_dom_set(domid, "shutdown %d", reason);
+ return -1;
+ }
+
+ ret = do_xen_hypercall(handle, &hypercall);
+ if (ret < 0) {
+ xc_error_hypercall(hypercall, ret);
+ xc_error_dom_set(domid, "shutdown %d", reason);
+ }
+ munlock(&arg, sizeof(arg));
+ return ret;
+}
+
+int xc_vcpu_setaffinity(int handle, unsigned int domid, int vcpu,
+ uint64_t cpumap)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_setvcpuaffinity, domid);
+ domctl.u.vcpuaffinity.vcpu = vcpu;
+ domctl.u.vcpuaffinity.cpumap.nr_cpus = sizeof(cpumap) * 8;
+
+ set_xen_guest_handle(domctl.u.vcpuaffinity.cpumap.bitmap, (uint8_t *) &cpumap);
+
+ if (mlock(&cpumap, sizeof(cpumap)) != 0) {
+ xc_error_set("mlock failed: %s", strerror(errno));
+ xc_error_dom_set(domid, "vcpu %d set affinity", vcpu);
+ return -1;
+ }
+
+ ret = do_domctl(handle, &domctl);
+ if (ret < 0)
+ xc_error_dom_set(domid, "vcpu %d set affinity", vcpu);
+ munlock(&cpumap, sizeof(cpumap));
+ return ret;
+}
+
+int xc_vcpu_getaffinity(int handle, unsigned int domid, int vcpu,
+ uint64_t *cpumap)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_getvcpuaffinity, domid);
+ domctl.u.vcpuaffinity.vcpu = vcpu;
+ domctl.u.vcpuaffinity.cpumap.nr_cpus = sizeof(*cpumap) * 8;
+
+ set_xen_guest_handle(domctl.u.vcpuaffinity.cpumap.bitmap, cpumap);
+
+ if (mlock(cpumap, sizeof(*cpumap)) != 0) {
+ xc_error_set("mlock failed: %s", strerror(errno));
+ xc_error_dom_set(domid, "vcpu %d get affinity", vcpu);
+ return -1;
+ }
+
+ ret = do_domctl(handle, &domctl);
+ if (ret < 0)
+ xc_error_dom_set(domid, "vcpu %d get affinity", vcpu);
+ munlock(cpumap, sizeof(*cpumap));
+ return ret;
+}
+
+int xc_vcpu_context_get(int handle, unsigned int domid, unsigned short vcpu,
+ struct vcpu_guest_context *ctxt)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_getvcpucontext, domid);
+ domctl.u.vcpucontext.vcpu = vcpu;
+
+ set_xen_guest_handle(domctl.u.vcpucontext.ctxt, ctxt);
+
+ if (mlock(ctxt, sizeof(struct vcpu_guest_context)) != 0) {
+ xc_error_set("mlock failed: %s", strerror(errno));
+ xc_error_dom_set(domid, "vcpu %d get context", vcpu);
+ return -1;
+ }
+
+ ret = do_domctl(handle, &domctl);
+ if (ret < 0)
+ xc_error_dom_set(domid, "vcpu %d get context", vcpu);
+ munlock(ctxt, sizeof(struct vcpu_guest_context));
+
+ return ret;
+}
+
+int xc_domain_getinfolist(int handle, unsigned int first_domain,
+ unsigned int max_domains, xc_domaininfo_t *info)
+{
+ int ret;
+ DECLARE_SYSCTL(XEN_SYSCTL_getdomaininfolist);
+ sysctl.u.getdomaininfolist.first_domain = first_domain;
+ sysctl.u.getdomaininfolist.max_domains = max_domains;
+ set_xen_guest_handle(sysctl.u.getdomaininfolist.buffer, info);
+
+ if (mlock(info, max_domains * sizeof(xc_domaininfo_t)) != 0) {
+ xc_error_set("getinfolist(%d, %u, %u, %x (%d)) failed: mlock failed: %s",
+ handle, first_domain, max_domains, info, sizeof(xc_domaininfo_t),
+ strerror(errno));
+ return -1;
+ }
+
+ ret = do_sysctl(handle, &sysctl);
+ if (ret < 0)
+ xc_error_set("getinfolist(%d, %u, %u, %x (%d)) failed: %s",
+ handle, first_domain, max_domains, info, sizeof(xc_domaininfo_t),
+ xc_error_get());
+ else
+ ret = sysctl.u.getdomaininfolist.num_domains;
+
+ munlock(info, max_domains * sizeof(xc_domaininfo_t));
+ return ret;
+}
+
+int xc_domain_getinfo(int handle, unsigned int domid, xc_domaininfo_t *info)
+{
+ int ret;
+ ret = xc_domain_getinfolist(handle, domid, 1, info);
+ if (ret != 1) {
+ xc_error_set("getinfo failed: domain %d: %s", domid, xc_error_get());
+ return -1;
+ }
+
+ /* If the requested domain didn't exist but there exists one with a
+ higher domain ID, this will be returned. We consider this an error since
+ we only wanted info about a specific domain. */
+ if (info->domain != domid) {
+ xc_error_set("getinfo failed: domain %d nolonger exists", domid);
+ return -1;
+ }
+
+ return 0;
+}
+
+int xc_domain_setmaxmem(int handle, unsigned int domid, unsigned int max_memkb)
+{
+ DECLARE_DOMCTL(XEN_DOMCTL_max_mem, domid);
+ domctl.u.max_mem.max_memkb = max_memkb;
+ int ret;
+
+ ret = do_domctl(handle, &domctl);
+ if (ret < 0)
+ xc_error_dom_set(domid, "set max memory to %u", max_memkb);
+ return ret;
+}
+
+int xc_domain_set_memmap_limit(int handle, unsigned int domid,
+ unsigned long map_limitkb)
+{
+ int ret;
+ struct xen_foreign_memory_map fmap = {
+ .domid = domid,
+ .map = { .nr_entries = 1 }
+ };
+ struct e820entry e820 = {
+ .addr = 0,
+ .size = (uint64_t)map_limitkb << 10,
+ .type = E820_RAM
+ };
+ DECLARE_HYPERCALL2(__HYPERVISOR_memory_op, XENMEM_set_memory_map, &fmap);
+
+ set_xen_guest_handle(fmap.map.buffer, &e820);
+
+ if (mlock(&fmap, sizeof(fmap)) != 0) {
+ xc_error_set("set_memmap_limit failed: mlock failed: %s",
+ strerror(errno));
+ return -1;
+ }
+
+ if (mlock(&e820, sizeof(e820)) != 0) {
+ xc_error_set("set_memmap_limit failed: mlock failed: %s",
+ strerror(errno));
+ munlock(&fmap, sizeof(fmap));
+ return -1;
+ }
+
+ ret = do_xen_hypercall(handle, &hypercall);
+ if (ret)
+ xc_error_hypercall(hypercall, ret);
+
+ munlock(&e820, sizeof(e820));
+ munlock(&fmap, sizeof(fmap));
+ return ret;
+}
+
+int xc_domain_set_time_offset(int handle, unsigned int domid, int time_offset)
+{
+ DECLARE_DOMCTL(XEN_DOMCTL_settimeoffset, domid);
+ domctl.u.settimeoffset.time_offset_seconds = time_offset;
+ int ret;
+
+ ret = do_domctl(handle, &domctl);
+ if (ret < 0)
+ xc_error_dom_set(domid, "set time offset %d", time_offset);
+ return ret;
+}
+
+int xc_domain_memory_increase_reservation(int handle, unsigned int domid,
+ unsigned long nr_extents,
+ unsigned int extent_order,
+ unsigned int address_bits,
+ xen_pfn_t *extent_start)
+{
+ int ret;
+ struct xen_memory_reservation reservation = {
+ .nr_extents = nr_extents,
+ .extent_order = extent_order,
+ .COMPAT_FIELD_ADDRESS_BITS = address_bits,
+ .domid = domid
+ };
+
+ set_xen_guest_handle(reservation.extent_start, extent_start);
+
+ ret = do_memctl_reservation(handle, XENMEM_increase_reservation,
+ &reservation);
+ if (ret != nr_extents) {
+ xc_error_dom_set(domid, "increase reservation to %lu",
+ nr_extents);
+ return (ret >= 0) ? -1 : ret;
+ }
+ return 0;
+}
+
+int xc_domain_memory_decrease_reservation(int handle, unsigned int domid,
+ unsigned long nr_extents,
+ unsigned int extent_order,
+ unsigned int address_bits,
+ xen_pfn_t *extent_start)
+{
+ int ret;
+ struct xen_memory_reservation reservation = {
+ .nr_extents = nr_extents,
+ .extent_order = extent_order,
+ .COMPAT_FIELD_ADDRESS_BITS = 0,
+ .domid = domid
+ };
+
+ set_xen_guest_handle(reservation.extent_start, extent_start);
+ if (!extent_start) {
+ xc_error_set("decrease reservation: extent start is NULL");
+ return -EINVAL;
+ }
+
+ ret = do_memctl_reservation(handle, XENMEM_decrease_reservation,
+ &reservation);
+ if (ret < nr_extents) {
+ xc_error_dom_set(domid, "decrease reservation to %lu",
+ nr_extents);
+ return (ret >= 0) ? -1 : ret;
+ }
+ return 0;
+}
+
+int xc_domain_memory_populate_physmap(int handle, unsigned int domid,
+ unsigned long nr_extents,
+ unsigned int extent_order,
+ unsigned int address_bits,
+ xen_pfn_t *extent_start)
+{
+ int ret;
+ struct xen_memory_reservation reservation = {
+ .nr_extents = nr_extents,
+ .extent_order = extent_order,
+ .COMPAT_FIELD_ADDRESS_BITS = address_bits,
+ .domid = domid
+ };
+
+ set_xen_guest_handle(reservation.extent_start, extent_start);
+ ret = do_memctl_reservation(handle, XENMEM_populate_physmap,
+ &reservation);
+ if (ret < nr_extents) {
+ xc_error_dom_set(domid, "populate physmap");
+ return (ret >= 0) ? -1 : ret;
+ }
+ return 0;
+}
+
+int xc_domain_setvmxassist(int handle, unsigned int domid, int use_vmxassist)
+{
+ int ret = 0;
+#ifdef XEN_DOMCTL_setvmxassist
+ DECLARE_DOMCTL(XEN_DOMCTL_setvmxassist, domid);
+ domctl.u.setvmxassist.use_vmxassist = use_vmxassist;
+
+ ret = do_domctl(handle, &domctl);
+ if (ret)
+ xc_error_dom_set(domid, "setting vmxassist to %d",
+ use_vmxassist);
+#endif
+ return ret;
+}
+
+int xc_domain_max_vcpus(int handle, unsigned int domid, unsigned int max)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_max_vcpus, domid);
+ domctl.u.max_vcpus.max = max;
+
+ ret = do_domctl(handle, &domctl);
+ if (ret)
+ xc_error_dom_set(domid, "setting max vcpus to %d", max);
+ return ret;
+}
+
+int xc_domain_sethandle(int handle, unsigned int domid,
+ xen_domain_handle_t dhandle)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_setdomainhandle, domid);
+ memcpy(domctl.u.setdomainhandle.handle, dhandle, sizeof(xen_domain_handle_t));
+
+ ret = do_domctl(handle, &domctl);
+ if (ret)
+ xc_error_dom_set(domid, "set handle");
+ return ret;
+}
+
+int xc_vcpu_getinfo(int handle, unsigned int domid, unsigned int vcpu,
+ xc_vcpuinfo_t *info)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_getvcpuinfo, domid);
+ domctl.u.getvcpuinfo.vcpu = vcpu;
+
+ ret = do_domctl(handle, &domctl);
+ if (ret < 0) {
+ xc_error_dom_set(domid, "vcpu %u getinfo", vcpu);
+ return ret;
+ }
+ memcpy(info, &domctl.u.getvcpuinfo, sizeof(*info));
+ return ret;
+}
+
+int xc_get_runstate_info(int handle, unsigned int domid,
+ xc_runstate_info_t *info)
+{
+ int ret = -EBADF;
+#ifdef XEN_DOMCTL_get_runstate_info
+ DECLARE_DOMCTL(XEN_DOMCTL_get_runstate_info, domid);
+ ret = do_domctl(handle, &domctl);
+ if (ret < 0) {
+ xc_error_dom_set(domid, "get runstate info");
+ return ret;
+ }
+ memcpy(info, &domctl.u.domain_runstate, sizeof(*info));
+#endif
+ return ret;
+}
+
+int xc_domain_ioport_permission(int handle, unsigned int domid,
+ unsigned int first_port, unsigned int nr_ports,
+ unsigned int allow_access)
+{
+ DECLARE_DOMCTL(XEN_DOMCTL_ioport_permission, domid);
+ domctl.u.ioport_permission.first_port = first_port;
+ domctl.u.ioport_permission.nr_ports = nr_ports;
+ domctl.u.ioport_permission.allow_access = allow_access;
+
+ return do_domctl(handle, &domctl);
+}
+
+int xc_vcpu_getcontext(int handle, unsigned int domid,
+ unsigned int vcpu, vcpu_guest_context_any_t *ctxt)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_getvcpucontext, domid);
+ domctl.u.vcpucontext.vcpu = vcpu;
+ set_xen_guest_handle(domctl.u.vcpucontext.ctxt, ctxt);
+
+ if (mlock(ctxt, sizeof(*ctxt)) != 0) {
+ xc_error_set("mlock failed: %s", strerror(errno));
+ return -1;
+ }
+
+ ret = do_domctl(handle, &domctl);
+ if (ret)
+ xc_error_dom_set(domid, "vcpu %u getcontext", vcpu);
+ munlock(ctxt, sizeof(*ctxt));
+ return ret;
+}
+
+int xc_vcpu_setcontext(int handle, unsigned int domid,
+ unsigned int vcpu, vcpu_guest_context_any_t *ctxt)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_setvcpucontext, domid);
+ domctl.u.vcpucontext.vcpu = vcpu;
+ set_xen_guest_handle(domctl.u.vcpucontext.ctxt, ctxt);
+
+ if (mlock(ctxt, sizeof(*ctxt)) != 0) {
+ xc_error_set("mlock failed: %s", strerror(errno));
+ return -1;
+ }
+
+ ret = do_domctl(handle, &domctl);
+ if (ret)
+ xc_error_dom_set(domid, "vcpu %u setcontext", vcpu);
+
+ munlock(ctxt, sizeof(*ctxt));
+ return ret;
+}
+
+int xc_domain_irq_permission(int handle, unsigned int domid,
+ unsigned char pirq, unsigned char allow_access)
+{
+ DECLARE_DOMCTL(XEN_DOMCTL_irq_permission, domid);
+ domctl.u.irq_permission.pirq = pirq;
+ domctl.u.irq_permission.allow_access = allow_access;
+ int ret;
+
+ ret = do_domctl(handle, &domctl);
+ if (ret)
+ xc_error_dom_set(domid, "irq permission %u to %u",
+ pirq, allow_access);
+ return ret;
+}
+
+int xc_domain_iomem_permission(int handle, unsigned int domid,
+ unsigned long first_mfn, unsigned long nr_mfns,
+ unsigned char allow_access)
+{
+ DECLARE_DOMCTL(XEN_DOMCTL_iomem_permission, domid);
+ domctl.u.iomem_permission.first_mfn = first_mfn;
+ domctl.u.iomem_permission.nr_mfns = nr_mfns;
+ domctl.u.iomem_permission.allow_access = allow_access;
+ int ret;
+
+ ret = do_domctl(handle, &domctl);
+ if (ret)
+ xc_error_dom_set(domid, "iomem permission [%lu, %lu] to %u",
+ first_mfn, first_mfn + nr_mfns, allow_access);
+ return ret;
+}
+
+long long xc_domain_get_cpu_usage(int handle, unsigned int domid,
+ unsigned int vcpu)
+{
+ DECLARE_DOMCTL(XEN_DOMCTL_getvcpuinfo, domid);
+ domctl.u.getvcpuinfo.vcpu = vcpu;
+
+ if (do_domctl(handle, &domctl) < 0) {
+ xc_error_dom_set(domid, "get cpu %d usage", vcpu);
+ return -1;
+ }
+ return domctl.u.getvcpuinfo.cpu_time;
+}
+
+void *xc_map_foreign_range(int handle, unsigned int domid,
+ int size, int prot, unsigned long mfn)
+{
+ privcmd_mmap_entry_t entry = {
+ .mfn = mfn,
+ .npages = (size + PAGE_SIZE - 1) >> PAGE_SHIFT,
+ };
+ privcmd_mmap_t ioctlx = {
+ .num = 1,
+ .dom = domid,
+ .entry = &entry,
+ };
+ void *addr;
+
+ addr = do_mmap(NULL, size, prot, MAP_SHARED, handle, 0);
+ if (addr == MAP_FAILED) {
+ xc_error_set("mmap failed: %s", strerror(errno));
+ xc_error_dom_set(domid, "map foreign range [%lx,%lx] prot %u",
+ mfn, mfn + size, prot);
+ return NULL;
+ }
+ entry.va = (unsigned long) addr;
+ if (do_ioctl(handle, IOCTL_PRIVCMD_MMAP, &ioctlx) < 0) {
+ xc_error_set("ioctl failed: %s", strerror(errno));
+ xc_error_dom_set(domid, "map foreign range [%lx,%lx] prot %u",
+ mfn, mfn + size, prot);
+ munmap(addr, size);
+ return NULL;
+ }
+ return addr;
+}
+
+int xc_map_foreign_ranges(int handle, unsigned int domid,
+ privcmd_mmap_entry_t *entries, int nr)
+{
+ privcmd_mmap_t ioctlx = {
+ .num = nr,
+ .dom = domid,
+ .entry = entries,
+ };
+ int ret;
+
+ ret = do_ioctl(handle, IOCTL_PRIVCMD_MMAP, &ioctlx);
+ if (ret < 0) {
+ xc_error_set("ioctl failed: %s", strerror(errno));
+ xc_error_dom_set(domid, "map foreign ranges");
+ return -1;
+ }
+ return ret;
+}
+
+int xc_readconsolering(int handle, char **pbuffer,
+ unsigned int *pnr_chars, int clear)
+{
+ int ret;
+ DECLARE_SYSCTL(XEN_SYSCTL_readconsole);
+ char *buffer = *pbuffer;
+ unsigned int nr_chars = *pnr_chars;
+
+ set_xen_guest_handle(sysctl.u.readconsole.buffer, buffer);
+ sysctl.u.readconsole.count = nr_chars;
+ sysctl.u.readconsole.clear = clear;
+
+ if (mlock(buffer, nr_chars) != 0) {
+ xc_error_set("read console ring: mlock failed: %s",
+ strerror(errno));
+ return -1;
+ }
+
+ ret = do_sysctl(handle, &sysctl);
+ if (ret != 0)
+ xc_error_set("read console ring failed: %s", xc_error_get());
+ else
+ *pnr_chars = sysctl.u.readconsole.count;
+
+ munlock(buffer, nr_chars);
+ return ret;
+}
+
+int xc_send_debug_keys(int handle, char *keys)
+{
+ int ret;
+ DECLARE_SYSCTL(XEN_SYSCTL_debug_keys);
+
+ set_xen_guest_handle(sysctl.u.debug_keys.keys, keys);
+ sysctl.u.debug_keys.nr_keys = strlen(keys);
+
+ if (mlock(keys, sysctl.u.debug_keys.nr_keys) != 0) {
+ xc_error_set("send debug keys: mlock failed: %s",
+ strerror(errno));
+ return -1;
+ }
+
+ ret = do_sysctl(handle, &sysctl);
+ if (ret != 0)
+ xc_error_set("send debug keys: %s", xc_error_get());
+
+ munlock(keys, sysctl.u.debug_keys.nr_keys);
+ return ret;
+}
+
+int xc_physinfo(int handle, xc_physinfo_t *put_info)
+{
+ DECLARE_SYSCTL(XEN_SYSCTL_physinfo);
+ int ret;
+
+ ret = do_sysctl(handle, &sysctl);
+ if (ret) {
+ xc_error_set("physinfo failed: %s", xc_error_get());
+ return ret;
+ }
+ memcpy(put_info, &sysctl.u.physinfo, sizeof(*put_info));
+ return 0;
+}
+
+int xc_pcpu_info(int handle, int max_cpus, uint64_t *info, int *nr_cpus)
+{
+ DECLARE_SYSCTL(XEN_SYSCTL_getcpuinfo);
+ int ret;
+
+ sysctl.u.getcpuinfo.max_cpus = max_cpus;
+ set_xen_guest_handle(sysctl.u.getcpuinfo.info, info);
+
+ if (mlock(info, sizeof(*info) * max_cpus) != 0) {
+ xc_error_set("mlock failed: %s", strerror(errno));
+ return -1;
+ }
+
+ ret = do_sysctl(handle, &sysctl);
+ if (ret)
+ xc_error_set("pcpu info failed: %s", xc_error_get());
+ else if (ret == 0 && nr_cpus)
+ *nr_cpus = sysctl.u.getcpuinfo.nr_cpus;
+ munlock(info, sizeof(*info) * max_cpus);
+ return ret;
+}
+
+int xc_sched_id(int handle, int *sched_id)
+{
+ DECLARE_SYSCTL(XEN_SYSCTL_sched_id);
+ int ret;
+
+ ret = do_sysctl(handle, &sysctl);
+ if (ret) {
+ xc_error_set("sched id failed: %s", xc_error_get());
+ return ret;
+ }
+ *sched_id = sysctl.u.sched_id.sched_id;
+ return 0;
+}
+
+int xc_version(int handle, int cmd, void *arg)
+{
+ int argsize;
+ int ret;
+ DECLARE_HYPERCALL2(__HYPERVISOR_xen_version, cmd, arg);
+
+ switch (cmd) {
+ case XENVER_extraversion:
+ argsize = sizeof(xen_extraversion_t); break;
+ case XENVER_compile_info:
+ argsize = sizeof(xen_compile_info_t); break;
+ case XENVER_capabilities:
+ argsize = sizeof(xen_capabilities_info_t); break;
+ case XENVER_changeset:
+ argsize = sizeof(xen_changeset_info_t); break;
+ case XENVER_platform_parameters:
+ argsize = sizeof(xen_platform_parameters_t); break;
+ case XENVER_version:
+ argsize = 0; break;
+ default:
+ xc_error_set("version: unknown command");
+ return -1;
+ }
+ if (argsize && mlock(arg, argsize) == -1) {
+ xc_error_set("version: mlock failed: %s", strerror(errno));
+ return -ENOMEM;
+ }
+
+ ret = do_xen_hypercall(handle, &hypercall);
+ if (ret)
+ xc_error_hypercall(hypercall, ret);
+
+ if (argsize)
+ munlock(arg, argsize);
+ return ret;
+}
+
+int xc_evtchn_alloc_unbound(int handle, unsigned int domid,
+ unsigned int remote_domid)
+{
+ struct evtchn_alloc_unbound arg = {
+ .dom = domid,
+ .remote_dom = remote_domid,
+ };
+ int ret;
+
+ ret = do_evtchnctl(handle, EVTCHNOP_alloc_unbound, &arg, sizeof(arg));
+ if (ret) {
+ xc_error_dom_set(domid, "alloc unbound evtchn to %d",
+ remote_domid);
+ return ret;
+ }
+ return arg.port;
+}
+
+int xc_evtchn_reset(int handle, unsigned int domid)
+{
+ struct evtchn_reset arg = {
+ .dom = domid,
+ };
+ int ret;
+
+ ret = do_evtchnctl(handle, EVTCHNOP_reset, &arg, sizeof(arg));
+ if (ret)
+ xc_error_dom_set(domid, "reset evtchn of %d", domid);
+ return ret;
+}
+
+int xc_sched_credit_domain_set(int handle, unsigned int domid,
+ struct xen_domctl_sched_credit *sdom)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_scheduler_op, domid);
+ domctl.u.scheduler_op.sched_id = XEN_SCHEDULER_CREDIT;
+ domctl.u.scheduler_op.cmd = XEN_DOMCTL_SCHEDOP_putinfo;
+ domctl.u.scheduler_op.u.credit = *sdom;
+
+ ret = do_domctl(handle, &domctl);
+ if (ret < 0)
+ xc_error_dom_set(domid, "credit scheduler domain set");
+ return ret;
+}
+
+int xc_sched_credit_domain_get(int handle, unsigned int domid,
+ struct xen_domctl_sched_credit *sdom)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_scheduler_op, domid);
+
+ domctl.u.scheduler_op.sched_id = XEN_SCHEDULER_CREDIT;
+ domctl.u.scheduler_op.cmd = XEN_DOMCTL_SCHEDOP_getinfo;
+
+ ret = do_domctl(handle, &domctl);
+ if (ret < 0)
+ xc_error_dom_set(domid, "credit scheduler domain get");
+ else
+ *sdom = domctl.u.scheduler_op.u.credit;
+ return ret;
+}
+
+int xc_shadow_allocation_get(int handle, unsigned int domid, uint32_t *mb)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_shadow_op, domid);
+
+ domctl.u.shadow_op.op = XEN_DOMCTL_SHADOW_OP_GET_ALLOCATION;
+
+ ret = do_domctl(handle, &domctl);
+ if (ret < 0)
+ xc_error_dom_set(domid, "shadow allocation get");
+ else
+ *mb = domctl.u.shadow_op.mb;
+ return ret;
+}
+
+int xc_shadow_allocation_set(int handle, unsigned int domid, uint32_t mb)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_shadow_op, domid);
+
+ domctl.u.shadow_op.op = XEN_DOMCTL_SHADOW_OP_SET_ALLOCATION;
+ domctl.u.shadow_op.mb = mb;
+
+ ret = do_domctl(handle, &domctl);
+ if (ret < 0)
+ xc_error_dom_set(domid, "shadow allocation set");
+ return ret;
+}
+
+int xc_domain_get_pfn_list(int handle, unsigned int domid,
+ xen_pfn_t *pfn_array, unsigned long max_pfns)
+{
+ int ret;
+ DECLARE_DOMCTL(XEN_DOMCTL_getmemlist, domid);
+
+ domctl.u.getmemlist.max_pfns = max_pfns;
+ set_xen_guest_handle(domctl.u.getmemlist.buffer, pfn_array);
+
+ if (mlock(pfn_array, max_pfns * sizeof(xen_pfn_t)) != 0) {
+ xc_error_set("mlock failed: %s", strerror(errno));
+ return -1;
+ }
+
+ ret = do_domctl(handle, &domctl);
+ if (ret < 0)
+ xc_error_dom_set(domid, "get pfn list");
+
+ munlock(pfn_array, max_pfns * sizeof(xen_pfn_t));
+ return (ret < 0) ? ret : domctl.u.getmemlist.num_pfns;
+}
+
+#define MARSHALL_BDF(d,b,s,f) \
+ (((b) & 0xff) << 16 | ((s) & 0x1f) << 11 | ((f) & 0x7) << 8)
+
+int xc_domain_assign_device(int handle, unsigned int domid,
+ int domain, int bus, int slot, int func)
+{
+ int ret = -EBADF;
+#ifdef XEN_DOMCTL_assign_device
+ DECLARE_DOMCTL(XEN_DOMCTL_assign_device, domid);
+
+ domctl.u.assign_device.machine_bdf = MARSHALL_BDF(domain, bus, slot, func);
+ ret = do_domctl(handle, &domctl);
+ if (ret < 0)
+ xc_error_dom_set(domid, "assign device");
+#endif
+ return ret;
+}
+
+int xc_domain_deassign_device(int handle, unsigned int domid,
+ int domain, int bus, int slot, int func)
+{
+ int ret = -EBADF;
+#ifdef XEN_DOMCTL_deassign_device
+ DECLARE_DOMCTL(XEN_DOMCTL_deassign_device, domid);
+
+ domctl.u.assign_device.machine_bdf = MARSHALL_BDF(domain, bus, slot, func);
+ ret = do_domctl(handle, &domctl);
+ if (ret < 0)
+ xc_error_dom_set(domid, "deassign device");
+#endif
+ return ret;
+}
+
+int xc_domain_test_assign_device(int handle, unsigned int domid,
+ int domain, int bus, int slot, int func)
+{
+ int ret = -EBADF;
+#ifdef XEN_DOMCTL_test_assign_device
+ DECLARE_DOMCTL(XEN_DOMCTL_test_assign_device, domid);
+ domctl.u.assign_device.machine_bdf = MARSHALL_BDF(domain, bus, slot, func);
+
+ ret = do_domctl(handle, &domctl);
+ if (ret < 0)
+ xc_error_dom_set(domid, "test assign device");
+#endif
+ return ret;
+}
+
+int xc_domain_watchdog(int handle, int id, uint32_t timeout)
+{
+ int ret = -EBADF;
+#ifdef SCHEDOP_watchdog
+ sched_watchdog_t arg = {
+ .id = (uint32_t) id,
+ .timeout = timeout,
+ };
+ DECLARE_HYPERCALL2(__HYPERVISOR_sched_op, SCHEDOP_watchdog, &arg);
+
+ if (mlock(&arg, sizeof(arg)) != 0) {
+ xc_error_set("mlock failed: %s", strerror(errno));
+ return -1;
+ }
+
+ ret = do_xen_hypercall(handle, &hypercall);
+ if (ret < 0) {
+ xc_error_hypercall(hypercall, ret);
+ }
+ munlock(&arg, sizeof(arg));
+#endif
+ return ret;
+}
+
+int xc_domain_set_machine_address_size(int xc, uint32_t domid, unsigned int width)
+{
+ DECLARE_DOMCTL(XEN_DOMCTL_set_machine_address_size, domid);
+ int rc;
+
+ domctl.u.address_size.size = width;
+ rc = do_domctl(xc, &domctl);
+ if (rc != 0)
+ xc_error_dom_set(domid, "set machine address size");
+
+ return rc;
+}
+
+int xc_domain_get_machine_address_size(int xc, uint32_t domid)
+{
+ DECLARE_DOMCTL(XEN_DOMCTL_get_machine_address_size, domid);
+ int rc;
+
+ rc = do_domctl(xc, &domctl);
+ if (rc != 0)
+ xc_error_dom_set(domid, "get machine address size");
+ return rc == 0 ? domctl.u.address_size.size : rc;
+}
+
+int xc_domain_get_address_size(int handle, uint32_t domid)
+{
+ DECLARE_DOMCTL(XEN_DOMCTL_get_address_size, domid);
+ int rc;
+
+ rc = do_domctl(handle, &domctl);
+ if (rc != 0)
+ xc_error_dom_set(domid, "get address size");
+ return rc == 0 ? domctl.u.address_size.size : rc;
+}
+
+#include "xc_cpuid.h"
+int xc_domain_cpuid_set(int xc, unsigned int domid, int hvm,
+ uint32_t input, uint32_t oinput,
+ char *config[4], char *config_out[4])
+{
+ int ret = -EBADF;
+#ifdef XEN_DOMCTL_set_cpuid
+ DECLARE_DOMCTL(XEN_DOMCTL_set_cpuid, domid);
+ uint32_t regs[4], polregs[4];
+ int i, j;
+
+ xc_cpuid(input, oinput, regs);
+ memcpy(polregs, regs, sizeof(regs));
+ do_cpuid_policy(xc, domid, hvm, input, polregs);
+
+ for (i = 0; i < 4; i++) {
+ if (!config[i]) {
+ regs[i] = polregs[i];
+ continue;
+ }
+
+ for (j = 0; j < 32; j++) {
+ unsigned char val, polval;
+
+ val = !!((regs[i] & (1U << (31 - j))));
+ polval = !!((regs[i] & (1U << (31 - j))));
+
+ switch (config[i][j]) {
+ case '1': val = 1; break; /* force to true */
+ case '0': val = 0; break; /* force to false */
+ case 'x': val = polval; break;
+ case 'k': case 's': break;
+ default:
+ xc_error_dom_set(domid, "domain cpuid set: invalid config");
+ ret = -EINVAL;
+ goto out;
+ }
+
+ if (val)
+ set_bit(31 - j, regs[i]);
+ else
+ clear_bit(31 - j, regs[i]);
+
+ if (config_out && config_out[i]) {
+ config_out[i][j] = (config[i][j] == 's')
+ ? '0' + val
+ : config[i][j];
+ }
+ }
+ }
+
+ domctl.u.cpuid.input[0] = input;
+ domctl.u.cpuid.input[1] = oinput;
+ domctl.u.cpuid.eax = regs[0];
+ domctl.u.cpuid.ebx = regs[1];
+ domctl.u.cpuid.ecx = regs[2];
+ domctl.u.cpuid.edx = regs[3];
+ ret = do_domctl(xc, &domctl);
+ if (ret) {
+ xc_error_dom_set(domid, "cpuid set");
+ goto out;
+ }
+out:
+#endif
+ return ret;
+}
+
+int xc_domain_cpuid_apply(int xc, unsigned int domid, int hvm)
+{
+ int ret = -EBADF;
+#ifdef XEN_DOMCTL_set_cpuid
+ uint32_t regs[4], base_max, ext_max, eax, ecx;
+
+ /* determinate cpuid range */
+ xc_cpuid(0, 0, regs);
+ base_max = MIN(regs[0], DEF_MAX_BASE);
+ xc_cpuid(0x80000000, 0, regs);
+ ext_max = MIN(regs[0], DEF_MAX_EXT);
+
+ eax = ecx = 0;
+ while (!(eax & 0x80000000) || (eax <= ext_max)) {
+ xc_cpuid(eax, ecx, regs);
+
+ do_cpuid_policy(xc, domid, hvm, eax, regs);
+
+ if (regs[0] || regs[1] || regs[2] || regs[3]) {
+ DECLARE_DOMCTL(XEN_DOMCTL_set_cpuid, domid);
+
+ domctl.u.cpuid.input[0] = eax;
+ domctl.u.cpuid.input[1] = (eax == 4) ? ecx : XEN_CPUID_INPUT_UNUSED;
+ domctl.u.cpuid.eax = regs[0];
+ domctl.u.cpuid.ebx = regs[1];
+ domctl.u.cpuid.ecx = regs[2];
+ domctl.u.cpuid.edx = regs[3];
+
+ ret = do_domctl(xc, &domctl);
+ if (ret) {
+ xc_error_dom_set(domid, "cpuid apply");
+ goto out;
+ }
+
+ /* we repeat when doing node 4 (cache descriptor leaves) increasing ecx
+ * until the cpuid eax value masked is 0 */
+ if (eax == 4) {
+ ecx++;
+ if ((regs[0] & 0x1f) != 0)
+ continue;
+ ecx = 0;
+ }
+ }
+
+ eax++;
+ if (!(eax & 0x80000000) && (eax > base_max))
+ eax = 0x80000000;
+ }
+ ret = 0;
+out:
+#endif
+ return ret;
+}
+
+/*
+ * return 1 on checking success
+ * 0 on checking failure
+ * -EINVAL if the config contains unknown character
+ */
+int xc_cpuid_check(uint32_t input, uint32_t optsubinput,
+ char *config[4], char *config_out[4])
+{
+ int ret = -EBADF;
+#ifdef XEN_DOMCTL_set_cpuid
+ uint32_t regs[4];
+ int i, j;
+
+ xc_cpuid(input, optsubinput, regs);
+
+ ret = 1;
+ for (i = 0; i < 4; i++) {
+ if (!config[i])
+ continue;
+ for (j = 0; j < 32; j++) {
+ unsigned char val;
+
+ val = !!((regs[i] & (1U << (31 - j))));
+
+ switch (config[i][j]) {
+ case '1': if (!val) { ret = 0; goto out; }; break;
+ case '0': if (val) { ret = 0; goto out; }; break;
+ case 'x': case 's': break;
+ default:
+ xc_error_set("cpuid check: invalid config");
+ ret = -EINVAL;
+ goto out;
+ }
+
+ if (config_out && config_out[i]) {
+ config_out[i][j] = (config[i][j] == 's')
+ ? '0' + val
+ : config[i][j];
+ }
+ }
+ }
+out:
+#endif
+ return ret;
+}
+
+int xc_domain_send_s3resume(int handle, unsigned int domid)
+{
+ #define HVM_PARAM_ACPI_S_STATE 14
+ return xc_set_hvm_param(handle, domid, HVM_PARAM_ACPI_S_STATE, 0);
+}
+
+int xc_domain_get_acpi_s_state(int handle, unsigned int domid)
+{
+ int ret;
+ unsigned long value;
+
+ ret = xc_get_hvm_param(handle, domid, HVM_PARAM_ACPI_S_STATE, &value);
+ if (ret != 0)
+ xc_error_dom_set(domid, "get acpi s-state");
+ return value;
+}
+
+int xc_domain_suppress_spurious_page_faults(int xc, uint32_t domid)
+{
+ int rc = 0;
+#ifdef XEN_DOMCTL_suppress_spurious_page_faults
+ DECLARE_DOMCTL(XEN_DOMCTL_suppress_spurious_page_faults, domid);
+
+ rc = do_domctl(xc, &domctl);
+ if (rc != 0)
+ xc_error_dom_set(domid, "suppress spurious page faults");
+#endif
+ return rc;
+}
+
+/*
+ * Local variables:
+ * indent-tabs-mode: t
+ * c-basic-offset: 8
+ * tab-width: 8
+ * End:
+ */
--- /dev/null
+/*
+ * Copyright (c) 2007 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ */
+
+#ifdef WITH_INJECTION_CAPABILITY
+#include "../fake/using.h"
+#include "../fake/marshall.h"
+
+#include <sys/types.h>
+#include <sys/socket.h>
+#include <sys/un.h>
+
+static int fake_interface_open(void)
+{
+ struct sockaddr_un remote;
+ char *s;
+ int fd, len;
+
+ s = getenv("XIU");
+ if (!s)
+ return -1;
+ snprintf(remote.sun_path, 256, "%s-xc", s);
+ remote.sun_family = AF_UNIX;
+ len = strlen(remote.sun_path) + sizeof(remote.sun_family);
+
+ fd = socket(AF_UNIX, SOCK_STREAM, 0);
+ if (fd == -1)
+ return -1;
+ if (connect(fd, (struct sockaddr *)&remote, len) != 0)
+ return -1;
+
+ return fd;
+}
+
+static int fake_interface_close(int handle)
+{
+ return close(handle);
+}
+
+static int fake_interface_ioctl(int handle, int cmd, void *arg)
+{
+ return 0;
+}
+
+static void * fake_interface_mmap(void *start, size_t length, int prot, int flags,
+ int fd, off_t offset)
+{
+ return mmap(start, length, prot, MAP_PRIVATE|MAP_ANONYMOUS, -1, offset);
+}
+
+#define DOMAINHANDLE "%02x-%02x-%02x-%02x-%02x-%02x-%02x-%02x-%02x-%02x-%02x-%02x-%02x-%02x-%02x-%02x"
+
+static int fake_xen_domctl(int handle, struct xen_domctl *domctl)
+{
+ #define DOMCTLcmd "domctl"
+ switch (domctl->cmd) {
+ case XEN_DOMCTL_pausedomain:
+ case XEN_DOMCTL_unpausedomain:
+ case XEN_DOMCTL_resumedomain:
+ case XEN_DOMCTL_destroydomain:
+ marshall_command(handle, "%s,%d,%d\n", DOMCTLcmd, domctl->cmd, domctl->domain);
+ return unmarshall_return(handle);
+ case XEN_DOMCTL_createdomain: /* W ssidref */
+ marshall_command(handle, "%s,%d,%d," DOMAINHANDLE "\n", DOMCTLcmd,
+ domctl->cmd,
+ domctl->u.createdomain.flags,
+ domctl->u.createdomain.handle[0],
+ domctl->u.createdomain.handle[1],
+ domctl->u.createdomain.handle[2],
+ domctl->u.createdomain.handle[3],
+ domctl->u.createdomain.handle[4],
+ domctl->u.createdomain.handle[5],
+ domctl->u.createdomain.handle[6],
+ domctl->u.createdomain.handle[7],
+ domctl->u.createdomain.handle[8],
+ domctl->u.createdomain.handle[9],
+ domctl->u.createdomain.handle[10],
+ domctl->u.createdomain.handle[11],
+ domctl->u.createdomain.handle[12],
+ domctl->u.createdomain.handle[13],
+ domctl->u.createdomain.handle[14],
+ domctl->u.createdomain.handle[15]);
+ domctl->domain = unmarshall_int(handle);
+ return unmarshall_return(handle);
+ case XEN_DOMCTL_max_mem: /* W domid, maxmem */
+ marshall_command(handle, "%s,%d,%d,%d\n", DOMCTLcmd,
+ domctl->cmd,
+ domctl->domain, domctl->u.max_mem.max_memkb);
+ return unmarshall_return(handle);
+ case XEN_DOMCTL_settimeoffset: /* W domid, time */
+ marshall_command(handle, "%s,%d,%d,%d\n", DOMCTLcmd,
+ domctl->cmd,
+ domctl->domain,
+ domctl->u.settimeoffset.time_offset_seconds);
+ return unmarshall_return(handle);
+#ifdef XEN_DOMCTL_setvmxassist
+ case XEN_DOMCTL_setvmxassist: /* W domid, use_vmxassist */
+ marshall_command(handle, "%s,%d,%d,%d\n", DOMCTLcmd,
+ domctl->cmd,
+ domctl->domain,
+ domctl->u.setvmxassist.use_vmxassist);
+ return unmarshall_return(handle);
+#endif
+ case XEN_DOMCTL_max_vcpus: /* W domid, max */
+ marshall_command(handle, "%s,%d,%d,%d\n", DOMCTLcmd,
+ domctl->cmd,
+ domctl->domain,
+ domctl->u.max_vcpus.max);
+ return unmarshall_return(handle);
+ case XEN_DOMCTL_setdomainhandle: { /* domid, handle */
+ marshall_command(handle, "%s,%d,%d," DOMAINHANDLE "\n", DOMCTLcmd,
+ domctl->cmd,
+ domctl->domain,
+ domctl->u.setdomainhandle.handle[0],
+ domctl->u.setdomainhandle.handle[1],
+ domctl->u.setdomainhandle.handle[2],
+ domctl->u.setdomainhandle.handle[3],
+ domctl->u.setdomainhandle.handle[4],
+ domctl->u.setdomainhandle.handle[5],
+ domctl->u.setdomainhandle.handle[6],
+ domctl->u.setdomainhandle.handle[7],
+ domctl->u.setdomainhandle.handle[8],
+ domctl->u.setdomainhandle.handle[9],
+ domctl->u.setdomainhandle.handle[10],
+ domctl->u.setdomainhandle.handle[11],
+ domctl->u.setdomainhandle.handle[12],
+ domctl->u.setdomainhandle.handle[13],
+ domctl->u.setdomainhandle.handle[14],
+ domctl->u.setdomainhandle.handle[15]);
+ return unmarshall_return(handle);
+ }
+ /* just returning success : might need init */
+ case XEN_DOMCTL_getvcpucontext:
+ case XEN_DOMCTL_getvcpuaffinity:
+ return 0;
+ /* just returning success */
+ case XEN_DOMCTL_scheduler_op:
+ return 0;
+ case XEN_DOMCTL_shadow_op:
+ /* Only handle set/get allocation at the moment */
+ marshall_command(handle, "%s,%d,%d,%d,%d,%d\n", DOMCTLcmd,
+ domctl->cmd,
+ domctl->domain,
+ domctl->u.shadow_op.op,
+ domctl->u.shadow_op.mode,
+ domctl->u.shadow_op.mb);
+ if(domctl->u.shadow_op.op == XEN_DOMCTL_SHADOW_OP_GET_ALLOCATION)
+ domctl->u.shadow_op.mb = unmarshall_int(handle);
+
+ return unmarshall_return(handle);
+
+ /* just return success */
+ case XEN_DOMCTL_ioport_permission:
+ case XEN_DOMCTL_irq_permission:
+ case XEN_DOMCTL_iomem_permission:
+ case XEN_DOMCTL_setvcpuaffinity:
+ case XEN_DOMCTL_setvcpucontext:
+ case XEN_DOMCTL_getmemlist:
+ case XEN_DOMCTL_getvcpuinfo:
+#ifdef XEN_DOMCTL_get_runstate_info
+ case XEN_DOMCTL_get_runstate_info:
+#endif
+ case XEN_DOMCTL_set_machine_address_size:
+#ifdef XEN_DOMCTL_suppress_spurious_page_faults
+ case XEN_DOMCTL_suppress_spurious_page_faults:
+#endif
+ return 0;
+ default:
+ return -EINVAL;
+ }
+}
+
+static int fake_xen_sysctl(int handle, struct xen_sysctl *sysctl)
+{
+ #define SYSCTLcmd "sysctl"
+ switch (sysctl->cmd) {
+ case XEN_SYSCTL_getdomaininfolist: {
+ xc_domaininfo_t *info; int num, i;
+
+ get_xen_guest_handle(info, sysctl->u.getdomaininfolist.buffer);
+
+ marshall_command(handle, "%s,%d,%d,%d\n", SYSCTLcmd, sysctl->cmd,
+ sysctl->u.getdomaininfolist.first_domain,
+ sysctl->u.getdomaininfolist.max_domains);
+ num = unmarshall_int(handle);
+ for (i = 0; i < num; i++) {
+ int uuid[16], j, flags;
+ char **ret;
+
+ ret = unmarshall_multiple(handle);
+ if (!ret)
+ return -EBADF;
+
+ /* domid,uuid,flags */
+ info->domain = atoi(ret[0]);
+
+ parse_uuid(ret[1], uuid);
+ for (j = 0; j < 16; j++)
+ info->handle[j] = uuid[j] & 0xff;
+
+ flags = atoi(ret[2]);
+ info->flags = 0;
+ if (flags & 0x1) info->flags |= XEN_DOMINF_dying;
+ if (flags & 0x2) info->flags |= XEN_DOMINF_shutdown;
+ if (flags & 0x4) info->flags |= XEN_DOMINF_paused;
+ if (flags & 0x8) info->flags |= XEN_DOMINF_blocked;
+ if (flags & 0x10) info->flags |= XEN_DOMINF_running;
+ if (flags & 0x20) info->flags |= XEN_DOMINF_hvm_guest;
+ info->flags |= ((flags >> 8) & 0xff) << XEN_DOMINF_shutdownshift;
+
+ info->nr_online_vcpus = atoi(ret[3]);
+ info->max_vcpu_id = atoi(ret[4]);
+
+ info->tot_pages = atoi(ret[5]);
+ info->max_pages = atoi(ret[6]);
+ info->shared_info_frame = atoi(ret[7]);
+ info->cpu_time = atoi(ret[8]);
+ info->ssidref = atoi(ret[9]);
+
+ string_split_free(ret);
+ info++;
+
+ }
+ sysctl->u.getdomaininfolist.num_domains = num;
+ return unmarshall_return(handle);
+ }
+ case XEN_SYSCTL_readconsole:
+ case XEN_SYSCTL_debug_keys:
+ return 0;
+ case XEN_SYSCTL_physinfo: {
+ char **ret;
+ int sockets_per_node;
+
+ marshall_command(handle, "%s,%d\n", SYSCTLcmd, sysctl->cmd);
+ ret = unmarshall_multiple(handle);
+ if (!ret) return -EBADF;
+
+ sockets_per_node = atoi(ret[2]);
+
+ sysctl->u.physinfo.threads_per_core = atoi(ret[0]);
+ sysctl->u.physinfo.cores_per_socket = atoi(ret[1]);
+#if XEN_SYSCTL_INTERFACE_VERSION < 6
+ sysctl->u.physinfo.sockets_per_node = sockets_per_node;
+#endif
+ sysctl->u.physinfo.nr_nodes = atoi(ret[3]);
+#if XEN_SYSCTL_INTERFACE_VERSION >= 6
+ sysctl->u.physinfo.nr_cpus =
+ sysctl->u.physinfo.threads_per_core *
+ sysctl->u.physinfo.cores_per_socket *
+ sockets_per_node *
+ sysctl->u.physinfo.nr_nodes;
+#endif
+ sysctl->u.physinfo.cpu_khz = atoi(ret[4]);
+ sysctl->u.physinfo.total_pages = atoi(ret[5]);
+ sysctl->u.physinfo.free_pages = atoi(ret[6]);
+ sysctl->u.physinfo.scrub_pages = 0;
+
+ string_split_free(ret);
+ return unmarshall_return(handle);
+ }
+ case XEN_SYSCTL_getcpuinfo: {
+ uint64_t *info;
+ int num, i;
+
+ get_xen_guest_handle(info, sysctl->u.getcpuinfo.info);
+ marshall_command(handle, "%s,%d,%d\n", SYSCTLcmd, sysctl->cmd, sysctl->u.getcpuinfo.max_cpus);
+ num = unmarshall_int(handle);
+ for (i = 0; i < num; i++) {
+ info[i] = unmarshall_int64(handle);
+ }
+ return unmarshall_return(handle);
+ }
+ case XEN_SYSCTL_sched_id:
+ return 0;
+ default:
+ return -EINVAL;
+ }
+ return 0;
+}
+
+static int fake_xen_eventchn(int handle, unsigned long cmd, unsigned long arg)
+{
+ switch (cmd) {
+ case EVTCHNOP_alloc_unbound:
+ case EVTCHNOP_reset:
+ return 0;
+ default:
+ return -EINVAL;
+ }
+ return 0;
+}
+
+static int fake_xen_memoryop(int handle, unsigned long cmd, struct xen_memory_reservation *reservation)
+{
+ switch (cmd) {
+ case XENMEM_set_memory_map:
+ case XENMEM_increase_reservation:
+ case XENMEM_decrease_reservation:
+ case XENMEM_populate_physmap:
+ return 0;
+ default:
+ return -EINVAL;
+ }
+ return 0;
+}
+
+static int fake_xen_hvmop(int handle, unsigned long cmd, unsigned long arg)
+{
+ switch (cmd) {
+ case HVMOP_get_param:
+ return 0;
+ default:
+ return -EINVAL;
+ }
+ return 0;
+}
+
+static int fake_xen_schedop(int handle, unsigned long cmd, sched_remote_shutdown_t *arg)
+{
+ switch (cmd) {
+ case SCHEDOP_remote_shutdown:
+ return 0;
+ default:
+ return -EINVAL;
+ }
+ return 0;
+}
+
+static int fake_xen_versionop(int handle, unsigned long cmd, void * arg)
+{
+ switch (cmd) {
+ case XENVER_extraversion:
+ memset(arg, '\0', sizeof(xen_extraversion_t));
+ memcpy(arg, ".0", 2);
+ return 0;
+ case XENVER_compile_info:
+ memset(arg, '\0', sizeof(xen_compile_info_t));
+ return 0;
+ case XENVER_capabilities:
+ memset(arg, '\0', sizeof(xen_capabilities_info_t));
+ #define CAPA "xen-3.0-x86_64 xen-3.0-x86_32p hvm-3.0-x86_32 hvm-3.0-x86_32p hvm-3.0-x86_64"
+ memcpy(arg, CAPA, strlen(CAPA));
+ #undef CAPA
+ return 0;
+ case XENVER_changeset:
+ memset(arg, '\0', sizeof(xen_changeset_info_t));
+ return 0;
+ case XENVER_platform_parameters:
+ memset(arg, '\0', sizeof(xen_platform_parameters_t));
+ return 0;
+ case XENVER_version:
+ return (((3 << 16) & 0xffff0000) + (1 & 0xffff)); /* 3.1 */
+ default:
+ return -EINVAL;
+ }
+ return 0;
+}
+
+static int fake_xen_hypercall(int handle, privcmd_hypercall_t *hypercall)
+{
+ if (!hypercall) return -EINVAL;
+ switch (hypercall->op) {
+ case __HYPERVISOR_domctl:
+ return fake_xen_domctl(handle, (struct xen_domctl *) hypercall->arg[0]);
+ case __HYPERVISOR_sysctl:
+ return fake_xen_sysctl(handle, (struct xen_sysctl *) hypercall->arg[0]);
+ case __HYPERVISOR_event_channel_op:
+ return fake_xen_eventchn(handle, hypercall->arg[0], hypercall->arg[1]);
+ case __HYPERVISOR_memory_op:
+ return fake_xen_memoryop(handle, hypercall->arg[0], (struct xen_memory_reservation *) hypercall->arg[2]);
+ case __HYPERVISOR_hvm_op:
+ return fake_xen_hvmop(handle, hypercall->arg[0], hypercall->arg[2]);
+ case __HYPERVISOR_sched_op:
+ return fake_xen_schedop(handle, hypercall->arg[0], (sched_remote_shutdown_t *) hypercall->arg[1]);
+ case __HYPERVISOR_xen_version:
+ return fake_xen_versionop(handle, hypercall->arg[0], (void *) hypercall->arg[1]);
+ default:
+ return -EINVAL;
+ }
+}
+
+#define pre_interface_open() if (using_injection()) return fake_interface_open();
+#define pre_interface_close(h) if (using_injection()) return fake_interface_close(h);
+#define pre_xen_hypercall(h, p) if (using_injection()) return fake_xen_hypercall(h, p);
+#define pre_ioctl(h, c, a) if (using_injection()) return fake_interface_ioctl(h, c, a);
+#define pre_mmap(s,l,p,f,d,o) if (using_injection()) return fake_interface_mmap(s,l,p,f,d,o);
+#else
+#define pre_interface_open() do {} while(0);
+#define pre_interface_close(h) do {} while(0);
+#define pre_xen_hypercall(h, p) do {} while(0);
+#define pre_ioctl(h, c, a) do {} while(0);
+#define pre_mmap(s,l,p,f,d,o) do {} while(0);
+#endif
--- /dev/null
+/* Copyright (c) 2005-2006 XenSource Inc. */
+
+#define _XOPEN_SOURCE 600
+#include <stdlib.h>
+
+#define CAML_NAME_SPACE
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/signals.h>
+#include <caml/fail.h>
+#include <caml/callback.h>
+
+#include <sys/mman.h>
+#include <stdint.h>
+#include <string.h>
+
+#include "xc.h"
+
+#include "mmap_stubs.h"
+
+#define PAGE_SHIFT 12
+#define PAGE_SIZE (1UL << PAGE_SHIFT)
+#define PAGE_MASK (~(PAGE_SIZE-1))
+
+#define _H(__h) (Int_val(__h))
+#define _D(__d) ((uint32_t)Int_val(__d))
+
+#define Val_none (Val_int(0))
+
+#define string_of_option_array(array, index) \
+ ((Field(array, index) == Val_none) ? NULL : String_val(Field(Field(array, index), 0)))
+
+/* maybe here we should check the range of the input instead of blindly
+ * casting it to uint32 */
+#define cpuid_input_of_val(i1, i2, input) \
+ i1 = (uint32_t) Int64_val(Field(input, 0)); \
+ i2 = ((Field(input, 1) == Val_none) ? 0xffffffff : (uint32_t) Int64_val(Field(Field(input, 1), 0)));
+
+/**
+ * Convert the given number of pages to an amount in MiB, rounded up.
+ */
+void failwith_xc(void)
+{
+ caml_raise_with_string(*caml_named_value("xc.error"), xc_error_get());
+}
+
+CAMLprim value stub_sizeof_core_header(value unit)
+{
+ CAMLparam1(unit);
+ CAMLreturn(Val_int(sizeof(struct xc_core_header)));
+}
+
+CAMLprim value stub_sizeof_vcpu_guest_context(value unit)
+{
+ CAMLparam1(unit);
+ CAMLreturn(Val_int(sizeof(struct vcpu_guest_context)));
+}
+
+CAMLprim value stub_sizeof_xen_pfn(value unit)
+{
+ CAMLparam1(unit);
+ CAMLreturn(Val_int(sizeof(xen_pfn_t)));
+}
+
+#define XC_CORE_MAGIC 0xF00FEBED
+#define XC_CORE_MAGIC_HVM 0xF00FEBEE
+
+CAMLprim value stub_marshall_core_header(value header)
+{
+ CAMLparam1(header);
+ CAMLlocal1(s);
+ struct xc_core_header c_header;
+
+ c_header.xch_magic = (Field(header, 0))
+ ? XC_CORE_MAGIC
+ : XC_CORE_MAGIC_HVM;
+ c_header.xch_nr_vcpus = Int_val(Field(header, 1));
+ c_header.xch_nr_pages = Nativeint_val(Field(header, 2));
+ c_header.xch_ctxt_offset = Int64_val(Field(header, 3));
+ c_header.xch_index_offset = Int64_val(Field(header, 4));
+ c_header.xch_pages_offset = Int64_val(Field(header, 5));
+
+ s = caml_alloc_string(sizeof(c_header));
+ memcpy(String_val(s), (char *) &c_header, sizeof(c_header));
+ CAMLreturn(s);
+}
+
+CAMLprim value stub_xc_interface_open()
+{
+ int handle;
+ handle = xc_interface_open();
+ if (handle == -1)
+ failwith_xc();
+ return Val_int(handle);
+}
+
+
+CAMLprim value stub_xc_interface_open_fake()
+{
+ return Val_int(-1);
+}
+
+CAMLprim value stub_xc_using_injection()
+{
+ if (xc_using_injection ()){
+ return Val_int(1);
+ } else {
+ return Val_int(0);
+ }
+}
+
+CAMLprim value stub_xc_interface_close(value xc_handle)
+{
+ CAMLparam1(xc_handle);
+
+ int handle = _H(xc_handle);
+ // caml_enter_blocking_section();
+ xc_interface_close(handle);
+ // caml_leave_blocking_section();
+
+ CAMLreturn(Val_unit);
+}
+
+static int domain_create_flag_table[] = {
+ XEN_DOMCTL_CDF_hvm_guest,
+ XEN_DOMCTL_CDF_hap,
+};
+
+CAMLprim value stub_xc_domain_create(value xc_handle, value ssidref,
+ value flags, value handle)
+{
+ CAMLparam4(xc_handle, ssidref, flags, handle);
+
+ uint32_t domid = 0;
+ xen_domain_handle_t h = { 0 };
+ int result;
+ int i;
+ int c_xc_handle = _H(xc_handle);
+ uint32_t c_ssidref = Int32_val(ssidref);
+ unsigned int c_flags = 0;
+ value l;
+
+ if (Wosize_val(handle) != 16)
+ caml_invalid_argument("Handle not a 16-integer array");
+
+ for (i = 0; i < sizeof(h); i++) {
+ h[i] = Int_val(Field(handle, i)) & 0xff;
+ }
+
+ for (l = flags; l != Val_none; l = Field(l, 1)) {
+ int v = Int_val(Field(l, 0));
+ c_flags |= domain_create_flag_table[v];
+ }
+
+ // caml_enter_blocking_section();
+ result = xc_domain_create(c_xc_handle, c_ssidref, h, c_flags, &domid);
+ // caml_leave_blocking_section();
+
+ if (result < 0)
+ failwith_xc();
+
+ CAMLreturn(Val_int(domid));
+}
+
+CAMLprim value stub_xc_domain_setvmxassist(value xc_handle, value domid,
+ value use_vmxassist)
+{
+ CAMLparam3(xc_handle, domid, use_vmxassist);
+ int r;
+
+ r = xc_domain_setvmxassist(_H(xc_handle), _D(domid),
+ Bool_val(use_vmxassist));
+ if (r)
+ failwith_xc();
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_max_vcpus(value xc_handle, value domid,
+ value max_vcpus)
+{
+ CAMLparam3(xc_handle, domid, max_vcpus);
+ int r;
+
+ r = xc_domain_max_vcpus(_H(xc_handle), _D(domid), Int_val(max_vcpus));
+ if (r)
+ failwith_xc();
+
+ CAMLreturn(Val_unit);
+}
+
+
+value stub_xc_domain_sethandle(value xc_handle, value domid, value handle)
+{
+ CAMLparam3(xc_handle, domid, handle);
+ xen_domain_handle_t h = { 0 };
+ int i;
+
+ if (Wosize_val(handle) != 16)
+ caml_invalid_argument("Handle not a 16-integer array");
+
+ for (i = 0; i < sizeof(h); i++) {
+ h[i] = Int_val(Field(handle, i)) & 0xff;
+ }
+
+ i = xc_domain_sethandle(_H(xc_handle), _D(domid), h);
+ if (i)
+ failwith_xc();
+
+ CAMLreturn(Val_unit);
+}
+
+static value dom_op(value xc_handle, value domid, int (*fn)(int, uint32_t))
+{
+ CAMLparam2(xc_handle, domid);
+
+ int c_xc_handle = _H(xc_handle);
+ uint32_t c_domid = _D(domid);
+
+ // caml_enter_blocking_section();
+ int result = fn(c_xc_handle, c_domid);
+ // caml_leave_blocking_section();
+ if (result)
+ failwith_xc();
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_pause(value xc_handle, value domid)
+{
+ return dom_op(xc_handle, domid, xc_domain_pause);
+}
+
+
+CAMLprim value stub_xc_domain_unpause(value xc_handle, value domid)
+{
+ return dom_op(xc_handle, domid, xc_domain_unpause);
+}
+
+CAMLprim value stub_xc_domain_destroy(value xc_handle, value domid)
+{
+ return dom_op(xc_handle, domid, xc_domain_destroy);
+}
+
+CAMLprim value stub_xc_domain_resume_fast(value xc_handle, value domid)
+{
+ return dom_op(xc_handle, domid, xc_domain_resume_fast);
+}
+
+CAMLprim value stub_xc_domain_shutdown(value handle, value domid, value reason)
+{
+ CAMLparam3(handle, domid, reason);
+ int ret;
+
+ ret = xc_domain_shutdown(_H(handle), _D(domid), Int_val(reason));
+ if (ret < 0)
+ failwith_xc();
+
+ CAMLreturn(Val_unit);
+}
+
+static value alloc_domaininfo(xc_domaininfo_t * info)
+{
+ CAMLparam0();
+ CAMLlocal2(result, tmp);
+ int i;
+
+ result = caml_alloc_tuple(16);
+
+ Store_field(result, 0, Val_int(info->domain));
+ Store_field(result, 1, Val_bool(info->flags & XEN_DOMINF_dying));
+ Store_field(result, 2, Val_bool(info->flags & XEN_DOMINF_shutdown));
+ Store_field(result, 3, Val_bool(info->flags & XEN_DOMINF_paused));
+ Store_field(result, 4, Val_bool(info->flags & XEN_DOMINF_blocked));
+ Store_field(result, 5, Val_bool(info->flags & XEN_DOMINF_running));
+ Store_field(result, 6, Val_bool(info->flags & XEN_DOMINF_hvm_guest));
+ Store_field(result, 7, Val_int((info->flags >> XEN_DOMINF_shutdownshift)
+ & XEN_DOMINF_shutdownmask));
+ Store_field(result, 8, caml_copy_nativeint(info->tot_pages));
+ Store_field(result, 9, caml_copy_nativeint(info->max_pages));
+ Store_field(result, 10, caml_copy_int64(info->shared_info_frame));
+ Store_field(result, 11, caml_copy_int64(info->cpu_time));
+ Store_field(result, 12, Val_int(info->nr_online_vcpus));
+ Store_field(result, 13, Val_int(info->max_vcpu_id));
+ Store_field(result, 14, caml_copy_int32(info->ssidref));
+
+ tmp = caml_alloc_small(16, 0);
+ for (i = 0; i < 16; i++) {
+ Field(tmp, i) = Val_int(info->handle[i]);
+ }
+
+ Store_field(result, 15, tmp);
+
+ CAMLreturn(result);
+}
+
+CAMLprim value stub_xc_domain_getinfolist(value xc_handle, value first_domain, value nb)
+{
+ CAMLparam3(xc_handle, first_domain, nb);
+ CAMLlocal2(result, temp);
+ xc_domaininfo_t * info;
+ int i, ret, toalloc;
+
+ /* get the minimum number of allocate byte we need and bump it up to page boundary */
+ toalloc = (sizeof(xc_domaininfo_t) * Int_val(nb)) | 0xfff;
+ ret = posix_memalign((void **) ((void *) &info), 4096, toalloc);
+ if (ret)
+ caml_raise_out_of_memory();
+
+ result = temp = Val_emptylist;
+
+ int c_xc_handle = _H(xc_handle);
+ uint32_t c_first_domain = _D(first_domain);
+ unsigned int c_max_domains = Int_val(nb);
+ // caml_enter_blocking_section();
+ int retval = xc_domain_getinfolist(c_xc_handle, c_first_domain,
+ c_max_domains, info);
+ // caml_leave_blocking_section();
+
+ if (retval < 0) {
+ free(info);
+ failwith_xc();
+ }
+ for (i = 0; i < retval; i++) {
+ result = caml_alloc_small(2, Tag_cons);
+ Field(result, 0) = Val_int(0);
+ Field(result, 1) = temp;
+ temp = result;
+
+ Store_field(result, 0, alloc_domaininfo(info + i));
+ }
+
+ free(info);
+ CAMLreturn(result);
+}
+
+CAMLprim value stub_xc_domain_getinfo(value xc_handle, value domid)
+{
+ CAMLparam2(xc_handle, domid);
+ CAMLlocal1(result);
+ xc_domaininfo_t info;
+ int ret;
+
+ ret = xc_domain_getinfo(_H(xc_handle), _D(domid), &info);
+ if (ret != 0)
+ failwith_xc();
+
+ result = alloc_domaininfo(&info);
+ CAMLreturn(result);
+}
+
+CAMLprim value stub_xc_vcpu_getinfo(value xc_handle, value domid, value vcpu)
+{
+ CAMLparam3(xc_handle, domid, vcpu);
+ CAMLlocal1(result);
+ xc_vcpuinfo_t info;
+ int retval;
+
+ int c_xc_handle = _H(xc_handle);
+ uint32_t c_domid = _D(domid);
+ uint32_t c_vcpu = Int_val(vcpu);
+ // caml_enter_blocking_section();
+ retval = xc_vcpu_getinfo(c_xc_handle, c_domid,
+ c_vcpu, &info);
+ // caml_leave_blocking_section();
+ if (retval < 0)
+ failwith_xc();
+
+ result = caml_alloc_tuple(5);
+ Store_field(result, 0, Val_bool(info.online));
+ Store_field(result, 1, Val_bool(info.blocked));
+ Store_field(result, 2, Val_bool(info.running));
+ Store_field(result, 3, caml_copy_int64(info.cpu_time));
+ Store_field(result, 4, caml_copy_int32(info.cpu));
+
+ CAMLreturn(result);
+}
+
+CAMLprim value stub_xc_get_runstate_info(value xc_handle, value domid)
+{
+ CAMLparam2(xc_handle, domid);
+ CAMLlocal1(result);
+ xc_runstate_info_t info;
+ int retval;
+
+ int c_xc_handle = _H(xc_handle);
+ uint32_t c_domid = _D(domid);
+ retval = xc_get_runstate_info(c_xc_handle, c_domid, &info);
+ if (retval < 0)
+ failwith_xc();
+
+ /* Store
+ 0 : state (int32)
+ 1 : missed_changes (int32)
+ 2 : state_entry_time (int64)
+ 3-8 : times (int64s)
+ */
+ result = caml_alloc_tuple(9);
+ Store_field(result, 0, caml_copy_int32(info.state));
+ Store_field(result, 1, caml_copy_int32(info.missed_changes));
+ Store_field(result, 2, caml_copy_int64(info.state_entry_time));
+ Store_field(result, 3, caml_copy_int64(info.time[0]));
+ Store_field(result, 4, caml_copy_int64(info.time[1]));
+ Store_field(result, 5, caml_copy_int64(info.time[2]));
+ Store_field(result, 6, caml_copy_int64(info.time[3]));
+ Store_field(result, 7, caml_copy_int64(info.time[4]));
+ Store_field(result, 8, caml_copy_int64(info.time[5]));
+
+ CAMLreturn(result);
+}
+
+
+
+CAMLprim value stub_xc_vcpu_context_get(value xc_handle, value domid,
+ value cpu)
+{
+ CAMLparam3(xc_handle, domid, cpu);
+ CAMLlocal1(context);
+ int ret;
+ struct vcpu_guest_context ctxt;
+
+ ret = xc_vcpu_getcontext(_H(xc_handle), _D(domid), Int_val(cpu), &ctxt);
+
+ context = caml_alloc_string(sizeof(ctxt));
+ memcpy(String_val(context), (char *) &ctxt, sizeof(ctxt));
+
+ CAMLreturn(context);
+}
+
+CAMLprim value stub_xc_vcpu_setaffinity(value xc_handle, value domid,
+ value vcpu, value cpumap)
+{
+ CAMLparam4(xc_handle, domid, vcpu, cpumap);
+ uint64_t c_cpumap;
+ int retval;
+
+ c_cpumap = Int64_val(cpumap);
+ retval = xc_vcpu_setaffinity(_H(xc_handle), _D(domid),
+ Int_val(vcpu), c_cpumap);
+ if (retval < 0)
+ failwith_xc();
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_vcpu_getaffinity(value xc_handle, value domid,
+ value vcpu)
+{
+ CAMLparam3(xc_handle, domid, vcpu);
+ CAMLlocal1(ret);
+ uint64_t cpumap;
+ int retval;
+
+ retval = xc_vcpu_getaffinity(_H(xc_handle), _D(domid),
+ Int_val(vcpu), &cpumap);
+ if (retval < 0)
+ failwith_xc();
+ ret = caml_copy_int64(cpumap);
+ CAMLreturn(ret);
+}
+
+CAMLprim value stub_xc_sched_id(value xc_handle)
+{
+ CAMLparam1(xc_handle);
+ int sched_id;
+
+ if (xc_sched_id(_H(xc_handle), &sched_id))
+ failwith_xc();
+ CAMLreturn(Val_int(sched_id));
+}
+
+CAMLprim value stub_xc_evtchn_alloc_unbound(value xc_handle,
+ value local_domid,
+ value remote_domid)
+{
+ CAMLparam3(xc_handle, local_domid, remote_domid);
+
+ int c_xc_handle = _H(xc_handle);
+ uint32_t c_local_domid = _D(local_domid);
+ uint32_t c_remote_domid = _D(remote_domid);
+
+ // caml_enter_blocking_section();
+ int result = xc_evtchn_alloc_unbound(c_xc_handle, c_local_domid,
+ c_remote_domid);
+ // caml_leave_blocking_section();
+
+ if (result < 0)
+ failwith_xc();
+ CAMLreturn(Val_int(result));
+}
+
+CAMLprim value stub_xc_evtchn_reset(value handle, value domid)
+{
+ CAMLparam2(handle, domid);
+ int r;
+
+ r = xc_evtchn_reset(_H(handle), _D(domid));
+ if (r < 0)
+ failwith_xc();
+ CAMLreturn(Val_unit);
+}
+
+
+#define RING_SIZE 32768
+static char ring[RING_SIZE];
+
+CAMLprim value stub_xc_readconsolering(value xc_handle)
+{
+ unsigned int size = RING_SIZE;
+ char *ring_ptr = ring;
+
+ CAMLparam1(xc_handle);
+ int c_xc_handle = _H(xc_handle);
+
+ // caml_enter_blocking_section();
+ int retval = xc_readconsolering(c_xc_handle, &ring_ptr, &size, 0);
+ // caml_leave_blocking_section();
+
+ if (retval)
+ failwith_xc();
+ ring[size] = '\0';
+ CAMLreturn(caml_copy_string(ring));
+}
+
+CAMLprim value stub_xc_send_debug_keys(value xc_handle, value keys)
+{
+ CAMLparam2(xc_handle, keys);
+ int r;
+
+ r = xc_send_debug_keys(_H(xc_handle), String_val(keys));
+ if (r)
+ failwith_xc();
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_physinfo(value xc_handle)
+{
+ CAMLparam1(xc_handle);
+ CAMLlocal1(physinfo);
+ xc_physinfo_t c_physinfo;
+ int r;
+
+ // caml_enter_blocking_section();
+ r = xc_physinfo(_H(xc_handle), &c_physinfo);
+ // caml_leave_blocking_section();
+
+ if (r)
+ failwith_xc();
+
+ physinfo = caml_alloc_tuple(9);
+ Store_field(physinfo, 0, Val_int(COMPAT_FIELD_physinfo_get_nr_cpus(c_physinfo)));
+ Store_field(physinfo, 1, Val_int(c_physinfo.threads_per_core));
+ Store_field(physinfo, 2, Val_int(c_physinfo.cores_per_socket));
+ Store_field(physinfo, 3, Val_int(COMPAT_FIELD_physinfo_get_sockets_per_node(c_physinfo)));
+ Store_field(physinfo, 4, Val_int(c_physinfo.nr_nodes));
+ Store_field(physinfo, 5, Val_int(c_physinfo.cpu_khz));
+ Store_field(physinfo, 6, caml_copy_nativeint(c_physinfo.total_pages));
+ Store_field(physinfo, 7, caml_copy_nativeint(c_physinfo.free_pages));
+ Store_field(physinfo, 8, caml_copy_nativeint(c_physinfo.scrub_pages));
+
+ CAMLreturn(physinfo);
+}
+
+CAMLprim value stub_xc_pcpu_info(value xc_handle, value nr_cpus)
+{
+ CAMLparam2(xc_handle, nr_cpus);
+ CAMLlocal2(pcpus, v);
+ uint64_t *info;
+ int r, size;
+
+ if (Int_val(nr_cpus) < 1)
+ caml_invalid_argument("nr_cpus");
+
+ info = calloc(Int_val(nr_cpus) + 1, sizeof(uint64_t));
+ if (!info)
+ caml_raise_out_of_memory();
+
+ // caml_enter_blocking_section();
+ r = xc_pcpu_info(_H(xc_handle), Int_val(nr_cpus), info, &size);
+ // caml_leave_blocking_section();
+
+ if (r) {
+ free(info);
+ failwith_xc();
+ }
+
+ if (size > 0) {
+ int i;
+ pcpus = caml_alloc(size, 0);
+ for (i = 0; i < size; i++) {
+ v = caml_copy_int64(info[i]);
+ caml_modify(&Field(pcpus, i), v);
+ }
+ } else
+ pcpus = Atom(0);
+ free(info);
+ CAMLreturn(pcpus);
+}
+
+CAMLprim value stub_xc_domain_setmaxmem(value xc_handle, value domid,
+ value max_memkb)
+{
+ CAMLparam3(xc_handle, domid, max_memkb);
+
+ int c_xc_handle = _H(xc_handle);
+ uint32_t c_domid = _D(domid);
+ unsigned int c_max_memkb = Int64_val(max_memkb);
+ // caml_enter_blocking_section();
+ int retval = xc_domain_setmaxmem(c_xc_handle, c_domid,
+ c_max_memkb);
+ // caml_leave_blocking_section();
+ if (retval)
+ failwith_xc();
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_set_memmap_limit(value xc_handle, value domid,
+ value map_limitkb)
+{
+ CAMLparam3(xc_handle, domid, map_limitkb);
+ unsigned long v;
+ int retval;
+
+ v = Int64_val(map_limitkb);
+ retval = xc_domain_set_memmap_limit(_H(xc_handle), _D(domid), v);
+ if (retval)
+ failwith_xc();
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_memory_increase_reservation(value xc_handle,
+ value domid,
+ value mem_kb)
+{
+ CAMLparam3(xc_handle, domid, mem_kb);
+
+ unsigned long nr_extents = ((unsigned long)(Int64_val(mem_kb))) >> (PAGE_SHIFT - 10);
+
+ int c_xc_handle = _H(xc_handle);
+ uint32_t c_domid = _D(domid);
+ // caml_enter_blocking_section();
+ int retval = xc_domain_memory_increase_reservation(c_xc_handle, c_domid,
+ nr_extents, 0, 0, NULL);
+ // caml_leave_blocking_section();
+
+ if (retval)
+ failwith_xc();
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_set_machine_address_size(value xc_handle,
+ value domid,
+ value width)
+{
+ CAMLparam3(xc_handle, domid, width);
+ int c_xc_handle = _H(xc_handle);
+ uint32_t c_domid = _D(domid);
+ int c_width = Int_val(width);
+
+ int retval = xc_domain_set_machine_address_size(c_xc_handle, c_domid, c_width);
+ if (retval)
+ failwith_xc();
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_get_machine_address_size(value xc_handle,
+ value domid)
+{
+ CAMLparam2(xc_handle, domid);
+ int retval;
+
+ retval = xc_domain_get_machine_address_size(_H(xc_handle), _D(domid));
+ if (retval < 0)
+ failwith_xc();
+ CAMLreturn(Val_int(retval));
+}
+
+CAMLprim value stub_xc_domain_suppress_spurious_page_faults(value xc_handle,
+ value domid)
+{
+ CAMLparam2(xc_handle, domid);
+ int c_xc_handle = _H(xc_handle);
+ uint32_t c_domid = _D(domid);
+
+ int retval = xc_domain_suppress_spurious_page_faults(c_xc_handle, c_domid);
+ if (retval)
+ failwith_xc();
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_cpuid_set(value xc_handle, value domid,
+ value is_hvm, value input,
+ value config)
+{
+ CAMLparam5(xc_handle, domid, is_hvm, input, config);
+ CAMLlocal2(array, tmp);
+ int r;
+ char *c_config[4], *out_config[4];
+ uint32_t c_input, c_oinput;
+
+ c_config[0] = string_of_option_array(config, 0);
+ c_config[1] = string_of_option_array(config, 1);
+ c_config[2] = string_of_option_array(config, 2);
+ c_config[3] = string_of_option_array(config, 3);
+
+ cpuid_input_of_val(c_input, c_oinput, input);
+
+ array = caml_alloc(4, 0);
+ for (r = 0; r < 4; r++) {
+ tmp = Val_none;
+ if (c_config[r]) {
+ tmp = caml_alloc_small(1, 0);
+ Field(tmp, 0) = caml_alloc_string(32);
+ }
+ Store_field(array, r, tmp);
+ }
+
+ for (r = 0; r < 4; r++)
+ out_config[r] = (c_config[r]) ? String_val(Field(Field(array, r), 0)) : NULL;
+
+ r = xc_domain_cpuid_set(_H(xc_handle), _D(domid), Bool_val(is_hvm),
+ c_input, c_oinput, c_config, out_config);
+ if (r < 0)
+ failwith_xc();
+ CAMLreturn(array);
+}
+
+CAMLprim value stub_xc_domain_cpuid_apply(value xc_handle, value domid, value is_hvm)
+{
+ CAMLparam3(xc_handle, domid, is_hvm);
+ int r;
+ r = xc_domain_cpuid_apply(_H(xc_handle), _D(domid), Bool_val(is_hvm));
+ if (r < 0)
+ failwith_xc();
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_cpuid_check(value input, value config)
+{
+ CAMLparam2(input, config);
+ CAMLlocal3(ret, array, tmp);
+ int r;
+ uint32_t c_input, c_oinput;
+ char *c_config[4], *out_config[4];
+
+ c_config[0] = string_of_option_array(config, 0);
+ c_config[1] = string_of_option_array(config, 1);
+ c_config[2] = string_of_option_array(config, 2);
+ c_config[3] = string_of_option_array(config, 3);
+
+ cpuid_input_of_val(c_input, c_oinput, input);
+
+ array = caml_alloc(4, 0);
+ for (r = 0; r < 4; r++) {
+ tmp = Val_none;
+ if (c_config[r]) {
+ tmp = caml_alloc_small(1, 0);
+ Field(tmp, 0) = caml_alloc_string(32);
+ }
+ Store_field(array, r, tmp);
+ }
+
+ for (r = 0; r < 4; r++)
+ out_config[r] = (c_config[r]) ? String_val(Field(Field(array, r), 0)) : NULL;
+
+ r = xc_cpuid_check(c_input, c_oinput, c_config, out_config);
+ if (r < 0)
+ failwith_xc();
+
+ ret = caml_alloc_tuple(2);
+ Store_field(ret, 0, Val_bool(r));
+ Store_field(ret, 1, array);
+
+ CAMLreturn(ret);
+}
+
+CAMLprim value stub_xc_version_version(value xc_handle)
+{
+ CAMLparam1(xc_handle);
+ CAMLlocal1(result);
+ xen_extraversion_t extra;
+ long packed;
+ int retval;
+
+ int c_xc_handle = _H(xc_handle);
+ // caml_enter_blocking_section();
+ packed = xc_version(c_xc_handle, XENVER_version, NULL);
+ retval = xc_version(c_xc_handle, XENVER_extraversion, &extra);
+ // caml_leave_blocking_section();
+
+ if (retval)
+ failwith_xc();
+
+ result = caml_alloc_tuple(3);
+
+ Store_field(result, 0, Val_int(packed >> 16));
+ Store_field(result, 1, Val_int(packed & 0xffff));
+ Store_field(result, 2, caml_copy_string(extra));
+
+ CAMLreturn(result);
+}
+
+
+CAMLprim value stub_xc_version_compile_info(value xc_handle)
+{
+ CAMLparam1(xc_handle);
+ CAMLlocal1(result);
+ xen_compile_info_t ci;
+ int retval;
+
+ int c_xc_handle = _H(xc_handle);
+ // caml_enter_blocking_section();
+ retval = xc_version(c_xc_handle, XENVER_compile_info, &ci);
+ // caml_leave_blocking_section();
+
+ if (retval)
+ failwith_xc();
+
+ result = caml_alloc_tuple(4);
+
+ Store_field(result, 0, caml_copy_string(ci.compiler));
+ Store_field(result, 1, caml_copy_string(ci.compile_by));
+ Store_field(result, 2, caml_copy_string(ci.compile_domain));
+ Store_field(result, 3, caml_copy_string(ci.compile_date));
+
+ CAMLreturn(result);
+}
+
+
+static value xc_version_single_string(value xc_handle, int code, void *info)
+{
+ CAMLparam1(xc_handle);
+ int retval;
+
+ int c_xc_handle = _H(xc_handle);
+ // caml_enter_blocking_section();
+ retval = xc_version(c_xc_handle, code, info);
+ // caml_leave_blocking_section();
+
+ if (retval)
+ failwith_xc();
+
+ CAMLreturn(caml_copy_string((char *)info));
+}
+
+
+CAMLprim value stub_xc_version_changeset(value xc_handle)
+{
+ xen_changeset_info_t ci;
+
+ return xc_version_single_string(xc_handle, XENVER_changeset, &ci);
+}
+
+
+CAMLprim value stub_xc_version_capabilities(value xc_handle)
+{
+ xen_capabilities_info_t ci;
+
+ return xc_version_single_string(xc_handle, XENVER_capabilities, &ci);
+}
+
+
+CAMLprim value stub_pages_to_kib(value pages)
+{
+ CAMLparam1(pages);
+
+ CAMLreturn(caml_copy_int64(Int64_val(pages) << (PAGE_SHIFT - 10)));
+}
+
+
+CAMLprim value stub_map_foreign_range(value xc_handle, value dom,
+ value size, value mfn)
+{
+ CAMLparam4(xc_handle, dom, size, mfn);
+ CAMLlocal1(result);
+ struct mmap_interface *intf;
+
+ result = caml_alloc(sizeof(struct mmap_interface), Abstract_tag);
+ intf = (struct mmap_interface *) result;
+
+ intf->len = Int_val(size);
+
+ int c_xc_handle = _H(xc_handle);
+ uint32_t c_dom = _D(dom);
+ unsigned long c_mfn = Nativeint_val(mfn);
+ // caml_enter_blocking_section();
+ intf->addr = xc_map_foreign_range(c_xc_handle, c_dom,
+ intf->len, PROT_READ|PROT_WRITE,
+ c_mfn);
+ // caml_leave_blocking_section();
+ if (!intf->addr)
+ caml_failwith("xc_map_foreign_range error");
+ CAMLreturn(result);
+}
+
+CAMLprim value stub_sched_credit_domain_get(value xc_handle, value domid)
+{
+ CAMLparam2(xc_handle, domid);
+ CAMLlocal1(sdom);
+ struct xen_domctl_sched_credit c_sdom;
+ int ret;
+
+ // caml_enter_blocking_section();
+ ret = xc_sched_credit_domain_get(_H(xc_handle), _D(domid), &c_sdom);
+ // caml_leave_blocking_section();
+ if (ret != 0)
+ failwith_xc();
+
+ sdom = caml_alloc_tuple(2);
+ Store_field(sdom, 0, Val_int(c_sdom.weight));
+ Store_field(sdom, 1, Val_int(c_sdom.cap));
+
+ CAMLreturn(sdom);
+}
+
+CAMLprim value stub_sched_credit_domain_set(value xc_handle, value domid,
+ value sdom)
+{
+ CAMLparam3(xc_handle, domid, sdom);
+ struct xen_domctl_sched_credit c_sdom;
+ int ret;
+
+ c_sdom.weight = Int_val(Field(sdom, 0));
+ c_sdom.cap = Int_val(Field(sdom, 1));
+ // caml_enter_blocking_section();
+ ret = xc_sched_credit_domain_set(_H(xc_handle), _D(domid), &c_sdom);
+ // caml_leave_blocking_section();
+ if (ret != 0)
+ failwith_xc();
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_shadow_allocation_get(value xc_handle, value domid)
+{
+ CAMLparam2(xc_handle, domid);
+ CAMLlocal1(mb);
+ uint32_t c_mb;
+ int ret;
+
+ // caml_enter_blocking_section();
+ ret = xc_shadow_allocation_get(_H(xc_handle), _D(domid), &c_mb);
+ // caml_leave_blocking_section();
+ if (ret != 0)
+ failwith_xc();
+
+ mb = Val_int(c_mb);
+ CAMLreturn(mb);
+}
+
+CAMLprim value stub_shadow_allocation_set(value xc_handle, value domid,
+ value mb)
+{
+ CAMLparam3(xc_handle, domid, mb);
+ uint32_t c_mb;
+ int ret;
+
+ c_mb = Int_val(mb);
+ // caml_enter_blocking_section();
+ ret = xc_shadow_allocation_set(_H(xc_handle), _D(domid), c_mb);
+ // caml_leave_blocking_section();
+ if (ret != 0)
+ failwith_xc();
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_get_pfn_list(value xc_handle, value domid,
+ value nr_pfns)
+{
+ CAMLparam3(xc_handle, domid, nr_pfns);
+ CAMLlocal2(array, v);
+ unsigned long c_nr_pfns;
+ long ret, i;
+ xen_pfn_t *c_array;
+
+ c_nr_pfns = Nativeint_val(nr_pfns);
+
+ c_array = malloc(sizeof(xen_pfn_t) * c_nr_pfns);
+ if (!c_array)
+ caml_raise_out_of_memory();
+
+ ret = xc_domain_get_pfn_list(_H(xc_handle), _D(domid),
+ c_array, c_nr_pfns);
+ if (ret < 0) {
+ free(c_array);
+ failwith_xc();
+ }
+
+ array = caml_alloc(ret, 0);
+ for (i = 0; i < ret; i++) {
+ v = caml_copy_nativeint(c_array[i]);
+ Store_field(array, i, v);
+ }
+ free(c_array);
+
+ CAMLreturn(array);
+}
+
+CAMLprim value stub_xc_domain_ioport_permission(value xc_handle, value domid,
+ value start_port, value nr_ports,
+ value allow)
+{
+ CAMLparam5(xc_handle, domid, start_port, nr_ports, allow);
+ uint32_t c_start_port, c_nr_ports;
+ uint8_t c_allow;
+ int ret;
+
+ c_start_port = Int_val(start_port);
+ c_nr_ports = Int_val(nr_ports);
+ c_allow = Bool_val(allow);
+
+ ret = xc_domain_ioport_permission(_H(xc_handle), _D(domid),
+ c_start_port, c_nr_ports, c_allow);
+ if (ret < 0)
+ failwith_xc();
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_iomem_permission(value xc_handle, value domid,
+ value start_pfn, value nr_pfns,
+ value allow)
+{
+ CAMLparam5(xc_handle, domid, start_pfn, nr_pfns, allow);
+ unsigned long c_start_pfn, c_nr_pfns;
+ uint8_t c_allow;
+ int ret;
+
+ c_start_pfn = Nativeint_val(start_pfn);
+ c_nr_pfns = Nativeint_val(nr_pfns);
+ c_allow = Bool_val(allow);
+
+ ret = xc_domain_iomem_permission(_H(xc_handle), _D(domid),
+ c_start_pfn, c_nr_pfns, c_allow);
+ if (ret < 0)
+ failwith_xc();
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_irq_permission(value xc_handle, value domid,
+ value pirq, value allow)
+{
+ CAMLparam4(xc_handle, domid, pirq, allow);
+ uint8_t c_pirq;
+ uint8_t c_allow;
+ int ret;
+
+ c_pirq = Int_val(pirq);
+ c_allow = Bool_val(allow);
+
+ ret = xc_domain_irq_permission(_H(xc_handle), _D(domid),
+ c_pirq, c_allow);
+ if (ret < 0)
+ failwith_xc();
+
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_hvm_check_pvdriver(value xc_handle, value domid)
+{
+ CAMLparam2(xc_handle, domid);
+ int ret;
+
+ ret = xc_hvm_check_pvdriver(_H(xc_handle), _D(domid));
+ if (ret < 0)
+ failwith_xc();
+ CAMLreturn(Val_bool(ret));
+}
+
+CAMLprim value stub_xc_domain_test_assign_device(value xc_handle, value domid, value desc)
+{
+ CAMLparam3(xc_handle, domid, desc);
+ int ret;
+ int domain, bus, slot, func;
+
+ domain = Int_val(Field(desc, 0));
+ bus = Int_val(Field(desc, 1));
+ slot = Int_val(Field(desc, 2));
+ func = Int_val(Field(desc, 3));
+
+ ret = xc_domain_test_assign_device(_H(xc_handle), _D(domid),
+ domain, bus, slot, func);
+ CAMLreturn(Val_bool(ret == 0));
+}
+
+CAMLprim value stub_xc_domain_assign_device(value xc_handle, value domid, value desc)
+{
+ CAMLparam3(xc_handle, domid, desc);
+ int ret;
+ int domain, bus, slot, func;
+
+ domain = Int_val(Field(desc, 0));
+ bus = Int_val(Field(desc, 1));
+ slot = Int_val(Field(desc, 2));
+ func = Int_val(Field(desc, 3));
+
+ ret = xc_domain_assign_device(_H(xc_handle), _D(domid),
+ domain, bus, slot, func);
+ if (ret < 0)
+ failwith_xc();
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_deassign_device(value xc_handle, value domid, value desc)
+{
+ CAMLparam3(xc_handle, domid, desc);
+ int ret;
+ int domain, bus, slot, func;
+
+ domain = Int_val(Field(desc, 0));
+ bus = Int_val(Field(desc, 1));
+ slot = Int_val(Field(desc, 2));
+ func = Int_val(Field(desc, 3));
+
+ ret = xc_domain_deassign_device(_H(xc_handle), _D(domid),
+ domain, bus, slot, func);
+ if (ret < 0)
+ failwith_xc();
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_watchdog(value handle, value id, value timeout)
+{
+ CAMLparam3(handle, id, timeout);
+ int ret;
+ unsigned int c_timeout = Int32_val(timeout);
+
+ ret = xc_domain_watchdog(_H(handle), Int_val(id), c_timeout);
+ if (ret < 0)
+ failwith_xc();
+
+ CAMLreturn(Val_int(ret));
+}
+
+CAMLprim value stub_xc_domain_get_acpi_s_state(value handle, value domid)
+{
+ CAMLparam2(handle, domid);
+ int ret;
+
+ ret = xc_domain_get_acpi_s_state(_H(handle), _D(domid));
+ if (ret < 0)
+ failwith_xc();
+
+ CAMLreturn(Val_int(ret));
+}
+
+CAMLprim value stub_xc_domain_send_s3resume(value handle, value domid)
+{
+ CAMLparam2(handle, domid);
+ xc_domain_send_s3resume(_H(handle), _D(domid));
+ CAMLreturn(Val_unit);
+}
+
+/*
+ * Local variables:
+ * indent-tabs-mode: t
+ * c-basic-offset: 8
+ * tab-width: 8
+ * End:
+ */
--- /dev/null
+version = "@VERSION@"
+description = "Xml-light2 - Xml-light replacement"
+requires = "stdext"
+archive(byte) = "xml-light2.cma"
+archive(native) = "xml-light2.cmxa"
--- /dev/null
+OCAMLPACKS = xmlm
+
+CC = gcc
+CFLAGS = -Wall -fPIC -O2 -I/opt/xensource/lib/ocaml
+
+OCAMLFIND = ocamlfind
+OCAMLFINDFLAGS = -package $(OCAMLPACKS)
+
+OCAMLC = $(OCAMLFIND) ocamlc -g $(OCAMLFINDFLAGS)
+OCAMLOPT = $(OCAMLFIND) ocamlopt $(OCAMLFINDFLAGS)
+
+LDFLAGS = -cclib -L./
+
+DESTDIR ?= /
+VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0)
+OCAMLOPTFLAGS = -g -dtypes
+
+OCAMLABI := $(shell ocamlc -version)
+OCAMLLIBDIR := $(shell ocamlc -where)
+OCAMLDESTDIR ?= $(OCAMLLIBDIR)
+
+OBJS = xml
+INTF = xml.cmi
+LIBS = xml-light2.cma xml-light2.cmxa
+
+all: $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+xml-light2.cmxa: $(foreach obj,$(OBJS),$(obj).cmx)
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -a -o $@ $(foreach obj,$(OBJS),$(obj).cmx)
+
+xml-light2.cma: $(foreach obj,$(OBJS),$(obj).cmo)
+ $(OCAMLC) -a -o $@ $(foreach obj,$(OBJS),$(obj).cmo)
+
+%.cmo: %.ml
+ $(OCAMLC) -c -I ../stdext -o $@ $<
+
+%.cmi: %.mli
+ $(OCAMLC) -c -I ../stdext -o $@ $<
+
+%.cmx: %.ml
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -c -I ../stdext -o $@ $<
+
+%.o: %.c
+ $(CC) $(CFLAGS) -c -o $@ $<
+
+META: META.in
+ sed 's/@VERSION@/$(VERSION)/g' < $< > $@
+
+.PHONY: install
+install: $(LIBS) META
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore xml-light2 META $(INTF) $(LIBS) *.a *.cmx
+
+.PHONY: uninstall
+uninstall:
+ ocamlfind remove xml-light2
+
+clean:
+ rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS)
+
--- /dev/null
+(*
+ * Copyright (c) 2007 XenSource Ltd.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ *
+ * This is a replacement interface for xml-light that use the superior xmlm
+ * engine to parse stuff. Also the output functions SKIP characters that are
+ * not allowed in XML.
+ *)
+
+(* tree representation *)
+type xml =
+ | Element of (string * (string * string) list * xml list)
+ | PCData of string
+
+type error_pos = { eline: int; eline_start: int; emin: int; emax: int }
+type error = string * error_pos
+
+exception Error of error
+
+let error (msg,pos) =
+ Printf.sprintf "%s line %d" msg pos.eline
+
+(* internal parse function *)
+let _parse i =
+ let filter_empty_pcdata l =
+ let is_empty_string s =
+ let is_empty = ref true in
+ for i = 0 to (String.length s - 1)
+ do
+ if s.[i] <> '\n' && s.[i] <> ' ' && s.[i] <> '\t' then
+ is_empty := false
+ done;
+ not (!is_empty)
+ in
+ List.filter (fun node ->
+ match node with Element _ -> true | PCData data -> is_empty_string data
+ ) l
+ in
+ let d data acc =
+ match acc with
+ | childs :: path -> ((PCData data) :: childs) :: path
+ | [] -> assert false
+ in
+ let s tag acc = [] :: acc in
+ let e tag acc =
+ match acc with
+ | childs :: path ->
+ (* xml light doesn't handle namespace in node *)
+ let (_, name), attrs = tag in
+ (* xml light doesn't have namespace in attributes *)
+ let realattrs = List.map (fun ((_, n), v) -> n, v) attrs in
+ let childs = filter_empty_pcdata childs in
+ let el = Element (name, realattrs, List.rev childs) in
+ begin match path with
+ | parent :: path' -> (el :: parent) :: path'
+ | [] -> [ [ el ] ]
+ end
+ | [] -> assert false
+ in
+ match Xmlm.input ~d ~s ~e [] i with
+ | [ [ r ] ] -> r
+ | _ -> assert false
+
+let parse i =
+ try _parse i
+ with
+ | Xmlm.Error ((line, col), msg) ->
+ let pos = {
+ eline = line; eline_start = line;
+ emin = col; emax = col
+ } in
+ let err = Xmlm.error_message msg in
+ raise (Error (err, pos))
+
+(* common parse function *)
+let parse_file file =
+ let chan = open_in file in
+ try
+ let i = Xmlm.input_of_channel chan in
+ let ret = parse i in
+ close_in chan;
+ ret
+ with exn ->
+ close_in_noerr chan; raise exn
+
+let parse_in chan =
+ let i = Xmlm.input_of_channel chan in
+ parse i
+
+let parse_string s =
+ let i = Xmlm.input_of_string s in
+ parse i
+
+(* common output function *)
+let substitute list s =
+ s
+
+let esc_pcdata data =
+ let buf = Buffer.create (String.length data + 10) in
+ for i = 0 to String.length data - 1
+ do
+ let s = match data.[i] with
+ | '>' -> ">";
+ | '<' -> "<";
+ | '&' -> "&";
+ | '"' -> """;
+ | c when (c >= '\x20' && c <= '\xff')
+ || c = '\x09' || c = '\x0a' || c = '\x0d'
+ -> String.make 1 c
+ | _ -> ""
+ in
+ Buffer.add_string buf s
+ done;
+ Buffer.contents buf
+
+let str_of_attrs attrs =
+ let fmt s = Printf.sprintf s in
+ if List.length attrs > 0 then
+ " "^(String.concat " " (List.map (fun (k, v) -> fmt "%s=\"%s\"" k (esc_pcdata v)) attrs))
+ else
+ ""
+
+let to_fct xml f =
+ let fmt s = Printf.sprintf s in
+ let rec print xml =
+ match xml with
+ | Element (name, attrs, []) ->
+ let astr = str_of_attrs attrs in
+ let on = fmt "<%s%s/>" name astr in
+ f on;
+ | Element (name, attrs, children) ->
+ let astr = str_of_attrs attrs in
+ let on = fmt "<%s%s>" name astr in
+ let off = fmt "</%s>" name in
+ f on;
+ List.iter (fun child -> print child) children;
+ f off
+ | PCData data ->
+ f (esc_pcdata data)
+ in
+ print xml
+
+let to_fct_fmt xml f =
+ let fmt s = Printf.sprintf s in
+ let rec print newl indent xml =
+ match xml with
+ | Element (name, attrs, [ PCData data ]) ->
+ let astr = str_of_attrs attrs in
+ let on = fmt "%s<%s%s>" indent name astr in
+ let off = fmt "</%s>%s" name (if newl then "\n" else "") in
+ f on;
+ f (esc_pcdata data);
+ f off;
+ | Element (name, attrs, []) ->
+ let astr = str_of_attrs attrs in
+ let on = fmt "%s<%s%s/>%s" indent name astr
+ (if newl then "\n" else "") in
+ f on;
+ | Element (name, attrs, children) ->
+ let astr = str_of_attrs attrs in
+ let on = fmt "%s<%s%s>\n" indent name astr in
+ let off = fmt "%s</%s>%s" indent name
+ (if newl then "\n" else "") in
+ f on;
+ List.iter (fun child -> print true
+ (indent ^ " ") child) children;
+ f off
+ | PCData data ->
+ f ((esc_pcdata data) ^ (if newl then "\n" else ""))
+ in
+ print false "" xml
+
+let to_string xml =
+ let buffer = Buffer.create 1024 in
+ to_fct xml (fun s -> Buffer.add_string buffer s);
+ let s = Buffer.contents buffer in Buffer.reset buffer; s
+
+let to_string_fmt xml =
+ let buffer = Buffer.create 1024 in
+ to_fct_fmt xml (fun s -> Buffer.add_string buffer s);
+ let s = Buffer.contents buffer in Buffer.reset buffer; s
+
+let to_bigbuffer xml =
+ let buffer = Bigbuffer.make () in
+ to_fct xml (fun s -> Bigbuffer.append_substring buffer s 0 (String.length s));
+ buffer
--- /dev/null
+(** tree representation *)
+type xml =
+ | Element of (string * (string * string) list * xml list)
+ | PCData of string
+
+type error_pos
+type error = string * error_pos
+
+exception Error of error
+
+val error : error -> string
+
+(** input functions *)
+val parse_file : string -> xml
+val parse_in : in_channel -> xml
+val parse_string : string -> xml
+
+(** output functions *)
+val to_fct : xml -> (string -> unit) -> unit
+val to_fct_fmt : xml -> (string -> unit) -> unit
+val to_string : xml -> string
+val to_string_fmt : xml -> string
+val to_bigbuffer : xml -> Bigbuffer.t
--- /dev/null
+version = "@VERSION@"
+description = "XenStore Interface"
+archive(byte) = "xs.cma"
+archive(native) = "xs.cmxa"
--- /dev/null
+CC = gcc
+CFLAGS = -Wall -fPIC -O2 -I/opt/xensource/lib/ocaml
+OCAMLC = ocamlc -g -I ../xb/
+OCAMLOPT = ocamlopt
+
+LDFLAGS = -cclib -L./
+
+DESTDIR ?= /
+VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0)
+OCAMLOPTFLAGS = -g -dtypes -I ../xb/
+
+OCAMLABI := $(shell ocamlc -version)
+OCAMLLIBDIR := $(shell ocamlc -where)
+OCAMLDESTDIR ?= $(OCAMLLIBDIR)
+
+PREINTF = xsraw.cmi xst.cmi
+PREOBJS = queueop xsraw xst
+PRELIBS = $(foreach obj, $(PREOBJS),$(obj).cmo) $(foreach obj,$(PREOJBS),$(obj).cmx)
+OBJS = queueop xsraw xst xs
+INTF = xsraw.cmi xst.cmi xs.cmi
+LIBS = xs.cma xs.cmxa
+
+all: $(PREINTF) $(PRELIBS) $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+xs.cmxa: $(foreach obj,$(OBJS),$(obj).cmx)
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -a -o $@ $(foreach obj,$(OBJS),$(obj).cmx)
+
+xs.cma: $(foreach obj,$(OBJS),$(obj).cmo)
+ $(OCAMLC) -a -o $@ $(foreach obj,$(OBJS),$(obj).cmo)
+
+%.cmo: %.ml
+ $(OCAMLC) -c -o $@ $<
+
+%.cmi: %.mli
+ $(OCAMLC) -c -o $@ $<
+
+%.cmx: %.ml
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -c -o $@ $<
+
+%.o: %.c
+ $(CC) $(CFLAGS) -c -o $@ $<
+
+META: META.in
+ sed 's/@VERSION@/$(VERSION)/g' < $< > $@
+
+.PHONY: install
+install: $(LIBS) META
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore xs META $(INTF) xs.mli xst.mli xsraw.mli $(LIBS) *.a *.cmx
+
+.PHONY: uninstall
+uninstall:
+ ocamlfind remove xs
+
+clean:
+ rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot $(LIBS) $(PROGRAMS)
+
--- /dev/null
+(*
+ * Copyright (c) 2006 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ *
+ * All rights reserved.
+ *)
+
+let data_concat ls = (String.concat "\000" ls) ^ "\000"
+let queue_path ty (tid: int) (path: string) con =
+ let data = data_concat [ path; ] in
+ Xb.queue con (Xb.Packet.create tid 0 ty data)
+
+(* operations *)
+let directory tid path con = queue_path Xb.Op.Directory tid path con
+let read tid path con = queue_path Xb.Op.Read tid path con
+
+let getperms tid path con = queue_path Xb.Op.Getperms tid path con
+
+let debug commands con =
+ Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Debug (data_concat commands))
+
+let watch path data con =
+ let data = data_concat [ path; data; ] in
+ Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Watch data)
+
+let unwatch path data con =
+ let data = data_concat [ path; data; ] in
+ Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Unwatch data)
+
+let transaction_start con =
+ Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Transaction_start (data_concat []))
+
+let transaction_end tid commit con =
+ let data = data_concat [ (if commit then "T" else "F"); ] in
+ Xb.queue con (Xb.Packet.create tid 0 Xb.Op.Transaction_end data)
+
+let introduce domid mfn port con =
+ let data = data_concat [ Printf.sprintf "%u" domid;
+ Printf.sprintf "%nu" mfn;
+ string_of_int port; ] in
+ Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Introduce data)
+
+let release domid con =
+ let data = data_concat [ Printf.sprintf "%u" domid; ] in
+ Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Release data)
+
+let resume domid con =
+ let data = data_concat [ Printf.sprintf "%u" domid; ] in
+ Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Resume data)
+
+let getdomainpath domid con =
+ let data = data_concat [ Printf.sprintf "%u" domid; ] in
+ Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Getdomainpath data)
+
+let write tid path value con =
+ let data = path ^ "\000" ^ value (* no NULL at the end *) in
+ Xb.queue con (Xb.Packet.create tid 0 Xb.Op.Write data)
+
+let mkdir tid path con = queue_path Xb.Op.Mkdir tid path con
+let rm tid path con = queue_path Xb.Op.Rm tid path con
+
+let setperms tid path perms con =
+ let data = data_concat [ path; perms ] in
+ Xb.queue con (Xb.Packet.create tid 0 Xb.Op.Setperms data)
--- /dev/null
+(*
+ * Copyright (c) 2006 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ *
+ * All rights reserved.
+ *)
+
+type perms = Xsraw.perms
+type con = Xsraw.con
+type domid = int
+
+type xsh =
+{
+ con: con;
+ debug: string list -> string;
+ directory: string -> string list;
+ read: string -> string;
+ readv: string -> string list -> string list;
+ write: string -> string -> unit;
+ writev: string -> (string * string) list -> unit;
+ mkdir: string -> unit;
+ rm: string -> unit;
+ getperms: string -> perms;
+ setperms: string -> perms -> unit;
+ setpermsv: string -> string list -> perms -> unit;
+ introduce: domid -> nativeint -> int -> unit;
+ release: domid -> unit;
+ resume: domid -> unit;
+ getdomainpath: domid -> string;
+ watch: string -> string -> unit;
+ unwatch: string -> string -> unit;
+}
+
+let get_operations con = {
+ con = con;
+ debug = (fun commands -> Xsraw.debug commands con);
+ directory = (fun path -> Xsraw.directory 0 path con);
+ read = (fun path -> Xsraw.read 0 path con);
+ readv = (fun dir vec -> Xsraw.readv 0 dir vec con);
+ write = (fun path value -> Xsraw.write 0 path value con);
+ writev = (fun dir vec -> Xsraw.writev 0 dir vec con);
+ mkdir = (fun path -> Xsraw.mkdir 0 path con);
+ rm = (fun path -> Xsraw.rm 0 path con);
+ getperms = (fun path -> Xsraw.getperms 0 path con);
+ setperms = (fun path perms -> Xsraw.setperms 0 path perms con);
+ setpermsv = (fun dir vec perms -> Xsraw.setpermsv 0 dir vec perms con);
+ introduce = (fun id mfn port -> Xsraw.introduce id mfn port con);
+ release = (fun id -> Xsraw.release id con);
+ resume = (fun id -> Xsraw.resume id con);
+ getdomainpath = (fun id -> Xsraw.getdomainpath id con);
+ watch = (fun path data -> Xsraw.watch path data con);
+ unwatch = (fun path data -> Xsraw.unwatch path data con);
+}
+
+let transaction xsh = Xst.transaction xsh.con
+
+let has_watchevents xsh = Xsraw.has_watchevents xsh.con
+let get_watchevent xsh = Xsraw.get_watchevent xsh.con
+
+let read_watchevent xsh = Xsraw.read_watchevent xsh.con
+
+let make fd = get_operations (Xsraw.open_fd fd)
+let get_fd xsh = Xb.get_fd xsh.con.Xsraw.xb
+
+exception Timeout
+
+(* Should never be thrown, indicates a bug in the read_watchevent_timetout function *)
+exception Timeout_with_nonempty_queue
+
+(* Just in case we screw up: poll the callback every couple of seconds rather
+ than wait for the whole timeout period *)
+let max_blocking_time = 5. (* seconds *)
+
+let read_watchevent_timeout xsh timeout callback =
+ let start_time = Unix.gettimeofday () in
+ let end_time = start_time +. timeout in
+
+ let left = ref timeout in
+
+ (* Returns true if a watch event in the queue satisfied us *)
+ let process_queued_events () =
+ let success = ref false in
+ while Xsraw.has_watchevents xsh.con && not(!success)
+ do
+ success := callback (Xsraw.get_watchevent xsh.con)
+ done;
+ !success in
+ (* Returns true if a watch event read from the socket satisfied us *)
+ let process_incoming_event () =
+ let fd = get_fd xsh in
+ let r, _, _ = Unix.select [ fd ] [] [] (min max_blocking_time !left) in
+
+ (* If data is available for reading then read it *)
+ if r = []
+ then false (* timeout, either a max_blocking_time or global *)
+ else callback (Xsraw.read_watchevent xsh.con) in
+
+ let success = ref false in
+ while !left > 0. && not(!success)
+ do
+ (* NB the 'callback' might call back into Xs functions
+ and as a side-effect, watches might be queued. Hence
+ we must process the queue on every loop iteration *)
+
+ (* First process all queued watch events *)
+ if not(!success)
+ then success := process_queued_events ();
+ (* Then block for one more watch event *)
+ if not(!success)
+ then success := process_incoming_event ();
+ (* Just in case our callback caused events to be queued
+ and this is our last time round the loop: this prevents
+ us throwing the Timeout_with_nonempty_queue spuriously *)
+ if not(!success)
+ then success := process_queued_events ();
+
+ (* Update the time left *)
+ let current_time = Unix.gettimeofday () in
+ left := end_time -. current_time
+ done;
+ if not(!success) then begin
+ (* Sanity check: it should be impossible for any
+ events to be queued here *)
+ if Xsraw.has_watchevents xsh.con
+ then raise Timeout_with_nonempty_queue
+ else raise Timeout
+ end
+
+
+let monitor_paths xsh l time callback =
+ let unwatch () =
+ List.iter (fun (w,v) -> try xsh.unwatch w v with _ -> ()) l in
+ List.iter (fun (w,v) -> xsh.watch w v) l;
+ begin try
+ read_watchevent_timeout xsh time callback;
+ with
+ exn -> unwatch (); raise exn;
+ end;
+ unwatch ()
+
+let daemon_socket = "/var/run/xenstored/socket"
+
+(** Throws this rather than a miscellaneous Unix.connect failed *)
+exception Failed_to_connect
+
+let daemon_open () =
+ try
+ let sockaddr = Unix.ADDR_UNIX(daemon_socket) in
+ let sock = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
+ Unix.connect sock sockaddr;
+ Unix.set_close_on_exec sock;
+ make sock
+ with _ -> raise Failed_to_connect
+
+let domain_open () =
+ let path = "/proc/xen/xenbus" in
+ let fd = Unix.openfile path [ Unix.O_RDWR ] 0o550 in
+ Unix.set_close_on_exec fd;
+ make fd
+
+let close xsh = Xsraw.close xsh.con
--- /dev/null
+(*
+ * Copyright (c) 2006 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ *
+ * All rights reserved.
+ *)
+
+exception Timeout
+
+(** Throws this rather than a miscellaneous Unix.connect failed *)
+exception Failed_to_connect
+
+(** perms contains 3 things:
+ - owner domid.
+ - other perm: applied to domain that is not owner or in ACL.
+ - ACL: list of per-domain permission
+ *)
+type perms = Xsraw.perms
+
+type domid = int
+type con
+
+type xsh = {
+ con : con;
+ debug: string list -> string;
+ directory : string -> string list;
+ read : string -> string;
+ readv : string -> string list -> string list;
+ write : string -> string -> unit;
+ writev : string -> (string * string) list -> unit;
+ mkdir : string -> unit;
+ rm : string -> unit;
+ getperms : string -> perms;
+ setperms : string -> perms -> unit;
+ setpermsv : string -> string list -> perms -> unit;
+ introduce : domid -> nativeint -> int -> unit;
+ release : domid -> unit;
+ resume : domid -> unit;
+ getdomainpath : domid -> string;
+ watch : string -> string -> unit;
+ unwatch : string -> string -> unit;
+}
+
+(** get operations provide a vector of xenstore function that apply to one
+ connection *)
+val get_operations : con -> xsh
+
+(** create a transaction with a vector of function that can be applied
+ into the transaction. *)
+val transaction : xsh -> (Xst.ops -> 'a) -> 'a
+
+(** watch manipulation on a connection *)
+val has_watchevents : xsh -> bool
+val get_watchevent : xsh -> string * string
+val read_watchevent : xsh -> string * string
+
+(** get_fd return the fd of the connection to be able to select on it.
+ NOTE: it works only for socket-based connection *)
+val get_fd : xsh -> Unix.file_descr
+
+(** wait for watchevent with a timeout. Until the callback return true,
+ every watch during the time specified, will be pass to the callback.
+ NOTE: it works only when use with a socket-based connection *)
+val read_watchevent_timeout : xsh -> float -> (string * string -> bool) -> unit
+
+(** register a set of watches, then wait for watchevent.
+ remove all watches previously set before giving back the hand. *)
+val monitor_paths : xsh
+ -> (string * string) list
+ -> float
+ -> (string * string -> bool)
+ -> unit
+
+(** open a socket-based xenstored connection *)
+val daemon_open : unit -> xsh
+
+(** open a mmap-based xenstored connection *)
+val domain_open : unit -> xsh
+
+(** close any xenstored connection *)
+val close : xsh -> unit
--- /dev/null
+(*
+ * Copyright (c) 2006 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ *
+ * All rights reserved.
+ *)
+exception Partial_not_empty
+exception Unexpected_packet of string
+
+(** Thrown when a path looks invalid e.g. if it contains "//" *)
+exception Invalid_path of string
+
+let unexpected_packet expected received =
+ let s = Printf.sprintf "expecting %s received %s"
+ (Xb.Op.to_string expected)
+ (Xb.Op.to_string received) in
+ raise (Unexpected_packet s)
+
+type con = {
+ xb: Xb.t;
+ watchevents: (string * string) Queue.t;
+}
+
+let close con =
+ Xb.close con.xb
+
+let open_fd fd = {
+ xb = Xb.open_fd fd;
+ watchevents = Queue.create ();
+}
+
+let rec split_string ?limit:(limit=(-1)) c s =
+ let i = try String.index s c with Not_found -> -1 in
+ let nlimit = if limit = -1 || limit = 0 then limit else limit - 1 in
+ if i = -1 || nlimit = 0 then
+ [ s ]
+ else
+ let a = String.sub s 0 i
+ and b = String.sub s (i + 1) (String.length s - i - 1) in
+ a :: (split_string ~limit: nlimit c b)
+
+type perm = PERM_NONE | PERM_READ | PERM_WRITE | PERM_RDWR
+
+type perms = int * perm * (int * perm) list
+
+let string_of_perms perms =
+ let owner, other, acl = perms in
+ let char_of_perm perm =
+ match perm with PERM_NONE -> 'n' | PERM_READ -> 'r'
+ | PERM_WRITE -> 'w' | PERM_RDWR -> 'b' in
+ let string_of_perm (id, perm) = Printf.sprintf "%c%u" (char_of_perm perm) id in
+ String.concat "\000" (List.map string_of_perm ((owner,other) :: acl))
+
+let perms_of_string s =
+ let perm_of_char c =
+ match c with 'n' -> PERM_NONE | 'r' -> PERM_READ
+ | 'w' -> PERM_WRITE | 'b' -> PERM_RDWR
+ | c -> invalid_arg (Printf.sprintf "unknown permission type: %c" c) in
+ let perm_of_string s =
+ if String.length s < 2
+ then invalid_arg (Printf.sprintf "perm of string: length = %d; contents=\"%s\"" (String.length s) s)
+ else
+ begin
+ int_of_string (String.sub s 1 (String.length s - 1)),
+ perm_of_char s.[0]
+ end in
+ let rec split s =
+ try let i = String.index s '\000' in
+ String.sub s 0 i :: split (String.sub s (i + 1) (String.length s - 1 - i))
+ with Not_found -> if s = "" then [] else [ s ] in
+ let l = List.map perm_of_string (split s) in
+ match l with h :: l -> (fst h, snd h, l) | [] -> (0, PERM_NONE, [])
+
+(* send one packet - can sleep *)
+let pkt_send con =
+ if Xb.has_old_output con.xb then
+ raise Partial_not_empty;
+ let workdone = ref false in
+ while not !workdone
+ do
+ workdone := Xb.output con.xb
+ done
+
+(* receive one packet - can sleep *)
+let pkt_recv con =
+ let workdone = ref false in
+ while not !workdone
+ do
+ workdone := Xb.input con.xb
+ done;
+ Xb.get_in_packet con.xb
+
+let pkt_recv_timeout con timeout =
+ let fd = Xb.get_fd con.xb in
+ let r, _, _ = Unix.select [ fd ] [] [] timeout in
+ if r = [] then
+ true, None
+ else (
+ let workdone = Xb.input con.xb in
+ if workdone then
+ false, (Some (Xb.get_in_packet con.xb))
+ else
+ false, None
+ )
+
+let queue_watchevent con data =
+ let ls = split_string ~limit:2 '\000' data in
+ if List.length ls != 2 then
+ raise (Xb.Packet.DataError "arguments number mismatch");
+ let event = List.nth ls 0
+ and event_data = List.nth ls 1 in
+ Queue.push (event, event_data) con.watchevents
+
+let has_watchevents con = Queue.length con.watchevents > 0
+let get_watchevent con = Queue.pop con.watchevents
+
+let read_watchevent con =
+ let pkt = pkt_recv con in
+ match Xb.Packet.get_ty pkt with
+ | Xb.Op.Watchevent ->
+ queue_watchevent con (Xb.Packet.get_data pkt);
+ Queue.pop con.watchevents
+ | ty -> unexpected_packet Xb.Op.Watchevent ty
+
+(* send one packet in the queue, and wait for reply *)
+let rec sync_recv ty con =
+ let pkt = pkt_recv con in
+ match Xb.Packet.get_ty pkt with
+ | Xb.Op.Error -> (
+ match Xb.Packet.get_data pkt with
+ | "ENOENT" -> raise Xb.Noent
+ | "EAGAIN" -> raise Xb.Eagain
+ | "EINVAL" -> raise Xb.Invalid
+ | s -> raise (Xb.Packet.Error s))
+ | Xb.Op.Watchevent ->
+ queue_watchevent con (Xb.Packet.get_data pkt);
+ sync_recv ty con
+ | rty when rty = ty -> Xb.Packet.get_data pkt
+ | rty -> unexpected_packet ty rty
+
+let sync f con =
+ (* queue a query using function f *)
+ f con.xb;
+ if Xb.output_len con.xb = 0 then
+ Printf.printf "output len = 0\n%!";
+ let ty = Xb.Packet.get_ty (Xb.peek_output con.xb) in
+ pkt_send con;
+ sync_recv ty con
+
+let ack s =
+ if s = "OK" then () else raise (Xb.Packet.DataError s)
+
+(** Check paths are suitable for read/write/mkdir/rm/directory etc (NOT watches) *)
+let validate_path path =
+ (* Paths shouldn't have a "//" in the middle *)
+ let bad = "//" in
+ for offset = 0 to String.length path - (String.length bad) do
+ if String.sub path offset (String.length bad) = bad then
+ raise (Invalid_path path)
+ done;
+ (* Paths shouldn't have a "/" at the end, except for the root *)
+ if path <> "/" && path <> "" && path.[String.length path - 1] = '/' then
+ raise (Invalid_path path)
+
+(** Check to see if a path is suitable for watches *)
+let validate_watch_path path =
+ (* Check for stuff like @releaseDomain etc first *)
+ if path <> "" && path.[0] = '@' then ()
+ else validate_path path
+
+let debug command con =
+ sync (Queueop.debug command) con
+
+let directory tid path con =
+ validate_path path;
+ let data = sync (Queueop.directory tid path) con in
+ split_string '\000' data
+
+let read tid path con =
+ validate_path path;
+ sync (Queueop.read tid path) con
+
+let readv tid dir vec con =
+ List.map (fun path -> validate_path path; read tid path con)
+ (if dir <> "" then
+ (List.map (fun v -> dir ^ "/" ^ v) vec) else vec)
+
+let getperms tid path con =
+ validate_path path;
+ perms_of_string (sync (Queueop.getperms tid path) con)
+
+let watch path data con =
+ validate_watch_path path;
+ ack (sync (Queueop.watch path data) con)
+
+let unwatch path data con =
+ validate_watch_path path;
+ ack (sync (Queueop.unwatch path data) con)
+
+let transaction_start con =
+ let data = sync (Queueop.transaction_start) con in
+ try
+ int_of_string data
+ with
+ _ -> raise (Packet.DataError (Printf.sprintf "int expected; got '%s'" data))
+
+let transaction_end tid commit con =
+ try
+ ack (sync (Queueop.transaction_end tid commit) con);
+ true
+ with
+ Xb.Eagain -> false
+
+let introduce domid mfn port con =
+ ack (sync (Queueop.introduce domid mfn port) con)
+
+let release domid con =
+ ack (sync (Queueop.release domid) con)
+
+let resume domid con =
+ ack (sync (Queueop.resume domid) con)
+
+let getdomainpath domid con =
+ sync (Queueop.getdomainpath domid) con
+
+let write tid path value con =
+ validate_path path;
+ ack (sync (Queueop.write tid path value) con)
+
+let writev tid dir vec con =
+ List.iter (fun (entry, value) ->
+ let path = (if dir <> "" then dir ^ "/" ^ entry else entry) in
+ validate_path path;
+ write tid path value con) vec
+
+let mkdir tid path con =
+ validate_path path;
+ ack (sync (Queueop.mkdir tid path) con)
+
+let rm tid path con =
+ validate_path path;
+ try
+ ack (sync (Queueop.rm tid path) con)
+ with
+ Xb.Noent -> ()
+
+let setperms tid path perms con =
+ validate_path path;
+ ack (sync (Queueop.setperms tid path (string_of_perms perms)) con)
+
+let setpermsv tid dir vec perms con =
+ List.iter (fun entry ->
+ let path = (if dir <> "" then dir ^ "/" ^ entry else entry) in
+ validate_path path;
+ setperms tid path perms con) vec
--- /dev/null
+exception Partial_not_empty
+exception Unexpected_packet of string
+exception Invalid_path of string
+val unexpected_packet : Xb.Op.operation -> Xb.Op.operation -> 'a
+type con = { xb : Xb.t; watchevents : (string * string) Queue.t; }
+val close : con -> unit
+val open_fd : Unix.file_descr -> con
+val split_string : ?limit:int -> char -> string -> string list
+type perm = PERM_NONE | PERM_READ | PERM_WRITE | PERM_RDWR
+type perms = int * perm * (int * perm) list
+val string_of_perms : int * perm * (int * perm) list -> string
+val perms_of_string : string -> int * perm * (int * perm) list
+val pkt_send : con -> unit
+val pkt_recv : con -> Xb.Packet.t
+val pkt_recv_timeout : con -> float -> bool * Xb.Packet.t option
+val queue_watchevent : con -> string -> unit
+val has_watchevents : con -> bool
+val get_watchevent : con -> string * string
+val read_watchevent : con -> string * string
+val sync_recv : Xb.Op.operation -> con -> string
+val sync : (Xb.t -> 'a) -> con -> string
+val ack : string -> unit
+val validate_path : string -> unit
+val validate_watch_path : string -> unit
+val directory : int -> string -> con -> string list
+val debug : string list -> con -> string
+val read : int -> string -> con -> string
+val readv : int -> string -> string list -> con -> string list
+val getperms : int -> string -> con -> int * perm * (int * perm) list
+val watch : string -> string -> con -> unit
+val unwatch : string -> string -> con -> unit
+val transaction_start : con -> int
+val transaction_end : int -> bool -> con -> bool
+val introduce : int -> nativeint -> int -> con -> unit
+val release : int -> con -> unit
+val resume : int -> con -> unit
+val getdomainpath : int -> con -> string
+val write : int -> string -> string -> con -> unit
+val writev : int -> string -> (string * string) list -> con -> unit
+val mkdir : int -> string -> con -> unit
+val rm : int -> string -> con -> unit
+val setperms : int -> string -> int * perm * (int * perm) list -> con -> unit
+val setpermsv :
+ int ->
+ string -> string list -> int * perm * (int * perm) list -> con -> unit
--- /dev/null
+(*
+ * Copyright (c) 2006 XenSource Inc.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ *
+ * All rights reserved.
+ *)
+
+type ops =
+{
+ directory: string -> string list;
+ read: string -> string;
+ readv: string -> string list -> string list;
+ write: string -> string -> unit;
+ writev: string -> (string * string) list -> unit;
+ mkdir: string -> unit;
+ rm: string -> unit;
+ getperms: string -> Xsraw.perms;
+ setperms: string -> Xsraw.perms -> unit;
+ setpermsv: string -> string list -> Xsraw.perms -> unit;
+}
+
+let get_operations tid xsh = {
+ directory = (fun path -> Xsraw.directory tid path xsh);
+ read = (fun path -> Xsraw.read tid path xsh);
+ readv = (fun dir vec -> Xsraw.readv tid dir vec xsh);
+ write = (fun path value -> Xsraw.write tid path value xsh);
+ writev = (fun dir vec -> Xsraw.writev tid dir vec xsh);
+ mkdir = (fun path -> Xsraw.mkdir tid path xsh);
+ rm = (fun path -> Xsraw.rm tid path xsh);
+ getperms = (fun path -> Xsraw.getperms tid path xsh);
+ setperms = (fun path perms -> Xsraw.setperms tid path perms xsh);
+ setpermsv = (fun dir vec perms -> Xsraw.setpermsv tid dir vec perms xsh);
+}
+
+let transaction xsh (f: ops -> 'a) : 'a =
+ let commited = ref false and result = ref None in
+ while not !commited
+ do
+ let tid = Xsraw.transaction_start xsh in
+ let t = get_operations tid xsh in
+
+ begin try
+ result := Some (f t)
+ with exn ->
+ ignore (Xsraw.transaction_end tid false xsh);
+ raise exn
+ end;
+ commited := Xsraw.transaction_end tid true xsh
+ done;
+ match !result with
+ | None -> failwith "internal error in transaction"
+ | Some result -> result
--- /dev/null
+type ops = {
+ directory : string -> string list;
+ read : string -> string;
+ readv : string -> string list -> string list;
+ write : string -> string -> unit;
+ writev : string -> (string * string) list -> unit;
+ mkdir : string -> unit;
+ rm : string -> unit;
+ getperms : string -> Xsraw.perms;
+ setperms : string -> Xsraw.perms -> unit;
+ setpermsv : string -> string list -> Xsraw.perms -> unit;
+}
+
+val get_operations : int -> Xsraw.con -> ops
+val transaction : Xsraw.con -> (ops -> 'a) -> 'a
--- /dev/null
+version = "@VERSION@"
+description = "XenStore RPC"
+archive(byte) = "xsrpc.cma"
+archive(native) = "xsrpc.cmxa"
--- /dev/null
+CC = gcc
+CFLAGS = -Wall -fPIC -O2 -I/opt/xensource/lib/ocaml
+OCAMLC = ocamlc -g -I ../xb/ -I ../xs/
+OCAMLOPT = ocamlopt
+
+LDFLAGS = -cclib -L./
+
+DESTDIR ?= /
+VERSION := $(shell hg parents --template "{rev}" 2>/dev/null || echo 0.0)
+OCAMLOPTFLAGS = -g -dtypes -I ../xb/ -I ../xs/
+
+OCAMLABI := $(shell ocamlc -version)
+OCAMLLIBDIR := $(shell ocamlc -where)
+OCAMLDESTDIR ?= $(OCAMLLIBDIR)
+
+OBJS = xsrpc
+INTF = xsrpc.cmi
+LIBS = xsrpc.cma xsrpc.cmxa
+
+all: $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+xsrpc.cmxa: $(foreach obj,$(OBJS),$(obj).cmx)
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -a -o $@ $(foreach obj,$(OBJS),$(obj).cmx)
+
+xsrpc.cma: $(foreach obj,$(OBJS),$(obj).cmo)
+ $(OCAMLC) -a -o $@ $(foreach obj,$(OBJS),$(obj).cmo)
+
+%.cmo: %.ml
+ $(OCAMLC) -c -o $@ $<
+
+%.cmi: %.mli
+ $(OCAMLC) -c -o $@ $<
+
+%.cmx: %.ml
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -c -o $@ $<
+
+%.o: %.c
+ $(CC) $(CFLAGS) -c -o $@ $<
+
+META: META.in
+ sed 's/@VERSION@/$(VERSION)/g' < $< > $@
+
+.PHONY: install
+install: $(LIBS) META
+ ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore xsrpc META $(INTF) $(LIBS) *.a *.cmx
+
+.PHONY: uninstall
+uninstall:
+ ocamlfind remove xsrpc
+
+clean:
+ rm -f *.o *.so *.a *.cmo *.cmi *.cma *.cmx *.cmxa *.annot META $(LIBS) $(PROGRAMS)
+
--- /dev/null
+(*
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ *
+ * Xenstore RPC
+ *)
+
+(*
+ * everything RPC related stuff happens in : /local/domain/<domid>/RPC
+ *
+ * typical layout:
+ * <servicename>/<origin_domid>
+ * query/
+ * <idquery>/
+ * data[0-9]{2} -- contains the actual query splitted in
+ * 512 bytes entries. (max at 99 nodes)
+ * cmd -- the cmd executed
+ * submit -- created with the number of packet to read once
+ * every data has been inserted in xs.
+ * reply/
+ * <idquery>/
+ * data[0-9]{2} -- contains the reply splitted in
+ * 512 bytes entries. (max at 99 nodes)
+ * submit -- just like inside the query node
+ *
+ * a query will be cleaned by the asking side by removing the <idquery>
+ * directory from the query and reply directory.
+ *
+ *)
+
+exception Stop_listen
+exception Timeout
+exception Protocol_error of string
+
+type status = Error | Success
+
+let status_of_string s =
+ match s with "success" -> Success | _ -> Error
+
+let string_of_status s =
+ match s with Success -> "success" | Error -> "error"
+
+type t = {
+ xs: Xs.xsh;
+ rpcpath: string;
+ service: string;
+ dstid: int;
+ mutable id: int;
+}
+
+(* some string utility *)
+let endswith suffix x =
+ let x_l = String.length x and suffix_l = String.length suffix in
+ suffix_l <= x_l && String.sub x (x_l - suffix_l) suffix_l = suffix
+
+let split_size sz s =
+ let len = String.length s in
+ let modsz = if len mod sz = 0 then true else false in
+ let a = Array.make (len / sz + (if modsz then 0 else 1)) "" in
+ for i = 0 to (len / sz)
+ do
+ let chunk = min sz (len - (i * sz)) in
+ if chunk > 0 then
+ a.(i) <- String.sub s (i * sz) chunk
+ done;
+ a
+
+let rec split_string ?limit:(limit=(-1)) c s =
+ let i = try String.index s c with Not_found -> -1 in
+ let nlimit = if limit = -1 || limit = 0 then limit else limit - 1 in
+ if i = -1 || nlimit = 0 then
+ [ s ]
+ else
+ let a = String.sub s 0 i
+ and b = String.sub s (i + 1) (String.length s - i - 1) in
+ a :: (split_string ~limit: nlimit c b)
+
+(** open a RPC channel to @t sending queries, and t replying *)
+let bind dstid service =
+ (* FIXME: only works from dom0 at the moment since domU might not
+ be able to create for sure node in others domain directories.
+ need to create a small thing running in dom0 to grant access
+ to create channel from domU to domU *)
+ let xs = Xs.daemon_open () in
+ let self =
+ try int_of_string (xs.Xs.read "domid")
+ with Xb.Invalid -> 0
+ in
+ let rpcpath = xs.Xs.getdomainpath dstid ^ (Printf.sprintf "/RPC/%s/%d" service self) in
+ xs.Xs.mkdir rpcpath;
+ xs.Xs.setperms rpcpath (self, Xsraw.PERM_RDWR, [ dstid, Xsraw.PERM_RDWR ]);
+ { xs = xs; rpcpath = rpcpath; dstid = dstid; id = 0; service = service }
+
+let query_with_id h id cmd data =
+ let len = String.length data in
+
+ let querypath = Printf.sprintf "%s/query/%s" h.rpcpath id in
+ let replypath = Printf.sprintf "%s/reply/%s" h.rpcpath id in
+
+ let qdatapath i = Printf.sprintf "%s/data%.2d" querypath i in
+ let rdatapath i = Printf.sprintf "%s/data%.2d" replypath i in
+
+ let a = Array.mapi (fun i x -> qdatapath i, x) (split_size 512 data) in
+ Array.iter (fun (path, value) -> h.xs.Xs.write path value) a;
+ h.xs.Xs.write (querypath ^ "/cmd") cmd;
+ h.xs.Xs.write (querypath ^ "/submit") (string_of_int (Array.length a));
+
+ (* now wait for a reply. wrap the xs.timeout in xsrpc.timeout *)
+ let callback (path, _) =
+ if endswith "/submit" path then
+ try ignore (int_of_string (h.xs.Xs.read path)); true with _ -> false
+ else
+ false
+ in
+ begin
+ try Xs.monitor_paths h.xs [ replypath, "rpc-r" ] 120. callback
+ with Xs.Timeout -> raise Timeout
+ end;
+
+ let nbnodes = int_of_string (h.xs.Xs.read (Printf.sprintf "%s/submit" replypath)) in
+ let status = status_of_string (try h.xs.Xs.read (replypath ^ "/status") with _ -> "") in
+ let buf = Buffer.create (nbnodes * 512) in
+ for i = 0 to nbnodes - 1
+ do
+ let data =
+ try h.xs.Xs.read (rdatapath i)
+ with _ -> raise (Protocol_error "datapath missing")
+ in
+ Buffer.add_string buf data
+ done;
+ (* after the query, we try to clean up the tree by removing the query/<id>
+ * and reply/<id> directories *)
+ begin try h.xs.Xs.rm querypath with _ -> (); end;
+ begin try h.xs.Xs.rm replypath with _ -> (); end;
+ (status, Buffer.contents buf)
+
+let query h cmd data =
+ (* send the query *)
+ let id = h.id in
+ h.id <- h.id + 1;
+ query_with_id h (string_of_int id) cmd data
+
+(** until f raise a Stop_listening, carry on with listening new commands *)
+let listen service f =
+ let xs = Xs.daemon_open () in
+ let self =
+ try int_of_string (xs.Xs.read "domid")
+ with Xb.Invalid -> 0
+ in
+ let rpcpath = xs.Xs.getdomainpath self ^ "/RPC/" ^ service in
+ let callback (path, _) =
+ let l = split_string '/' path in
+ begin match l with
+ | "" :: "local" :: "domain" :: domid :: "RPC" :: service :: sdomid :: "query" :: id :: [ "submit" ] -> (
+ let sdomid = int_of_string sdomid in
+ let nbdata = int_of_string (xs.Xs.read path) in
+
+ let querypath = Printf.sprintf "/local/domain/%s/RPC/%s/%d/query/%s"
+ domid service sdomid id in
+ let replypath = Printf.sprintf "/local/domain/%s/RPC/%s/%d/reply/%s"
+ domid service sdomid id in
+ let cmd = try xs.Xs.read (querypath ^ "/cmd") with _ -> "" in
+ let qdatapath i = Printf.sprintf "%s/data%.2d" querypath i in
+ let rdatapath i = Printf.sprintf "%s/data%.2d" replypath i in
+
+ (* read query *)
+ let buf = Buffer.create 1024 in
+ for i = 0 to nbdata - 1
+ do
+ let s = xs.Xs.read (qdatapath i) in
+ Buffer.add_string buf s
+ done;
+ let data = Buffer.contents buf in
+
+ (* start callback with all parameters *)
+ match f sdomid id cmd data with
+ | None -> ()
+ | Some (status, data) ->
+ let a = Array.mapi (fun i x -> rdatapath i, x) (split_size 512 data) in
+ Array.iter (fun (path, value) -> xs.Xs.write path value) a;
+ xs.Xs.write (replypath ^ "/status") (string_of_status status);
+ xs.Xs.write (replypath ^ "/submit") (string_of_int (Array.length a));
+ )
+ | _ ->
+ ()
+ end;
+ false
+ in
+ let quit = ref false in
+ while not !quit
+ do
+ try
+ Xs.monitor_paths xs [ rpcpath, "rpc" ] 3600. callback
+ with
+ | Xs.Timeout -> ()
+ | Stop_listen -> quit := true
+ done;
+ ()
--- /dev/null
+(*
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent@xensource.com>
+ *
+ *)
+
+type t
+
+exception Stop_listen
+exception Timeout
+exception Protocol_error of string
+
+type status = Error | Success
+
+val bind : int -> string -> t
+val query_with_id : t -> string -> string -> string -> (status * string)
+val query : t -> string -> string -> (status * string)
+val listen : string -> (int -> string -> string -> string -> (status * string) option) -> unit
projects / xcp / xen-api-libs.git / commitdiff