* [PATCH 1/6] add ocaml libs (xc/xb/xs/eventchn)
2010-03-01 11:59 [RFC][PATCH 0/6] merge ocaml xenstored and dependencies Vincent Hanquez
@ 2010-03-01 11:59 ` Vincent Hanquez
2010-03-01 11:59 ` [PATCH 2/6] add ocaml xenstored Vincent Hanquez
` (4 subsequent siblings)
5 siblings, 0 replies; 7+ messages in thread
From: Vincent Hanquez @ 2010-03-01 11:59 UTC (permalink / raw)
To: xen-devel; +Cc: Vincent Hanquez
[-- Attachment #1: Type: text/plain, Size: 9732 bytes --]
Signed-off-by: Vincent Hanquez <vincent.hanquez@eu.citrix.com>
---
tools/ocaml/libs/eventchn/META.in | 4 +
tools/ocaml/libs/eventchn/Makefile | 28 +
tools/ocaml/libs/eventchn/eventchn.ml | 27 +
tools/ocaml/libs/eventchn/eventchn.mli | 26 +
tools/ocaml/libs/eventchn/eventchn_stubs.c | 173 ++++
tools/ocaml/libs/log/META.in | 4 +
tools/ocaml/libs/log/Makefile | 43 +
tools/ocaml/libs/log/log.ml | 258 +++++
tools/ocaml/libs/log/log.mli | 55 +
tools/ocaml/libs/log/logs.ml | 197 ++++
tools/ocaml/libs/log/logs.mli | 46 +
tools/ocaml/libs/log/syslog.ml | 26 +
tools/ocaml/libs/log/syslog.mli | 41 +
tools/ocaml/libs/log/syslog_stubs.c | 73 ++
tools/ocaml/libs/mmap/META.in | 4 +
tools/ocaml/libs/mmap/Makefile | 27 +
tools/ocaml/libs/mmap/mmap.ml | 31 +
tools/ocaml/libs/mmap/mmap.mli | 28 +
tools/ocaml/libs/mmap/mmap_stubs.c | 136 +++
tools/ocaml/libs/mmap/mmap_stubs.h | 33 +
tools/ocaml/libs/stdext/META.in | 5 +
tools/ocaml/libs/stdext/Makefile | 43 +
tools/ocaml/libs/stdext/bigbuffer.ml | 90 ++
tools/ocaml/libs/stdext/bigbuffer.mli | 22 +
tools/ocaml/libs/stdext/eventloop.ml | 357 +++++++
tools/ocaml/libs/stdext/eventloop.mli | 100 ++
tools/ocaml/libs/stdext/file.ml | 34 +
tools/ocaml/libs/stdext/file.mli | 18 +
tools/ocaml/libs/stdext/filenameext.ml | 33 +
tools/ocaml/libs/stdext/filenameext.mli | 17 +
tools/ocaml/libs/stdext/hashtblext.ml | 38 +
tools/ocaml/libs/stdext/hashtblext.mli | 77 ++
tools/ocaml/libs/stdext/listext.ml | 27 +
tools/ocaml/libs/stdext/listext.mli | 65 ++
tools/ocaml/libs/stdext/opt.ml | 48 +
tools/ocaml/libs/stdext/opt.mli | 24 +
tools/ocaml/libs/stdext/pervasiveext.ml | 61 ++
tools/ocaml/libs/stdext/pervasiveext.mli | 30 +
tools/ocaml/libs/stdext/qring.ml | 161 +++
tools/ocaml/libs/stdext/qring.mli | 47 +
tools/ocaml/libs/stdext/ring.ml | 109 ++
tools/ocaml/libs/stdext/ring.mli | 30 +
tools/ocaml/libs/stdext/stringext.ml | 206 ++++
tools/ocaml/libs/stdext/stringext.mli | 108 ++
tools/ocaml/libs/stdext/threadext.ml | 212 ++++
tools/ocaml/libs/stdext/threadext.mli | 67 ++
tools/ocaml/libs/stdext/trie.ml | 182 ++++
tools/ocaml/libs/stdext/trie.mli | 60 ++
tools/ocaml/libs/stdext/unixext.ml | 437 ++++++++
tools/ocaml/libs/stdext/unixext.mli | 84 ++
tools/ocaml/libs/stdext/unixext_stubs.c | 304 ++++++
tools/ocaml/libs/stdext/vIO.ml | 250 +++++
tools/ocaml/libs/stdext/vIO.mli | 51 +
tools/ocaml/libs/stdext/varmap.ml | 26 +
tools/ocaml/libs/stdext/varmap.mli | 22 +
tools/ocaml/libs/uuid/META.in | 4 +
tools/ocaml/libs/uuid/Makefile | 26 +
tools/ocaml/libs/uuid/uuid.ml | 88 ++
tools/ocaml/libs/uuid/uuid.mli | 53 +
tools/ocaml/libs/xb/META.in | 4 +
tools/ocaml/libs/xb/Makefile | 41 +
tools/ocaml/libs/xb/op.ml | 84 ++
tools/ocaml/libs/xb/packet.ml | 50 +
tools/ocaml/libs/xb/partial.ml | 44 +
tools/ocaml/libs/xb/xb.ml | 189 ++++
tools/ocaml/libs/xb/xb.mli | 83 ++
tools/ocaml/libs/xb/xb_stubs.c | 74 ++
tools/ocaml/libs/xb/xs_ring.ml | 18 +
tools/ocaml/libs/xb/xs_ring_stubs.c | 117 +++
tools/ocaml/libs/xc/META.in | 4 +
tools/ocaml/libs/xc/Makefile | 28 +
tools/ocaml/libs/xc/xc.h | 191 ++++
tools/ocaml/libs/xc/xc.ml | 340 +++++++
tools/ocaml/libs/xc/xc.mli | 196 ++++
tools/ocaml/libs/xc/xc_cpufeature.h | 116 +++
tools/ocaml/libs/xc/xc_cpuid.h | 285 ++++++
tools/ocaml/libs/xc/xc_e820.h | 20 +
tools/ocaml/libs/xc/xc_lib.c | 1502 ++++++++++++++++++++++++++++
tools/ocaml/libs/xc/xc_stubs.c | 1170 ++++++++++++++++++++++
tools/ocaml/libs/xs/META.in | 4 +
tools/ocaml/libs/xs/Makefile | 42 +
tools/ocaml/libs/xs/queueop.ml | 73 ++
tools/ocaml/libs/xs/xs.ml | 170 ++++
tools/ocaml/libs/xs/xs.mli | 90 ++
tools/ocaml/libs/xs/xsraw.ml | 265 +++++
tools/ocaml/libs/xs/xsraw.mli | 60 ++
tools/ocaml/libs/xs/xst.ml | 61 ++
tools/ocaml/libs/xs/xst.mli | 30 +
88 files changed, 10227 insertions(+), 0 deletions(-)
create mode 100644 tools/ocaml/libs/eventchn/META.in
create mode 100644 tools/ocaml/libs/eventchn/Makefile
create mode 100644 tools/ocaml/libs/eventchn/eventchn.ml
create mode 100644 tools/ocaml/libs/eventchn/eventchn.mli
create mode 100644 tools/ocaml/libs/eventchn/eventchn_stubs.c
create mode 100644 tools/ocaml/libs/log/META.in
create mode 100644 tools/ocaml/libs/log/Makefile
create mode 100644 tools/ocaml/libs/log/log.ml
create mode 100644 tools/ocaml/libs/log/log.mli
create mode 100644 tools/ocaml/libs/log/logs.ml
create mode 100644 tools/ocaml/libs/log/logs.mli
create mode 100644 tools/ocaml/libs/log/syslog.ml
create mode 100644 tools/ocaml/libs/log/syslog.mli
create mode 100644 tools/ocaml/libs/log/syslog_stubs.c
create mode 100644 tools/ocaml/libs/mmap/META.in
create mode 100644 tools/ocaml/libs/mmap/Makefile
create mode 100644 tools/ocaml/libs/mmap/mmap.ml
create mode 100644 tools/ocaml/libs/mmap/mmap.mli
create mode 100644 tools/ocaml/libs/mmap/mmap_stubs.c
create mode 100644 tools/ocaml/libs/mmap/mmap_stubs.h
create mode 100644 tools/ocaml/libs/stdext/META.in
create mode 100644 tools/ocaml/libs/stdext/Makefile
create mode 100644 tools/ocaml/libs/stdext/bigbuffer.ml
create mode 100644 tools/ocaml/libs/stdext/bigbuffer.mli
create mode 100644 tools/ocaml/libs/stdext/eventloop.ml
create mode 100644 tools/ocaml/libs/stdext/eventloop.mli
create mode 100644 tools/ocaml/libs/stdext/file.ml
create mode 100644 tools/ocaml/libs/stdext/file.mli
create mode 100644 tools/ocaml/libs/stdext/filenameext.ml
create mode 100644 tools/ocaml/libs/stdext/filenameext.mli
create mode 100644 tools/ocaml/libs/stdext/hashtblext.ml
create mode 100644 tools/ocaml/libs/stdext/hashtblext.mli
create mode 100644 tools/ocaml/libs/stdext/listext.ml
create mode 100644 tools/ocaml/libs/stdext/listext.mli
create mode 100644 tools/ocaml/libs/stdext/opt.ml
create mode 100644 tools/ocaml/libs/stdext/opt.mli
create mode 100644 tools/ocaml/libs/stdext/pervasiveext.ml
create mode 100644 tools/ocaml/libs/stdext/pervasiveext.mli
create mode 100644 tools/ocaml/libs/stdext/qring.ml
create mode 100644 tools/ocaml/libs/stdext/qring.mli
create mode 100644 tools/ocaml/libs/stdext/ring.ml
create mode 100644 tools/ocaml/libs/stdext/ring.mli
create mode 100644 tools/ocaml/libs/stdext/stringext.ml
create mode 100644 tools/ocaml/libs/stdext/stringext.mli
create mode 100644 tools/ocaml/libs/stdext/threadext.ml
create mode 100644 tools/ocaml/libs/stdext/threadext.mli
create mode 100644 tools/ocaml/libs/stdext/trie.ml
create mode 100644 tools/ocaml/libs/stdext/trie.mli
create mode 100644 tools/ocaml/libs/stdext/unixext.ml
create mode 100644 tools/ocaml/libs/stdext/unixext.mli
create mode 100644 tools/ocaml/libs/stdext/unixext_stubs.c
create mode 100644 tools/ocaml/libs/stdext/vIO.ml
create mode 100644 tools/ocaml/libs/stdext/vIO.mli
create mode 100644 tools/ocaml/libs/stdext/varmap.ml
create mode 100644 tools/ocaml/libs/stdext/varmap.mli
create mode 100644 tools/ocaml/libs/uuid/META.in
create mode 100644 tools/ocaml/libs/uuid/Makefile
create mode 100644 tools/ocaml/libs/uuid/uuid.ml
create mode 100644 tools/ocaml/libs/uuid/uuid.mli
create mode 100644 tools/ocaml/libs/xb/META.in
create mode 100644 tools/ocaml/libs/xb/Makefile
create mode 100644 tools/ocaml/libs/xb/op.ml
create mode 100644 tools/ocaml/libs/xb/packet.ml
create mode 100644 tools/ocaml/libs/xb/partial.ml
create mode 100644 tools/ocaml/libs/xb/xb.ml
create mode 100644 tools/ocaml/libs/xb/xb.mli
create mode 100644 tools/ocaml/libs/xb/xb_stubs.c
create mode 100644 tools/ocaml/libs/xb/xs_ring.ml
create mode 100644 tools/ocaml/libs/xb/xs_ring_stubs.c
create mode 100644 tools/ocaml/libs/xc/META.in
create mode 100644 tools/ocaml/libs/xc/Makefile
create mode 100644 tools/ocaml/libs/xc/xc.h
create mode 100644 tools/ocaml/libs/xc/xc.ml
create mode 100644 tools/ocaml/libs/xc/xc.mli
create mode 100644 tools/ocaml/libs/xc/xc_cpufeature.h
create mode 100644 tools/ocaml/libs/xc/xc_cpuid.h
create mode 100644 tools/ocaml/libs/xc/xc_e820.h
create mode 100644 tools/ocaml/libs/xc/xc_lib.c
create mode 100644 tools/ocaml/libs/xc/xc_stubs.c
create mode 100644 tools/ocaml/libs/xs/META.in
create mode 100644 tools/ocaml/libs/xs/Makefile
create mode 100644 tools/ocaml/libs/xs/queueop.ml
create mode 100644 tools/ocaml/libs/xs/xs.ml
create mode 100644 tools/ocaml/libs/xs/xs.mli
create mode 100644 tools/ocaml/libs/xs/xsraw.ml
create mode 100644 tools/ocaml/libs/xs/xsraw.mli
create mode 100644 tools/ocaml/libs/xs/xst.ml
create mode 100644 tools/ocaml/libs/xs/xst.mli
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-add-ocaml-libs-xc-xb-xs-eventchn.patch --]
[-- Type: text/x-patch; name="0001-add-ocaml-libs-xc-xb-xs-eventchn.patch", Size: 346290 bytes --]
diff --git a/tools/ocaml/libs/eventchn/META.in b/tools/ocaml/libs/eventchn/META.in
new file mode 100644
index 0000000..f3e01aa
--- /dev/null
+++ b/tools/ocaml/libs/eventchn/META.in
@@ -0,0 +1,4 @@
+version = "@VERSION@"
+description = "Eventchn interface extension"
+archive(byte) = "eventchn.cma"
+archive(native) = "eventchn.cmxa"
diff --git a/tools/ocaml/libs/eventchn/Makefile b/tools/ocaml/libs/eventchn/Makefile
new file mode 100644
index 0000000..9d6ef31
--- /dev/null
+++ b/tools/ocaml/libs/eventchn/Makefile
@@ -0,0 +1,28 @@
+TOPLEVEL=../..
+include $(TOPLEVEL)/common.make
+
+OBJS = eventchn
+INTF = $(foreach obj, $(OBJS),$(obj).cmi)
+LIBS = eventchn.cma eventchn.cmxa
+
+all: $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+eventchn_OBJS = $(OBJS)
+eventchn_C_OBJS = eventchn_stubs
+
+OCAML_LIBRARY = eventchn
+
+.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
+
+include $(TOPLEVEL)/Makefile.rules
+
diff --git a/tools/ocaml/libs/eventchn/eventchn.ml b/tools/ocaml/libs/eventchn/eventchn.ml
new file mode 100644
index 0000000..c4a7fa3
--- /dev/null
+++ b/tools/ocaml/libs/eventchn/eventchn.ml
@@ -0,0 +1,27 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+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")
diff --git a/tools/ocaml/libs/eventchn/eventchn.mli b/tools/ocaml/libs/eventchn/eventchn.mli
new file mode 100644
index 0000000..7088700
--- /dev/null
+++ b/tools/ocaml/libs/eventchn/eventchn.mli
@@ -0,0 +1,26 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+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"
diff --git a/tools/ocaml/libs/eventchn/eventchn_stubs.c b/tools/ocaml/libs/eventchn/eventchn_stubs.c
new file mode 100644
index 0000000..ab61b0a
--- /dev/null
+++ b/tools/ocaml/libs/eventchn/eventchn_stubs.c
@@ -0,0 +1,173 @@
+/*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ */
+
+#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"
+
+static int eventchn_major = 10;
+static int eventchn_minor = 61;
+
+static int do_ioctl(int handle, int cmd, void *arg)
+{
+ return ioctl(handle, cmd, arg);
+}
+
+static int do_read_port(int handle, evtchn_port_t *port)
+{
+ return (read(handle, port, sizeof(evtchn_port_t)) != sizeof(evtchn_port_t));
+}
+
+static int do_write_port(int handle, evtchn_port_t port)
+{
+ return (write(handle, &port, sizeof(evtchn_port_t)) != sizeof(evtchn_port_t));
+}
+
+int eventchn_do_open(void)
+{
+ int fd;
+
+ fd = open(EVENTCHN_PATH, O_RDWR);
+ if (fd == -1 && errno == ENOENT) {
+ mkdir("/dev/xen", 0640);
+ mknod(EVENTCHN_PATH, S_IFCHR | 0640, makedev(eventchn_major, eventchn_minor));
+ 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);
+}
diff --git a/tools/ocaml/libs/log/META.in b/tools/ocaml/libs/log/META.in
new file mode 100644
index 0000000..5c3646a
--- /dev/null
+++ b/tools/ocaml/libs/log/META.in
@@ -0,0 +1,4 @@
+version = "@VERSION@"
+description = "Log - logging library"
+archive(byte) = "log.cma"
+archive(native) = "log.cmxa"
diff --git a/tools/ocaml/libs/log/Makefile b/tools/ocaml/libs/log/Makefile
new file mode 100644
index 0000000..d16f72a
--- /dev/null
+++ b/tools/ocaml/libs/log/Makefile
@@ -0,0 +1,43 @@
+TOPLEVEL=../..
+include $(TOPLEVEL)/common.make
+
+OCAMLINCLUDE += -I ../stdext
+
+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)
+ $(call mk-caml-lib-native, $@, -cclib -lsyslog_stubs, $(foreach obj,$(OBJS),$(obj).cmx))
+
+log.cma: $(foreach obj,$(OBJS),$(obj).cmo)
+ $(call mk-caml-lib-bytecode, $@, -dllib dllsyslog_stubs.so -cclib -lsyslog_stubs, $(foreach obj,$(OBJS),$(obj).cmo))
+
+syslog_stubs.a: syslog_stubs.o
+ $(call mk-caml-stubs, $@, $+)
+
+libsyslog_stubs.a: syslog_stubs.o
+ $(call mk-caml-lib-stubs, $@, $+)
+
+logs.mli : logs.ml
+ $(OCAMLC) -i $(OCAMLCFLAGS) $< > $@
+
+syslog.mli : syslog.ml
+ $(OCAMLC) -i $< > $@
+
+.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
+
+include $(TOPLEVEL)/Makefile.rules
+
diff --git a/tools/ocaml/libs/log/log.ml b/tools/ocaml/libs/log/log.ml
new file mode 100644
index 0000000..4f42759
--- /dev/null
+++ b/tools/ocaml/libs/log/log.ml
@@ -0,0 +1,258 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+open Printf
+
+exception Unknown_level of string
+
+type stream_type = Stderr | Stdout | File of string
+
+type stream_log = {
+ ty : stream_type;
+ channel : out_channel option ref;
+}
+
+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; }
+
+(** 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 -> (
+ 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 -> (
+ 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 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%s|%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
+ try
+ fprintf stream "%s\n%!" string
+ with _ -> () (* Trap exception when we fail to write log *)
+ 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 -> (
+ 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
diff --git a/tools/ocaml/libs/log/log.mli b/tools/ocaml/libs/log/log.mli
new file mode 100644
index 0000000..36c5a6b
--- /dev/null
+++ b/tools/ocaml/libs/log/log.mli
@@ -0,0 +1,55 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+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;
+}
+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 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
diff --git a/tools/ocaml/libs/log/logs.ml b/tools/ocaml/libs/log/logs.ml
new file mode 100644
index 0000000..2a40896
--- /dev/null
+++ b/tools/ocaml/libs/log/logs.ml
@@ -0,0 +1,197 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+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
diff --git a/tools/ocaml/libs/log/logs.mli b/tools/ocaml/libs/log/logs.mli
new file mode 100644
index 0000000..76e10db
--- /dev/null
+++ b/tools/ocaml/libs/log/logs.mli
@@ -0,0 +1,46 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+type keylogger = {
+ mutable debug : string list;
+ mutable info : string list;
+ mutable warn : string list;
+ mutable error : string list;
+ no_default : bool;
+}
+val __all_loggers : (string, Log.t) Hashtbl.t
+val __default_logger : keylogger
+val __log_mapping : (string, keylogger) Hashtbl.t
+val get_or_open : string -> Log.t
+val add : string -> string list -> unit
+val get_by_level : keylogger -> Log.level -> string list
+val set_by_level : keylogger -> Log.level -> string list -> unit
+val set : string -> Log.level -> string list -> unit
+val set_default : Log.level -> string list -> unit
+val append : string -> Log.level -> string -> unit
+val append_default : Log.level -> string -> unit
+val reopen : unit -> unit
+val reclaim : unit -> unit
+val clear : string -> Log.level -> unit
+val clear_default : Log.level -> unit
+val reset_all : string list -> unit
+val log :
+ string ->
+ Log.level -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a
+val debug : string -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a
+val info : string -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a
+val warn : string -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a
+val error : string -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a
diff --git a/tools/ocaml/libs/log/syslog.ml b/tools/ocaml/libs/log/syslog.ml
new file mode 100644
index 0000000..2b417da
--- /dev/null
+++ b/tools/ocaml/libs/log/syslog.ml
@@ -0,0 +1,26 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+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"
diff --git a/tools/ocaml/libs/log/syslog.mli b/tools/ocaml/libs/log/syslog.mli
new file mode 100644
index 0000000..425f42a
--- /dev/null
+++ b/tools/ocaml/libs/log/syslog.mli
@@ -0,0 +1,41 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+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 log : facility -> level -> string -> unit = "stub_syslog"
+external close : unit -> unit = "stub_closelog"
diff --git a/tools/ocaml/libs/log/syslog_stubs.c b/tools/ocaml/libs/log/syslog_stubs.c
new file mode 100644
index 0000000..965610a
--- /dev/null
+++ b/tools/ocaml/libs/log/syslog_stubs.c
@@ -0,0 +1,73 @@
+/*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ */
+
+#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);
+}
diff --git a/tools/ocaml/libs/mmap/META.in b/tools/ocaml/libs/mmap/META.in
new file mode 100644
index 0000000..1d71548
--- /dev/null
+++ b/tools/ocaml/libs/mmap/META.in
@@ -0,0 +1,4 @@
+version = "@VERSION@"
+description = "Mmap interface extension"
+archive(byte) = "mmap.cma"
+archive(native) = "mmap.cmxa"
diff --git a/tools/ocaml/libs/mmap/Makefile b/tools/ocaml/libs/mmap/Makefile
new file mode 100644
index 0000000..bd8ab43
--- /dev/null
+++ b/tools/ocaml/libs/mmap/Makefile
@@ -0,0 +1,27 @@
+TOPLEVEL=../..
+include $(TOPLEVEL)/common.make
+
+OBJS = mmap
+INTF = $(foreach obj, $(OBJS),$(obj).cmi)
+LIBS = mmap.cma mmap.cmxa
+
+all: $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+mmap_OBJS = $(OBJS)
+mmap_C_OBJS = mmap_stubs
+OCAML_LIBRARY = mmap
+
+.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
+
+include $(TOPLEVEL)/Makefile.rules
+
diff --git a/tools/ocaml/libs/mmap/mmap.ml b/tools/ocaml/libs/mmap/mmap.ml
new file mode 100644
index 0000000..44b67c8
--- /dev/null
+++ b/tools/ocaml/libs/mmap/mmap.ml
@@ -0,0 +1,31 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+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"
diff --git a/tools/ocaml/libs/mmap/mmap.mli b/tools/ocaml/libs/mmap/mmap.mli
new file mode 100644
index 0000000..8f92ed6
--- /dev/null
+++ b/tools/ocaml/libs/mmap/mmap.mli
@@ -0,0 +1,28 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+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"
diff --git a/tools/ocaml/libs/mmap/mmap_stubs.c b/tools/ocaml/libs/mmap/mmap_stubs.c
new file mode 100644
index 0000000..e32cef6
--- /dev/null
+++ b/tools/ocaml/libs/mmap/mmap_stubs.c
@@ -0,0 +1,136 @@
+/*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ */
+
+#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);
+}
diff --git a/tools/ocaml/libs/mmap/mmap_stubs.h b/tools/ocaml/libs/mmap/mmap_stubs.h
new file mode 100644
index 0000000..65e4239
--- /dev/null
+++ b/tools/ocaml/libs/mmap/mmap_stubs.h
@@ -0,0 +1,33 @@
+/*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ */
+
+#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
diff --git a/tools/ocaml/libs/stdext/META.in b/tools/ocaml/libs/stdext/META.in
new file mode 100644
index 0000000..bc67d1e
--- /dev/null
+++ b/tools/ocaml/libs/stdext/META.in
@@ -0,0 +1,5 @@
+version = "@VERSION@"
+description = "Stdext - Common stdlib extensions"
+requires = "unix,uuid"
+archive(byte) = "stdext.cma"
+archive(native) = "stdext.cmxa"
diff --git a/tools/ocaml/libs/stdext/Makefile b/tools/ocaml/libs/stdext/Makefile
new file mode 100644
index 0000000..7c51c71
--- /dev/null
+++ b/tools/ocaml/libs/stdext/Makefile
@@ -0,0 +1,43 @@
+TOPLEVEL=../..
+include $(TOPLEVEL)/common.make
+
+OCAMLINCLUDE += -I ../uuid
+
+OCAML_TEST_INC = -I $(shell ocamlfind query oUnit)
+OCAML_TEST_LIB = $(shell ocamlfind query oUnit)/oUnit.cmxa
+
+OBJS = filenameext stringext hashtblext listext pervasiveext threadext ring qring trie opt unixext bigbuffer vIO varmap eventloop
+INTF = $(foreach obj, $(OBJS),$(obj).cmi)
+LIBS = stdext.cma stdext.cmxa
+
+all: $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+stdext_OBJS = $(OBJS)
+stdext_C_OBJS = unixext_stubs
+
+OCAML_LIBRARY = stdext
+
+## OBJS
+threadext.cmo: threadext.ml
+ $(call quiet-command, $(OCAMLC) $(OCAMLCFLAGS) -thread -c -o $@ $<,MLC,$@)
+
+threadext.cmi: threadext.mli
+ $(call quiet-command, $(OCAMLC) $(OCAMLCFLAGS) -thread -c -o $@ $<,MLI,$@)
+
+threadext.cmx: threadext.ml
+ $(call quiet-command, $(OCAMLOPT) $(OCAMLOPTFLAGS) -thread -c -o $@ $<,MLOPT,$@)
+
+.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
+
+include $(TOPLEVEL)/Makefile.rules
+
diff --git a/tools/ocaml/libs/stdext/bigbuffer.ml b/tools/ocaml/libs/stdext/bigbuffer.ml
new file mode 100644
index 0000000..b2ac54b
--- /dev/null
+++ b/tools/ocaml/libs/stdext/bigbuffer.ml
@@ -0,0 +1,90 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+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)
diff --git a/tools/ocaml/libs/stdext/bigbuffer.mli b/tools/ocaml/libs/stdext/bigbuffer.mli
new file mode 100644
index 0000000..f40fd09
--- /dev/null
+++ b/tools/ocaml/libs/stdext/bigbuffer.mli
@@ -0,0 +1,22 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+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
diff --git a/tools/ocaml/libs/stdext/eventloop.ml b/tools/ocaml/libs/stdext/eventloop.ml
new file mode 100644
index 0000000..8d69a4c
--- /dev/null
+++ b/tools/ocaml/libs/stdext/eventloop.ml
@@ -0,0 +1,357 @@
+(*
+ * Copyright (C) 2009 Citrix Ltd.
+ * Author Prashanth Mundkur <firstname.lastname@citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+let verbose = ref false
+
+let dbg fmt =
+ let logger s = if !verbose then Printf.printf "%s\n%!" s in
+ Printf.ksprintf logger fmt
+
+module ConnMap = Map.Make (struct type t = Unix.file_descr let compare = compare end)
+
+(* A module that supports finding a timer by handle as well as by expiry time. *)
+module Timers = struct
+
+ type 'a entry =
+ {
+ handle : int;
+ mutable expires_at: float;
+ value: 'a;
+ }
+
+ module Timers_by_expiry = Map.Make (struct type t = float let compare = compare end)
+
+ type 'a t =
+ {
+ mutable by_expiry: (('a entry) list) Timers_by_expiry.t;
+ }
+
+ let create () = { by_expiry = Timers_by_expiry.empty }
+
+ let is_empty t = Timers_by_expiry.is_empty t.by_expiry
+
+ let next_handle = ref 0
+
+ (** inserts an existing (but not inserted) entry in the map *)
+ let submit_timer t at e =
+ e.expires_at <- at;
+ let es = try Timers_by_expiry.find e.expires_at t.by_expiry with Not_found -> [] in
+ t.by_expiry <- Timers_by_expiry.add e.expires_at (e :: es) t.by_expiry
+
+ let add_timer t at v =
+ incr next_handle;
+ let e = { handle = !next_handle; expires_at = at; value = v } in
+ submit_timer t at e;
+ e
+
+ let remove_timer t entry =
+ let handle = entry.handle in
+ let es = Timers_by_expiry.find entry.expires_at t.by_expiry in
+ let es = List.filter (fun e' -> e'.handle <> handle) es in
+ t.by_expiry <- (match es with
+ | [] -> Timers_by_expiry.remove entry.expires_at t.by_expiry
+ | _ -> Timers_by_expiry.add entry.expires_at es t.by_expiry
+ )
+
+ exception Found of float
+
+ (* Should only be called on a non-empty Timer set; otherwise,
+ Not_found is raised. *)
+ let get_first_expiry_time t =
+ try
+ (* This should give the earliest expiry time,
+ since iteration is done in increasing order. *)
+ Timers_by_expiry.iter (fun tim -> raise (Found tim)) t.by_expiry;
+ raise Not_found
+ with Found tim -> tim
+
+ (* Extracts the timers for time t, and return a list of values for those timers *)
+ let extract_timers_at t tim =
+ try
+ let es = Timers_by_expiry.find tim t.by_expiry in
+ t.by_expiry <- Timers_by_expiry.remove tim t.by_expiry;
+ List.map (fun e -> e.value) es
+ with Not_found -> []
+
+end
+
+type error = Unix.error * string * string
+
+type handle = Unix.file_descr
+
+let handle_compare = compare
+let handle_hash h = Unixext.int_of_file_descr h
+
+type conn_status =
+ | Connecting
+ | Listening
+ | Connected
+
+type conn_callbacks =
+{
+ accept_callback : t -> handle -> Unix.file_descr -> Unix.sockaddr -> unit;
+ connect_callback : t -> handle -> unit;
+ error_callback : t -> handle -> error -> unit;
+ recv_ready_callback : t -> handle -> Unix.file_descr -> unit;
+ send_ready_callback : t -> handle -> Unix.file_descr -> unit;
+}
+
+and conn_state =
+{
+ mutable callbacks : conn_callbacks;
+ mutable status : conn_status;
+ mutable send_enabled : bool;
+ mutable recv_enabled : bool;
+}
+
+and t =
+{
+ mutable conns: conn_state ConnMap.t;
+ mutable timers: (unit -> unit) Timers.t;
+ (* select state *)
+ readers: Unixext.Fdset.t;
+ writers: Unixext.Fdset.t;
+ excepts: Unixext.Fdset.t;
+ (* dispatch state *)
+ mutable d_readers: Unixext.Fdset.t;
+ mutable d_writers: Unixext.Fdset.t;
+ (** Unix.gettimeofday() at the time the loop iteration started *)
+ mutable current_time: float;
+}
+
+let create () =
+{ conns = ConnMap.empty;
+ timers = Timers.create ();
+ readers = Unixext.Fdset.create ();
+ writers = Unixext.Fdset.create ();
+ excepts = Unixext.Fdset.create ();
+ d_readers = Unixext.Fdset.create ();
+ d_writers = Unixext.Fdset.create ();
+ current_time = 0.0;
+}
+
+(* connections *)
+
+let register_conn t fd ?(enable_send=false) ?(enable_recv=true) callbacks =
+ let conn_state = { callbacks = callbacks;
+ status = Connected;
+ send_enabled = enable_send;
+ recv_enabled = enable_recv;
+ }
+ in
+ t.conns <- ConnMap.add fd conn_state t.conns;
+ Unix.set_nonblock fd;
+ if conn_state.recv_enabled then
+ Unixext.Fdset.set t.readers fd;
+ if conn_state.send_enabled then
+ Unixext.Fdset.set t.writers fd;
+ fd
+
+let remove_conn t handle =
+ Unixext.Fdset.clear t.readers handle;
+ Unixext.Fdset.clear t.writers handle;
+ (* Also remove this handle from the set we might be
+ dispatching over. *)
+ Unixext.Fdset.clear t.d_readers handle;
+ Unixext.Fdset.clear t.d_writers handle;
+ t.conns <- ConnMap.remove handle t.conns
+
+let get_fd t handle = handle
+
+let connect t handle addr =
+ let conn_state = ConnMap.find handle t.conns in
+ conn_state.status <- Connecting;
+ try
+ Unix.connect handle addr;
+ conn_state.status <- Connected;
+ conn_state.callbacks.connect_callback t handle
+ with
+ | Unix.Unix_error (Unix.EINPROGRESS, _, _) ->
+ Unixext.Fdset.set t.readers handle;
+ Unixext.Fdset.set t.writers handle
+ | Unix.Unix_error (ec, f, s) ->
+ conn_state.callbacks.error_callback t handle (ec, f, s)
+
+let listen t handle =
+ let conn_state = ConnMap.find handle t.conns in
+ Unix.listen handle 5;
+ Unixext.Fdset.set t.readers handle;
+ conn_state.recv_enabled <- true;
+ conn_state.status <- Listening
+
+let enable_send t handle =
+ let conn_state = ConnMap.find handle t.conns in
+ conn_state.send_enabled <- true;
+ if conn_state.status = Connected then
+ Unixext.Fdset.set t.writers handle
+
+let disable_send t handle =
+ let conn_state = ConnMap.find handle t.conns in
+ conn_state.send_enabled <- false;
+ if conn_state.status = Connected then
+ Unixext.Fdset.clear t.writers handle
+
+let enable_recv t handle =
+ let conn_state = ConnMap.find handle t.conns in
+ conn_state.recv_enabled <- true;
+ if conn_state.status = Connected then
+ Unixext.Fdset.set t.readers handle
+
+let disable_recv t handle =
+ let conn_state = ConnMap.find handle t.conns in
+ conn_state.recv_enabled <- false;
+ if conn_state.status = Connected then
+ Unixext.Fdset.clear t.readers handle
+
+let set_callbacks t handle callbacks =
+ let conn_state = ConnMap.find handle t.conns in
+ conn_state.callbacks <- callbacks
+
+let has_connections t = not (ConnMap.is_empty t.conns)
+
+(* timers *)
+
+type timer = (unit -> unit) Timers.entry
+
+let start_timer t time_offset_sec cb =
+ let at = Unix.gettimeofday () +. time_offset_sec in
+ Timers.add_timer t.timers at cb
+
+let start_timer_asap t cb =
+ Timers.add_timer t.timers t.current_time cb
+
+let start_periodic_timer t time_offset_sec period cb =
+ let orig_timer = ref (None: timer option) in
+ let resubmit_timer_closure () =
+ let orig_timer = match !orig_timer with None -> raise Not_found | Some x -> x in
+ Timers.submit_timer t.timers (t.current_time +. period) orig_timer;
+ cb (); (* invoke the user's callback *)
+ in
+ let new_timer = start_timer t time_offset_sec resubmit_timer_closure in
+ orig_timer := Some (new_timer);
+ new_timer
+
+let cancel_timer t timer =
+ Timers.remove_timer t.timers timer
+
+let timer_compare tim1 tim2 = compare tim1.Timers.handle tim2.Timers.handle
+let timer_hash tim = tim.Timers.handle
+
+let has_timers t = not (Timers.is_empty t.timers)
+
+(* event dispatch *)
+
+let dispatch_read t fd cs =
+ match cs.status with
+ | Connecting ->
+ (match Unix.getsockopt_error fd with
+ | None ->
+ cs.status <- Connected;
+ if not cs.recv_enabled then
+ Unixext.Fdset.clear t.readers fd;
+ if not cs.send_enabled then
+ Unixext.Fdset.clear t.writers fd;
+ cs.callbacks.connect_callback t fd
+ | Some err ->
+ cs.callbacks.error_callback t fd (err, "connect", "")
+ )
+ | Listening ->
+ (try
+ let afd, aaddr = Unix.accept fd in
+ cs.callbacks.accept_callback t fd afd aaddr
+ with
+ | Unix.Unix_error (Unix.EWOULDBLOCK, _, _)
+ | Unix.Unix_error (Unix.ECONNABORTED, _, _)
+ | Unix.Unix_error (Unix.EINTR, _, _)
+ -> ()
+ | Unix.Unix_error (ec, f, s) ->
+ cs.callbacks.error_callback t fd (ec, f, s)
+ )
+ | Connected ->
+ if cs.recv_enabled
+ then cs.callbacks.recv_ready_callback t fd fd
+ else Unixext.Fdset.clear t.readers fd
+
+let dispatch_write t fd cs =
+ match cs.status with
+ | Connecting ->
+ (match Unix.getsockopt_error fd with
+ | None ->
+ cs.status <- Connected;
+ if not cs.recv_enabled then
+ Unixext.Fdset.clear t.readers fd;
+ if not cs.send_enabled then
+ Unixext.Fdset.clear t.writers fd;
+ cs.callbacks.connect_callback t fd
+ | Some err ->
+ cs.callbacks.error_callback t fd (err, "connect", "")
+ )
+ | Listening ->
+ (* This should never happen, since listening sockets
+ are not set for writing. But, to avoid a busy
+ select loop in case this socket keeps firing for
+ writes, we disable the write watch. *)
+ Unixext.Fdset.clear t.writers fd
+ | Connected ->
+ if cs.send_enabled
+ then cs.callbacks.send_ready_callback t fd fd
+ else Unixext.Fdset.clear t.writers fd
+
+let dispatch_timers t =
+ let break = ref false in
+ while ((not (Timers.is_empty t.timers)) && (not !break)) do
+ let first_expired = Timers.get_first_expiry_time t.timers in
+ if first_expired > t.current_time then
+ break := true
+ else begin
+ let cbs = Timers.extract_timers_at t.timers first_expired in
+ List.iter (fun cb -> cb ()) cbs
+ end
+ done
+
+let dispatch t interval =
+ t.current_time <- Unix.gettimeofday ();
+ let interval =
+ if Timers.is_empty t.timers then interval
+ else
+ (* the blocking interval for select is the
+ smaller of the specified interval, and the
+ interval before which the earliest timer
+ expires.
+ *)
+ let block_until = if interval > 0.0 then t.current_time +. interval else t.current_time in
+ let first_expiry = Timers.get_first_expiry_time t.timers in
+ let block_until = (if first_expiry < block_until then first_expiry else block_until) in
+ let interval = block_until -. t.current_time in
+ if interval < 0.0 then 0.0 else interval
+ in
+ let events =
+ try Some (Unixext.Fdset.select t.readers t.writers t.excepts interval)
+ with Unix.Unix_error (Unix.EINTR, _, _) -> None
+ in
+ (match events with
+ | Some (r, w, _) ->
+ (* Store dispatch set for remove_conn. *)
+ t.d_readers <- r;
+ t.d_writers <- w;
+ ConnMap.iter (fun fd cs ->
+ if Unixext.Fdset.is_set t.d_readers fd then
+ dispatch_read t fd cs;
+ if Unixext.Fdset.is_set t.d_writers fd then
+ dispatch_write t fd cs
+ ) t.conns
+ | None -> ()
+ );
+ dispatch_timers t
diff --git a/tools/ocaml/libs/stdext/eventloop.mli b/tools/ocaml/libs/stdext/eventloop.mli
new file mode 100644
index 0000000..6e57991
--- /dev/null
+++ b/tools/ocaml/libs/stdext/eventloop.mli
@@ -0,0 +1,100 @@
+(*
+ * Copyright (C) 2009 Citrix Ltd.
+ * Author Prashanth Mundkur <firstname.lastname@citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+
+type t
+
+val create : unit -> t
+
+(* connections *)
+
+type handle
+type error = Unix.error * string * string
+
+type conn_callbacks =
+{
+ accept_callback : t -> handle -> Unix.file_descr -> Unix.sockaddr -> unit;
+ connect_callback : t -> handle -> unit;
+ error_callback : t -> handle -> error -> unit;
+ recv_ready_callback : t -> handle -> Unix.file_descr -> unit;
+ send_ready_callback : t -> handle -> Unix.file_descr -> unit;
+}
+
+(* this is to allow collections indexed by connection handles. *)
+val handle_compare : handle -> handle -> int
+val handle_hash : handle -> int
+
+(* Connection Management *)
+
+(* by default, notifications for incoming data are disabled, and enabled for all others. *)
+val register_conn : t -> Unix.file_descr -> ?enable_send:bool -> ?enable_recv:bool -> conn_callbacks -> handle
+val remove_conn : t -> handle -> unit
+val get_fd : t -> handle -> Unix.file_descr
+
+val connect : t -> handle -> Unix.sockaddr -> unit
+val listen : t -> handle -> unit
+
+val enable_send : t -> handle -> unit
+val disable_send : t -> handle -> unit
+
+val enable_recv : t -> handle -> unit
+val disable_recv : t -> handle -> unit
+
+val set_callbacks : t -> handle -> conn_callbacks -> unit
+
+(* Timers *)
+
+type timer
+
+(** Starts a timer that will fire once only, and return a handle to
+ this timer, so that it can be cancelled before it fires. The timer
+ is automatically cancelled once it has fired.
+*)
+val start_timer : t -> float (* offset, secs *) -> (unit -> unit) -> timer
+
+(** Enqueues an event that will be invoked in the next event loop
+ iteration. This behaves as if a timer had been set to fire with
+ "now" as the trigger time.
+*)
+val start_timer_asap : t -> (unit -> unit) -> timer
+
+(** Starts a timer that will fire periodically. The timer needs
+ explicit cancellation.
+*)
+val start_periodic_timer: t -> float (* offset from current time, secs *) -> float (* period, secs *) -> (unit -> unit) -> timer
+
+(** Allows cancelling a timer before it fires. Non-periodic timers
+ are implicitly cancelled when their timer fires. Periodic timers
+ however need explicit cancellation.
+*)
+val cancel_timer : t -> timer -> unit
+
+(** Utilities for storing timer handles in data structures. *)
+val timer_compare: timer -> timer -> int
+val timer_hash: timer -> int
+
+(* Event Dispatch *)
+
+(* dispatch t intvl will block at most for intvl seconds, and dispatch
+ any retrieved events and expired timers.
+*)
+val dispatch : t -> float -> unit
+
+
+(* Event loop management *)
+
+val has_timers : t -> bool
+
+val has_connections : t -> bool
diff --git a/tools/ocaml/libs/stdext/file.ml b/tools/ocaml/libs/stdext/file.ml
new file mode 100644
index 0000000..1b6b42d
--- /dev/null
+++ b/tools/ocaml/libs/stdext/file.ml
@@ -0,0 +1,34 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * Author Dave Scott <dave.scott@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+let write_string file mode s =
+ let fn_write_string fd = Unixext.really_write fd s 0 (String.length s) in
+ Unixext.with_file file (Unix.O_WRONLY :: mode) 0o640 fn_write_string
+
+let write_fn file mode fn =
+ let fn_write_fn fd =
+ let quit = ref false in
+ while not !quit
+ do
+ let s = fn () in
+ if s = "" then
+ quit := true
+ else
+ Unixext.really_write fd s 0 (String.length s)
+ done
+ in
+ Unixext.with_file file (Unix.O_WRONLY :: mode) 0o640 fn_write_fn
diff --git a/tools/ocaml/libs/stdext/file.mli b/tools/ocaml/libs/stdext/file.mli
new file mode 100644
index 0000000..d3f50e7
--- /dev/null
+++ b/tools/ocaml/libs/stdext/file.mli
@@ -0,0 +1,18 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * Author Dave Scott <dave.scott@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+val write_string : string -> Unix.open_flag list -> string -> unit
+val write_fn : string -> Unix.open_flag list -> (unit -> string) -> unit
diff --git a/tools/ocaml/libs/stdext/filenameext.ml b/tools/ocaml/libs/stdext/filenameext.ml
new file mode 100644
index 0000000..8e4379a
--- /dev/null
+++ b/tools/ocaml/libs/stdext/filenameext.ml
@@ -0,0 +1,33 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * Author Dave Scott <dave.scott@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+(** 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 ()
+
+
+
diff --git a/tools/ocaml/libs/stdext/filenameext.mli b/tools/ocaml/libs/stdext/filenameext.mli
new file mode 100644
index 0000000..db4d76e
--- /dev/null
+++ b/tools/ocaml/libs/stdext/filenameext.mli
@@ -0,0 +1,17 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * Author Dave Scott <dave.scott@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+val temp_file_in_dir : string -> string
diff --git a/tools/ocaml/libs/stdext/hashtblext.ml b/tools/ocaml/libs/stdext/hashtblext.ml
new file mode 100644
index 0000000..de0f2ce
--- /dev/null
+++ b/tools/ocaml/libs/stdext/hashtblext.ml
@@ -0,0 +1,38 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+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
diff --git a/tools/ocaml/libs/stdext/hashtblext.mli b/tools/ocaml/libs/stdext/hashtblext.mli
new file mode 100644
index 0000000..a117146
--- /dev/null
+++ b/tools/ocaml/libs/stdext/hashtblext.mli
@@ -0,0 +1,77 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+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
diff --git a/tools/ocaml/libs/stdext/listext.ml b/tools/ocaml/libs/stdext/listext.ml
new file mode 100644
index 0000000..3825add
--- /dev/null
+++ b/tools/ocaml/libs/stdext/listext.ml
@@ -0,0 +1,27 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * Author Dave Scott <dave.scott@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+module List = struct include List
+
+let iteri f l =
+ let i = ref 0 in
+ List.iter (fun x -> f !i x; incr i) l
+
+let mapi f l =
+ let i = ref 0 in
+ List.map (fun x -> let r = f !i x in incr i; r) l
+
+end
diff --git a/tools/ocaml/libs/stdext/listext.mli b/tools/ocaml/libs/stdext/listext.mli
new file mode 100644
index 0000000..c0dfe6d
--- /dev/null
+++ b/tools/ocaml/libs/stdext/listext.mli
@@ -0,0 +1,65 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * Author Dave Scott <dave.scott@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+module List :
+ sig
+ 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
+
+ val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list
+ val iteri : (int -> 'a -> unit) -> 'a list -> unit
+
+ end
diff --git a/tools/ocaml/libs/stdext/opt.ml b/tools/ocaml/libs/stdext/opt.ml
new file mode 100644
index 0000000..bb41672
--- /dev/null
+++ b/tools/ocaml/libs/stdext/opt.ml
@@ -0,0 +1,48 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * Author Dave Scott <dave.scott@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+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
diff --git a/tools/ocaml/libs/stdext/opt.mli b/tools/ocaml/libs/stdext/opt.mli
new file mode 100644
index 0000000..92b476b
--- /dev/null
+++ b/tools/ocaml/libs/stdext/opt.mli
@@ -0,0 +1,24 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * Author Dave Scott <dave.scott@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+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
diff --git a/tools/ocaml/libs/stdext/pervasiveext.ml b/tools/ocaml/libs/stdext/pervasiveext.ml
new file mode 100644
index 0000000..8621c82
--- /dev/null
+++ b/tools/ocaml/libs/stdext/pervasiveext.ml
@@ -0,0 +1,61 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * Author Dave Scott <dave.scott@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+(** 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
+
+type ('a, 'b) either = Right of 'a | Left of 'b
+
+(** if v is not none, apply f on it and return some value else return none. *)
+let may f v =
+ match v with Some x -> Some (f x) | None -> None
+
+(** default value to d if v is none. *)
+let default d v =
+ match v with Some x -> x | None -> d
+
+(** apply f on v if not none *)
+let maybe f v =
+ match v with None -> () | Some x -> f x
+
+(** 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 ()
diff --git a/tools/ocaml/libs/stdext/pervasiveext.mli b/tools/ocaml/libs/stdext/pervasiveext.mli
new file mode 100644
index 0000000..0d53745
--- /dev/null
+++ b/tools/ocaml/libs/stdext/pervasiveext.mli
@@ -0,0 +1,30 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * Author Dave Scott <dave.scott@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+type ('a, 'b) either = Right of 'a | Left of 'b
+val exnhook : (exn -> unit) option ref
+val finally : (unit -> 'a) -> (unit -> 'b) -> 'a
+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
diff --git a/tools/ocaml/libs/stdext/qring.ml b/tools/ocaml/libs/stdext/qring.ml
new file mode 100644
index 0000000..859b63b
--- /dev/null
+++ b/tools/ocaml/libs/stdext/qring.ml
@@ -0,0 +1,161 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+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_internal ring out offset sz =
+ if ring.pwrap then (
+ let left_end = ring.sz - ring.cons in
+ if sz > left_end then (
+ String.blit ring.data ring.cons out offset left_end;
+ String.blit ring.data 0 out (offset + left_end) (sz - left_end);
+ ) else
+ String.blit ring.data ring.cons out offset sz;
+ ) else
+ String.blit ring.data ring.cons out offset sz;
+ adv_cons ring sz;
+ ()
+
+let consume_length_max ring sz =
+ let max = to_consume ring in
+ if sz > 0 then
+ if sz > max then max else sz
+ else
+ if max + sz > 0 then max + sz else 0
+
+let consume_to ring s offset sz =
+ let sz = consume_length_max ring sz in
+ consume_internal ring s offset sz;
+ sz
+
+let consume ring sz =
+ let sz = consume_length_max ring sz in
+ let out = String.create sz in
+ consume_internal ring out 0 sz;
+ out
+
+let consume_offset ring i =
+ if i >= ring.cons then
+ consume ring (i - ring.cons)
+ else
+ consume ring (ring.sz - ring.cons + i)
+
+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 ring data offset len =
+ 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 offset ring.data ring.prod firstblitsz;
+ String.blit data (offset + firstblitsz) ring.data 0 (len - firstblitsz);
+ ) else
+ String.blit data offset ring.data ring.prod len;
+ adv_prod ring len;
+ ()
+
+let feed_data ring data =
+ feed ring data 0 (String.length data)
+
+(* 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
diff --git a/tools/ocaml/libs/stdext/qring.mli b/tools/ocaml/libs/stdext/qring.mli
new file mode 100644
index 0000000..9b7f184
--- /dev/null
+++ b/tools/ocaml/libs/stdext/qring.mli
@@ -0,0 +1,47 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+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_to : t -> string -> int -> int -> int
+val consume : t -> int -> string
+val consume_offset : t -> int -> string
+val consume_all : t -> string
+val skip : t -> int -> unit
+
+val feed : t -> string -> int -> 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
diff --git a/tools/ocaml/libs/stdext/ring.ml b/tools/ocaml/libs/stdext/ring.ml
new file mode 100644
index 0000000..4372e22
--- /dev/null
+++ b/tools/ocaml/libs/stdext/ring.ml
@@ -0,0 +1,109 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+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, starting at the top *)
+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)
+
+(** get list of latest #nb value, starting at the top *)
+let get_nb_lst ring nb =
+ if nb > ring.size then
+ raise (Invalid_argument "get_nb_lst: nb");
+ let l = ref [] in
+ for i = nb - 1 downto 0
+ do
+ l := peek ring i :: !l
+ done;
+ !l
+
+(** get array of latest #nb value, ending at the top *)
+let get_nb_rev ring nb =
+ if nb > ring.size then
+ raise (Invalid_argument "get_nb_rev: nb");
+ let a = Array.create nb (top ring) in
+ for i = 1 to nb - 1
+ do
+ (* FIXME: OPTIMIZE ME with 2 Array.blit *)
+ a.(nb - 1 - i) <- peek ring i
+ done;
+ a
+
+(** get list of latest #nb value, ending at the top *)
+let get_nb_rev_lst ring nb =
+ if nb > ring.size then
+ raise (Invalid_argument "get_nb_rev_lst: nb");
+ let l = ref [] in
+ for i = 0 to nb - 1
+ do
+ l := peek ring i :: !l
+ done;
+ !l
+
diff --git a/tools/ocaml/libs/stdext/ring.mli b/tools/ocaml/libs/stdext/ring.mli
new file mode 100644
index 0000000..183de02
--- /dev/null
+++ b/tools/ocaml/libs/stdext/ring.mli
@@ -0,0 +1,30 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * Author Dave Scott <dave.scott@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+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_nb_lst : 'a t -> int -> 'a list
+val get : 'a t -> 'a array
+val get_nb_rev : 'a t -> int -> 'a array
+val get_nb_rev_lst : 'a t -> int -> 'a list
diff --git a/tools/ocaml/libs/stdext/stringext.ml b/tools/ocaml/libs/stdext/stringext.ml
new file mode 100644
index 0000000..e705be3
--- /dev/null
+++ b/tools/ocaml/libs/stdext/stringext.ml
@@ -0,0 +1,206 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * Author Dave Scott <dave.scott@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+module String = struct include String
+
+let of_char c = String.make 1 c
+
+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 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 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 left s n =
+ let l = String.length s in
+ let n = min n l in
+ String.sub s 0 n
+
+let right s n =
+ let l = String.length s in
+ let p = max 0 (l - n) in
+ String.sub s p (l - p)
+end
diff --git a/tools/ocaml/libs/stdext/stringext.mli b/tools/ocaml/libs/stdext/stringext.mli
new file mode 100644
index 0000000..4383fd5
--- /dev/null
+++ b/tools/ocaml/libs/stdext/stringext.mli
@@ -0,0 +1,108 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * Author Dave Scott <dave.scott@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+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
+
+ (** Iterate over the characters with the character index in argument *)
+ val iteri : (int -> char -> 'a) -> string -> unit
+
+ val fold_right : (char -> 'a -> 'a) -> string -> 'a -> 'a
+ val fold_left : ('a -> char -> 'a) -> 'a -> string -> '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
+
+ (** 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
+
+ (** get beginning portion of string *)
+ val left : string -> int -> string
+
+ (** get end portion of string *)
+ val right : string -> int -> string
+ end
diff --git a/tools/ocaml/libs/stdext/threadext.ml b/tools/ocaml/libs/stdext/threadext.ml
new file mode 100644
index 0000000..5e96600
--- /dev/null
+++ b/tools/ocaml/libs/stdext/threadext.ml
@@ -0,0 +1,212 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * Author Anil Madhavapeddy <anil.madhavapeddy@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+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
+
+module Condition = struct
+ include Condition
+ external timedwait : Condition.t -> Mutex.t -> float -> bool = "caml_condition_timedwait"
+end
+
+module TMutex = struct
+
+exception Timeout
+
+type t = { mutex: Mutex.t; mutable time: float; post_locking: unit -> float }
+
+let init ?(post=(fun () -> 0.)) () = { mutex = Mutex.create (); time = 0.; post_locking = post }
+
+let lock ?(retry=0) ?(delay=0.05) t =
+ if retry > 0 then (
+ let left = ref retry in
+ let locked = ref false in
+ while not !locked && !left > 0
+ do
+ locked := Mutex.try_lock t.mutex;
+ if not !locked then (
+ decr left;
+ Thread.delay delay;
+ )
+ done;
+ if not !locked then
+ raise Timeout
+ ) else (
+ Mutex.lock t.mutex;
+ );
+ try t.time <- t.post_locking () with _ -> ();
+ ()
+
+let unlock t =
+ t.time <- 0.;
+ Mutex.unlock t.mutex
+
+let execute ?retry ?delay t f =
+ lock ?retry ?delay t;
+ let r = begin try f () with exn -> unlock t; raise exn end; in
+ unlock t;
+ 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
diff --git a/tools/ocaml/libs/stdext/threadext.mli b/tools/ocaml/libs/stdext/threadext.mli
new file mode 100644
index 0000000..d25c795
--- /dev/null
+++ b/tools/ocaml/libs/stdext/threadext.mli
@@ -0,0 +1,67 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * Author Anil Madhavapeddy <anil.madhavapeddy@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+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 Condition :
+ sig
+ type t = Condition.t
+ val create : unit -> t
+ val signal : t -> unit
+ val broadcast: t -> unit
+ val wait : t -> Mutex.t -> unit
+ val timedwait : t -> Mutex.t -> float -> bool
+ end
+
+module TMutex : sig
+ exception Timeout
+ type t
+ val init : ?post:(unit -> float) -> unit -> t
+ val lock : ?retry:int -> ?delay:float -> t -> unit
+ val unlock : t -> unit
+ val execute : ?retry:int -> ?delay:float -> 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
diff --git a/tools/ocaml/libs/stdext/trie.ml b/tools/ocaml/libs/stdext/trie.ml
new file mode 100644
index 0000000..bc9a903
--- /dev/null
+++ b/tools/ocaml/libs/stdext/trie.ml
@@ -0,0 +1,182 @@
+(*
+ * Copyright (C) 2008-2009 Citrix Ltd.
+ * Author Thomas Gazagnaire <thomas.gazagnaire@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+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
+
diff --git a/tools/ocaml/libs/stdext/trie.mli b/tools/ocaml/libs/stdext/trie.mli
new file mode 100644
index 0000000..25db9d0
--- /dev/null
+++ b/tools/ocaml/libs/stdext/trie.mli
@@ -0,0 +1,60 @@
+(*
+ * Copyright (C) 2008-2009 Citrix Ltd.
+ * Author Thomas Gazagnaire <thomas.gazagnaire@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+(** 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. *)
diff --git a/tools/ocaml/libs/stdext/unixext.ml b/tools/ocaml/libs/stdext/unixext.ml
new file mode 100644
index 0000000..c34b274
--- /dev/null
+++ b/tools/ocaml/libs/stdext/unixext.ml
@@ -0,0 +1,437 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * Author Dave Scott <dave.scott@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+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)
+
+(** Atomically write a string to a file *)
+let write_string_to_file fname s =
+ 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
+ Pervasiveext.finally
+ (fun () ->
+ let len = String.length s in
+ let written = Unix.write fd s 0 len in
+ if written <> len then (failwith "Short write occured!"))
+ (fun () -> Unix.close fd);
+ Unix.rename tmp fname)
+ (fun () -> unlink_safe tmp)
+
+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;
+ let wnum = Unix.write ofd buffer 0 num in
+ total_bytes := Int64.add !total_bytes num64;
+ finished := wnum = 0 || !limit = Some 0L;
+ done;
+ !total_bytes
+
+(** 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_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
+
+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))
+
+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"
+
+external get_major_minor : string -> int * int = "stub_unixext_get_major_minor"
+
+module Fdset = struct
+ type t
+ external of_list : Unix.file_descr list -> t = "stub_fdset_of_list"
+ let create () = of_list []
+ external is_set : t -> Unix.file_descr -> bool = "stub_fdset_is_set"
+ 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"
+ let select r w e t = _select r w e t
+ let select_ro r t = _select_ro r t
+end
+
+let _ = Callback.register_exception "unixext.unix_error" (Unix_error (0))
diff --git a/tools/ocaml/libs/stdext/unixext.mli b/tools/ocaml/libs/stdext/unixext.mli
new file mode 100644
index 0000000..b6dc96f
--- /dev/null
+++ b/tools/ocaml/libs/stdext/unixext.mli
@@ -0,0 +1,84 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ * Author Dave Scott <dave.scott@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+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 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
+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_write : Unix.file_descr -> string -> int -> int -> unit
+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
+
+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
+val get_major_minor : string -> int * int
+
+module Fdset : sig
+ type t
+ val create : unit -> 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 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
+end
diff --git a/tools/ocaml/libs/stdext/unixext_stubs.c b/tools/ocaml/libs/stdext/unixext_stubs.c
new file mode 100644
index 0000000..cbe1519
--- /dev/null
+++ b/tools/ocaml/libs/stdext/unixext_stubs.c
@@ -0,0 +1,304 @@
+#include <sys/types.h>
+#include <sys/stat.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 <pthread.h> /* needed for caml_condition_timedwait */
+
+#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);
+ int cfd;
+
+ cfd = Int_val(fd);
+ FD_SET(cfd, FDSET_OF_VALUE(set));
+ if (cfd > MAXFD_OF_VALUE(set))
+ MAXFD_OF_VALUE(set) = cfd;
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_fdset_clear(value set, value fd)
+{
+ CAMLparam2(set, fd);
+ int cfd, d;
+
+ cfd = Int_val(fd);
+ FD_CLR(cfd, FDSET_OF_VALUE(set));
+ if (cfd == MAXFD_OF_VALUE(set)) {
+ for (d = cfd - 1; d >= 0; d--) {
+ if (FD_ISSET(d, FDSET_OF_VALUE(set))) {
+ MAXFD_OF_VALUE(set) = d;
+ break;
+ }
+ }
+ if (d < 0)
+ MAXFD_OF_VALUE(set) = -1;
+ }
+ CAMLreturn(Val_unit);
+}
+
+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));
+ MAXFD_OF_VALUE(nrset) = MAXFD_OF_VALUE(rset);
+ MAXFD_OF_VALUE(nwset) = MAXFD_OF_VALUE(wset);
+ MAXFD_OF_VALUE(neset) = MAXFD_OF_VALUE(eset);
+
+ 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);
+}
+
+value stub_unixext_get_major_minor(value dpath)
+{
+ CAMLparam1(dpath);
+ CAMLlocal1(majmin);
+ struct stat statbuf;
+ unsigned major, minor;
+ int ret;
+
+ ret = stat(String_val(dpath), &statbuf);
+ if (ret == -1)
+ caml_failwith("cannot stat path");
+
+ major = (statbuf.st_rdev & 0xfff00) >> 8;
+ minor = (statbuf.st_rdev & 0xff) | ((statbuf.st_rdev >> 12) & 0xfff00);
+
+ majmin = caml_alloc_tuple(2);
+ Store_field(majmin, 0, Val_int(major));
+ Store_field(majmin, 1, Val_int(minor));
+ CAMLreturn(majmin);
+}
+
+// from otherlibs/systhreads/posix.c
+#define Condition_val(v) (* ((pthread_cond_t **) Data_custom_val(v)))
+#define Mutex_val(v) (* ((pthread_mutex_t **) Data_custom_val(v)))
+
+static void caml_pthread_check(int retcode, char *msg)
+{
+ char * err;
+ int errlen, msglen;
+ value str;
+
+ if (retcode == 0) return;
+ err = strerror(retcode);
+ msglen = strlen(msg);
+ errlen = strlen(err);
+ str = alloc_string(msglen + 2 + errlen);
+ memmove (&Byte(str, 0), msg, msglen);
+ memmove (&Byte(str, msglen), ": ", 2);
+ memmove (&Byte(str, msglen + 2), err, errlen);
+ raise_sys_error(str);
+}
+
+// from http://caml.inria.fr/mantis/view.php?id=4104
+CAMLprim value caml_condition_timedwait(value v_cnd, value v_mtx, value v_timeo)
+{
+ CAMLparam2(v_cnd, v_mtx);
+ int ret;
+ pthread_cond_t *cnd = Condition_val(v_cnd);
+ pthread_mutex_t *mtx = Mutex_val(v_mtx);
+ double timeo = Double_val(v_timeo);
+ struct timespec ts;
+
+ ts.tv_sec = timeo;
+ ts.tv_nsec = (timeo - ts.tv_sec) * 1e9;
+ enter_blocking_section();
+ ret = pthread_cond_timedwait(cnd, mtx, &ts);
+ leave_blocking_section();
+ if (ret == ETIMEDOUT) CAMLreturn(Val_false);
+ caml_pthread_check(ret, "Condition.timedwait");
+ CAMLreturn(Val_true);
+}
diff --git a/tools/ocaml/libs/stdext/vIO.ml b/tools/ocaml/libs/stdext/vIO.ml
new file mode 100644
index 0000000..4f6450a
--- /dev/null
+++ b/tools/ocaml/libs/stdext/vIO.ml
@@ -0,0 +1,250 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008-2009 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+type backend = {
+ blksize: int;
+ read: string -> int -> int -> int;
+ write: string -> int -> int -> int;
+ flush: unit -> unit;
+ close: unit -> unit;
+ selectable: Unix.file_descr option;
+}
+
+type cache = {
+ read_cache_size: int;
+ write_cache_size: int;
+ read_ring: Qring.t;
+ write_ring: Qring.t;
+}
+
+type t = { backend: backend; mutable cache: cache; mutable reached_eof: bool }
+
+exception Cache_not_empty
+exception Invalid_cache_size
+
+let check_cache_size sz =
+ if sz < 0 || sz > 1024 * 1024 then
+ raise Invalid_cache_size
+
+let make rcache wcache backend =
+ check_cache_size rcache;
+ check_cache_size wcache;
+ let cache = {
+ read_cache_size = rcache;
+ write_cache_size = wcache;
+ read_ring = Qring.make rcache;
+ write_ring = Qring.make wcache;
+ } in
+ { backend = backend; cache = cache; reached_eof = false }
+
+let set_read_cache con sz =
+ check_cache_size sz;
+ if Qring.to_consume con.cache.read_ring > 0 then
+ raise Cache_not_empty;
+ con.cache <- {
+ con.cache with read_cache_size = sz; read_ring = Qring.make sz
+ }
+
+let set_write_cache con sz =
+ check_cache_size sz;
+ if Qring.to_consume con.cache.write_ring > 0 then
+ raise Cache_not_empty;
+ con.cache <- {
+ con.cache with write_cache_size = sz; write_ring = Qring.make sz
+ }
+
+let get_fd con =
+ match con.backend.selectable with
+ | None -> assert false
+ | Some fd -> fd
+
+let read_fill_cache con =
+ if con.reached_eof then
+ 0
+ else
+ let tofill = Qring.to_fill con.cache.read_ring in
+ let toread = min con.backend.blksize tofill in
+ let s = String.create toread in
+ let readed = con.backend.read s 0 toread in
+ if readed = 0 then
+ con.reached_eof <- true
+ else
+ Qring.feed con.cache.read_ring s 0 readed;
+ readed
+
+let has_read_cache con =
+ Qring.to_consume con.cache.read_ring > 0
+
+exception Internal_cache_error
+
+let read_once_nocache con buf index hint =
+ con.backend.read buf index hint
+
+let read_once_cache con buf index hint =
+ let cached = Qring.to_consume con.cache.read_ring in
+ if cached >= hint then (
+ let rhint = Qring.consume_to con.cache.read_ring buf index hint in
+ if rhint < hint then
+ raise Internal_cache_error;
+ hint
+ ) else (
+ if cached > 0 then (
+ let rcached = Qring.consume_to con.cache.read_ring buf index cached in
+ if rcached < cached then
+ raise Internal_cache_error;
+ ()
+ );
+ let readed = read_fill_cache con in
+ if readed > 0 then (
+ let left = hint - cached in
+ let len = if readed > left then left else readed in
+ let rlen = Qring.consume_to con.cache.read_ring buf (index + cached) len in
+ if rlen < len then
+ raise Internal_cache_error;
+ ()
+ );
+ min (readed + cached) hint
+ )
+
+let read_once con =
+ (if con.cache.read_cache_size = 0 then read_once_nocache else read_once_cache) con
+
+let write_flush_cache con =
+ let buf = Qring.consume_all con.cache.write_ring in
+ let len = String.length buf in
+ if len > 0 then (
+ let written = con.backend.write buf 0 len in
+ if written = 0 then
+ 0
+ else if written = len then
+ Qring.to_fill con.cache.write_ring
+ else ( (* 0 < written < len *)
+ let to_put_back = len - written in
+ Qring.feed con.cache.write_ring buf written to_put_back;
+ Qring.to_fill con.cache.write_ring
+ )
+ ) else
+ 0
+
+let write_once_nocache con buf index hint =
+ con.backend.write buf index hint
+
+let write_once_cache con buf index hint =
+ let can_cache = Qring.to_fill con.cache.write_ring in
+ (* the cache is full, flush it, and fill the cache with the buf as much as we can *)
+ if can_cache = 0 then (
+ let to_fill = write_flush_cache con in
+ if to_fill > 0 then (
+ let len = min hint can_cache in
+ Qring.feed con.cache.write_ring buf index len;
+ len
+ ) else
+ 0
+ (* the cache is empty *)
+ ) else if can_cache = con.cache.write_cache_size then (
+ (* check if we have enough to send a full buf without copying to the cache *)
+ if can_cache <= hint then (
+ let written = con.backend.write buf index hint in
+ written
+ ) else (
+ Qring.feed con.cache.write_ring buf index hint;
+ hint
+ )
+ (* the cache contains something, try filling it *)
+ ) else (
+ (* the cache will be full *)
+ if can_cache <= hint then (
+ Qring.feed con.cache.write_ring buf index can_cache;
+ let to_fill = write_flush_cache con in
+ ignore to_fill;
+ can_cache
+ ) else (
+ Qring.feed con.cache.write_ring buf index hint;
+ hint
+ )
+ )
+
+let write_once con =
+ (if con.cache.write_cache_size = 0 then write_once_nocache else write_once_cache) con
+
+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 read con buf index size =
+ do_rw_io (read_once con) buf index size
+
+exception Line_limit_reached
+exception Buffer_limit_reached
+exception Eof_reached
+
+let read_line con max =
+ let buffer = Buffer.create 80 in
+ let s = String.create 1 in
+ let found = ref false and i = ref 0 in
+ while not !found && (max = 0 || !i < max)
+ do
+ let n = read_once con s 0 1 in
+ if n = 0 then
+ raise Eof_reached;
+
+ if s.[0] = '\n' then
+ found := true
+ else (
+ i := !i + n;
+ Buffer.add_string buffer s;
+ )
+ done;
+ if !i = max then
+ raise Line_limit_reached;
+ Buffer.contents buffer
+
+let readf_eof con f max =
+ let end_of_file = ref false in
+ let acc = ref 0 in
+ let s = String.create 1024 in
+ while not !end_of_file
+ do
+ let ret = read_once con s 0 1024 in
+ if ret = 0 then
+ end_of_file := true
+ else (
+ acc := !acc + ret;
+ if max > 0 && !acc > max then
+ raise Buffer_limit_reached;
+ f s 0 ret
+ )
+ done
+
+
+let write con buf index size =
+ do_rw_io (write_once con) buf index size
+
+let flush con = while write_flush_cache con > 0 do () done
+
+let close con = con.backend.close ()
diff --git a/tools/ocaml/libs/stdext/vIO.mli b/tools/ocaml/libs/stdext/vIO.mli
new file mode 100644
index 0000000..6f05c97
--- /dev/null
+++ b/tools/ocaml/libs/stdext/vIO.mli
@@ -0,0 +1,51 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008-2009 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+type backend = {
+ blksize: int;
+ read: string -> int -> int -> int;
+ write: string -> int -> int -> int;
+ flush: unit -> unit;
+ close: unit -> unit;
+ selectable: Unix.file_descr option;
+}
+
+exception Line_limit_reached
+exception Eof_reached
+exception Invalid_cache_size
+
+type t
+
+val make : int -> int -> backend -> t
+
+val set_read_cache : t -> int -> unit
+val set_write_cache : t -> int -> unit
+
+val has_read_cache : t -> bool
+
+val get_fd : t -> Unix.file_descr
+
+val read_once : t -> string -> int -> int -> int
+val write_once : t -> string -> int -> int -> int
+
+val read : t -> string -> int -> int -> int
+val write : t -> string -> int -> int -> int
+
+val read_line : t -> int -> string
+val readf_eof : t -> (string -> int -> int -> unit) -> int -> unit
+
+val flush : t -> unit
+val close : t -> unit
diff --git a/tools/ocaml/libs/stdext/varmap.ml b/tools/ocaml/libs/stdext/varmap.ml
new file mode 100644
index 0000000..3704305
--- /dev/null
+++ b/tools/ocaml/libs/stdext/varmap.ml
@@ -0,0 +1,26 @@
+(*
+ * Copyright (C) 2009 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+exception Failed_assoc of string
+exception Failed_revassoc
+
+type 'a table = (string * 'a) list
+
+let assoc (table: 'a table) x =
+ try snd (List.find (fun (a, b) -> x = a) table)
+ with Not_found -> raise (Failed_assoc x)
+
+let rev_assoc (table: 'a table) y =
+ try fst (List.find (fun (a, b) -> y = b) table)
+ with Not_found -> raise Failed_revassoc
diff --git a/tools/ocaml/libs/stdext/varmap.mli b/tools/ocaml/libs/stdext/varmap.mli
new file mode 100644
index 0000000..8ce5ebf
--- /dev/null
+++ b/tools/ocaml/libs/stdext/varmap.mli
@@ -0,0 +1,22 @@
+(*
+ * Copyright (C) 2009 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+exception Failed_assoc of string
+exception Failed_revassoc
+
+type 'a table = (string * 'a) list
+
+val assoc : 'a table -> string -> 'a
+val rev_assoc : 'a table -> 'a -> string
diff --git a/tools/ocaml/libs/uuid/META.in b/tools/ocaml/libs/uuid/META.in
new file mode 100644
index 0000000..f33c980
--- /dev/null
+++ b/tools/ocaml/libs/uuid/META.in
@@ -0,0 +1,4 @@
+version = "@VERSION@"
+description = "Uuid - universal identifer"
+archive(byte) = "uuid.cma"
+archive(native) = "uuid.cmxa"
diff --git a/tools/ocaml/libs/uuid/Makefile b/tools/ocaml/libs/uuid/Makefile
new file mode 100644
index 0000000..8ddb0e2
--- /dev/null
+++ b/tools/ocaml/libs/uuid/Makefile
@@ -0,0 +1,26 @@
+TOPLEVEL=../..
+include $(TOPLEVEL)/common.make
+
+OBJS = uuid
+INTF = $(foreach obj, $(OBJS),$(obj).cmi)
+LIBS = uuid.cma uuid.cmxa
+
+all: $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+uuid_OBJS = $(OBJS)
+OCAML_NOC_LIBRARY = uuid
+
+.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
+
+include $(TOPLEVEL)/Makefile.rules
+
diff --git a/tools/ocaml/libs/uuid/uuid.ml b/tools/ocaml/libs/uuid/uuid.ml
new file mode 100644
index 0000000..7c25247
--- /dev/null
+++ b/tools/ocaml/libs/uuid/uuid.ml
@@ -0,0 +1,88 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+(** 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
+
+(* 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"
diff --git a/tools/ocaml/libs/uuid/uuid.mli b/tools/ocaml/libs/uuid/uuid.mli
new file mode 100644
index 0000000..3b4a937
--- /dev/null
+++ b/tools/ocaml/libs/uuid/uuid.mli
@@ -0,0 +1,53 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+(** 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
+
+(* 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
diff --git a/tools/ocaml/libs/xb/META.in b/tools/ocaml/libs/xb/META.in
new file mode 100644
index 0000000..c041010
--- /dev/null
+++ b/tools/ocaml/libs/xb/META.in
@@ -0,0 +1,4 @@
+version = "@VERSION@"
+description = "XenBus Interface"
+archive(byte) = "xb.cma"
+archive(native) = "xb.cmxa"
diff --git a/tools/ocaml/libs/xb/Makefile b/tools/ocaml/libs/xb/Makefile
new file mode 100644
index 0000000..56afb4a
--- /dev/null
+++ b/tools/ocaml/libs/xb/Makefile
@@ -0,0 +1,41 @@
+TOPLEVEL=../..
+include $(TOPLEVEL)/common.make
+
+CFLAGS += -I../mmap
+OCAMLINCLUDE += -I ../mmap
+
+.NOTPARALLEL:
+# Ocaml is such a PITA!
+
+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_OCAML_OBJS = $(OBJS) $(PREOJBS)
+
+all: $(PREINTF) $(PRELIBS) $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+xb_OBJS = $(OBJS)
+xb_C_OBJS = xs_ring_stubs xb_stubs
+OCAML_LIBRARY = xb
+
+%.mli: %.ml
+ $(E) " MLI $@"
+ $(Q)$(OCAMLC) -i $< $o
+
+.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
+
+include $(TOPLEVEL)/Makefile.rules
diff --git a/tools/ocaml/libs/xb/op.ml b/tools/ocaml/libs/xb/op.ml
new file mode 100644
index 0000000..6ea8fe6
--- /dev/null
+++ b/tools/ocaml/libs/xb/op.ml
@@ -0,0 +1,84 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+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> *)
+let offset_pq = size
+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"
diff --git a/tools/ocaml/libs/xb/packet.ml b/tools/ocaml/libs/xb/packet.ml
new file mode 100644
index 0000000..74c04bb
--- /dev/null
+++ b/tools/ocaml/libs/xb/packet.ml
@@ -0,0 +1,50 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+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
diff --git a/tools/ocaml/libs/xb/partial.ml b/tools/ocaml/libs/xb/partial.ml
new file mode 100644
index 0000000..3558889
--- /dev/null
+++ b/tools/ocaml/libs/xb/partial.ml
@@ -0,0 +1,44 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+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)
diff --git a/tools/ocaml/libs/xb/xb.ml b/tools/ocaml/libs/xb/xb.ml
new file mode 100644
index 0000000..4d02376
--- /dev/null
+++ b/tools/ocaml/libs/xb/xb.ml
@@ -0,0 +1,189 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+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")
diff --git a/tools/ocaml/libs/xb/xb.mli b/tools/ocaml/libs/xb/xb.mli
new file mode 100644
index 0000000..6cbf0a8
--- /dev/null
+++ b/tools/ocaml/libs/xb/xb.mli
@@ -0,0 +1,83 @@
+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
diff --git a/tools/ocaml/libs/xb/xb_stubs.c b/tools/ocaml/libs/xb/xb_stubs.c
new file mode 100644
index 0000000..b4d1ee6
--- /dev/null
+++ b/tools/ocaml/libs/xb/xb_stubs.c
@@ -0,0 +1,74 @@
+/*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ */
+
+#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_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);
+}
diff --git a/tools/ocaml/libs/xb/xs_ring.ml b/tools/ocaml/libs/xb/xs_ring.ml
new file mode 100644
index 0000000..00c18d5
--- /dev/null
+++ b/tools/ocaml/libs/xb/xs_ring.ml
@@ -0,0 +1,18 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+external read: Mmap.mmap_interface -> string -> int -> int = "ml_interface_read"
+external write: Mmap.mmap_interface -> string -> int -> int = "ml_interface_write"
diff --git a/tools/ocaml/libs/xb/xs_ring_stubs.c b/tools/ocaml/libs/xb/xs_ring_stubs.c
new file mode 100644
index 0000000..9aef23e
--- /dev/null
+++ b/tools/ocaml/libs/xb/xs_ring_stubs.c
@@ -0,0 +1,117 @@
+/*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ */
+
+#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);
+}
diff --git a/tools/ocaml/libs/xc/META.in b/tools/ocaml/libs/xc/META.in
new file mode 100644
index 0000000..e46d7dd
--- /dev/null
+++ b/tools/ocaml/libs/xc/META.in
@@ -0,0 +1,4 @@
+version = "@VERSION@"
+description = "Xen Control Interface"
+archive(byte) = "xc.cma"
+archive(native) = "xc.cmxa"
diff --git a/tools/ocaml/libs/xc/Makefile b/tools/ocaml/libs/xc/Makefile
new file mode 100644
index 0000000..9e361b5
--- /dev/null
+++ b/tools/ocaml/libs/xc/Makefile
@@ -0,0 +1,28 @@
+TOPLEVEL=../..
+include $(TOPLEVEL)/common.make
+
+CFLAGS += -I../mmap -I./
+OCAMLINCLUDE += -I ../mmap -I ../uuid
+
+OBJS = xc
+INTF = xc.cmi
+LIBS = xc.cma xc.cmxa
+
+xc_OBJS = $(OBJS)
+xc_C_OBJS = xc_lib xc_stubs
+
+OCAML_LIBRARY = xc
+
+all: $(INTF) $(LIBS)
+
+libs: $(LIBS)
+
+.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
+
+include $(TOPLEVEL)/Makefile.rules
diff --git a/tools/ocaml/libs/xc/xc.h b/tools/ocaml/libs/xc/xc.h
new file mode 100644
index 0000000..8ef7009
--- /dev/null
+++ b/tools/ocaml/libs/xc/xc.h
@@ -0,0 +1,191 @@
+/*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ */
+
+#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"
+
+typedef xen_domctl_getdomaininfo_t xc_domaininfo_t;
+typedef xen_domctl_getvcpuinfo_t xc_vcpuinfo_t;
+typedef xen_sysctl_physinfo_t xc_physinfo_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_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_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_set_vpt_align(int handle, unsigned int domid, int vpt_align);
+int xc_domain_set_hpet(int handle, unsigned int domid, int hpet);
+int xc_domain_set_timer_mode(int handle, unsigned int domid, int mode);
+int xc_domain_get_acpi_s_state(int handle, unsigned int 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
diff --git a/tools/ocaml/libs/xc/xc.ml b/tools/ocaml/libs/xc/xc.ml
new file mode 100644
index 0000000..b9dd284
--- /dev/null
+++ b/tools/ocaml/libs/xc/xc.ml
@@ -0,0 +1,340 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+(** *)
+type domid = int
+
+(* ** xenctrl.h ** *)
+
+type vcpuinfo =
+{
+ online: bool;
+ blocked: bool;
+ running: bool;
+ cputime: int64;
+ cpumap: int32;
+}
+
+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_cap_flag =
+ | CAP_HVM
+ | CAP_DirectIO
+
+type physinfo =
+{
+ threads_per_core : int;
+ cores_per_socket : int;
+ nr_cpus : int;
+ max_node_id : int;
+ cpu_khz : int;
+ total_pages : nativeint;
+ free_pages : nativeint;
+ scrub_pages : nativeint;
+ (* XXX hw_cap *)
+ capabilities : physinfo_cap_flag list;
+}
+
+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_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_set_timer_mode: handle -> domid -> int -> unit = "stub_xc_domain_set_timer_mode"
+external domain_set_hpet: handle -> domid -> int -> unit = "stub_xc_domain_set_hpet"
+external domain_set_vpt_align: handle -> domid -> int -> unit = "stub_xc_domain_set_vpt_align"
+
+external domain_send_s3resume: handle -> domid -> unit = "stub_xc_domain_send_s3resume"
+external domain_get_acpi_s_state: handle -> domid -> int = "stub_xc_domain_get_acpi_s_state"
+
+(** 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")
diff --git a/tools/ocaml/libs/xc/xc.mli b/tools/ocaml/libs/xc/xc.mli
new file mode 100644
index 0000000..dc55b67
--- /dev/null
+++ b/tools/ocaml/libs/xc/xc.mli
@@ -0,0 +1,196 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+type domid = int
+type vcpuinfo = {
+ online : bool;
+ blocked : bool;
+ running : bool;
+ cputime : int64;
+ cpumap : int32;
+}
+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_cap_flag = CAP_HVM | CAP_DirectIO
+type physinfo = {
+ threads_per_core : int;
+ cores_per_socket : int;
+ nr_cpus : int;
+ max_node_id : int;
+ cpu_khz : int;
+ total_pages : nativeint;
+ free_pages : nativeint;
+ scrub_pages : nativeint;
+ capabilities : physinfo_cap_flag list;
+}
+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_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_set_timer_mode: handle -> domid -> int -> unit = "stub_xc_domain_set_timer_mode"
+external domain_set_hpet: handle -> domid -> int -> unit = "stub_xc_domain_set_hpet"
+external domain_set_vpt_align: handle -> domid -> int -> unit = "stub_xc_domain_set_vpt_align"
+
+external domain_send_s3resume: handle -> domid -> unit
+ = "stub_xc_domain_send_s3resume"
+external domain_get_acpi_s_state: handle -> domid -> int = "stub_xc_domain_get_acpi_s_state"
+
+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_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"
+
diff --git a/tools/ocaml/libs/xc/xc_cpufeature.h b/tools/ocaml/libs/xc/xc_cpufeature.h
new file mode 100644
index 0000000..047a6c9
--- /dev/null
+++ b/tools/ocaml/libs/xc/xc_cpufeature.h
@@ -0,0 +1,116 @@
+#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 */
+#define X86_FEATURE_HYPERVISOR (4*32+31) /* Running under some hypervisor */
+
+/* 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 */
diff --git a/tools/ocaml/libs/xc/xc_cpuid.h b/tools/ocaml/libs/xc/xc_cpuid.h
new file mode 100644
index 0000000..43743ef
--- /dev/null
+++ b/tools/ocaml/libs/xc/xc_cpuid.h
@@ -0,0 +1,285 @@
+#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[2] |= bitmaskof(X86_FEATURE_HYPERVISOR);
+
+ 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_machine_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
diff --git a/tools/ocaml/libs/xc/xc_e820.h b/tools/ocaml/libs/xc/xc_e820.h
new file mode 100644
index 0000000..52bbb0f
--- /dev/null
+++ b/tools/ocaml/libs/xc/xc_e820.h
@@ -0,0 +1,20 @@
+#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__ */
diff --git a/tools/ocaml/libs/xc/xc_lib.c b/tools/ocaml/libs/xc/xc_lib.c
new file mode 100644
index 0000000..7fffc43
--- /dev/null
+++ b/tools/ocaml/libs/xc/xc_lib.c
@@ -0,0 +1,1502 @@
+/*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ */
+
+#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)
+
+int xc_using_injection(void)
+{
+ return 0;
+}
+
+/*---- Trivia ----*/
+int xc_interface_open(void)
+{
+ int fd, ret;
+
+ 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;
+
+ 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)
+{
+ 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)
+{
+ return ioctl(handle, cmd, arg);
+}
+
+static void * do_mmap(void *start, size_t length, int prot, int flags,
+ int fd, off_t 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_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;
+}
+
+#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;
+}
+
+#ifndef HVM_PARAM_HPET_ENABLED
+#define HVM_PARAM_HPET_ENABLED 11
+#endif
+
+#ifndef HVM_PARAM_ACPI_S_STATE
+#define HVM_PARAM_ACPI_S_STATE 14
+#endif
+
+#ifndef HVM_PARAM_VPT_ALIGN
+#define HVM_PARAM_VPT_ALIGN 16
+#endif
+
+int xc_domain_send_s3resume(int handle, unsigned int domid)
+{
+ return xc_set_hvm_param(handle, domid, HVM_PARAM_ACPI_S_STATE, 0);
+}
+
+int xc_domain_set_timer_mode(int handle, unsigned int domid, int mode)
+{
+ return xc_set_hvm_param(handle, domid,
+ HVM_PARAM_TIMER_MODE, (unsigned long) mode);
+}
+
+int xc_domain_set_hpet(int handle, unsigned int domid, int hpet)
+{
+ return xc_set_hvm_param(handle, domid, HVM_PARAM_HPET_ENABLED, (unsigned long) hpet);
+}
+
+int xc_domain_set_vpt_align(int handle, unsigned int domid, int vpt_align)
+{
+ return xc_set_hvm_param(handle, domid, HVM_PARAM_HPET_ENABLED, (unsigned long) vpt_align);
+}
+
+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;
+}
diff --git a/tools/ocaml/libs/xc/xc_stubs.c b/tools/ocaml/libs/xc/xc_stubs.c
new file mode 100644
index 0000000..b43a750
--- /dev/null
+++ b/tools/ocaml/libs/xc/xc_stubs.c
@@ -0,0 +1,1170 @@
+/*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ */
+
+#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_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);
+ CAMLlocal3(physinfo, cap_list, tmp);
+ 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();
+
+ tmp = cap_list = Val_emptylist;
+ for (r = 0; r < 2; r++) {
+ if ((c_physinfo.capabilities >> r) & 1) {
+ tmp = caml_alloc_small(2, Tag_cons);
+ Field(tmp, 0) = Val_int(r);
+ Field(tmp, 1) = cap_list;
+ cap_list = tmp;
+ }
+ }
+
+ physinfo = caml_alloc_tuple(9);
+ Store_field(physinfo, 0, Val_int(c_physinfo.threads_per_core));
+ Store_field(physinfo, 1, Val_int(c_physinfo.cores_per_socket));
+ Store_field(physinfo, 2, Val_int(c_physinfo.nr_cpus));
+ Store_field(physinfo, 3, Val_int(c_physinfo.max_node_id));
+ Store_field(physinfo, 4, Val_int(c_physinfo.cpu_khz));
+ Store_field(physinfo, 5, caml_copy_nativeint(c_physinfo.total_pages));
+ Store_field(physinfo, 6, caml_copy_nativeint(c_physinfo.free_pages));
+ Store_field(physinfo, 7, caml_copy_nativeint(c_physinfo.scrub_pages));
+ Store_field(physinfo, 8, cap_list);
+
+ 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_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_domain_set_timer_mode(value handle, value id, value mode)
+{
+ CAMLparam3(handle, id, mode);
+ int ret;
+
+ ret = xc_domain_set_timer_mode(_H(handle), _D(id), Int_val(mode));
+ if (ret < 0)
+ failwith_xc();
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_set_hpet(value handle, value id, value mode)
+{
+ CAMLparam3(handle, id, mode);
+ int ret;
+
+ ret = xc_domain_set_hpet(_H(handle), _D(id), Int_val(mode));
+ if (ret < 0)
+ failwith_xc();
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_domain_set_vpt_align(value handle, value id, value mode)
+{
+ CAMLparam3(handle, id, mode);
+ int ret;
+
+ ret = xc_domain_set_vpt_align(_H(handle), _D(id), Int_val(mode));
+ if (ret < 0)
+ failwith_xc();
+ CAMLreturn(Val_unit);
+}
+
+CAMLprim value stub_xc_watchdog(value handle, value domid, value timeout)
+{
+ CAMLparam3(handle, domid, timeout);
+ int ret;
+ unsigned int c_timeout = Int32_val(timeout);
+
+ ret = xc_domain_watchdog(_H(handle), _D(domid), c_timeout);
+ 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);
+}
+
+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));
+}
+
+/*
+ * Local variables:
+ * indent-tabs-mode: t
+ * c-basic-offset: 8
+ * tab-width: 8
+ * End:
+ */
diff --git a/tools/ocaml/libs/xs/META.in b/tools/ocaml/libs/xs/META.in
new file mode 100644
index 0000000..77d93b5
--- /dev/null
+++ b/tools/ocaml/libs/xs/META.in
@@ -0,0 +1,4 @@
+version = "@VERSION@"
+description = "XenStore Interface"
+archive(byte) = "xs.cma"
+archive(native) = "xs.cmxa"
diff --git a/tools/ocaml/libs/xs/Makefile b/tools/ocaml/libs/xs/Makefile
new file mode 100644
index 0000000..87cd375
--- /dev/null
+++ b/tools/ocaml/libs/xs/Makefile
@@ -0,0 +1,42 @@
+TOPLEVEL=../..
+include $(TOPLEVEL)/common.make
+
+OCAMLINCLUDE += -I ../xb/
+
+.NOTPARALLEL:
+# Ocaml is such a PITA!
+
+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_OBJS = $(OBJS)
+OCAML_NOC_LIBRARY = xs
+
+#xs.cmxa: $(foreach obj,$(OBJS),$(obj).cmx)
+# $(E) " MLLIB $@"
+# $(Q)$(OCAMLOPT) $(OCAMLOPTFLAGS) -a -o $@ $(foreach obj,$(OBJS),$(obj).cmx)
+#
+#xs.cma: $(foreach obj,$(OBJS),$(obj).cmo)
+# $(E) " MLLIB $@"
+# $(Q)$(OCAMLC) -a -o $@ $(foreach obj,$(OBJS),$(obj).cmo)
+
+.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
+
+include $(TOPLEVEL)/Makefile.rules
+
diff --git a/tools/ocaml/libs/xs/queueop.ml b/tools/ocaml/libs/xs/queueop.ml
new file mode 100644
index 0000000..cb298f5
--- /dev/null
+++ b/tools/ocaml/libs/xs/queueop.ml
@@ -0,0 +1,73 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+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)
diff --git a/tools/ocaml/libs/xs/xs.ml b/tools/ocaml/libs/xs/xs.ml
new file mode 100644
index 0000000..768778f
--- /dev/null
+++ b/tools/ocaml/libs/xs/xs.ml
@@ -0,0 +1,170 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+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
diff --git a/tools/ocaml/libs/xs/xs.mli b/tools/ocaml/libs/xs/xs.mli
new file mode 100644
index 0000000..ce505b6
--- /dev/null
+++ b/tools/ocaml/libs/xs/xs.mli
@@ -0,0 +1,90 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+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
diff --git a/tools/ocaml/libs/xs/xsraw.ml b/tools/ocaml/libs/xs/xsraw.ml
new file mode 100644
index 0000000..370d38e
--- /dev/null
+++ b/tools/ocaml/libs/xs/xsraw.ml
@@ -0,0 +1,265 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+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
diff --git a/tools/ocaml/libs/xs/xsraw.mli b/tools/ocaml/libs/xs/xsraw.mli
new file mode 100644
index 0000000..42f87b6
--- /dev/null
+++ b/tools/ocaml/libs/xs/xsraw.mli
@@ -0,0 +1,60 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+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
diff --git a/tools/ocaml/libs/xs/xst.ml b/tools/ocaml/libs/xs/xst.ml
new file mode 100644
index 0000000..16affd2
--- /dev/null
+++ b/tools/ocaml/libs/xs/xst.ml
@@ -0,0 +1,61 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+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
diff --git a/tools/ocaml/libs/xs/xst.mli b/tools/ocaml/libs/xs/xst.mli
new file mode 100644
index 0000000..5ae5604
--- /dev/null
+++ b/tools/ocaml/libs/xs/xst.mli
@@ -0,0 +1,30 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008 Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program 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; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU Lesser General Public License for more details.
+ *)
+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
[-- Attachment #3: Type: text/plain, Size: 138 bytes --]
_______________________________________________
Xen-devel mailing list
Xen-devel@lists.xensource.com
http://lists.xensource.com/xen-devel
^ permalink raw reply related [flat|nested] 7+ messages in thread